From: Matt Birkholz Date: Tue, 18 Jan 2011 19:02:52 +0000 (-0700) Subject: Lay off dynamic-wind. X-Git-Tag: 20110609-ELisp~3 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=0952de3db3ba82a6fa033ce1e4d4952f8a2b128c;p=mit-scheme.git Lay off dynamic-wind. Implemented dynamic bindings with *specpdl*, avoiding a dynamic-wind for every funcall. --- diff --git a/src/elisp/Symbols.scm b/src/elisp/Symbols.scm index 0bf89b93e..9b5a5d9eb 100644 --- a/src/elisp/Symbols.scm +++ b/src/elisp/Symbols.scm @@ -95,6 +95,62 @@ Emacs symbol. |# (%record %symbol name +unbound+ +unbound+ '() '() false false-procedure '() '() '() '() '() '() '() '() '())) +;;;; Special bindings stack. + +(define *specpdl* '()) + +(define-integrable (%specbind vars inits thunk) + (let ((saved-specpdl *specpdl*)) + (%wind-one! (cons (cons vars inits) *specpdl*)) + (let ((value (thunk))) + (%unwind! saved-specpdl) + value))) + +(define-integrable (%wind! saved-state) + (cond ((eq? saved-state *specpdl*) unspecific) + ((null? saved-state) + (error "Cannot wind to saved-state!" saved-state)) + (else + ;; Wind up to previous state. + (%wind! (cdr saved-state)) + ;; Wind up this state. + (%wind-one! saved-state) + unspecific))) + +(define (%wind-one! saved-state) + (let loop ((vars (car (car saved-state))) + (vals (cdr (car saved-state)))) + (if (pair? vars) + (let ((var (car vars)) + (val (car vals))) + (set-car! vals (%symbol-value-no-error var)) + (if (eq? val +unbound+) + (%set-symbol-unbound! var) + (%set-symbol-value! var val)) + (loop (cdr vars) (cdr vals))))) + (set! *specpdl* saved-state)) + +(define (%unwind! saved-state) + (cond ((eq? *specpdl* saved-state) unspecific) + ((null? *specpdl*) + (error "Unwound past saved state!" saved-state)) + (else + ;; Unwind this state. + (let loop ((vars (car (car *specpdl*))) + (vals (cdr (car *specpdl*)))) + (if (pair? vars) + (let ((var (car vars)) + (val (car vals))) + (set-car! vals (%symbol-value-no-error var)) + (if (eq? val +unbound+) + (%set-symbol-unbound! var) + (%set-symbol-value! var val)) + (loop (cdr vars) (cdr vals))))) + (set! *specpdl* (cdr *specpdl*)) + ;; Unwind previous states. + (%unwind! saved-state) + unspecific))) + ;;;; Exported definitions (declare (integrate-operator %symbol?)) @@ -206,6 +262,18 @@ Emacs symbol. |# ;; Assume it's the empty list. (error:%signal Qsetting-constant (list '())))) +(declare (integrate-operator %symbol-value-no-error)) +(define (%symbol-value-no-error symbol) + (if (%%symbol? symbol) + (let ((%value (%symbol/value symbol))) + (cond ((eq? %value +not-global+) + (if ((%symbol/bound? symbol)) + ((%symbol/get-value symbol)) + +unbound+)) + (else %value))) + ;; Assume it's the empty list. + '())) + (declare (integrate-operator %symbol-value)) (define (%symbol-value symbol) (if (%%symbol? symbol) diff --git a/src/elisp/callint.scm b/src/elisp/callint.scm index 3de35173f..11e5ed605 100644 --- a/src/elisp/callint.scm +++ b/src/elisp/callint.scm @@ -141,11 +141,21 @@ Otherwise, this is done only if an arg is read using the minibuffer." ;; interactively! ;; THIS is how to call a command interactively -- as though from ;; command dispatch. - (%with-current-buffer - buffer + ;; Remove any local bindings still active. These are probably + ;; bogus, perhaps from calling Emacs Lisp functions via the + ;; interpreter and aborting. Since we're theoretically just inside + ;; the top-level command dispatch loop, we should be able to discard + ;; these safely and reset the current-buffer. + (%unwind! '()) + ;; Remove any local bindings left over after command execution. + (%unwind-protect (lambda () - (%set-symbol-value! Qthis-command function) - (%funcall function args)))) + (%with-current-buffer + buffer + (lambda () + (%set-symbol-value! Qthis-command function) + (%funcall function args)))) + (lambda () unspecific))) ;;; This is basically (edwin command-reader)interactive-arguments, hacked to ;;; record Emacs Lisp command invocations in the command-history as diff --git a/src/elisp/elisp.pkg b/src/elisp/elisp.pkg index 47c3f99ed..53bc341c4 100644 --- a/src/elisp/elisp.pkg +++ b/src/elisp/elisp.pkg @@ -93,6 +93,11 @@ Copyright (c) 1993 Matthew Birkholz, All Rights Reserved |# %symbol ;record type, used by inlined %symbol? +unbound+ ;constant, used by %symbol-fbound?... +not-global+ ;constant, used by %symbol-value... + *specpdl* + %specbind + %wind! + %wind-one! ;procedure, used by %specbind... + %unwind! %symbol? %make-symbol %symbol-name diff --git a/src/elisp/eval.scm b/src/elisp/eval.scm index 3541fae36..628e19294 100644 --- a/src/elisp/eval.scm +++ b/src/elisp/eval.scm @@ -315,36 +315,6 @@ All the VALUEFORMs are evalled before any symbols are bound." (cons (%car elt) vars) (cons (%eval (%car (%cdr elt))) inits))))))) -(define (%specbind vars inits thunk) - (let ((current-buffer (%current-buffer)) - (+unbound+ "unbound")) - (let ((exchange! - (lambda () - ;; When rewinding, (%current-buffer) may not be the same as - ;; current-buffer, so set it before establishing bindings and - ;; restore it afterwards. - (let ((old-buffer (%current-buffer))) - (%set-current-buffer! current-buffer) - (let loop ((syms vars) - (vals inits)) - (if (pair? syms) - (let* ((symbol (car syms)) - (new-value (car vals)) - (old-value (if (%symbol-bound? symbol) - (%symbol-value symbol) - +unbound+))) - (if (eq? new-value +unbound+) - (%set-symbol-unbound! symbol) - (%set-symbol-value! symbol new-value)) - (set-car! vals old-value) - (loop (cdr syms) (cdr vals))))) - (%set-current-buffer! old-buffer)) - unspecific))) - (dynamic-wind - exchange! - thunk - exchange!)))) - (DEFUN (el:while "e test . body) "(while TEST BODY...) if TEST yields non-NIL, execute the BODY forms and repeat." (let loop () @@ -412,14 +382,17 @@ return from catch." (%catch (%eval tag) (lambda () (%progn body)))) (define (%catch tag thunk) - (call-with-current-continuation - (lambda (exit) - (bind-condition-handler - (list condition-type:%throw) - (lambda (condition) - (if (eq? (access-condition condition 'TAG) tag) - (exit (access-condition condition 'VALUE)))) - thunk)))) + (let ((saved-specpdl *specpdl*)) + (call-with-current-continuation + (lambda (exit) + (bind-condition-handler + (list condition-type:%throw) + (lambda (condition) + (if (eq? (access-condition condition 'TAG) tag) + (begin + (%unwind! saved-specpdl) + (exit (access-condition condition 'VALUE))))) + thunk))))) (DEFUN (el:throw tag value) "(throw TAG VALUE): throw to the catch for TAG and return VALUE from it. @@ -437,10 +410,22 @@ If BODYFORM exits nonlocally, the UNWINDFORMS are executed anyway." (lambda () (%progn unwindforms)))) (define (%unwind-protect protected-thunk unwind-thunk) - (dynamic-wind - (lambda () unspecific) - protected-thunk - unwind-thunk)) + (let (;;(inside-specpdl *specpdl*) + (outside-specpdl)) + (dynamic-wind + (lambda () + (set! outside-specpdl *specpdl*) + ;; Let whoever caught the cc worry about saving the dynamic state! + ;;(%wind! inside-specpdl) + ;;(set! inside-specpdl) + unspecific) + protected-thunk + (lambda () + ;;(set! inside-specpdl *specpdl*) + (%unwind! outside-specpdl) + (set! outside-specpdl) + (unwind-thunk) + unspecific)))) (define condition-type:%signal (make-condition-type 'EL:SIGNAL () '(NAME DATA) @@ -483,28 +468,30 @@ control returns to the condition-case and the handler BODY... is executed with VAR bound to (SIGNALED-CONDITIONS . SIGNAL-DATA). The value of the last BODY form is returned from the condition-case. See SIGNAL for more info." - (call-with-current-continuation - (lambda (exit) - (bind-condition-handler - (list condition-type:%signal) - (lambda (condition) - (let ((generalizations (%get (access-condition condition 'NAME) - Qerror-conditions))) - (let loop ((handlers handlers)) - (cond ((null? handlers) false) - ((memq (caar handlers) generalizations) - (exit (if (null? var) - (%progn (CHECK-LIST (cdar handlers))) - (%specbind - (list var) - (list (cons - (access-condition condition 'NAME) - (access-condition condition 'DATA))) - (lambda () - (%progn (CHECK-LIST (cdar handlers)))))))) - (else (loop (cdr handlers))))))) - (lambda () - (%eval bodyform)))))) + (let ((saved-specpdl *specpdl*)) + (call-with-current-continuation + (lambda (exit) + (bind-condition-handler + (list condition-type:%signal) + (lambda (condition) + (let ((generalizations (%get (access-condition condition 'NAME) + Qerror-conditions))) + (let loop ((handlers handlers)) + (cond ((null? handlers) false) + ((memq (caar handlers) generalizations) + (%unwind! saved-specpdl) + (exit (if (null? var) + (%progn (CHECK-LIST (cdar handlers))) + (%specbind + (list var) + (list (cons + (access-condition condition 'NAME) + (access-condition condition 'DATA))) + (lambda () + (%progn (CHECK-LIST (cdar handlers)))))))) + (else (loop (cdr handlers))))))) + (lambda () + (%eval bodyform))))))) (DEFUN (el:signal name data) "Signal an error. Args are SIGNAL-NAME, and associated DATA. @@ -619,10 +606,18 @@ this does nothing and returns nil." "an alist of Emacs Lisp symbols and values, or the Emacs Lisp symbol \"t\"")) (loop autoload-queue))))) - (let ((outside-queue) + (let ((outside-specpdl) + (outside-queue) + ;;(inside-specpdl *specpdl*) (inside-queue Qt)) (dynamic-wind (lambda () + (set! outside-specpdl *specpdl*) + ;; Let whoever caught the cc worry about saving the dynamic state! + ;;(%wind! inside-specpdl) + ;;(set! *specpdl* inside-specpdl) + ;;(set! inside-specpdl) + ;; Don't make them worry about the autoload-queue! (set! outside-queue autoload-queue) (set! autoload-queue inside-queue) (set! inside-queue) @@ -636,6 +631,9 @@ this does nothing and returns nil." (set! inside-queue autoload-queue) (set! autoload-queue outside-queue) (set! outside-queue) + ;;(set! inside-specpdl *specpdl*) + (%unwind! outside-specpdl) + (set! outside-specpdl) unspecific)))) (DEFUN (el:eval form)