From: Gabor Melis Date: Thu, 6 Oct 2005 19:43:00 +0000 (+0000) Subject: 0.9.5.27: preparing for aysnc unwinds X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;ds=sidebyside;h=64d420902d31cb87ea752f09b314e4767816a9c9;p=sbcl.git 0.9.5.27: preparing for aysnc unwinds * refactoring: lisp level interrupt handlers can enable interrupts with with-interrupts, the runtime no longer does so before calling unknonw lisp handlers * sigchld, sigalrm don't get lost when an async unwind occurs --- diff --git a/contrib/sb-sprof/sb-sprof.lisp b/contrib/sb-sprof/sb-sprof.lisp index 5d6a32b..eeca769 100644 --- a/contrib/sb-sprof/sb-sprof.lisp +++ b/contrib/sb-sprof/sb-sprof.lisp @@ -574,9 +574,10 @@ #+(or x86 x86-64) (defun sigprof-handler (signal code scp) (declare (ignore signal code) (type system-area-pointer scp)) - (when (and *sampling* - (< *samples-index* (length *samples*))) - (sb-sys:without-gcing + (sb-sys:with-interrupts + (when (and *sampling* + (< *samples-index* (length *samples*))) + (sb-sys:without-gcing (locally (declare (optimize (inhibit-warnings 2))) (with-alien ((scp (* os-context-t) :local scp)) ;; For some reason completely bogus small values for the @@ -604,25 +605,26 @@ (sap-int ra) 0))) (t - (record 0))))))))))) + (record 0)))))))))))) ;; FIXME: On non-x86 platforms we don't yet walk the call stack deeper ;; than one level. #-(or x86 x86-64) (defun sigprof-handler (signal code scp) (declare (ignore signal code)) - (when (and *sampling* - (< *samples-index* (length *samples*))) - (sb-sys:without-gcing - (with-alien ((scp (* os-context-t) :local scp)) - (locally (declare (optimize (inhibit-warnings 2))) - (let* ((pc-ptr (sb-vm:context-pc scp)) - (fp (sb-vm::context-register scp #.sb-vm::cfp-offset)) - (ra (sap-ref-word - (int-sap fp) - (* sb-vm::lra-save-offset sb-vm::n-word-bytes)))) - (record (sap-int pc-ptr)) - (record ra))))))) + (sb-sys:with-interrupts + (when (and *sampling* + (< *samples-index* (length *samples*))) + (sb-sys:without-gcing + (with-alien ((scp (* os-context-t) :local scp)) + (locally (declare (optimize (inhibit-warnings 2))) + (let* ((pc-ptr (sb-vm:context-pc scp)) + (fp (sb-vm::context-register scp #.sb-vm::cfp-offset)) + (ra (sap-ref-word + (int-sap fp) + (* sb-vm::lra-save-offset sb-vm::n-word-bytes)))) + (record (sap-int pc-ptr)) + (record ra)))))))) ;;; Map function FN over code objects in dynamic-space. FN is called ;;; with two arguments, the object and its size in bytes. diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 083926c..15b771b 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -1591,7 +1591,7 @@ is a good idea, but see SB-SYS re. blurring of boundaries." #s(sb-cold:package-data :name "SB!THREAD" - :use ("CL" "SB!ALIEN" "SB!INT") + :use ("CL" "SB!ALIEN" "SB!INT" "SB!SYS") :doc "public (but low-level): native thread support" :export ("*CURRENT-THREAD*" "THREAD" "MAKE-THREAD" "THREAD-NAME" "THREAD-ALIVE-P" @@ -1883,7 +1883,11 @@ SB-KERNEL) have been undone, but probably more remain." "FOREIGN-SYMBOL-DATAREF-SAP" "GET-PAGE-SIZE" "GET-SYSTEM-INFO" "IGNORE-INTERRUPT" - "INT-SAP" "INVALIDATE-DESCRIPTOR" "IO-TIMEOUT" + "IN-INTERRUPTION" + "INT-SAP" + "INVALIDATE-DESCRIPTOR" + "INVOKE-INTERRUPTION" + "IO-TIMEOUT" "LIST-DYNAMIC-FOREIGN-SYMBOLS" "MACRO" "MAKE-FD-STREAM" "MAKE-OBJECT-SET" "MEMMOVE" "NATURALIZE-BOOLEAN" "NATURALIZE-INTEGER" diff --git a/src/code/float-trap.lisp b/src/code/float-trap.lisp index e0b2730..4ba4d1b 100644 --- a/src/code/float-trap.lisp +++ b/src/code/float-trap.lisp @@ -161,23 +161,24 @@ (sb!alien:sap-alien context (* os-context-t)))) (traps (logand (ldb float-exceptions-byte modes) (ldb float-traps-byte modes)))) - (cond ((not (zerop (logand float-divide-by-zero-trap-bit traps))) - (error 'division-by-zero)) - ((not (zerop (logand float-invalid-trap-bit traps))) - (error 'floating-point-invalid-operation)) - ((not (zerop (logand float-overflow-trap-bit traps))) - (error 'floating-point-overflow)) - ((not (zerop (logand float-underflow-trap-bit traps))) - (error 'floating-point-underflow)) - ((not (zerop (logand float-inexact-trap-bit traps))) - (error 'floating-point-inexact)) - #!+freebsd - ((zerop (ldb float-exceptions-byte modes)) - ;; I can't tell what caused the exception!! - (error 'floating-point-exception - :traps (getf (get-floating-point-modes) :traps))) - (t - (error 'floating-point-exception))))) + (with-interrupts + (cond ((not (zerop (logand float-divide-by-zero-trap-bit traps))) + (error 'division-by-zero)) + ((not (zerop (logand float-invalid-trap-bit traps))) + (error 'floating-point-invalid-operation)) + ((not (zerop (logand float-overflow-trap-bit traps))) + (error 'floating-point-overflow)) + ((not (zerop (logand float-underflow-trap-bit traps))) + (error 'floating-point-underflow)) + ((not (zerop (logand float-inexact-trap-bit traps))) + (error 'floating-point-inexact)) + #!+freebsd + ((zerop (ldb float-exceptions-byte modes)) + ;; I can't tell what caused the exception!! + (error 'floating-point-exception + :traps (getf (get-floating-point-modes) :traps))) + (t + (error 'floating-point-exception)))))) ;;; Execute BODY with the floating point exceptions listed in TRAPS ;;; masked (disabled). TRAPS should be a list of possible exceptions diff --git a/src/code/target-signal.lisp b/src/code/target-signal.lisp index 4d3e40e..09d8653 100644 --- a/src/code/target-signal.lisp +++ b/src/code/target-signal.lisp @@ -11,6 +11,16 @@ (in-package "SB!UNIX") +(defun invoke-interruption (function) + (without-interrupts + (sb!unix::reset-signal-mask) + (funcall function))) + +(defmacro in-interruption ((&rest args) &body body) + #!+sb-doc + "Convenience macro on top of INVOKE-INTERRUPTION." + `(invoke-interruption (lambda () ,@body) ,@args)) + ;;; These should probably be somewhere, but I don't know where. (defconstant sig_dfl 0) (defconstant sig_ign 1) @@ -57,17 +67,21 @@ (defun enable-interrupt (signal handler) (declare (type (or function fixnum (member :default :ignore)) handler)) (/show0 "enable-interrupt") - (without-gcing - (let ((result (install-handler signal - (case handler - (:default sig_dfl) - (:ignore sig_ign) - (t - (sb!kernel:get-lisp-obj-address - handler)))))) - (cond ((= result sig_dfl) :default) - ((= result sig_ign) :ignore) - (t (the (or function fixnum) (sb!kernel:make-lisp-obj result))))))) + (flet ((run-handler (&rest args) + (in-interruption () + (apply handler args)))) + (without-gcing + (let ((result (install-handler signal + (case handler + (:default sig_dfl) + (:ignore sig_ign) + (t + (sb!kernel:get-lisp-obj-address + #'run-handler)))))) + (cond ((= result sig_dfl) :default) + ((= result sig_ign) :ignore) + (t (the (or function fixnum) + (sb!kernel:make-lisp-obj result)))))))) (defun default-interrupt (signal) (enable-interrupt signal :default)) @@ -84,15 +98,9 @@ ;;; SIGINT in --disable-debugger mode will cleanly terminate the system ;;; (by respecting the *DEBUGGER-HOOK* established in that mode). (defun sigint-%break (format-string &rest format-arguments) - #!+sb-thread - (let ((foreground-thread (sb!thread::foreground-thread))) - (if (eq foreground-thread sb!thread:*current-thread*) - (apply #'%break 'sigint format-string format-arguments) - (sb!thread:interrupt-thread - foreground-thread - (lambda () (apply #'%break 'sigint format-string format-arguments))))) - #!-sb-thread - (apply #'%break 'sigint format-string format-arguments)) + (flet ((break-it () + (apply #'%break 'sigint format-string format-arguments))) + (sb!thread:interrupt-thread (sb!thread::foreground-thread) #'break-it))) (eval-when (:compile-toplevel :execute) (sb!xc:defmacro define-signal-handler (name @@ -101,10 +109,12 @@ `(defun ,name (signal info context) (declare (ignore signal info)) (declare (type system-area-pointer context)) - (/show "in Lisp-level signal handler" ,(symbol-name name) (sap-int context)) - (,function ,(concatenate 'simple-string what " at #X~X") - (with-alien ((context (* os-context-t) context)) - (sap-int (sb!vm:context-pc context))))))) + (/show "in Lisp-level signal handler" ,(symbol-name name) + (sap-int context)) + (with-interrupts + (,function ,(concatenate 'simple-string what " at #X~X") + (with-alien ((context (* os-context-t) context)) + (sap-int (sb!vm:context-pc context)))))))) (define-signal-handler sigint-handler "interrupted" sigint-%break) (define-signal-handler sigill-handler "illegal instruction") diff --git a/src/code/target-thread.lisp b/src/code/target-thread.lisp index 29cdf1e..18832b4 100644 --- a/src/code/target-thread.lisp +++ b/src/code/target-thread.lisp @@ -64,7 +64,7 @@ in future versions." (declaim (inline current-thread-sap-id)) (defun current-thread-sap-id () - (sb!sys:sap-int + (sap-int (sb!vm::current-thread-offset-sap sb!vm::thread-os-thread-slot))) (defun init-initial-thread () @@ -107,7 +107,7 @@ in future versions." #!-sb-thread (defun sb!vm::current-thread-offset-sap (n) (declare (type (unsigned-byte 27) n)) - (sb!sys:sap-ref-sap (alien-sap (extern-alien "all_threads" (* t))) + (sap-ref-sap (alien-sap (extern-alien "all_threads" (* t))) (* n sb!vm:n-word-bytes))) ;;;; spinlocks @@ -349,7 +349,7 @@ this semaphore, then N of them is woken up." #!-sb-thread `(locally ,@body) #!+sb-thread - `(sb!sys:without-interrupts + `(without-interrupts (with-mutex ((session-lock ,session)) ,@body))) @@ -465,16 +465,16 @@ have the foreground next." (labels ((thread-repl () (sb!unix::unix-setsid) (let* ((sb!impl::*stdin* - (sb!sys:make-fd-stream in :input t :buffering :line + (make-fd-stream in :input t :buffering :line :dual-channel-p t)) (sb!impl::*stdout* - (sb!sys:make-fd-stream out :output t :buffering :line + (make-fd-stream out :output t :buffering :line :dual-channel-p t)) (sb!impl::*stderr* - (sb!sys:make-fd-stream err :output t :buffering :line + (make-fd-stream err :output t :buffering :line :dual-channel-p t)) (sb!impl::*tty* - (sb!sys:make-fd-stream err :input t :output t + (make-fd-stream err :input t :output t :buffering :line :dual-channel-p t)) (sb!impl::*descriptor-handlers* nil)) @@ -539,7 +539,7 @@ returns the thread exits." ;; reference to this thread (handle-thread-exit thread))))))) (values)))) - (sb!sys:with-pinned-objects (initial-function) + (with-pinned-objects (initial-function) (let ((os-thread ;; don't let the child inherit *CURRENT-THREAD* because that ;; can prevent gc'ing this thread while the child runs @@ -569,15 +569,17 @@ returns the thread exits." "The thread that was not interrupted.") (defmacro with-interruptions-lock ((thread) &body body) - `(sb!sys:without-interrupts + `(without-interrupts (with-mutex ((thread-interruptions-lock ,thread)) ,@body))) ;; Called from the signal handler. (defun run-interruption () - (let ((interruption (with-interruptions-lock (*current-thread*) - (pop (thread-interruptions *current-thread*))))) - (funcall interruption))) + (in-interruption () + (let ((interruption (with-interruptions-lock (*current-thread*) + (pop (thread-interruptions *current-thread*))))) + (with-interrupts + (funcall interruption))))) ;; The order of interrupt execution is peculiar. If thread A ;; interrupts thread B with I1, I2 and B for some reason receives I1 @@ -589,7 +591,7 @@ returns the thread exits." (defun interrupt-thread (thread function) #!+sb-doc "Interrupt the live THREAD and make it run FUNCTION. A moderate -degree of care is expected for use of interrupt-thread, due to its +degree of care is expected for use of INTERRUPT-THREAD, due to its nature: if you interrupt a thread that was holding important locks then do something that turns out to need those locks, you probably won't like the effect." @@ -624,21 +626,21 @@ SB-EXT:QUIT - the usual cleanup forms will be evaluated" (defun thread-sap-for-id (id) (let ((thread-sap (alien-sap (extern-alien "all_threads" (* t))))) (loop - (when (sb!sys:sap= thread-sap (sb!sys:int-sap 0)) (return nil)) - (let ((os-thread (sb!sys:sap-ref-word thread-sap - (* sb!vm:n-word-bytes - sb!vm::thread-os-thread-slot)))) + (when (sap= thread-sap (int-sap 0)) (return nil)) + (let ((os-thread (sap-ref-word thread-sap + (* sb!vm:n-word-bytes + sb!vm::thread-os-thread-slot)))) (print os-thread) (when (= os-thread id) (return thread-sap)) (setf thread-sap - (sb!sys:sap-ref-sap thread-sap (* sb!vm:n-word-bytes - sb!vm::thread-next-slot))))))) + (sap-ref-sap thread-sap (* sb!vm:n-word-bytes + sb!vm::thread-next-slot))))))) #!+sb-thread (defun symbol-value-in-thread (symbol thread-sap) (let* ((index (sb!vm::symbol-tls-index symbol)) - (tl-val (sb!sys:sap-ref-word thread-sap - (* sb!vm:n-word-bytes index)))) + (tl-val (sap-ref-word thread-sap + (* sb!vm:n-word-bytes index)))) (if (eql tl-val sb!vm::no-tls-value-marker-widetag) (sb!vm::symbol-global-value symbol) (sb!kernel:make-lisp-obj tl-val)))) diff --git a/src/code/timer.lisp b/src/code/timer.lisp index 3730a20..3280bd2 100644 --- a/src/code/timer.lisp +++ b/src/code/timer.lisp @@ -339,19 +339,21 @@ triggers." (sb!thread:interrupt-thread-error (c) (warn c))))))) +;; Called from the signal handler. (defun run-expired-timers () (unwind-protect - (let (timer) - (loop - (with-scheduler-lock () - (setq timer (peek-schedule)) - (unless (and timer - (> (get-internal-real-time) - (%timer-expire-time timer))) - (return-from run-expired-timers nil)) - (assert (eq timer (priority-queue-extract-maximum *schedule*)))) - ;; run the timer without the lock - (run-timer timer))) + (with-interrupts + (let (timer) + (loop + (with-scheduler-lock () + (setq timer (peek-schedule)) + (unless (and timer + (> (get-internal-real-time) + (%timer-expire-time timer))) + (return-from run-expired-timers nil)) + (assert (eq timer (priority-queue-extract-maximum *schedule*)))) + ;; run the timer without the lock + (run-timer timer)))) (with-scheduler-lock () (set-system-timer)))) diff --git a/src/runtime/interrupt.c b/src/runtime/interrupt.c index 4497428..868d65c 100644 --- a/src/runtime/interrupt.c +++ b/src/runtime/interrupt.c @@ -68,7 +68,7 @@ -void run_deferred_handler(struct interrupt_data *data, void *v_context) ; +void run_deferred_handler(struct interrupt_data *data, void *v_context); static void store_signal_data_for_later (struct interrupt_data *data, void *handler, int signal, siginfo_t *info, @@ -474,8 +474,15 @@ interrupt_handle_now(int signal, siginfo_t *info, void *void_context) lispobj info_sap,context_sap = alloc_sap(context); info_sap = alloc_sap(info); - /* Allow signals again. */ - thread_sigmask(SIG_SETMASK, os_context_sigmask_addr(context), 0); + /* Leave deferrable signals blocked, the handler itself will + * allow signals again when it sees fit. */ +#ifdef LISP_FEATURE_SB_THREAD + { + sigset_t unblock; + sigaddset(&unblock, SIG_STOP_FOR_GC); + thread_sigmask(SIG_UNBLOCK, &unblock, 0); + } +#endif FSHOW_SIGNAL((stderr,"/calling Lisp-level handler\n")); @@ -880,6 +887,8 @@ void arrange_return_to_lisp_function(os_context_t *context, lispobj function) void interrupt_thread_handler(int num, siginfo_t *info, void *v_context) { os_context_t *context = (os_context_t*)arch_os_get_context(&v_context); + /* let the handler enable interrupts again when it sees fit */ + sigaddset_deferrable(os_context_sigmask_addr(context)); arrange_return_to_lisp_function(context, SymbolFunction(RUN_INTERRUPTION)); } diff --git a/version.lisp-expr b/version.lisp-expr index d20751a..f1d8d07 100644 --- 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.5.26" +"0.9.5.27"