Marc:
I've been looking at a few benchmarks that use syntax-case.scm for macro expansion, and, well, for some reason the compiler doesn't do lambda-lifting after syntax-case.scm has been loaded.
You're really hurting on some benchmarks.
Brad
Here's the code:
(declare (standard-bindings)(block))
(define (update! table key value func) (let ((hash (vector-ref table 0)) (eql? (vector-ref table 1)) (size (vector-ref table 2)) (tabl (vector-ref table 3)) (count (vector-ref table 4))) (let ((slot (hash size key))) (let loop ((bucket (vector-ref tabl slot))) (cond ((null? bucket) (vector-set! table 4 (+ (vector-ref table 4) 1)) (vector-set! tabl slot (cons (cons key value) (vector-ref tabl slot)))) ((eql? (caar bucket) key) (set-cdr! (car bucket) (func key (cdar bucket) value))) (else (loop (cdr bucket))))))))
Here's without syntax-case.scm:
(define update! (lambda (table key value func) (let ((count (if (and ('#<procedure #4 ##vector?> table) ('#<procedure #5 ##fx<> 4 ('#<procedure #6 ##vector-length> table))) ('#<procedure #7 ##vector-ref> table 4) (vector-ref table 4))) (tabl (if (and ('#<procedure #4 ##vector?> table) ('#<procedure #5 ##fx<> 3 ('#<procedure #6 ##vector-length> table))) ('#<procedure #7 ##vector-ref> table 3) (vector-ref table 3))) (size (if (and ('#<procedure #4 ##vector?> table) ('#<procedure #5 ##fx<> 2 ('#<procedure #6 ##vector-length> table))) ('#<procedure #7 ##vector-ref> table 2) (vector-ref table 2))) (eql? (if (and ('#<procedure #4 ##vector?> table) ('#<procedure #5 ##fx<> 1 ('#<procedure #6 ##vector-length> table))) ('#<procedure #7 ##vector-ref> table 1) (vector-ref table 1))) (hash (if (and ('#<procedure #4 ##vector?> table) ('#<procedure #5 ##fx<> 0 ('#<procedure #6 ##vector-length> table))) ('#<procedure #7 ##vector-ref> table 0) (vector-ref table 0)))) (let ((slot (hash size key))) (letrec ((loop (lambda (table key value func tabl eql? slot bucket) (if ('#<procedure #9 ##null?> bucket) (let ((begin-temp.0 (let ((temp.18 (let ((temp.13 (if (and ('#<procedure #4 ##vector?> table)
('#<procedure #5 ##fx<>
4
('#<procedure #6 ##vector-length> table))) ( '#<procedure #7 ##vector-ref> table 4) ( vector-ref table 4)))) (if ('#<procedure #11 ##fixnum?> temp.13) (let ((temp. 15 ('#<procedure #12 ##fx+?> temp.13 1))) (if temp. 15 temp.15 (+ temp.13 1))) (+ temp.13 1))))) (if (and (and ('#<procedure #4 ##vector?> table) ('#<procedure #14 ##subtyped-mutable?> table)) ('#<procedure #5 ##fx<> 4 ('#<procedure #6 ##vector-length> table))) ('#<procedure #15 ##vector- set!> table 4 temp.18) (vector-set! table 4 temp. 18))))) (let ((temp.23 ('#<procedure #18 ##cons> ('#<procedure #18 ##cons> key value) (if (and ('#<procedure #4 ##vector?> tabl) (and ('#<procedure #11 ##fixnum?> slot) (and ('#<procedure #16 ##fx<=> 0 slot)
('#<procedure #5 ##fx<> slot
('#<procedure #6 ##vector-length> tabl))))) ('#<procedure #7 ##vector-ref> tabl slot) (vector-ref tabl slot))))) (if (and (and ('#<procedure #4 ##vector?> tabl) ('#<procedure #14 ##subtyped-mutable?> tabl)) (and ('#<procedure #11 ##fixnum?> slot) (and ('#<procedure #16 ##fx<=> 0 slot) ('#<procedure #5 ##fx<> slot ('#<procedure #6 ##vector-length> tabl))))) ('#<procedure #15 ##vector-set!
tabl slot temp.23)
(vector-set! tabl slot temp.23)))) (if (eql? (let ((temp.25 (if ('#<procedure #20 ##pair?> bucket)
('#<procedure #21 ##car> bucket) #f))) (if ('#<procedure #20 ##pair?> temp.25) ('#<procedure #21 ##car> temp.25) (caar bucket))) key) (let ((temp.30 (func key (let ((temp.28 (if ('#<procedure #20 ##pair?> bucket)
('#<procedure #21 ##car> bucket)
#f))) (if ('#<procedure #20 ##pair?> temp.28)
('#<procedure #23 ##cdr> temp.28) (cdar bucket))) value)) (temp.29 (if ('#<procedure #20 ##pair?> bucket) ('#<procedure #21 ##car> bucket) (car bucket)))) (if (and ('#<procedure #20 ##pair?
temp.29)
('#<procedure #26 ##pair- mutable?> temp.29)) ('#<procedure #27 ##set-cdr!> temp.29 temp.30) (set-cdr! temp.29 temp.30))) (loop table key value func tabl eql? slot (if ('#<procedure #20 ##pair?
bucket)
('#<procedure #23 ##cdr> bucket) (cdr bucket)))))))) (loop table key value func tabl eql? slot (if (and ('#<procedure #4 ##vector?> tabl) (and ('#<procedure #11 ##fixnum?> slot) (and ('#<procedure #16 ##fx<=> 0 slot) ('#<procedure #5 ##fx<> slot ('#<procedure #6 ##vector-length> tabl))))) ('#<procedure #7 ##vector-ref> tabl slot) (vector-ref tabl slot))))))))
Here's after loading syntax-case.scm:
(compile-file "update-test.scm" '(expansion))
Expansion:
(define update! (lambda (%%table0 %%key1 %%value2 %%func3) (let ((%%count8 (if (and ('#<procedure #4 ##vector?> %%table0) ('#<procedure #5 ##fx<> 4 ('#<procedure #6 ##vector-length> %%table0))) ('#<procedure #7 ##vector-ref> %%table0 4) (vector-ref %%table0 4))) (%%tabl7 (if (and ('#<procedure #4 ##vector?> %%table0) ('#<procedure #5 ##fx<> 3 ('#<procedure #6 ##vector-length> %%table0))) ('#<procedure #7 ##vector-ref> %%table0 3) (vector-ref %%table0 3))) (%%size6 (if (and ('#<procedure #4 ##vector?> %%table0) ('#<procedure #5 ##fx<> 2 ('#<procedure #6 ##vector-length> %%table0))) ('#<procedure #7 ##vector-ref> %%table0 2) (vector-ref %%table0 2))) (%%eql?5 (if (and ('#<procedure #4 ##vector?> %%table0) ('#<procedure #5 ##fx<> 1 ('#<procedure #6 ##vector-length> %%table0))) ('#<procedure #7 ##vector-ref> %%table0 1) (vector-ref %%table0 1))) (%%hash4 (if (and ('#<procedure #4 ##vector?> %%table0) ('#<procedure #5 ##fx<> 0 ('#<procedure #6 ##vector-length> %%table0))) ('#<procedure #7 ##vector-ref> %%table0 0) (vector-ref %%table0 0)))) (let ((%%slot9 (%%hash4 %%size6 %%key1))) ((letrec ((%%loop10 (lambda (%%bucket11) (if ('#<procedure #9 ##null?> %%bucket11) (let ((begin-temp.0 (let ((temp.20 (let ((temp.15 (if (and ('#<procedure #4 ##vector?> %%table0)
('#<procedure #5 ##fx<>
4
('#<procedure #6 ##vector-length> %%table0)))
('#<procedure #7 ##vector-ref> %%table0 4)
(vector-ref %%table0 4)))) (if ('#<procedure #11 ##fixnum?> temp.15) (let ((temp.17 ('#<procedure #12 ##fx+?> temp.15 1))) (if temp.17 temp.17 (+ temp.15 1))) (+ temp.15 1))))) (if (and (and ('#<procedure #4 ##vector?> %%table0) ('#<procedure #14 ##subtyped-mutable?> %%table0)) ('#<procedure #5 ##fx<> 4 ('#<procedure #6 ##vector-length> %%table0))) ('#<procedure #15 ##vector-set!
%%table0 4 temp.20)
(vector-set! %%table0 4 temp. 20))))) (let ((temp.25 ('#<procedure #18 ##cons> ('#<procedure #18 ##cons> %%key1 %%value2) (if (and ('#<procedure #4 ##vector?> %%tabl7) (and ('#<procedure #11 ##fixnum?> %%slot9) (and ('#<procedure #16 ##fx<=> 0 %%slot9)
('#<procedure #5 ##fx<> %%slot9
('#<procedure #6 ##vector-length> %%tabl7))))) ('#<procedure #7 ##vector-ref> %%tabl7 %%slot9) (vector-ref %%tabl7 %% slot9))))) (if (and (and ('#<procedure #4 ##vector?
%%tabl7)
('#<procedure #14 ##subtyped-mutable?> %%tabl7)) (and ('#<procedure #11 ##fixnum?> %%slot9) (and ('#<procedure #16 ##fx<=> 0 %%slot9) ('#<procedure #5 ##fx<> %%slot9 ('#<procedure #6 ##vector-length> %%tabl7))))) ('#<procedure #15 ##vector-set!> %% tabl7 %%slot9 temp.25) (vector-set! %%tabl7 %%slot9 temp. 25)))) (if (%%eql?5 (let ((temp.27 (if ('#<procedure #20 ##pair?> %%bucket11)
('#<procedure #21 ##car> %%bucket11) #f))) (if ('#<procedure #20 ##pair?
temp.27)
('#<procedure #21 ##car> temp.27) (caar %%bucket11))) %%key1) (let ((temp.32 (%%func3 %%key1 (let ((temp.30 (if ('#<procedure #20 ##pair?> %%bucket11)
('#<procedure #21 ##car> %%bucket11)
#f))) (if ('#<procedure #20 ##pair?> temp.30)
('#<procedure #23 ##cdr> temp.30) (cdar %% bucket11))) %%value2)) (temp.31 (if ('#<procedure #20 ##pair?> %%bucket11) ('#<procedure #21 ##car> %%bucket11) (car %%bucket11)))) (if (and ('#<procedure #20 ##pair?> temp.31) ('#<procedure #26 ##pair- mutable?> temp.31)) ('#<procedure #27 ##set-cdr!> temp.31 temp.32) (set-cdr! temp.31 temp.32))) (%%loop10 (if ('#<procedure #20 ##pair?> %% bucket11) ('#<procedure #23 ##cdr> %%bucket11) (cdr %%bucket11)))))))) %%loop10) (if (and ('#<procedure #4 ##vector?> %%tabl7) (and ('#<procedure #11 ##fixnum?> %%slot9) (and ('#<procedure #16 ##fx<=> 0 %%slot9) ('#<procedure #5 ##fx<> %%slot9 ('#<procedure #6 ##vector-length> %%tabl7))))) ('#<procedure #7 ##vector-ref> %%tabl7 %%slot9) (vector-ref %%tabl7 %%slot9)))))))