[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[PATCH 3/3] Add `fixnum?' VM primitive
From: |
Andreas Rottmann |
Subject: |
[PATCH 3/3] Add `fixnum?' VM primitive |
Date: |
Sat, 2 Apr 2011 19:42:28 +0200 |
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 @@ address@hidden@_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/>.
+ */
+
+
+
+#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)));
+}
+
/*
* 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
- R6RS fixnum arithmetic optimizations, Andreas Rottmann, 2011/04/02
- [PATCH 1/3] Add a few benchmarks for R6RS fixnum arithmetic, Andreas Rottmann, 2011/04/02
- [PATCH 2/3] Several optimizations for R6RS fixnum arithmetic, Andreas Rottmann, 2011/04/02
- [PATCH 3/3] Add `fixnum?' VM primitive,
Andreas Rottmann <=
- Re: [PATCH 3/3] Add `fixnum?' VM primitive, Andy Wingo, 2011/04/04
- Re: [PATCH 3/3] Add `fixnum?' VM primitive, Andreas Rottmann, 2011/04/04
- define-inlinable, Ludovic Courtès, 2011/04/06
- Re: define-inlinable, Andreas Rottmann, 2011/04/06
- Re: define-inlinable, Ludovic Courtès, 2011/04/06
- Re: define-inlinable, Andy Wingo, 2011/04/11
- Re: define-inlinable, Ludovic Courtès, 2011/04/11
- Re: define-inlinable, Andy Wingo, 2011/04/11
- Re: define-inlinable, Andreas Rottmann, 2011/04/11
- Re: [PATCH 3/3] Add `fixnum?' VM primitive, Ludovic Courtès, 2011/04/07