Phase 12/13/14 deeper: inline method dispatch + mixed-length match fusion
ober
17b047634be4d92e86ae5f52d9e6c0c4e9d884bc
--- a/lib/jerboa/runtime.sls +++ b/lib/jerboa/runtime.sls @@ -71,33 +71,46 @@ (or (and table (hashtable-ref table name #f)) (loop (record-type-parent t))))))) - ;; Arity-specialized dispatch entry points. Each is one straight-line - ;; lookup + direct call, so the compiler avoids the apply + rest-list - ;; allocation that the variadic form requires. The error path is - ;; never-returning so the (or method ...) idiom keeps the fast path - ;; tight. + ;; Slow-path: called only after the own-RTD lookup misses. Walks + ;; parents. Receives the first parent directly to avoid re-checking + ;; the own RTD we already looked at. + (define (%find-method-parents parent name) + (and parent (find-method parent name))) + + ;; Arity-specialized dispatch entry points. Each inlines the common + ;; fast path: (1) own-RTD hashtable lookup, (2) method table lookup. + ;; Only on a miss do we call into the parent-walking slow path. This + ;; avoids the find-method procedure-call frame on the hot path. (define (%missing-method obj name) (error 'call-method "no method" name (record-type-name (record-rtd obj)))) - (define (call-method-0 obj name) - ((or (find-method (record-rtd obj) name) - (%missing-method obj name)) obj)) - (define (call-method-1 obj name a) - ((or (find-method (record-rtd obj) name) - (%missing-method obj name)) obj a)) - (define (call-method-2 obj name a b) - ((or (find-method (record-rtd obj) name) - (%missing-method obj name)) obj a b)) - (define (call-method-3 obj name a b c) - ((or (find-method (record-rtd obj) name) - (%missing-method obj name)) obj a b c)) - (define (call-method-4 obj name a b c d) - ((or (find-method (record-rtd obj) name) - (%missing-method obj name)) obj a b c d)) + (define-syntax %dispatch-body + ;; (%dispatch-body obj name (arg ...)) + (syntax-rules () + [(_ obj-expr name-expr (arg ...)) + (let* ([%o obj-expr] + [%rtd (record-rtd %o)] + [%tbl (hashtable-ref *method-tables* %rtd #f)] + [%m (and %tbl (hashtable-ref %tbl name-expr #f))]) + (if %m + (%m %o arg ...) + ((or (%find-method-parents (record-type-parent %rtd) name-expr) + (%missing-method %o name-expr)) + %o arg ...)))])) + (define (call-method-0 obj name) (%dispatch-body obj name ())) + (define (call-method-1 obj name a) (%dispatch-body obj name (a))) + (define (call-method-2 obj name a b) (%dispatch-body obj name (a b))) + (define (call-method-3 obj name a b c) (%dispatch-body obj name (a b c))) + (define (call-method-4 obj name a b c d) (%dispatch-body obj name (a b c d))) (define (call-method obj name . args) - (apply (or (find-method (record-rtd obj) name) - (%missing-method obj name)) - obj args)) + (let* ([rtd (record-rtd obj)] + [tbl (hashtable-ref *method-tables* rtd #f)] + [m (and tbl (hashtable-ref tbl name #f))]) + (if m + (apply m obj args) + (apply (or (%find-method-parents (record-type-parent rtd) name) + (%missing-method obj name)) + obj args)))) ;; ~ is the dispatch operator: (~ obj 'method args...). Expand to ;; the narrowest arity-specialized call-method-N so the compiler @@ -107,14 +120,52 @@ ;; procedure for higher-order use. (define (~proc obj method-name . args) (apply call-method obj method-name args)) + ;; Expand ~ inline: direct own-RTD lookup avoids the call-method-N + ;; procedure-call frame on the fast path. Miss falls through to + ;; call-method-N which re-does the lookup and walks parents. (define-syntax ~ (lambda (stx) (syntax-case stx () - [(_ obj name) #'(call-method-0 obj name)] - [(_ obj name a) #'(call-method-1 obj name a)] - [(_ obj name a b) #'(call-method-2 obj name a b)] - [(_ obj name a b c) #'(call-method-3 obj name a b c)] - [(_ obj name a b c d) #'(call-method-4 obj name a b c d)] + [(_ obj name) + #'(let* ([%o obj] + [%n name] + [%rtd (record-rtd %o)] + [%tbl (hashtable-ref *method-tables* %rtd #f)] + [%m (and %tbl (hashtable-ref %tbl %n #f))]) + (if %m (%m %o) (call-method-0 %o %n)))] + [(_ obj name a) + #'(let* ([%o obj] + [%n name] + [%a a] + [%rtd (record-rtd %o)] + [%tbl (hashtable-ref *method-tables* %rtd #f)] + [%m (and %tbl (hashtable-ref %tbl %n #f))]) + (if %m (%m %o %a) (call-method-1 %o %n %a)))] + [(_ obj name a b) + #'(let* ([%o obj] + [%n name] + [%a a] [%b b] + [%rtd (record-rtd %o)] + [%tbl (hashtable-ref *method-tables* %rtd #f)] + [%m (and %tbl (hashtable-ref %tbl %n #f))]) + (if %m (%m %o %a %b) (call-method-2 %o %n %a %b)))] + [(_ obj name a b c) + #'(let* ([%o obj] + [%n name] + [%a a] [%b b] [%c c] + [%rtd (record-rtd %o)] + [%tbl (hashtable-ref *method-tables* %rtd #f)] + [%m (and %tbl (hashtable-ref %tbl %n #f))]) + (if %m (%m %o %a %b %c) (call-method-3 %o %n %a %b %c)))] + [(_ obj name a b c d) + #'(let* ([%o obj] + [%n name] + [%a a] [%b b] [%c c] [%d d] + [%rtd (record-rtd %o)] + [%tbl (hashtable-ref *method-tables* %rtd #f)] + [%m (and %tbl (hashtable-ref %tbl %n #f))]) + (if %m (%m %o %a %b %c %d) + (call-method-4 %o %n %a %b %c %d)))] [(_ obj name arg ...) #'(call-method obj name arg ...)] [id (identifier? #'id) #'~proc]))) --- a/lib/std/iter.sls +++ b/lib/std/iter.sls @@ -50,6 +50,15 @@ (define (in-hash-values ht) (hash-values ht)) + ;; Fusion helpers: return the raw vector from (hashtable-entries ht) + ;; without the (let-values ...) → call-with-values overhead that + ;; inlining hashtable-entries into each macro expansion would force + ;; on every enclosing call. `(hashtable-keys ht)` already returns a + ;; single vector, so we only need a helper for values. + (define (%ht-values-vec ht) + (call-with-values (lambda () (hashtable-entries ht)) + (lambda (_keys vals) vals))) + (define (in-hash-pairs ht) (hash->list ht)) @@ -301,7 +310,7 @@ (loop (fx+ i 1) (cons (begin body ...) acc)))))))] [(_ ((var (in-hash-values ht-expr))) body ...) (binding-id? #'var) - #'(let-values ([(%ks vs) (hashtable-entries ht-expr)]) + #'(let ([vs (%ht-values-vec ht-expr)]) (let ([n (vector-length vs)]) (let loop ([i 0] [acc '()]) (if (fx>= i n) (reverse acc) --- a/lib/std/match2.sls +++ b/lib/std/match2.sls @@ -449,30 +449,40 @@ (cadr pat-parts))) (define (split-tagged-run clauses) - ;; Collect the leading run of tagged-list clauses sharing the - ;; same length, with distinct tags. Returns (values run rest). + ;; Collect the leading run of tagged-list clauses with distinct + ;; head tags. Clause lengths MAY vary — we factor the list? + + ;; head-extraction spine and per-arm-check the length when it + ;; differs across the run. Returns (values run rest). (if (not (and (pair? clauses) (tagged-list-clause? (car clauses)))) (values '() clauses) - (let ([n (tagged-list-clause-length (car clauses))]) - (let loop ([cs (cdr clauses)] - [run (list (car clauses))] - [tags (list (tagged-list-clause-tag-sym (car clauses)))]) - (if (and (pair? cs) - (tagged-list-clause? (car cs)) - (= (tagged-list-clause-length (car cs)) n) - (not (memq (tagged-list-clause-tag-sym (car cs)) tags))) - (loop (cdr cs) - (cons (car cs) run) - (cons (tagged-list-clause-tag-sym (car cs)) tags)) - (values (reverse run) cs)))))) + (let loop ([cs (cdr clauses)] + [run (list (car clauses))] + [tags (list (tagged-list-clause-tag-sym (car clauses)))]) + (if (and (pair? cs) + (tagged-list-clause? (car cs)) + (not (memq (tagged-list-clause-tag-sym (car cs)) tags))) + (loop (cdr cs) + (cons (car cs) run) + (cons (tagged-list-clause-tag-sym (car cs)) tags)) + (values (reverse run) cs))))) + + (define (uniform-length run) + ;; Returns the common length if all clauses share it, else #f. + (let ([n0 (tagged-list-clause-length (car run))]) + (and (for-all (lambda (c) + (= (tagged-list-clause-length c) n0)) + run) + n0))) ;; Compile a run of tagged-list clauses into a single list-shape - ;; check + cond dispatch on the head tag. Each arm still runs - ;; compile-pat over the remaining sub-patterns, so nested patterns - ;; behave identically to the unfused path. + ;; check + cond dispatch on the head tag. Uniform-length runs + ;; factor the length check too (single (= (length) N)); mixed- + ;; length runs still factor pair?+list?+head extraction but + ;; check each arm's length individually. Nested patterns behave + ;; identically to the unfused path. (define (compile-tagged-run run rest-stx val) - (let* ([n (tagged-list-clause-length (car run))] - [hd-tmp (car (generate-temporaries '(hd)))] + (let* ([hd-tmp (car (generate-temporaries '(hd)))] + [uniform-n (uniform-length run)] [arms (map (lambda (clause) (let* ([parts (syntax->list clause)] @@ -483,6 +493,7 @@ ;; sub-patterns after the (quote TAG) head [sub-pats (cddr pat-parts)] [tag-stx (tagged-list-clause-tag-stx clause)] + [n (tagged-list-clause-length clause)] ;; Match remaining elements at indices 1..N-1. [inner (let loop ([ps sub-pats] [i 1] [acc body]) @@ -492,14 +503,29 @@ #`(list-ref #,val #,i) acc rest-stx))))]) - #`[(eq? #,hd-tmp #,tag-stx) #,inner])) + (if uniform-n + #`[(eq? #,hd-tmp #,tag-stx) #,inner] + #`[(eq? #,hd-tmp #,tag-stx) + (if (and (list? #,val) (= (length #,val) #,n)) + #,inner + #,rest-stx)]))) run)]) - #`(if (and (list? #,val) (= (length #,val) #,n)) - (let ([#,hd-tmp (list-ref #,val 0)]) - (cond - #,@arms - [else #,rest-stx])) - #,rest-stx))) + (if uniform-n + #`(if (and (list? #,val) (= (length #,val) #,uniform-n)) + (let ([#,hd-tmp (list-ref #,val 0)]) + (cond + #,@arms + [else #,rest-stx])) + #,rest-stx) + ;; Mixed length: factor pair? + head extraction only. + ;; Per-arm check list?+length before entering the body so + ;; improper lists fall through safely. + #`(if (pair? #,val) + (let ([#,hd-tmp (car #,val)]) + (cond + #,@arms + [else #,rest-stx])) + #,rest-stx)))) (define (compile-clauses clauses val) (cond @@ -516,8 +542,11 @@ [(and (tagged-list-clause? (car clauses)) (pair? (cdr clauses)) (tagged-list-clause? (cadr clauses)) - (= (tagged-list-clause-length (car clauses)) - (tagged-list-clause-length (cadr clauses)))) + ;; Require distinct tags on the first two so the run + ;; has at least 2 arms to fuse — same-tag clauses end + ;; the run inside split-tagged-run anyway. + (not (eq? (tagged-list-clause-tag-sym (car clauses)) + (tagged-list-clause-tag-sym (cadr clauses))))) (let-values ([(run rest) (split-tagged-run clauses)]) (if (>= (length run) 2) (compile-tagged-run run (compile-clauses rest val) val)