0.8.15.18: Linkage table tweaks & alien bugfix

[sbcl.git] / src / code / host-alieneval.lisp

diff --git a/src/code/host-alieneval.lisp b/src/code/host-alieneval.lisp
index 7bab89b..bc0100b 100644 (file)
--- 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))))))
 \f
 ;;;; the FUNCTION and VALUES alien types