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)))
(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
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))
"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
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.
projects / sbcl.git / commitdiff