Support Typed Jerboa string inputs
ober
f79869de42dcc945f871317c0943cb1ba09ed9d5
--- a/docs/jerboa-to-rust.md +++ b/docs/jerboa-to-rust.md @@ -232,8 +232,9 @@ should get separate ABI wrappers. Current landing: scalar ABI-safe exported functions get generated Rust `extern "C"` wrappers, and `.ss` Jerboa wrapper files call those symbols through -Chez `foreign-procedure`. Non-scalar values still wait for opaque handles and -conversion records. +Chez `foreign-procedure`. `String` arguments can cross this boundary for +scalar-return functions as UTF-8 bytevector-plus-length pairs. Non-scalar +returns and owned values still wait for opaque handles and conversion records. ## Generics @@ -568,9 +569,11 @@ Second module: typed `rope`. - Support `Bool`, `Int`, `Nat`, `String`, `Bytes`. - Support function calls. -- Support `if`, `let`, arithmetic, comparisons. -- Generate wrappers. Initial scalar `.ss` wrappers landed; record, variant, - string, bytes, option, result, and handle conversions remain future work. +- Support `if`, `let`, arithmetic, comparisons. Initial `string-length` + support landed as a checked `(String -> Nat)` builtin. +- Generate wrappers. Initial scalar `.ss` wrappers and `String` argument + wrappers landed; record, variant, string return, bytes, option, result, and + handle conversions remain future work. ### Milestone 3: Records and Variants --- a/docs/typed-jerboa.md +++ b/docs/typed-jerboa.md @@ -156,10 +156,11 @@ Current landing: generated crates deny unsafe operations rather than claiming a blanket `forbid(unsafe_code)` once wrappers are present. - `(jerboa typed wrapper)`, `support/typed-wrappers.ss`, and `make - typed-wrappers` generate `.ss` Jerboa wrapper files for scalar ABI-safe - exports. The wrappers load the compiled Rust cdylib from - `JERBOA_TYPED_RUST_LIB`, validate dynamic arguments, call - `foreign-procedure`, and convert `Char` values through unsigned code points. + typed-wrappers` generate `.ss` Jerboa wrapper files for ABI-safe exports. + The wrappers load the compiled Rust cdylib from `JERBOA_TYPED_RUST_LIB`, + validate dynamic arguments, call `foreign-procedure`, convert `Char` values + through unsigned code points, and pass `String` arguments as UTF-8 + bytevector-plus-length pairs for scalar-return functions. - `make typed-wrapper-smoke` builds the primitive Rust fixture, generates its wrapper, loads the cdylib, and calls the generated Jerboa functions through Chez FFI. @@ -174,9 +175,10 @@ Current landing: literals, variables, `begin`, simple `let`, `if`, arithmetic primitives, numeric comparisons, boolean primitives, calls to typed functions defined in the same module, generated record/variant operations, and exhaustive - `match` over same-module variants. Imported calls and richer forms are - reported as unsupported. It does not yet resolve imports, lower to typed core - IR, compile generated Rust, or emit LLVM. + `match` over same-module variants. The first builtin string primitive, + `string-length`, is checked as `(String -> Nat)` and lowers to Rust + `.len()`. Imported calls and richer forms are reported as unsupported. It + does not yet resolve imports, lower to typed core IR, or emit LLVM. ## Surface Syntax @@ -809,10 +811,12 @@ Minimum excluded features: targets landed for a primitive typed fixture. - Compile generated Rust as a static or dynamic library. Initial disposable `rlib`/`staticlib`/`cdylib` builds landed. -- Generate conversion functions. Initial scalar argument checks and `Char` - code-point conversions landed at the wrapper boundary. +- Generate conversion functions. Initial scalar argument checks, `Char` + code-point conversions, and `String` argument UTF-8 bytevector conversions + landed at the wrapper boundary. - Generate Jerboa wrappers. Initial `.ss` wrapper generation landed for - scalar ABI-safe exported functions. + scalar ABI-safe exported functions and `String` arguments with scalar + returns. ### Milestone 4: First Real Module --- a/lib/jerboa/typed/checker.ss +++ b/lib/jerboa/typed/checker.ss @@ -201,6 +201,11 @@ (map typed-param-type (typed-def-params decl)) (typed-def-return-type decl))))) + (def builtin-call-signatures + (list + (cons 'string-length + (make-typed-call-sig (list 'String) 'Nat)))) + (def (field-types fields) (map typed-field-type fields)) @@ -260,7 +265,7 @@ (def (call-env declarations) (let loop ([rest declarations] [out '()]) (cond - [(null? rest) (reverse out)] + [(null? rest) (append builtin-call-signatures (reverse out))] [else (loop (cdr rest) (append (reverse (declaration-call-signatures (car rest))) --- a/lib/jerboa/typed/rust.ss +++ b/lib/jerboa/typed/rust.ss @@ -312,6 +312,10 @@ (memq type '(Unit Bool Char Int Nat Fixnum Float)) #t)) + (def (abi-safe-param-type? type) + (or (abi-safe-type? type) + (eq? type 'String))) + (def (abi-rust-type type) (case type [(Unit) "()"] @@ -328,7 +332,7 @@ (let loop ([params (typed-def-params def)]) (cond [(null? params) #t] - [(abi-safe-type? (typed-param-type (car params))) + [(abi-safe-param-type? (typed-param-type (car params))) (loop (cdr params))] [else #f])))) @@ -349,21 +353,52 @@ (rust-symbol-name (typed-def-name def)))) (def (emit-abi-param param) - (string-append - (rust-symbol-name (typed-param-name param)) - ": " - (abi-rust-type (typed-param-type param)))) + (let ([name (rust-symbol-name (typed-param-name param))]) + (case (typed-param-type param) + [(String) + (list + (string-append name "_ptr: *const u8") + (string-append name "_len: usize"))] + [else + (list + (string-append + name + ": " + (abi-rust-type (typed-param-type param))))]))) (def (emit-abi-param-conversion param port) - (when (eq? (typed-param-type param) 'Char) - (let ([name (rust-symbol-name (typed-param-name param))]) - (write-line port 1 - (string-append - "let " - name - " = char::from_u32(" - name - ").unwrap_or('\\u{FFFD}');"))))) + (let ([name (rust-symbol-name (typed-param-name param))]) + (case (typed-param-type param) + [(Char) + (write-line port 1 + (string-append + "let " + name + " = char::from_u32(" + name + ").unwrap_or('\\u{FFFD}');"))] + [(String) + (write-line port 1 (string-append "let " name " = {")) + (write-line port 2 + (string-append + "let bytes: &[u8] = if " + name + "_ptr.is_null() {")) + (write-line port 3 "&[]") + (write-line port 2 "} else {") + (write-line port 3 + "// unsafe: pointer and length are produced by the generated Jerboa wrapper.") + (write-line port 3 + (string-append + "unsafe { std::slice::from_raw_parts(" + name + "_ptr, " + name + "_len) }")) + (write-line port 2 "};") + (write-line port 2 "String::from_utf8_lossy(bytes).into_owned()") + (write-line port 1 "};")] + [else #f]))) (def (abi-return-expression def call) (case (typed-def-return-type def) @@ -388,7 +423,7 @@ "pub extern \"C\" fn " (abi-wrapper-name module def) "(" - (join-strings (map emit-abi-param params) ", ") + (join-strings (append-map emit-abi-param params) ", ") ") -> " (abi-rust-type (typed-def-return-type def)) " {")) @@ -571,6 +606,14 @@ (join-strings (map emit-match-clause (cdr args)) " ") " }")) + (def (emit-string-length args) + (unless (= (length args) 1) + (error 'typed-rust "string-length expects one operand" args)) + (string-append + "(" + (emit-expression (car args)) + ").len() as u64")) + (def (emit-call name args) (let ([record-constructor (lookup-record-constructor name)] [record-accessor (lookup-record-accessor name)] @@ -586,6 +629,8 @@ [variant-constructor (emit-variant-constructor-call variant-constructor args)] [variant-predicate "true"] + [(eq? name 'string-length) + (emit-string-length args)] [else (string-append (rust-symbol-name name) --- a/lib/jerboa/typed/wrapper.ss +++ b/lib/jerboa/typed/wrapper.ss @@ -40,6 +40,12 @@ (loop (cdr rest)))) (get-output-string port))])) + (def (append-map f xs) + (let loop ([rest xs] [out '()]) + (if (null? rest) + (reverse out) + (loop (cdr rest) (append (reverse (f (car rest))) out))))) + (def (write-indent port level) (let loop ([n level]) (when (> n 0) @@ -75,6 +81,11 @@ [(Float) 'double] [else (error 'typed-wrapper "unsupported ABI type" type)])) + (def (abi-chez-argument-types type) + (case type + [(String) '(u8* size_t)] + [else (list (abi-chez-type type))])) + (def (typed-module-wrapper-file-name module) (string-append (join-strings @@ -109,6 +120,7 @@ [(Nat) (string-append "(%typed-rust-uint64? " name ")")] [(Fixnum) (string-append "(fixnum? " name ")")] [(Float) (string-append "(real? " name ")")] + [(String) (string-append "(string? " name ")")] [else (error 'typed-wrapper "unsupported ABI parameter type" (typed-param-type param))]))) @@ -128,17 +140,39 @@ name-code "))")))) - (def (wrapper-argument-expression param) + (def (string-bytes-name param) + (string->symbol + (string-append + "%" + (rust-symbol-name (typed-param-name param)) + "_bytes"))) + + (def (string-param? param) + (eq? (typed-param-type param) 'String)) + + (def (has-string-param? params) + (let loop ([rest params]) + (cond + [(null? rest) #f] + [(string-param? (car rest)) #t] + [else (loop (cdr rest))]))) + + (def (wrapper-argument-expressions param) (let ([name (datum->code (typed-param-name param))]) (case (typed-param-type param) - [(Char) (string-append "(char->integer " name ")")] - [else name]))) + [(Char) (list (string-append "(char->integer " name ")"))] + [(String) + (let ([bytes-name (datum->code (string-bytes-name param))]) + (list + bytes-name + (string-append "(bytevector-length " bytes-name ")")))] + [else (list name)]))) (def (wrapper-call-expression def) (string-append "(" (datum->code (ffi-binding-name def)) - (let ([args (map wrapper-argument-expression (typed-def-params def))]) + (let ([args (append-map wrapper-argument-expressions (typed-def-params def))]) (if (null? args) "" (string-append " " (join-strings args " ")))) @@ -161,9 +195,11 @@ (datum->code (abi-wrapper-name module def)) " (" (join-strings - (map (lambda (param) - (datum->code (abi-chez-type (typed-param-type param)))) - (typed-def-params def)) + (append-map + (lambda (param) + (map datum->code + (abi-chez-argument-types (typed-param-type param)))) + (typed-def-params def)) " ") ") " (datum->code (abi-chez-type (typed-def-return-type def))) @@ -190,7 +226,31 @@ (lambda (param) (emit-param-check def param port)) params) - (write-line port 1 (wrapper-return-expression def)) + (if (has-string-param? params) + (begin + (write-line port 1 + (string-append + "(let (" + (join-strings + (map + (lambda (param) + (string-append + "[" + (datum->code (string-bytes-name param)) + " (string->utf8 " + (datum->code (typed-param-name param)) + ")]")) + (let loop ([rest params] [out '()]) + (cond + [(null? rest) (reverse out)] + [(string-param? (car rest)) + (loop (cdr rest) (cons (car rest) out))] + [else (loop (cdr rest) out)]))) + " ") + ")")) + (write-line port 2 (wrapper-return-expression def)) + (write-line port 1 ")")) + (write-line port 1 (wrapper-return-expression def))) (write-line port 0 ")") (newline port))) --- a/tests/fixtures/typed/rust-basic.ss +++ b/tests/fixtures/typed/rust-basic.ss @@ -1,5 +1,5 @@ (typed-library (sample typed rust-basic) - (export zero add-one positive? choose greeting double-add) + (export zero add-one positive? choose greeting double-add text-length) (def (zero) : Nat 0) @@ -18,4 +18,7 @@ (def (double-add (x : Nat)) : Nat (let ((y (+ x x))) - (+ y 1)))) + (+ y 1))) + + (def (text-length (text : String)) : Nat + (string-length text))) --- a/tests/test-typed-checker.ss +++ b/tests/test-typed-checker.ss @@ -271,6 +271,22 @@ (g x)))) '(return-type-mismatch)) +(test "builtin string-length returns Nat" + (error-kinds + '(typed-library (body string-length-ok) + (export f) + (def (f (x : String)) : Nat + (string-length x)))) + '()) + +(test "builtin string-length rejects non-String" + (error-kinds + '(typed-library (body string-length-bad) + (export f) + (def (f (x : Nat)) : Nat + (string-length x)))) + '(argument-type-mismatch)) + (test "record constructor and accessor calls" (error-kinds '(typed-library (body record-ok) --- a/tests/test-typed-rust.ss +++ b/tests/test-typed-rust.ss @@ -56,6 +56,15 @@ (define char-rust "// Generated by Jerboa's typed Rust backend. Do not edit.\n#![deny(unsafe_op_in_unsafe_fn)]\n#![allow(unused_parens)]\n#![allow(unused_variables)]\n\npub fn same_char(ch: char) -> char {\n ch\n}\n\n#[unsafe(no_mangle)]\npub extern \"C\" fn jt_sample_typed_char_same_char(ch: u32) -> u32 {\n let ch = char::from_u32(ch).unwrap_or('\\u{FFFD}');\n (same_char(ch) as u32)\n}\n\n") +(define string-form + '(typed-library (sample typed text) + (export text-length) + (def (text-length (s : String)) : Nat + (string-length s)))) + +(define string-rust + "// Generated by Jerboa's typed Rust backend. Do not edit.\n#![deny(unsafe_op_in_unsafe_fn)]\n#![allow(unused_parens)]\n#![allow(unused_variables)]\n\npub fn text_length(s: String) -> u64 {\n (s).len() as u64\n}\n\n#[unsafe(no_mangle)]\npub extern \"C\" fn jt_sample_typed_text_text_length(s_ptr: *const u8, s_len: usize) -> u64 {\n let s = {\n let bytes: &[u8] = if s_ptr.is_null() {\n &[]\n } else {\n // unsafe: pointer and length are produced by the generated Jerboa wrapper.\n unsafe { std::slice::from_raw_parts(s_ptr, s_len) }\n };\n String::from_utf8_lossy(bytes).into_owned()\n };\n text_length(s)\n}\n\n") + (define ops-form '(typed-library (sample typed ops) (export pane-id make-insert make-noop edit-size) @@ -97,6 +106,10 @@ (typed-library-form->rust-string char-form) char-rust) +(test "rust emits string input ABI conversions" + (typed-library-form->rust-string string-form) + string-rust) + (test "rust lowers record and variant operations" (typed-library-form->rust-string ops-form) ops-rust) --- a/tests/test-typed-wrapper-e2e.ss +++ b/tests/test-typed-wrapper-e2e.ss @@ -31,6 +31,7 @@ (check "positive?" (positive? 9)) (check "choose" (= (choose #t) 1)) (check "double-add" (= (double-add 20) 41)) +(check "text-length" (= (text-length "hello") 5)) (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 @@ -20,6 +20,15 @@ (begin (set! fail (+ fail 1)) (printf "FAIL ~a: got ~s expected ~s~%" name got expected)))))])) +(define (substring? haystack needle) + (let ([hlen (string-length haystack)] + [nlen (string-length needle)]) + (let loop ([i 0]) + (cond + [(> (+ i nlen) hlen) #f] + [(string=? (substring haystack i (+ i nlen)) needle) #t] + [else (loop (+ i 1))])))) + (define calc-form '(typed-library (sample typed calc) (export zero add-one) @@ -33,6 +42,15 @@ (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 %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) + (export text-length) + (def (text-length (s : String)) : Nat + (string-length s)))) + +(define string-wrapper + (typed-library-form->jerboa-wrapper-string string-form)) + (printf "--- Typed Jerboa wrapper tests ---~%") (test "wrapper maps Unit to void" @@ -55,6 +73,21 @@ (typed-library-form->jerboa-wrapper-string calc-form) calc-wrapper) +(test "wrapper binds String as u8* plus size_t" + (substring? string-wrapper + "(foreign-procedure \"jt_sample_typed_text_text_length\" (u8* size_t) unsigned-64)") + #t) + +(test "wrapper converts String args to utf8 bytevectors" + (substring? string-wrapper + "[%s_bytes (string->utf8 s)]") + #t) + +(test "wrapper passes String bytes and length" + (substring? string-wrapper + "(%text_length %s_bytes (bytevector-length %s_bytes))") + #t) + (printf "~%Typed wrapper: ~a passed, ~a failed~%" pass fail) (when (> fail 0) (exit 1))