[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