From: Nikodemus Siivola <nikodemus@random-state.net>
Date: Tue, 19 Jun 2007 21:00:03 +0000 (+0000)
Subject: 1.0.6.56: replace CALL-WITH-DX-FUNCTION with DX-FLET
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=60a7d6fe1a3005f89973181c065d2bfa8c974e55;p=sbcl.git

1.0.6.56: replace CALL-WITH-DX-FUNCTION with DX-FLET

 * Essentially same underlying macroexpansion, but more flexible in
   use, and possibly even easier to read.

 * Use DX-FLET instead of LAMBDAs in our CALL-WITH-FOO expansions
   to avoid consing up closures.
---

diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr
index 74ab81d..a5d9b33 100644
--- a/package-data-list.lisp-expr
+++ b/package-data-list.lisp-expr
@@ -901,6 +901,7 @@ possibly temporariliy, because it might be used internally."
                "DEFENUM"
                "DEFPRINTER"
                "AVER" "ENFORCE-TYPE"
+               "DX-FLET"
                "AWHEN" "ACOND" "IT"
                "BINDING*"
                "!DEF-BOOLEAN-ATTRIBUTE"
diff --git a/src/code/cross-misc.lisp b/src/code/cross-misc.lisp
index 16b4999..0f68d1d 100644
--- a/src/code/cross-misc.lisp
+++ b/src/code/cross-misc.lisp
@@ -25,6 +25,10 @@
 ;;; may then have to wade through some irrelevant warnings).
 (declaim (declaration inhibit-warnings))
 
+;;; We sometimes want to enable DX unconditionally in our own code,
+;;; but the host can ignore this without harm.
+(declaim (declaration sb!c::stack-allocate-dynamic-extent))
+
 ;;; Interrupt control isn't an issue in the cross-compiler: we don't
 ;;; use address-dependent (and thus GC-dependent) hashes, and we only
 ;;; have a single thread of control.
diff --git a/src/code/early-extensions.lisp b/src/code/early-extensions.lisp
index c3f2474..8e10277 100644
--- a/src/code/early-extensions.lisp
+++ b/src/code/early-extensions.lisp
@@ -1257,3 +1257,38 @@
 an implementation of EVAL that calls the compiler will be used. If set
 to :INTERPRET, an interpreter will be used.")
 
+;;; Helper for making the DX closure allocation in macros expanding
+;;; to CALL-WITH-FOO less ugly.
+;;;
+;;; This expands to something like
+;;;
+;;;  (flet ((foo (...) <body-of-foo>))
+;;;     (declare (optimize stack-allocate-dynamic-extent))
+;;;     (flet ((foo (...)
+;;;              (foo ...))
+;;;        (declare (dynamic-extent #'foo))
+;;;        <body-of-dx-flet>)))
+;;;
+;;; The outer FLETs are inlined into the inner ones, and the inner ones
+;;; are DX-allocated. The double-fletting is done to keep the bodies of
+;;; the functions in an environment with correct policy: we don't want
+;;; to force DX allocation in their bodies, which would be bad eg.
+;;; in safe code.
+(defmacro dx-flet (functions &body forms)
+  `(flet ,functions
+     (declare (optimize sb!c::stack-allocate-dynamic-extent))
+     (flet ,(mapcar
+             (lambda (f)
+               (let ((args (cadr f))
+                     (name (car f)))
+                 (when (intersection args lambda-list-keywords)
+                   ;; No fundamental reason not to support them, but we
+                   ;; don't currently need them here.
+                   (error "Non-required arguments not implemented for DX-FLET."))
+                 `(,name ,args
+                    (,name ,@args))))
+             functions)
+       (declare (dynamic-extent ,@(mapcar (lambda (f)
+                                            `(function ,(car f)))
+                                          functions)))
+       ,@forms)))
diff --git a/src/code/signal.lisp b/src/code/signal.lisp
index a7db12d..02a215a 100644
--- a/src/code/signal.lisp
+++ b/src/code/signal.lisp
@@ -90,47 +90,26 @@ WITHOUT-INTERRUPTS in:
     (lambda () (with-local-interrupts ...)))
 "
   (with-unique-names (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))))
-
-;;; 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))))))
+    `(dx-flet ((without-interrupts-thunk (,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)
+                              `(dx-flet ((allow-with-interrupts-thunk ()
+                                            ,@allow-forms))
+                                 (call-allowing-with-interrupts
+                                  #'allow-with-interrupts-thunk
+                                  ,',outer-allow-with-interrupts)))
+                            (with-local-interrupts (&body with-forms)
+                              `(dx-flet ((with-local-interrupts-thunk ()
+                                           ,@with-forms))
+                                 (call-with-local-interrupts
+                                  #'with-local-interrupts-thunk
+                                  ,',outer-allow-with-interrupts))))
+                   (declare (enable-package-locks allow-with-interrupts
+                                                  with-interrupts))
+                   ,@body)))
+       (call-without-interrupts #'without-interrupts-thunk))))
 
 (sb!xc:defmacro with-interrupts (&body body)
   #!+sb-doc
@@ -141,9 +120,10 @@ As interrupts are normally allowed WITH-INTERRUPTS only makes sense if there
 is an outer WITHOUT-INTERRUPTS with a corresponding ALLOW-WITH-INTERRUPTS:
 interrupts are not enabled if any outer WITHOUT-INTERRUPTS is not accompanied
 by ALLOW-WITH-INTERRUPTS."
-  `(call-with-interrupts
-    (lambda () ,@body)
-    (and (not *interrupts-enabled*) *allow-with-interrupts*)))
+  `(dx-flet ((with-interrupts-thunk () ,@body))
+     (call-with-interrupts
+      #'with-interrupts-thunk
+      (and (not *interrupts-enabled*) *allow-with-interrupts*))))
 
 (defun call-allowing-with-interrupts (function allowp)
   (declare (function function))
diff --git a/src/code/thread.lisp b/src/code/thread.lisp
index 7cf49b8..4ef2e66 100644
--- a/src/code/thread.lisp
+++ b/src/code/thread.lisp
@@ -31,17 +31,19 @@
   "Acquire MUTEX for the dynamic scope of BODY, setting it to
 NEW-VALUE or some suitable default value if NIL.  If WAIT-P is non-NIL
 and the mutex is in use, sleep until it is available"
-  `(call-with-mutex
-    (lambda () ,@body)
-    ,mutex
-    ,value
-    ,wait-p))
+  `(dx-flet ((with-mutex-thunk () ,@body))
+     (call-with-mutex
+      #'with-mutex-thunk
+      ,mutex
+      ,value
+      ,wait-p)))
 
 (sb!xc:defmacro with-system-mutex ((mutex &key without-gcing) &body body)
-  `(call-with-system-mutex
-    (lambda () ,@body)
-    ,mutex
-    ,without-gcing))
+  `(dx-flet ((with-system-mutex-thunk () ,@body))
+     (call-with-system-mutex
+      #'with-system-mutex-thunk
+      ,mutex
+      ,without-gcing)))
 
 (sb!xc:defmacro with-recursive-lock ((mutex) &body body)
   #!+sb-doc
@@ -49,26 +51,30 @@ and the mutex is in use, sleep until it is available"
 further recursive lock attempts for the same mutex succeed. It is
 allowed to mix WITH-MUTEX and WITH-RECURSIVE-LOCK for the same mutex
 provided the default value is used for the mutex."
-  `(call-with-recursive-lock
-    (lambda () ,@body)
-    ,mutex))
+  `(dx-flet ((with-recursive-lock-thunk () ,@body))
+     (call-with-recursive-lock
+      #'with-recursive-lock-thunk
+      ,mutex)))
 
 (sb!xc:defmacro with-recursive-spinlock ((spinlock) &body body)
-  `(call-with-recursive-spinlock
-    (lambda () ,@body)
-    ,spinlock))
+  `(dx-flet ((with-recursive-spinlock-thunk () ,@body))
+     (call-with-recursive-spinlock
+      #'with-recursive-spinlock-thunk
+      ,spinlock)))
 
 (sb!xc:defmacro with-recursive-system-spinlock ((spinlock &key without-gcing)
                                                 &body body)
-  `(call-with-recursive-system-spinlock
-    (lambda () ,@body)
-    ,spinlock
-    ,without-gcing))
+  `(dx-flet ((with-recursive-system-spinlock-thunk () ,@body))
+     (call-with-recursive-system-spinlock
+      #'with-recursive-system-spinlock-thunk
+      ,spinlock
+      ,without-gcing)))
 
 (sb!xc:defmacro with-spinlock ((spinlock) &body body)
-  `(call-with-spinlock
-    (lambda () ,@body)
-    ,spinlock))
+  `(dx-flet ((with-spinlock-thunk () ,@body))
+     (call-with-spinlock
+      #'with-spinlock-thunk
+      ,spinlock)))
 
 ;;; KLUDGE: this separate implementation for (NOT SB-THREAD) is not
 ;;; strictly necessary; GET-MUTEX and RELEASE-MUTEX are implemented.
diff --git a/version.lisp-expr b/version.lisp-expr
index 9a9b13c..e30deb9 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".)
-"1.0.6.55"
+"1.0.6.56"