X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcode%2Fsignal.lisp;h=a7db12d1872e67ac35a323294871894088851d1b;hb=9b634117911815fbf4154546431b4dcf13e38b47;hp=fca9c580e579dfb5eaa78a027b35428285333bc3;hpb=c548f73e8dd676d6ec4576eba6ab661a5061bdfe;p=sbcl.git

diff --git a/src/code/signal.lisp b/src/code/signal.lisp
index fca9c58..a7db12d 100644
--- a/src/code/signal.lisp
+++ b/src/code/signal.lisp
@@ -90,20 +90,47 @@ WITHOUT-INTERRUPTS in:
     (lambda () (with-local-interrupts ...)))
 "
   (with-unique-names (outer-allow-with-interrupts)
-    `(call-without-interrupts
-      (lambda (,outer-allow-with-interrupts)
-        (declare (disable-package-locks allow-with-interrupts with-interrupts)
-                 (ignorable ,outer-allow-with-interrupts))
-        (macrolet ((allow-with-interrupts (&body allow-forms)
-                     `(call-allowing-with-interrupts
-                       (lambda () ,@allow-forms)
-                       ,',outer-allow-with-interrupts))
-                   (with-local-interrupts (&body with-forms)
-                     `(call-with-local-interrupts
-                       (lambda () ,@with-forms)
-                       ,',outer-allow-with-interrupts)))
+    `(call-with-dx-function (call-without-interrupts
+                             ,outer-allow-with-interrupts)
+       (declare (disable-package-locks allow-with-interrupts with-interrupts)
+                (ignorable ,outer-allow-with-interrupts))
+       (macrolet ((allow-with-interrupts (&body allow-forms)
+                    `(call-allowing-with-interrupts
+                      (lambda () ,@allow-forms)
+                      ,',outer-allow-with-interrupts))
+                  (with-local-interrupts (&body with-forms)
+                    `(call-with-local-interrupts
+                      (lambda () ,@with-forms)
+                      ,',outer-allow-with-interrupts)))
          (declare (enable-package-locks allow-with-interrupts with-interrupts))
-         ,@body)))))
+         ,@body))))
+
+;;; Helper for making the DX closure allocation in WITHOUT-INTERRUPTS
+;;; less ugly.
+;;;
+;;; TODO: generalize for cases where FUNCTION takes more arguments
+;;; than just the thunk; use in other WITH-FOO macros that expand to a
+;;; CALL-WITH-FOO. I just did WITHOUT-INTERRUPTS since it's
+;;; performance critical (for example each call to GETHASH was consing
+;;; 48 bytes of WITHOUT-INTERRUPTS closures). --JES, 2007-06-08
+(sb!xc:defmacro call-with-dx-function ((function &rest args) &body body)
+  (with-unique-names (fun1 fun2)
+    `(flet ((,fun1 (,@args)
+              ,@body))
+       (declare (optimize sb!c::stack-allocate-dynamic-extent))
+       (flet ((,fun2 (,@args)
+                ;; Avoid consing up a closure: FUN1 will be inlined
+                ;; and FUN2 will be stack-allocated, so we avoid
+                ;; consing up a closure. This is split into two
+                ;; separate functions to ensure that the body doesn't
+                ;; get compiled with (OPTIMIZE
+                ;; SB!C::STACK-ALLOCATE-DYNAMIC-EXTENT), which could
+                ;; cause problems e.g. when the body contains
+                ;; DYNAMIC-EXTENT declarations and the code is being
+                ;; compiled with (SAFETY 3).
+                (,fun1 ,@args)))
+         (declare (dynamic-extent (function ,fun2)))
+         (,function (function ,fun2))))))
 
 (sb!xc:defmacro with-interrupts (&body body)
   #!+sb-doc