Pass Typed Jerboa options as handles
ober
34be27f2aa2644c8ac6a51fddea42438f0a5b915
--- a/docs/jerboa-to-rust.md +++ b/docs/jerboa-to-rust.md @@ -632,9 +632,11 @@ Second module: typed `rope`. argument wrappers landed. Same-module record and variant values now cross the wrapper boundary as opaque handles. `String` and `Bytes` returns now cross through generated byte buffer ownership helpers. Generated wrappers can - explicitly drop typed handles. Option, result, automatic handle finalization, - and richer handle conversions remain future work. Boundary tests now cover - stale handle use after drop and double-drop rejection. + 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. ### Milestone 3: Records and Variants --- a/docs/typed-jerboa.md +++ b/docs/typed-jerboa.md @@ -188,7 +188,7 @@ 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. + double-drop rejection, 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 @@ -213,7 +213,9 @@ Current landing: constructors in the front end: `(option-some expr)`, `(option-none Type)`, `(result-ok expr ErrorType)`, and `(result-err ValueType expr)`. Rust lowering maps them to `Some`, `None`, `Ok`, and `Err` without treating type - operands as runtime values. + operands as runtime values. Exported Option/Result values cross the current + Jerboa FFI boundary as opaque typed handles; direct conversion to idiomatic + Scheme option/result values remains future work. - The current Rust lowering uses a conservative Clone-only ownership model: generated constructors, ordinary calls, and recursive match rebinding clone owned values so recursive branch code can pass the same child value to more @@ -912,9 +914,9 @@ Minimum excluded features: movement and borrowing rules are not enforced yet. Owned-to-Borrow calls are allowed before the owner moves and rejected after it moves. - Model FFI handles. The current generated wrapper layer models same-module - record and variant handles as tagged opaque values, exposes explicit handle - drops, clears dropped handle ids, and has boundary tests for stale use and - double-close rejection. + 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. ### Milestone 6: LLVM Prototype --- a/lib/jerboa/typed/rust.ss +++ b/lib/jerboa/typed/rust.ss @@ -330,11 +330,20 @@ (memq type '(Unit Bool Char Int Nat Fixnum Float)) #t)) + (def (abi-option-result-handle-type? type) + (and (pair? type) + (or (and (eq? (car type) 'Option) + (= (length type) 2)) + (and (eq? (car type) 'Result) + (= (length type) 3))))) + (def (abi-handle-type? type) - (and (symbol? type) - (or (lookup-name type (*rust-record-env*)) - (lookup-name type (*rust-variant-env*))) - #t)) + (or + (and (symbol? type) + (or (lookup-name type (*rust-record-env*)) + (lookup-name type (*rust-variant-env*))) + #t) + (abi-option-result-handle-type? type))) (def (abi-return-buffer-type? type) (and (symbol? type) --- a/lib/jerboa/typed/wrapper.ss +++ b/lib/jerboa/typed/wrapper.ss @@ -91,18 +91,27 @@ (and (memq (typed-def-name def) (typed-module-exports module)) #t)) + (def (option-result-handle-type? type) + (and (pair? type) + (or (and (eq? (car type) 'Option) + (= (length type) 2)) + (and (eq? (car type) 'Result) + (= (length type) 3))))) + (def (module-handle-type? module type) - (and (symbol? type) - (let loop ([decls (typed-module-declarations module)]) - (cond - [(null? decls) #f] - [(and (typed-record? (car decls)) - (eq? type (typed-record-name (car decls)))) - #t] - [(and (typed-variant? (car decls)) - (eq? type (typed-variant-name (car decls)))) - #t] - [else (loop (cdr decls))])))) + (or + (option-result-handle-type? type) + (and (symbol? type) + (let loop ([decls (typed-module-declarations module)]) + (cond + [(null? decls) #f] + [(and (typed-record? (car decls)) + (eq? type (typed-record-name (car decls)))) + #t] + [(and (typed-variant? (car decls)) + (eq? type (typed-variant-name (car decls)))) + #t] + [else (loop (cdr decls))]))))) (def (abi-wrapper-scalar-type? type) (and (symbol? type) @@ -411,7 +420,7 @@ (write-line port 1 "(and (vector? value)") (write-line port 2 "(= (vector-length value) 3)") (write-line port 2 "(eq? (vector-ref value 0) 'typed-handle)") - (write-line port 2 "(eq? (vector-ref value 1) type)") + (write-line port 2 "(equal? (vector-ref value 1) type)") (write-line port 2 "(%typed-rust-handle-id-valid? (vector-ref value 2))))") (newline port) (write-line port 0 "(def (%typed-rust-handle-id value)") --- a/tests/fixtures/typed/rust-basic.ss +++ b/tests/fixtures/typed/rust-basic.ss @@ -1,6 +1,7 @@ (typed-library (sample typed rust-basic) (export zero add-one positive? choose greeting echo-text double-add text-length - bytes-length echo-bytes make-box box-value make-some token-size) + bytes-length echo-bytes make-box box-value make-some token-size + maybe-value echo-maybe ok-value err-value echo-result) (record Box ((value : Nat))) @@ -52,4 +53,19 @@ (def (token-size (token : Token)) : Nat (match token ((Some value) value) - ((Empty) 0)))) + ((Empty) 0))) + + (def (maybe-value (x : Nat)) : (Option Nat) + (option-some x)) + + (def (echo-maybe (maybe : (Option Nat))) : (Option Nat) + maybe) + + (def (ok-value (x : Nat)) : (Result Nat String) + (result-ok x String)) + + (def (err-value (message : String)) : (Result Nat String) + (result-err Nat message)) + + (def (echo-result (r : (Result Nat String))) : (Result Nat String) + r)) --- a/tests/test-typed-rust.ss +++ b/tests/test-typed-rust.ss @@ -171,15 +171,19 @@ (define option-result-form '(typed-library (sample typed option-result) - (export maybe-value none-text ok-value err-value) + (export maybe-value none-text echo-maybe ok-value err-value echo-result) (def (maybe-value (x : Nat)) : (Option Nat) (option-some x)) (def (none-text) : (Option String) (option-none String)) + (def (echo-maybe (maybe : (Option Nat))) : (Option Nat) + maybe) (def (ok-value (x : Nat)) : (Result Nat String) (result-ok x String)) (def (err-value (message : String)) : (Result Nat String) - (result-err Nat message)))) + (result-err Nat message)) + (def (echo-result (r : (Result Nat String))) : (Result Nat String) + r))) (define option-result-rust (typed-library-form->rust-string option-result-form)) @@ -290,6 +294,18 @@ (substring? option-result-rust "Err((message).clone())")) #t) +(test "rust emits option and result handle ABI wrappers" + (and (substring? option-result-rust "fn jt_store_handle<T: Any + Send>(value: T) -> u64") + (substring? option-result-rust "pub extern \"C\" fn jt_sample_typed_option_result_maybe_value(x: u64) -> u64") + (substring? option-result-rust "jt_store_handle(maybe_value(x))") + (substring? option-result-rust "pub extern \"C\" fn jt_sample_typed_option_result_echo_maybe(maybe_handle: u64) -> u64") + (substring? option-result-rust "let maybe = jt_clone_handle::<Option<u64>>(maybe_handle).unwrap_or_else(|| panic!(\"invalid typed handle\"));") + (substring? option-result-rust "jt_store_handle(echo_maybe(maybe))") + (substring? option-result-rust "pub extern \"C\" fn jt_sample_typed_option_result_echo_result(r_handle: u64) -> u64") + (substring? option-result-rust "let r = jt_clone_handle::<Result<u64, String>>(r_handle).unwrap_or_else(|| panic!(\"invalid typed handle\"));") + (substring? option-result-rust "jt_store_handle(echo_result(r))")) + #t) + (printf "~%Typed Rust emitter: ~a passed, ~a failed~%" pass fail) (when (> fail 0) (exit 1)) --- a/tests/test-typed-wrapper-e2e.ss +++ b/tests/test-typed-wrapper-e2e.ss @@ -61,6 +61,28 @@ (check "variant handle round trip" (= (token-size (make-some 23)) 23)) +(define maybe-handle (maybe-value 29)) +(check "option handle return" + (%typed-rust-handle? maybe-handle '(Option Nat))) +(define maybe-roundtrip (echo-maybe maybe-handle)) +(check "option handle round trip" + (%typed-rust-handle? maybe-roundtrip '(Option Nat))) + +(define ok-handle (ok-value 37)) +(check "result ok handle return" + (%typed-rust-handle? ok-handle '(Result Nat String))) +(define err-handle (err-value "bad")) +(check "result err handle return" + (%typed-rust-handle? err-handle '(Result Nat String))) +(define result-roundtrip (echo-result ok-handle)) +(check "result handle round trip" + (%typed-rust-handle? result-roundtrip '(Result Nat String))) + +(check "option handle rejects result" + (raises? (lambda () (echo-maybe ok-handle)))) +(check "result handle rejects option" + (raises? (lambda () (echo-result maybe-handle)))) + (define dropped-box (make-box 31)) (check "handle drop" (%typed-rust-handle-drop! dropped-box)) @@ -86,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")))) +(check "option and result handle drops" + (and (%typed-rust-handle-drop! maybe-handle) + (%typed-rust-handle-drop! maybe-roundtrip) + (%typed-rust-handle-drop! ok-handle) + (%typed-rust-handle-drop! err-handle) + (%typed-rust-handle-drop! result-roundtrip))) (printf "~%Typed wrapper FFI smoke: ~a passed, ~a failed~%" pass fail) (when (> fail 0) --- a/tests/test-typed-wrappers.ss +++ b/tests/test-typed-wrappers.ss @@ -40,7 +40,7 @@ (+ x 1)))) (define calc-wrapper - ";; Generated by Jerboa's typed wrapper backend. Do not edit.\n(import (jerboa prelude)\n (only (chezscheme) foreign-procedure getenv load-shared-object))\n\n(def %typed-rust-library-path (getenv \"JERBOA_TYPED_RUST_LIB\"))\n(when %typed-rust-library-path\n (load-shared-object %typed-rust-library-path))\n\n(def %typed-rust-min-int64 -9223372036854775808)\n(def %typed-rust-max-int64 9223372036854775807)\n(def %typed-rust-max-uint64 18446744073709551615)\n\n(def (%typed-rust-int64? x)\n (and (integer? x)\n (exact? x)\n (<= %typed-rust-min-int64 x %typed-rust-max-int64)))\n\n(def (%typed-rust-uint64? x)\n (and (integer? x)\n (exact? x)\n (<= 0 x %typed-rust-max-uint64)))\n\n(def (%typed-rust-handle-id-valid? id)\n (and (%typed-rust-uint64? id)\n (> id 0)))\n\n(def (%typed-rust-make-handle type id)\n (unless (%typed-rust-handle-id-valid? id)\n (error '%typed-rust-make-handle \"typed Rust returned invalid handle\" type id))\n (vector 'typed-handle type id))\n\n(def (%typed-rust-handle? value type)\n (and (vector? value)\n (= (vector-length value) 3)\n (eq? (vector-ref value 0) 'typed-handle)\n (eq? (vector-ref value 1) type)\n (%typed-rust-handle-id-valid? (vector-ref value 2))))\n\n(def (%typed-rust-handle-id value)\n (vector-ref value 2))\n\n(def %zero\n (foreign-procedure \"jt_sample_typed_calc_zero\" () unsigned-64))\n\n(def %add_one\n (foreign-procedure \"jt_sample_typed_calc_add_one\" (unsigned-64) unsigned-64))\n\n(def (zero)\n (%zero)\n)\n\n(def (add-one x)\n (unless (%typed-rust-uint64? x)\n (error 'add-one \"expected Nat for x\" x))\n (%add_one x)\n)\n\n") + ";; Generated by Jerboa's typed wrapper backend. Do not edit.\n(import (jerboa prelude)\n (only (chezscheme) foreign-procedure getenv load-shared-object))\n\n(def %typed-rust-library-path (getenv \"JERBOA_TYPED_RUST_LIB\"))\n(when %typed-rust-library-path\n (load-shared-object %typed-rust-library-path))\n\n(def %typed-rust-min-int64 -9223372036854775808)\n(def %typed-rust-max-int64 9223372036854775807)\n(def %typed-rust-max-uint64 18446744073709551615)\n\n(def (%typed-rust-int64? x)\n (and (integer? x)\n (exact? x)\n (<= %typed-rust-min-int64 x %typed-rust-max-int64)))\n\n(def (%typed-rust-uint64? x)\n (and (integer? x)\n (exact? x)\n (<= 0 x %typed-rust-max-uint64)))\n\n(def (%typed-rust-handle-id-valid? id)\n (and (%typed-rust-uint64? id)\n (> id 0)))\n\n(def (%typed-rust-make-handle type id)\n (unless (%typed-rust-handle-id-valid? id)\n (error '%typed-rust-make-handle \"typed Rust returned invalid handle\" type id))\n (vector 'typed-handle type id))\n\n(def (%typed-rust-handle? value type)\n (and (vector? value)\n (= (vector-length value) 3)\n (eq? (vector-ref value 0) 'typed-handle)\n (equal? (vector-ref value 1) type)\n (%typed-rust-handle-id-valid? (vector-ref value 2))))\n\n(def (%typed-rust-handle-id value)\n (vector-ref value 2))\n\n(def %zero\n (foreign-procedure \"jt_sample_typed_calc_zero\" () unsigned-64))\n\n(def %add_one\n (foreign-procedure \"jt_sample_typed_calc_add_one\" (unsigned-64) unsigned-64))\n\n(def (zero)\n (%zero)\n)\n\n(def (add-one x)\n (unless (%typed-rust-uint64? x)\n (error 'add-one \"expected Nat for x\" x))\n (%add_one x)\n)\n\n") (define string-form '(typed-library (sample typed text) @@ -95,6 +95,23 @@ (define handle-wrapper (typed-library-form->jerboa-wrapper-string handle-form)) +(define option-result-form + '(typed-library (sample typed option-result) + (export maybe-value echo-maybe ok-value err-value echo-result) + (def (maybe-value (x : Nat)) : (Option Nat) + (option-some x)) + (def (echo-maybe (maybe : (Option Nat))) : (Option Nat) + maybe) + (def (ok-value (x : Nat)) : (Result Nat String) + (result-ok x String)) + (def (err-value (message : String)) : (Result Nat String) + (result-err Nat message)) + (def (echo-result (r : (Result Nat String))) : (Result Nat String) + r))) + +(define option-result-wrapper + (typed-library-form->jerboa-wrapper-string option-result-form)) + (printf "--- Typed Jerboa wrapper tests ---~%") (test "wrapper maps Unit to void" @@ -213,6 +230,28 @@ "(%typed-rust-handle-id-valid? (vector-ref value 2))")) #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)") + (substring? option-result-wrapper + "(%typed-rust-make-handle '(Option Nat) (%maybe_value x))") + (substring? option-result-wrapper + "(%typed-rust-make-handle '(Result Nat String) (%ok_value x))") + (substring? option-result-wrapper + "(%typed-rust-make-handle '(Result Nat String) (%err_value %message_bytes (bytevector-length %message_bytes)))")) + #t) + +(test "wrapper passes option and result handle parameters" + (and (substring? option-result-wrapper + "(unless (%typed-rust-handle? maybe '(Option Nat))") + (substring? option-result-wrapper + "(%echo_maybe (%typed-rust-handle-id maybe))") + (substring? option-result-wrapper + "(unless (%typed-rust-handle? r '(Result Nat String))") + (substring? option-result-wrapper + "(%echo_result (%typed-rust-handle-id r))")) + #t) + (printf "~%Typed wrapper: ~a passed, ~a failed~%" pass fail) (when (> fail 0) (exit 1))