Lower Typed Jerboa via core IR in Rust emitter
ober
e62bc719b7d72fe13a007ca3c132b3edc8038d3d
--- a/docs/jerboa-to-rust.md +++ b/docs/jerboa-to-rust.md @@ -81,13 +81,13 @@ Landed: Still open: -- Typed core IR adoption. The IR record types live in `(jerboa typed core)` - and the checker now elaborates def bodies into IR via - `check-and-elaborate-typed-module` (each def's body is a `typed-ir-begin` - wrapping inferred `typed-ir-lit`/`typed-ir-var`/`typed-ir-let`/`typed-ir-if`/ - `typed-ir-match`/`typed-ir-call` nodes with pre-resolved call kinds). The - Rust emitter still walks surface datums and needs to be switched over to - consume the IR. +- (Done) Typed core IR adoption. The IR record types live in + `(jerboa typed core)`, the checker elaborates def bodies into IR via + `check-and-elaborate-typed-module`, and the Rust emitter + (`typed-module->rust-string`, `typed-modules->rust-crate-string`, and their + library-form siblings) now consumes the IR through `*rust-ir-env*`. Future + rust.ss work can prune the surface fall-back paths once the wrapper + generator follows. - Import resolution between typed modules. - Structured Rust-to-Scheme error returns instead of conservative panic defaults. --- a/docs/typed-jerboa.md +++ b/docs/typed-jerboa.md @@ -231,8 +231,8 @@ Current landing: as `(Bytes -> Nat)` and lowers the same way. `debug-string` checks one typed operand and lowers to Rust `format!("{:?}", ...)`, using the Debug derives on generated records and variants. Imported calls and richer forms are reported - as unsupported. It does not yet resolve imports, lower to typed core IR, or - emit LLVM. + as unsupported. Typed core IR is now produced by the checker and consumed by + the Rust emitter; imports and LLVM emission are still TODO. - `Option` and `Result` type expressions now have explicit checked constructors in the front end: `(option-some expr)`, `(option-none Type)`, `(result-ok expr ErrorType)`, and `(result-err ValueType expr)`. Rust @@ -280,10 +280,12 @@ Code that has landed: The next model should continue in small commits with tests and docs per step. Highest-value next steps: -1. Continue the typed core IR rollout. The IR record types live in - `(jerboa typed core)` and the checker now elaborates def bodies into IR via - `check-and-elaborate-typed-module`. The remaining step is to switch the - Rust emitter to consume IR rather than re-walking surface datums. +1. (Done) Typed core IR rollout. The IR record types live in + `(jerboa typed core)`; the checker elaborates def bodies via + `check-and-elaborate-typed-module`; and the Rust emitter consumes that + IR through `*rust-ir-env*` in `typed-module->rust-string` and + `typed-modules->rust-crate-string`. The wrapper generator still walks + surface AST, which is fine for ABI-level shape information. 2. Resolve imports between typed modules. The checker currently handles calls within one typed module only; imported calls are intentionally unsupported. 3. Improve boundary semantics for Option/Result. They currently cross the FFI --- a/lib/jerboa/typed/rust.ss +++ b/lib/jerboa/typed/rust.ss @@ -19,11 +19,14 @@ (import (chezscheme) ; jerboa-security: suppress direct-chezscheme-import-user-code -- trusted typed compiler Rust emitter (only (jerboa core) def) (jerboa typed parser) - (jerboa typed checker)) + (jerboa typed checker) + (jerboa typed core)) (def *rust-record-env* (make-parameter '())) (def *rust-variant-env* (make-parameter '())) (def *rust-variant-case-env* (make-parameter '())) + ;; alist of (def-name . typed-ir-begin) populated per module by emit-module + (def *rust-ir-env* (make-parameter '())) (def (emit-to-string thunk) (let ([port (open-output-string)]) @@ -998,8 +1001,170 @@ (join-strings (map emit-argument-expression args) ", ") ")")]))) + (def (emit-ir-expression ir) + (cond + [(typed-ir-lit? ir) (emit-expression (typed-ir-lit-value ir))] + [(typed-ir-var? ir) (rust-symbol-name (typed-ir-var-name ir))] + [(typed-ir-begin? ir) (emit-begin (typed-ir-begin-exprs ir))] + [(typed-ir-let? ir) (emit-ir-let ir)] + [(typed-ir-if? ir) (emit-ir-if ir)] + [(typed-ir-match? ir) (emit-ir-match ir)] + [(typed-ir-call? ir) (emit-ir-call ir)] + [else (error 'typed-rust "unsupported IR node" ir)])) + + (def (emit-ir-let ir) + (string-append + "{ " + (join-strings + (append + (map (lambda (binding) + (string-append + "let " + (rust-symbol-name (typed-ir-binding-name binding)) + " = " + (emit-expression (typed-ir-binding-expr binding)) + ";")) + (typed-ir-let-bindings ir)) + (list (emit-begin (typed-ir-let-body ir)))) + " ") + " }")) + + (def (emit-ir-if ir) + (string-append + "if " + (emit-expression (typed-ir-if-test ir)) + " { " + (emit-expression (typed-ir-if-then ir)) + " } else { " + (emit-expression (typed-ir-if-else ir)) + " }")) + + (def (emit-ir-match-clause clause) + (let* ([case-name (typed-ir-match-clause-case clause)] + [bindings (typed-ir-match-clause-bindings clause)] + [body (typed-ir-match-clause-body clause)] + [case-entry (lookup-variant-constructor case-name)]) + (unless case-entry + (error 'typed-rust "unknown variant case in match IR" case-name)) + (string-append + (emit-match-case-pattern case-entry bindings) + " => " + (emit-match-branch-body + (emit-match-recursive-bindings + (car case-entry) + (typed-variant-case-fields (cdr case-entry)) + bindings) + body) + ","))) + + (def (emit-ir-match ir) + (let* ([target (typed-ir-match-scrutinee ir)] + [clauses (typed-ir-match-clauses ir)] + [default (typed-ir-match-default ir)] + [default-clause + (and default + (string-append "_ => " (emit-begin default) ","))]) + (string-append + "match " + (emit-expression target) + " { " + (join-strings + (append + (map emit-ir-match-clause clauses) + (if default-clause (list default-clause) '())) + " ") + " }"))) + + (def (ir-call-info-ref ir key) + (let ([entry (assq key (typed-ir-call-info ir))]) + (and entry (cdr entry)))) + + (def (emit-ir-call ir) + (let ([kind (typed-ir-call-kind ir)] + [operator (typed-ir-call-operator ir)] + [args (typed-ir-call-args ir)]) + (case kind + [(prim-arith) + (emit-binary-chain (symbol->string operator) args)] + [(prim-cmp) + (emit-binary-chain + (case operator + [(=) "=="] [(<) "<"] [(<=) "<="] [(>) ">"] [(>=) ">="] + [else (error 'typed-rust "unknown cmp operator" operator)]) + args)] + [(prim-eq) (emit-equality args)] + [(prim-bool) + (case operator + [(not) + (unless (= (length args) 1) + (error 'typed-rust "not expects one operand" args)) + (string-append "(!" (emit-expression (car args)) ")")] + [(and) (emit-bool-chain "&&" args)] + [(or) (emit-bool-chain "||" args)] + [else (error 'typed-rust "unknown bool operator" operator)])] + [(string-length) (emit-string-length args)] + [(string-append) (emit-string-append args)] + [(bytevector-length) (emit-bytevector-length args)] + [(debug-string) (emit-debug-string args)] + [(record-ctor) + (let ([record (lookup-name (ir-call-info-ref ir 'record) + (*rust-record-env*))]) + (unless record + (error 'typed-rust "unknown record in IR call" + (ir-call-info-ref ir 'record))) + (emit-record-constructor-call record args))] + [(record-pred) "true"] + [(record-accessor) + (let* ([record-name (ir-call-info-ref ir 'record)] + [field-name (ir-call-info-ref ir 'field)] + [record (lookup-name record-name (*rust-record-env*))] + [field (and record + (let loop ([rest (typed-record-fields record)]) + (cond + [(null? rest) #f] + [(eq? (typed-field-name (car rest)) field-name) + (car rest)] + [else (loop (cdr rest))])))]) + (unless field + (error 'typed-rust "unknown record field in IR call" + (list record-name field-name))) + (emit-record-accessor-call (cons record field) args))] + [(record-setter) "()"] + [(variant-ctor) + (let* ([variant-name (ir-call-info-ref ir 'variant)] + [case-name (ir-call-info-ref ir 'case)] + [variant (lookup-name variant-name (*rust-variant-env*))] + [case + (and variant + (let loop ([rest (typed-variant-cases variant)]) + (cond + [(null? rest) #f] + [(eq? (typed-variant-case-name (car rest)) case-name) + (car rest)] + [else (loop (cdr rest))])))]) + (unless case + (error 'typed-rust "unknown variant case in IR call" + (list variant-name case-name))) + (emit-variant-constructor-call (cons variant case) args))] + [(variant-pred) "true"] + [(option-some) + (string-append "Some(" (emit-argument-expression (car args)) ")")] + [(option-none) "None"] + [(result-ok) + (string-append "Ok(" (emit-argument-expression (car args)) ")")] + [(result-err) + (string-append "Err(" (emit-argument-expression (car args)) ")")] + [(function) + (string-append + (rust-symbol-name operator) + "(" + (join-strings (map emit-argument-expression args) ", ") + ")")] + [else (error 'typed-rust "unknown IR call kind" kind)]))) + (def (emit-expression expr) (cond + [(typed-ir-node? expr) (emit-ir-expression expr)] [(boolean? expr) (if expr "true" "false")] [(char? expr) (rust-char-literal expr)] [(string? expr) @@ -1051,7 +1216,12 @@ [else (error 'typed-rust "unsupported expression" expr)])) (def (emit-def def port) - (let ([params (join-strings (map emit-param (typed-def-params def)) ", ")]) + (let* ([params (join-strings (map emit-param (typed-def-params def)) ", ")] + [ir-entry (assq (typed-def-name def) (*rust-ir-env*))] + [body-text + (cond + [ir-entry (emit-expression (cdr ir-entry))] + [else (emit-begin (strip-source-annotations (typed-def-body def)))])]) (write-line port 0 (string-append "pub fn " @@ -1061,8 +1231,7 @@ ") -> " (rust-type (typed-def-return-type def)) " {")) - (write-line port 1 - (emit-begin (strip-source-annotations (typed-def-body def)))) + (write-line port 1 body-text) (write-line port 0 "}") (newline port))) @@ -1097,40 +1266,50 @@ (emit-runtime-helpers (list module) port) (emit-module-declarations module port)) - (def (typed-module->rust-string module) - (let ([errors (check-typed-module module)]) + (def (elaborate-module-or-error module who) + (let-values ([(errors defs) + (check-and-elaborate-typed-module module)]) (unless (null? errors) - (error 'typed-module->rust-string + (error who "typed module has check errors" (map typed-check-error-kind errors))) + ;; Build an alist of (def-name . body-ir) for emit-def lookups. + (map (lambda (ed) + (cons (elaborated-def-name ed) + (elaborated-def-body-ir ed))) + defs))) + + (def (typed-module->rust-string module) + (let ([ir-env (elaborate-module-or-error module 'typed-module->rust-string)]) (with-rust-env (list module) (lambda () - (emit-to-string - (lambda (port) - (emit-module module port))))))) + (parameterize ([*rust-ir-env* ir-env]) + (emit-to-string + (lambda (port) + (emit-module module port)))))))) (def (typed-library-form->rust-string form) (typed-module->rust-string (parse-typed-library form))) (def (typed-modules->rust-crate-string modules) - (for-each - (lambda (module) - (let ([errors (check-typed-module module)]) - (unless (null? errors) - (error 'typed-modules->rust-crate-string - "typed module has check errors" - (map typed-check-error-kind errors))))) - modules) - (with-rust-env modules - (lambda () - (emit-to-string - (lambda (port) - (emit-rust-header port) - (emit-runtime-helpers modules port) - (for-each - (lambda (module) - (emit-module-declarations module port)) - modules)))))) + (let ([ir-envs + (map (lambda (m) + (elaborate-module-or-error + m 'typed-modules->rust-crate-string)) + modules)]) + (with-rust-env modules + (lambda () + (emit-to-string + (lambda (port) + (emit-rust-header port) + (emit-runtime-helpers modules port) + (let loop ([rest-modules modules] [rest-envs ir-envs]) + (cond + [(null? rest-modules) #f] + [else + (parameterize ([*rust-ir-env* (car rest-envs)]) + (emit-module-declarations (car rest-modules) port)) + (loop (cdr rest-modules) (cdr rest-envs))])))))))) (def (typed-library-forms->rust-crate-string forms) (typed-modules->rust-crate-string (map parse-typed-library forms)))