typed/llvmir: add LLVM IR backend skeleton (Phase 1)
ober
01f84d1daa4f883d23de530e7223dd2ff372aa07
--- a/Makefile +++ b/Makefile @@ -42,7 +42,7 @@ TYPED_RUST_SOURCES ?= $(TYPED_SOURCES) TYPED_RUST_DIR ?= build/typed/rust TYPED_WRAPPER_DIR ?= build/typed/jerboa -.PHONY: help chez chez-cross build binary binary-typed binary-typed-smoke binary-cross native-cross pure-audit typecheck typed-rust typed-wrappers typed-build typed-wrapper-smoke typed-split-tree-smoke typed-test typed-clean test test-reader test-core test-runtime test-stdlib test-ffi test-modules test-expanded test-contract test-ergo test-limits-primitives test-typed-core test-typed-parser test-typed-checker test-typed-rust test-typed-wrappers test-pure-audit test-features test-wrappers test-phase4a test-phase4b test-phase4c test-phase4d test-phase4e test-phase4f test-phase5 test-phase5e test-phase6 test-phase7 test-phase8 test-functional test-repl test-security test-security-profile test-native test-gaps native clean-native audit-native clean security security-production security-profile fuzz fuzz-smoke fuzz-deep fuzz-reader-fuzz fuzz-json-fuzz fuzz-http2-fuzz fuzz-dns-fuzz fuzz-pregexp-fuzz fuzz-csv-fuzz fuzz-base64-fuzz fuzz-hex-fuzz fuzz-uri-fuzz fuzz-format-fuzz fuzz-router-fuzz fuzz-sandbox-fuzz test-rawstring test-regex test-rx test-peg test-regex-all check-docs check-docs-strict docker-build docker-push +.PHONY: help chez chez-cross build binary binary-typed binary-typed-smoke binary-cross native-cross pure-audit typecheck typed-rust typed-wrappers typed-build typed-wrapper-smoke typed-split-tree-smoke typed-test typed-clean test test-reader test-core test-runtime test-stdlib test-ffi test-modules test-expanded test-contract test-ergo test-limits-primitives test-typed-core test-typed-parser test-typed-checker test-typed-rust test-typed-llvmir test-typed-wrappers test-pure-audit test-features test-wrappers test-phase4a test-phase4b test-phase4c test-phase4d test-phase4e test-phase4f test-phase5 test-phase5e test-phase6 test-phase7 test-phase8 test-functional test-repl test-security test-security-profile test-native test-gaps native clean-native audit-native clean security security-production security-profile fuzz fuzz-smoke fuzz-deep fuzz-reader-fuzz fuzz-json-fuzz fuzz-http2-fuzz fuzz-dns-fuzz fuzz-pregexp-fuzz fuzz-csv-fuzz fuzz-base64-fuzz fuzz-hex-fuzz fuzz-uri-fuzz fuzz-format-fuzz fuzz-router-fuzz fuzz-sandbox-fuzz test-rawstring test-regex test-rx test-peg test-regex-all check-docs check-docs-strict docker-build docker-push help: @echo "Usage: make <target>" @@ -139,6 +139,7 @@ help: @echo " test-typed-parser Typed Jerboa parser tests" @echo " test-typed-checker Typed Jerboa checker tests" @echo " test-typed-rust Typed Jerboa Rust emitter tests" + @echo " test-typed-llvmir Typed Jerboa LLVM IR emitter tests" @echo " test-typed-wrappers Typed Jerboa wrapper generator tests" @echo " test-pure-audit Pure Jerboa migration scanner tests" @echo "" @@ -838,7 +839,7 @@ typed-split-tree-smoke: build/typed/split-tree-smoke/sample_typed_split_tree.ss \ tests/test-typed-split-tree-caller.ss -typed-test: test-typed-core test-typed-parser test-typed-checker test-typed-rust test-typed-wrappers test-typed-fuzz typecheck +typed-test: test-typed-core test-typed-parser test-typed-checker test-typed-rust test-typed-llvmir test-typed-wrappers test-typed-fuzz typecheck # Build a jerboa-bin that bakes in a Typed Jerboa Rust .a archive. The # generated wrapper resolves its `jt_*` symbols via dlsym(RTLD_DEFAULT) — no @@ -935,6 +936,9 @@ test-typed-checker: test-typed-rust: @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-typed-rust.ss +test-typed-llvmir: + @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-typed-llvmir.ss + test-typed-wrappers: @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-typed-wrappers.ss new file mode 100644 --- /dev/null +++ b/lib/jerboa/typed/llvmir.ss @@ -0,0 +1,389 @@ +#!chezscheme +;;; (jerboa typed llvmir) -- experimental textual LLVM IR backend for Typed Jerboa +;;; +;;; Lowers the checked typed core IR (the same elaborated module/def data the +;;; Rust backend consumes) to deterministic textual LLVM IR (.ll). This is a +;;; narrow, verifier-driven path: it supports scalar functions only and +;;; deliberately rejects anything it cannot lower yet. Rust remains the +;;; reference backend; see docs/llvmir-handoff.md. +;;; +;;; Representation: +;;; Bool -> i1 +;;; Nat -> i64 (unsigned operations: udiv, icmp ult, ...) +;;; Int -> i64 (signed operations: sdiv, icmp slt, ...) +;;; Float -> double +;;; Unit -> void (function returns only) + +(library (jerboa typed llvmir) + (export + llvm-symbol-name + llvm-module-mangle + llvm-function-symbol + llvm-float-literal + typed-module->llvmir-string + typed-library-form->llvmir-string + typed-library-forms->llvmir-module) + + (import (chezscheme) ; jerboa-security: suppress direct-chezscheme-import-user-code -- trusted typed compiler LLVM IR emitter + (only (jerboa core) def defstruct) + (jerboa typed parser) + (jerboa typed checker) + (jerboa typed core)) + + ;; --- small string helpers -------------------------------------------------- + + (def (emit-to-string thunk) + (let ([port (open-output-string)]) + (thunk port) + (get-output-string port))) + + (def (join-strings strings separator) + (cond + [(null? strings) ""] + [else + (let ([port (open-output-string)]) + (display (car strings) port) + (let loop ([rest (cdr strings)]) + (unless (null? rest) + (display separator port) + (display (car rest) port) + (loop (cdr rest)))) + (get-output-string port))])) + + ;; --- identifier mangling --------------------------------------------------- + ;; + ;; Generated LLVM identifiers must be deterministic and valid. Unquoted LLVM + ;; names match [a-zA-Z$._][a-zA-Z$._0-9]*; user identifiers are never trusted + ;; raw. One mangler is shared by function and module names. + + (def (identifier-start? ch) + (or (char-alphabetic? ch) (char=? ch #\_))) + + (def (identifier-char? ch) + (or (identifier-start? ch) (char-numeric? ch))) + + (def (write-llvm-ident-char ch port) + (cond + [(identifier-char? ch) (write-char ch port)] + [(char=? ch #\-) (write-char #\_ port)] + [(char=? ch #\?) (display "_p" port)] + [(char=? ch #\!) (display "_bang" port)] + [else (write-char #\_ port)])) + + (def (sanitize-llvm-ident raw) + (let ([port (open-output-string)]) + (let loop ([chars (string->list raw)]) + (unless (null? chars) + (write-llvm-ident-char (car chars) port) + (loop (cdr chars)))) + (let ([name (get-output-string port)]) + (cond + [(string=? name "") "_"] + [(not (identifier-start? (string-ref name 0))) + (string-append "_" name)] + [else name])))) + + (def (llvm-symbol-name sym) + (sanitize-llvm-ident (symbol->string sym))) + + (def (llvm-module-mangle module-name) + (join-strings (map llvm-symbol-name module-name) "_")) + + ;; Function symbol shape: @jt_llvm_<module_mangle>__<def_mangle> + (def (llvm-function-symbol module-name def-name) + (string-append + "jt_llvm_" + (llvm-module-mangle module-name) + "__" + (llvm-symbol-name def-name))) + + ;; --- types ----------------------------------------------------------------- + + (def (llvm-type type) + (case type + [(Bool) "i1"] + [(Nat Int) "i64"] + [(Float) "double"] + [(Unit) "void"] + [else (error 'typed-llvmir "unsupported type for LLVM lowering" type)])) + + (def (scalar-value-type? type) + (and (symbol? type) (memq type '(Bool Nat Int Float)) #t)) + + (def (llvm-return-type type) + (if (or (eq? type 'Unit) (scalar-value-type? type)) + (llvm-type type) + (error 'typed-llvmir "unsupported return type for LLVM lowering" type))) + + (def (llvm-param-type type) + (if (scalar-value-type? type) + (llvm-type type) + (error 'typed-llvmir "unsupported parameter type for LLVM lowering" type))) + + ;; --- literals ---------------------------------------------------------------- + + (def hex-digits "0123456789ABCDEF") + + ;; LLVM textual float syntax is picky; the always-valid spelling for a + ;; double constant is the 16-hex-digit bit pattern (e.g. 4.25 -> + ;; 0x4011000000000000), which is also stable across printers. + (def (llvm-float-literal x) + (let ([bv (make-bytevector 8)]) + (bytevector-ieee-double-set! bv 0 x (endianness big)) + (let ([port (open-output-string)]) + (display "0x" port) + (let loop ([i 0]) + (when (< i 8) + (let ([b (bytevector-u8-ref bv i)]) + (write-char (string-ref hex-digits (quotient b 16)) port) + (write-char (string-ref hex-digits (remainder b 16)) port)) + (loop (+ i 1)))) + (get-output-string port)))) + + ;; --- emitter records --------------------------------------------------------- + + ;; A lowered value: textual LLVM type plus operand text (SSA name or constant). + (defstruct llvm-value (type text)) + ;; A finished basic block: label plus instruction lines in final order; the + ;; terminator is the last line. instrs may be patched late for loop headers. + (defstruct llvm-block (label instrs)) + ;; A rendered function definition. + (defstruct llvm-function (name return-type params blocks)) + ;; Callable signature for direct same-module calls. + (defstruct llvm-fn-sig (symbol return-type param-types)) + ;; Mutable per-function emission state. vars maps Jerboa names to + ;; llvm-value records; fns maps def names to llvm-fn-sig records. + (defstruct llvm-env + (value-counter label-counter blocks current-label current-instrs vars fns)) + + (def unit-value (make-llvm-value "void" "")) + + (def (fresh-value! env) + (let ([n (llvm-env-value-counter env)]) + (llvm-env-value-counter-set! env (+ n 1)) + (string-append "%v" (number->string n)))) + + (def (fresh-label-index! env) + (let ([n (llvm-env-label-counter env)]) + (llvm-env-label-counter-set! env (+ n 1)) + n)) + + (def (emit-instr! env text) + (llvm-env-current-instrs-set! env + (cons text (llvm-env-current-instrs env)))) + + (def (start-block! env label) + (llvm-env-current-label-set! env label) + (llvm-env-current-instrs-set! env '())) + + ;; Close the open block with exactly one terminator and archive it. + (def (finish-block! env terminator) + (llvm-env-blocks-set! env + (cons (make-llvm-block + (llvm-env-current-label env) + (reverse (cons terminator (llvm-env-current-instrs env)))) + (llvm-env-blocks env))) + (llvm-env-current-label-set! env #f) + (llvm-env-current-instrs-set! env '())) + + (def (bind-var! env name value) + (llvm-env-vars-set! env (cons (cons name value) (llvm-env-vars env)))) + + (def (lookup-var env name) + (let ([entry (assq name (llvm-env-vars env))]) + (and entry (cdr entry)))) + + (def (lookup-fn env name) + (let ([entry (assq name (llvm-env-fns env))]) + (and entry (cdr entry)))) + + ;; --- expression lowering ----------------------------------------------------- + ;; + ;; lower-expr appends instructions to the env's open block and returns the + ;; result as an llvm-value. Control flow (if) closes and opens blocks. + + (def (lower-expr env ir) + (cond + [(typed-ir-lit? ir) (lower-lit ir)] + [(typed-ir-var? ir) (lower-var env ir)] + [(typed-ir-begin? ir) + (lower-begin env (typed-ir-begin-exprs ir) (typed-ir-begin-type ir))] + [else + (error 'typed-llvmir "unsupported typed IR node for LLVM lowering" ir)])) + + (def (lower-lit ir) + (let ([type (typed-ir-lit-type ir)] + [value (typed-ir-lit-value ir)]) + (case type + [(Bool) (make-llvm-value "i1" (if value "true" "false"))] + [(Nat Int) (make-llvm-value "i64" (number->string value))] + [(Float) (make-llvm-value "double" (llvm-float-literal value))] + [else + (error 'typed-llvmir "unsupported literal type for LLVM lowering" type)]))) + + (def (lower-var env ir) + (let ([value (lookup-var env (typed-ir-var-name ir))]) + (unless value + (error 'typed-llvmir "unbound variable in LLVM lowering" + (typed-ir-var-name ir))) + value)) + + (def (lower-begin env exprs type) + (cond + [(null? exprs) unit-value] + [else + (let loop ([rest exprs]) + (let ([value (lower-expr env (car rest))]) + (if (null? (cdr rest)) + value + (loop (cdr rest)))))])) + + ;; --- function lowering --------------------------------------------------------- + + (def (param-llvm-name index) + (string-append "%a" (number->string index))) + + (def (lower-def module-name fns def body-ir) + (let* ([params (typed-def-params def)] + [return-type (typed-def-return-type def)] + [env (make-llvm-env 0 0 '() #f '() '() fns)]) + ;; Positional parameter names (%a0, %a1, ...) cannot collide with %vN + ;; locals, so user identifiers never appear as raw LLVM names. + (let loop ([rest params] [i 0]) + (unless (null? rest) + (bind-var! env (typed-param-name (car rest)) + (make-llvm-value + (llvm-param-type (typed-param-type (car rest))) + (param-llvm-name i))) + (loop (cdr rest) (+ i 1)))) + (start-block! env "entry") + (let ([result (lower-expr env body-ir)]) + (finish-block! env + (if (eq? return-type 'Unit) + "ret void" + (string-append + "ret " (llvm-value-type result) " " (llvm-value-text result)))) + (make-llvm-function + (llvm-function-symbol module-name (typed-def-name def)) + (llvm-return-type return-type) + (let loop ([rest params] [i 0] [out '()]) + (if (null? rest) + (reverse out) + (loop (cdr rest) (+ i 1) + (cons (string-append + (llvm-param-type (typed-param-type (car rest))) + " " + (param-llvm-name i)) + out)))) + (reverse (llvm-env-blocks env)))))) + + ;; --- rendering ----------------------------------------------------------------- + + (def (render-block block port) + (display (llvm-block-label block) port) + (display ":" port) + (newline port) + (for-each + (lambda (instr) + (display " " port) + (display instr port) + (newline port)) + (llvm-block-instrs block))) + + (def (render-function fn port) + (display "define " port) + (display (llvm-function-return-type fn) port) + (display " @" port) + (display (llvm-function-name fn) port) + (display "(" port) + (display (join-strings (llvm-function-params fn) ", ") port) + (display ") {" port) + (newline port) + (let loop ([rest (llvm-function-blocks fn)] [first? #t]) + (unless (null? rest) + (unless first? (newline port)) + (render-block (car rest) port) + (loop (cdr rest) #f))) + (display "}" port) + (newline port)) + + ;; --- module lowering -------------------------------------------------------------- + + (def (module-fn-env module) + (let ([module-name (typed-module-name module)]) + (let loop ([rest (typed-module-declarations module)] [out '()]) + (cond + [(null? rest) (reverse out)] + [(typed-def? (car rest)) + (let ([def (car rest)]) + (loop (cdr rest) + (cons (cons (typed-def-name def) + (make-llvm-fn-sig + (llvm-function-symbol + module-name (typed-def-name def)) + (typed-def-return-type def) + (map typed-param-type (typed-def-params def)))) + out)))] + [else + (error 'typed-llvmir + "only function definitions are supported by the LLVM backend" + (car rest))])))) + + (def (elaborate-module-or-error module who) + (let-values ([(errors defs) + (check-and-elaborate-typed-module module)]) + (unless (null? errors) + (error who + "typed module has check errors" + (map typed-check-error-kind errors))) + (map (lambda (ed) + (cons (elaborated-def-name ed) + (elaborated-def-body-ir ed))) + defs))) + + (def (module-functions module) + (let ([ir-env (elaborate-module-or-error module 'typed-module->llvmir-string)] + [fns (module-fn-env module)] + [module-name (typed-module-name module)]) + (let loop ([rest (typed-module-declarations module)] [out '()]) + (cond + [(null? rest) (reverse out)] + [(typed-def? (car rest)) + (let* ([def (car rest)] + [entry (assq (typed-def-name def) ir-env)]) + (unless entry + (error 'typed-llvmir "no elaborated IR for def" + (typed-def-name def))) + (loop (cdr rest) + (cons (lower-def module-name fns def (cdr entry)) out)))] + [else (loop (cdr rest) out)])))) + + (def (render-module-header module port) + (display "; Generated by Jerboa's typed LLVM IR backend. Do not edit." port) + (newline port) + (display "; module: " port) + (display (llvm-module-mangle (typed-module-name module)) port) + (newline port) + (newline port)) + + (def (typed-module->llvmir-string module) + (emit-to-string + (lambda (port) + (render-module-header module port) + (let loop ([rest (module-functions module)] [first? #t]) + (unless (null? rest) + (unless first? (newline port)) + (render-function (car rest) port) + (loop (cdr rest) #f)))))) + + (def (typed-library-form->llvmir-string form) + (typed-module->llvmir-string (parse-typed-library form))) + + ;; Concatenate independent modules into one textual LLVM module. The MVP + ;; supports direct same-module calls only, so modules are checked and + ;; lowered independently (cross-module imports are checker errors). + (def (typed-library-forms->llvmir-module forms) + (let ([strings (map typed-library-form->llvmir-string forms)]) + (join-strings strings "\n"))) + +) ;; end library new file mode 100644 --- /dev/null +++ b/support/typed-llvmir.ss @@ -0,0 +1,131 @@ +#!chezscheme +;;; typed-llvmir.ss -- generate textual LLVM IR from Typed Jerboa source files +;;; +;;; Usage: +;;; scheme --libdirs lib --script support/typed-llvmir.ss OUT-DIR file.ss ... +;;; +;;; Writes one <module_mangle>.ll per typed-library form found in the input +;;; files, e.g. build/typed/llvmir/sample_typed_llvmir_basic.ll. + +(import (chezscheme) ; jerboa-security: suppress direct-chezscheme-import-user-code -- trusted typed LLVM IR generator script + (jerboa reader) + (jerboa typed parser) + (jerboa typed llvmir)) + +(define (usage) + (display "Usage: scheme --libdirs lib --script support/typed-llvmir.ss OUT-DIR file.ss ...\n")) + +(define (string-split-slash text) + (let ([len (string-length text)]) + (let loop ([i 0] [start 0] [out '()]) + (cond + [(= i len) + (let ([part (substring text start i)]) + (reverse (if (string=? part "") out (cons part out))))] + [(char=? (string-ref text i) #\/) + (let ([part (substring text start i)]) + (loop (+ i 1) + (+ i 1) + (if (string=? part "") out (cons part out))))] + [else (loop (+ i 1) start out)])))) + +(define (absolute-path? path) + (and (> (string-length path) 0) + (char=? (string-ref path 0) #\/))) + +(define (path-join2 base part) + (cond + [(string=? base "") part] + [(string=? base "/") (string-append "/" part)] + [else (string-append base "/" part)])) + +(define (path-has-parent-reference? path) + (let loop ([parts (string-split-slash path)]) + (cond + [(null? parts) #f] + [(string=? (car parts) "..") #t] + [else (loop (cdr parts))]))) + +(define (validate-output-path path) + (when (path-has-parent-reference? path) + (error 'typed-llvmir + "output paths must not contain parent directory references" + path)) + path) + +(define (ensure-directory path) + (cond + [(file-directory? path) #t] + [(file-exists? path) + (error 'typed-llvmir "path exists but is not a directory" path)] + [else + (mkdir path) + #t])) + +(define (ensure-directory-tree path) + (let ([parts (string-split-slash path)] + [root (if (absolute-path? path) "/" "")]) + (let loop ([rest parts] [current root]) + (unless (null? rest) + (let ([next (path-join2 current (car rest))]) + (ensure-directory next) + (loop (cdr rest) next)))))) + +(define (write-file-string path text) + (let ([safe-path (validate-output-path path)] + [port #f]) + (dynamic-wind + (lambda () + (set! port (open-output-file safe-path 'replace))) + (lambda () (display text port)) + (lambda () + (when port + (close-port port)))))) + +(define (typed-library-forms forms) + (let loop ([rest forms] [out '()]) + (cond + [(null? rest) (reverse out)] + [(typed-library-form? (car rest)) + (loop (cdr rest) (cons (car rest) out))] + [else + (loop (cdr rest) out)]))) + +(define (read-typed-library-forms path) + (typed-library-forms (jerboa-read-file path))) + +(define (read-all-typed-library-forms paths) + (let loop ([rest paths] [out '()]) + (if (null? rest) + (reverse out) + (loop (cdr rest) + (append (reverse (read-typed-library-forms (car rest))) out))))) + +(define (generate-llvmir out-dir source-paths) + (let* ([safe-out-dir (validate-output-path out-dir)] + [forms (read-all-typed-library-forms source-paths)]) + (when (null? forms) + (error 'typed-llvmir "no typed-library forms found" source-paths)) + (ensure-directory-tree safe-out-dir) + (for-each + (lambda (form) + (let* ([module (parse-typed-library form)] + [file-name + (string-append + (llvm-module-mangle (typed-module-name module)) + ".ll")] + [path (path-join2 safe-out-dir file-name)]) + (write-file-string path (typed-module->llvmir-string module)))) + forms) + (printf "Typed Jerboa LLVM IR: wrote ~a module~a to ~a\n" + (length forms) + (if (= (length forms) 1) "" "s") + safe-out-dir))) + +(define args (command-line-arguments)) + +(when (< (length args) 2) + (usage) + (exit 2)) + +(generate-llvmir (car args) (cdr args)) new file mode 100644 --- /dev/null +++ b/tests/fixtures/typed/llvmir-basic.ss @@ -0,0 +1,11 @@ +(typed-library (sample typed llvmir-basic) + (export answer truthy echo) + + (def (answer) : Nat + 42) + + (def (truthy) : Bool + #t) + + (def (echo (x : Nat)) : Nat + x)) new file mode 100644 --- /dev/null +++ b/tests/test-typed-llvmir.ss @@ -0,0 +1,168 @@ +#!chezscheme +;;; Tests for (jerboa typed llvmir) + +(import (chezscheme) + (jerboa typed parser) + (jerboa typed llvmir)) + +(define pass 0) +(define fail 0) + +(define-syntax test + (syntax-rules () + [(_ name expr expected) + (guard (exn [#t (set! fail (+ fail 1)) + (printf "FAIL ~a: exception ~a~%" name + (if (message-condition? exn) (condition-message exn) exn))]) + (let ([got expr]) + (if (equal? got expected) + (begin (set! pass (+ pass 1)) + (printf " ok ~a~%" name)) + (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))])))) + +;; --- mangling --------------------------------------------------------------- + +(test "symbol mangling keeps plain names" + (llvm-symbol-name 'answer) + "answer") + +(test "symbol mangling rewrites dashes" + (llvm-symbol-name 'add-one) + "add_one") + +(test "symbol mangling rewrites predicates" + (llvm-symbol-name 'positive?) + "positive_p") + +(test "symbol mangling rewrites bangs" + (llvm-symbol-name 'set-it!) + "set_it_bang") + +(test "module mangling joins parts" + (llvm-module-mangle '(sample typed llvmir-basic)) + "sample_typed_llvmir_basic") + +(test "function symbols are deterministic" + (llvm-function-symbol '(sample typed llvmir-basic) 'add-one) + "jt_llvm_sample_typed_llvmir_basic__add_one") + +;; --- float literals ----------------------------------------------------------- + +(test "float literal 4.25" + (llvm-float-literal 4.25) + "0x4011000000000000") + +(test "float literal 1.5" + (llvm-float-literal 1.5) + "0x3FF8000000000000") + +(test "float literal 0.1 round-trips bit pattern" + (llvm-float-literal 0.1) + "0x3FB999999999999A") + +(test "float literal negative" + (llvm-float-literal -2.0) + "0xC000000000000000") + +;; --- basic module emission ------------------------------------------------------ + +(define basic-form + '(typed-library (sample typed llvmir-basic) + (export answer truthy echo) + (def (answer) : Nat + 42) + (def (truthy) : Bool + #t) + (def (echo (x : Nat)) : Nat + x))) + +(define basic-ll (typed-library-form->llvmir-string basic-form)) + +(test "module header names the backend" + (substring? basic-ll + "; Generated by Jerboa's typed LLVM IR backend. Do not edit.") + #t) + +(test "module header names the module" + (substring? basic-ll "; module: sample_typed_llvmir_basic") + #t) + +(test "nat literal function defines i64" + (substring? basic-ll + "define i64 @jt_llvm_sample_typed_llvmir_basic__answer() {") + #t) + +(test "nat literal function returns the literal" + (substring? basic-ll "ret i64 42") + #t) + +(test "bool literal function defines i1" + (substring? basic-ll + "define i1 @jt_llvm_sample_typed_llvmir_basic__truthy() {") + #t) + +(test "bool literal function returns true" + (substring? basic-ll "ret i1 true") + #t) + +(test "param echo binds positional names" + (substring? basic-ll + "define i64 @jt_llvm_sample_typed_llvmir_basic__echo(i64 %a0) {") + #t) + +(test "param echo returns the parameter" + (substring? basic-ll "ret i64 %a0") + #t) + +(test "entry blocks are labelled" + (substring? basic-ll "entry:") + #t) + +;; --- determinism ------------------------------------------------------------------ + +(test "emission is deterministic across runs" + (string=? basic-ll (typed-library-form->llvmir-string basic-form)) + #t) + +(test "forms->module emission is deterministic" + (string=? (typed-library-forms->llvmir-module (list basic-form)) + (typed-library-forms->llvmir-module (list basic-form))) + #t) + +;; --- rejection of unsupported shapes ------------------------------------------------ + +(test "string-returning defs are rejected" + (guard (exn [#t 'rejected]) + (typed-library-form->llvmir-string + '(typed-library (sample typed llvmir-strings) + (export greeting) + (def (greeting) : String + "hello"))) + 'accepted) + 'rejected) + +(test "record declarations are rejected" + (guard (exn [#t 'rejected]) + (typed-library-form->llvmir-string + '(typed-library (sample typed llvmir-records) + (export make-Box Box?) + (record Box + ((value : Nat))))) + 'accepted) + 'rejected) + +;; --- summary ------------------------------------------------------------------------- + +(printf "~%~a passed, ~a failed~%" pass fail) +(when (> fail 0) + (exit 1))