#+(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
(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.
#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"
"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"
(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
(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)
(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))
;;; 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
`(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")
(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 ()
#!-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
#!-sb-thread
`(locally ,@body)
#!+sb-thread
- `(sb!sys:without-interrupts
+ `(without-interrupts
(with-mutex ((session-lock ,session))
,@body)))
(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))
;; 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
"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
(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."
(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))))
(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))))
-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,
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"));
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));
}
;;; 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"
projects / sbcl.git / commitdiff