From 2515dc55c8690232a345e8b027163c3d806a8ecb Mon Sep 17 00:00:00 2001
From: jjgarcia <jjgarcia>
Date: Thu, 29 May 2008 06:44:55 +0000
Subject: [PATCH 01/14] No GC_* function can be called before GC_init

---
 src/c/alloc_2.d | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/src/c/alloc_2.d b/src/c/alloc_2.d
index 73e471da8..06ca937d6 100644
--- a/src/c/alloc_2.d
+++ b/src/c/alloc_2.d
@@ -190,9 +190,9 @@ init_alloc(void)
 	alloc_initialized = TRUE;
 
 	GC_no_dls = 1;
-	GC_register_displacement(1);
 	GC_all_interior_pointers = 0;
 	GC_init();
+	GC_register_displacement(1);
 #if 0
 	GC_init_explicit_typing();
 #endif

From 5c387aa367ee2d8985d3dfd0a72e58373b32a75e Mon Sep 17 00:00:00 2001
From: jjgarcia <jjgarcia>
Date: Thu, 29 May 2008 06:45:28 +0000
Subject: [PATCH 02/14] *print-circle* and other variables interfered and
 slowed gentemp/gensym

---
 src/c/symbol.d | 16 ++++++++++------
 1 file changed, 10 insertions(+), 6 deletions(-)

diff --git a/src/c/symbol.d b/src/c/symbol.d
index 6fcfca619..874e9303b 100644
--- a/src/c/symbol.d
+++ b/src/c/symbol.d
@@ -347,11 +347,13 @@ cl_symbol_name(cl_object x)
 		goto AGAIN;
 	}
 	output = ecl_make_string_output_stream(64);
+	bds_bind(@'*print-escape*', Cnil);
+	bds_bind(@'*print-readably*', Cnil);
 	bds_bind(@'*print-base*', MAKE_FIXNUM(10));
 	bds_bind(@'*print-radix*', Cnil);
-	ecl_princ(prefix, output);
-	ecl_princ(counter, output);
-	bds_unwind_n(2);
+	si_write_ugly_object(prefix, output);
+	si_write_ugly_object(counter, output);
+	bds_unwind_n(4);
 	output = cl_make_symbol(cl_get_output_stream_string(output));
 	if (increment)
 		ECL_SETQ(@'*gensym-counter*',ecl_one_plus(counter));
@@ -366,11 +368,13 @@ cl_symbol_name(cl_object x)
 	pack = si_coerce_to_package(pack);
 ONCE_MORE:
 	output = ecl_make_string_output_stream(64);
+	bds_bind(@'*print-escape*', Cnil);
+	bds_bind(@'*print-readably*', Cnil);
 	bds_bind(@'*print-base*', MAKE_FIXNUM(10));
 	bds_bind(@'*print-radix*', Cnil);
-	ecl_princ(prefix, output);
-	ecl_princ(cl_core.gentemp_counter, output);
-	bds_unwind_n(2);
+	si_write_ugly_object(prefix, output);
+	si_write_ugly_object(cl_core.gentemp_counter, output);
+	bds_unwind_n(4);
 	cl_core.gentemp_counter = ecl_one_plus(cl_core.gentemp_counter);
 	s = ecl_intern(cl_get_output_stream_string(output), pack, &intern_flag);
 	if (intern_flag != 0)

From 83d3be00ead4e87189ec8aa662a53759bd37efec Mon Sep 17 00:00:00 2001
From: jjgarcia <jjgarcia>
Date: Thu, 29 May 2008 06:45:53 +0000
Subject: [PATCH 03/14] Call upgraded-array-element-type directly instead of
 using cl_funcall.

---
 src/c/array.d | 2 +-
 src/c/cinit.d | 6 ++++++
 2 files changed, 7 insertions(+), 1 deletion(-)

diff --git a/src/c/array.d b/src/c/array.d
index ec32db147..2e10290d2 100644
--- a/src/c/array.d
+++ b/src/c/array.d
@@ -540,7 +540,7 @@ ecl_symbol_to_elttype(cl_object x)
 	else if (x == Cnil) {
 		FEerror("ECL does not support arrays with element type NIL", 0);
 	}
-	x = cl_funcall(2, @'upgraded-array-element-type', x);
+	x = cl_upgraded_array_element_type(1, x);
 	goto BEGIN;
 }
 
diff --git a/src/c/cinit.d b/src/c/cinit.d
index 5696c625a..0bd6153d4 100644
--- a/src/c/cinit.d
+++ b/src/c/cinit.d
@@ -28,6 +28,12 @@
  * called instead.
  */
 
+extern cl_object
+cl_upgraded_array_element_type(cl_narg narg, cl_object type, ...)
+{
+	return cl_funcall(2, @'upgraded-array-element-type', type);
+}
+
 extern cl_object
 si_safe_eval(cl_narg arg, cl_object form, cl_object env, cl_object error_value, ...)
 {

From be239d8bf7f4ed79910b44e6f6f982b7f0ae951e Mon Sep 17 00:00:00 2001
From: jjgarcia <jjgarcia>
Date: Thu, 29 May 2008 06:46:38 +0000
Subject: [PATCH 04/14] Remove unused variables from CONCATENATE

---
 src/lsp/arraylib.lsp |  7 +++----
 src/lsp/seq.lsp      | 28 +++++++++++++---------------
 2 files changed, 16 insertions(+), 19 deletions(-)

diff --git a/src/lsp/arraylib.lsp b/src/lsp/arraylib.lsp
index 5a51ec30d..7fb23c5e8 100644
--- a/src/lsp/arraylib.lsp
+++ b/src/lsp/arraylib.lsp
@@ -84,10 +84,9 @@ contiguous block."
   "Args: (&rest objects)
 Creates and returns a simple-vector, with the N-th OBJECT being the N-th
 element."
-  (make-array (list (length objects))
-	      :element-type t
-	      :initial-contents objects))
-
+  (let ((a (si:make-vector t (length objects) nil nil nil 0)))
+    (fill-array a objects)
+    a))
 
 (defun array-dimensions (array)
   "Args: (array)
diff --git a/src/lsp/seq.lsp b/src/lsp/seq.lsp
index b2defbafb..6262b6d7a 100644
--- a/src/lsp/seq.lsp
+++ b/src/lsp/seq.lsp
@@ -139,10 +139,10 @@ default value of INITIAL-ELEMENT depends on TYPE."
 	 (setf start 0))
 	((not (integerp start))
 	 (error "Value ~A is not a valid index into sequence ~A" start sequence)))
-  (cond ((>= start (length sequence))
-	 nil)
-	((consp sequence)
+  (cond ((consp sequence)
 	 (nthcdr start sequence))
+	((>= start (length sequence))
+	 nil)
 	(t
 	 start)))
 
@@ -166,18 +166,16 @@ default value of INITIAL-ELEMENT depends on TYPE."
   "Args: (type &rest sequences)
 Returns a new sequence of the specified type, consisting of all elements of
 SEQUENCEs."
-  (do* ((x (make-sequence result-type
-			 (apply #'+ (mapcar #'length sequences))))
-        (s sequences (cdr s))
-        (ix (make-seq-iterator x)))
-      ((null s) x)
-    (declare (fixnum i))
-    (do ((js (make-seq-iterator (car s)) (seq-iterator-next (car s) js))
-         (n (length (car s))))
-        ((null js))
-      (declare (fixnum j n))
-      (seq-iterator-set x ix (seq-iterator-ref (car s) js))
-      (setq ix (seq-iterator-next x ix)))))
+  (do* ((length-list (mapcar #'length sequences) (rest length-list))
+	(output (make-sequence result-type (apply #'+ length-list)))
+        (sequences sequences (rest sequences))
+        (i (make-seq-iterator output)))
+      ((null sequences) output)
+    (do* ((s (first sequences))
+	  (j (make-seq-iterator s) (seq-iterator-next s j)))
+	 ((null j))
+      (seq-iterator-set output i (seq-iterator-ref s j))
+      (setq i (seq-iterator-next output i)))))
 
 
 (defun map (result-type function sequence &rest more-sequences)

From 1551bc2b9bfb8351a5f353158e20f6ba50805990 Mon Sep 17 00:00:00 2001
From: jjgarcia <jjgarcia>
Date: Thu, 29 May 2008 06:47:17 +0000
Subject: [PATCH 05/14] Establish quick TYPEP checkers for BASE-STRING and
 BIT-VECTOR

---
 src/lsp/predlib.lsp | 2 ++
 1 file changed, 2 insertions(+)

diff --git a/src/lsp/predlib.lsp b/src/lsp/predlib.lsp
index eaac19570..e8e38f1e3 100644
--- a/src/lsp/predlib.lsp
+++ b/src/lsp/predlib.lsp
@@ -217,6 +217,8 @@ has no fill-pointer, and is not adjustable."
              #-unicode
 	     (EXTENDED-CHAR . CONSTANTLY-NIL)
 	     (BASE-CHAR . BASE-CHAR-P)
+	     (BASE-STRING . BASE-STRING-P)
+	     (BIT-VECTOR . BIT-VECTOR-P)
 	     (CHARACTER . CHARACTERP)
 	     (COMPILED-FUNCTION . COMPILED-FUNCTION-P)
 	     (COMPLEX . COMPLEXP)

From a7912d704c414504ec936f7a3ab17721c185ee7f Mon Sep 17 00:00:00 2001
From: jjgarcia <jjgarcia>
Date: Thu, 29 May 2008 06:47:39 +0000
Subject: [PATCH 06/14] '* is not a good output for CLOSEST-VECTOR-TYPE.

---
 src/lsp/seq.lsp | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/src/lsp/seq.lsp b/src/lsp/seq.lsp
index 6262b6d7a..27a5a52f8 100644
--- a/src/lsp/seq.lsp
+++ b/src/lsp/seq.lsp
@@ -41,7 +41,7 @@
 	   (setq name type args nil)))
     (case name
       ((VECTOR)
-       (setq elt-type (if (endp args) '* (first args))
+       (setq elt-type (if (endp args) 'T (first args))
 	     length (if (endp (rest args)) '* (second args))))
       ((SIMPLE-VECTOR)
        (setq elt-type 'T

From d5d76014a32601b4a86c73405873d74a9a7c07ec Mon Sep 17 00:00:00 2001
From: jjgarcia <jjgarcia>
Date: Thu, 29 May 2008 06:47:57 +0000
Subject: [PATCH 07/14] MAKE-SEQUENCE and associated functions used SUBTYPEP at
 least once. We now avoid that call.

---
 src/cmp/sysfun.lsp    |  2 +-
 src/lsp/defstruct.lsp |  2 +-
 src/lsp/seq.lsp       | 53 ++++++++++++++++++++++++-------------------
 3 files changed, 32 insertions(+), 25 deletions(-)

diff --git a/src/cmp/sysfun.lsp b/src/cmp/sysfun.lsp
index a2660240c..5df7fa079 100644
--- a/src/cmp/sysfun.lsp
+++ b/src/cmp/sysfun.lsp
@@ -1453,7 +1453,7 @@ type_of(#0)==t_bitvector")
     si::check-keyword si::check-arg-length si::dm-too-few-arguments si::dm-bad-key
     remove-documentation si::get-documentation
     si::set-documentation si::expand-set-documentation
-    si::closest-vector-type si::packages-iterator
+    si::packages-iterator
     si::pprint-logical-block-helper si::pprint-pop-helper
     si::make-seq-iterator si::seq-iterator-ref si::seq-iterator-set si::seq-iterator-next
     si::structure-type-error si::define-structure
diff --git a/src/lsp/defstruct.lsp b/src/lsp/defstruct.lsp
index 1050da8aa..da5b7ca66 100644
--- a/src/lsp/defstruct.lsp
+++ b/src/lsp/defstruct.lsp
@@ -170,7 +170,7 @@
           ((subtypep type 'VECTOR)
            `(defun ,constructor-name ,keys
               (make-array ',(list (length slot-names))
-			  :element-type ',(closest-vector-type type)
+			  :element-type ',(closest-sequence-type type)
 	       		  :initial-contents (list ,@slot-names))))
           ((eq type 'LIST)
            `(defun ,constructor-name ,keys
diff --git a/src/lsp/seq.lsp b/src/lsp/seq.lsp
index 27a5a52f8..9b5bc4ea2 100644
--- a/src/lsp/seq.lsp
+++ b/src/lsp/seq.lsp
@@ -31,7 +31,7 @@
 	 :expected-type type
 	 :datum object))
 
-(defun closest-vector-type (type)
+(defun closest-sequence-type (type)
   (let (elt-type length name args)
     (cond ((consp type)
 	   (setq name (first type) args (cdr type)))
@@ -40,6 +40,10 @@
 	  (t
 	   (setq name type args nil)))
     (case name
+      ((LIST)
+       ;; This is the only descriptor that does not match a real
+       ;; array type.
+       (setq elt-type 'LIST length '*))
       ((VECTOR)
        (setq elt-type (if (endp args) 'T (first args))
 	     length (if (endp (rest args)) '* (second args))))
@@ -76,6 +80,8 @@
        ;; type is *. Instead we just compare with some specialized
        ;; types and otherwise fail.
        (dolist (i '(
+		    (NIL . NIL)
+		    (LIST . LIST)
                     #-unicode
                     (SIMPLE-STRING . BASE-CHAR)
                     #-unicode
@@ -103,6 +109,9 @@
 		    (error-sequence-type type)))
 	  (when (subtypep type (car i))
 	    (setq elt-type (cdr i) length '*)
+	    ;; The (NIL . NIL) case above
+	    (unless elt-type
+	      (error-sequence-type type))
 	    (return)))))
     (values elt-type length)))
 
@@ -111,28 +120,26 @@
 Creates and returns a sequence of the given TYPE and LENGTH.  If INITIAL-
 ELEMENT is given, then it becomes the elements of the created sequence.  The
 default value of INITIAL-ELEMENT depends on TYPE."
-  (if (subtypep type 'LIST)
-      (progn
-	(when (subtypep type 'NIL)
-	  (error-sequence-type type))
-	(setq sequence (make-list size :initial-element initial-element))
-	(unless (subtypep 'LIST type)
-	  (when (or (and (subtypep type 'NULL) (plusp size))
-		    (and (subtypep type 'CONS) (zerop size)))
-	    (error-sequence-length (make-list size :initial-element initial-element) type 0))))
-      (multiple-value-bind (element-type length)
-	  (closest-vector-type type)
-	(setq sequence (sys:make-vector (if (eq element-type '*) T element-type)
-					size nil nil nil nil))
-	(when iesp
-	  (do ((i 0 (1+ i))
-	       (size size))
-	      ((>= i size))
-	    (declare (fixnum i size))
-	    (setf (elt sequence i) initial-element)))
-	(unless (or (eql length '*) (eql length size))
-	  (error-sequence-length sequence type size))))
-  sequence)
+  (multiple-value-bind (element-type length)
+      (closest-sequence-type type)
+    (cond ((eq element-type 'LIST)
+	   (setq sequence (make-list size :initial-element initial-element))
+	   (unless (subtypep 'LIST type)
+	     (when (or (and (subtypep type 'NULL) (plusp size))
+		       (and (subtypep type 'CONS) (zerop size)))
+	       (error-sequence-length (make-list size :initial-element initial-element) type 0))))
+	  (t
+	   (setq sequence (sys:make-vector (if (eq element-type '*) T element-type)
+					   size nil nil nil nil))
+	   (when iesp
+	     (do ((i 0 (1+ i))
+		  (size size))
+		 ((>= i size))
+	       (declare (fixnum i size))
+	       (setf (elt sequence i) initial-element)))
+	   (unless (or (eql length '*) (eql length size))
+	     (error-sequence-length sequence type size))))
+    sequence))
 
 (defun make-seq-iterator (sequence &optional (start 0))
   (cond ((null start)

From 79a4547523a93712867a373dc84124592360d03e Mon Sep 17 00:00:00 2001
From: jjgarcia <jjgarcia>
Date: Thu, 29 May 2008 06:48:19 +0000
Subject: [PATCH 08/14] Close the library before the error handler changes the
 block.

---
 src/c/ffi.d | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/src/c/ffi.d b/src/c/ffi.d
index 70d4ff005..5b9b6f6ae 100644
--- a/src/c/ffi.d
+++ b/src/c/ffi.d
@@ -434,8 +434,8 @@ si_load_foreign_module(cl_object filename)
 	output = ecl_library_open(filename, 0);
 	if (output->cblock.handle == NULL)
 	{
-		output = ecl_library_error(output);
 		ecl_library_close(output);
+		output = ecl_library_error(output);
 	}
 OUTPUT:
 #ifdef ECL_THREADS

From 512462cecd93a493dab47b370bd150e22ecf332a Mon Sep 17 00:00:00 2001
From: jjgarcia <jjgarcia>
Date: Thu, 29 May 2008 06:48:44 +0000
Subject: [PATCH 09/14] Exported the hashing functions

---
 src/c/hash.d          | 30 ++++++++++++++++++++++++++++++
 src/c/symbols_list.h  |  4 ++++
 src/c/symbols_list2.h |  4 ++++
 src/h/external.h      |  3 +++
 4 files changed, 41 insertions(+)

diff --git a/src/c/hash.d b/src/c/hash.d
index 479beb04a..73267711d 100644
--- a/src/c/hash.d
+++ b/src/c/hash.d
@@ -613,6 +613,36 @@ cl_sxhash(cl_object key)
 	@(return MAKE_FIXNUM(output & mask))
 }
 
+@(defun si::hash-eql (&rest args)
+	cl_index h;
+@
+	for (h = 0; narg; narg--) {
+		cl_object o = cl_va_arg(args);
+		h = _hash_eql(h, o);
+	}
+	@(return MAKE_FIXNUM(h))
+@)
+
+@(defun si::hash-equal (&rest args)
+	cl_index h;
+@
+	for (h = 0; narg; narg--) {
+		cl_object o = cl_va_arg(args);
+		h = _hash_equal(0, h, o);
+	}
+	@(return MAKE_FIXNUM(h))
+@)
+
+@(defun si::hash-equalp (&rest args)
+	cl_index h;
+@
+	for (h = 0; narg; narg--) {
+		cl_object o = cl_va_arg(args);
+		h = _hash_equalp(0, h, o);
+	}
+	@(return MAKE_FIXNUM(h))
+@)
+
 cl_object
 cl_maphash(cl_object fun, cl_object ht)
 {
diff --git a/src/c/symbols_list.h b/src/c/symbols_list.h
index a4c66a8f9..1c656428d 100644
--- a/src/c/symbols_list.h
+++ b/src/c/symbols_list.h
@@ -1699,5 +1699,9 @@ cl_symbols[] = {
 
 {SYS_ "BYTECODES", SI_ORDINARY, NULL, 1, OBJNULL},
 
+{SYS_ "HASH-EQL", SI_ORDINARY, si_hash_eql, -1, OBJNULL},
+{SYS_ "HASH-EQUAL", SI_ORDINARY, si_hash_equal, -1, OBJNULL},
+{SYS_ "HASH-EQUALP", SI_ORDINARY, si_hash_equalp, -1, OBJNULL},
+
 /* Tag for end of list */
 {NULL, CL_ORDINARY, NULL, -1, OBJNULL}};
diff --git a/src/c/symbols_list2.h b/src/c/symbols_list2.h
index 962c73fc1..50cd2ce46 100644
--- a/src/c/symbols_list2.h
+++ b/src/c/symbols_list2.h
@@ -1699,5 +1699,9 @@ cl_symbols[] = {
 
 {SYS_ "BYTECODES",NULL},
 
+{SYS_ "HASH-EQL","si_hash_eql"},
+{SYS_ "HASH-EQUAL","si_hash_equal"},
+{SYS_ "HASH-EQUALP","si_hash_equalp"},
+
 /* Tag for end of list */
 {NULL,NULL}};
diff --git a/src/h/external.h b/src/h/external.h
index fb6069e10..df517310c 100644
--- a/src/h/external.h
+++ b/src/h/external.h
@@ -678,6 +678,9 @@ extern ECL_API cl_object si_hash_table_iterator(cl_object ht);
 extern ECL_API cl_object cl_make_hash_table _ARGS((cl_narg narg, ...));
 extern ECL_API cl_object cl_gethash _ARGS((cl_narg narg, cl_object key, cl_object ht, ...));
 extern ECL_API cl_object si_copy_hash_table(cl_object orig);
+extern ECL_API cl_object si_hash_eql _ARGS((cl_narg narg, ...));
+extern ECL_API cl_object si_hash_equal _ARGS((cl_narg narg, ...));
+extern ECL_API cl_object si_hash_equalp _ARGS((cl_narg narg, ...));
 
 extern ECL_API void ecl_sethash(cl_object key, cl_object hashtable, cl_object value);
 extern ECL_API cl_object ecl_gethash(cl_object key, cl_object hash);

From 2aa5b079109b3fb7e557196268626ac4a7d9355c Mon Sep 17 00:00:00 2001
From: jjgarcia <jjgarcia>
Date: Thu, 29 May 2008 06:49:08 +0000
Subject: [PATCH 10/14] Implemented a cache for SUBTYPEP

---
 src/clos/standard.lsp |  5 +++++
 src/lsp/predlib.lsp   | 33 ++++++++++++++++++++++++++++-----
 2 files changed, 33 insertions(+), 5 deletions(-)

diff --git a/src/clos/standard.lsp b/src/clos/standard.lsp
index 8f77ecc77..2f6d2111f 100644
--- a/src/clos/standard.lsp
+++ b/src/clos/standard.lsp
@@ -273,6 +273,11 @@ because it contains a reference to the undefined class~%  ~A"
     ;; This is not really needed, because when we modify the list of slots
     ;; all instances automatically become obsolete (See change.lsp)
     ;(make-instances-obsolete class)
+    ;;
+    ;; But this is really needed: we have to clear the different type caches
+    ;; for type comparisons and so on.
+    ;;
+    (si::subtypep-clear-cache)
     )
   ;; As mentioned above, when a parent is finalized, it is responsible for
   ;; invoking FINALIZE-INHERITANCE on all of its children. Obviously,
diff --git a/src/lsp/predlib.lsp b/src/lsp/predlib.lsp
index e8e38f1e3..34c9f9e19 100644
--- a/src/lsp/predlib.lsp
+++ b/src/lsp/predlib.lsp
@@ -14,6 +14,12 @@
 
 (in-package "SYSTEM")
 
+(defvar *subtypep-cache* (si:make-vector t 256 nil nil nil 0))
+
+(defun subtypep-clear-cache ()
+  (and (fboundp 'fill)
+       (fill *subtypep-cache* nil)))
+
 (defun create-type-name (name)
   (when (member name *alien-declarations*)
     (error "Symbol ~s is a declaration specifier and cannot be used to name a new type" name)))
@@ -24,6 +30,7 @@
   (create-type-name name)
   (put-sysprop name 'DEFTYPE-FORM form)
   (put-sysprop name 'DEFTYPE-DEFINITION function)
+  (subtypep-clear-cache)
   name)
 
 ;;; DEFTYPE macro.
@@ -1222,10 +1229,26 @@ if not possible."
 	   (values nil nil)))))
 
 (defun subtypep (t1 t2 &optional env)
+  ;; One easy case: types are equal
   (when (eq t1 t2)
     (return-from subtypep (values t t)))
-  (let* ((*highest-type-tag* *highest-type-tag*)
-	 (*save-types-database* t)
-	 (*member-types* *member-types*)
-	 (*elementary-types* *elementary-types*))
-    (fast-subtypep t1 t2)))
+  ;; Another easy case: types are classes.
+  (when (and (instancep t1) (instancep t2)
+	     (clos::classp t1) (clos::classp t2))
+    (return-from subtypep (subclassp t1 t2) t))
+  ;; Finally, cached results.
+  (let* ((cache *subtypep-cache*)
+	 (hash (logand (hash-eql t1 t2) 255))
+	 (elt (aref cache hash)))
+    (declare (type (integer 0 255) hash))
+    (when (and elt (eq (caar elt) t1) (eq (cdar elt) t2))
+      (setf elt (cdr elt))
+      (return-from subtypep (values (car elt) (cdr elt))))
+    (let* ((*highest-type-tag* *highest-type-tag*)
+	   (*save-types-database* t)
+	   (*member-types* *member-types*)
+	   (*elementary-types* *elementary-types*))
+      (multiple-value-bind (test confident)
+	  (fast-subtypep t1 t2)
+	(setf (aref cache hash) (cons (cons t1 t2) (cons test confident)))
+	(values test confident)))))

From d03680f014eef27b4a0bf6cdb215f74380d2e2b7 Mon Sep 17 00:00:00 2001
From: jjgarcia <jjgarcia>
Date: Thu, 29 May 2008 06:49:28 +0000
Subject: [PATCH 11/14] Cache results from upgraded-array-element-type

---
 src/lsp/predlib.lsp | 27 +++++++++++++++++++--------
 1 file changed, 19 insertions(+), 8 deletions(-)

diff --git a/src/lsp/predlib.lsp b/src/lsp/predlib.lsp
index 34c9f9e19..707426b32 100644
--- a/src/lsp/predlib.lsp
+++ b/src/lsp/predlib.lsp
@@ -16,9 +16,12 @@
 
 (defvar *subtypep-cache* (si:make-vector t 256 nil nil nil 0))
 
+(defvar *upgraded-array-element-type-cache* (si:make-vector t 128 nil nil nil 0))
+
 (defun subtypep-clear-cache ()
-  (and (fboundp 'fill)
-       (fill *subtypep-cache* nil)))
+  (when (fboundp 'fill)
+    (fill *subtypep-cache* nil)
+    (fill *upgraded-array-element-type-cache* nil)))
 
 (defun create-type-name (name)
   (when (member name *alien-declarations*)
@@ -263,11 +266,19 @@ has no fill-pointer, and is not adjustable."
   '(NIL BASE-CHAR #+unicode CHARACTER BIT EXT::BYTE8 EXT::INTEGER8 EXT::CL-FIXNUM EXT::CL-INDEX SINGLE-FLOAT DOUBLE-FLOAT T))
 
 (defun upgraded-array-element-type (element-type &optional env)
-  (if (member element-type +upgraded-array-element-types+ :test #'eq)
-      element-type
-      (dolist (v +upgraded-array-element-types+ 'T)
-	(when (subtypep element-type v)
-	  (return v)))))
+  (let* ((hash (logand 127 (si:hash-eql element-type)))
+	 (record (aref *upgraded-array-element-type-cache* hash)))
+    (declare (type (integer 0 127) hash))
+    (if (and record (eq (car record) element-type))
+	(cdr record)
+	(let ((answer (or (member element-type +upgraded-array-element-types+
+				  :test #'eq)
+			  (dolist (v +upgraded-array-element-types+ 'T)
+			    (when (subtypep element-type v)
+			      (return v))))))
+	  (setf (aref *upgraded-array-element-type-cache* hash)
+		(cons element-type answer))
+	  answer))))
 
 (defun upgraded-complex-part-type (real-type &optional env)
   ;; ECL does not have specialized complex types. If we had them, the
@@ -1235,7 +1246,7 @@ if not possible."
   ;; Another easy case: types are classes.
   (when (and (instancep t1) (instancep t2)
 	     (clos::classp t1) (clos::classp t2))
-    (return-from subtypep (subclassp t1 t2) t))
+    (return-from subtypep (values (subclassp t1 t2) t)))
   ;; Finally, cached results.
   (let* ((cache *subtypep-cache*)
 	 (hash (logand (hash-eql t1 t2) 255))

From 2e100452ce2879dd747bc6c86f45d36da92e296f Mon Sep 17 00:00:00 2001
From: jjgarcia <jjgarcia>
Date: Thu, 29 May 2008 06:49:49 +0000
Subject: [PATCH 12/14] Implemented an optimizer for COERCE and improved the
 one for TYPEP, which did not handle sequence types.

---
 src/cmp/cmpopt.lsp  | 156 +++++++++++++++++++++++++++++++++++++++++++-
 src/lsp/predlib.lsp | 107 +++++++++++++++++++-----------
 2 files changed, 222 insertions(+), 41 deletions(-)

diff --git a/src/cmp/cmpopt.lsp b/src/cmp/cmpopt.lsp
index 74cc9d5aa..efb9fa843 100644
--- a/src/cmp/cmpopt.lsp
+++ b/src/cmp/cmpopt.lsp
@@ -48,21 +48,40 @@
   ;; step. Otherwise the compiler macro will enter an infinite loop.
   (let* ((space (cmp-env-optimization 'space env))
 	 (speed (cmp-env-optimization 'speed env))
+	 (safety (cmp-env-optimization 'safety env))
+	 (orig-type type)
 	 aux function
 	 first rest)
     (declare (si::fixnum space speed))
     (cond ((not (and (constantp type) (setf type (cmp-eval type)) t))
 	   form)
+	  ;; Type is not known
+	  ((not (known-type-p type))
+	   form)
 	  ;; Simple ones
-	  ((eq type 'T) T)
+	  ((subtypep 'T type) T)
 	  ((eq type 'NIL) NIL)
 	  ((eq aux 'SATISFIES)
 	   `(funcall #',function ,object))
 	  ;;
+	  ;; Detect inconsistencies in the provided type. If we run at low
+	  ;; safety, we will simply assume the user knows what she's doing.
+	  ((subtypep type NIL)
+	   (cmpwarn "TYPEP form contains an empty type ~S and cannot be optimized" type)
+	   (if (< safety 1)
+	       NIL
+	       form))
+	  ;;
 	  ;; There exists a function which checks for this type?
 	  ((setf function (get-sysprop type 'si::type-predicate))
 	   `(,function ,object))
 	  ;;
+	  ;; Similar as before, but we assume the user did not give us
+	  ;; the right name, or gave us an equivalent type.
+	  ((loop for (a-type . function-name) in si::+known-typep-predicates+
+	      when (si::type= type a-type)
+	      do (return `(,function-name ,object))))
+	  ;;
 	  ;; The following are not real functions, but are expanded by the
 	  ;; compiler into C forms.
 	  ((setf function (assoc type '((SINGLE-FLOAT . SINGLE-FLOAT-P)
@@ -81,6 +100,11 @@
 	  ((and (>= space 2) (> space speed))
 	   form)
 	  ;;
+	  ;; CONS types. They must be checked _before_ sequence types. We
+	  ;; do not produce optimized forms because they can be recursive.
+	  ((and (consp type) (eq (first type) 'CONS))
+	   form)
+	  ;;
 	  ;; The type denotes a known class and we can check it
 	  #+clos
 	  ((setf aux (find-class type nil))
@@ -94,7 +118,7 @@
 	  ((setf rest (rest type)
 		 first (first type)
 		 function (get-sysprop first 'SI::DEFTYPE-DEFINITION))
-	   (expand-typep form object (apply function rest) env))
+	   (expand-typep form object `',(apply function rest) env))
 	  ;;
 	  ;; (TYPEP o '(NOT t)) => (NOT (TYPEP o 't))
 	  ((eq first 'NOT)
@@ -155,3 +179,131 @@
 	      (setq ,list-var (rest ,typed-var)))
 	   ,(when output-form `(setq ,var nil))
 	   ,output-form)))))
+
+;;;
+;;; COERCE
+;;;
+;;; Simple coercion rules are implemented using the following
+;;; templates.  X is replaced by the coerced value, which can be a
+;;; lisp form. We use a LET form to avoid evaluating twice the same
+;;; form.
+;;;
+(defvar +coercion-table+
+  '((float . (float x))
+    (short-float  . (float x 0.0s0))
+    (single-float . (float x 0.0f0))
+    (double-float . (float x 0.0d0))
+    (long-float . (float x 0.0l0))
+    (base-char . (character x))
+    (character . (character x))
+    (function . (si::coerce-to-function x))
+    (complex .
+     (let ((y x))
+       (declare (:read-only y))
+       (complex (realpart y) (imagpart y))))
+    ))
+
+(defun expand-coerce (form value type env)
+  (declare (si::c-local))
+  ;; This function is reponsible for expanding (TYPEP object type)
+  ;; forms into a reasonable set of system calls. When it fails to
+  ;; match the compiler constraints on speed and space, it simply
+  ;; returns the original form. Note that for successful recursion we
+  ;; have to output indeed the ORIGINAL FORM, not some intermediate
+  ;; step. Otherwise the compiler macro will enter an infinite loop.
+  (let* ((space (cmp-env-optimization 'space env))
+	 (speed (cmp-env-optimization 'speed env))
+	 (safety (cmp-env-optimization 'safety env))
+	 (orig-type type)
+	 first rest)
+    (cond ((not (and (constantp type) (setf type (cmp-eval type))))
+	   form)
+	  ;;
+	  ;; Trivial case
+	  ((subtypep 't type)
+	   value)
+	  ;;
+	  ;; Detect inconsistencies in the type form.
+	  ((subtypep type 'nil)
+	   (cmperror "Cannot COERCE an expression to an empty type."))
+	  ;;
+	  ;; No optimizations that take up too much space unless requested.
+	  ((and (>= space 2) (> space speed))
+	   form)
+	  ;;
+	  ;; Search for a simple template above, replacing X by the value.
+	  ((loop for (a-type . template) in +coercion-table+
+	      when (eq type a-type)
+	      do (return (subst value 'x template))))
+	  ;;
+	  ;; Complex types defined with DEFTYPE.
+	  ((and (atom type)
+		(get-sysprop type 'SI::DEFTYPE-DEFINITION)
+		(setq function (get-sysprop type 'SI::DEFTYPE-DEFINITION)))
+	   (expand-coerce form value `',(funcall function) env))
+	  ;;
+	  ;; CONS types are not coercible.
+	  ((and (consp type)
+		(eq (first type) 'CONS))
+	   form)
+	  ;;
+	  ;; Search for a simple template above, but now assuming the user
+	  ;; provided a more complex form of the same value.
+	  ((loop for (a-type . template) in +coercion-table+
+	      when (si::type= type a-type)
+	      do (return (subst value 'x template))))
+	  ;;
+	  ;; SEQUENCE types
+	  ((subtypep type 'sequence)
+	   (multiple-value-bind (elt-type length)
+	       (si::closest-sequence-type type)
+	     (when (eq elt-type 'list)
+	       (setf type 'list))
+	     `(let ((y ,value))
+		(declare (:read-only y))
+		(if (typep y ',type)
+		    y
+		    (concatenate ',type y)))))
+	  ;;
+	  ;; There are no other atomic types to optimize
+	  ((atom type)
+	   form)
+	  ;;
+	  ;; (TYPEP o '(AND t1 t2 ...)) => (AND (TYPEP o 't1) (TYPEP o 't2) ...)
+	  ((progn
+	     (setf rest (rest type) first (first type))
+	     (eq first 'AND))
+	   `(let ((x ,value))
+	      ,@(loop for i in rest
+		   collect `(setf x (coerce x ',i)))
+	      x))
+	  ;;
+	  ;; (COMPLEX whatever) types
+	  ((and (eq first 'complex)
+		(= (length rest) 1))
+	   `(let ((y ,value))
+	      (declare (:read-only y))
+	      (complex (coerce (realpart y) ',(first rest))
+		       (coerce (imagpart y) ',(first rest)))))
+	  ;;
+	  ;; (INTEGER * *), etc We have to signal an error if the type
+	  ;; does not match. However, if safety settings are low, we
+	  ;; skip this test.
+	  ((member first '(INTEGER RATIONAL FLOAT REAL SINGLE-FLOAT
+			   DOUBLE-FLOAT #+long-float LONG-FLOAT
+			   #+short-float SHORT-FLOAT))
+	   (let ((unchecked (expand-coerce form value `',first env)))
+	     (if (< safety 1)
+		 default
+		 `(let ((x ,unchecked))
+		    (declare (,first x))
+		    (check-type x ',type "coerced value")
+		    x))))
+	  ;;
+	  ;; We did not find a suitable expansion.
+	  (t
+	   form)
+	  )))
+
+(define-compiler-macro coerce (&whole form value type &environment env)
+  (expand-coerce form value type env))
diff --git a/src/lsp/predlib.lsp b/src/lsp/predlib.lsp
index 707426b32..872eceb05 100644
--- a/src/lsp/predlib.lsp
+++ b/src/lsp/predlib.lsp
@@ -222,44 +222,47 @@ has no fill-pointer, and is not adjustable."
        (not (array-has-fill-pointer-p x))
        (not (array-displacement x))))
 
-(dolist (l '((ARRAY . ARRAYP)
-	     (ATOM . ATOM)
-             #-unicode
-	     (EXTENDED-CHAR . CONSTANTLY-NIL)
-	     (BASE-CHAR . BASE-CHAR-P)
-	     (BASE-STRING . BASE-STRING-P)
-	     (BIT-VECTOR . BIT-VECTOR-P)
-	     (CHARACTER . CHARACTERP)
-	     (COMPILED-FUNCTION . COMPILED-FUNCTION-P)
-	     (COMPLEX . COMPLEXP)
-	     (CONS . CONSP)
-	     (FLOAT . FLOATP)
-	     (FUNCTION . FUNCTIONP)
-	     (HASH-TABLE . HASH-TABLE-P)
-	     (INTEGER . INTEGERP)
-	     (FIXNUM . SI::FIXNUMP)
-	     (KEYWORD . KEYWORDP)
-	     (LIST . LISTP)
-	     (LOGICAL-PATHNAME . LOGICAL-PATHNAME-P)
-	     (NIL . CONSTANTLY-NIL)
-	     (NULL . NULL)
-	     (NUMBER . NUMBERP)
-	     (PACKAGE . PACKAGEP)
-	     (RANDOM-STATE . RANDOM-STATE-P)
-	     (RATIONAL . RATIONALP)
-	     (PATHNAME . PATHNAMEP)
-	     (READTABLE . READTABLEP)
-	     (REAL . REALP)
-	     (SIMPLE-ARRAY . SIMPLE-ARRAY-P)
-	     (SIMPLE-STRING . SIMPLE-STRING-P)
-	     (SIMPLE-VECTOR . SIMPLE-VECTOR-P)
-	     (STREAM . STREAMP)
-	     (STRING . STRINGP)
-	     (STRUCTURE . SYS:STRUCTUREP)
-	     (SYMBOL . SYMBOLP)
-	     (T . CONSTANTLY-T)
-	     (VECTOR . VECTORP)
-	     ))
+(eval-when (:execute :load-toplevel :compile-toplevel)
+  (defconstant +known-typep-predicates+
+    '((ARRAY . ARRAYP)
+      (ATOM . ATOM)
+      #-unicode
+      (EXTENDED-CHAR . CONSTANTLY-NIL)
+      (BASE-CHAR . BASE-CHAR-P)
+      (BASE-STRING . BASE-STRING-P)
+      (BIT-VECTOR . BIT-VECTOR-P)
+      (CHARACTER . CHARACTERP)
+      (COMPILED-FUNCTION . COMPILED-FUNCTION-P)
+      (COMPLEX . COMPLEXP)
+      (CONS . CONSP)
+      (FLOAT . FLOATP)
+      (FUNCTION . FUNCTIONP)
+      (HASH-TABLE . HASH-TABLE-P)
+      (INTEGER . INTEGERP)
+      (FIXNUM . SI::FIXNUMP)
+      (KEYWORD . KEYWORDP)
+      (LIST . LISTP)
+      (LOGICAL-PATHNAME . LOGICAL-PATHNAME-P)
+      (NIL . CONSTANTLY-NIL)
+      (NULL . NULL)
+      (NUMBER . NUMBERP)
+      (PACKAGE . PACKAGEP)
+      (RANDOM-STATE . RANDOM-STATE-P)
+      (RATIONAL . RATIONALP)
+      (PATHNAME . PATHNAMEP)
+      (READTABLE . READTABLEP)
+      (REAL . REALP)
+      (SIMPLE-ARRAY . SIMPLE-ARRAY-P)
+      (SIMPLE-STRING . SIMPLE-STRING-P)
+      (SIMPLE-VECTOR . SIMPLE-VECTOR-P)
+      (STREAM . STREAMP)
+      (STRING . STRINGP)
+      (STRUCTURE . SYS:STRUCTUREP)
+      (SYMBOL . SYMBOLP)
+      (T . CONSTANTLY-T)
+      (VECTOR . VECTORP))))
+
+(dolist (l +known-typep-predicates+)
   (put-sysprop (car l) 'TYPE-PREDICATE (cdr l)))
 
 (defconstant +upgraded-array-element-types+
@@ -271,8 +274,9 @@ has no fill-pointer, and is not adjustable."
     (declare (type (integer 0 127) hash))
     (if (and record (eq (car record) element-type))
 	(cdr record)
-	(let ((answer (or (member element-type +upgraded-array-element-types+
+	(let ((answer (if (member element-type +upgraded-array-element-types+
 				  :test #'eq)
+			  element-type
 			  (dolist (v +upgraded-array-element-types+ 'T)
 			    (when (subtypep element-type v)
 			      (return v))))))
@@ -1263,3 +1267,28 @@ if not possible."
 	  (fast-subtypep t1 t2)
 	(setf (aref cache hash) (cons (cons t1 t2) (cons test confident)))
 	(values test confident)))))
+
+(defun fast-type= (t1 t2)
+  (declare (si::c-local))
+  (when (eq t1 t2)
+    (return-from fast-type= (values t t)))
+  (let* ((tag1 (safe-canonical-type t1))
+	 (tag2 (safe-canonical-type t2)))
+    (cond ((and (numberp tag1) (numberp tag2))
+	   (values (= (safe-canonical-type t1) (safe-canonical-type t2))
+		   t))
+	  #+nil
+	  ((null tag1)
+	   (error "Unknown type specifier ~S." t1))
+	  #+nil
+	  ((null tag2)
+	   (error "Unknown type specifier ~S." t2))
+	  (t
+	   (values nil nil)))))
+
+(defun type= (t1 t2)
+  (let ((*highest-type-tag* *highest-type-tag*)
+	(*save-types-database* t)
+	(*member-types* *member-types*)
+	(*elementary-types* *elementary-types*))
+    (fast-type= t1 t2)))

From e65c87b85aa7ff382a56b7340fd8b05b1b464ba4 Mon Sep 17 00:00:00 2001
From: jjgarcia <jjgarcia>
Date: Thu, 29 May 2008 06:50:10 +0000
Subject: [PATCH 13/14] The optimizer for COERCE now uses specialized functions
 for sequence types instead of open coding it every time.

---
 src/cmp/cmpopt.lsp | 10 +++-------
 src/cmp/sysfun.lsp |  1 +
 src/lsp/seq.lsp    | 25 +++++++++++++++++++++++++
 3 files changed, 29 insertions(+), 7 deletions(-)

diff --git a/src/cmp/cmpopt.lsp b/src/cmp/cmpopt.lsp
index efb9fa843..682123807 100644
--- a/src/cmp/cmpopt.lsp
+++ b/src/cmp/cmpopt.lsp
@@ -257,13 +257,9 @@
 	  ((subtypep type 'sequence)
 	   (multiple-value-bind (elt-type length)
 	       (si::closest-sequence-type type)
-	     (when (eq elt-type 'list)
-	       (setf type 'list))
-	     `(let ((y ,value))
-		(declare (:read-only y))
-		(if (typep y ',type)
-		    y
-		    (concatenate ',type y)))))
+	     (if (eq elt-type 'list)
+		 `(si::coerce-to-list ,value)
+		 `(si::coerce-to-vector ,value ',elt-type ',length))))
 	  ;;
 	  ;; There are no other atomic types to optimize
 	  ((atom type)
diff --git a/src/cmp/sysfun.lsp b/src/cmp/sysfun.lsp
index 5df7fa079..1e88ae42d 100644
--- a/src/cmp/sysfun.lsp
+++ b/src/cmp/sysfun.lsp
@@ -1457,6 +1457,7 @@ type_of(#0)==t_bitvector")
     si::pprint-logical-block-helper si::pprint-pop-helper
     si::make-seq-iterator si::seq-iterator-ref si::seq-iterator-set si::seq-iterator-next
     si::structure-type-error si::define-structure
+    si::coerce-to-list si::coerce-to-vector
     #+formatter
     ,@'(
     format-princ format-prin1 format-print-named-character
diff --git a/src/lsp/seq.lsp b/src/lsp/seq.lsp
index 9b5bc4ea2..d495fe8bf 100644
--- a/src/lsp/seq.lsp
+++ b/src/lsp/seq.lsp
@@ -169,6 +169,31 @@ default value of INITIAL-ELEMENT depends on TYPE."
 	   iterator)
       (rest iterator)))
 
+(defun coerce-to-list (object)
+  (if (listp object)
+      object
+      (do ((it (make-seq-iterator object) (seq-iterator-next object it))
+	   (output nil))
+	  ((null it) (nrevere output))
+	(push (seq-iterator-ref object it) output))))
+
+(defun coerce-to-vector (object elt-type length)
+  (let ((output object))
+    (unless (and (vectorp object)
+		 (eq (array-element-type object) elt-type))
+      (let* ((final-length (if (eq length '*) (length object) length)))
+	(setf output (make-vector elt-type final-length nil nil nil 0))
+	(do ((i (make-seq-iterator object) (seq-iterator-next output i))
+	     (j 0 (1+ j)))
+	    ((= j final-length)
+	     (setf object output))
+	  (declare (index j))
+	  (setf (aref output j) (seq-iterator-ref object i)))))
+    (unless (eq length '*)
+      (unless (= length (length output))
+	(check-type output `(vector ,elt-type (,length)) "coerced object")))
+    output))
+
 (defun concatenate (result-type &rest sequences)
   "Args: (type &rest sequences)
 Returns a new sequence of the specified type, consisting of all elements of

From 27ba547b649697f528c28da2cc4d9a6d126171d6 Mon Sep 17 00:00:00 2001
From: jjgarcia <jjgarcia>
Date: Thu, 29 May 2008 18:37:24 +0000
Subject: [PATCH 14/14] Fixed typo.

---
 src/lsp/seq.lsp | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/src/lsp/seq.lsp b/src/lsp/seq.lsp
index d495fe8bf..297393cde 100644
--- a/src/lsp/seq.lsp
+++ b/src/lsp/seq.lsp
@@ -174,7 +174,7 @@ default value of INITIAL-ELEMENT depends on TYPE."
       object
       (do ((it (make-seq-iterator object) (seq-iterator-next object it))
 	   (output nil))
-	  ((null it) (nrevere output))
+	  ((null it) (nreverse output))
 	(push (seq-iterator-ref object it) output))))
 
 (defun coerce-to-vector (object elt-type length)