changes in sbcl-0.8.18 relative to sbcl-0.8.17:
* new feature: reloading changed shared object files with
LOAD-SHARED-OBJECT now causes the new definitions to take effect.
+ * new feature: references to foreign variables and functions
+ can now be compiled and loaded before the corresponding shared
+ object file is loaded, as long as the foreign definitions are
+ available at runtime.
* Solaris 10 (aka SunOS 5.10) on the SPARC platform is now
supported. (thanks to Dan Debertin)
* fixed bug #331: structure-class instances corresponding to
* bug fix: RANDOM can be compiled when the compiler derives the type
of its numeric argument as a disjoint set of small integers.
(reported by Paul Dietz)
+ * bug fix: starting a core saved with shared objects loaded when
+ those objects are not available no longer causes threaded SBCL to
+ hang. (reported by Sean Ross)
* fixed some bugs related to Unicode integration:
** RUN-PROGRAM can allow its child to take input from a Lisp
stream. (reported by Stefan Scholl)
"MAKE-ALIEN"
"NULL-ALIEN"
"SAP-ALIEN" "SHORT" "SIGNED" "SLOT" "STRUCT"
+ "UNDEFINED-ALIEN-ERROR"
"UNSIGNED"
"UNSIGNED-CHAR" "UNSIGNED-INT" "UNSIGNED-LONG" "UNSIGNED-SHORT"
"UTF8-STRING"
;; The show is on.
(terpri)
(/show0 "going into toplevel loop")
- (handling-end-of-the-world
+ (handling-end-of-the-world
+ (thread-init-or-reinit)
(toplevel-init)
(critically-unreachable "after TOPLEVEL-INIT")))
\f
;;;; initialization functions
+(defun thread-init-or-reinit ()
+ (sb!thread::init-job-control)
+ (sb!thread::get-foreground))
+
(defun reinit ()
(without-interrupts
(without-gcing
- (os-cold-init-or-reinit)
+ (os-cold-init-or-reinit)
(stream-reinit)
(signal-cold-init-or-reinit)
(setf (sb!alien:extern-alien "internal_errors_enabled" boolean) t)
(set-floating-point-modes
:traps '(:overflow #!-netbsd :invalid :divide-by-zero))
(sb!thread::maybe-install-futex-functions)))
- (foreign-reinit)
+ (thread-init-or-reinit)
(gc-reinit)
;; make sure TIME works correctly from saved cores
(setf *internal-real-time-base-seconds* nil)
- (mapc #'funcall *init-hooks*))
+ (foreign-reinit)
+ (dolist (hook *init-hooks*)
+ (with-simple-restart (continue "Skip this initialization hook.")
+ (funcall hook))))
\f
;;;; some support for any hapless wretches who end up debugging cold
;;;; init code
SB-EXT:PACKAGE-LOCKED-ERROR-SYMBOL."))
) ; progn
+
+(define-condition undefined-alien-error (error) ()
+ (:report
+ (lambda (condition stream)
+ (declare (ignore condition))
+ (format stream "Attempt to access an undefined alien value."))))
\f
;;;; various other (not specified by ANSI) CONDITIONs
;;;;
(handle system-area-pointer)
(symbol c-string))
+(define-alien-variable undefined-alien-address unsigned-long)
+
(defvar *runtime-dlhandle*)
(defvar *shared-objects*)
(when objp
(dlclose-or-lose obj))
(dlerror) ; clear errors
- (let* ((file (when obj (shared-object-file obj)))
+ (let* ((file (and obj (shared-object-file obj)))
(sap (dlopen file (logior rtld-global rtld-now))))
(aver (or (not objp) file))
(when (zerop (sap-int sap))
(if objp
- (setf (shared-object-sap obj) *runtime-dlhandle*)
+ (setf (shared-object-sap obj) nil)
(setf *runtime-dlhandle* nil))
(error "Could not open ~:[runtime~;~:*shared object ~S~]: ~A"
obj (dlerror)))
(setf *shared-objects* (append (remove obj *shared-objects*)
(list obj)))
#!+linkage-table
- (when old
+ (when (or old (undefined-foreign-symbols))
(update-linkage-table))
(pathname filename))))
(defun try-reopen-shared-object (obj)
- (with-simple-restart (skip "~@<Skip this shared object and continue. ~
- References to foreign symbols in this ~
- shared object will fail with undefined ~
- consequences.~:>")
- (dlopen-or-lose obj)
- obj))
+ (declare (type shared-object obj))
+ (tagbody :dlopen
+ (restart-case
+ (dlopen-or-lose obj)
+ (continue ()
+ :report "Skip this shared object and continue."
+ (setf (shared-object-sap obj) nil))
+ (retry ()
+ :report "Retry loading this shared object."
+ (go :dlopen))
+ (load-other ()
+ :report "Specify an alternate shared object file to load."
+ (setf (shared-object-file obj)
+ (tagbody :query
+ (format *query-io* "~&Enter pathname (evaluated):~%")
+ (force-output *query-io*)
+ (let ((pathname (ignore-errors (pathname (read *query-io*)))))
+ (unless (pathnamep pathname)
+ (format *query-io* "~&Error: invalid pathname.~%")
+ (go :query))
+ (unix-namestring pathname)))))))
+ obj)
;;; Open libraries in *SHARED-OBJECTS* and the runtime. Called during
;;; initialization.
(mapc #'dlclose-or-lose (reverse *shared-objects*))
(dlclose-or-lose))
-(defun get-dynamic-foreign-symbol-address (symbol)
- (dlerror) ; clear old errors
- (let ((result (sap-int (dlsym *runtime-dlhandle* symbol)))
- (err (dlerror)))
- (if (or (not (zerop result)) (not err))
- result
- (dolist (obj *shared-objects*)
- (setf result (sap-int (dlsym (shared-object-sap obj) symbol))
- err (dlerror))
- (when (or (not (zerop result)) (not err))
- (return result))))))
+(let ((symbols ())
+ (undefineds ()))
+ (defun get-dynamic-foreign-symbol-address (symbol)
+ (dlerror) ; clear old errors
+ (unless *runtime-dlhandle*
+ (bug "Cannot resolve foreign symbol: lost *runtime-dlhandle*"))
+ (let* ((result (sap-int (dlsym *runtime-dlhandle* symbol)))
+ (err (dlerror))
+ (addr (if (or (not (zerop result)) (not err))
+ result
+ (dolist (obj *shared-objects*)
+ (let ((sap (shared-object-sap obj)))
+ (when sap
+ (setf result (sap-int (dlsym sap symbol))
+ err (dlerror))
+ (when (or (not (zerop result)) (not err))
+ (return result))))))))
+ (cond ((not addr)
+ (style-warn "Undefined alien: ~S" symbol)
+ (pushnew symbol undefineds :test #'equal)
+ (remove symbol symbols :test #'equal)
+ undefined-alien-address)
+ (addr
+ (pushnew symbol symbols :test #'equal)
+ (remove symbol undefineds :test #'equal)
+ addr))))
+ (defun dynamic-foreign-symbols ()
+ symbols)
+ (defun undefined-foreign-symbols ()
+ undefineds))
;; 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))
- (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.~%~:@>")
+ (when (dynamic-foreign-symbols)
+ (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.~%~%Dynamic foreign symbols in this core: ~
+ ~{~A~^, ~}~:@>" (dynamic-foreign-symbols)))
#!+os-provides-dlopen
(close-shared-objects))
"Control stack guard page temporarily disabled: proceed with caution~%")
(error 'control-stack-exhausted))))
-
-
+(defun undefined-alien-error ()
+ (error 'undefined-alien-error))
sb!vm:linkage-table-entry-size)
sb!vm:linkage-table-space-start))
(real-address (get-dynamic-foreign-symbol-address name)))
- (when real-address
- (unless (< table-address sb!vm:linkage-table-space-end)
- (error "Linkage-table full (~D entries): cannot link ~S."
- (hash-table-count *linkage-info*)
- name))
- (write-linkage-table-entry table-address real-address datap)
- (setf (gethash name *linkage-info*)
- (make-linkage-info :address table-address :datap datap)))))
+ (aver real-address)
+ (unless (< table-address sb!vm:linkage-table-space-end)
+ (error "Linkage-table full (~D entries): cannot link ~S."
+ (hash-table-count *linkage-info*)
+ name))
+ (write-linkage-table-entry table-address real-address datap)
+ (setf (gethash name *linkage-info*)
+ (make-linkage-info :address table-address :datap datap))))
;;; Add a foreign linkage entry if none exists, return the address
;;; in the linkage table.
(let ((datap (linkage-info-datap info))
(table-address (linkage-info-address info))
(real-address (get-dynamic-foreign-symbol-address name)))
- (cond (real-address
- (write-linkage-table-entry table-address
- real-address
- datap))
- (t
- (/show0 "oops")
- (cerror "Ignore. Attempts to access this foreign symbol ~
- will lead to badness characterized by ~
- segfaults, and potential corruption."
- "Could not resolve foreign function ~S for ~
- linkage-table." name)))))
+ (aver (and table-address real-address))
+ (write-linkage-table-entry table-address
+ real-address
+ datap)))
*linkage-info*))
#-gencgc (gc) #+gencgc (gc :full t))
(flet ((restart-lisp ()
(handling-end-of-the-world
- (reinit)
- (funcall toplevel))))
+ (reinit)
+ (funcall toplevel))))
;; FIXME: Perhaps WITHOUT-GCING should be wrapped around the
;; LET as well, to avoid the off chance of an interrupt triggering
;; GC and making our saved RESTART-LISP address invalid?
(get-lisp-obj-address #'restart-lisp)))))
(defun deinit ()
- (mapc #'funcall *save-hooks*)
+ (dolist (hook *save-hooks*)
+ (with-simple-restart (continue "Skip this save hook.")
+ (funcall hook)))
(when (fboundp 'cancel-finalization)
(cancel-finalization sb!sys:*tty*))
(profile-deinit)
;;; the default system top level function
(defun toplevel-init ()
-
- (/show0 "entering TOPLEVEL-INIT")
- (sb!thread::init-job-control)
- (sb!thread::get-foreground)
+ (/show0 "entering TOPLEVEL-INIT")
(let (;; value of --sysinit option
(sysinit nil)
;; value of --userinit option
sub-gc
sb!kernel::internal-error
sb!kernel::control-stack-exhausted-error
+ sb!kernel::undefined-alien-error
sb!di::handle-breakpoint
sb!di::handle-fun-end-breakpoint
(frob sub-gc)
(frob internal-error)
(frob sb!kernel::control-stack-exhausted-error)
+ (frob sb!kernel::undefined-alien-error)
(frob sb!di::handle-breakpoint)
(frob sb!di::handle-fun-end-breakpoint)
(frob sb!thread::handle-thread-exit))
sb!impl::sub-gc
sb!kernel::internal-error
sb!kernel::control-stack-exhausted-error
+ sb!kernel::undefined-alien-error
sb!di::handle-breakpoint
sb!impl::fdefinition-object
sb!impl::sub-gc
sb!kernel::internal-error
sb!kernel::control-stack-exhausted-error
+ sb!kernel::undefined-alien-error
sb!di::handle-breakpoint
sb!impl::fdefinition-object
sb!impl::sub-gc
sb!kernel::internal-error
sb!kernel::control-stack-exhausted-error
+ sb!kernel::undefined-alien-error
sb!di::handle-breakpoint
sb!impl::fdefinition-object
sub-gc
sb!kernel::internal-error
sb!kernel::control-stack-exhausted-error
+ sb!kernel::undefined-alien-error
sb!di::handle-breakpoint
sb!di::handle-fun-end-breakpoint
sub-gc
sb!kernel::internal-error
sb!kernel::control-stack-exhausted-error
+ sb!kernel::undefined-alien-error
sb!di::handle-breakpoint
fdefinition-object
#!+sb-thread sb!thread::handle-thread-exit
os_context_t *context = arch_os_get_context(&void_context);
if (!gencgc_handle_wp_violation(fault_addr))
- if(!handle_control_stack_guard_triggered(context,fault_addr))
+ if(!handle_guard_page_triggered(context,fault_addr))
/* FIXME is this context or void_context? not that it */
/* makes a difference currently except on linux/sparc */
interrupt_handle_now(signal, siginfo, void_context);
addr = arch_get_bad_addr(signal,info,context);
if(!interrupt_maybe_gc(signal, info, context))
- if(!handle_control_stack_guard_triggered(context,addr))
+ if(!handle_guard_page_triggered(context,addr))
interrupt_handle_now(signal, info, context);
/* Work around G5 bug; fix courtesy gbyers */
sigreturn(void_context);
{ /* called when a child thread exits */
mark_dead_threads();
}
-
#endif
-boolean handle_control_stack_guard_triggered(os_context_t *context,void *addr){
+boolean handle_guard_page_triggered(os_context_t *context,void *addr){
struct thread *th=arch_os_get_current_thread();
/* note the os_context hackery here. When the signal handler returns,
protect_control_stack_return_guard_page(th->pid,0);
return 1;
}
+ else if (addr >= undefined_alien_address &&
+ addr < undefined_alien_address + os_vm_page_size) {
+ arrange_return_to_lisp_function
+ (context, SymbolFunction(UNDEFINED_ALIEN_ERROR));
+ return 1;
+ }
else return 0;
}
extern void interrupt_handle_pending(os_context_t*);
extern void interrupt_internal_error(int, siginfo_t*, os_context_t*,
boolean continuable);
-extern boolean handle_control_stack_guard_triggered(os_context_t *,void *);
+extern boolean handle_guard_page_triggered(os_context_t *,void *);
extern boolean interrupt_maybe_gc(int, siginfo_t*, void*);
#ifdef LISP_FEATURE_SB_THREAD
extern void interrupt_thread_handler(int, siginfo_t*, void*);
os_context_t *context = arch_os_get_context(&void_context);
void* fault_addr = (void*)info->si_addr;
if (!gencgc_handle_wp_violation(fault_addr))
- if(!handle_control_stack_guard_triggered(context,fault_addr))
+ if(!handle_guard_page_triggered(context,fault_addr))
interrupt_handle_now(signal, info, void_context);
}
interrupt_handle_pending(context);
} else {
if(!interrupt_maybe_gc(signal, info, context))
- if(!handle_control_stack_guard_triggered(context,addr))
+ if(!handle_guard_page_triggered(context,addr))
interrupt_handle_now(signal, info, context);
}
}
#define OS_VM_PROT_ALL \
(OS_VM_PROT_READ | OS_VM_PROT_WRITE | OS_VM_PROT_EXECUTE)
+#define OS_VM_PROT_NONE (!OS_VM_PROT_ALL)
+
extern os_vm_size_t os_vm_page_size;
/* Do anything we need to do when starting up the runtime environment
*os_context_register_addr(context,reg_ALLOC) -= (1L<<63);
interrupt_handle_pending(context);
} else if (!interrupt_maybe_gc(signal, info, context)) {
- if(!handle_control_stack_guard_triggered(context,addr))
+ if(!handle_guard_page_triggered(context,addr))
interrupt_handle_now(signal, info, context);
}
}
addr = arch_get_bad_addr(signal, info, context);
if(!interrupt_maybe_gc(signal, info, context)) {
- if(!handle_control_stack_guard_triggered(context,addr))
+ if(!handle_guard_page_triggered(context,addr))
interrupt_handle_now(signal, info, context);
}
}
}
}
+os_vm_address_t undefined_alien_address = 0;
+
+static void
+ensure_undefined_alien(void) {
+ os_vm_address_t start = os_validate(NULL, os_vm_page_size);
+ if (start) {
+ os_protect(start, os_vm_page_size, OS_VM_PROT_NONE);
+ undefined_alien_address = start;
+ } else {
+ lose("could not allocate guard page for undefined alien");
+ }
+}
+
void
validate(void)
{
#ifdef LISP_FEATURE_LINKAGE_TABLE
ensure_space( (lispobj *)LINKAGE_TABLE_SPACE_START, LINKAGE_TABLE_SPACE_SIZE);
#endif
+
+#ifdef LISP_FEATURE_OS_PROVIDES_DLOPEN
+ ensure_undefined_alien();
+#endif
#ifdef PRINTNOISE
printf(" done.\n");
#endif
}
-void protect_control_stack_guard_page(pid_t t_id, int protect_p) {
+void
+protect_control_stack_guard_page(pid_t t_id, int protect_p) {
struct thread *th = find_thread_by_pid(t_id);
os_protect(CONTROL_STACK_GUARD_PAGE(th),
os_vm_page_size,protect_p ?
(OS_VM_PROT_READ|OS_VM_PROT_EXECUTE) : OS_VM_PROT_ALL);
}
-void protect_control_stack_return_guard_page(pid_t t_id, int protect_p) {
+void
+protect_control_stack_return_guard_page(pid_t t_id, int protect_p) {
struct thread *th = find_thread_by_pid(t_id);
os_protect(CONTROL_STACK_RETURN_GUARD_PAGE(th),
os_vm_page_size,protect_p ?
extern void validate(void);
extern void protect_control_stack_guard_page(pid_t t_id, int protect_p);
extern void protect_control_stack_return_guard_page(pid_t t_id, int protect_p);
+extern os_vm_address_t undefined_alien_address;
#endif
/* note for anyone trying to port an architecture's support files
## Make a little shared object files to test with.
+build_so() {
+ echo building $1.so
+ cc -c $1.c -o $1.o
+ ld -shared -o $1.so $1.o
+}
+
echo 'int summish(int x, int y) { return 1 + x + y; }' > $testfilestem.c
echo 'int numberish = 42;' >> $testfilestem.c
echo 'int nummish(int x) { return numberish + x; }' >> $testfilestem.c
-cc -c $testfilestem.c -o $testfilestem.o
-ld -shared -o $testfilestem.so $testfilestem.o
+build_so $testfilestem
-echo 'int foo = 13;' > $testfilestem-foobar.c
-echo 'int bar() { return 42; }' >> $testfilestem-foobar.c
-cc -c $testfilestem-foobar.c -o $testfilestem-foobar.o
-ld -shared -o $testfilestem-foobar.so $testfilestem-foobar.o
+echo 'int foo = 13;' > $testfilestem-b.c
+echo 'int bar() { return 42; }' >> $testfilestem-b.c
+build_so $testfilestem-b
-echo 'int foo = 42;' > $testfilestem-foobar2.c
-echo 'int bar() { return 13; }' >> $testfilestem-foobar2.c
-cc -c $testfilestem-foobar2.c -o $testfilestem-foobar2.o
-ld -shared -o $testfilestem-foobar2.so $testfilestem-foobar2.o
+echo 'int foo = 42;' > $testfilestem-b2.c
+echo 'int bar() { return 13; }' >> $testfilestem-b2.c
+build_so $testfilestem-b2
+
+echo 'int late_foo = 43;' > $testfilestem-c.c
+echo 'int late_bar() { return 14; }' >> $testfilestem-c.c
+build_so $testfilestem-c
## Foreign definitions & load
(handler-case
(progn
(load-shared-object "$testfilestem.so")
- (load-shared-object "$testfilestem-foobar.so"))
+ (load-shared-object "$testfilestem-b.so"))
(sb-int:unsupported-operator ()
;; At least as of sbcl-0.7.0.5, LOAD-SHARED-OBJECT isn't
;; supported on every OS. In that case, there's nothing to test,
;; that the location will be the same.
(assert (= (sb-sys:sap-int (alien-sap *environ*))
(sb-sys:sap-int (alien-sap environ))))
+
+ ;; automagic restarts
+ (setf *debugger-hook*
+ (lambda (condition hook)
+ (print (list :debugger-hook condition))
+ (let ((cont (find-restart 'continue condition)))
+ (when cont
+ (invoke-restart cont)))
+ (print :fell-through)
+ (invoke-debugger condition)))
EOF
# Test code
(assert (= 13 numberish))
(assert (= 14 (nummish 1)))
+ (print :stage-1)
+
+ ;; test realoading object file with new definitions
(assert (= 13 foo))
(assert (= 42 (bar)))
- ;; test realoading object file with new definitions
- (rename-file "$testfilestem-foobar.so" "$testfilestem-foobar.bak")
- (rename-file "$testfilestem-foobar2.so" "$testfilestem-foobar.so")
- (load-shared-object "$testfilestem-foobar.so")
+ (rename-file "$testfilestem-b.so" "$testfilestem-b.bak")
+ (rename-file "$testfilestem-b2.so" "$testfilestem-b.so")
+ (load-shared-object "$testfilestem-b.so")
(assert (= 42 foo))
(assert (= 13 (bar)))
- (rename-file "$testfilestem-foobar.so" "$testfilestem-foobar2.so")
- (rename-file "$testfilestem-foobar.bak" "$testfilestem-foobar.so")
+ (rename-file "$testfilestem-b.so" "$testfilestem-b2.so")
+ (rename-file "$testfilestem-b.bak" "$testfilestem-b.so")
+
+ (print :stage-2)
+
+ ;; test late resolution
+ (define-alien-variable late-foo int)
+ (define-alien-routine late-bar int)
+ (multiple-value-bind (val err) (ignore-errors late-foo)
+ (assert (not val))
+ (assert (typep err 'undefined-alien-error)))
+ (multiple-value-bind (val err) (ignore-errors (late-bar))
+ (assert (not val))
+ (assert (typep err 'undefined-alien-error)))
+ (load-shared-object "$testfilestem-c.so")
+ (assert (= 43 late-foo))
+ (assert (= 14 (late-bar)))
+
+ (print :stage-3)
(sb-ext:quit :unix-status 52) ; success convention for Lisp program
EOF
exit 1
fi
+echo compile ok
+
${SBCL:-sbcl} --load $testfilestem.def.fasl --load $testfilestem.test.lisp
RET=$?
if [ $RET = 22 ]; then
exit 1
fi
+echo load ok
+
${SBCL:-sbcl} --load $testfilestem.def.fasl --eval "(when (member :linkage-table *features*) (save-lisp-and-die \"$testfilestem.core\"))" <<EOF
(sb-ext:quit :unix-status 22) ; catch this
EOF
exit $PUNT # success -- linkage-table not available
fi
+echo table ok
+
$SBCL_ALLOWING_CORE --core $testfilestem.core --sysinit /dev/null --userinit /dev/null --load $testfilestem.test.lisp
if [ $? != 52 ]; then
rm $testfilestem.*
exit 1 # Failure
fi
+echo start ok
+
+# missing object file
+rm $testfilestem-b.so $testfilestem-b2.so
+$SBCL_ALLOWING_CORE --core $testfilestem.core --sysinit /dev/null --userinit /dev/null <<EOF
+ (assert (= 22 (summish 10 11)))
+ (multiple-value-bind (val err) (ignore-errors (eval 'foo))
+ (assert (not val))
+ (assert (typep err 'undefined-alien-error)))
+ (multiple-value-bind (val err) (ignore-errors (eval '(bar)))
+ (assert (not val))
+ (assert (typep err 'undefined-alien-error)))
+ (quit :unix-status 52)
+EOF
+if [ $? != 52 ]; then
+ rm $testfilestem.*
+ echo test failed: $?
+ exit 1 # Failure
+fi
+
+echo missing ok
+
rm $testfilestem.*
# success convention for script
;;; 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.17.18"
+"0.8.17.19"
projects / sbcl.git / commitdiff