From: Juho Snellman Date: Fri, 6 Jan 2006 01:11:07 +0000 (+0000) Subject: 0.9.8.14: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=93be0089fe7b2a9e34bf1cb6da9fe6e902769f5e;p=sbcl.git 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 <