include ../vanilla-module.mk
test::
- true
+ $(SBCL) --eval '(load (format nil "SYS:CONTRIB;~:@(~A~);TEST.LISP" "$(MODULE)"))' </dev/null
:mode mode))
(enable-call-counting)
(setf *profiled-threads* threads)
- (sb-sys:enable-interrupt sb-unix:sigprof #'sigprof-handler)
+ (sb-sys:enable-interrupt sb-unix:sigprof
+ #'sigprof-handler
+ :synchronous t)
(ecase mode
(:alloc
(let ((alloc-signal (1- alloc-interval)))
(with-profiling (:reset t :max-samples 1000 :report :graph)
(test-0 7)))
+(defun consalot ()
+ (let ((junk '()))
+ (loop repeat 10000 do
+ (push (make-array 10) junk))
+ junk))
+
+(defun consing-test ()
+ ;; 0.0001 chosen so that it breaks rather reliably when sprof does not
+ ;; respect pseudo atomic.
+ (with-profiling (:reset t :sample-interval 0.0001 :report :graph :loop nil)
+ (let ((target (+ (get-universal-time) 15)))
+ (princ #\.)
+ (force-output)
+ (loop
+ while (< (get-universal-time) target)
+ do (consalot)))))
+
;;; provision
(provide 'sb-sprof)
--- /dev/null
+(in-package :cl-user)
+(require :sb-sprof)
+
+#-win32 ;not yet
+(sb-sprof::test)
+#-win32 ;not yet
+(sb-sprof::consing-test)
+
+;; For debugging purposes, print output for visual inspection to see if
+;; the allocation sequence gets hit in the right places (i.e. not at all
+;; in traditional builds, and everywhere if SB-SAFEPOINT-STRICTLY is
+;; enabled.)
+(disassemble #'sb-sprof::consalot)
# roughly-equivalent magic nevertheless:)
printf ' :sb-dynamic-core :os-provides-dlopen' >> $ltf
printf ' :sb-thread :sb-safepoint :sb-thruption :sb-wtimer' >> $ltf
+ printf ' :sb-safepoint-strictly' >> $ltf
#
link_or_copy Config.$sbcl_arch-win32 Config
link_or_copy $sbcl_arch-win32-os.h target-arch-os.h
"THREAD-NAME"
"THREAD-YIELD"
"FOREIGN-THREAD"
+ #!+(and sb-safepoint-strictly (not win32))
+ "SIGNAL-HANDLING-THREAD"
;; Memory barrier
"BARRIER"
;; Mutexes
(sb!alien:define-alien-routine ("install_handler" install-handler)
sb!alien:unsigned-long
(signal sb!alien:int)
- (handler sb!alien:unsigned-long))
+ (handler sb!alien:unsigned-long)
+ (synchronous boolean))
;;;; interface to enabling and disabling signal handlers
-(defun enable-interrupt (signal handler)
+;;; Note on the SYNCHRONOUS argument: On builds without pseudo-atomic,
+;;; we have no way of knowing whether interrupted code was in an
+;;; allocation sequence, and cannot delay signals until after
+;;; allocation. Any signal that can occur asynchronously must be
+;;; considered unsafe for immediate execution, and the invocation of its
+;;; lisp handler will get delayed into a newly spawned signal handler
+;;; thread. However, there are signals which we must handle
+;;; immediately, because they occur synchonously (hence the boolean flag
+;;; SYNCHRONOUS to this function), luckily implying that the signal
+;;; happens only in specific places (illegal instructions, floating
+;;; point instructions, certain system calls), hopefully ruling out the
+;;; possibility that we would trigger it during allocation.
+
+(defun enable-interrupt (signal handler &key synchronous)
(declare (type (or function fixnum (member :default :ignore)) handler))
(/show0 "enable-interrupt")
(flet ((run-handler (&rest args)
(:ignore sig-ign)
(t
(sb!kernel:get-lisp-obj-address
- #'run-handler))))))
+ #'run-handler)))
+ synchronous)))
(cond ((= result sig-dfl) :default)
((= result sig-ign) :ignore)
(t (the (or function fixnum)
(defun ignore-interrupt (signal)
(enable-interrupt signal :ignore))
\f
+;;;; Support for signal handlers which aren't.
+;;;;
+;;;; On safepoint builds, user-defined Lisp signal handlers do not run
+;;;; in the handler for their signal, because we have no pseudo atomic
+;;;; mechanism to prevent handlers from hitting during allocation.
+;;;; Rather, the signal spawns off a fresh native thread, which calls
+;;;; into lisp with a fake context through this callback:
+
+#!+(and sb-safepoint-strictly (not win32))
+(defun signal-handler-callback (run-handler signal args)
+ (sb!thread::initial-thread-function-trampoline
+ (sb!thread::make-signal-handling-thread :name "signal handler"
+ :signal-number signal)
+ nil (lambda ()
+ (let* ((info (sb!sys:sap-ref-sap args 0))
+ (context (sb!sys:sap-ref-sap args sb!vm:n-word-bytes)))
+ (funcall run-handler signal info context)))
+ nil nil nil nil))
+
+\f
;;;; default LISP signal handlers
;;;;
;;;; Most of these just call ERROR to report the presence of the signal.
"Enable all the default signals that Lisp knows how to deal with."
(enable-interrupt sigint #'sigint-handler)
(enable-interrupt sigterm #'sigterm-handler)
- (enable-interrupt sigill #'sigill-handler)
+ (enable-interrupt sigill #'sigill-handler :synchronous t)
#!-linux
(enable-interrupt sigemt #'sigemt-handler)
- (enable-interrupt sigfpe #'sb!vm:sigfpe-handler)
- (enable-interrupt sigbus #'sigbus-handler)
+ (enable-interrupt sigfpe #'sb!vm:sigfpe-handler :synchronous t)
+ (enable-interrupt sigbus #'sigbus-handler :synchronous t)
#!-linux
- (enable-interrupt sigsys #'sigsys-handler)
+ (enable-interrupt sigsys #'sigsys-handler :synchronous t)
#!-sb-wtimer
(enable-interrupt sigalrm #'sigalrm-handler)
#!-sb-thruption
"Type of native threads which are attached to the runtime as Lisp threads
temporarily.")
+#!+(and sb-safepoint-strictly (not win32))
+(def!struct (signal-handling-thread
+ (:include foreign-thread)
+ (:conc-name "THREAD-"))
+ #!+sb-doc
+ "Asynchronous signal handling thread."
+ (signal-number nil :type integer))
+
(def!struct mutex
#!+sb-doc
"Mutex type."
#!+sb-safepoint (csp-around-foreign-call :c-type "lispobj *")
#!+sb-safepoint (pc-around-foreign-call :c-type "lispobj *")
#!+win32 (synchronous-io-handle-and-flag :c-type "HANDLE" :length 1)
+ #!+(and sb-safepoint-strictly (not win32))
+ (sprof-alloc-region :c-type "struct alloc_region" :length 5)
;; KLUDGE: On alpha, until STEPPING we have been lucky and the 32
;; bit slots came in pairs. However the C compiler will align
;; interrupt_contexts on a double word boundary. This logic should
fdefinition-object
#!+win32 sb!kernel::handle-win32-exception
#!+sb-thruption sb!thread::run-interruption
- #!+sb-safepoint sb!thread::enter-foreign-callback))
+ #!+sb-safepoint sb!thread::enter-foreign-callback
+ #!+(and sb-safepoint-strictly (not win32))
+ sb!unix::signal-handler-callback))
(defparameter *common-static-symbols*
'(t
;;; trap if ALLOC-TN's negative (handling the deferred interrupt) and
;;; using FLAG-TN - minus the large constant - to correct ALLOC-TN.
(defmacro pseudo-atomic ((flag-tn) &body forms)
+ #!+sb-safepoint-strictly
+ `(progn ,flag-tn ,@forms (emit-safepoint))
+ #!-sb-safepoint-strictly
`(progn
(without-scheduling ()
;; Extra debugging stuff:
#!+sb-thread
(defmacro pseudo-atomic (&rest forms)
- #!+win32
+ #!+sb-safepoint-strictly
`(progn ,@forms (emit-safepoint))
- #!-win32
+ #!-sb-safepoint-strictly
(with-unique-names (label)
`(let ((,label (gen-label)))
(inst mov (make-ea :qword
#!+sb-thread
(defmacro pseudo-atomic (&rest forms)
- #!+win32
+ #!+sb-safepoint-strictly
`(progn ,@forms (emit-safepoint))
- #!-win32
+ #!-sb-safepoint-strictly
(with-unique-names (label)
`(let ((,label (gen-label)))
(inst mov (make-ea :dword :disp (* 4 thread-pseudo-atomic-bits-slot))
lispobj AMD64_SYSV_ABI *
alloc(long nbytes)
{
-#ifdef LISP_FEATURE_WIN32
- /* WIN32 is currently the only platform where inline allocation is
- * not pseudo atomic. */
+#ifdef LISP_FEATURE_SB_SAFEPOINT_STRICTLY
struct thread *self = arch_os_get_current_thread();
int was_pseudo_atomic = get_pseudo_atomic_atomic(self);
if (!was_pseudo_atomic)
lispobj *result = general_alloc(nbytes, BOXED_PAGE_FLAG);
-#ifdef LISP_FEATURE_WIN32
+#ifdef LISP_FEATURE_SB_SAFEPOINT_STRICTLY
if (!was_pseudo_atomic)
clear_pseudo_atomic_atomic(self);
#endif
{
/* Flush the alloc regions updating the tables. */
struct thread *th;
- for_each_thread(th)
+ for_each_thread(th) {
gc_alloc_update_page_tables(BOXED_PAGE_FLAG, &th->alloc_region);
+#if defined(LISP_FEATURE_SB_SAFEPOINT_STRICTLY) && !defined(LISP_FEATURE_WIN32)
+ gc_alloc_update_page_tables(BOXED_PAGE_FLAG, &th->sprof_alloc_region);
+#endif
+ }
gc_alloc_update_page_tables(UNBOXED_PAGE_FLAG, &unboxed_region);
gc_alloc_update_page_tables(BOXED_PAGE_FLAG, &boxed_region);
}
#undef SA_NODEFER_TEST_BLOCK_SIGNAL
#undef SA_NODEFER_TEST_KILL_SIGNAL
+#if defined(LISP_FEATURE_SB_SAFEPOINT_STRICTLY) && !defined(LISP_FEATURE_WIN32)
+
+static void *
+signal_thread_trampoline(void *pthread_arg)
+{
+ int signo = (int) pthread_arg;
+ os_context_t fake_context;
+ siginfo_t fake_info;
+#ifdef LISP_FEATURE_PPC
+ mcontext_t uc_regs;
+#endif
+
+ memset(&fake_info, 0, sizeof(fake_info));
+ memset(&fake_context, 0, sizeof(fake_context));
+#ifdef LISP_FEATURE_PPC
+ memset(&uc_regs, 0, sizeof(uc_regs));
+ fake_context.uc_mcontext.uc_regs = &uc_regs;
+#endif
+
+ *os_context_pc_addr(&fake_context) = &signal_thread_trampoline;
+#ifdef ARCH_HAS_STACK_POINTER /* aka x86(-64) */
+ *os_context_sp_addr(&fake_context) = __builtin_frame_address(0);
+#endif
+
+ signal_handler_callback(interrupt_handlers[signo].lisp,
+ signo, &fake_info, &fake_context);
+ return 0;
+}
+
+static void
+sigprof_handler_trampoline(int signal, siginfo_t *info, void *void_context)
+{
+ SAVE_ERRNO(signal,context,void_context);
+ struct thread *self = arch_os_get_current_thread();
+
+ /* alloc() is not re-entrant and still uses pseudo atomic (even though
+ * inline allocation does not). In this case, give up. */
+ if (get_pseudo_atomic_atomic(self))
+ goto cleanup;
+
+ struct alloc_region tmp = self->alloc_region;
+ self->alloc_region = self->sprof_alloc_region;
+ self->sprof_alloc_region = tmp;
+
+ interrupt_handle_now_handler(signal, info, void_context);
+
+ /* And we're back. We know that the SIGPROF handler never unwinds
+ * non-locally, and can simply swap things back: */
+
+ tmp = self->alloc_region;
+ self->alloc_region = self->sprof_alloc_region;
+ self->sprof_alloc_region = tmp;
+
+cleanup:
+ ; /* Dear C compiler, it's OK to have a label here. */
+ RESTORE_ERRNO;
+}
+
+static void
+spawn_signal_thread_handler(int signal, siginfo_t *info, void *void_context)
+{
+ SAVE_ERRNO(signal,context,void_context);
+
+ pthread_attr_t attr;
+ pthread_t th;
+
+ if (pthread_attr_init(&attr))
+ goto lost;
+ if (pthread_attr_setstacksize(&attr, thread_control_stack_size))
+ goto lost;
+ if (pthread_create(&th, &attr, &signal_thread_trampoline, (void*) signal))
+ goto lost;
+ if (pthread_attr_destroy(&attr))
+ goto lost;
+
+ RESTORE_ERRNO;
+ return;
+
+lost:
+ lose("spawn_signal_thread_handler");
+}
+#endif
+
static void
unblock_me_trampoline(int signal, siginfo_t *info, void *void_context)
{
/* This is called from Lisp. */
uword_t
-install_handler(int signal, void handler(int, siginfo_t*, os_context_t*))
+install_handler(int signal, void handler(int, siginfo_t*, os_context_t*),
+ int synchronous)
{
#ifndef LISP_FEATURE_WIN32
struct sigaction sa;
if (ARE_SAME_HANDLER(handler, SIG_DFL) ||
ARE_SAME_HANDLER(handler, SIG_IGN))
sa.sa_sigaction = (void (*)(int, siginfo_t*, void*))handler;
+#ifdef LISP_FEATURE_SB_SAFEPOINT_STRICTLY
+ else if (signal == SIGPROF)
+ sa.sa_sigaction = sigprof_handler_trampoline;
+ else if (!synchronous)
+ sa.sa_sigaction = spawn_signal_thread_handler;
+#endif
else if (sigismember(&deferrable_sigset, signal))
sa.sa_sigaction = maybe_now_maybe_later;
else if (!sigaction_nodefer_works &&
int signal,
interrupt_handler_t handler);
extern uword_t install_handler(int signal,
- interrupt_handler_t handler);
+ interrupt_handler_t handler,
+ int synchronous);
extern union interrupt_handler interrupt_handlers[NSIG];
sigint_init(void)
{
SHOW("entering sigint_init()");
- install_handler(SIGINT, sigint_handler);
+ install_handler(SIGINT, sigint_handler, 1);
SHOW("leaving sigint_init()");
}
\f
}
#endif /* LISP_FEATURE_WIN32 */
+#if defined(LISP_FEATURE_SB_SAFEPOINT_STRICTLY) && !defined(LISP_FEATURE_WIN32)
+void
+signal_handler_callback(lispobj run_handler, int signo, void *info, void *ctx)
+{
+ init_thread_data scribble;
+ void *args[2];
+ args[0] = info;
+ args[1] = ctx;
+
+ attach_os_thread(&scribble);
+
+ odxprint(misc, "callback from signal handler thread for: %d\n", signo);
+ funcall3(StaticSymbolFunction(SIGNAL_HANDLER_CALLBACK),
+ run_handler, make_fixnum(signo), alloc_sap(args));
+
+ detach_os_thread(&scribble);
+ return;
+}
+#endif
+
void
callback_wrapper_trampoline(
#if !(defined(LISP_FEATURE_X86) || defined(LISP_FEATURE_X86_64))
#ifdef LISP_FEATURE_SB_SAFEPOINT
block_blockable_signals(0, 0);
gc_alloc_update_page_tables(BOXED_PAGE_FLAG, &th->alloc_region);
+#if defined(LISP_FEATURE_SB_SAFEPOINT_STRICTLY) && !defined(LISP_FEATURE_WIN32)
+ gc_alloc_update_page_tables(BOXED_PAGE_FLAG, &th->sprof_alloc_region);
+#endif
pop_gcing_safety(&scribble->safety);
lock_ret = pthread_mutex_lock(&all_threads_lock);
gc_assert(lock_ret == 0);
gc_assert(lock_ret == 0);
gc_alloc_update_page_tables(BOXED_PAGE_FLAG, &th->alloc_region);
+#if defined(LISP_FEATURE_SB_SAFEPOINT_STRICTLY) && !defined(LISP_FEATURE_WIN32)
+ gc_alloc_update_page_tables(BOXED_PAGE_FLAG, &th->sprof_alloc_region);
+#endif
unlink_thread(th);
pthread_mutex_unlock(&all_threads_lock);
gc_assert(lock_ret == 0);
#endif
#ifdef LISP_FEATURE_GENCGC
gc_set_region_empty(&th->alloc_region);
+# if defined(LISP_FEATURE_SB_SAFEPOINT_STRICTLY) && !defined(LISP_FEATURE_WIN32)
+ gc_set_region_empty(&th->sprof_alloc_region);
+# endif
#endif
#ifdef LISP_FEATURE_SB_THREAD
/* This parallels the same logic in globals.c for the
void attach_os_thread(init_thread_data *);
void detach_os_thread(init_thread_data *);
+# if defined(LISP_FEATURE_SB_SAFEPOINT_STRICTLY) && !defined(LISP_FEATURE_WIN32)
+
+void signal_handler_callback(lispobj, int, void *, void *);
+# endif
+
#endif
extern void create_initial_thread(lispobj);
:skipped-on :win32)
(assert (eq :condition
(handler-case
- (sb-thread::kill-safely
- (sb-thread::thread-os-thread sb-thread::*current-thread*)
- sb-unix:sigint)
+ (progn
+ (sb-thread::kill-safely
+ (sb-thread::thread-os-thread sb-thread::*current-thread*)
+ sb-unix:sigint)
+ #+sb-safepoint-strictly
+ ;; In this case, the signals handler gets invoked
+ ;; indirectly through an INTERRUPT-THREAD. Give it
+ ;; enough time to hit.
+ (sleep 1))
(sb-sys:interactive-interrupt ()
:condition)))))
(setf ,threads (union (union *threads-to-kill*
*threads-to-join*)
,threads))
+ #+(and sb-safepoint-strictly (not win32))
+ (dolist (thread (sb-thread:list-all-threads))
+ (when (typep thread 'sb-thread:signal-handling-thread)
+ (ignore-errors (sb-thread:join-thread thread))))
(dolist (thread (sb-thread:list-all-threads))
(unless (or (not (sb-thread:thread-alive-p thread))
(eql thread sb-thread:*current-thread*)
projects / sbcl.git / commitdiff