[Sbcl-commits] master: Reduce consing for restarts.

[stassats <sta...@us...>]

The branch "master" has been updated in SBCL:
       via  d3bfbcd7b79489875097da347a63b4c2085397e2 (commit)
      from  045048a22f1ff47936b6100c811956bcf85e0b13 (commit)

- Log -----------------------------------------------------------------
commit d3bfbcd7b79489875097da347a63b4c2085397e2
Author: Stas Boukarev <sta...@gm...>
Date:   Fri Jan 23 15:31:25 2015 +0300

    Reduce consing for restarts.
    
    Make make-restart optionally inlinable.
    DX-allocate lists on *restart-clusters*.
---
 src/code/defboot.lisp       |    1 +
 src/code/target-error.lisp  |    2 +
 src/code/target-thread.lisp |   68 +++++++++++++++++++++++-------------------
 3 files changed, 40 insertions(+), 31 deletions(-)

diff --git a/src/code/defboot.lisp b/src/code/defboot.lisp
index 9f14b63..2b3a1b1 100644
--- a/src/code/defboot.lisp
+++ b/src/code/defboot.lisp
@@ -484,6 +484,7 @@ evaluated as a PROGN."
     `(let ((*restart-clusters*
              (cons (list ,@(mapcar #'parse-binding bindings))
                    *restart-clusters*)))
+       (declare (truly-dynamic-extent *restart-clusters*))
        ,@forms)))
 
 ;;; Wrap the RESTART-CASE expression in a WITH-CONDITION-RESTARTS if
diff --git a/src/code/target-error.lisp b/src/code/target-error.lisp
index 2ff3a89..341a51d 100644
--- a/src/code/target-error.lisp
+++ b/src/code/target-error.lisp
@@ -44,6 +44,7 @@
 ;;; by RESTART-BIND.
 (defvar *restart-clusters* '())
 
+(declaim (inline make-restart)) ;; for DX allocation
 (defstruct (restart (:constructor make-restart
                         ;; Having TEST-FUNCTION at the end allows
                         ;; to not replicate its default value in RESTART-BIND.
@@ -63,6 +64,7 @@
   ;; however, since safe uses of restarts have to assume dynamic
   ;; extent.
   (associated-conditions '() :type list))
+(declaim (notinline make-restart))
 
 #!-sb-fluid (declaim (freeze-type restart))
 
diff --git a/src/code/target-thread.lisp b/src/code/target-thread.lisp
index f535e14..8da9715 100644
--- a/src/code/target-thread.lisp
+++ b/src/code/target-thread.lisp
@@ -1413,6 +1413,7 @@ session."
          (sb!impl::*previous-readtable-case* nil)
          (sb!impl::*internal-symbol-output-fun* nil)
          (sb!impl::*descriptor-handlers* nil)) ; serve-event
+    (declare (inline make-restart)) ;; to allow DX-allocation
     ;; Binding from C
     (setf sb!vm:*alloc-signal* *default-alloc-signal*)
     (setf (thread-os-thread thread) (current-thread-os-thread))
@@ -1433,38 +1434,43 @@ session."
       (catch 'sb!impl::toplevel-catcher
         (catch 'sb!impl::%end-of-the-world
           (catch '%abort-thread
-            (with-simple-restart
-                (abort "~@<Abort thread (~A)~@:>" *current-thread*)
+            (restart-bind ((abort
+                             (lambda ()
+                               (throw '%abort-thread nil))
+                             :report-function
+                             (lambda (stream)
+                               (format stream "~@<abort thread (~a)~@:>"
+                                       *current-thread*))))
               (without-interrupts
-                  (unwind-protect
-                       (with-local-interrupts
-                         (setf *gc-inhibit* nil) ;for foreign callbacks
-                         (sb!unix::unblock-deferrable-signals)
-                         (setf (thread-result thread)
-                               (prog1
-                                   (cons t
-                                         (multiple-value-list
-                                          (unwind-protect
-                                               (catch '%return-from-thread
-                                                 (if (listp arguments)
-                                                     (apply real-function arguments)
-                                                     (funcall real-function arg1 arg2 arg3)))
-                                            (when *exit-in-process*
-                                              (sb!impl::call-exit-hooks)))))
-                                 #!+sb-safepoint
-                                 (sb!kernel::gc-safepoint))))
-                    ;; We're going down, can't handle interrupts
-                    ;; sanely anymore. GC remains enabled.
-                    (block-deferrable-signals)
-                    ;; We don't want to run interrupts in a dead
-                    ;; thread when we leave WITHOUT-INTERRUPTS.
-                    ;; This potentially causes important
-                    ;; interupts to be lost: SIGINT comes to
-                    ;; mind.
-                    (setq *interrupt-pending* nil)
-                    #!+sb-thruption
-                    (setq *thruption-pending* nil)
-                    (handle-thread-exit thread)))))))))
+                (unwind-protect
+                     (with-local-interrupts
+                       (setf *gc-inhibit* nil) ;for foreign callbacks
+                       (sb!unix::unblock-deferrable-signals)
+                       (setf (thread-result thread)
+                             (prog1
+                                 (cons t
+                                       (multiple-value-list
+                                        (unwind-protect
+                                             (catch '%return-from-thread
+                                               (if (listp arguments)
+                                                   (apply real-function arguments)
+                                                   (funcall real-function arg1 arg2 arg3)))
+                                          (when *exit-in-process*
+                                            (sb!impl::call-exit-hooks)))))
+                               #!+sb-safepoint
+                               (sb!kernel::gc-safepoint))))
+                  ;; we're going down, can't handle interrupts
+                  ;; sanely anymore. gc remains enabled.
+                  (block-deferrable-signals)
+                  ;; we don't want to run interrupts in a dead
+                  ;; thread when we leave without-interrupts.
+                  ;; this potentially causes important
+                  ;; interupts to be lost: sigint comes to
+                  ;; mind.
+                  (setq *interrupt-pending* nil)
+                  #!+sb-thruption
+                  (setq *thruption-pending* nil)
+                  (handle-thread-exit thread)))))))))
   (values))
 
 (defun make-thread (function &key name arguments ephemeral)

-----------------------------------------------------------------------


hooks/post-receive
-- 
SBCL