(in-package "SB!UNIX")
(defmacro with-interrupt-bindings (&body body)
- `(let
- ;; KLUDGE: Whatever is on the PCL stacks before the interrupt
- ;; handler runs doesn't really matter, since we're not on the
- ;; same call stack, really -- and if we don't bind these (esp.
- ;; the cache one) we can get a bogus metacircle if an interrupt
- ;; handler calls a GF that was being computed when the interrupt
- ;; hit.
- ((sb!pcl::*cache-miss-values-stack* nil)
- (sb!pcl::*dfun-miss-gfs-on-stack* nil))
- ,@body))
+ (with-unique-names (empty)
+ `(let*
+ ;; KLUDGE: Whatever is on the PCL stacks before the interrupt
+ ;; handler runs doesn't really matter, since we're not on the
+ ;; same call stack, really -- and if we don't bind these (esp.
+ ;; the cache one) we can get a bogus metacircle if an interrupt
+ ;; handler calls a GF that was being computed when the interrupt
+ ;; hit.
+ ((sb!pcl::*cache-miss-values-stack* nil)
+ (sb!pcl::*dfun-miss-gfs-on-stack* nil)
+ ;; Unless we do this, ADJUST-ARRAY and SORT would need to
+ ;; disable interrupts.
+ (,empty (vector))
+ (sb!impl::*zap-array-data-temp* ,empty)
+ (sb!impl::*merge-sort-temp-vector* ,empty))
+ ,@body)))
(defun invoke-interruption (function)
- (with-interrupt-bindings
- (without-interrupts
+ (without-interrupts
+ (with-interrupt-bindings
;; Reset signal mask: the C-side handler has blocked all
;; deferrable interrupts before arranging return to lisp. This is
;; safe because we can't get a pending interrupt before we unblock
;; FIXME: Should we not reset the _entire_ mask, but just
;; restore it to the state before we got the interrupt?
(reset-signal-mask)
- (allow-with-interrupts (funcall function)))))
+ (let ((sb!debug:*stack-top-hint* (nth-value 1 (sb!kernel:find-interrupted-name-and-frame))))
+ (allow-with-interrupts (funcall function))))))
(defmacro in-interruption ((&key) &body body)
#!+sb-doc
(declare (type (or function fixnum (member :default :ignore)) handler))
(/show0 "enable-interrupt")
(flet ((run-handler (&rest args)
+ (declare (truly-dynamic-extent args))
(in-interruption ()
(apply handler args))))
(without-gcing