Step 8 complete: gradual typing Phase 2+3, optimization fixes
ober
c3e7d4eaa5b9ddd1063f7050743390bdd5d8e01c
--- a/docs/optimization.md +++ b/docs/optimization.md @@ -209,15 +209,25 @@ This only affects compilation (via `compile-file`), not source loading. 6. **`debug-level 0`** — For release builds, allows maximum continuation optimization. -## 17. Expected Optimization Impact - -Based on Chez Scheme's optimizer characteristics, these techniques should yield the most benefit: - -- **WPO** works despite `identifier-syntax` mutable exports -- **Full WPO requires `.wpo` files** from both jerboa runtime and application compat layers +## 17. Empirical Results (gherkin-shell benchmarks) + +Tested on gherkin-shell using shellbench. All numbers are executions/second (higher = better). + +| Optimization | Avg Improvement | Best Test | Binary Size | +|-------------|----------------|-----------|-------------| +| Baseline (default) | — | — | 6,543 KB | +| optimize-level 3 (shell only) | +3.2% | +6.3% | 6,499 KB | +| opt3 (runtime + shell) | +5.2% | +6.4% | 6,475 KB | +| opt3 + tuned cp0 + no inspector | +5.0% | +6.3% | 6,003 KB (-8.3%) | +| opt3 + tuned cp0 + partial WPO | +8.7% | +16.3% | 7,075 KB | +| **opt3 + tuned cp0 + full WPO** | **+9.6%** | **+20.3%** | 6,891 KB (+5.3%) | + +Key findings: +- **WPO works** despite `identifier-syntax` mutable exports (they survived WPO in this project) +- **Full WPO requires `.wpo` files** from both the Jerboa runtime and application compat layers - **cp0 tuning** (effort 500, score 50) adds ~1-2% on top of opt3 alone -- **`generate-inspector-information #f`** reduces binary size significantly with negligible performance impact -- **Biggest wins** expected on comparison operations and arithmetic +- **`generate-inspector-information #f`** reduces binary size significantly (-8.3%) with negligible performance impact +- **Biggest wins** on comparison operations (`cmp: [ ]` +20.3%) and arithmetic (`count: typeset -i` +17.9%) ## Summary --- a/lib/jerboa/runtime.sls +++ b/lib/jerboa/runtime.sls @@ -108,8 +108,9 @@ (if (procedure? default) (default) default) v))))) - (define (hash-get ht key) - (hashtable-ref ht key #f)) + (define-syntax hash-get + (syntax-rules () + ((_ ht key) (hashtable-ref ht key #f)))) (define hash-put! hashtable-set!) --- a/lib/std/misc/thread.sls +++ b/lib/std/misc/thread.sls @@ -153,8 +153,8 @@ (loop)))])))) (define (thread-yield!) - ;; Chez doesn't have an explicit yield; sleep briefly - (sleep (make-time 'time-duration 0 0))) + ;; Chez uses preemptive POSIX threads — no cooperative yield needed + (void)) (define (thread-sleep! seconds) (let* ([secs (exact (floor seconds))] --- a/lib/std/typed.sls +++ b/lib/std/typed.sls @@ -16,7 +16,9 @@ (export define/t lambda/t assert-type *typed-mode* register-type-predicate! - type-predicate) + type-predicate + ;; Phase 3: op specialization + with-fixnum-ops with-flonum-ops) (import (chezscheme)) ;; ========== Configuration ========== @@ -51,8 +53,40 @@ (define (register-type-predicate! type-name pred) (hashtable-set! *type-predicates* type-name pred)) - (define (type-predicate type-name) - (hashtable-ref *type-predicates* type-name #f)) + ;; Look up or construct a predicate for a type spec. + ;; Handles: + ;; symbol — direct lookup in *type-predicates* + ;; (listof T) — list whose elements satisfy T + ;; (vectorof T) — vector whose elements satisfy T + ;; (hashof K V) — hashtable? (key/value types not checked at runtime) + ;; (-> A ... B) — procedure? + (define (type-predicate spec) + (cond + [(symbol? spec) + (hashtable-ref *type-predicates* spec #f)] + [(and (pair? spec) (eq? (car spec) 'listof) (= (length spec) 2)) + (let ([elem-pred (type-predicate (cadr spec))]) + (if elem-pred + (lambda (x) + (and (list? x) (for-all elem-pred x))) + list?))] + [(and (pair? spec) (eq? (car spec) 'vectorof) (= (length spec) 2)) + (let ([elem-pred (type-predicate (cadr spec))]) + (if elem-pred + (lambda (x) + (and (vector? x) + (let loop ([i 0]) + (or (= i (vector-length x)) + (and (elem-pred (vector-ref x i)) + (loop (+ i 1))))))) + vector?))] + [(and (pair? spec) (eq? (car spec) 'hashof) (= (length spec) 3)) + ;; Runtime check is just "is it a hashtable?"; key/value types not verified per-entry + hashtable?] + [(and (pair? spec) (eq? (car spec) '->) (>= (length spec) 2)) + ;; Function type — just verify it's a procedure + procedure?] + [else #f])) ;; ========== Runtime Type Checking ========== @@ -164,4 +198,125 @@ (check-type! 'lambda 'aname arg 'atype) ... body ...)))]))) + ;; ========== Phase 3: Op Specialization ========== + ;; + ;; (with-fixnum-ops body ...) + ;; Recursively replaces generic arithmetic operators in body with fixnum + ;; variants: + → fx+, - → fx-, * → fx*, < → fx<, etc. + ;; The programmer takes responsibility for ensuring the values are fixnums. + ;; This allows Chez's cp0/cptypes to see the specialized ops directly. + ;; + ;; (with-flonum-ops body ...) + ;; Like with-fixnum-ops but replaces + → fl+, - → fl-, * → fl*, / → fl/, etc. + + ;; ========== Phase 3: Op Specialization ========== + ;; + ;; (with-fixnum-ops body ...) + ;; Recursively replaces generic arithmetic operators in body with fixnum + ;; variants: + → fx+, - → fx-, * → fx*, < → fx<, etc. + ;; The programmer takes responsibility for ensuring the values are fixnums. + ;; This allows Chez's cp0/cptypes to see the specialized ops directly. + ;; + ;; (with-flonum-ops body ...) + ;; Like with-fixnum-ops but replaces + → fl+, - → fl-, * → fl*, / → fl/, etc. + + (define-syntax with-fixnum-ops + (lambda (stx) + ;; Map of generic op → fixnum op (both as symbols) + (define fx-map + '((+ . fx+) + (- . fx-) + (* . fx*) + (< . fx<) + (> . fx>) + (<= . fx<=) + (>= . fx>=) + (= . fx=) + (quotient . fxquotient) + (remainder . fxremainder) + (modulo . fxmodulo) + (abs . fxabs) + (zero? . fxzero?) + (positive? . fxpositive?) + (negative? . fxnegative?) + (min . fxmin) + (max . fxmax) + (add1 . fx1+) + (sub1 . fx1-))) + ;; Special forms whose head must not be transformed + (define special-heads + '(quote if begin let let* letrec letrec* cond case when unless + and or lambda define set! do guard + with-syntax define-syntax let-syntax letrec-syntax + syntax-rules define-record-type library import export)) + (define (transform datum) + (cond + [(pair? datum) + (let ([head (car datum)]) + (cond + ;; Special forms: preserve head, recurse into subforms + [(memq head special-heads) + (cons head (map transform (cdr datum)))] + ;; Known arithmetic op: replace with fixnum version + [(assq head fx-map) => + (lambda (pair) (cons (cdr pair) (map transform (cdr datum))))] + ;; Other applications: recurse everywhere + [else (map transform datum)]))] + [else datum])) + (syntax-case stx () + [(kw body ...) + (let ([transformed (map (lambda (b) (transform (syntax->datum b))) + (syntax->list #'(body ...)))]) + (datum->syntax #'kw `(begin ,@transformed)))]))) + + (define-syntax with-flonum-ops + (lambda (stx) + (define fl-map + '((+ . fl+) + (- . fl-) + (* . fl*) + (/ . fl/) + (< . fl<) + (> . fl>) + (<= . fl<=) + (>= . fl>=) + (= . fl=) + (abs . flabs) + (sqrt . flsqrt) + (floor . flfloor) + (ceiling . flceiling) + (round . flround) + (truncate . fltruncate) + (sin . flsin) + (cos . flcos) + (tan . fltan) + (exp . flexp) + (log . fllog) + (zero? . flzero?) + (positive? . flpositive?) + (negative? . flnegative?) + (min . flmin) + (max . flmax))) + (define special-heads + '(quote if begin let let* letrec letrec* cond case when unless + and or lambda define set! do guard + with-syntax define-syntax let-syntax letrec-syntax + syntax-rules define-record-type library import export)) + (define (transform datum) + (cond + [(pair? datum) + (let ([head (car datum)]) + (cond + [(memq head special-heads) + (cons head (map transform (cdr datum)))] + [(assq head fl-map) => + (lambda (pair) (cons (cdr pair) (map transform (cdr datum))))] + [else (map transform datum)]))] + [else datum])) + (syntax-case stx () + [(kw body ...) + (let ([transformed (map (lambda (b) (transform (syntax->datum b))) + (syntax->list #'(body ...)))]) + (datum->syntax #'kw `(begin ,@transformed)))]))) + ) ;; end library --- a/tests/test-typed.ss +++ b/tests/test-typed.ss @@ -103,5 +103,110 @@ #f) #t)) +;;; Phase 2: Parametric Types + +;; Test 12: (listof fixnum) +(parameterize ([*typed-mode* 'debug]) + (define/t (sum-fixnums [lst : (listof fixnum)]) : fixnum + (apply + lst)) + (test "listof fixnum pass" (sum-fixnums '(1 2 3)) 6) + (test "listof fixnum fail" + (guard (exn [#t #t]) + (sum-fixnums '(1 "bad" 3)) + #f) + #t)) + +;; Test 13: (vectorof string) +(parameterize ([*typed-mode* 'debug]) + (define/t (first-str [v : (vectorof string)]) : string + (vector-ref v 0)) + (test "vectorof string pass" (first-str (vector "a" "b")) "a") + (test "vectorof string fail" + (guard (exn [#t #t]) + (first-str (vector 1 2)) + #f) + #t)) + +;; Test 14: (hashof string fixnum) — checks hashtable? only +(parameterize ([*typed-mode* 'debug]) + (define/t (get-count [ht : (hashof string fixnum)] [key : string]) : fixnum + (hashtable-ref ht key 0)) + (let ([ht (make-hashtable string-hash string=?)]) + (hashtable-set! ht "x" 42) + (test "hashof pass" (get-count ht "x") 42)) + (test "hashof fail" + (guard (exn [#t #t]) + (get-count "not-a-table" "x") + #f) + #t)) + +;; Test 15: (-> fixnum fixnum) — checks procedure? +(parameterize ([*typed-mode* 'debug]) + (define/t (apply-fn [f : (-> fixnum fixnum)] [n : fixnum]) : fixnum + (f n)) + (test "-> type pass" (apply-fn (lambda (x) (+ x 1)) 5) 6) + (test "-> type fail" + (guard (exn [#t #t]) + (apply-fn 42 5) + #f) + #t)) + +;;; Phase 3: Op Specialization + +;; Test 16: with-fixnum-ops replaces + → fx+ +(test "with-fixnum-ops addition" + (with-fixnum-ops (+ 3 4)) + 7) + +;; Test 17: with-fixnum-ops in a recursive function +(define (fib-fx n) + (with-fixnum-ops + (if (< n 2) + n + (+ (fib-fx (- n 1)) (fib-fx (- n 2)))))) +(test "with-fixnum-ops fibonacci" (fib-fx 10) 55) + +;; Test 18: with-fixnum-ops nested let +(test "with-fixnum-ops let" + (with-fixnum-ops + (let ([a 10] [b 3]) + (- a b))) + 7) + +;; Test 19: with-fixnum-ops comparison +(test "with-fixnum-ops comparison" + (with-fixnum-ops + (and (< 1 2) (>= 5 5))) + #t) + +;; Test 20: with-flonum-ops replaces + → fl+ +(test "with-flonum-ops addition" + (with-flonum-ops (+ 1.5 2.5)) + 4.0) + +;; Test 21: with-flonum-ops in a computation +(test "with-flonum-ops multiply" + (with-flonum-ops (* 2.0 3.14)) + 6.28) + +;; Test 22: with-flonum-ops preserves if/let structure +(test "with-flonum-ops let" + (with-flonum-ops + (let ([x 2.0]) + (if (> x 1.0) + (* x x) + x))) + 4.0) + +;; Test 23: with-fixnum-ops + define/t integration +(parameterize ([*typed-mode* 'release]) + (define/t (dot-product [n : fixnum]) : fixnum + (with-fixnum-ops + (let loop ([i 0] [acc 0]) + (if (= i n) + acc + (loop (+ i 1) (+ acc i)))))) + (test "define/t with-fixnum-ops" (dot-product 5) 10)) + (printf "~%~a tests, ~a passed, ~a failed~%" (+ pass fail) pass fail) (when (> fail 0) (exit 1))