|
[Sbcl-commits] CVS: sbcl/src/code numbers.lisp,1.47,1.48 pred.lisp,1.19,1.20
From: Juho Snellman <jsnell@us...> - 2005-12-28 22:37
|
Update of /cvsroot/sbcl/sbcl/src/code
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv15181/src/code
Modified Files:
numbers.lisp pred.lisp
Log Message:
0.9.8.3:
Make EQUAL faster (about 50% improvement for short lists on x86-64).
As amazing as it might seem, there are actually real-world
applications where significant time is spent in EQUAL.
* Inline EQL in EQUAL
* Rearrange things a bit to enable the inlining
* Rewrite EQUAL to use a local helper function
Index: numbers.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/numbers.lisp,v
retrieving revision 1.47
retrieving revision 1.48
diff -u -d -r1.47 -r1.48
--- numbers.lisp 2 Oct 2005 00:32:00 -0000 1.47
+++ numbers.lisp 28 Dec 2005 22:37:14 -0000 1.48
@@ -969,39 +969,6 @@
((complex (or float rational))
(and (= (realpart x) y)
(zerop (imagpart x))))))
-
-(defun eql (obj1 obj2)
- #!+sb-doc
- "Return T if OBJ1 and OBJ2 represent the same object, otherwise NIL."
- (or (eq obj1 obj2)
- (if (or (typep obj2 'fixnum)
- (not (typep obj2 'number)))
- nil
- (macrolet ((foo (&rest stuff)
- `(typecase obj2
- ,@(mapcar (lambda (foo)
- (let ((type (car foo))
- (fn (cadr foo)))
- `(,type
- (and (typep obj1 ',type)
- (,fn obj1 obj2)))))
- stuff))))
- (foo
- (single-float eql)
- (double-float eql)
- #!+long-float
- (long-float eql)
- (bignum
- (lambda (x y)
- (zerop (bignum-compare x y))))
- (ratio
- (lambda (x y)
- (and (eql (numerator x) (numerator y))
- (eql (denominator x) (denominator y)))))
- (complex
- (lambda (x y)
- (and (eql (realpart x) (realpart y))
- (eql (imagpart x) (imagpart y))))))))))
;;;; logicals
Index: pred.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/pred.lisp,v
retrieving revision 1.19
retrieving revision 1.20
diff -u -d -r1.19 -r1.20
--- pred.lisp 9 Sep 2005 14:16:18 -0000 1.19
+++ pred.lisp 28 Dec 2005 22:37:14 -0000 1.20
@@ -160,6 +160,43 @@
"Return T if OBJ1 and OBJ2 are the same object, otherwise NIL."
(eq obj1 obj2))
+(declaim (inline %eql))
+(defun %eql (obj1 obj2)
+ #!+sb-doc
+ "Return T if OBJ1 and OBJ2 represent the same object, otherwise NIL."
+ (or (eq obj1 obj2)
+ (if (or (typep obj2 'fixnum)
+ (not (typep obj2 'number)))
+ nil
+ (macrolet ((foo (&rest stuff)
+ `(typecase obj2
+ ,@(mapcar (lambda (foo)
+ (let ((type (car foo))
+ (fn (cadr foo)))
+ `(,type
+ (and (typep obj1 ',type)
+ (,fn obj1 obj2)))))
+ stuff))))
+ (foo
+ (single-float eql)
+ (double-float eql)
+ #!+long-float
+ (long-float eql)
+ (bignum
+ (lambda (x y)
+ (zerop (bignum-compare x y))))
+ (ratio
+ (lambda (x y)
+ (and (eql (numerator x) (numerator y))
+ (eql (denominator x) (denominator y)))))
+ (complex
+ (lambda (x y)
+ (and (eql (realpart x) (realpart y))
+ (eql (imagpart x) (imagpart y))))))))))
+
+(defun eql (x y)
+ (%eql x y))
+
(defun bit-vector-= (x y)
(declare (type bit-vector x y))
(if (and (simple-bit-vector-p x)
@@ -179,19 +216,23 @@
whose elements are EQUAL. Strings and bit-vectors are EQUAL if they
are the same length and have identical components. Other arrays must be
EQ to be EQUAL."
- (cond ((eql x y) t)
- ((consp x)
- (and (consp y)
- (equal (car x) (car y))
- (equal (cdr x) (cdr y))))
- ((stringp x)
- (and (stringp y) (string= x y)))
- ((pathnamep x)
- (and (pathnamep y) (pathname= x y)))
- ((bit-vector-p x)
- (and (bit-vector-p y)
- (bit-vector-= x y)))
- (t nil)))
+ (labels ((equal-aux (x y)
+ (cond ((%eql x y)
+ t)
+ ((consp x)
+ (and (consp y)
+ (equal-aux (car x) (car y))
+ (equal-aux (cdr x) (cdr y))))
+ ((stringp x)
+ (and (stringp y) (string= x y)))
+ ((pathnamep x)
+ (and (pathnamep y) (pathname= x y)))
+ ((bit-vector-p x)
+ (and (bit-vector-p y)
+ (bit-vector-= x y)))
+ (t nil))))
+ (declare (maybe-inline equal-aux))
+ (equal-aux x y)))
;;; EQUALP comparison of HASH-TABLE values
(defun hash-table-equalp (x y)
|
| Thread | Author | Date |
|---|---|---|
| [Sbcl-commits] CVS: sbcl/src/code numbers.lisp,1.47,1.48 pred.lisp,1.19,1.20 | Juho Snellman <jsnell@us...> |