Lower (Option Buffer) directly across the Typed Jerboa boundary
ober
535bc349856305fbf03a3be28dce47cd96eb24d9
--- a/docs/typed-jerboa.md +++ b/docs/typed-jerboa.md @@ -305,9 +305,12 @@ Highest-value next steps: the raw scalar value. `(Result <Scalar> <Scalar>)` follows the same pattern: returns lower to `u8` (1 = Ok, 0 = Err) plus two `*mut` out-pointers, and params lower to `u8` tag plus the raw ok/err scalar values; the wrapper - surfaces `(cons 'ok V)` / `(cons 'err E)`. `(Option <non-scalar>)` and - `(Result <*> <*>)` with any non-scalar inner still cross as opaque handles; - direct conversion for those remains open. + surfaces `(cons 'ok V)` / `(cons 'err E)`. `(Option String)` and + `(Option Bytes)` cross directly too: returns reuse the ptr/len byte-buffer + pattern with a `bool` status (1 = Some, 0 = None), and params lower to a + `u8` tag plus a raw bytes pointer and length. `(Result <*> <*>)` with any + non-scalar inner still crosses as an opaque handle; direct conversion for + `(Result <buffer> <*>)` and `(Result <*> <buffer>)` remains open. 4. Make resource lowering borrow-aware. The checker has straight-line owned move rules, but the Rust backend still uses a conservative Clone-heavy model and does not use resource `#:close` hooks for generated `Drop`. --- a/lib/jerboa/typed/rust.ss +++ b/lib/jerboa/typed/rust.ss @@ -356,6 +356,17 @@ (abi-safe-type? (caddr type)) (not (eq? (caddr type) 'Unit)))) + (def (abi-buffer-type? type) + (and (symbol? type) + (memq type '(String Bytes)) + #t)) + + (def (abi-option-buffer-type? type) + (and (pair? type) + (eq? (car type) 'Option) + (= (length type) 2) + (abi-buffer-type? (cadr type)))) + (def (abi-handle-type? type) (or (and (symbol? type) @@ -364,6 +375,7 @@ #t) (and (abi-option-result-handle-type? type) (not (abi-option-scalar-type? type)) + (not (abi-option-buffer-type? type)) (not (abi-result-scalar-scalar-type? type))))) (def (abi-return-buffer-type? type) @@ -376,6 +388,7 @@ (abi-handle-type? type) (abi-return-buffer-type? type) (abi-option-scalar-type? type) + (abi-option-buffer-type? type) (abi-result-scalar-scalar-type? type))) (def (abi-safe-param-type? type) @@ -383,6 +396,7 @@ (memq type '(String Bytes)) (abi-handle-type? type) (abi-option-scalar-type? type) + (abi-option-buffer-type? type) (abi-result-scalar-scalar-type? type))) (def (abi-rust-type type) @@ -441,6 +455,11 @@ (string-append name "_tag: u8") (string-append name "_ok: " (abi-rust-type (cadr type))) (string-append name "_err: " (abi-rust-type (caddr type))))] + [(abi-option-buffer-type? type) + (list + (string-append name "_tag: u8") + (string-append name "_ptr: *const u8") + (string-append name "_len: usize"))] [(abi-handle-type? type) (list (string-append name "_handle: u64"))] [else @@ -540,7 +559,8 @@ [(and (typed-def? (car decls)) (exported-def? module (car decls)) (abi-safe-def? (car decls)) - (abi-return-buffer-type? (typed-def-return-type (car decls)))) + (or (abi-return-buffer-type? (typed-def-return-type (car decls))) + (abi-option-buffer-type? (typed-def-return-type (car decls))))) #t] [else (loop (cdr decls))]))) @@ -641,6 +661,28 @@ " } else { " err-expr " };")))] + [(abi-option-buffer-type? type) + (let ([inner (cadr type)]) + (write-line port 2 + (string-append "let " name " = if " name "_tag != 0 {")) + (write-line port 3 + (string-append "let bytes: &[u8] = if " name "_ptr.is_null() {")) + (write-line port 4 "&[]") + (write-line port 3 "} else {") + (write-line port 4 + "// unsafe: pointer and length are produced by the generated Jerboa wrapper.") + (write-line port 4 + (string-append + "unsafe { std::slice::from_raw_parts(" + name "_ptr, " name "_len) }")) + (write-line port 3 "};") + (write-line port 3 + (if (eq? inner 'String) + "Some(String::from_utf8_lossy(bytes).into_owned())" + "Some(bytes.to_vec())")) + (write-line port 2 "} else {") + (write-line port 3 "None") + (write-line port 2 "};"))] [(abi-handle-type? type) (write-line port 2 (string-append @@ -688,6 +730,7 @@ [return-type (typed-def-return-type def)] [return-buffer? (abi-return-buffer-type? return-type)] [return-option-scalar? (abi-option-scalar-type? return-type)] + [return-option-buffer? (abi-option-buffer-type? return-type)] [return-result-scalar-scalar? (abi-result-scalar-scalar-type? return-type)] [param-names (map (lambda (param) @@ -705,6 +748,8 @@ (cond [return-buffer? '("out_ptr: *mut *mut u8" "out_len: *mut usize")] + [return-option-buffer? + '("out_ptr: *mut *mut u8" "out_len: *mut usize")] [return-option-scalar? (list (string-append @@ -723,6 +768,7 @@ (cond [return-buffer? "bool"] [return-option-scalar? "bool"] + [return-option-buffer? "bool"] [return-result-scalar-scalar? "u8"] [else (abi-rust-type return-type)])]) (write-line port 0 "#[unsafe(no_mangle)]") @@ -744,6 +790,15 @@ (cond [return-buffer? (write-line port 2 (abi-return-buffer-expression def call))] + [return-option-buffer? + (let ([inner (cadr return-type)]) + (write-line port 2 (string-append "match " call " {")) + (write-line port 3 + (if (eq? inner 'String) + "Some(value) => jt_return_bytes(value.into_bytes(), out_ptr, out_len)," + "Some(value) => jt_return_bytes(value, out_ptr, out_len),")) + (write-line port 3 "None => false,") + (write-line port 2 "}"))] [return-option-scalar? (let ([inner (cadr return-type)]) (write-line port 2 (string-append "match " call " {")) @@ -778,6 +833,7 @@ "Err(_) => " (cond [return-buffer? "false"] + [return-option-buffer? "false"] [return-option-scalar? "false"] [return-result-scalar-scalar? "0u8"] [else (abi-default-expression return-type)]) --- a/lib/jerboa/typed/wrapper.ss +++ b/lib/jerboa/typed/wrapper.ss @@ -119,10 +119,22 @@ (abi-wrapper-scalar-type? (caddr type)) (not (eq? (caddr type) 'Unit)))) + (def (buffer-type? type) + (and (symbol? type) + (memq type '(String Bytes)) + #t)) + + (def (option-buffer-type? type) + (and (pair? type) + (eq? (car type) 'Option) + (= (length type) 2) + (buffer-type? (cadr type)))) + (def (module-handle-type? module type) (or (and (option-result-handle-type? type) (not (option-scalar-type? type)) + (not (option-buffer-type? type)) (not (result-scalar-scalar-type? type))) (and (symbol? type) (let loop ([decls (typed-module-declarations module)]) @@ -146,6 +158,7 @@ (module-handle-type? module type) (abi-wrapper-return-buffer-type? type) (option-scalar-type? type) + (option-buffer-type? type) (result-scalar-scalar-type? type))) (def (wrapper-safe-param-type? module type) @@ -153,6 +166,7 @@ (memq type '(String Bytes)) (module-handle-type? module type) (option-scalar-type? type) + (option-buffer-type? type) (result-scalar-scalar-type? type))) (def (wrapper-safe-def? module def) @@ -168,6 +182,7 @@ (cond [(abi-wrapper-return-buffer-type? type) 'boolean] [(option-scalar-type? type) 'boolean] + [(option-buffer-type? type) 'boolean] [(result-scalar-scalar-type? type) 'unsigned-8] [(module-handle-type? module type) 'unsigned-64] [else (abi-chez-type type)])) @@ -177,6 +192,8 @@ [(memq type '(String Bytes)) '(u8* size_t)] [(option-scalar-type? type) (list 'unsigned-8 (abi-chez-type (cadr type)))] + [(option-buffer-type? type) + '(unsigned-8 u8* size_t)] [(result-scalar-scalar-type? type) (list 'unsigned-8 (abi-chez-type (cadr type)) @@ -198,7 +215,9 @@ (let loop ([defs (wrapper-defs module)]) (cond [(null? defs) #f] - [(abi-wrapper-return-buffer-type? (typed-def-return-type (car defs))) #t] + [(or (abi-wrapper-return-buffer-type? (typed-def-return-type (car defs))) + (option-buffer-type? (typed-def-return-type (car defs)))) + #t] [else (loop (cdr defs))]))) (def (def-uses-handle? module def) @@ -232,12 +251,21 @@ [(result-scalar-scalar-type? (typed-param-type (car params))) #t] [else (loop (cdr params))])))) + (def (def-uses-option-buffer? def) + (or (option-buffer-type? (typed-def-return-type def)) + (let loop ([params (typed-def-params def)]) + (cond + [(null? params) #f] + [(option-buffer-type? (typed-param-type (car params))) #t] + [else (loop (cdr params))])))) + (def (module-needs-option-scalar-runtime? module) (let loop ([defs (wrapper-defs module)]) (cond [(null? defs) #f] [(def-uses-option-scalar? (car defs)) #t] [(def-uses-result-scalar-scalar? (car defs)) #t] + [(def-uses-option-buffer? (car defs)) #t] [else (loop (cdr defs))]))) (def (chez-foreign-size-name type) @@ -323,6 +351,12 @@ [(Float) (string-append "(real? " name ")")] [else (error 'typed-wrapper "unsupported scalar inner" inner)])) + (def (buffer-check-expression inner name) + (case inner + [(String) (string-append "(string? " name ")")] + [(Bytes) (string-append "(bytevector? " name ")")] + [else (error 'typed-wrapper "unsupported buffer inner" inner)])) + (def (param-check-expression module param) (let ([name (datum->code (typed-param-name param))] [type (typed-param-type param)]) @@ -340,6 +374,11 @@ "(or (eq? " name " #f) (and (pair? " name ") (eq? (car " name ") 'some) " (scalar-check-expression (cadr type) (string-append "(cdr " name ")")) "))")] + [(option-buffer-type? type) + (string-append + "(or (eq? " name " #f) (and (pair? " name ") (eq? (car " name ") 'some) " + (buffer-check-expression (cadr type) (string-append "(cdr " name ")")) + "))")] [(result-scalar-scalar-type? type) (string-append "(and (pair? " name ") " @@ -385,13 +424,37 @@ (def (string-param? param) (eq? (typed-param-type param) 'String)) - (def (has-string-param? params) + (def (option-buffer-param? param) + (option-buffer-type? (typed-param-type param))) + + (def (needs-prelude-binding? param) + (or (string-param? param) (option-buffer-param? param))) + + (def (has-prelude-binding? params) (let loop ([rest params]) (cond [(null? rest) #f] - [(string-param? (car rest)) #t] + [(needs-prelude-binding? (car rest)) #t] [else (loop (cdr rest))]))) + (def (prelude-binding-expression param) + (let ([name (datum->code (typed-param-name param))] + [type (typed-param-type param)]) + (cond + [(string-param? param) + (string-append "(string->utf8 " name ")")] + [(option-buffer-param? param) + (let ([inner (cadr type)]) + (case inner + [(String) + (string-append "(if " name " (string->utf8 (cdr " name ")) #vu8())")] + [(Bytes) + (string-append "(if " name " (cdr " name ") #vu8())")] + [else + (error 'typed-wrapper "unsupported option-buffer inner" inner)]))] + [else + (error 'typed-wrapper "no prelude binding for param" param)]))) + (def (wrapper-argument-expressions module param) (let ([name (datum->code (typed-param-name param))] [type (typed-param-type param)]) @@ -415,6 +478,12 @@ " " (option-scalar-default-value (cadr type)) ")"))] + [(option-buffer-type? type) + (let ([bytes-name (datum->code (string-bytes-name param))]) + (list + (string-append "(if " name " 1 0)") + bytes-name + (string-append "(bytevector-length " bytes-name ")")))] [(result-scalar-scalar-type? type) (let* ([ok-inner (cadr type)] [err-inner (caddr type)] @@ -494,6 +563,25 @@ ")" " #f))" " (lambda () (foreign-free %out))))"))] + [(option-buffer-type? return-type) + (let* ([inner (cadr return-type)] + [decode-bytes "(%typed-rust-take-byte-buffer (foreign-ref 'void* %ptr_box 0) (foreign-ref 'size_t %len_box 0))"] + [decoded (if (eq? inner 'String) + (string-append "(utf8->string " decode-bytes ")") + decode-bytes)]) + (string-append + "(let ([%ptr_box (foreign-alloc (foreign-sizeof 'void*))]" + " [%len_box (foreign-alloc (foreign-sizeof 'size_t))])" + " (dynamic-wind" + " (lambda () #f)" + " (lambda ()" + " (foreign-set! 'void* %ptr_box 0 0)" + " (foreign-set! 'size_t %len_box 0 0)" + " (if " + (wrapper-call-expression* module def '("%ptr_box" "%len_box")) + " (cons 'some " decoded ")" + " #f))" + " (lambda () (foreign-free %ptr_box) (foreign-free %len_box))))"))] [(result-scalar-scalar-type? return-type) (let* ([ok-inner (cadr return-type)] [err-inner (caddr return-type)] @@ -547,6 +635,7 @@ (cond [(abi-wrapper-return-buffer-type? return-type) '("void*" "void*")] [(option-scalar-type? return-type) '("void*")] + [(option-buffer-type? return-type) '("void*" "void*")] [(result-scalar-scalar-type? return-type) '("void*" "void*")] [else '()])) " ") @@ -575,7 +664,7 @@ (lambda (param) (emit-param-check module def param port)) params) - (if (has-string-param? params) + (if (has-prelude-binding? params) (begin (write-line port 1 (string-append @@ -586,13 +675,13 @@ (string-append "[" (datum->code (string-bytes-name param)) - " (string->utf8 " - (datum->code (typed-param-name param)) - ")]")) + " " + (prelude-binding-expression param) + "]")) (let loop ([rest params] [out '()]) (cond [(null? rest) (reverse out)] - [(string-param? (car rest)) + [(needs-prelude-binding? (car rest)) (loop (cdr rest) (cons (car rest) out))] [else (loop (cdr rest) out)]))) " ") --- a/tests/fixtures/typed/rust-basic.ss +++ b/tests/fixtures/typed/rust-basic.ss @@ -2,7 +2,7 @@ (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 token-debug maybe-value echo-maybe ok-value err-value echo-result - only-pos echo-only-pos) + only-pos echo-only-pos maybe-text echo-maybe-text echo-maybe-bytes) (record Box ((value : Nat))) @@ -80,4 +80,15 @@ (result-err Nat #f))) (def (echo-only-pos (r : (Result Nat Bool))) : (Result Nat Bool) - r)) + r) + + (def (maybe-text (n : Nat)) : (Option String) + (if (> n 0) + (option-some (debug-string n)) + (option-none String))) + + (def (echo-maybe-text (m : (Option String))) : (Option String) + m) + + (def (echo-maybe-bytes (m : (Option Bytes))) : (Option Bytes) + m)) --- a/tests/test-typed-rust.ss +++ b/tests/test-typed-rust.ss @@ -171,11 +171,18 @@ (define option-result-form '(typed-library (sample typed option-result) - (export maybe-value none-text echo-maybe ok-value err-value echo-result) + (export maybe-value maybe-text echo-maybe-text echo-maybe-bytes 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 (maybe-text (x : Nat)) : (Option String) + (if (> x 0) + (option-some (debug-string x)) + (option-none String))) + (def (echo-maybe-text (m : (Option String))) : (Option String) + m) + (def (echo-maybe-bytes (m : (Option Bytes))) : (Option Bytes) + m) (def (echo-maybe (maybe : (Option Nat))) : (Option Nat) maybe) (def (ok-value (x : Nat)) : (Result Nat String) @@ -302,7 +309,7 @@ (test "rust lowers option and result constructors" (and (substring? option-result-rust "pub fn maybe_value(x: u64) -> Option<u64>") (substring? option-result-rust "Some((x).clone())") - (substring? option-result-rust "pub fn none_text() -> Option<String>") + (substring? option-result-rust "pub fn maybe_text(x: u64) -> Option<String>") (substring? option-result-rust "None") (substring? option-result-rust "pub fn ok_value(x: u64) -> Result<u64, String>") (substring? option-result-rust "Ok((x).clone())") @@ -323,10 +330,27 @@ "let maybe = if maybe_tag != 0 { Some(maybe_value) } else { None };")) #t) -(test "rust still uses handles for Option<non-scalar> and Result<*,String>" +(test "rust emits option-buffer direct ABI wrappers" + (and (substring? option-result-rust + "pub extern \"C\" fn jt_sample_typed_option_result_maybe_text(x: u64, out_ptr: *mut *mut u8, out_len: *mut usize) -> bool") + (substring? option-result-rust + "Some(value) => jt_return_bytes(value.into_bytes(), out_ptr, out_len),") + (substring? option-result-rust + "None => false,") + (substring? option-result-rust + "pub extern \"C\" fn jt_sample_typed_option_result_echo_maybe_text(m_tag: u8, m_ptr: *const u8, m_len: usize, out_ptr: *mut *mut u8, out_len: *mut usize) -> bool") + (substring? option-result-rust + "Some(String::from_utf8_lossy(bytes).into_owned())") + (substring? option-result-rust + "pub extern \"C\" fn jt_sample_typed_option_result_echo_maybe_bytes(m_tag: u8, m_ptr: *const u8, m_len: usize, out_ptr: *mut *mut u8, out_len: *mut usize) -> bool") + (substring? option-result-rust + "Some(value) => jt_return_bytes(value, out_ptr, out_len),") + (substring? option-result-rust + "Some(bytes.to_vec())")) + #t) + +(test "rust still uses handles for Result<*,String>" (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_none_text() -> u64") - (substring? option-result-rust "jt_store_handle(none_text())") (substring? option-result-rust "pub extern \"C\" fn jt_sample_typed_option_result_ok_value(x: u64) -> u64") (substring? option-result-rust "jt_store_handle(ok_value(x))") (substring? option-result-rust "pub extern \"C\" fn jt_sample_typed_option_result_echo_result(r_handle: u64) -> u64") --- a/tests/test-typed-wrapper-e2e.ss +++ b/tests/test-typed-wrapper-e2e.ss @@ -103,6 +103,35 @@ (check "result-scalar rejects wrong inner" (raises? (lambda () (echo-only-pos (cons 'ok "string-not-nat"))))) +(check "option string Some return" + (equal? (maybe-text 7) (cons 'some "7"))) +(check "option string None return" + (eq? (maybe-text 0) #f)) +(check "option string Some round trip" + (equal? (echo-maybe-text (cons 'some "hello")) (cons 'some "hello"))) +(check "option string None round trip" + (eq? (echo-maybe-text #f) #f)) +(check "option string Some empty round trip" + (equal? (echo-maybe-text (cons 'some "")) (cons 'some ""))) +(check "option string rejects bad shape" + (raises? (lambda () (echo-maybe-text (cons 'whatever "x"))))) +(check "option string rejects wrong inner" + (raises? (lambda () (echo-maybe-text (cons 'some 42))))) + +(define sample-bytes-2 (make-bytevector 3 0)) +(bytevector-u8-set! sample-bytes-2 0 9) +(bytevector-u8-set! sample-bytes-2 1 8) +(bytevector-u8-set! sample-bytes-2 2 7) +(check "option bytes Some round trip" + (let ([result (echo-maybe-bytes (cons 'some sample-bytes-2))]) + (and (pair? result) + (eq? (car result) 'some) + (bytevector-equal? (cdr result) sample-bytes-2)))) +(check "option bytes None round trip" + (eq? (echo-maybe-bytes #f) #f)) +(check "option bytes rejects wrong inner" + (raises? (lambda () (echo-maybe-bytes (cons 'some "not-bytes"))))) + (define dropped-box (make-box 31)) (check "handle drop" (%typed-rust-handle-drop! dropped-box)) --- a/tests/test-typed-wrappers.ss +++ b/tests/test-typed-wrappers.ss @@ -112,6 +112,21 @@ (define option-result-wrapper (typed-library-form->jerboa-wrapper-string option-result-form)) +(define option-buffer-form + '(typed-library (sample typed option-buffer) + (export maybe-text echo-maybe-text echo-maybe-bytes) + (def (maybe-text (x : Nat)) : (Option String) + (if (> x 0) + (option-some (debug-string x)) + (option-none String))) + (def (echo-maybe-text (m : (Option String))) : (Option String) + m) + (def (echo-maybe-bytes (m : (Option Bytes))) : (Option Bytes) + m))) + +(define option-buffer-wrapper + (typed-library-form->jerboa-wrapper-string option-buffer-form)) + (define result-scalar-form '(typed-library (sample typed result-scalar) (export only-pos echo-only-pos) @@ -297,6 +312,35 @@ "(%echo_only_pos (if (eq? (car r) 'ok) 1 0) (if (eq? (car r) 'ok) (cdr r) 0) (if (eq? (car r) 'err) (cdr r) #f) %ok_out %err_out)")) #t) +(test "wrapper lowers Option String returns directly" + (and (substring? option-buffer-wrapper + "(foreign-procedure \"jt_sample_typed_option_buffer_maybe_text\" (unsigned-64 void* void*) boolean)") + (substring? option-buffer-wrapper + "(if (%maybe_text x %ptr_box %len_box) (cons 'some (utf8->string (%typed-rust-take-byte-buffer (foreign-ref 'void* %ptr_box 0) (foreign-ref 'size_t %len_box 0)))) #f)")) + #t) + +(test "wrapper lowers Option String params directly" + (and (substring? option-buffer-wrapper + "(foreign-procedure \"jt_sample_typed_option_buffer_echo_maybe_text\" (unsigned-8 u8* size_t void* void*) boolean)") + (substring? option-buffer-wrapper + "(unless (or (eq? m #f) (and (pair? m) (eq? (car m) 'some) (string? (cdr m))))") + (substring? option-buffer-wrapper + "[%m_bytes (if m (string->utf8 (cdr m)) #vu8())]") + (substring? option-buffer-wrapper + "(%echo_maybe_text (if m 1 0) %m_bytes (bytevector-length %m_bytes) %ptr_box %len_box)")) + #t) + +(test "wrapper lowers Option Bytes params directly" + (and (substring? option-buffer-wrapper + "(foreign-procedure \"jt_sample_typed_option_buffer_echo_maybe_bytes\" (unsigned-8 u8* size_t void* void*) boolean)") + (substring? option-buffer-wrapper + "(unless (or (eq? m #f) (and (pair? m) (eq? (car m) 'some) (bytevector? (cdr m))))") + (substring? option-buffer-wrapper + "[%m_bytes (if m (cdr m) #vu8())]") + (substring? option-buffer-wrapper + "(if (%echo_maybe_bytes (if m 1 0) %m_bytes (bytevector-length %m_bytes) %ptr_box %len_box) (cons 'some (%typed-rust-take-byte-buffer (foreign-ref 'void* %ptr_box 0) (foreign-ref 'size_t %len_box 0))) #f)")) + #t) + (printf "~%Typed wrapper: ~a passed, ~a failed~%" pass fail) (when (> fail 0) (exit 1))