Lower (Result <buffer> <*>) and (Result <*> <buffer>) directly
ober
7407c846e422a87d4646b5567f9d75c550f278a5
--- a/docs/typed-jerboa.md +++ b/docs/typed-jerboa.md @@ -296,21 +296,22 @@ Highest-value next steps: elaboration, so cross-module record/variant/def references compile into a single Rust crate. The emitter still inlines all modules into one file and does not yet emit cross-module `use` declarations. -3. Improve boundary semantics for Option/Result (partial). `(Option <Scalar>)` - for Scalar in `{Bool, Char, Int, Nat, Fixnum, Float}` now crosses the FFI +3. Improve boundary semantics for Option/Result (Done). `(Option <Scalar>)` + for Scalar in `{Bool, Char, Int, Nat, Fixnum, Float}` crosses the FFI boundary as a tagged Scheme value (`#f` or `(cons 'some V)`): the Rust ABI writes the inner value through a `*mut <ScalarRustType>` out-pointer and returns a `bool` status, and the generated wrapper allocates the buffer with `dynamic-wind`-protected free. Option-scalar params lower to a `u8` tag plus - 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 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. + the raw scalar value. `(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 T E)` for any combination of scalar and buffer + inners (`{Bool, Char, Int, Nat, Fixnum, Float, String, Bytes}`) lowers + directly: returns produce a `u8` tag (1 = Ok, 0 = Err) plus per-side + out-pointers (a `*mut T` for scalar inners, a `*mut *mut u8` / `*mut usize` + pair for buffer inners via `jt_return_bytes`); params lower to a `u8` tag + plus per-side raw arguments (raw scalar value or pointer/length pair); the + wrapper surfaces `(cons 'ok V)` / `(cons 'err E)`. 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 @@ -367,6 +367,17 @@ (= (length type) 2) (abi-buffer-type? (cadr type)))) + (def (abi-inner-direct-type? type) + (or (and (abi-safe-type? type) (not (eq? type 'Unit))) + (abi-buffer-type? type))) + + (def (abi-result-direct-type? type) + (and (pair? type) + (eq? (car type) 'Result) + (= (length type) 3) + (abi-inner-direct-type? (cadr type)) + (abi-inner-direct-type? (caddr type)))) + (def (abi-handle-type? type) (or (and (symbol? type) @@ -376,7 +387,7 @@ (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))))) + (not (abi-result-direct-type? type))))) (def (abi-return-buffer-type? type) (and (symbol? type) @@ -389,7 +400,7 @@ (abi-return-buffer-type? type) (abi-option-scalar-type? type) (abi-option-buffer-type? type) - (abi-result-scalar-scalar-type? type))) + (abi-result-direct-type? type))) (def (abi-safe-param-type? type) (or (abi-safe-type? type) @@ -397,7 +408,7 @@ (abi-handle-type? type) (abi-option-scalar-type? type) (abi-option-buffer-type? type) - (abi-result-scalar-scalar-type? type))) + (abi-result-direct-type? type))) (def (abi-rust-type type) (case type @@ -438,6 +449,60 @@ "_" (rust-symbol-name (typed-def-name def)))) + ;; Inner-type ABI helpers for Result direct lowering: emit param/out args and + ;; the read/write code for one side of the Result. + (def (abi-inner-param-args type prefix role) + (cond + [(abi-buffer-type? type) + (list + (string-append prefix "_" role "_ptr: *const u8") + (string-append prefix "_" role "_len: usize"))] + [else + (list (string-append prefix "_" role ": " (abi-rust-type type)))])) + + (def (abi-inner-out-args type role) + (cond + [(abi-buffer-type? type) + (list + (string-append role "_ptr_out: *mut *mut u8") + (string-append role "_len_out: *mut usize"))] + [else + (list (string-append role "_out: *mut " (abi-rust-type type)))])) + + (def (abi-inner-read-expr type prefix role) + (cond + [(eq? type 'String) + (string-append + "{ let bytes: &[u8] = if " prefix "_" role "_ptr.is_null() { &[] } else {" + " unsafe { std::slice::from_raw_parts(" prefix "_" role "_ptr, " + prefix "_" role "_len) } };" + " String::from_utf8_lossy(bytes).into_owned() }")] + [(eq? type 'Bytes) + (string-append + "{ let bytes: &[u8] = if " prefix "_" role "_ptr.is_null() { &[] } else {" + " unsafe { std::slice::from_raw_parts(" prefix "_" role "_ptr, " + prefix "_" role "_len) } };" + " bytes.to_vec() }")] + [(eq? type 'Char) + (string-append "char::from_u32(" prefix "_" role ").unwrap_or('\\u{FFFD}')")] + [else + (string-append prefix "_" role)])) + + (def (abi-inner-write-stmt type role value) + (cond + [(eq? type 'String) + (string-append + "let _ = jt_return_bytes(" value ".into_bytes(), " + role "_ptr_out, " role "_len_out);")] + [(eq? type 'Bytes) + (string-append + "let _ = jt_return_bytes(" value ", " + role "_ptr_out, " role "_len_out);")] + [(eq? type 'Char) + (string-append "unsafe { *" role "_out = (" value " as u32); }")] + [else + (string-append "unsafe { *" role "_out = " value "; }")])) + (def (emit-abi-param param) (let ([name (rust-symbol-name (typed-param-name param))] [type (typed-param-type param)]) @@ -450,11 +515,12 @@ (list (string-append name "_tag: u8") (string-append name "_value: " (abi-rust-type (cadr type))))] - [(abi-result-scalar-scalar-type? type) - (list + [(abi-result-direct-type? type) + (cons (string-append name "_tag: u8") - (string-append name "_ok: " (abi-rust-type (cadr type))) - (string-append name "_err: " (abi-rust-type (caddr type))))] + (append + (abi-inner-param-args (cadr type) name "ok") + (abi-inner-param-args (caddr type) name "err")))] [(abi-option-buffer-type? type) (list (string-append name "_tag: u8") @@ -552,6 +618,14 @@ [else (loop (cdr decls))]))) + (def (def-touches-buffer? def) + (let ([rt (typed-def-return-type def)]) + (or (abi-return-buffer-type? rt) + (abi-option-buffer-type? rt) + (and (abi-result-direct-type? rt) + (or (abi-buffer-type? (cadr rt)) + (abi-buffer-type? (caddr rt))))))) + (def (module-needs-byte-buffer-runtime? module) (let loop ([decls (typed-module-declarations module)]) (cond @@ -559,8 +633,7 @@ [(and (typed-def? (car decls)) (exported-def? module (car decls)) (abi-safe-def? (car decls)) - (or (abi-return-buffer-type? (typed-def-return-type (car decls))) - (abi-option-buffer-type? (typed-def-return-type (car decls))))) + (def-touches-buffer? (car decls))) #t] [else (loop (cdr decls))]))) @@ -639,17 +712,13 @@ "_tag != 0 { " some-expr " } else { None };")))] - [(abi-result-scalar-scalar-type? type) + [(abi-result-direct-type? type) (let* ([ok-inner (cadr type)] [err-inner (caddr type)] [ok-expr - (if (eq? ok-inner 'Char) - (string-append "Ok(char::from_u32(" name "_ok).unwrap_or('\\u{FFFD}'))") - (string-append "Ok(" name "_ok)"))] + (string-append "Ok(" (abi-inner-read-expr ok-inner name "ok") ")")] [err-expr - (if (eq? err-inner 'Char) - (string-append "Err(char::from_u32(" name "_err).unwrap_or('\\u{FFFD}'))") - (string-append "Err(" name "_err)"))]) + (string-append "Err(" (abi-inner-read-expr err-inner name "err") ")")]) (write-line port 2 (string-append "let " @@ -731,8 +800,8 @@ [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)] + [return-result-direct? + (abi-result-direct-type? return-type)] [param-names (map (lambda (param) (rust-symbol-name (typed-param-name param))) params)] @@ -755,21 +824,17 @@ (string-append "out_ptr: *mut " (abi-rust-type (cadr return-type))))] - [return-result-scalar-scalar? - (list - (string-append - "ok_out: *mut " - (abi-rust-type (cadr return-type))) - (string-append - "err_out: *mut " - (abi-rust-type (caddr return-type))))] + [return-result-direct? + (append + (abi-inner-out-args (cadr return-type) "ok") + (abi-inner-out-args (caddr return-type) "err"))] [else '()]))] [extern-return-type (cond [return-buffer? "bool"] [return-option-scalar? "bool"] [return-option-buffer? "bool"] - [return-result-scalar-scalar? "u8"] + [return-result-direct? "u8"] [else (abi-rust-type return-type)])]) (write-line port 0 "#[unsafe(no_mangle)]") (write-line port 0 @@ -809,20 +874,20 @@ "; } true }")) (write-line port 3 "None => false,") (write-line port 2 "}"))] - [return-result-scalar-scalar? + [return-result-direct? (let ([ok-inner (cadr return-type)] [err-inner (caddr return-type)]) (write-line port 2 (string-append "match " call " {")) (write-line port 3 (string-append - "Ok(value) => { unsafe { *ok_out = " - (if (eq? ok-inner 'Char) "(value as u32)" "value") - "; } 1u8 }")) + "Ok(value) => { " + (abi-inner-write-stmt ok-inner "ok" "value") + " 1u8 }")) (write-line port 3 (string-append - "Err(value) => { unsafe { *err_out = " - (if (eq? err-inner 'Char) "(value as u32)" "value") - "; } 0u8 }")) + "Err(value) => { " + (abi-inner-write-stmt err-inner "err" "value") + " 0u8 }")) (write-line port 2 "}"))] [else (write-line port 2 (abi-return-expression def call))]) @@ -835,7 +900,7 @@ [return-buffer? "false"] [return-option-buffer? "false"] [return-option-scalar? "false"] - [return-result-scalar-scalar? "0u8"] + [return-result-direct? "0u8"] [else (abi-default-expression return-type)]) ",")) (write-line port 1 "}") --- a/lib/jerboa/typed/wrapper.ss +++ b/lib/jerboa/typed/wrapper.ss @@ -110,15 +110,6 @@ (abi-wrapper-scalar-type? (cadr type)) (not (eq? (cadr type) 'Unit)))) - (def (result-scalar-scalar-type? type) - (and (pair? type) - (eq? (car type) 'Result) - (= (length type) 3) - (abi-wrapper-scalar-type? (cadr type)) - (not (eq? (cadr type) 'Unit)) - (abi-wrapper-scalar-type? (caddr type)) - (not (eq? (caddr type) 'Unit)))) - (def (buffer-type? type) (and (symbol? type) (memq type '(String Bytes)) @@ -130,12 +121,23 @@ (= (length type) 2) (buffer-type? (cadr type)))) + (def (inner-direct-type? type) + (or (and (abi-wrapper-scalar-type? type) (not (eq? type 'Unit))) + (buffer-type? type))) + + (def (result-direct-type? type) + (and (pair? type) + (eq? (car type) 'Result) + (= (length type) 3) + (inner-direct-type? (cadr type)) + (inner-direct-type? (caddr 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))) + (not (result-direct-type? type))) (and (symbol? type) (let loop ([decls (typed-module-declarations module)]) (cond @@ -159,7 +161,7 @@ (abi-wrapper-return-buffer-type? type) (option-scalar-type? type) (option-buffer-type? type) - (result-scalar-scalar-type? type))) + (result-direct-type? type))) (def (wrapper-safe-param-type? module type) (or (abi-wrapper-scalar-type? type) @@ -167,7 +169,7 @@ (module-handle-type? module type) (option-scalar-type? type) (option-buffer-type? type) - (result-scalar-scalar-type? type))) + (result-direct-type? type))) (def (wrapper-safe-def? module def) (and (wrapper-safe-return-type? module (typed-def-return-type def)) @@ -178,12 +180,22 @@ (loop (cdr params))] [else #f])))) + (def (inner-chez-param-types type) + (cond + [(buffer-type? type) '(u8* size_t)] + [else (list (abi-chez-type type))])) + + (def (inner-chez-out-arg-types type) + (cond + [(buffer-type? type) '(void* void*)] + [else '(void*)])) + (def (abi-chez-return-type module type) (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] + [(result-direct-type? type) 'unsigned-8] [(module-handle-type? module type) 'unsigned-64] [else (abi-chez-type type)])) @@ -194,10 +206,10 @@ (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)) - (abi-chez-type (caddr type)))] + [(result-direct-type? type) + (cons 'unsigned-8 + (append (inner-chez-param-types (cadr type)) + (inner-chez-param-types (caddr type))))] [(module-handle-type? module type) '(unsigned-64)] [else (list (abi-chez-type type))])) @@ -211,13 +223,26 @@ (loop (cdr rest) (cons (car rest) out))] [else (loop (cdr rest) out)]))) + (def (type-touches-buffer? type) + (or (buffer-type? type) + (option-buffer-type? type) + (and (result-direct-type? type) + (or (buffer-type? (cadr type)) + (buffer-type? (caddr type)))))) + + (def (def-touches-buffer? def) + (or (type-touches-buffer? (typed-def-return-type def)) + (let loop ([params (typed-def-params def)]) + (cond + [(null? params) #f] + [(type-touches-buffer? (typed-param-type (car params))) #t] + [else (loop (cdr params))])))) + (def (module-needs-return-buffer? module) (let loop ([defs (wrapper-defs module)]) (cond [(null? defs) #f] - [(or (abi-wrapper-return-buffer-type? (typed-def-return-type (car defs))) - (option-buffer-type? (typed-def-return-type (car defs)))) - #t] + [(def-touches-buffer? (car defs)) #t] [else (loop (cdr defs))]))) (def (def-uses-handle? module def) @@ -243,12 +268,12 @@ [(option-scalar-type? (typed-param-type (car params))) #t] [else (loop (cdr params))])))) - (def (def-uses-result-scalar-scalar? def) - (or (result-scalar-scalar-type? (typed-def-return-type def)) + (def (def-uses-result-direct? def) + (or (result-direct-type? (typed-def-return-type def)) (let loop ([params (typed-def-params def)]) (cond [(null? params) #f] - [(result-scalar-scalar-type? (typed-param-type (car params))) #t] + [(result-direct-type? (typed-param-type (car params))) #t] [else (loop (cdr params))])))) (def (def-uses-option-buffer? def) @@ -264,7 +289,7 @@ (cond [(null? defs) #f] [(def-uses-option-scalar? (car defs)) #t] - [(def-uses-result-scalar-scalar? (car defs)) #t] + [(def-uses-result-direct? (car defs)) #t] [(def-uses-option-buffer? (car defs)) #t] [else (loop (cdr defs))]))) @@ -337,6 +362,73 @@ [(Bool) (string-append "(not (zero? " raw "))")] [else raw]))) + ;; Helpers for Result-direct return-expression: build out-buffer bindings, + ;; init/pass/free statements and read expressions for one side of the Result. + (def (result-inner-out-allocs type role) + (cond + [(buffer-type? type) + (list + (string-append "[%" role "_ptr_box (foreign-alloc (foreign-sizeof 'void*))]") + (string-append "[%" role "_len_box (foreign-alloc (foreign-sizeof 'size_t))]"))] + [else + (let ([ftype (option-scalar-foreign-type type)]) + (list + (string-append "[%" role "_out (foreign-alloc (foreign-sizeof '" ftype "))]")))])) + + (def (result-inner-out-inits type role) + (cond + [(buffer-type? type) + (list + (string-append "(foreign-set! 'void* %" role "_ptr_box 0 0)") + (string-append "(foreign-set! 'size_t %" role "_len_box 0 0)"))] + [else + (let ([ftype (option-scalar-foreign-type type)]) + (list + (string-append "(foreign-set! '" ftype " %" role "_out 0 " + (option-scalar-init-value type) ")")))])) + + (def (result-inner-out-pass type role) + (cond + [(buffer-type? type) + (list + (string-append "%" role "_ptr_box") + (string-append "%" role "_len_box"))] + [else + (list (string-append "%" role "_out"))])) + + (def (result-inner-out-frees type role) + (cond + [(buffer-type? type) + (list + (string-append "(foreign-free %" role "_ptr_box)") + (string-append "(foreign-free %" role "_len_box)"))] + [else + (list (string-append "(foreign-free %" role "_out)"))])) + + (def (result-inner-out-read type role) + (cond + [(eq? type 'String) + (string-append + "(utf8->string (%typed-rust-take-byte-buffer (foreign-ref 'void* %" + role "_ptr_box 0) (foreign-ref 'size_t %" role "_len_box 0)))")] + [(eq? type 'Bytes) + (string-append + "(%typed-rust-take-byte-buffer (foreign-ref 'void* %" + role "_ptr_box 0) (foreign-ref 'size_t %" role "_len_box 0))")] + [else + (option-scalar-read-expression type (string-append "%" role "_out"))])) + + ;; Names for the prelude-bound bytevectors carried by Result-direct params + ;; whose ok/err side is a buffer. + (def (result-param-bytes-name param role) + (string->symbol + (string-append + "%" + (rust-symbol-name (typed-param-name param)) + "_" + role + "_bytes"))) + (def (ffi-binding-name def) (string->symbol (string-append "%" (rust-symbol-name (typed-def-name def))))) @@ -379,15 +471,23 @@ "(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 ") " - "(or (and (eq? (car " name ") 'ok) " - (scalar-check-expression (cadr type) (string-append "(cdr " name ")")) - ") " - "(and (eq? (car " name ") 'err) " - (scalar-check-expression (caddr type) (string-append "(cdr " name ")")) - ")))")] + [(result-direct-type? type) + (let ([ok-check + (if (buffer-type? (cadr type)) + (buffer-check-expression (cadr type) (string-append "(cdr " name ")")) + (scalar-check-expression (cadr type) (string-append "(cdr " name ")")))] + [err-check + (if (buffer-type? (caddr type)) + (buffer-check-expression (caddr type) (string-append "(cdr " name ")")) + (scalar-check-expression (caddr type) (string-append "(cdr " name ")")))]) + (string-append + "(and (pair? " name ") " + "(or (and (eq? (car " name ") 'ok) " + ok-check + ") " + "(and (eq? (car " name ") 'err) " + err-check + ")))"))] [(module-handle-type? module type) (string-append "(%typed-rust-handle? " @@ -427,15 +527,14 @@ (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 (result-direct-param-needs-prelude? param) + (and (result-direct-type? (typed-param-type param)) + (not (null? (result-direct-param-buffer-roles param))))) - (def (has-prelude-binding? params) - (let loop ([rest params]) - (cond - [(null? rest) #f] - [(needs-prelude-binding? (car rest)) #t] - [else (loop (cdr rest))]))) + (def (needs-prelude-binding? param) + (or (string-param? param) + (option-buffer-param? param) + (result-direct-param-needs-prelude? param))) (def (prelude-binding-expression param) (let ([name (datum->code (typed-param-name param))] @@ -455,6 +554,78 @@ [else (error 'typed-wrapper "no prelude binding for param" param)]))) + (def (result-direct-param-buffer-roles param) + (let ([type (typed-param-type param)]) + (append + (if (buffer-type? (cadr type)) '("ok") '()) + (if (buffer-type? (caddr type)) '("err") '())))) + + (def (result-direct-param-bytes-expression param role) + (let ([name (datum->code (typed-param-name param))] + [inner (if (string=? role "ok") + (cadr (typed-param-type param)) + (caddr (typed-param-type param)))]) + (case inner + [(String) + (string-append "(if (eq? (car " name ") '" role ") (string->utf8 (cdr " name ")) #vu8())")] + [(Bytes) + (string-append "(if (eq? (car " name ") '" role ") (cdr " name ") #vu8())")] + [else + (error 'typed-wrapper "non-buffer inner has no bytes expression" inner)]))) + + (def (param-prelude-bindings param) + (let ([type (typed-param-type param)]) + (cond + [(string-param? param) + (list + (string-append + "[" + (datum->code (string-bytes-name param)) + " " + (prelude-binding-expression param) + "]"))] + [(option-buffer-param? param) + (list + (string-append + "[" + (datum->code (string-bytes-name param)) + " " + (prelude-binding-expression param) + "]"))] + [(result-direct-type? type) + (map + (lambda (role) + (string-append + "[" + (datum->code (result-param-bytes-name param role)) + " " + (result-direct-param-bytes-expression param role) + "]")) + (result-direct-param-buffer-roles param))] + [else '()]))) + + (def (result-direct-inner-args param inner role) + (let ([name (datum->code (typed-param-name param))]) + (cond + [(buffer-type? inner) + (let ([bytes-name (datum->code (result-param-bytes-name param role))]) + (list + bytes-name + (string-append "(bytevector-length " bytes-name ")")))] + [else + (let ([value-expr + (if (eq? inner 'Char) + (string-append "(char->integer (cdr " name "))") + (string-append "(cdr " name ")"))] + [default (option-scalar-default-value inner)]) + (list + (string-append + "(if (eq? (car " name ") '" role ") " + value-expr + " " + default + ")")))]))) + (def (wrapper-argument-expressions module param) (let ([name (datum->code (typed-param-name param))] [type (typed-param-type param)]) @@ -484,33 +655,14 @@ (string-append "(if " name " 1 0)") bytes-name (string-append "(bytevector-length " bytes-name ")")))] - [(result-scalar-scalar-type? type) + [(result-direct-type? type) (let* ([ok-inner (cadr type)] - [err-inner (caddr type)] - [ok-default (option-scalar-default-value ok-inner)] - [err-default (option-scalar-default-value err-inner)] - [ok-value-expr - (if (eq? ok-inner 'Char) - (string-append "(char->integer (cdr " name "))") - (string-append "(cdr " name ")"))] - [err-value-expr - (if (eq? err-inner 'Char) - (string-append "(char->integer (cdr " name "))") - (string-append "(cdr " name ")"))]) - (list + [err-inner (caddr type)]) + (cons (string-append "(if (eq? (car " name ") 'ok) 1 0)") - (string-append - "(if (eq? (car " name ") 'ok) " - ok-value-expr - " " - ok-default - ")") - (string-append - "(if (eq? (car " name ") 'err) " - err-value-expr - " " - err-default - ")")))] + (append + (result-direct-inner-args param ok-inner "ok") + (result-direct-inner-args param err-inner "err"))))] [(module-handle-type? module type) (list (string-append "(%typed-rust-handle-id " name ")"))] [else (list name)]))) @@ -582,29 +734,36 @@ " (cons 'some " decoded ")" " #f))" " (lambda () (foreign-free %ptr_box) (foreign-free %len_box))))"))] - [(result-scalar-scalar-type? return-type) + [(result-direct-type? return-type) (let* ([ok-inner (cadr return-type)] [err-inner (caddr return-type)] - [ok-ftype (option-scalar-foreign-type ok-inner)] - [err-ftype (option-scalar-foreign-type err-inner)]) + [ok-allocs (result-inner-out-allocs ok-inner "ok")] + [err-allocs (result-inner-out-allocs err-inner "err")] + [ok-inits (result-inner-out-inits ok-inner "ok")] + [err-inits (result-inner-out-inits err-inner "err")] + [ok-passes (result-inner-out-pass ok-inner "ok")] + [err-passes (result-inner-out-pass err-inner "err")] + [ok-frees (result-inner-out-frees ok-inner "ok")] + [err-frees (result-inner-out-frees err-inner "err")] + [ok-read (result-inner-out-read ok-inner "ok")] + [err-read (result-inner-out-read err-inner "err")]) (string-append - "(let ([%ok_out (foreign-alloc (foreign-sizeof '" ok-ftype "))]" - " [%err_out (foreign-alloc (foreign-sizeof '" err-ftype "))])" + "(let (" + (join-strings (append ok-allocs err-allocs) " ") + ")" " (dynamic-wind" " (lambda () #f)" " (lambda ()" - " (foreign-set! '" ok-ftype " %ok_out 0 " (option-scalar-init-value ok-inner) ")" - " (foreign-set! '" err-ftype " %err_out 0 " (option-scalar-init-value err-inner) ")" + " " + (join-strings (append ok-inits err-inits) " ") " (if (= 1 " - (wrapper-call-expression* module def '("%ok_out" "%err_out")) - ")" - " (cons 'ok " - (option-scalar-read-expression ok-inner "%ok_out") + (wrapper-call-expression* module def (append ok-passes err-passes)) ")" - " (cons 'err " - (option-scalar-read-expression err-inner "%err_out") - ")))" - " (lambda () (foreign-free %ok_out) (foreign-free %err_out))))"))] + " (cons 'ok " ok-read ")" + " (cons 'err " err-read ")))" + " (lambda () " + (join-strings (append ok-frees err-frees) " ") + ")))"))] [(module-handle-type? module return-type) (string-append "(%typed-rust-make-handle " @@ -636,7 +795,11 @@ [(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*")] + [(result-direct-type? return-type) + (map datum->code + (append + (inner-chez-out-arg-types (cadr return-type)) + (inner-chez-out-arg-types (caddr return-type))))] [else '()])) " ") ") " @@ -664,31 +827,14 @@ (lambda (param) (emit-param-check module def param port)) params) - (if (has-prelude-binding? params) - (begin - (write-line port 1 - (string-append - "(let (" - (join-strings - (map - (lambda (param) - (string-append - "[" - (datum->code (string-bytes-name param)) - " " - (prelude-binding-expression param) - "]")) - (let loop ([rest params] [out '()]) - (cond - [(null? rest) (reverse out)] - [(needs-prelude-binding? (car rest)) - (loop (cdr rest) (cons (car rest) out))] - [else (loop (cdr rest) out)]))) - " ") - ")")) - (write-line port 2 (wrapper-return-expression module def)) - (write-line port 1 ")")) - (write-line port 1 (wrapper-return-expression module def))) + (let ([bindings (append-map param-prelude-bindings params)]) + (if (null? bindings) + (write-line port 1 (wrapper-return-expression module def)) + (begin + (write-line port 1 + (string-append "(let (" (join-strings bindings " ") ")")) + (write-line port 2 (wrapper-return-expression module def)) + (write-line port 1 ")")))) (write-line port 0 ")") (newline port))) --- a/tests/fixtures/typed/rust-basic.ss +++ b/tests/fixtures/typed/rust-basic.ss @@ -2,7 +2,8 @@ (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 maybe-text echo-maybe-text echo-maybe-bytes) + only-pos echo-only-pos maybe-text echo-maybe-text echo-maybe-bytes + text-or-zero echo-text-or echo-text-or-bytes) (record Box ((value : Nat))) @@ -91,4 +92,15 @@ m) (def (echo-maybe-bytes (m : (Option Bytes))) : (Option Bytes) - m)) + m) + + (def (text-or-zero (n : Nat)) : (Result String Nat) + (if (> n 0) + (result-ok (debug-string n) Nat) + (result-err String 0))) + + (def (echo-text-or (r : (Result String Nat))) : (Result String Nat) + r) + + (def (echo-text-or-bytes (r : (Result String Bytes))) : (Result String Bytes) + r)) --- a/tests/test-typed-rust.ss +++ b/tests/test-typed-rust.ss @@ -349,13 +349,15 @@ "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_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") - (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))")) +(test "rust emits result-scalar-buffer direct ABI wrappers" + (and (substring? option-result-rust + "pub extern \"C\" fn jt_sample_typed_option_result_ok_value(x: u64, ok_out: *mut u64, err_ptr_out: *mut *mut u8, err_len_out: *mut usize) -> u8") + (substring? option-result-rust + "Ok(value) => { unsafe { *ok_out = value; } 1u8 }") + (substring? option-result-rust + "Err(value) => { let _ = jt_return_bytes(value.into_bytes(), err_ptr_out, err_len_out); 0u8 }") + (substring? option-result-rust + "pub extern \"C\" fn jt_sample_typed_option_result_echo_result(r_tag: u8, r_ok: u64, r_err_ptr: *const u8, r_err_len: usize, ok_out: *mut u64, err_ptr_out: *mut *mut u8, err_len_out: *mut usize) -> u8")) #t) (define result-scalar-form --- a/tests/test-typed-wrapper-e2e.ss +++ b/tests/test-typed-wrapper-e2e.ss @@ -73,22 +73,30 @@ (check "option scalar None round trip" (eq? maybe-none-roundtrip #f)) -(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 scalar rejects non-Option" - (raises? (lambda () (echo-maybe ok-handle)))) +(define ok-result (ok-value 37)) +(check "result Ok direct return" + (equal? ok-result (cons 'ok 37))) +(define err-result (err-value "bad")) +(check "result Err direct return" + (equal? err-result (cons 'err "bad"))) +(define result-roundtrip (echo-result ok-result)) +(check "result Ok direct round trip" + (equal? result-roundtrip (cons 'ok 37))) +(check "result Err direct round trip" + (equal? (echo-result err-result) (cons 'err "bad"))) +(check "result Err empty string round trip" + (equal? (echo-result (cons 'err "")) (cons 'err ""))) + +(check "option scalar rejects result shape" + (raises? (lambda () (echo-maybe ok-result)))) (check "option scalar rejects bad shape" (raises? (lambda () (echo-maybe (cons 'whatever 1))))) -(check "result handle rejects option" +(check "result direct rejects option shape" (raises? (lambda () (echo-result maybe-some)))) +(check "result direct rejects bad shape" + (raises? (lambda () (echo-result (cons 'maybe 1))))) +(check "result direct rejects wrong inner" + (raises? (lambda () (echo-result (cons 'ok "should-be-nat"))))) (check "result-scalar Ok return" (equal? (only-pos 5) (cons 'ok 5))) @@ -122,6 +130,37 @@ (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 "result buffer-scalar Ok return" + (equal? (text-or-zero 7) (cons 'ok "7"))) +(check "result buffer-scalar Err return" + (equal? (text-or-zero 0) (cons 'err 0))) +(check "result buffer-scalar Ok round trip" + (equal? (echo-text-or (cons 'ok "hello")) (cons 'ok "hello"))) +(check "result buffer-scalar Err round trip" + (equal? (echo-text-or (cons 'err 99)) (cons 'err 99))) +(check "result buffer-scalar Ok empty string" + (equal? (echo-text-or (cons 'ok "")) (cons 'ok ""))) +(check "result buffer-scalar rejects bad shape" + (raises? (lambda () (echo-text-or (cons 'maybe "x"))))) +(check "result buffer-scalar rejects wrong inner" + (raises? (lambda () (echo-text-or (cons 'ok 42))))) + +(define rb-bytes (make-bytevector 3 0)) +(bytevector-u8-set! rb-bytes 0 11) +(bytevector-u8-set! rb-bytes 1 22) +(bytevector-u8-set! rb-bytes 2 33) +(check "result buffer-buffer Ok round trip" + (equal? (echo-text-or-bytes (cons 'ok "string-side")) (cons 'ok "string-side"))) +(check "result buffer-buffer Err round trip" + (let ([result (echo-text-or-bytes (cons 'err rb-bytes))]) + (and (pair? result) + (eq? (car result) 'err) + (bytevector-equal? (cdr result) rb-bytes)))) +(check "result buffer-buffer Ok empty round trip" + (equal? (echo-text-or-bytes (cons 'ok "")) (cons 'ok ""))) +(check "result buffer-buffer rejects bad inner" + (raises? (lambda () (echo-text-or-bytes (cons 'ok 42))))) + (check "option bytes Some round trip" (let ([result (echo-maybe-bytes (cons 'some sample-bytes-2))]) (and (pair? result) @@ -163,10 +202,6 @@ (collect) (check "handle guardian reaps unreachable handles" (> (%typed-rust-reap-handles!) 0))) -(check "result handle drops" - (and (%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 @@ -285,15 +285,26 @@ "(%echo_maybe (if maybe 1 0) (if maybe (cdr maybe) 0) %out)")) #t) -(test "wrapper still uses handles for Result returns and params" +(test "wrapper lowers Result Nat String returns directly" (and (substring? option-result-wrapper - "(%typed-rust-make-handle '(Result Nat String) (%ok_value x))") + "(foreign-procedure \"jt_sample_typed_option_result_ok_value\" (unsigned-64 void* void* void*) unsigned-8)") (substring? option-result-wrapper - "(%typed-rust-make-handle '(Result Nat String) (%err_value %message_bytes (bytevector-length %message_bytes)))") + "(foreign-procedure \"jt_sample_typed_option_result_err_value\" (u8* size_t void* void* void*) unsigned-8)") (substring? option-result-wrapper - "(unless (%typed-rust-handle? r '(Result Nat String))") + "(let ([%ok_out (foreign-alloc (foreign-sizeof 'unsigned-64))] [%err_ptr_box (foreign-alloc (foreign-sizeof 'void*))] [%err_len_box (foreign-alloc (foreign-sizeof 'size_t))])") (substring? option-result-wrapper - "(%echo_result (%typed-rust-handle-id r))")) + "(cons 'err (utf8->string (%typed-rust-take-byte-buffer (foreign-ref 'void* %err_ptr_box 0) (foreign-ref 'size_t %err_len_box 0))))")) + #t) + +(test "wrapper lowers Result Nat String params directly" + (and (substring? option-result-wrapper + "(foreign-procedure \"jt_sample_typed_option_result_echo_result\" (unsigned-8 unsigned-64 u8* size_t void* void* void*) unsigned-8)") + (substring? option-result-wrapper + "(unless (and (pair? r) (or (and (eq? (car r) 'ok) (%typed-rust-uint64? (cdr r))) (and (eq? (car r) 'err) (string? (cdr r)))))") + (substring? option-result-wrapper + "[%r_err_bytes (if (eq? (car r) 'err) (string->utf8 (cdr r)) #vu8())]") + (substring? option-result-wrapper + "(%echo_result (if (eq? (car r) 'ok) 1 0) (if (eq? (car r) 'ok) (cdr r) 0) %r_err_bytes (bytevector-length %r_err_bytes) %ok_out %err_ptr_box %err_len_box)")) #t) (test "wrapper lowers Result-scalar-scalar returns directly"