Lower (Result Scalar Scalar) directly across the Typed Jerboa boundary
ober
fed5d2d95488e65f167670c148ac93a9be2c6ba9
--- a/docs/typed-jerboa.md +++ b/docs/typed-jerboa.md @@ -302,8 +302,12 @@ Highest-value next steps: 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 T E)` and `(Option <non-scalar>)` still cross - as opaque handles; direct conversion for those remains open. + 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. 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 @@ -347,6 +347,15 @@ (abi-safe-type? (cadr type)) (not (eq? (cadr type) 'Unit)))) + (def (abi-result-scalar-scalar-type? type) + (and (pair? type) + (eq? (car type) 'Result) + (= (length type) 3) + (abi-safe-type? (cadr type)) + (not (eq? (cadr type) 'Unit)) + (abi-safe-type? (caddr type)) + (not (eq? (caddr type) 'Unit)))) + (def (abi-handle-type? type) (or (and (symbol? type) @@ -354,7 +363,8 @@ (lookup-name type (*rust-variant-env*))) #t) (and (abi-option-result-handle-type? type) - (not (abi-option-scalar-type? type))))) + (not (abi-option-scalar-type? type)) + (not (abi-result-scalar-scalar-type? type))))) (def (abi-return-buffer-type? type) (and (symbol? type) @@ -365,13 +375,15 @@ (or (abi-safe-type? type) (abi-handle-type? type) (abi-return-buffer-type? type) - (abi-option-scalar-type? type))) + (abi-option-scalar-type? type) + (abi-result-scalar-scalar-type? type))) (def (abi-safe-param-type? type) (or (abi-safe-type? type) (memq type '(String Bytes)) (abi-handle-type? type) - (abi-option-scalar-type? type))) + (abi-option-scalar-type? type) + (abi-result-scalar-scalar-type? type))) (def (abi-rust-type type) (case type @@ -424,6 +436,11 @@ (list (string-append name "_tag: u8") (string-append name "_value: " (abi-rust-type (cadr type))))] + [(abi-result-scalar-scalar-type? type) + (list + (string-append name "_tag: u8") + (string-append name "_ok: " (abi-rust-type (cadr type))) + (string-append name "_err: " (abi-rust-type (caddr type))))] [(abi-handle-type? type) (list (string-append name "_handle: u64"))] [else @@ -602,6 +619,28 @@ "_tag != 0 { " some-expr " } else { None };")))] + [(abi-result-scalar-scalar-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)"))] + [err-expr + (if (eq? err-inner 'Char) + (string-append "Err(char::from_u32(" name "_err).unwrap_or('\\u{FFFD}'))") + (string-append "Err(" name "_err)"))]) + (write-line port 2 + (string-append + "let " + name + " = if " + name + "_tag != 0 { " + ok-expr + " } else { " + err-expr + " };")))] [(abi-handle-type? type) (write-line port 2 (string-append @@ -649,6 +688,8 @@ [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-result-scalar-scalar? + (abi-result-scalar-scalar-type? return-type)] [param-names (map (lambda (param) (rust-symbol-name (typed-param-name param))) params)] @@ -669,11 +710,20 @@ (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))))] [else '()]))] [extern-return-type (cond [return-buffer? "bool"] [return-option-scalar? "bool"] + [return-result-scalar-scalar? "u8"] [else (abi-rust-type return-type)])]) (write-line port 0 "#[unsafe(no_mangle)]") (write-line port 0 @@ -704,6 +754,21 @@ "; } true }")) (write-line port 3 "None => false,") (write-line port 2 "}"))] + [return-result-scalar-scalar? + (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 }")) + (write-line port 3 + (string-append + "Err(value) => { unsafe { *err_out = " + (if (eq? err-inner 'Char) "(value as u32)" "value") + "; } 0u8 }")) + (write-line port 2 "}"))] [else (write-line port 2 (abi-return-expression def call))]) (write-line port 1 "})) {") @@ -714,6 +779,7 @@ (cond [return-buffer? "false"] [return-option-scalar? "false"] + [return-result-scalar-scalar? "0u8"] [else (abi-default-expression return-type)]) ",")) (write-line port 1 "}") --- a/lib/jerboa/typed/wrapper.ss +++ b/lib/jerboa/typed/wrapper.ss @@ -110,10 +110,20 @@ (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 (module-handle-type? module type) (or (and (option-result-handle-type? type) - (not (option-scalar-type? type))) + (not (option-scalar-type? type)) + (not (result-scalar-scalar-type? type))) (and (symbol? type) (let loop ([decls (typed-module-declarations module)]) (cond @@ -135,13 +145,15 @@ (or (abi-wrapper-scalar-type? type) (module-handle-type? module type) (abi-wrapper-return-buffer-type? type) - (option-scalar-type? type))) + (option-scalar-type? type) + (result-scalar-scalar-type? type))) (def (wrapper-safe-param-type? module type) (or (abi-wrapper-scalar-type? type) (memq type '(String Bytes)) (module-handle-type? module type) - (option-scalar-type? type))) + (option-scalar-type? type) + (result-scalar-scalar-type? type))) (def (wrapper-safe-def? module def) (and (wrapper-safe-return-type? module (typed-def-return-type def)) @@ -156,6 +168,7 @@ (cond [(abi-wrapper-return-buffer-type? type) 'boolean] [(option-scalar-type? type) 'boolean] + [(result-scalar-scalar-type? type) 'unsigned-8] [(module-handle-type? module type) 'unsigned-64] [else (abi-chez-type type)])) @@ -164,6 +177,10 @@ [(memq type '(String Bytes)) '(u8* size_t)] [(option-scalar-type? type) (list 'unsigned-8 (abi-chez-type (cadr type)))] + [(result-scalar-scalar-type? type) + (list 'unsigned-8 + (abi-chez-type (cadr type)) + (abi-chez-type (caddr type)))] [(module-handle-type? module type) '(unsigned-64)] [else (list (abi-chez-type type))])) @@ -207,11 +224,20 @@ [(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)) + (let loop ([params (typed-def-params def)]) + (cond + [(null? params) #f] + [(result-scalar-scalar-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] [else (loop (cdr defs))]))) (def (chez-foreign-size-name type) @@ -314,6 +340,15 @@ "(or (eq? " name " #f) (and (pair? " name ") (eq? (car " name ") 'some) " (scalar-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 ")")) + ")))")] [(module-handle-type? module type) (string-append "(%typed-rust-handle? " @@ -380,6 +415,33 @@ " " (option-scalar-default-value (cadr type)) ")"))] + [(result-scalar-scalar-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 + (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 + ")")))] [(module-handle-type? module type) (list (string-append "(%typed-rust-handle-id " name ")"))] [else (list name)]))) @@ -432,6 +494,29 @@ ")" " #f))" " (lambda () (foreign-free %out))))"))] + [(result-scalar-scalar-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)]) + (string-append + "(let ([%ok_out (foreign-alloc (foreign-sizeof '" ok-ftype "))]" + " [%err_out (foreign-alloc (foreign-sizeof '" err-ftype "))])" + " (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) ")" + " (if (= 1 " + (wrapper-call-expression* module def '("%ok_out" "%err_out")) + ")" + " (cons 'ok " + (option-scalar-read-expression ok-inner "%ok_out") + ")" + " (cons 'err " + (option-scalar-read-expression err-inner "%err_out") + ")))" + " (lambda () (foreign-free %ok_out) (foreign-free %err_out))))"))] [(module-handle-type? module return-type) (string-append "(%typed-rust-make-handle " @@ -462,6 +547,7 @@ (cond [(abi-wrapper-return-buffer-type? return-type) '("void*" "void*")] [(option-scalar-type? return-type) '("void*")] + [(result-scalar-scalar-type? return-type) '("void*" "void*")] [else '()])) " ") ") " --- a/tests/fixtures/typed/rust-basic.ss +++ b/tests/fixtures/typed/rust-basic.ss @@ -1,7 +1,8 @@ (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 - token-debug maybe-value echo-maybe ok-value err-value echo-result) + token-debug maybe-value echo-maybe ok-value err-value echo-result + only-pos echo-only-pos) (record Box ((value : Nat))) @@ -71,4 +72,12 @@ (result-err Nat message)) (def (echo-result (r : (Result Nat String))) : (Result Nat String) + r) + + (def (only-pos (n : Nat)) : (Result Nat Bool) + (if (> n 0) + (result-ok n Bool) + (result-err Nat #f))) + + (def (echo-only-pos (r : (Result Nat Bool))) : (Result Nat Bool) r)) --- a/tests/test-typed-rust.ss +++ b/tests/test-typed-rust.ss @@ -323,7 +323,7 @@ "let maybe = if maybe_tag != 0 { Some(maybe_value) } else { None };")) #t) -(test "rust still uses handles for Option<non-scalar> and Result" +(test "rust still uses handles for Option<non-scalar> and 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())") @@ -334,6 +334,32 @@ (substring? option-result-rust "jt_store_handle(echo_result(r))")) #t) +(define result-scalar-form + '(typed-library (sample typed result-scalar) + (export only-pos echo-only-pos) + (def (only-pos (n : Nat)) : (Result Nat Bool) + (if (> n 0) + (result-ok n Bool) + (result-err Nat #f))) + (def (echo-only-pos (r : (Result Nat Bool))) : (Result Nat Bool) + r))) + +(define result-scalar-rust + (typed-library-form->rust-string result-scalar-form)) + +(test "rust emits result-scalar-scalar direct ABI wrappers" + (and (substring? result-scalar-rust + "pub extern \"C\" fn jt_sample_typed_result_scalar_only_pos(n: u64, ok_out: *mut u64, err_out: *mut bool) -> u8") + (substring? result-scalar-rust + "Ok(value) => { unsafe { *ok_out = value; } 1u8 }") + (substring? result-scalar-rust + "Err(value) => { unsafe { *err_out = value; } 0u8 }") + (substring? result-scalar-rust + "pub extern \"C\" fn jt_sample_typed_result_scalar_echo_only_pos(r_tag: u8, r_ok: u64, r_err: bool, ok_out: *mut u64, err_out: *mut bool) -> u8") + (substring? result-scalar-rust + "let r = if r_tag != 0 { Ok(r_ok) } else { Err(r_err) };")) + #t) + (test "rust lowers equal? primitive" (and (substring? equality-rust "pub fn same_text_p(a: String, b: String) -> bool") (substring? equality-rust "(a == b)") --- a/tests/test-typed-wrapper-e2e.ss +++ b/tests/test-typed-wrapper-e2e.ss @@ -90,6 +90,19 @@ (check "result handle rejects option" (raises? (lambda () (echo-result maybe-some)))) +(check "result-scalar Ok return" + (equal? (only-pos 5) (cons 'ok 5))) +(check "result-scalar Err return" + (equal? (only-pos 0) (cons 'err #f))) +(check "result-scalar Ok round trip" + (equal? (echo-only-pos (cons 'ok 42)) (cons 'ok 42))) +(check "result-scalar Err round trip" + (equal? (echo-only-pos (cons 'err #t)) (cons 'err #t))) +(check "result-scalar rejects bad shape" + (raises? (lambda () (echo-only-pos (cons 'maybe 1))))) +(check "result-scalar rejects wrong inner" + (raises? (lambda () (echo-only-pos (cons 'ok "string-not-nat"))))) + (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,19 @@ (define option-result-wrapper (typed-library-form->jerboa-wrapper-string option-result-form)) +(define result-scalar-form + '(typed-library (sample typed result-scalar) + (export only-pos echo-only-pos) + (def (only-pos (n : Nat)) : (Result Nat Bool) + (if (> n 0) + (result-ok n Bool) + (result-err Nat #f))) + (def (echo-only-pos (r : (Result Nat Bool))) : (Result Nat Bool) + r))) + +(define result-scalar-wrapper + (typed-library-form->jerboa-wrapper-string result-scalar-form)) + (printf "--- Typed Jerboa wrapper tests ---~%") (test "wrapper maps Unit to void" @@ -268,6 +281,22 @@ "(%echo_result (%typed-rust-handle-id r))")) #t) +(test "wrapper lowers Result-scalar-scalar returns directly" + (and (substring? result-scalar-wrapper + "(foreign-procedure \"jt_sample_typed_result_scalar_only_pos\" (unsigned-64 void* void*) unsigned-8)") + (substring? result-scalar-wrapper + "(if (= 1 (%only_pos n %ok_out %err_out)) (cons 'ok (foreign-ref 'unsigned-64 %ok_out 0)) (cons 'err (not (zero? (foreign-ref 'unsigned-8 %err_out 0)))))")) + #t) + +(test "wrapper lowers Result-scalar-scalar params directly" + (and (substring? result-scalar-wrapper + "(foreign-procedure \"jt_sample_typed_result_scalar_echo_only_pos\" (unsigned-8 unsigned-64 boolean void* void*) unsigned-8)") + (substring? result-scalar-wrapper + "(unless (and (pair? r) (or (and (eq? (car r) 'ok) (%typed-rust-uint64? (cdr r))) (and (eq? (car r) 'err) (boolean? (cdr r)))))") + (substring? result-scalar-wrapper + "(%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) + (printf "~%Typed wrapper: ~a passed, ~a failed~%" pass fail) (when (> fail 0) (exit 1))