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)
;;
NetBSD)
printf ' :netbsd' >> $ltf
+ sbcl_os="netbsd"
ln -s Config.$sbcl_arch-netbsd Config
;;
*)
# 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
# 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
;;; 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*)))
;;; 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))
(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
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
(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)
;;; 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"
projects / sbcl.git / commitdiff