From: Nikodemus Siivola <nikodemus@random-state.net>
Date: Mon, 18 Oct 2004 14:59:34 +0000 (+0000)
Subject: 0.8.15.18: Linkage table tweaks & alien bugfix
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=1f7bb609de31bba1a85817496ecbde52a07edf14;p=sbcl.git

0.8.15.18: Linkage table tweaks & alien bugfix
            * Build with linkage-table by default on x86/NetBSD and
               sparc/Linux as well.
            * Don't try to be too clever about when to warn user about
               alien definitions when saving cores on non-linkage-table
               platforms: do it unconditionally.
            * Fix parsing of recursive alien record and union types
               (reported by Thomas F. Burdick, port of Helmut Eller's
               patch for the same problem in CMUCL.)
---

diff --git a/NEWS b/NEWS
index b269696..292ee48 100644
--- a/NEWS
+++ b/NEWS
@@ -1,4 +1,12 @@
 changes in sbcl-0.8.16 relative to sbcl-0.8.15:
+  * enhancement: saving cores with foreign code loaded is now
+    supported on x86/NetBSD and sparc/Linux in addition to the previously
+    supported platforms.
+  * bug fix: parsing self-recursive alien record types multiple times
+    no longer causes infinite recursion. (reported by Thomas F. Burdick,
+    original patch by Helmut Eller for CMUCL)
+  * bug fix: stack-exhaustion detection works now on NetBSD as well.
+    (thanks to Richard Kreuter)
   * bug fix: defining classes whose accessors are methods on existing
     generic functions in other (locked) packages no longer signals
     bogus package lock violations. (reported by François-René Rideau)
diff --git a/make-config.sh b/make-config.sh
index f0dab4c..e725cfe 100644
--- a/make-config.sh
+++ b/make-config.sh
@@ -131,6 +131,7 @@ case `uname` in
 		;;
 	    NetBSD)
                 printf ' :netbsd' >> $ltf
+		sbcl_os="netbsd"
 		ln -s Config.$sbcl_arch-netbsd Config
 		;;
 	    *)
@@ -185,7 +186,7 @@ cd $original_dir
 # similar with :STACK-GROWS-FOOWARD, too. -- WHN 2002-03-03
 if [ "$sbcl_arch" = "x86" ]; then
     printf ' :gencgc :stack-grows-downward-not-upward :c-stack-is-control-stack' >> $ltf
-    if [ "$sbcl_os" = "linux" ] || [ "$sbcl_os" = "freebsd" ]; then
+    if [ "$sbcl_os" = "linux" ] || [ "$sbcl_os" = "freebsd" ] || [ "$sbcl_os" = "netbsd" ]; then
 	printf ' :linkage-table' >> $ltf
     fi
 elif [ "$sbcl_arch" = "mips" ]; then
@@ -219,7 +220,7 @@ elif [ "$sbcl_arch" = "sparc" ]; then
     # FUNCDEF macro for assembler. No harm in running this on sparc-linux 
     # as well.
     sh tools-for-build/sparc-funcdef.sh > src/runtime/sparc-funcdef.h
-    if [ "$sbcl_os" = "sunos" ]; then
+    if [ "$sbcl_os" = "sunos" ] || [ "$sbcl_os" = "linux" ]; then
 	printf ' :linkage-table' >> $ltf
     fi
 else
diff --git a/src/code/foreign-load.lisp b/src/code/foreign-load.lisp
index 58a2aa2..d678b0d 100644
--- a/src/code/foreign-load.lisp
+++ b/src/code/foreign-load.lisp
@@ -75,7 +75,7 @@ SB-EXT:SAVE-LISP-AND-DIE for details."
 ;;; Open libraries in *SHARED-OBJECTS* and the runtime. Called during
 ;;; initialization. 
 (defun reopen-shared-objects ()
-  ;; Ensure that the runtime is present in the list
+  ;; Ensure that the runtime is open
   (setf *runtime-dlhandle* (dlopen-or-lose nil)
         *shared-objects* (mapcar #'try-reopen-shared-object *shared-objects*)))
 
diff --git a/src/code/foreign.lisp b/src/code/foreign.lisp
index 539f272..5cc3cd3 100644
--- a/src/code/foreign.lisp
+++ b/src/code/foreign.lisp
@@ -66,17 +66,17 @@
 ;;; Cleanups before saving a core
 #-sb-xc-host
 (defun foreign-deinit ()
+  ;; KLUDGE: Giving this warning only when non-static foreign symbols
+  ;; are used would be much nicer, but actually pretty hard: we can
+  ;; get dynamic symbols thru the runtime as well, so cheking the
+  ;; list of *shared-objects* is not enough. Eugh & blech.
   #!+(and os-provides-dlopen (not linkage-table))
-  (let ((shared (remove-if #'null (mapcar #'sb!alien::shared-object-file
-					  *shared-objects*))))
-    (when shared
-      (warn "~@<Saving cores with shared objects loaded is unsupported on ~
-            this platform: calls to foreign functions in shared objects ~
-            from the restarted core will not work. You may be able to ~
-            work around this limitation by reloading all foreign definitions ~
-            and code using them in the restarted core, but no guarantees.~%~%~
-            Shared objects in this image:~% ~{~A~^, ~}~:@>"
-	    shared)))
+  (warn "~@<Saving cores with alien definitions referring to non-static
+            foreign symbols is unsupported on this platform: references to
+            such foreign symbols from the restarted core will not work. You
+            may be able to work around this limitation by reloading all
+            foreign definitions and code using them in the restarted core,
+            but no guarantees.~%~:@>")
   #!+os-provides-dlopen
   (close-shared-objects))
 
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
 
diff --git a/src/code/save.lisp b/src/code/save.lisp
index 1d3b3fa..739e3ea 100644
--- a/src/code/save.lisp
+++ b/src/code/save.lisp
@@ -77,7 +77,8 @@ automatically reloaded on startup, but references to foreign symbols
 do not survive intact on all platforms: in this case a WARNING is
 signalled when saving the core. If no warning is signalled, then the
 foreign symbol references will remain intact. Platforms where this is
-currently the case are x86/FreeBSD, x86/Linux, and sparc/SunOS.
+currently the case are x86/FreeBSD, x86/Linux, x86/NetBSD,
+sparc/Linux, and sparc/SunOS.
 
 This implementation is not as polished and painless as you might like:
   * It corrupts the current Lisp image enough that the current process
diff --git a/tests/alien.impure.lisp b/tests/alien.impure.lisp
index 14784ea..c1c43de 100644
--- a/tests/alien.impure.lisp
+++ b/tests/alien.impure.lisp
@@ -68,5 +68,27 @@
   (assert (= 1 (slot (slot s1 'x) 'y)))
   (assert (= 2 (slot (slot s2 'x) 'y))))
 
+;;; "Alien bug" on sbcl-devel 2004-10-11 by Thomas F. Burdick caused
+;;; by recursive struct definition.
+(let ((fname "alien-bug-2004-10-11.tmp.lisp"))
+  (unwind-protect 
+       (progn
+         (with-open-file (f fname :direction :output)
+           (mapc (lambda (form) (print form f))
+                 '((defpackage :alien-bug
+                     (:use :cl :sb-alien))
+                   (in-package :alien-bug)
+                   (define-alien-type objc-class
+                       (struct objc-class
+                        (protocols 
+                         (* (struct protocol-list
+                                    (list (array (* (struct objc-class))))))))))))
+           (load fname)
+           (load fname)
+           (load (compile-file fname))
+           (load (compile-file fname)))
+    (delete-file (compile-file-pathname fname))
+    (delete-file fname)))
+
 ;;; success
 (quit :unix-status 104)
diff --git a/version.lisp-expr b/version.lisp-expr
index bd77c7c..34202f8 100644
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.8.15.17"
+"0.8.15.18"