[gambit-list] Speeding up rational arithmetic

Bradley Lucier lucier at math.purdue.edu
Sun Apr 1 00:59:05 EDT 2007


Marc:

I thought that I might speed up rational arithmetic a bit in the  
common case where the numerators and denominators are small integers,  
so I tried some new declarations:

(define-prim (##ratnum.* x y)
   (##declare (run-time-bindings)
              (mostly-fixnum))
   (let ((p (macro-ratnum-numerator x))
         (q (macro-ratnum-denominator x))
         (r (macro-ratnum-numerator y))
         (s (macro-ratnum-denominator y)))
     (if (##eq? x y)
       (macro-ratnum-make (* p p) (* q q))     ; already in lowest form
       (let* ((gcd-ps (gcd p s))
              (gcd-rq (gcd r q))
              (num (* (quotient p gcd-ps) (quotient r gcd-rq)))
              (den (* (quotient q gcd-rq) (quotient s gcd-ps))))
         (if (##eq? den 1)
           num
           (macro-ratnum-make num den))))))

but this isn't quite right, since, e.g., for the form (* p p), if p  
is not a fixnum, then  gsc generates calls to (* p p) instead of (##*  
p p) even though (declare (standard-bindings) is in effect. So a user  
could screw up rational arithmetic simply by redefining * (which is  
allowed, after all).

Perhaps the code generator should be changed to call (##* p p)  
directly in this case.

The full expansion is below.

Brad

(define ##ratnum.*
   (lambda (x y)
     (let ((s ('#<procedure #7 ##vector-ref> y 1))
           (r ('#<procedure #7 ##vector-ref> y 0))
           (q ('#<procedure #7 ##vector-ref> x 1))
           (p ('#<procedure #7 ##vector-ref> x 0)))
       (if ('#<procedure #27 ##eq?> x y)
           ('#<procedure #75 ##subtype-set!>
            ('#<procedure #76 ##vector>
             (if (and ('#<procedure #14 ##fixnum?> p)
                      ('#<procedure #14 ##fixnum?> p))
                 (if ('#<procedure #298 ##eqv?> p 0)
                     0
                     (let ((temp.236
                            (if ('#<procedure #298 ##eqv?> p -1)
                                ('#<procedure #207 ##fx-?> p)
                                ('#<procedure #208 ##fx*?> p p))))
                       (if temp.236 temp.236 (* p p))))
                 (* p p))
             (if (and ('#<procedure #14 ##fixnum?> q)
                      ('#<procedure #14 ##fixnum?> q))
                 (if ('#<procedure #298 ##eqv?> q 0)
                     0
                     (let ((temp.239
                            (if ('#<procedure #298 ##eqv?> q -1)
                                ('#<procedure #207 ##fx-?> q)
                                ('#<procedure #208 ##fx*?> q q))))
                       (if temp.239 temp.239 (* q q))))
                 (* q q)))
            2)
           (let ((gcd-ps ('#<procedure #94 gcd> p s)))
             (let ((gcd-rq ('#<procedure #94 gcd> r q)))
               (let ((num (let ((temp.245
                                 (if (and ('#<procedure #14 ##fixnum? 
 > gcd-rq)
                                          (and ('#<procedure #14  
##fixnum?> r)
                                               ('#<procedure #21 ##not>
                                                ('#<procedure #298  
##eqv?>
                                                 gcd-rq
                                                 0))))
                                     (if ('#<procedure #298 ##eqv?>  
gcd-rq -1)
                                         (or ('#<procedure #207 ##fx-? 
 > r)
                                             (quotient r gcd-rq))
                                         ('#<procedure #216  
##fxquotient>
                                          r
                                          gcd-rq))
                                     (quotient r gcd-rq)))
                                (temp.244
                                 (if (and ('#<procedure #14 ##fixnum? 
 > gcd-ps)
                                          (and ('#<procedure #14  
##fixnum?> p)
                                               ('#<procedure #21 ##not>
                                                ('#<procedure #298  
##eqv?>
                                                 gcd-ps
                                                 0))))
                                     (if ('#<procedure #298 ##eqv?>  
gcd-ps -1)
                                         (or ('#<procedure #207 ##fx-? 
 > p)
                                             (quotient p gcd-ps))
                                         ('#<procedure #216  
##fxquotient>
                                          p
                                          gcd-ps))
                                     (quotient p gcd-ps))))
                            (if (and ('#<procedure #14 ##fixnum?>  
temp.245)
                                     ('#<procedure #14 ##fixnum?>  
temp.244))
                                (if ('#<procedure #298 ##eqv?> temp. 
245 0)
                                    0
                                    (let ((temp.246
                                           (if ('#<procedure #298  
##eqv?>
                                                temp.245
                                                -1)
                                               ('#<procedure #207  
##fx-?>
                                                temp.244)
                                               ('#<procedure #208  
##fx*?>
                                                temp.244
                                                temp.245))))
                                      (if temp.246
                                          temp.246
                                          (* temp.244 temp.245))))
                                (* temp.244 temp.245)))))
                 (let ((den (let ((temp.252
                                   (if (and ('#<procedure #14  
##fixnum?> gcd-ps)
                                            (and ('#<procedure #14  
##fixnum?> s)
                                                 ('#<procedure #21  
##not>
                                                  ('#<procedure #298  
##eqv?>
                                                   gcd-ps
                                                   0))))
                                       (if ('#<procedure #298 ##eqv?>  
gcd-ps -1)
                                           (or ('#<procedure #207  
##fx-?> s)
                                               (quotient s gcd-ps))
                                           ('#<procedure #216  
##fxquotient>
                                            s
                                            gcd-ps))
                                       (quotient s gcd-ps)))
                                  (temp.251
                                   (if (and ('#<procedure #14  
##fixnum?> gcd-rq)
                                            (and ('#<procedure #14  
##fixnum?> q)
                                                 ('#<procedure #21  
##not>
                                                  ('#<procedure #298  
##eqv?>
                                                   gcd-rq
                                                   0))))
                                       (if ('#<procedure #298 ##eqv?>  
gcd-rq -1)
                                           (or ('#<procedure #207  
##fx-?> q)
                                               (quotient q gcd-rq))
                                           ('#<procedure #216  
##fxquotient>
                                            q
                                            gcd-rq))
                                       (quotient q gcd-rq))))
                              (if (and ('#<procedure #14 ##fixnum?>  
temp.252)
                                       ('#<procedure #14 ##fixnum?>  
temp.251))
                                  (if ('#<procedure #298 ##eqv?> temp. 
252 0)
                                      0
                                      (let ((temp.253
                                             (if ('#<procedure #298  
##eqv?>
                                                  temp.252
                                                  -1)
                                                 ('#<procedure #207  
##fx-?>
                                                  temp.251)
                                                 ('#<procedure #208  
##fx*?>
                                                  temp.251
                                                  temp.252))))
                                        (if temp.253
                                            temp.253
                                            (* temp.251 temp.252))))
                                  (* temp.251 temp.252)))))
                   (if ('#<procedure #27 ##eq?> den 1)
                       num
                       ('#<procedure #75 ##subtype-set!>
                        ('#<procedure #76 ##vector> num den)
                        2))))))))))



More information about the Gambit-list mailing list