typed/llvmir: generate @main and add smoke executable (Phase 4)
ober
4d727a3fbb667ffbe8295cccc5581a2f6feb40aa
--- a/Makefile +++ b/Makefile @@ -40,8 +40,10 @@ 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 +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-smoke.ss TYPED_LLVMIR_DIR ?= build/typed/llvmir +TYPED_LLVMIR_SMOKE_MODULE ?= sample_typed_llvmir_smoke +TYPED_LLVMIR_SMOKE_EXPECT ?= 42 # LLVM tool discovery for the typed LLVM IR backend: PATH first, then the # Homebrew LLVM keg (Apple Silicon, then Intel). Empty when no LLVM exists. LLVM_BIN ?= $(shell if command -v llvm-as >/dev/null 2>&1; then dirname "$$(command -v llvm-as)"; elif [ -x /opt/homebrew/opt/llvm/bin/llvm-as ]; then echo /opt/homebrew/opt/llvm/bin; elif [ -x /usr/local/opt/llvm/bin/llvm-as ]; then echo /usr/local/opt/llvm/bin; fi) @@ -820,6 +822,22 @@ typed-llvmir-check: typed-llvmir echo "typed-llvmir-check: OK $$f"; \ done +# Build the smoke fixture's optimized bitcode into a real executable with +# llc + the system C compiler, run it, and require the expected exit status. +typed-llvmir-smoke: typed-llvmir-check + @base="$(TYPED_LLVMIR_DIR)/$(TYPED_LLVMIR_SMOKE_MODULE)"; \ + "$(LLVM_BIN)/llc" -filetype=obj "$$base.opt.bc" -o "$$base.o" \ + || { echo "typed-llvmir-smoke: llc failed on $$base.opt.bc" >&2; exit 1; }; \ + cc "$$base.o" -o "$$base" \ + || { echo "typed-llvmir-smoke: link failed on $$base.o" >&2; exit 1; }; \ + if "$$base"; then status=0; else status=$$?; fi; \ + if [ "$$status" -eq "$(TYPED_LLVMIR_SMOKE_EXPECT)" ]; then \ + echo "typed-llvmir-smoke: PASS — $$base exited $$status"; \ + else \ + echo "typed-llvmir-smoke: FAIL — $$base exited $$status, expected $(TYPED_LLVMIR_SMOKE_EXPECT)" >&2; \ + exit 1; \ + fi + typed-wrappers: @$(SCHEME) --libdirs $(LIBDIRS) --script support/typed-wrappers.ss $(TYPED_WRAPPER_DIR) $(TYPED_RUST_SOURCES) --- a/lib/jerboa/typed/llvmir.ss +++ b/lib/jerboa/typed/llvmir.ss @@ -601,13 +601,54 @@ (elaborated-def-body-ir ed))) defs))) + ;; Smoke-test convention: a zero-parameter `main` returning Nat, Int, or + ;; Bool gets a generated process-entry @main wrapper. Other `main` shapes + ;; lower as ordinary functions only. + (def (smoke-main-def module) + (let loop ([rest (typed-module-declarations module)]) + (cond + [(null? rest) #f] + [(and (typed-def? (car rest)) + (eq? (typed-def-name (car rest)) 'main) + (null? (typed-def-params (car rest))) + (memq (typed-def-return-type (car rest)) '(Nat Int Bool))) + (car rest)] + [else (loop (cdr rest))]))) + + ;; Nat/Int main truncates to the i32 process status (smoke fixtures keep + ;; result values tiny and exact); Bool main exits 0 for #t and 1 for #f. + (def (main-wrapper-function module-name main-def) + (let ([symbol (llvm-function-symbol module-name 'main)]) + (make-llvm-function "main" "i32" '() + (list + (make-llvm-block "entry" + (case (typed-def-return-type main-def) + [(Nat Int) + (list + (string-append "%v0 = call i64 @" symbol "()") + "%v1 = trunc i64 %v0 to i32" + "ret i32 %v1")] + [(Bool) + (list + (string-append "%v0 = call i1 @" symbol "()") + "%v1 = select i1 %v0, i32 0, i32 1" + "ret i32 %v1")] + [else + (error 'typed-llvmir "unsupported main return type for @main" + (typed-def-return-type main-def))])))))) + (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)] + [(null? rest) + (let ([main-def (smoke-main-def module)]) + (reverse + (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)]) new file mode 100644 --- /dev/null +++ b/tests/fixtures/typed/llvmir-smoke.ss @@ -0,0 +1,12 @@ +(typed-library (sample typed llvmir-smoke) + (export main) + + (def (add2 (a : Nat) (b : Nat)) : Nat + (+ a b)) + + (def (pick (flag : Bool) (a : Nat) (b : Nat)) : Nat + (if flag a b)) + + ;; Process exit status doubles as the observed result: expected 42. + (def (main) : Nat + (pick (> (add2 20 1) 20) (add2 40 2) 0))) --- a/tests/test-typed-llvmir.ss +++ b/tests/test-typed-llvmir.ss @@ -319,6 +319,54 @@ (typed-library-forms->llvmir-module (list basic-form))) #t) +;; --- @main smoke wrapper -------------------------------------------------------- + +(define smoke-form + '(typed-library (sample typed llvmir-smoke) + (export main) + (def (add2 (a : Nat) (b : Nat)) : Nat + (+ a b)) + (def (main) : Nat + (add2 40 2)))) + +(define smoke-ll (typed-library-form->llvmir-string smoke-form)) + +(test "nat main emits an i32 @main wrapper" + (substring? smoke-ll "define i32 @main() {") + #t) + +(test "nat main calls the mangled entry" + (substring? smoke-ll + "%v0 = call i64 @jt_llvm_sample_typed_llvmir_smoke__main()") + #t) + +(test "nat main truncates to the process status" + (and (substring? smoke-ll "%v1 = trunc i64 %v0 to i32") + (substring? smoke-ll "ret i32 %v1")) + #t) + +(define bool-main-ll + (typed-library-form->llvmir-string + '(typed-library (sample typed llvmir-bool-main) + (export main) + (def (main) : Bool + #t)))) + +(test "bool main exits 0 for true and 1 for false" + (substring? bool-main-ll "%v1 = select i1 %v0, i32 0, i32 1") + #t) + +(define param-main-ll + (typed-library-form->llvmir-string + '(typed-library (sample typed llvmir-param-main) + (export main) + (def (main (x : Nat)) : Nat + x)))) + +(test "main with parameters gets no @main wrapper" + (substring? param-main-ll "define i32 @main") + #f) + ;; --- rejection of unsupported shapes ------------------------------------------------ (test "string-returning defs are rejected"