From: Nikodemus Siivola Date: Fri, 30 May 2008 11:32:13 +0000 (+0000) Subject: 1.0.17.8: use dynamic-extent in HANDLER-CASE and HANDLER-BIND X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=bef03694b858728bfe9481385631daeda607b5c6;p=sbcl.git 1.0.17.8: use dynamic-extent in HANDLER-CASE and HANDLER-BIND * Hairier then I would have liked due to need not to leak the stack allocation policy to user code. See my email to sbcl-devel: "Future of sb-c:stack-allocate-dynamic-extent" for related discussion. * Also eliminate one redundant FLOAT-WAIT by splitting HANDLER-BIND into two parts, and using the more primitive one -- one that doesn't inject FLOAT-WAIT on its -- to implement HANDLER-CASE. --- diff --git a/NEWS b/NEWS index e37de68..f669895 100644 --- a/NEWS +++ b/NEWS @@ -7,6 +7,8 @@ changes in sbcl-1.0.18 relative to 1.0.17: ** inline constructors are capable of dynamic extent allocation (generally on x86 and x86-64, in some cases on other platforms as well.) + * optimization: simple uses of HANDLER-CASE and HANDLER-BIND no + longer cons. changes in sbcl-1.0.17 relative to 1.0.16: * temporary regression: user code can no longer allocate closure diff --git a/src/code/defboot.lisp b/src/code/defboot.lisp index 16fd031..f36232b 100644 --- a/src/code/defboot.lisp +++ b/src/code/defboot.lisp @@ -563,39 +563,60 @@ evaluated as a PROGN." (format stream ,format-string ,@format-arguments)) (values nil t)))) -(defmacro-mundanely handler-bind (bindings &body forms) - #!+sb-doc - "(HANDLER-BIND ( {(type handler)}* ) body) - Executes body in a dynamic context where the given handler bindings are - in effect. Each handler must take the condition being signalled as an - argument. The bindings are searched first to last in the event of a - signalled condition." +(defmacro-mundanely %handler-bind (bindings form) (let ((member-if (member-if (lambda (x) (not (proper-list-of-length-p x 2))) bindings))) (when member-if (error "ill-formed handler binding: ~S" (first member-if)))) - `(let ((*handler-clusters* - (cons (list ,@(mapcar (lambda (x) `(cons ',(car x) ,(cadr x))) - bindings)) - *handler-clusters*))) - (multiple-value-prog1 - (progn - ,@forms) - ;; Wait for any float exceptions. - #!+x86 (float-wait)))) + (let* ((local-funs nil) + (mapped-bindings (mapcar (lambda (binding) + (destructuring-bind (type handler) binding + (let (lambda-form) + (if (and (consp handler) + (or (prog1 (eq 'lambda (car handler)) + (setf lambda-form handler)) + (and (eq 'function (car handler)) + (consp (cdr handler)) + (consp (cadr handler)) + (prog1 (eq 'lambda (caadr handler)) + (setf lambda-form (cadr handler)))))) + (let ((name (gensym "LAMBDA"))) + (push `(,name ,@(cdr lambda-form)) local-funs) + (list type `(function ,name))) + binding)))) + bindings)) + (form-fun (gensym "FORM-FUN"))) + `(dx-flet (,@(reverse local-funs) + (,form-fun () (progn ,form))) + (let ((*handler-clusters* + (cons (list ,@(mapcar (lambda (x) `(cons ',(car x) ,(cadr x))) + mapped-bindings)) + *handler-clusters*))) + (declare (dynamic-extent *handler-clusters*)) + (,form-fun))))) + +(defmacro-mundanely handler-bind (bindings &body forms) + #!+sb-doc + "(HANDLER-BIND ( {(type handler)}* ) body) + +Executes body in a dynamic context where the given handler bindings are in +effect. Each handler must take the condition being signalled as an argument. +The bindings are searched first to last in the event of a signalled +condition." + `(%handler-bind ,bindings + #!-x86 (progn ,@forms) + ;; Need to catch FP errors here! + #!+x86 (multiple-value-prog1 (progn ,@forms) (float-wait)))) (defmacro-mundanely handler-case (form &rest cases) - "(HANDLER-CASE form - { (type ([var]) body) }* ) - Execute FORM in a context with handlers established for the condition - types. A peculiar property allows type to be :NO-ERROR. If such a clause - occurs, and form returns normally, all its values are passed to this clause - as if by MULTIPLE-VALUE-CALL. The :NO-ERROR clause accepts more than one - var specification." - ;; FIXME: Replacing CADR, CDDDR and friends with DESTRUCTURING-BIND - ;; and names for the subexpressions would make it easier to - ;; understand the code below. + "(HANDLER-CASE form { (type ([var]) body) }* ) + +Execute FORM in a context with handlers established for the condition types. A +peculiar property allows type to be :NO-ERROR. If such a clause occurs, and +form returns normally, all its values are passed to this clause as if by +MULTIPLE-VALUE-CALL. The :NO-ERROR clause accepts more than one var +specification." (let ((no-error-clause (assoc ':no-error cases))) (if no-error-clause (let ((normal-return (make-symbol "normal-return")) @@ -606,41 +627,47 @@ evaluated as a PROGN." (return-from ,error-return (handler-case (return-from ,normal-return ,form) ,@(remove no-error-clause cases))))))) - (let ((tag (gensym)) - (var (gensym)) - (annotated-cases (mapcar (lambda (case) (cons (gensym) case)) - cases))) - `(block ,tag - (let ((,var nil)) - (declare (ignorable ,var)) - (tagbody - (handler-bind - ,(mapcar (lambda (annotated-case) - (list (cadr annotated-case) - `(lambda (temp) - ,(if (caddr annotated-case) - `(setq ,var temp) - '(declare (ignore temp))) - (go ,(car annotated-case))))) - annotated-cases) - (return-from ,tag - #!-x86 ,form - #!+x86 (multiple-value-prog1 ,form - ;; Need to catch FP errors here! - (float-wait)))) - ,@(mapcan - (lambda (annotated-case) - (list (car annotated-case) - (let ((body (cdddr annotated-case))) - `(return-from - ,tag - ,(cond ((caddr annotated-case) - `(let ((,(caaddr annotated-case) - ,var)) - ,@body)) - (t - `(locally ,@body))))))) - annotated-cases)))))))) + (let* ((local-funs nil) + (annotated-cases (mapcar (lambda (case) + (let ((tag (gensym "TAG")) + (fun (gensym "FUN"))) + (destructuring-bind (type ll &body body) case + (push `(,fun ,ll ,@body) local-funs) + (list tag type ll fun)))) + cases))) + (with-unique-names (block var form-fun) + `(dx-flet ((,form-fun () + #!-x86 ,form + ;; Need to catch FP errors here! + #!+x86 (multiple-value-prog1 ,form (float-wait))) + ,@(reverse local-funs)) + (declare (optimize (sb!c::check-tag-existence 0))) + (block ,block + (dx-let ((,var nil)) + (declare (ignorable ,var)) + (tagbody + (%handler-bind + ,(mapcar (lambda (annotated-case) + (destructuring-bind (tag type ll fun-name) annotated-case + (declare (ignore fun-name)) + (list type + `(lambda (temp) + ,(if ll + `(setf ,var temp) + '(declare (ignore temp))) + (go ,tag))))) + annotated-cases) + (return-from ,block (,form-fun))) + ,@(mapcan + (lambda (annotated-case) + (destructuring-bind (tag type ll fun-name) annotated-case + (declare (ignore type)) + (list tag + `(return-from ,block + ,(if ll + `(,fun-name ,var) + `(,fun-name)))))) + annotated-cases)))))))))) ;;;; miscellaneous diff --git a/tests/dynamic-extent.impure.lisp b/tests/dynamic-extent.impure.lisp index 10677ac..da58dbf 100644 --- a/tests/dynamic-extent.impure.lisp +++ b/tests/dynamic-extent.impure.lisp @@ -382,6 +382,21 @@ (true dx) nil)) +;;; handler-case and handler-bind should use DX internally + +(defun dx-handler-bind (x) + (handler-bind ((error (lambda (c) (break "OOPS: ~S caused ~S" x c))) + ((and serious-condition (not error)) + #'(lambda (c) (break "OOPS2: ~S did ~S" x c)))) + (/ 2 x))) + +(defun dx-handler-case (x) + (assert (zerop (handler-case (/ 2 x) + (error (c) + (break "OOPS: ~S caused ~S" x c)) + (:no-error (res) + (1- res)))))) + ;;; with-spinlock should use DX and not cons (defvar *slock* (sb-thread::make-spinlock :name "slocklock")) @@ -446,6 +461,8 @@ (assert-consing (nested-dx-not-used *a-cons*)) (assert-no-consing (nested-evil-dx-used *a-cons*)) (assert-no-consing (multiple-dx-uses)) + (assert-no-consing (dx-handler-bind 2)) + (assert-no-consing (dx-handler-case 2)) ;; Not strictly DX.. (assert-no-consing (test-hash-table)) #+sb-thread diff --git a/version.lisp-expr b/version.lisp-expr index 11ae740..60a95f9 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.17.7" +"1.0.17.8"