Loading syntax-case.scm disables lambda-lifting - Gambit-list

21 Mai 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)))))))