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 (file)
--- a/NEWS
+++ b/NEWS
@@ -1,4 +1,12 @@
 changes in sbcl-0.8.16 relative to sbcl-0.8.15:
 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)
   * 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 (file)
--- a/make-config.sh
+++ b/make-config.sh
@@ -131,6 +131,7 @@ case `uname` in
                ;;
            NetBSD)
                 printf ' :netbsd' >> $ltf
                ;;
            NetBSD)
                 printf ' :netbsd' >> $ltf

+               sbcl_os="netbsd"

                ln -s Config.$sbcl_arch-netbsd Config
                ;;
            *)
                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
 # 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
        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
     # 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
        printf ' :linkage-table' >> $ltf
     fi
 else

diff --git a/src/code/foreign-load.lisp b/src/code/foreign-load.lisp
index 58a2aa2..d678b0d 100644 (file)
--- 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 ()
 ;;; 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*)))
 
   (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 (file)
--- 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 ()
 ;;; 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))
   #!+(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))
 
   #!+os-provides-dlopen
   (close-shared-objects))
 

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)))))
 
                          (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))
 
 (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
 
 \f
 ;;;; the FUNCTION and VALUES alien types
 

diff --git a/src/code/save.lisp b/src/code/save.lisp
index 1d3b3fa..739e3ea 100644 (file)
--- 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
 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
 
 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 (file)
--- 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))))
 
   (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)
 ;;; success
 (quit :unix-status 104)

diff --git a/version.lisp-expr b/version.lisp-expr
index bd77c7c..34202f8 100644 (file)
--- 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".)
 ;;; 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"