typed/llvmir: String/Bytes core (P1 of secmon port)
ober
66469ac04a66a8df565003146040b4c673dbd243
--- a/Makefile +++ b/Makefile @@ -40,7 +40,7 @@ PURE_AUDIT_ARGS ?= --summary --discover $(PURE_AUDIT_ROOT) TYPED_SOURCES ?= tests/fixtures/typed/valid-split-tree.ss TYPED_RUST_SOURCES ?= $(TYPED_SOURCES) TYPED_RUST_DIR ?= build/typed/rust -TYPED_LLVMIR_SOURCES ?= tests/fixtures/typed/llvmir-basic.ss tests/fixtures/typed/llvmir-if.ss tests/fixtures/typed/llvmir-call.ss tests/fixtures/typed/llvmir-float.ss tests/fixtures/typed/llvmir-bitwise.ss tests/fixtures/typed/llvmir-for-fold.ss tests/fixtures/typed/llvmir-smoke.ss +TYPED_LLVMIR_SOURCES ?= tests/fixtures/typed/llvmir-basic.ss tests/fixtures/typed/llvmir-if.ss tests/fixtures/typed/llvmir-call.ss tests/fixtures/typed/llvmir-float.ss tests/fixtures/typed/llvmir-bitwise.ss tests/fixtures/typed/llvmir-for-fold.ss tests/fixtures/typed/llvmir-bytes.ss tests/fixtures/typed/llvmir-smoke.ss TYPED_LLVMIR_DIR ?= build/typed/llvmir TYPED_LLVMIR_SMOKE_MODULE ?= sample_typed_llvmir_smoke TYPED_LLVMIR_SMOKE_EXPECT ?= 42 --- a/lib/jerboa/typed/llvmir.ss +++ b/lib/jerboa/typed/llvmir.ss @@ -99,24 +99,39 @@ ;; --- types ----------------------------------------------------------------- + ;; String and Bytes share one representation: a by-value fat pointer + ;; { ptr, i64 } of (data, length). Both carry raw bytes (UTF-8 for String), + ;; so string->utf8 / utf8->string are value-level identities. The buffers + ;; are immutable: params point at caller memory, bytes-build allocates fresh. + (def buffer-llvm-type "{ ptr, i64 }") + + (def (buffer-type? type) + (and (symbol? type) (memq type '(String Bytes)) #t)) + (def (llvm-type type) (case type [(Bool) "i1"] [(Nat Int) "i64"] [(Float) "double"] + [(String Bytes) buffer-llvm-type] [(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)) + ;; A type that can be a function parameter or return value: scalars and + ;; buffers directly, plus record types (resolved structurally elsewhere). + (def (value-type? type) + (or (scalar-value-type? type) (buffer-type? type))) + (def (llvm-return-type type) - (if (or (eq? type 'Unit) (scalar-value-type? type)) + (if (or (eq? type 'Unit) (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) + (if (value-type? type) (llvm-type type) (error 'typed-llvmir "unsupported parameter type for LLVM lowering" type))) @@ -151,18 +166,67 @@ (defstruct llvm-function (name return-type params blocks)) ;; Callable signature for direct same-module calls. (defstruct llvm-fn-sig (symbol return-type param-types)) + ;; Module-shared emission context: `declare` lines, string-literal globals, + ;; and a counter for unique global names. Shared across every function of a + ;; module so intrinsics and identical literals are emitted once. + (defstruct llvm-mod-ctx (intrinsics globals counter)) + + (def (make-empty-mod-ctx) + (make-llvm-mod-ctx (box '()) (box '()) (box 0))) + ;; Mutable per-function emission state. vars maps Jerboa names to ;; llvm-value records; fns maps def names to llvm-fn-sig records; - ;; intrinsics is a module-shared box of `declare` lines in first-use order. + ;; ctx is the module-shared llvm-mod-ctx. (defstruct llvm-env (value-counter label-counter blocks current-label current-instrs vars fns - intrinsics)) + ctx)) (def (require-intrinsic! env decl) - (let ([b (llvm-env-intrinsics env)]) + (let ([b (llvm-mod-ctx-intrinsics (llvm-env-ctx env))]) (unless (member decl (unbox b)) (set-box! b (cons decl (unbox b)))))) + ;; Intern a byte buffer as a private global constant and return its symbol. + ;; Identical contents share one global (dedup by the rendered bytes), so + ;; repeated string literals like "/tmp/" emit a single constant. + (def (intern-bytes-global! env bv) + (let* ([ctx (llvm-env-ctx env)] + [globals (llvm-mod-ctx-globals ctx)] + [array-type + (string-append "[" (number->string (bytevector-length bv)) " x i8]")] + [body (string-append array-type " " (llvm-bytes-constant bv))] + [existing (assoc body (unbox globals))]) + (cond + [existing (cdr existing)] + [else + (let* ([counter (llvm-mod-ctx-counter ctx)] + [n (unbox counter)] + [name (string-append "@.bytes." (number->string n))]) + (set-box! counter (+ n 1)) + (set-box! globals (cons (cons body name) (unbox globals))) + name)]))) + + ;; Render a bytevector as an LLVM c"..." string constant. Bytes outside the + ;; printable, non-escaping ASCII range use \HH; LLVM requires \5C for "\" + ;; and \22 for the quote. + (def (llvm-bytes-constant bv) + (let ([port (open-output-string)] + [len (bytevector-length bv)]) + (write-char #\c port) + (write-char #\" port) + (let loop ([i 0]) + (when (< i len) + (let ([b (bytevector-u8-ref bv i)]) + (cond + [(or (< b 32) (> b 126) (= b 34) (= b 92)) + (write-char #\\ port) + (write-char (string-ref hex-digits (quotient b 16)) port) + (write-char (string-ref hex-digits (remainder b 16)) port)] + [else (write-char (integer->char b) port)])) + (loop (+ i 1)))) + (write-char #\" port) + (get-output-string port))) + (def unit-value (make-llvm-value "void" "")) (def (fresh-value! env) @@ -211,27 +275,50 @@ (def (lower-expr env ir) (cond - [(typed-ir-lit? ir) (lower-lit ir)] + [(typed-ir-lit? ir) (lower-lit env 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))] [(typed-ir-let? ir) (lower-let env ir)] [(typed-ir-if? ir) (lower-if env ir)] [(typed-ir-for-fold? ir) (lower-for-fold env ir)] + [(typed-ir-bytes-build? ir) (lower-bytes-build env ir)] [(typed-ir-call? ir) (lower-call env ir)] [else (error 'typed-llvmir "unsupported typed IR node for LLVM lowering" ir)])) - (def (lower-lit ir) + (def (lower-lit env 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))] + [(String) (lower-buffer-literal env (string->utf8 value))] + [(Bytes) (lower-buffer-literal env value)] [else (error 'typed-llvmir "unsupported literal type for LLVM lowering" type)]))) + ;; Build a { ptr, i64 } value pointing at an interned private constant. + (def (lower-buffer-literal env bv) + (let* ([global (intern-bytes-global! env bv)] + [len (number->string (bytevector-length bv))] + [array-type (string-append "[" len " x i8]")] + [ptr-reg (fresh-value! env)] + [t0 (fresh-value! env)] + [result (fresh-value! env)]) + (emit-instr! env + (string-append + ptr-reg " = getelementptr " array-type ", ptr " global + ", i64 0, i64 0")) + (emit-instr! env + (string-append + t0 " = insertvalue " buffer-llvm-type " undef, ptr " ptr-reg ", 0")) + (emit-instr! env + (string-append + result " = insertvalue " buffer-llvm-type " " t0 ", i64 " len ", 1")) + (make-llvm-value buffer-llvm-type result))) + (def (lower-var env ir) (let ([value (lookup-var env (typed-ir-var-name ir))]) (unless value @@ -366,6 +453,111 @@ (start-block! env exit-label) (make-llvm-value acc-ty acc-reg))))) + ;; (bytes-build size (i body)) allocates a fresh `size`-byte buffer and fills + ;; byte i with (body & 0xff), i running 0..size. Lowers to malloc + a store + ;; loop, yielding a { ptr, i64 } Bytes value. The buffer is never freed + ;; (analysis kernels are short-lived; ownership/GC is future work). + (def (lower-bytes-build env ir) + (require-intrinsic! env "declare ptr @malloc(i64)") + (let* ([size (lower-operand env (typed-ir-bytes-build-size ir) "i64" + 'bytes-build)] + [buf (fresh-value! env)]) + (emit-instr! env + (string-append buf " = call ptr @malloc(i64 " (llvm-value-text size) ")")) + (let* ([n (number->string (fresh-label-index! env))] + [head-label (string-append "build_head" n)] + [body-label (string-append "build_body" n)] + [exit-label (string-append "build_exit" n)] + [pre-label (llvm-env-current-label env)] + [idx-reg (fresh-value! env)] + [cond-reg (fresh-value! env)] + [head-block (make-llvm-block head-label '())]) + (finish-block! env (string-append "br label %" head-label)) + (llvm-env-blocks-set! env (cons head-block (llvm-env-blocks env))) + (start-block! env body-label) + (let ([saved-vars (llvm-env-vars env)]) + (bind-var! env (typed-ir-bytes-build-var-name ir) + (make-llvm-value "i64" idx-reg)) + (let* ([val (lower-operand env (typed-ir-bytes-build-body ir) "i64" + 'bytes-build)] + [body-end (llvm-env-current-label env)] + [b8 (fresh-value! env)] + [ep (fresh-value! env)] + [inc-reg (fresh-value! env)]) + (llvm-env-vars-set! env saved-vars) + (emit-instr! env + (string-append b8 " = trunc i64 " (llvm-value-text val) " to i8")) + (emit-instr! env + (string-append ep " = getelementptr i8, ptr " buf ", i64 " idx-reg)) + (emit-instr! env (string-append "store i8 " b8 ", ptr " ep)) + (emit-instr! env (string-append inc-reg " = add i64 " idx-reg ", 1")) + (finish-block! env (string-append "br label %" head-label)) + (llvm-block-instrs-set! head-block + (list + (string-append + idx-reg " = phi i64 [ 0, %" pre-label " ]" + ", [ " inc-reg ", %" body-end " ]") + (string-append + cond-reg " = icmp ult i64 " idx-reg ", " (llvm-value-text size)) + (string-append + "br i1 " cond-reg + ", label %" body-label ", label %" exit-label))) + (start-block! env exit-label) + (let ([t0 (fresh-value! env)] + [result (fresh-value! env)]) + (emit-instr! env + (string-append + t0 " = insertvalue " buffer-llvm-type " undef, ptr " buf ", 0")) + (emit-instr! env + (string-append + result " = insertvalue " buffer-llvm-type " " t0 + ", i64 " (llvm-value-text size) ", 1")) + (make-llvm-value buffer-llvm-type result))))))) + + ;; --- buffer primitives ------------------------------------------------------- + + ;; string->utf8 / utf8->string are value-level identities: String and Bytes + ;; share the { ptr, i64 } representation and both hold raw UTF-8 bytes. + (def (lower-buffer-identity env args context) + (unless (= (length args) 1) + (error 'typed-llvmir "buffer conversion expects one operand" context)) + (lower-operand env (car args) buffer-llvm-type context)) + + ;; (bytevector-length b) / (string-length s): the i64 length field. + (def (lower-buffer-length env args context) + (unless (= (length args) 1) + (error 'typed-llvmir "length expects one operand" context)) + (let ([buf (lower-operand env (car args) buffer-llvm-type context)] + [result (fresh-value! env)]) + (emit-instr! env + (string-append + result " = extractvalue " buffer-llvm-type " " + (llvm-value-text buf) ", 1")) + (make-llvm-value "i64" result))) + + ;; (bytevector-u8-ref b i): zero-extend the i-th byte to i64. No bounds check + ;; (the kernels guard indices; matches the Rust backend's [i] indexing). + (def (lower-bytevector-u8-ref env args) + (unless (= (length args) 2) + (error 'typed-llvmir "bytevector-u8-ref expects two operands" args)) + (let* ([buf (lower-operand env (car args) buffer-llvm-type 'bytevector-u8-ref)] + [idx (lower-operand env (cadr args) "i64" 'bytevector-u8-ref)] + [ptr-reg (fresh-value! env)] + [ep (fresh-value! env)] + [byte (fresh-value! env)] + [result (fresh-value! env)]) + (emit-instr! env + (string-append + ptr-reg " = extractvalue " buffer-llvm-type " " + (llvm-value-text buf) ", 0")) + (emit-instr! env + (string-append + ep " = getelementptr i8, ptr " ptr-reg ", i64 " (llvm-value-text idx))) + (emit-instr! env (string-append byte " = load i8, ptr " ep)) + (emit-instr! env + (string-append result " = zext i8 " byte " to i64")) + (make-llvm-value "i64" result))) + ;; --- call lowering ----------------------------------------------------------- ;; Lower an operand and require it to have the expected LLVM type. Mixed @@ -643,6 +835,11 @@ [(prim-shift) (lower-shift env operator args type)] [(exact->inexact) (lower-to-float env args)] [(log2) (lower-log2 env args)] + [(string->utf8) (lower-buffer-identity env args 'string->utf8)] + [(utf8->string) (lower-buffer-identity env args 'utf8->string)] + [(string-length) (lower-buffer-length env args 'string-length)] + [(bytevector-length) (lower-buffer-length env args 'bytevector-length)] + [(bytevector-u8-ref) (lower-bytevector-u8-ref env args)] [(function) (lower-function-call env operator args)] [else (error 'typed-llvmir "unsupported call kind for LLVM lowering" kind)]))) @@ -652,10 +849,10 @@ (def (param-llvm-name index) (string-append "%a" (number->string index))) - (def (lower-def module-name fns intrinsics def body-ir) + (def (lower-def module-name fns ctx def body-ir) (let* ([params (typed-def-params def)] [return-type (typed-def-return-type def)] - [env (make-llvm-env 0 0 '() #f '() '() fns intrinsics)]) + [env (make-llvm-env 0 0 '() #f '() '() fns ctx)]) ;; 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]) @@ -786,22 +983,19 @@ (error 'typed-llvmir "unsupported main return type for @main" (typed-def-return-type main-def))])))))) - ;; Returns (cons functions intrinsic-declarations). - (def (module-functions module) + ;; Lower one module's defs into the shared fns map and ctx, appending the + ;; resulting llvm-function records (reversed) onto `acc`. Used by both the + ;; single-module and whole-program emitters. + (def (lower-module-defs! module fns ctx acc) (let ([ir-env (elaborate-module-or-error module 'typed-module->llvmir-string)] - [fns (module-fn-env module)] - [module-name (typed-module-name module)] - [intrinsics (box '())]) - (let loop ([rest (typed-module-declarations module)] [out '()]) + [module-name (typed-module-name module)]) + (let loop ([rest (typed-module-declarations module)] [out acc]) (cond [(null? rest) (let ([main-def (smoke-main-def module)]) - (cons - (reverse - (if main-def - (cons (main-wrapper-function module-name main-def) out) - out)) - (reverse (unbox intrinsics))))] + (if main-def + (cons (main-wrapper-function module-name main-def) out) + out))] [(typed-def? (car rest)) (let* ([def (car rest)] [entry (assq (typed-def-name def) ir-env)]) @@ -809,10 +1003,34 @@ (error 'typed-llvmir "no elaborated IR for def" (typed-def-name def))) (loop (cdr rest) - (cons (lower-def module-name fns intrinsics def (cdr entry)) - out)))] + (cons (lower-def module-name fns ctx def (cdr entry)) out)))] [else (loop (cdr rest) out)])))) + ;; Returns (cons functions ctx). + (def (module-functions module) + (let ([fns (module-fn-env module)] + [ctx (make-empty-mod-ctx)]) + (cons (reverse (lower-module-defs! module fns ctx '())) ctx))) + + ;; Render a module context's prelude: string-literal globals first, then + ;; intrinsic declares. Both are emitted once per textual module. + (def (render-mod-ctx-prelude ctx port) + (let ([globals (reverse (unbox (llvm-mod-ctx-globals ctx)))] + [intrinsics (reverse (unbox (llvm-mod-ctx-intrinsics ctx)))]) + (for-each + (lambda (entry) + (display (cdr entry) port) + (display " = private unnamed_addr constant " port) + (display (car entry) port) + (newline port)) + globals) + (for-each + (lambda (decl) (display decl port) (newline port)) + intrinsics) + ;; blank line before the first function when the prelude emitted anything + (unless (and (null? globals) (null? intrinsics)) + (newline port)))) + (def (render-module-header module port) (display "; Generated by Jerboa's typed LLVM IR backend. Do not edit." port) (newline port) @@ -824,16 +1042,11 @@ (def (typed-module->llvmir-string module) (let* ([lowered (module-functions module)] [functions (car lowered)] - [declarations (cdr lowered)]) + [ctx (cdr lowered)]) (emit-to-string (lambda (port) (render-module-header module port) - (for-each - (lambda (decl) - (display decl port) - (newline port)) - declarations) - (unless (null? declarations) (newline port)) + (render-mod-ctx-prelude ctx port) (let loop ([rest functions] [first? #t]) (unless (null? rest) (unless first? (newline port)) new file mode 100644 --- /dev/null +++ b/tests/fixtures/typed/llvmir-bytes.ss @@ -0,0 +1,30 @@ +(typed-library (sample typed llvmir-bytes) + (export greeting text-len byte-at to-bytes xor-buf first-eq?) + + ;; a bare String literal return + (def (greeting) : String + "hello") + + ;; String/Bytes length (extractvalue of the fat pointer) + (def (text-len (s : String)) : Nat + (string-length s)) + + ;; index a byte out of a buffer + (def (byte-at (b : Bytes) (i : Nat)) : Nat + (bytevector-u8-ref b i)) + + ;; string->utf8 is a value-level identity + (def (to-bytes (s : String)) : Bytes + (string->utf8 s)) + + ;; bytes-build: XOR every byte with a key into a fresh buffer + (def (xor-buf (data : Bytes) (key : Nat)) : Bytes + (bytes-build (bytevector-length data) + (i (bitwise-xor (bytevector-u8-ref data i) key)))) + + ;; literal compare: does the first byte equal the first byte of "h"? + (def (first-eq? (s : String)) : Bool + (let ((bs (string->utf8 s)) + (h (string->utf8 "h"))) + (and (> (bytevector-length bs) 0) + (= (bytevector-u8-ref bs 0) (bytevector-u8-ref h 0)))))) --- a/tests/test-typed-llvmir.ss +++ b/tests/test-typed-llvmir.ss @@ -471,6 +471,83 @@ (string=? fold-ll (typed-library-form->llvmir-string fold-form)) #t) +;; --- String / Bytes lowering -------------------------------------------------------- + +(define bytes-form + '(typed-library (sample typed llvmir-bytes) + (export greeting text-len byte-at to-bytes xor-buf first-eq?) + (def (greeting) : String + "hello") + (def (text-len (s : String)) : Nat + (string-length s)) + (def (byte-at (b : Bytes) (i : Nat)) : Nat + (bytevector-u8-ref b i)) + (def (to-bytes (s : String)) : Bytes + (string->utf8 s)) + (def (xor-buf (data : Bytes) (key : Nat)) : Bytes + (bytes-build (bytevector-length data) + (i (bitwise-xor (bytevector-u8-ref data i) key)))) + (def (first-eq? (s : String)) : Bool + (let ((bs (string->utf8 s)) + (h (string->utf8 "h"))) + (and (> (bytevector-length bs) 0) + (= (bytevector-u8-ref bs 0) (bytevector-u8-ref h 0))))))) + +(define bytes-ll (typed-library-form->llvmir-string bytes-form)) + +(test "String and Bytes are the {ptr,i64} fat pointer" + (and (substring? bytes-ll "define { ptr, i64 } @jt_llvm_sample_typed_llvmir_bytes__greeting()") + (substring? bytes-ll "define { ptr, i64 } @jt_llvm_sample_typed_llvmir_bytes__to_bytes({ ptr, i64 } %a0)")) + #t) + +(test "string literal interns a private byte constant" + (and (substring? bytes-ll "@.bytes.0 = private unnamed_addr constant [5 x i8] c\"hello\"") + (substring? bytes-ll "getelementptr [5 x i8], ptr @.bytes.0, i64 0, i64 0")) + #t) + +(test "string literal builds the fat pointer with its length" + (and (substring? bytes-ll "insertvalue { ptr, i64 } undef, ptr %v0, 0") + (substring? bytes-ll "insertvalue { ptr, i64 } %v1, i64 5, 1")) + #t) + +(test "string-length extracts the length field" + (substring? bytes-ll "%v0 = extractvalue { ptr, i64 } %a0, 1") + #t) + +(test "bytevector-u8-ref does extractvalue + gep + load + zext" + (and (substring? bytes-ll "%v0 = extractvalue { ptr, i64 } %a0, 0") + (substring? bytes-ll "%v1 = getelementptr i8, ptr %v0, i64 %a1") + (substring? bytes-ll "%v2 = load i8, ptr %v1") + (substring? bytes-ll "%v3 = zext i8 %v2 to i64")) + #t) + +(test "string->utf8 is a value identity (returns its operand)" + (substring? bytes-ll "ret { ptr, i64 } %a0") + #t) + +(test "bytes-build mallocs and stores in a loop" + (and (substring? bytes-ll "declare ptr @malloc(i64)") + (substring? bytes-ll "call ptr @malloc(i64 ") + (substring? bytes-ll "build_head") + (substring? bytes-ll "store i8 ") + (substring? bytes-ll "trunc i64 ")) + #t) + +(test "identical literals share one global" + ;; "h" appears twice in first-eq?'s body but interns once + (let loop ([i 0] [count 0]) + (let ([idx (let scan ([j i]) + (cond + [(> (+ j 4) (string-length bytes-ll)) #f] + [(string=? (substring bytes-ll j (+ j 4)) "c\"h\"") j] + [else (scan (+ j 1))]))]) + (if idx (loop (+ idx 1) (+ count 1)) count))) + 1) + +(test "bytes emission is deterministic across runs" + (string=? bytes-ll (typed-library-form->llvmir-string bytes-form)) + #t) + ;; --- @main smoke wrapper -------------------------------------------------------- (define smoke-form @@ -521,7 +598,7 @@ ;; --- rejection of unsupported shapes ------------------------------------------------ -(test "string-returning defs are rejected" +(test "string-returning defs are accepted" (guard (exn [#t 'rejected]) (typed-library-form->llvmir-string '(typed-library (sample typed llvmir-strings) @@ -529,15 +606,15 @@ (def (greeting) : String "hello"))) 'accepted) - 'rejected) + 'accepted) -(test "record declarations are rejected" +(test "option-returning defs 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))))) + '(typed-library (sample typed llvmir-option) + (export maybe) + (def (maybe (x : Nat)) : (Option Nat) + (option-some x)))) 'accepted) 'rejected)