From: Stas Boukarev <stassats@gmail.com>
Date: Thu, 7 Nov 2013 22:26:47 +0000 (+0400)
Subject: Optimize RESTART-CASE.
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=9b81111025d01fb7a708e1ab114646e7807d1b46;p=sbcl.git

Optimize RESTART-CASE.

Optimize a case when restart handlers have zero or one arguments:
instead of saving a &rest list and then applying a function, don't
save anything, or save one argument and use FUNCALL.

Based on a patch by Jan Moringen.

Closes lp#1249055.
---

diff --git a/NEWS b/NEWS
index 9ec0f85..0605d50 100644
--- a/NEWS
+++ b/NEWS
@@ -5,6 +5,8 @@ changes relative to sbcl-1.1.13:
   * optimization: [N]BUTLAST perform a single pass over the list. (lp#1245697)
   * optimization: EQUALP on structures with raw slots (double-float/complex)
     no longer conses and is faster.
+  * optimization: RESTART-CASE expands to more compact code.
+    Thanks to Jan Moringen. (lp#1249055)
   * enhancement: Top-level defmethod without defgeneric no longer causes
     undefined-function warnings in subsequent forms. (lp#503095)
   * bug fix: EQUALP now compares correctly structures with raw slots larger
diff --git a/src/code/defboot.lisp b/src/code/defboot.lisp
index 3ce3db4..c3bb341 100644
--- a/src/code/defboot.lisp
+++ b/src/code/defboot.lisp
@@ -522,7 +522,7 @@ evaluated as a PROGN."
                              (return (values result form))))
                           result)))))
              (parse-clause (clause)
-               (unless (and (listp clause ) (>= (length clause) 2)
+               (unless (and (listp clause) (>= (length clause) 2)
                             (listp (second clause)))
                  (error "ill-formed ~S clause, no lambda-list:~%  ~S"
                         'restart-case clause))
@@ -531,18 +531,33 @@ evaluated as a PROGN."
                      (parse-keywords-and-body body)
                    (list name (sb!xc:gensym "TAG") keywords lambda-list body))))
              (make-binding (clause-data)
-               (destructuring-bind (name tag keywords &rest rest) clause-data
-                 (declare (ignore rest))
-                 `(,name #'(lambda (&rest temp)
-                             (setq ,temp-var temp)
-                             (locally (declare (optimize (safety 0)))
-                               (go ,tag)))
-                         ,@keywords)))
+               (destructuring-bind (name tag keywords lambda-list body) clause-data
+                 (declare (ignore body))
+                 `(,name
+                   (lambda ,(cond ((null lambda-list)
+                                   ())
+                                  ((and (null (cdr lambda-list))
+                                        (not (member (car lambda-list)
+                                                     '(&optional &key &aux))))
+                                   '(temp))
+                                  (t
+                                   '(&rest temp)))
+                     ,@(when lambda-list `((setq ,temp-var temp)))
+                     (locally (declare (optimize (safety 0)))
+                       (go ,tag)))
+                   ,@keywords)))
              (make-apply-and-return (clause-data)
                (destructuring-bind (name tag keywords lambda-list body) clause-data
                  (declare (ignore name keywords))
                  `(,tag (return-from ,block-tag
-                          (apply (lambda ,lambda-list ,@body) ,temp-var))))))
+                          ,(cond ((null lambda-list)
+                                  `(progn ,@body))
+                                 ((and (null (cdr lambda-list))
+                                       (not (member (car lambda-list)
+                                                    '(&optional &key &aux))))
+                                  `(funcall (lambda ,lambda-list ,@body) ,temp-var))
+                                 (t
+                                  `(apply (lambda ,lambda-list ,@body) ,temp-var))))))))
       (let ((clauses-data (mapcar #'parse-clause clauses)))
         `(block ,block-tag
            (let ((,temp-var nil))