Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

Less consing for restarts.

Reduced consing in restart-bind and friends, in the spirit of the
original handler-bind tricks.

* src/code/defboot.lisp (with-condition-restarts): make use of dx-let
(restart-bind): use dx-let for restart clusters; turn lambda forms
into dx-flettable local functions.

* src/code/target-error.lisp: declaim make-restart constructor inline
to make stack-allocation of restarts possible (CLHS allows
dynamic-extent for restarts).
  • Loading branch information...
commit fb555841f95c5fd05ada5ddef43bd61cd09c2a4e 1 parent 07c0546
@akovalenko authored
Showing with 42 additions and 21 deletions.
  1. +41 −21 src/code/defboot.lisp
  2. +1 −0  src/code/target-error.lisp
View
62 src/code/defboot.lisp
@@ -415,12 +415,12 @@ evaluated as a PROGN."
This allows FIND-RESTART, etc., to recognize restarts that are not related
to the error currently being debugged. See also RESTART-CASE."
(let ((n-cond (gensym)))
- `(let ((*condition-restarts*
- (cons (let ((,n-cond ,condition-form))
- (cons ,n-cond
- (append ,restarts-form
- (cdr (assoc ,n-cond *condition-restarts*)))))
- *condition-restarts*)))
+ `(dx-let ((*condition-restarts*
+ (cons (let ((,n-cond ,condition-form))
+ (cons ,n-cond
+ (append ,restarts-form
+ (cdr (assoc ,n-cond *condition-restarts*)))))
+ *condition-restarts*)))
,@body)))
(defmacro-mundanely restart-bind (bindings &body forms)
@@ -428,22 +428,42 @@ evaluated as a PROGN."
"Executes forms in a dynamic context where the given restart bindings are
in effect. Users probably want to use RESTART-CASE. When clauses contain
the same restart name, FIND-RESTART will find the first such clause."
- `(let ((*restart-clusters*
- (cons (list
- ,@(mapcar (lambda (binding)
- (unless (or (car binding)
- (member :report-function
- binding
- :test #'eq))
- (warn "Unnamed restart does not have a ~
+ (let (dx-fun)
+ (setf bindings
+ (flet ((dxify (thing)
+ (typecase thing
+ ((cons (eql lambda))
+ (setf thing `(function ,thing))))
+ (typecase thing
+ ((cons (eql function)
+ (cons
+ (cons (eql lambda))))
+ `(function
+ ,(caar (push (list* (gensym "LAMBDA")
+ (rest (second thing)))
+ dx-fun))))
+ (t thing))))
+ (mapcar (lambda (binding)
+ (cons (first binding)
+ (mapcar #'dxify (rest binding))))
+ bindings)))
+ `(dx-flet ,dx-fun
+ (dx-let ((*restart-clusters*
+ (cons (list
+ ,@(mapcar (lambda (binding)
+ (unless (or (car binding)
+ (member :report-function
+ binding
+ :test #'eq))
+ (warn "Unnamed restart does not have a ~
report function: ~S"
- binding))
- `(make-restart :name ',(car binding)
- :function ,(cadr binding)
- ,@(cddr binding)))
- bindings))
- *restart-clusters*)))
- ,@forms))
+ binding))
+ `(make-restart :name ',(car binding)
+ :function ,(cadr binding)
+ ,@(cddr binding)))
+ bindings))
+ *restart-clusters*)))
+ ,@forms))))
;;; Wrap the RESTART-CASE expression in a WITH-CONDITION-RESTARTS if
;;; appropriate. Gross, but it's what the book seems to say...
View
1  src/code/target-error.lisp
@@ -32,6 +32,7 @@
(defvar *handler-clusters* (initial-handler-clusters))
+(declaim (inline make-restart))
(defstruct (restart (:copier nil) (:predicate nil))
(name (missing-arg) :type symbol :read-only t)
(function (missing-arg) :type function)
Please sign in to comment.
Something went wrong with that request. Please try again.