typed/llvmir: variants + match (P7)
ober
597538549b92c72a73417b441f441def2638362c
--- 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-record.ss tests/fixtures/typed/llvmir-option.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-option.ss tests/fixtures/typed/llvmir-variant.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 @@ -340,6 +340,7 @@ [(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-match? ir) (lower-match env ir)] [(typed-ir-call? ir) (lower-call env ir)] [else (error 'typed-llvmir "unsupported typed IR node for LLVM lowering" ir)])) @@ -705,6 +706,214 @@ (string-append result " = insertvalue " struct-ty " undef, i1 false, 0")) (make-llvm-value struct-ty result))) + ;; --- variant primitives ------------------------------------------------------ + + ;; The LLVM struct type holding one case's fields: { f0ty, f1ty, ... }. + (def (variant-case-struct-type fields) + (string-append + "{ " + (join-strings + (map (lambda (field) (llvm-type (typed-field-type field))) fields) + ", ") + " }")) + + ;; Index of a case in its variant's declared order — the tag value. + (def (variant-case-index variant case-name) + (let loop ([cases (typed-variant-cases variant)] [idx 0]) + (cond + [(null? cases) (error 'typed-llvmir "unknown variant case" case-name)] + [(eq? (typed-variant-case-name (car cases)) case-name) idx] + [else (loop (cdr cases) (+ idx 1))]))) + + (def (variant-case-by-name variant case-name) + (let loop ([cases (typed-variant-cases variant)]) + (cond + [(null? cases) (error 'typed-llvmir "unknown variant case" case-name)] + [(eq? (typed-variant-case-name (car cases)) case-name) (car cases)] + [else (loop (cdr cases))]))) + + ;; (Case f0 f1 ...) : V -> { i32 tag, ptr box }. A fieldless case boxes to a + ;; null pointer; otherwise malloc a heap struct of the fields and store each. + ;; The box is never freed (consistent with bytes-build; GC is future work). + (def (lower-variant-ctor env ir args) + (let* ([variant-name (ir-call-info-ref ir 'variant)] + [case-name (ir-call-info-ref ir 'case)] + [variant (lookup-variant variant-name)]) + (unless variant + (error 'typed-llvmir "unknown variant in LLVM ctor" variant-name)) + (let* ([case (variant-case-by-name variant case-name)] + [fields (typed-variant-case-fields case)] + [tag (number->string (variant-case-index variant case-name))]) + (unless (= (length fields) (length args)) + (error 'typed-llvmir "variant constructor arity mismatch" + (list variant-name case-name (length fields) (length args)))) + (let ([box + (cond + [(null? fields) "null"] + [else + (require-intrinsic! env "declare ptr @malloc(i64)") + (let* ([struct-ty (variant-case-struct-type fields)] + [szp (fresh-value! env)] + [sz (fresh-value! env)] + [box-reg (fresh-value! env)]) + (emit-instr! env + (string-append + szp " = getelementptr " struct-ty ", ptr null, i64 1")) + (emit-instr! env + (string-append sz " = ptrtoint ptr " szp " to i64")) + (emit-instr! env + (string-append box-reg " = call ptr @malloc(i64 " sz ")")) + ;; store each field into the heap struct + (let loop ([rest-fields fields] [rest-args args] [idx 0]) + (unless (null? rest-fields) + (let* ([field-ty (llvm-type (typed-field-type (car rest-fields)))] + [value (lower-operand env (car rest-args) field-ty + 'variant-ctor)] + [fp (fresh-value! env)]) + (emit-instr! env + (string-append + fp " = getelementptr " struct-ty ", ptr " box-reg + ", i64 0, i32 " (number->string idx))) + (emit-instr! env + (string-append + "store " field-ty " " (llvm-value-text value) + ", ptr " fp)) + (loop (cdr rest-fields) (cdr rest-args) (+ idx 1))))) + box-reg)])]) + (let* ([t0 (fresh-value! env)] + [result (fresh-value! env)]) + (emit-instr! env + (string-append + t0 " = insertvalue " variant-llvm-type " undef, i32 " tag ", 0")) + (emit-instr! env + (string-append + result " = insertvalue " variant-llvm-type " " t0 + ", ptr " box ", 1")) + (make-llvm-value variant-llvm-type result)))))) + + ;; --- match ------------------------------------------------------------------- + ;; + ;; Lower (match scrut clause...) on a variant to a `switch` on the tag. Each + ;; case block loads its fields from the box, binds them, lowers the body, and + ;; branches to a join; a `phi` collects the per-arm results. The default arm + ;; covers any uncovered case (or `unreachable` when the match is exhaustive). + (def (lower-match env ir) + (let* ([scrut (lower-operand env (typed-ir-match-scrutinee ir) + variant-llvm-type 'match)] + [variant-name (typed-ir-match-scrutinee-type ir)] + [variant (lookup-variant variant-name)] + [clauses (typed-ir-match-clauses ir)] + [default (typed-ir-match-default ir)] + [result-type (typed-ir-match-type ir)] + [void? (eq? result-type 'Unit)] + [result-ty (and (not void?) (llvm-type result-type))] + [n (number->string (fresh-label-index! env))] + [join-label (string-append "match_join" n)] + [default-label (string-append "match_default" n)] + [tag (fresh-value! env)] + [box (fresh-value! env)]) + (unless variant + (error 'typed-llvmir "unknown variant in match" variant-name)) + (emit-instr! env + (string-append + tag " = extractvalue " variant-llvm-type " " + (llvm-value-text scrut) ", 0")) + (emit-instr! env + (string-append + box " = extractvalue " variant-llvm-type " " + (llvm-value-text scrut) ", 1")) + ;; assign a block label per clause and build the switch table + (let* ([labelled + (let loop ([rest clauses] [i 0] [out '()]) + (if (null? rest) + (reverse out) + (loop (cdr rest) (+ i 1) + (cons (cons (car rest) + (string-append "match_case" n "_" + (number->string i))) + out))))] + [switch-arms + (join-strings + (map (lambda (entry) + (let ([idx (variant-case-index variant + (typed-ir-match-clause-case (car entry)))]) + (string-append + "i32 " (number->string idx) + ", label %" (cdr entry)))) + labelled) + " ")]) + (finish-block! env + (string-append + "switch i32 " tag ", label %" default-label + " [ " switch-arms " ]")) + ;; lower each case arm, collecting (result-text . end-label) for the phi + (let loop ([rest labelled] [incomings '()]) + (cond + [(null? rest) + ;; default arm + (start-block! env default-label) + (let ([incomings + (cond + [default + (let ([value (lower-begin env default result-type)] + [end (llvm-env-current-label env)]) + (finish-block! env (string-append "br label %" join-label)) + (if void? + incomings + (cons (cons (llvm-value-text value) end) incomings)))] + [else + (finish-block! env "unreachable") + incomings])]) + (start-block! env join-label) + (if void? + unit-value + (let ([result (fresh-value! env)]) + (emit-instr! env + (string-append + result " = phi " result-ty " " + (join-strings + (map (lambda (inc) + (string-append + "[ " (car inc) ", %" (cdr inc) " ]")) + (reverse incomings)) + ", "))) + (make-llvm-value result-ty result))))] + [else + (let* ([clause (caar rest)] + [label (cdar rest)] + [case-name (typed-ir-match-clause-case clause)] + [bindings (typed-ir-match-clause-bindings clause)] + [field-types (typed-ir-match-clause-field-types clause)] + [body (typed-ir-match-clause-body clause)] + [case (variant-case-by-name variant case-name)] + [fields (typed-variant-case-fields case)] + [struct-ty (variant-case-struct-type fields)] + [saved-vars (llvm-env-vars env)]) + (start-block! env label) + ;; load + bind each non-wildcard field from the box + (let bind-loop ([bs bindings] [fts field-types] [idx 0]) + (unless (or (null? bs) (null? fts)) + (unless (eq? (car bs) '_) + (let* ([field-ty (llvm-type (car fts))] + [fp (fresh-value! env)] + [val (fresh-value! env)]) + (emit-instr! env + (string-append + fp " = getelementptr " struct-ty ", ptr " box + ", i64 0, i32 " (number->string idx))) + (emit-instr! env + (string-append val " = load " field-ty ", ptr " fp)) + (bind-var! env (car bs) (make-llvm-value field-ty val)))) + (bind-loop (cdr bs) (cdr fts) (+ idx 1)))) + (let ([value (lower-begin env body result-type)] + [end (llvm-env-current-label env)]) + (llvm-env-vars-set! env saved-vars) + (finish-block! env (string-append "br label %" join-label)) + (loop (cdr rest) + (if void? + incomings + (cons (cons (llvm-value-text value) end) incomings)))))]))))) + ;; --- call lowering ----------------------------------------------------------- ;; Lower an operand and require it to have the expected LLVM type. Mixed @@ -992,6 +1201,8 @@ [(record-pred) (make-llvm-value "i1" "true")] [(option-some) (lower-option-some env ir args)] [(option-none) (lower-option-none env ir)] + [(variant-ctor) (lower-variant-ctor env ir args)] + [(variant-pred) (make-llvm-value "i1" "true")] [(function) (lower-function-call env operator args)] [else (error 'typed-llvmir "unsupported call kind for LLVM lowering" kind)]))) new file mode 100644 --- /dev/null +++ b/tests/fixtures/typed/llvmir-variant.ss @@ -0,0 +1,37 @@ +(typed-library (sample typed llvmir-variant) + (export make-some make-pair make-empty token-size kind-tag describe) + + ;; a tagged union with fieldless, single-field, and multi-field cases + (variant Token + (Some (value : Nat)) + (Pair (a : Nat) (b : Nat)) + (Empty)) + + (def (make-some (x : Nat)) : Token + (Some x)) + + (def (make-pair (a : Nat) (b : Nat)) : Token + (Pair a b)) + + (def (make-empty) : Token + (Empty)) + + ;; exhaustive match binding fields per case + (def (token-size (t : Token)) : Nat + (match t + ((Some value) value) + ((Pair a b) (+ a b)) + ((Empty) 0))) + + ;; match with a default (else) arm + (def (kind-tag (t : Token)) : Nat + (match t + ((Some value) 1) + (else 9))) + + ;; match returning a String, exercising a wildcard binding + (def (describe (t : Token)) : String + (match t + ((Some _) "some") + ((Pair _ _) "pair") + ((Empty) "empty")))) --- a/tests/test-typed-llvmir.ss +++ b/tests/test-typed-llvmir.ss @@ -646,6 +646,87 @@ (string=? option-ll (typed-library-form->llvmir-string option-form)) #t) +;; --- variants and match ------------------------------------------------------------- + +(define variant-form + '(typed-library (sample typed llvmir-variant) + (export make-some make-pair make-empty token-size kind-tag describe) + (variant Token + (Some (value : Nat)) + (Pair (a : Nat) (b : Nat)) + (Empty)) + (def (make-some (x : Nat)) : Token + (Some x)) + (def (make-pair (a : Nat) (b : Nat)) : Token + (Pair a b)) + (def (make-empty) : Token + (Empty)) + (def (token-size (t : Token)) : Nat + (match t + ((Some value) value) + ((Pair a b) (+ a b)) + ((Empty) 0))) + (def (kind-tag (t : Token)) : Nat + (match t + ((Some value) 1) + (else 9))) + (def (describe (t : Token)) : String + (match t + ((Some _) "some") + ((Pair _ _) "pair") + ((Empty) "empty"))))) + +(define variant-ll (typed-library-form->llvmir-string variant-form)) + +(test "variant is a tagged boxed { i32, ptr } value" + (substring? variant-ll + "define { i32, ptr } @jt_llvm_sample_typed_llvmir_variant__make_some(i64 %a0)") + #t) + +(test "variant constructor tags by case index and boxes fields" + (and (substring? variant-ll "call ptr @malloc(i64 ") + (substring? variant-ll "insertvalue { i32, ptr } undef, i32 0, 0") + (substring? variant-ll "store i64 %a0, ptr ")) + #t) + +(test "fieldless variant case boxes a null pointer" + (substring? variant-ll "insertvalue { i32, ptr } %v0, ptr null, 1") + #t) + +(test "match switches on the tag field" + (and (substring? variant-ll "extractvalue { i32, ptr } %a0, 0") + (substring? variant-ll "switch i32 ") + (substring? variant-ll "label %match_case")) + #t) + +(test "match loads bound fields from the box" + (and (substring? variant-ll "getelementptr { i64, i64 }, ptr ") + (substring? variant-ll "load i64, ptr ")) + #t) + +(test "exhaustive match has an unreachable default" + (and (substring? variant-ll "match_default") + (substring? variant-ll "unreachable")) + #t) + +(test "match joins arms with a phi" + (substring? variant-ll "phi i64 [ ") + #t) + +(test "match with an else arm lowers the default body" + ;; kind-tag: Some -> 1, else -> 9; no unreachable in that match + (substring? variant-ll "[ 9, %match_default") + #t) + +(test "match can return a String (wildcard bindings)" + (substring? variant-ll + "define { ptr, i64 } @jt_llvm_sample_typed_llvmir_variant__describe") + #t) + +(test "variant emission is deterministic across runs" + (string=? variant-ll (typed-library-form->llvmir-string variant-form)) + #t) + ;; --- @main smoke wrapper -------------------------------------------------------- (define smoke-form