0.9.8.14:

        Fix saving a core with callbacks on x86 and x86-64, as
        discussed on sbcl-devel "CFFI Callbacks on SBCL" on
        2005-12-31. Essentially the problem is that the address of
        #'ENTER-ALIEN-CALLBACK is hard-coded into the assembly callback
        wrappers, and the address of the function can change when
        saving a non-purified core.

        * Define a static symbol that contains #'ENTER-ALIEN-CALLBACK
          in the value slot.
        * Change the x86 / x86-64 wrappers to indirect through the
          slot.
        * Add minimal test case
        * Add a make-config.sh-detected :alien-callbacks feature

diff --git a/NEWS b/NEWS
index 2aa55db..ce30417 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -8,6 +8,7 @@ changes in sbcl-0.9.9 relative to sbcl-0.9.8:
     Dietz)
   * bug fix: interrupt handling on NetBSD (thanks to Richard M
     Kreuter)
+  * bug fix: saving a core corrupted callbacks on x86/x86-64
   * optimization: faster implementation of EQUAL
   * fixed segfaults on x86 FreeBSD 7-current (thanks to NIIMI Satoshi)
 

diff --git a/base-target-features.lisp-expr b/base-target-features.lisp-expr
index 3523114..8867d5e 100644 (file)
--- a/base-target-features.lisp-expr
+++ b/base-target-features.lisp-expr
@@ -284,6 +284,9 @@
  ;;   :stack-allocatable-closures
  ;;     The compiler can allocate dynamic-extent closures on stack.
  ;;
+ ;;   :alien-callbacks
+ ;;     Alien callbacks have been implemented for this platform.
+ ;;
  ;; operating system features:
  ;;   :linux   = We're intended to run under some version of Linux.
  ;;   :bsd     = We're intended to run under some version of BSD Unix. (This

diff --git a/make-config.sh b/make-config.sh
index 3ceb758..7fc58f0 100644 (file)
--- a/make-config.sh
+++ b/make-config.sh
@@ -196,13 +196,13 @@ 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
-    printf ' :stack-allocatable-closures' >> $ltf
+    printf ' :stack-allocatable-closures :alien-callbacks' >> $ltf
     if [ "$sbcl_os" = "linux" ] || [ "$sbcl_os" = "freebsd" ] || [ "$sbcl_os" = "netbsd" ] || [ "$sbcl_os" = "sunos" ]; then
        printf ' :linkage-table' >> $ltf
     fi
 elif [ "$sbcl_arch" = "x86-64" ]; then
     printf ' :gencgc :stack-grows-downward-not-upward :c-stack-is-control-stack :linkage-table' >> $ltf
-    printf ' :stack-allocatable-closures' >> $ltf
+    printf ' :stack-allocatable-closures :alien-callbacks' >> $ltf
 elif [ "$sbcl_arch" = "mips" ]; then
     printf ' :linkage-table' >> $ltf
     printf ' :stack-allocatable-closures' >> $ltf
@@ -224,7 +224,7 @@ elif [ "$sbcl_arch" = "ppc" -a "$sbcl_os" = "linux" ]; then
 elif [ "$sbcl_arch" = "ppc" -a "$sbcl_os" = "darwin" ]; then
     printf ' :stack-allocatable-closures' >> $ltf
     # We provide a dlopen shim, so a little lie won't hurt
-    printf " :os-provides-dlopen :linkage-table" >> $ltf
+    printf " :os-provides-dlopen :linkage-table :alien-callbacks" >> $ltf
     # The default stack ulimit under darwin is too small to run PURIFY.
     # Best we can do is complain and exit at this stage
     if [ "`ulimit -s`" = "512" ]; then

diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr
index c87ae89..9739983 100644 (file)
--- a/package-data-list.lisp-expr
+++ b/package-data-list.lisp-expr
@@ -110,7 +110,7 @@ of SBCL which maintained the CMU-CL-style split into two packages.)"
                "COMPUTE-NATURALIZE-LAMBDA" "DEFINE-ALIEN-TYPE-CLASS"
                "DEFINE-ALIEN-TYPE-METHOD" "DEFINE-ALIEN-TYPE-TRANSLATOR" "DEPORT"
                "DEPOSIT-ALIEN-VALUE" "DISPOSE-LOCAL-ALIEN"
-               "ENTER-ALIEN-CALLBACK"
+               "*ENTER-ALIEN-CALLBACK*" "ENTER-ALIEN-CALLBACK"
                "EXTRACT-ALIEN-VALUE"
                "HEAP-ALIEN-INFO" "HEAP-ALIEN-INFO-P" "HEAP-ALIEN-INFO-SAP-FORM"
                "HEAP-ALIEN-INFO-TYPE" "INVOKE-ALIEN-TYPE-METHOD" "LOCAL-ALIEN"

diff --git a/src/code/target-alieneval.lisp b/src/code/target-alieneval.lisp
index 7a6e041..ff7e49c 100644 (file)
--- a/src/code/target-alieneval.lisp
+++ b/src/code/target-alieneval.lisp
@@ -895,6 +895,11 @@ ENTER-ALIEN-CALLBACK pulls the corresponsing trampoline out and calls it.")
            return
            arguments))
 
+;;; To ensure that callback wrapper functions continue working even
+;;; if #'ENTER-ALIEN-CALLBACK moves in memory, access to it is indirected
+;;; through the *ENTER-ALIEN-CALLBACK* static symbol. -- JES, 2006-01-01
+(defvar *enter-alien-callback* #'enter-alien-callback)
+
 ;;;; interface (not public, yet) for alien callbacks
 
 (defmacro alien-callback (specifier function &environment env)

diff --git a/src/compiler/x86-64/c-call.lisp b/src/compiler/x86-64/c-call.lisp
index b2e4fc3..e2cf179 100644 (file)
--- a/src/compiler/x86-64/c-call.lisp
+++ b/src/compiler/x86-64/c-call.lisp
@@ -408,7 +408,15 @@
                    (bug "Unknown alien floating point type: ~S" type)))))
 
         ;; arg0 to FUNCALL3 (function)
-        (inst mov rdi (get-lisp-obj-address #'enter-alien-callback))
+        ;;
+        ;; Indirect the access to ENTER-ALIEN-CALLBACK through
+        ;; the symbol-value slot of SB-ALIEN::*ENTER-ALIEN-CALLBACK*
+        ;; to ensure it'll work even if the GC moves ENTER-ALIEN-CALLBACK.
+        ;; Skip any SB-THREAD TLS magic, since we don't expecte anyone
+        ;; to rebind the variable. -- JES, 2006-01-01
+        (inst mov rdi (+ nil-value (static-symbol-offset
+                                    'sb!alien::*enter-alien-callback*)))
+        (loadw rdi rdi symbol-value-slot other-pointer-lowtag)
         ;; arg0 to ENTER-ALIEN-CALLBACK (trampoline index)
         (inst mov rsi (fixnumize index))
         ;; arg1 to ENTER-ALIEN-CALLBACK (pointer to argument vector)

diff --git a/src/compiler/x86-64/parms.lisp b/src/compiler/x86-64/parms.lisp
index 06f0420..2afd891 100644 (file)
--- a/src/compiler/x86-64/parms.lisp
+++ b/src/compiler/x86-64/parms.lisp
@@ -225,6 +225,10 @@
     ;; For GC-AND-SAVE
     *restart-lisp-function*
 
+    ;; Needed for callbacks to work across saving cores. see
+    ;; ALIEN-CALLBACK-ASSEMBLER-WRAPPER in c-call.lisp for gory details.
+    sb!alien::*enter-alien-callback*
+
     ;; The ..SLOT-UNBOUND.. symbol is static in order to optimise the
     ;; common slot unbound check.
     ;;

diff --git a/src/compiler/x86/c-call.lisp b/src/compiler/x86/c-call.lisp
index 278c950..4bcfd03 100644 (file)
--- a/src/compiler/x86/c-call.lisp
+++ b/src/compiler/x86/c-call.lisp
@@ -439,7 +439,16 @@ pointer to the arguments."
               (inst add  eax 16)                    ; arguments
               (inst push eax)                       ; arg1
               (inst push (ash index 2))             ; arg0
-              (inst push (get-lisp-obj-address #'enter-alien-callback)) ; function
+
+              ;; Indirect the access to ENTER-ALIEN-CALLBACK through
+              ;; the symbol-value slot of SB-ALIEN::*ENTER-ALIEN-CALLBACK*
+              ;; to ensure it'll work even if the GC moves ENTER-ALIEN-CALLBACK.
+              ;; Skip any SB-THREAD TLS magic, since we don't expecte anyone
+              ;; to rebind the variable. -- JES, 2006-01-01
+              (inst mov eax (+ nil-value (static-symbol-offset
+                                          'sb!alien::*enter-alien-callback*)))
+              (loadw eax eax symbol-value-slot other-pointer-lowtag)
+              (inst push eax) ; function
               (inst mov  eax (foreign-symbol-address "funcall3"))
               (inst call eax)
               ;; now put the result into the right register

diff --git a/src/compiler/x86/parms.lisp b/src/compiler/x86/parms.lisp
index e53929d..d8c61b5 100644 (file)
--- a/src/compiler/x86/parms.lisp
+++ b/src/compiler/x86/parms.lisp
@@ -359,6 +359,10 @@
     ;; For GC-AND-SAVE
     *restart-lisp-function*
 
+    ;; Needed for callbacks to work across saving cores. see
+    ;; ALIEN-CALLBACK-ASSEMBLER-WRAPPER in c-call.lisp for gory details.
+    sb!alien::*enter-alien-callback*
+
     ;; The ..SLOT-UNBOUND.. symbol is static in order to optimise the
     ;; common slot unbound check.
     ;;

diff --git a/tests/callback.impure.lisp b/tests/callback.impure.lisp
index bda01b2..7db8a10 100644 (file)
--- a/tests/callback.impure.lisp
+++ b/tests/callback.impure.lisp
@@ -14,7 +14,7 @@
 (in-package :cl-user)
 
 ;;; callbacks only on a few platforms
-#-(or (and ppc darwin) x86 x86-64)
+#-alien-callbacks
 (quit :unix-status 104)
 
 ;;; simple callback for a function

diff --git a/tests/core.test.sh b/tests/core.test.sh
index c60f099..4a74485 100644 (file)
--- a/tests/core.test.sh
+++ b/tests/core.test.sh
@@ -39,6 +39,28 @@ else
     exit 1
 fi
 
+# In sbcl-0.9.8 saving cores with callbacks didn't work on gencgc platforms
+$SBCL <<EOF
+  (defun bar () 
+    (format t "~&Callbacks not supported, skipping~%")
+    (quit :unix-status 42))
+  #+alien-callbacks
+  (progn
+    (sb-alien::define-alien-callback foo int () 42)
+    (defun bar () (quit :unix-status (alien-funcall foo))))
+  (save-lisp-and-die "$tmpcore")
+EOF
+$SBCL_ALLOWING_CORE --core "$tmpcore" \
+--userinit /dev/null --sysinit /dev/null <<EOF
+  (bar)
+EOF
+if [ $? = 42 ]; then
+    echo "/Callbacks after SAVE-LISP-AND-DIE worked, good."
+else
+    echo "failure in basic SAVE-LISP-AND-DIE: $?"
+    exit 1
+fi
+
 rm -f $tmpcore
 echo "/returning success from core.test.sh"
 exit 104

diff --git a/version.lisp-expr b/version.lisp-expr
index 08b7177..5bea2a5 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".)
-"0.9.8.13"
+"0.9.8.14"