typed/llvmir: records + aggregate for/fold accumulators (P2)
ober
33994513f75ba0e66d8b7b947ccabac34ed374d4
--- 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-bytes.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-record.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 @@ -108,22 +108,50 @@ (def (buffer-type? type) (and (symbol? type) (memq type '(String Bytes)) #t)) + ;; Records lower to by-value LLVM structs. The env maps a record name to its + ;; typed-record so type/ctor/accessor lowering can resolve fields and order. + ;; Set during emission; empty outside it. + (def *llvm-record-env* (make-parameter '())) + + (def (lookup-record name) + (let ([entry (assq name (*llvm-record-env*))]) + (and entry (cdr entry)))) + + (def (record-type? type) + (and (symbol? type) (lookup-record type) #t)) + + ;; Structural struct type: { <field0-llvm-type>, <field1-llvm-type>, ... }. + ;; Structural (not a named %T) so no type definitions need emitting; the + ;; checker already enforced field correctness. Recursive records are not + ;; supported (they would recurse forever here). + (def (record-llvm-type record) + (string-append + "{ " + (join-strings + (map (lambda (field) (llvm-type (typed-field-type field))) + (typed-record-fields record)) + ", ") + " }")) + (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)])) + (cond + [(record-type? type) (record-llvm-type (lookup-record type))] + [else + (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). + ;; buffers directly, plus record types (resolved structurally). (def (value-type? type) - (or (scalar-value-type? type) (buffer-type? type))) + (or (scalar-value-type? type) (buffer-type? type) (record-type? type))) (def (llvm-return-type type) (if (or (eq? type 'Unit) (value-type? type)) @@ -558,6 +586,66 @@ (string-append result " = zext i8 " byte " to i64")) (make-llvm-value "i64" result))) + ;; --- record primitives ------------------------------------------------------- + + (def (ir-call-info-ref ir key) + (let ([entry (assq key (typed-ir-call-info ir))]) + (and entry (cdr entry)))) + + ;; (make-R f0 f1 ...) builds a by-value struct with an insertvalue chain, + ;; one field at a time into `undef`. + (def (lower-record-ctor env ir args) + (let* ([record-name (ir-call-info-ref ir 'record)] + [record (lookup-record record-name)]) + (unless record + (error 'typed-llvmir "unknown record in LLVM ctor" record-name)) + (let* ([fields (typed-record-fields record)] + [struct-ty (record-llvm-type record)]) + (unless (= (length fields) (length args)) + (error 'typed-llvmir "record constructor arity mismatch" + (list record-name (length fields) (length args)))) + (let loop ([rest-fields fields] [rest-args args] [idx 0] [prev "undef"]) + (cond + [(null? rest-fields) (make-llvm-value struct-ty prev)] + [else + (let* ([field-ty (llvm-type (typed-field-type (car rest-fields)))] + [value (lower-operand env (car rest-args) field-ty + 'record-ctor)] + [result (fresh-value! env)]) + (emit-instr! env + (string-append + result " = insertvalue " struct-ty " " prev ", " + field-ty " " (llvm-value-text value) ", " + (number->string idx))) + (loop (cdr rest-fields) (cdr rest-args) (+ idx 1) result))]))))) + + ;; (R-field r) extracts one field by its positional index. + (def (lower-record-accessor env ir args) + (let* ([record-name (ir-call-info-ref ir 'record)] + [field-name (ir-call-info-ref ir 'field)] + [record (lookup-record record-name)]) + (unless record + (error 'typed-llvmir "unknown record in LLVM accessor" record-name)) + (unless (= (length args) 1) + (error 'typed-llvmir "record accessor expects one operand" args)) + (let loop ([fields (typed-record-fields record)] [idx 0]) + (cond + [(null? fields) + (error 'typed-llvmir "unknown record field in LLVM accessor" + (list record-name field-name))] + [(eq? (typed-field-name (car fields)) field-name) + (let ([struct-ty (record-llvm-type record)] + [value (lower-operand env (car args) + (record-llvm-type record) 'record-accessor)] + [result (fresh-value! env)]) + (emit-instr! env + (string-append + result " = extractvalue " struct-ty " " + (llvm-value-text value) ", " (number->string idx))) + (make-llvm-value (llvm-type (typed-field-type (car fields))) + result))] + [else (loop (cdr fields) (+ idx 1))])))) + ;; --- call lowering ----------------------------------------------------------- ;; Lower an operand and require it to have the expected LLVM type. Mixed @@ -840,6 +928,9 @@ [(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)] + [(record-ctor) (lower-record-ctor env ir args)] + [(record-accessor) (lower-record-accessor env ir args)] + [(record-pred) (make-llvm-value "i1" "true")] [(function) (lower-function-call env operator args)] [else (error 'typed-llvmir "unsupported call kind for LLVM lowering" kind)]))) @@ -930,11 +1021,26 @@ (typed-def-return-type def) (map typed-param-type (typed-def-params def)))) out)))] + [(typed-record? (car rest)) (loop (cdr rest) out)] [else (error 'typed-llvmir - "only function definitions are supported by the LLVM backend" + "only function and record declarations are supported by the LLVM backend" (car rest))])))) + ;; alist of record-name -> typed-record for the modules in scope. + (def (modules-record-env modules) + (let loop ([modules modules] [out '()]) + (cond + [(null? modules) (reverse out)] + [else + (let inner ([rest (typed-module-declarations (car modules))] [out out]) + (cond + [(null? rest) (loop (cdr modules) out)] + [(typed-record? (car rest)) + (inner (cdr rest) + (cons (cons (typed-record-name (car rest)) (car rest)) out))] + [else (inner (cdr rest) out)]))]))) + (def (elaborate-module-or-error module who) (let-values ([(errors defs) (check-and-elaborate-typed-module module)]) @@ -1040,18 +1146,19 @@ (newline port)) (def (typed-module->llvmir-string module) - (let* ([lowered (module-functions module)] - [functions (car lowered)] - [ctx (cdr lowered)]) - (emit-to-string - (lambda (port) - (render-module-header module port) - (render-mod-ctx-prelude ctx port) - (let loop ([rest functions] [first? #t]) - (unless (null? rest) - (unless first? (newline port)) - (render-function (car rest) port) - (loop (cdr rest) #f))))))) + (parameterize ([*llvm-record-env* (modules-record-env (list module))]) + (let* ([lowered (module-functions module)] + [functions (car lowered)] + [ctx (cdr lowered)]) + (emit-to-string + (lambda (port) + (render-module-header module port) + (render-mod-ctx-prelude ctx port) + (let loop ([rest functions] [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))) new file mode 100644 --- /dev/null +++ b/tests/fixtures/typed/llvmir-record.ss @@ -0,0 +1,23 @@ +(typed-library (sample typed llvmir-record) + (export run-of best-of bump longest-run) + + ;; a two-field by-value record, used as a for/fold accumulator + (record Run + ((cur : Nat) + (best : Nat))) + + (def (run-of (s : Run)) : Nat + (Run-cur s)) + + (def (best-of (s : Run)) : Nat + (Run-best s)) + + (def (bump (s : Run)) : Run + (let ((r (+ (Run-cur s) 1))) + (make-Run r (if (> r (Run-best s)) r (Run-best s))))) + + ;; longest prefix run length, folding a record accumulator over an index + (def (longest-run (n : Nat)) : Nat + (Run-best + (for/fold ((st (make-Run 0 0))) ((i (in-range n))) + (bump st))))) --- a/tests/test-typed-llvmir.ss +++ b/tests/test-typed-llvmir.ss @@ -548,6 +548,52 @@ (string=? bytes-ll (typed-library-form->llvmir-string bytes-form)) #t) +;; --- records and aggregate for/fold accumulators ------------------------------------ + +(define record-form + '(typed-library (sample typed llvmir-record) + (export run-of best-of bump longest-run) + (record Run + ((cur : Nat) + (best : Nat))) + (def (run-of (s : Run)) : Nat + (Run-cur s)) + (def (best-of (s : Run)) : Nat + (Run-best s)) + (def (bump (s : Run)) : Run + (let ((r (+ (Run-cur s) 1))) + (make-Run r (if (> r (Run-best s)) r (Run-best s))))) + (def (longest-run (n : Nat)) : Nat + (Run-best + (for/fold ((st (make-Run 0 0))) ((i (in-range n))) + (bump st)))))) + +(define record-ll (typed-library-form->llvmir-string record-form)) + +(test "record is a by-value struct param/return" + (and (substring? record-ll "define i64 @jt_llvm_sample_typed_llvmir_record__run_of({ i64, i64 } %a0)") + (substring? record-ll "define { i64, i64 } @jt_llvm_sample_typed_llvmir_record__bump({ i64, i64 } %a0)")) + #t) + +(test "record accessor extracts the field by index" + (and (substring? record-ll "%v0 = extractvalue { i64, i64 } %a0, 0") + (substring? record-ll "extractvalue { i64, i64 } %a0, 1")) + #t) + +(test "record constructor is an insertvalue chain" + (and (substring? record-ll "insertvalue { i64, i64 } undef, i64 ") + (substring? record-ll ", 0") + (substring? record-ll ", 1")) + #t) + +(test "for/fold carries a record accumulator in a struct phi" + (substring? record-ll "phi { i64, i64 } [ ") + #t) + +(test "record emission is deterministic across runs" + (string=? record-ll (typed-library-form->llvmir-string record-form)) + #t) + ;; --- @main smoke wrapper -------------------------------------------------------- (define smoke-form