[PATCH 3/3] Add `fixnum?' VM primitive

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

This primitive can be used to significantly speed up the operations in
`(rnrs arithmetic fixnums)'.

* libguile/r6rs-arithmetic.c: New file containing `fixnum?' procedure
  implementation as a new extension.
* libguile/r6rs-arithmetic.h: New file with prototypes for the above.
* libguile/Makefile.am: Add above files in relevant places.

* libguile/init.c (scm_i_init_guile): Register R6RS arithmetic
  extension.

* libguile/vm-i-scheme.c (fixnump): New VM primitive.
* module/language/tree-il/compile-glil.scm (*primcall-ops*): Add
  `fixnum?'.
* module/language/tree-il/primitives.scm
  (*interesting-primitive-names*, *effect-free-primitives*)
  (*effect+exception-free-primitives*): Add `fixnum?'.
---
 libguile/Makefile.am                     |    4 ++
 libguile/init.c                          |    2 +
 libguile/numbers.c                       |    1 -
 libguile/numbers.h                       |    1 +
 libguile/r6rs-arithmetic.c               |   48 ++++++++++++++++++++++++++++++
 libguile/r6rs-arithmetic.h               |   30 ++++++++++++++++++
 libguile/vm-i-scheme.c                   |    8 ++++-
 module/language/tree-il/compile-glil.scm |    1 +
 module/language/tree-il/primitives.scm   |    9 +++--
 module/rnrs/arithmetic/fixnums.scm       |   11 +++----
 10 files changed, 103 insertions(+), 12 deletions(-)
 create mode 100644 libguile/r6rs-arithmetic.c
 create mode 100644 libguile/r6rs-arithmetic.h

diff --git a/libguile/Makefile.am b/libguile/Makefile.am
index ac27eb8..01a384d 100644
--- a/libguile/Makefile.am
+++ b/libguile/Makefile.am
@@ -179,6 +179,7 @@ libguile_@GUILE_EFFECTIVE_VERSION@_la_SOURCES =				\
 	procs.c					\
 	programs.c				\
 	promises.c				\
+	r6rs-arithmetic.c			\
 	r6rs-ports.c				\
 	random.c				\
 	rdelim.c				\
@@ -275,6 +276,7 @@ DOT_X_FILES =					\
 	procprop.x				\
 	procs.x					\
 	promises.x				\
+	r6rs-arithmetic.x			\
 	r6rs-ports.x				\
 	random.x				\
 	rdelim.x				\
@@ -375,6 +377,7 @@ DOT_DOC_FILES = 				\
 	procprop.doc				\
 	procs.doc				\
 	promises.doc				\
+	r6rs-arithmetic.doc			\
 	r6rs-ports.doc				\
 	random.doc				\
 	rdelim.doc				\
@@ -569,6 +572,7 @@ modinclude_HEADERS =				\
 	programs.h				\
 	promises.h				\
 	pthread-threads.h			\
+	r6rs-arithmetic.h			\
 	r6rs-ports.h				\
 	random.h				\
 	rdelim.h				\
diff --git a/libguile/init.c b/libguile/init.c
index 8b3b8cd..2c23b1e 100644
--- a/libguile/init.c
+++ b/libguile/init.c
@@ -100,6 +100,7 @@
 #include "libguile/programs.h"
 #include "libguile/promises.h"
 #include "libguile/array-map.h"
+#include "libguile/r6rs-arithmetic.h"
 #include "libguile/random.h"
 #include "libguile/rdelim.h"
 #include "libguile/read.h"
@@ -403,6 +404,7 @@ scm_i_init_guile (void *base)
   scm_bootstrap_programs ();
   scm_bootstrap_vm ();
   scm_register_r6rs_ports ();
+  scm_register_r6rs_arithmetic ();
   scm_register_foreign ();
   scm_register_srfi_1 ();
   scm_register_srfi_60 ();
diff --git a/libguile/numbers.c b/libguile/numbers.c
index 427e772..0a10030 100644
--- a/libguile/numbers.c
+++ b/libguile/numbers.c
@@ -6122,7 +6122,6 @@ SCM_DEFINE (scm_integer_p, "integer?", 1, 0, 0,
 }
 #undef FUNC_NAME
 
-
 SCM scm_i_num_eq_p (SCM, SCM, SCM);
 SCM_PRIMITIVE_GENERIC (scm_i_num_eq_p, "=", 0, 2, 1,
                        (SCM x, SCM y, SCM rest),
diff --git a/libguile/numbers.h b/libguile/numbers.h
index ab96981..fb97785 100644
--- a/libguile/numbers.h
+++ b/libguile/numbers.h
@@ -240,6 +240,7 @@ SCM_API SCM scm_complex_p (SCM x);
 SCM_API SCM scm_real_p (SCM x);
 SCM_API SCM scm_rational_p (SCM z);
 SCM_API SCM scm_integer_p (SCM x);
+SCM_API SCM scm_fixnum_p (SCM x);
 SCM_API SCM scm_inexact_p (SCM x);
 SCM_API SCM scm_num_eq_p (SCM x, SCM y);
 SCM_API SCM scm_less_p (SCM x, SCM y);
diff --git a/libguile/r6rs-arithmetic.c b/libguile/r6rs-arithmetic.c
new file mode 100644
index 0000000..b00f1f4
--- /dev/null
+++ b/libguile/r6rs-arithmetic.c
@@ -0,0 +1,48 @@
+/* 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/>.
+ */
+
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include "libguile/_scm.h"
+#include "libguile/numbers.h"
+#include "libguile/r6rs-arithmetic.h"
+
+SCM_DEFINE (scm_fixnum_p, "fixnum?", 1, 0, 0,
+            (SCM x),
+            "Return @code{#t} if @var{x} is a fixnum, @code{#f} otherwise.")
+#define FUNC_NAME s_scm_fixnum_p
+{
+  return scm_from_bool (SCM_I_INUMP (x));
+}
+#undef FUNC_NAME
+
+void
+scm_register_r6rs_arithmetic (void)
+{
+  scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
+                            "scm_init_r6rs_arithmetic",
+			    (scm_t_extension_init_func) scm_init_r6rs_arithmetic,
+			    NULL);
+}
+
+void
+scm_init_r6rs_arithmetic (void)
+{
+#include "libguile/r6rs-arithmetic.x"
+}
diff --git a/libguile/r6rs-arithmetic.h b/libguile/r6rs-arithmetic.h
new file mode 100644
index 0000000..833426a
--- /dev/null
+++ b/libguile/r6rs-arithmetic.h
@@ -0,0 +1,30 @@
+#ifndef SCM_R6RS_ARITHMETIC_H
+#define SCM_R6RS_ARITHMETIC_H
+
+/* 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/>.
+ */
+
+\f
+
+#include "libguile/__scm.h"
+
+/* R6RS Fixnum Arithmetic  */
+
+SCM_API void scm_init_r6rs_arithmetic (void);
+SCM_INTERNAL void scm_register_r6rs_arithmetic (void);
+
+#endif /* SCM_R6RS_ARITHMETIC_H */
diff --git a/libguile/vm-i-scheme.c b/libguile/vm-i-scheme.c
index 9e249bc..21255c6 100644
--- a/libguile/vm-i-scheme.c
+++ b/libguile/vm-i-scheme.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 2001, 2009, 2010 Free Software Foundation, Inc.
+/* Copyright (C) 2001, 2009, 2010, 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
@@ -111,6 +111,12 @@ VM_DEFINE_FUNCTION (139, vectorp, "vector?", 1)
   RETURN (scm_from_bool (SCM_I_IS_VECTOR (x)));
 }
 
+VM_DEFINE_FUNCTION (210, fixnump, "fixnum?", 1)
+{
+  ARGS1 (x);
+  RETURN (scm_from_bool (SCM_I_INUMP (x)));
+}
+
 \f
 /*
  * Basic data
diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm
index f193e9d..b4d860f 100644
--- a/module/language/tree-il/compile-glil.scm
+++ b/module/language/tree-il/compile-glil.scm
@@ -108,6 +108,7 @@
    ((list? . 1) . list?)
    ((symbol? . 1) . symbol?)
    ((vector? . 1) . vector?)
+   ((fixnum? . 1) . fixnum?)
    (list . list)
    (vector . vector)
    ((class-of . 1) . class-of)
diff --git a/module/language/tree-il/primitives.scm b/module/language/tree-il/primitives.scm
index 316a462..24e6021 100644
--- a/module/language/tree-il/primitives.scm
+++ b/module/language/tree-il/primitives.scm
@@ -1,6 +1,6 @@
 ;;; open-coding primitive procedures
 
-;; Copyright (C) 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 2009, 2010, 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
@@ -21,6 +21,7 @@
 (define-module (language tree-il primitives)
   #:use-module (system base pmatch)
   #:use-module (rnrs bytevectors)
+  #:use-module (rnrs arithmetic fixnums)
   #:use-module (system base syntax)
   #:use-module (language tree-il)
   #:use-module (srfi srfi-4)
@@ -43,7 +44,7 @@
     + * - / 1- 1+ quotient remainder modulo
     ash logand logior logxor
     not
-    pair? null? list? symbol? vector? acons cons cons*
+    fixnum? pair? null? list? symbol? vector? acons cons cons*
 
     list vector
 
@@ -112,7 +113,7 @@
     = < > <= >= zero?
     + * - / 1- 1+ quotient remainder modulo
     not
-    pair? null? list? symbol? vector? acons cons cons*
+    pair? null? list? symbol? vector? fixnum? acons cons cons*
     list vector
     car cdr
     caar cadr cdar cddr
@@ -137,7 +138,7 @@
   '(values
     eq? eqv? equal?
     not
-    pair? null? list? symbol? vector? acons cons cons*
+    pair? null? list? symbol? vector? fixnum? acons cons cons*
     list vector
     struct?))
 
diff --git a/module/rnrs/arithmetic/fixnums.scm b/module/rnrs/arithmetic/fixnums.scm
index 03511ed..b519920 100644
--- a/module/rnrs/arithmetic/fixnums.scm
+++ b/module/rnrs/arithmetic/fixnums.scm
@@ -76,7 +76,9 @@
 	  fxreverse-bit-field)
   (import (only (guile) ash
 		        cons*
+			effective-version
 			inexact->exact
+			load-extension
 			logand
 			logbit?
 			logcount
@@ -93,18 +95,15 @@
 	  (rnrs exceptions (6))
 	  (rnrs lists (6)))
 
+  (load-extension (string-append "libguile-" (effective-version))
+                  "scm_init_r6rs_arithmetic")
+
   (define fixnum-width 
     (let ((w (inexact->exact (round (/ (log (+ most-positive-fixnum 1)) (log 2))))))
       (lambda () w)))
 
   (define (greatest-fixnum) most-positive-fixnum)
   (define (least-fixnum) most-negative-fixnum)
-  
-  (define (fixnum? obj) 
-    (and (integer? obj) 
-	 (exact? obj) 
-	 (>= obj most-negative-fixnum) 
-	 (<= obj most-positive-fixnum)))
 
   (define-syntax assert-fixnum
     (syntax-rules ()
-- 
1.7.4.1