[PATCH] Take some lowhanging fruit to speed up R6RS fixnum operations

[Andreas Rottmann <a.rottmann@gmx.at>]

* module/rnrs/arithmetic/fixnums.scm (assert-fixnum): Is now a
  macro.
  (assert-fixnums): New procedure checking a the elements of a list
  for fixnum-ness.  All callers applying `assert-fixnum' to a list
  now changed to use this procedure.

* module/rnrs/arithmetic/fixnums.scm (define-fxop*): New macro for
  defining n-ary procedures special-casing the binary case via
  case-lambda.  All applicable procedures redefined using this
  macro.

* benchmark-suite/benchmarks/r6rs-arithmetic.bm: New file containing
  some benchmarks for R6RS fixnum operations.
---
 benchmark-suite/benchmarks/r6rs-arithmetic.bm |   35 +++++++++++++
 module/rnrs/arithmetic/fixnums.scm            |   69 +++++++++++--------------
 2 files changed, 66 insertions(+), 38 deletions(-)
 create mode 100644 benchmark-suite/benchmarks/r6rs-arithmetic.bm

diff --git a/benchmark-suite/benchmarks/r6rs-arithmetic.bm b/benchmark-suite/benchmarks/r6rs-arithmetic.bm
new file mode 100644
index 0000000..4c9b8e6
--- /dev/null
+++ b/benchmark-suite/benchmarks/r6rs-arithmetic.bm
@@ -0,0 +1,35 @@
+;;; -*- mode: scheme; coding: utf-8; -*-
+;;; R6RS-specific arithmetic benchmarks
+;;;
+;;; Copyright (C) 2011 Free Software Foundation, Inc.
+;;;
+;;; This library is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU Lesser General Public
+;;; License as published by the Free Software Foundation; either
+;;; version 3 of the License, or (at your option) any later version.
+;;;
+;;; This library is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; Lesser General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with this library. If not, see
+;;; <http://www.gnu.org/licenses/>.
+
+(define-module (benchmarks r6rs-arithmetic)
+  #:use-module (benchmark-suite lib)
+  #:use-module (rnrs arithmetic fixnums))
+
+\f
+(with-benchmark-prefix "fixnum"
+
+  (benchmark "fixnum? [yes]" 1e7
+    (fixnum? 10000))
+
+  (let ((n (+ most-positive-fixnum 100)))
+    (benchmark "fixnum? [no]" 1e7
+      (fixnum? n)))
+
+  (benchmark "fxxor [2]" 1e7
+    (fxxor 3 8)))
diff --git a/module/rnrs/arithmetic/fixnums.scm b/module/rnrs/arithmetic/fixnums.scm
index befbe9d..8c35dc6 100644
--- a/module/rnrs/arithmetic/fixnums.scm
+++ b/module/rnrs/arithmetic/fixnums.scm
@@ -87,6 +87,7 @@
 			most-negative-fixnum)
 	  (ice-9 optargs)
 	  (rnrs base (6))
+	  (rnrs control (6))
 	  (rnrs arithmetic bitwise (6))
 	  (rnrs conditions (6))
 	  (rnrs exceptions (6))
@@ -105,50 +106,42 @@
 	 (>= obj most-negative-fixnum) 
 	 (<= obj most-positive-fixnum)))
 
-  (define (assert-fixnum . args)
+  (define-syntax assert-fixnum
+    (syntax-rules ()
+      ((_ arg ...)
+       (or (and (fixnum? arg) ...)
+	   (raise (make-assertion-violation))))))
+
+  (define (assert-fixnums args)
     (or (for-all fixnum? args) (raise (make-assertion-violation))))
 
-  (define (fx=? fx1 fx2 . rst)
-    (let ((args (cons* fx1 fx2 rst)))
-      (apply assert-fixnum args) 
-      (apply = args)))
-
-  (define (fx>? fx1 fx2 . rst)
-    (let ((args (cons* fx1 fx2 rst))) 
-      (apply assert-fixnum args) 
-      (apply > args)))
-
-  (define (fx<? fx1 fx2 . rst)
-    (let ((args (cons* fx1 fx2 rst)))
-      (apply assert-fixnum rst)
-      (apply < args)))
-
-  (define (fx>=? fx1 fx2 . rst)
-    (let ((args (cons* fx1 fx2 rst)))
-      (apply assert-fixnum rst)
-      (apply >= args)))
-
-  (define (fx<=? fx1 fx2 . rst)
-    (let ((args (cons* fx1 fx2 rst)))
-      (apply assert-fixnum rst)
-      (apply <= args)))
-  
+  (define-syntax define-fxop*
+    (syntax-rules ()
+      ((_ name op)
+       (define name
+	 (case-lambda
+	   ((x y)
+	    (assert-fixnum x y)
+	    (op x y))
+	   (args
+	    (assert-fixnums args)
+	    (apply op args)))))))
+
+  (define-fxop* fx=? =)
+  (define-fxop* fx>? >)
+  (define-fxop* fx<? <)
+  (define-fxop* fx>=? >=)
+  (define-fxop* fx<=? <=)
+
   (define (fxzero? fx) (assert-fixnum fx) (zero? fx))
   (define (fxpositive? fx) (assert-fixnum fx) (positive? fx))
   (define (fxnegative? fx) (assert-fixnum fx) (negative? fx))
   (define (fxodd? fx) (assert-fixnum fx) (odd? fx))
   (define (fxeven? fx) (assert-fixnum fx) (even? fx))
 
-  (define (fxmax fx1 fx2 . rst)
-    (let ((args (cons* fx1 fx2 rst)))
-      (apply assert-fixnum args)
-      (apply max args)))
+  (define-fxop* fxmax max)
+  (define-fxop* fxmin min)
 
-  (define (fxmin fx1 fx2 . rst)
-    (let ((args (cons* fx1 fx2 rst)))
-      (apply assert-fixnum args)
-      (apply min args)))
- 
   (define (fx+ fx1 fx2)
     (assert-fixnum fx1 fx2) 
     (let ((r (+ fx1 fx2))) 
@@ -219,9 +212,9 @@
       (values s0 s1)))
 
   (define (fxnot fx) (assert-fixnum fx) (lognot fx))
-  (define (fxand . args) (apply assert-fixnum args) (apply logand args))
-  (define (fxior . args) (apply assert-fixnum args) (apply logior args))
-  (define (fxxor . args) (apply assert-fixnum args) (apply logxor args))
+  (define-fxop* fxand logand)
+  (define-fxop* fxior logior)
+  (define-fxop* fxxor logxor)
 
   (define (fxif fx1 fx2 fx3) 
     (assert-fixnum fx1 fx2 fx3) 
-- 
1.7.4.1