X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fhost-alieneval.lisp;h=bc0100b9a9bc52ae0813a21568b24eeea6d0d2da;hb=15d6e7c9a2c3234f95dfe278046fa2fee1b0c007;hp=7bab89b392cc83dc677e35763a3f2fbea5198560;hpb=e29e584efdc110f14698801ad1004f9a34a3b448;p=sbcl.git

diff --git a/src/code/host-alieneval.lisp b/src/code/host-alieneval.lisp
index 7bab89b..bc0100b 100644
--- a/src/code/host-alieneval.lisp
+++ b/src/code/host-alieneval.lisp
@@ -1008,67 +1008,40 @@
 			  (list (alien-record-field-bits field)))))
 		(alien-record-type-fields type)))))
 
-;;; Test the record fields. The depth is limiting in case of cyclic
-;;; pointers.
-(defun record-fields-match (fields1 fields2 depth)
-  (declare (type list fields1 fields2)
-	   (type (mod 64) depth))
-  (labels ((record-type-= (type1 type2 depth)
-	     (and (eq (alien-record-type-name type1)
-		      (alien-record-type-name type2))
-		  (eq (alien-record-type-kind type1)
-		      (alien-record-type-kind type2))
-		  (= (length (alien-record-type-fields type1))
-		     (length (alien-record-type-fields type2)))
-		  (record-fields-match (alien-record-type-fields type1)
-				       (alien-record-type-fields type2)
-				       (1+ depth))))
-	   (pointer-type-= (type1 type2 depth)
-	     (let ((to1 (alien-pointer-type-to type1))
-		   (to2 (alien-pointer-type-to type2)))
-	       (if to1
-		   (if to2
-		       (type-= to1 to2 (1+ depth))
-		       nil)
-		   (null to2))))
-	   (type-= (type1 type2 depth)
-	     (cond ((and (alien-pointer-type-p type1)
-			 (alien-pointer-type-p type2))
-		    (or (> depth 10)
-			(pointer-type-= type1 type2 depth)))
-		   ((and (alien-record-type-p type1)
-			 (alien-record-type-p type2))
-		    (record-type-= type1 type2 depth))
-		   (t
-		    (alien-type-= type1 type2)))))
-    (do ((fields1-rem fields1 (rest fields1-rem))
-	 (fields2-rem fields2 (rest fields2-rem)))
-	((or (eq fields1-rem fields2-rem)
-	     (endp fields1-rem) (endp fields2-rem))
-	 (eq fields1-rem fields2-rem))
-      (let ((field1 (first fields1-rem))
-	    (field2 (first fields2-rem)))
-	(declare (type alien-record-field field1 field2))
-	(unless (and (eq (alien-record-field-name field1)
-			 (alien-record-field-name field2))
-		     (eql (alien-record-field-bits field1)
-			  (alien-record-field-bits field2))
-		     (eql (alien-record-field-offset field1)
-			  (alien-record-field-offset field2))
-		     (let ((field1 (alien-record-field-type field1))
-			   (field2 (alien-record-field-type field2)))
-		       (type-= field1 field2 (1+ depth))))
-	  (return nil))))))
+;;; Test the record fields. Keep a hashtable table of already compared
+;;; types to detect cycles.
+(defun record-fields-match-p (field1 field2)
+  (and (eq (alien-record-field-name field1)
+	   (alien-record-field-name field2))
+       (eql (alien-record-field-bits field1)
+	    (alien-record-field-bits field2))
+       (eql (alien-record-field-offset field1)
+	    (alien-record-field-offset field2))
+       (alien-type-= (alien-record-field-type field1)
+		     (alien-record-field-type field2))))
+
+(defvar *alien-type-matches* nil
+  "A hashtable used to detect cycles while comparing record types.")
 
 (define-alien-type-method (record :type=) (type1 type2)
   (and (eq (alien-record-type-name type1)
 	   (alien-record-type-name type2))
        (eq (alien-record-type-kind type1)
 	   (alien-record-type-kind type2))
-       (= (length (alien-record-type-fields type1))
-	  (length (alien-record-type-fields type2)))
-       (record-fields-match (alien-record-type-fields type1)
-			    (alien-record-type-fields type2) 0)))
+       (eql (alien-type-bits type1) 
+	    (alien-type-bits type2))
+       (eql (alien-type-alignment type1) 
+	    (alien-type-alignment type2))
+       (flet ((match-fields (&optional old)
+		(setf (gethash type1 *alien-type-matches*) (cons type2 old))
+		(every #'record-fields-match-p 
+		       (alien-record-type-fields type1)
+		       (alien-record-type-fields type2))))
+	 (if *alien-type-matches*
+	     (let ((types (gethash type1 *alien-type-matches*)))
+	       (or (memq type2 types) (match-fields types)))
+	     (let ((*alien-type-matches* (make-hash-table :test #'eq)))
+	       (match-fields))))))
 
 ;;;; the FUNCTION and VALUES alien types