[gambit-list] Loading syntax-case.scm disables lambda-lifting
Bradley Lucier
lucier at math.purdue.edu
Mon May 21 12:35:45 EDT 2007
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)))))))
More information about the Gambit-list
mailing list