From: Nikodemus S. <de...@us...> - 2007-06-28 13:06:14
|
Update of /cvsroot/sbcl/sbcl/src/code In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv32704/src/code Modified Files: cross-misc.lisp early-extensions.lisp thread.lisp Log Message: 1.0.7.1: dynamic extent value cells * Pass DX information from leaf to MAKE-VALUE-CELL, and implement the DX allocation for it on x86 and x86-64. * Declare some appropriate closed-over variables dynamic-extent: allows non-consing WITH-SPINLOCK &co. * Tests. Index: cross-misc.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/code/cross-misc.lisp,v retrieving revision 1.26 retrieving revision 1.27 diff -u -d -r1.26 -r1.27 --- cross-misc.lisp 19 Jun 2007 21:00:05 -0000 1.26 +++ cross-misc.lisp 28 Jun 2007 13:04:58 -0000 1.27 @@ -25,10 +25,6 @@ ;;; 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. Index: early-extensions.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/code/early-extensions.lisp,v retrieving revision 1.85 retrieving revision 1.86 diff -u -d -r1.85 -r1.86 --- early-extensions.lisp 19 Jun 2007 21:00:05 -0000 1.85 +++ early-extensions.lisp 28 Jun 2007 13:04:58 -0000 1.86 @@ -1275,20 +1275,34 @@ ;;; 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))) + (let ((names (mapcar #'car functions))) + `(flet ,functions + #-sb-xc-host + (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 (x) `(function ,x)) names))) + ,@forms)))) + +;;; Another similar one -- but actually touches the policy of the body, +;;; so take care with this one... +(defmacro dx-let (bindings &body forms) + `(locally + #-sb-xc-host + (declare (optimize sb!c::stack-allocate-dynamic-extent)) + (let ,bindings + (declare (dynamic-extent ,@(mapcar (lambda (bind) + (if (consp bind) + (car bind) + bind)) + bindings))) ,@forms))) Index: thread.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/code/thread.lisp,v retrieving revision 1.22 retrieving revision 1.23 diff -u -d -r1.22 -r1.23 --- thread.lisp 19 Jun 2007 21:00:05 -0000 1.22 +++ thread.lisp 28 Jun 2007 13:04:58 -0000 1.23 @@ -119,11 +119,14 @@ (funcall function))) #!+sb-thread +;;; KLUDGE: These need to use DX-LET, because the cleanup form that +;;; closes over GOT-IT causes a value-cell to be allocated for it -- and +;;; we prefer that to go on the stack since it can. (progn (defun call-with-system-mutex (function mutex &optional without-gcing-p) (declare (function function)) (flet ((%call-with-system-mutex () - (let (got-it) + (dx-let (got-it) (unwind-protect (when (setf got-it (get-mutex mutex)) (funcall function)) @@ -138,8 +141,8 @@ (defun call-with-recursive-system-spinlock (function lock &optional without-gcing-p) (declare (function function)) (flet ((%call-with-system-spinlock () - (let ((inner-lock-p (eq *current-thread* (spinlock-value lock))) - (got-it nil)) + (dx-let ((inner-lock-p (eq *current-thread* (spinlock-value lock))) + (got-it nil)) (unwind-protect (when (or inner-lock-p (setf got-it (get-spinlock lock))) (funcall function)) @@ -151,9 +154,20 @@ (without-interrupts (%call-with-system-spinlock))))) + (defun call-with-spinlock (function spinlock) + (declare (function function)) + (dx-let ((got-it nil)) + (without-interrupts + (unwind-protect + (when (setf got-it (allow-with-interrupts + (get-spinlock spinlock))) + (with-local-interrupts (funcall function))) + (when got-it + (release-spinlock spinlock)))))) + (defun call-with-mutex (function mutex value waitp) (declare (function function)) - (let ((got-it nil)) + (dx-let ((got-it nil)) (without-interrupts (unwind-protect (when (setq got-it (allow-with-interrupts @@ -164,8 +178,8 @@ (defun call-with-recursive-lock (function mutex) (declare (function function)) - (let ((inner-lock-p (eq (mutex-value mutex) *current-thread*)) - (got-it nil)) + (dx-let ((inner-lock-p (eq (mutex-value mutex) *current-thread*)) + (got-it nil)) (without-interrupts (unwind-protect (when (or inner-lock-p (setf got-it (allow-with-interrupts @@ -174,20 +188,11 @@ (when got-it (release-mutex mutex)))))) - (defun call-with-spinlock (function spinlock) - (declare (function function)) - (let ((got-it nil)) - (without-interrupts - (unwind-protect - (when (setf got-it (allow-with-interrupts - (get-spinlock spinlock))) - (with-local-interrupts (funcall function))) - (when got-it - (release-spinlock spinlock)))))) + (defun call-with-recursive-spinlock (function spinlock) (declare (function function)) - (let ((inner-lock-p (eq (spinlock-value spinlock) *current-thread*)) + (dx-let ((inner-lock-p (eq (spinlock-value spinlock) *current-thread*)) (got-it nil)) (without-interrupts (unwind-protect |