From: Stefan Monnier Date: Thu, 3 Oct 2013 04:58:56 +0000 (-0400) Subject: Introduce new bytecodes for efficient catch/condition-case in lexbind. X-Git-Tag: emacs-24.3.90~173^2^2~42^2~45^2~387^2~1405 X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=adf2aa61404305e58e71cde0193bb650aff2c4b3;p=emacs.git Introduce new bytecodes for efficient catch/condition-case in lexbind. * lisp/emacs-lisp/byte-opt.el (byte-optimize-form-code-walker): Optimize under `condition-case' and `catch' if byte-compile--use-old-handlers is nil. (disassemble-offset): Handle new bytecodes. * lisp/emacs-lisp/bytecomp.el (byte-pushcatch, byte-pushconditioncase) (byte-pophandler): New byte codes. (byte-goto-ops): Adjust accordingly. (byte-compile--use-old-handlers): New var. (byte-compile-catch): Use new byte codes depending on byte-compile--use-old-handlers. (byte-compile-condition-case--old): Rename from byte-compile-condition-case. (byte-compile-condition-case--new): New function. (byte-compile-condition-case): New function that dispatches depending on byte-compile--use-old-handlers. (byte-compile-unwind-protect): Pass a function to byte-unwind-protect when we can. * lisp/emacs-lisp/cconv.el (cconv-convert, cconv-analyse-form): Adjust for the new compilation scheme using the new byte-codes. * src/alloc.c (Fgarbage_collect): Merge scans of handlerlist and catchlist, and make them unconditional now that they're heap-allocated. * src/bytecode.c (BYTE_CODES): Add Bpushcatch, Bpushconditioncase and Bpophandler. (bcall0): New function. (exec_byte_code): Add corresponding cases. Improve error message when encountering an invalid byte-code. Let Bunwind_protect accept a function (rather than a list of expressions) as argument. * src/eval.c (catchlist): Remove (merge with handlerlist). (handlerlist, lisp_eval_depth): Not static any more. (internal_catch, internal_condition_case, internal_condition_case_1) (internal_condition_case_2, internal_condition_case_n): Use PUSH_HANDLER. (unwind_to_catch, Fthrow, Fsignal): Adjust to merged handlerlist/catchlist. (internal_lisp_condition_case): Use PUSH_HANDLER. Adjust to new handlerlist which can only handle a single condition-case handler at a time. (find_handler_clause): Simplify since we only a single branch here any more. * src/lisp.h (struct handler): Merge struct handler and struct catchtag. (PUSH_HANDLER): New macro. (catchlist): Remove. (handlerlist): Always declare. --- diff --git a/lisp/ChangeLog b/lisp/ChangeLog index a0eeb4a47bd..90158b85b4d 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,27 @@ +2013-10-03 Stefan Monnier + + * emacs-lisp/cconv.el (cconv-convert, cconv-analyse-form): Adjust for + the new compilation scheme using the new byte-codes. + + * emacs-lisp/bytecomp.el (byte-pushcatch, byte-pushconditioncase) + (byte-pophandler): New byte codes. + (byte-goto-ops): Adjust accordingly. + (byte-compile--use-old-handlers): New var. + (byte-compile-catch): Use new byte codes depending on + byte-compile--use-old-handlers. + (byte-compile-condition-case--old): Rename from + byte-compile-condition-case. + (byte-compile-condition-case--new): New function. + (byte-compile-condition-case): New function that dispatches depending + on byte-compile--use-old-handlers. + (byte-compile-unwind-protect): Pass a function to byte-unwind-protect + when we can. + + * emacs-lisp/byte-opt.el (byte-optimize-form-code-walker): + Optimize under `condition-case' and `catch' if + byte-compile--use-old-handlers is nil. + (disassemble-offset): Handle new bytecodes. + 2013-10-03 Stefan Monnier * subr.el (error): Use `declare'. diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index 9da1a4d1f38..14293e3c0df 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -488,11 +488,22 @@ (prin1-to-string form)) nil) - ((memq fn '(function condition-case)) - ;; These forms are compiled as constants or by breaking out + ((eq fn 'function) + ;; This forms is compiled as constant or by breaking out ;; all the subexpressions and compiling them separately. form) + ((eq fn 'condition-case) + (if byte-compile--use-old-handlers + ;; Will be optimized later. + form + `(condition-case ,(nth 1 form) ;Not evaluated. + ,(byte-optimize-form (nth 2 form) for-effect) + ,@(mapcar (lambda (clause) + `(,(car clause) + ,@(byte-optimize-body (cdr clause) for-effect))) + (nthcdr 3 form))))) + ((eq fn 'unwind-protect) ;; the "protected" part of an unwind-protect is compiled (and thus ;; optimized) as a top-level form, so don't do it here. But the @@ -504,13 +515,14 @@ (cdr (cdr form))))) ((eq fn 'catch) - ;; the body of a catch is compiled (and thus optimized) as a - ;; top-level form, so don't do it here. The tag is never - ;; for-effect. The body should have the same for-effect status - ;; as the catch form itself, but that isn't handled properly yet. (cons fn (cons (byte-optimize-form (nth 1 form) nil) - (cdr (cdr form))))) + (if byte-compile--use-old-handlers + ;; The body of a catch is compiled (and thus + ;; optimized) as a top-level form, so don't do it + ;; here. + (cdr (cdr form)) + (byte-optimize-body (cdr form) for-effect))))) ((eq fn 'ignore) ;; Don't treat the args to `ignore' as being @@ -1292,7 +1304,7 @@ "Don't call this!" ;; Fetch and return the offset for the current opcode. ;; Return nil if this opcode has no offset. - (cond ((< bytedecomp-op byte-nth) + (cond ((< bytedecomp-op byte-pophandler) (let ((tem (logand bytedecomp-op 7))) (setq bytedecomp-op (logand bytedecomp-op 248)) (cond ((eq tem 6) @@ -1311,7 +1323,9 @@ (setq bytedecomp-op byte-constant))) ((or (and (>= bytedecomp-op byte-constant2) (<= bytedecomp-op byte-goto-if-not-nil-else-pop)) - (= bytedecomp-op byte-stack-set2)) + (memq bytedecomp-op (eval-when-compile + (list byte-stack-set2 byte-pushcatch + byte-pushconditioncase)))) ;; Offset in next 2 bytes. (setq bytedecomp-ptr (1+ bytedecomp-ptr)) (+ (aref bytes bytedecomp-ptr) diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 164cdb12952..35c7c391870 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -535,7 +535,13 @@ Each element is (INDEX . VALUE)") (byte-defop 40 0 byte-unbind "for unbinding special bindings") ;; codes 8-47 are consumed by the preceding opcodes -;; unused: 48-55 +;; New (in Emacs-24.4) bytecodes for more efficient handling of non-local exits +;; (especially useful in lexical-binding code). +(byte-defop 48 0 byte-pophandler) +(byte-defop 50 -1 byte-pushcatch) +(byte-defop 49 -1 byte-pushconditioncase) + +;; unused: 51-55 (byte-defop 56 -1 byte-nth) (byte-defop 57 0 byte-symbolp) @@ -707,7 +713,8 @@ otherwise pop it") (defconst byte-goto-ops '(byte-goto byte-goto-if-nil byte-goto-if-not-nil byte-goto-if-nil-else-pop - byte-goto-if-not-nil-else-pop) + byte-goto-if-not-nil-else-pop + byte-pushcatch byte-pushconditioncase) "List of byte-codes whose offset is a pc.") (defconst byte-goto-always-pop-ops '(byte-goto-if-nil byte-goto-if-not-nil)) @@ -4028,23 +4035,35 @@ binding slots have been popped." ;; (byte-defop-compiler-1 with-output-to-temp-buffer) ;Obsolete: now a macro. (byte-defop-compiler-1 track-mouse) +(defvar byte-compile--use-old-handlers t + "If nil, use new byte codes introduced in Emacs-24.4.") + (defun byte-compile-catch (form) (byte-compile-form (car (cdr form))) - (pcase (cddr form) - (`(:fun-body ,f) - (byte-compile-form `(list 'funcall ,f))) - (body - (byte-compile-push-constant - (byte-compile-top-level (cons 'progn body) byte-compile--for-effect)))) - (byte-compile-out 'byte-catch 0)) + (if (not byte-compile--use-old-handlers) + (let ((endtag (byte-compile-make-tag))) + (byte-compile-goto 'byte-pushcatch endtag) + (byte-compile-body (cddr form) nil) + (byte-compile-out 'byte-pophandler) + (byte-compile-out-tag endtag)) + (pcase (cddr form) + (`(:fun-body ,f) + (byte-compile-form `(list 'funcall ,f))) + (body + (byte-compile-push-constant + (byte-compile-top-level (cons 'progn body) byte-compile--for-effect)))) + (byte-compile-out 'byte-catch 0))) (defun byte-compile-unwind-protect (form) (pcase (cddr form) (`(:fun-body ,f) - (byte-compile-form `(list (list 'funcall ,f)))) + (byte-compile-form + (if byte-compile--use-old-handlers `(list (list 'funcall ,f)) f))) (handlers - (byte-compile-push-constant - (byte-compile-top-level-body handlers t)))) + (if byte-compile--use-old-handlers + (byte-compile-push-constant + (byte-compile-top-level-body handlers t)) + (byte-compile-form `#'(lambda () ,@handlers))))) (byte-compile-out 'byte-unwind-protect 0) (byte-compile-form-do-effect (car (cdr form))) (byte-compile-out 'byte-unbind 1)) @@ -4056,6 +4075,11 @@ binding slots have been popped." (_ `(eval '(track-mouse ,@(byte-compile-top-level-body (cdr form)))))))) (defun byte-compile-condition-case (form) + (if byte-compile--use-old-handlers + (byte-compile-condition-case--old form) + (byte-compile-condition-case--new form))) + +(defun byte-compile-condition-case--old (form) (let* ((var (nth 1 form)) (fun-bodies (eq var :fun-body)) (byte-compile-bound-variables @@ -4106,6 +4130,62 @@ binding slots have been popped." (byte-compile-push-constant compiled-clauses))) (byte-compile-out 'byte-condition-case 0))) +(defun byte-compile-condition-case--new (form) + (let* ((var (nth 1 form)) + (body (nth 2 form)) + (depth byte-compile-depth) + (clauses (mapcar (lambda (clause) + (cons (byte-compile-make-tag) clause)) + (nthcdr 3 form))) + (endtag (byte-compile-make-tag))) + (byte-compile-set-symbol-position 'condition-case) + (unless (symbolp var) + (byte-compile-warn + "`%s' is not a variable-name or nil (in condition-case)" var)) + + (dolist (clause (reverse clauses)) + (let ((condition (nth 1 clause))) + (unless (consp condition) (setq condition (list condition))) + (dolist (c condition) + (unless (and c (symbolp c)) + (byte-compile-warn + "`%S' is not a condition name (in condition-case)" c)) + ;; In reality, the `error-conditions' property is only required + ;; for the argument to `signal', not to `condition-case'. + ;;(unless (consp (get c 'error-conditions)) + ;; (byte-compile-warn + ;; "`%s' is not a known condition name (in condition-case)" + ;; c)) + ) + (byte-compile-push-constant condition)) + (byte-compile-goto 'byte-pushconditioncase (car clause))) + + (byte-compile-form body) ;; byte-compile--for-effect + (dolist (_ clauses) (byte-compile-out 'byte-pophandler)) + (byte-compile-goto 'byte-goto endtag) + + (while clauses + (let ((clause (pop clauses)) + (byte-compile-bound-variables byte-compile-bound-variables) + (byte-compile--lexical-environment + byte-compile--lexical-environment)) + (setq byte-compile-depth (1+ depth)) + (byte-compile-out-tag (pop clause)) + (dolist (_ clauses) (byte-compile-out 'byte-pophandler)) + (cond + ((null var) (byte-compile-discard)) + (lexical-binding + (push (cons var (1- byte-compile-depth)) + byte-compile--lexical-environment)) + (t (byte-compile-dynamic-variable-bind var))) + (byte-compile-body (cdr clause)) ;; byte-compile--for-effect + (cond + ((null var) nil) + (lexical-binding (byte-compile-discard 1 'preserve-tos)) + (t (byte-compile-out 'byte-unbind 1))) + (byte-compile-goto 'byte-goto endtag))) + + (byte-compile-out-tag endtag))) (defun byte-compile-save-excursion (form) (if (and (eq 'set-buffer (car-safe (car-safe (cdr form)))) diff --git a/lisp/emacs-lisp/cconv.el b/lisp/emacs-lisp/cconv.el index c655c2fff84..f24e503fd6d 100644 --- a/lisp/emacs-lisp/cconv.el +++ b/lisp/emacs-lisp/cconv.el @@ -79,8 +79,7 @@ ;; command-history). ;; - canonize code in macro-expand so we don't have to handle (let (var) body) ;; and other oddities. -;; - new byte codes for unwind-protect, catch, and condition-case so that -;; closures aren't needed at all. +;; - new byte codes for unwind-protect so that closures aren't needed at all. ;; - a reference to a var that is known statically to always hold a constant ;; should be turned into a byte-constant rather than a byte-stack-ref. ;; Hmm... right, that's called constant propagation and could be done here, @@ -421,18 +420,42 @@ places where they originally did not directly appear." forms))) ;condition-case - (`(condition-case ,var ,protected-form . ,handlers) + ((and `(condition-case ,var ,protected-form . ,handlers) + (guard byte-compile--use-old-handlers)) (let ((newform (cconv--convert-function () (list protected-form) env form))) `(condition-case :fun-body ,newform - ,@(mapcar (lambda (handler) + ,@(mapcar (lambda (handler) (list (car handler) (cconv--convert-function (list (or var cconv--dummy-var)) (cdr handler) env form))) handlers)))) - (`(,(and head (or `catch `unwind-protect)) ,form . ,body) + ; condition-case with new byte-codes. + (`(condition-case ,var ,protected-form . ,handlers) + `(condition-case ,var + ,(cconv-convert protected-form env extend) + ,@(let* ((cm (and var (member (cons (list var) form) + cconv-captured+mutated))) + (newenv + (cond (cm (cons `(,var . (car-save ,var)) env)) + ((assq var env) (cons `(,var) env)) + (t env)))) + (mapcar + (lambda (handler) + `(,(car handler) + ,@(let ((body + (mapcar (lambda (form) + (cconv-convert form newenv extend)) + (cdr handler)))) + (if (not cm) body + `((let ((,var (list ,var))) ,@body)))))) + handlers)))) + + (`(,(and head (or (and `catch (guard byte-compile--use-old-handlers)) + `unwind-protect)) + ,form . ,body) `(,head ,(cconv-convert form env extend) :fun-body ,(cconv--convert-function () body env form))) @@ -491,7 +514,7 @@ places where they originally did not directly appear." (`(,func . ,forms) ;; First element is function or whatever function-like forms are: or, and, - ;; if, progn, prog1, prog2, while, until + ;; if, catch, progn, prog1, prog2, while, until `(,func . ,(mapcar (lambda (form) (cconv-convert form env extend)) forms))) @@ -646,16 +669,32 @@ and updates the data stored in ENV." (`(quote . ,_) nil) ; quote form (`(function . ,_) nil) ; same as quote - (`(condition-case ,var ,protected-form . ,handlers) + ((and `(condition-case ,var ,protected-form . ,handlers) + (guard byte-compile--use-old-handlers)) ;; FIXME: The bytecode for condition-case forces us to wrap the - ;; form and handlers in closures (for handlers, it's understandable - ;; but not for the protected form). + ;; form and handlers in closures. (cconv--analyse-function () (list protected-form) env form) (dolist (handler handlers) - (cconv--analyse-function (if var (list var)) (cdr handler) env form))) + (cconv--analyse-function (if var (list var)) (cdr handler) + env form))) - ;; FIXME: The bytecode for catch forces us to wrap the body. - (`(,(or `catch `unwind-protect) ,form . ,body) + (`(condition-case ,var ,protected-form . ,handlers) + (cconv-analyse-form protected-form env) + (when (and var (symbolp var) (byte-compile-not-lexical-var-p var)) + (byte-compile-log-warning + (format "Lexical variable shadows the dynamic variable %S" var))) + (let* ((varstruct (list var nil nil nil nil))) + (if var (push varstruct env)) + (dolist (handler handlers) + (dolist (form (cdr handler)) + (cconv-analyse-form form env))) + (if var (cconv--analyse-use (cons (list var) (cdr varstruct)) + form "variable")))) + + ;; FIXME: The bytecode for unwind-protect forces us to wrap the unwind. + (`(,(or (and `catch (guard byte-compile--use-old-handlers)) + `unwind-protect) + ,form . ,body) (cconv-analyse-form form env) (cconv--analyse-function () body env form)) diff --git a/src/ChangeLog b/src/ChangeLog index c201df19851..4b1bfc75187 100644 --- a/src/ChangeLog +++ b/src/ChangeLog @@ -1,3 +1,33 @@ +2013-10-03 Stefan Monnier + + * lisp.h (struct handler): Merge struct handler and struct catchtag. + (PUSH_HANDLER): New macro. + (catchlist): Remove. + (handlerlist): Always declare. + + * eval.c (catchlist): Remove (merge with handlerlist). + (handlerlist, lisp_eval_depth): Not static any more. + (internal_catch, internal_condition_case, internal_condition_case_1) + (internal_condition_case_2, internal_condition_case_n): + Use PUSH_HANDLER. + (unwind_to_catch, Fthrow, Fsignal): Adjust to merged + handlerlist/catchlist. + (internal_lisp_condition_case): Use PUSH_HANDLER. Adjust to new + handlerlist which can only handle a single condition-case handler at + a time. + (find_handler_clause): Simplify since we only a single branch here + any more. + + * bytecode.c (BYTE_CODES): Add Bpushcatch, Bpushconditioncase + and Bpophandler. + (bcall0): New function. + (exec_byte_code): Add corresponding cases. Improve error message when + encountering an invalid byte-code. Let Bunwind_protect accept + a function (rather than a list of expressions) as argument. + + * alloc.c (Fgarbage_collect): Merge scans of handlerlist and catchlist, + and make them unconditional now that they're heap-allocated. + 2013-10-03 Stefan Monnier * charset.c (Fdecode_char, Fencode_char): Remove description of diff --git a/src/alloc.c b/src/alloc.c index 2d9828ffa79..6b07f0bd7b1 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -5370,23 +5370,15 @@ See Info node `(elisp)Garbage Collection'. */) mark_object (tail->var[i]); } mark_byte_stack (); +#endif { - struct catchtag *catch; struct handler *handler; - - for (catch = catchlist; catch; catch = catch->next) - { - mark_object (catch->tag); - mark_object (catch->val); - } - for (handler = handlerlist; handler; handler = handler->next) - { - mark_object (handler->handler); - mark_object (handler->var); - } + for (handler = handlerlist; handler; handler = handler->next) + { + mark_object (handler->tag_or_ch); + mark_object (handler->val); + } } -#endif - #ifdef HAVE_WINDOW_SYSTEM mark_fringe_data (); #endif diff --git a/src/bytecode.c b/src/bytecode.c index 23e50826633..f7ccd35cbba 100644 --- a/src/bytecode.c +++ b/src/bytecode.c @@ -141,6 +141,10 @@ DEFINE (Bunbind5, 055) \ DEFINE (Bunbind6, 056) \ DEFINE (Bunbind7, 057) \ \ +DEFINE (Bpophandler, 060) \ +DEFINE (Bpushconditioncase, 061) \ +DEFINE (Bpushcatch, 062) \ + \ DEFINE (Bnth, 070) \ DEFINE (Bsymbolp, 071) \ DEFINE (Bconsp, 072) \ @@ -478,6 +482,12 @@ If the third argument is incorrect, Emacs may crash. */) return exec_byte_code (bytestr, vector, maxdepth, Qnil, 0, NULL); } +static void +bcall0 (Lisp_Object f) +{ + Ffuncall (1, &f); +} + /* Execute the byte-code in BYTESTR. VECTOR is the constant vector, and MAXDEPTH is the maximum stack depth used (if MAXDEPTH is incorrect, emacs may crash!). If ARGS_TEMPLATE is non-nil, it should be a lisp @@ -506,6 +516,7 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, struct byte_stack stack; Lisp_Object *top; Lisp_Object result; + enum handlertype type; #if 0 /* CHECK_FRAME_FONT */ { @@ -1078,7 +1089,7 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, save_restriction_save ()); NEXT; - CASE (Bcatch): /* FIXME: ill-suited for lexbind. */ + CASE (Bcatch): /* Obsolete since 24.4. */ { Lisp_Object v1; BEFORE_POTENTIAL_GC (); @@ -1088,11 +1099,56 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, NEXT; } + CASE (Bpushcatch): /* New in 24.4. */ + type = CATCHER; + goto pushhandler; + CASE (Bpushconditioncase): /* New in 24.4. */ + { + extern EMACS_INT lisp_eval_depth; + extern int poll_suppress_count; + extern int interrupt_input_blocked; + struct handler *c; + Lisp_Object tag; + int dest; + + type = CONDITION_CASE; + pushhandler: + tag = POP; + dest = FETCH2; + + PUSH_HANDLER (c, tag, type); + c->bytecode_dest = dest; + c->bytecode_top = top; + if (sys_setjmp (c->jmp)) + { + struct handler *c = handlerlist; + top = c->bytecode_top; + int dest = c->bytecode_dest; + handlerlist = c->next; + PUSH (c->val); + CHECK_RANGE (dest); + stack.pc = stack.byte_string_start + dest; + } + NEXT; + } + + CASE (Bpophandler): /* New in 24.4. */ + { + handlerlist = handlerlist->next; + NEXT; + } + CASE (Bunwind_protect): /* FIXME: avoid closure for lexbind. */ - record_unwind_protect (unwind_body, POP); - NEXT; + { + Lisp_Object handler = POP; + /* Support for a function here is new in 24.4. */ + record_unwind_protect (NILP (Ffunctionp (handler)) + ? unwind_body : bcall0, + handler); + NEXT; + } - CASE (Bcondition_case): /* FIXME: ill-suited for lexbind. */ + CASE (Bcondition_case): /* Obsolete since 24.4. */ { Lisp_Object handlers, body; handlers = POP; @@ -1884,7 +1940,10 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, /* Actually this is Bstack_ref with offset 0, but we use Bdup for that instead. */ /* CASE (Bstack_ref): */ - error ("Invalid byte opcode"); + call3 (intern ("error"), + build_string ("Invalid byte opcode: op=%s, ptr=%d"), + make_number (op), + make_number ((stack.pc - 1) - stack.byte_string_start)); /* Handy byte-codes for lexical binding. */ CASE (Bstack_ref1): @@ -1957,11 +2016,11 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, /* Binds and unbinds are supposed to be compiled balanced. */ if (SPECPDL_INDEX () != count) -#ifdef BYTE_CODE_SAFE - error ("binding stack not balanced (serious byte compiler bug)"); -#else - emacs_abort (); -#endif + { + if (SPECPDL_INDEX () > count) + unbind_to (count, Qnil); + error ("binding stack not balanced (serious byte compiler bug)"); + } return result; } diff --git a/src/eval.c b/src/eval.c index 6e964f6604b..5526b28b2e0 100644 --- a/src/eval.c +++ b/src/eval.c @@ -32,20 +32,8 @@ along with GNU Emacs. If not, see . */ #include "xterm.h" #endif -#if !BYTE_MARK_STACK -static -#endif -struct catchtag *catchlist; - -/* Chain of condition handlers currently in effect. - The elements of this chain are contained in the stack frames - of Fcondition_case and internal_condition_case. - When an error is signaled (by calling Fsignal, below), - this chain is searched for an element that applies. */ +/* Chain of condition and catch handlers currently in effect. */ -#if !BYTE_MARK_STACK -static -#endif struct handler *handlerlist; #ifdef DEBUG_GCPRO @@ -92,7 +80,7 @@ union specbinding *specpdl_ptr; /* Depth in Lisp evaluations and function calls. */ -static EMACS_INT lisp_eval_depth; +EMACS_INT lisp_eval_depth; /* The value of num_nonmacro_input_events as of the last time we started to enter the debugger. If we decide to enter the debugger @@ -253,8 +241,7 @@ void init_eval (void) { specpdl_ptr = specpdl; - catchlist = 0; - handlerlist = 0; + handlerlist = NULL; Vquit_flag = Qnil; debug_on_next_call = 0; lisp_eval_depth = 0; @@ -1093,28 +1080,26 @@ Lisp_Object internal_catch (Lisp_Object tag, Lisp_Object (*func) (Lisp_Object), Lisp_Object arg) { /* This structure is made part of the chain `catchlist'. */ - struct catchtag c; + struct handler *c; /* Fill in the components of c, and put it on the list. */ - c.next = catchlist; - c.tag = tag; - c.val = Qnil; - c.handlerlist = handlerlist; - c.lisp_eval_depth = lisp_eval_depth; - c.pdlcount = SPECPDL_INDEX (); - c.poll_suppress_count = poll_suppress_count; - c.interrupt_input_blocked = interrupt_input_blocked; - c.gcpro = gcprolist; - c.byte_stack = byte_stack_list; - catchlist = &c; + PUSH_HANDLER (c, tag, CATCHER); /* Call FUNC. */ - if (! sys_setjmp (c.jmp)) - c.val = (*func) (arg); - - /* Throw works by a longjmp that comes right here. */ - catchlist = c.next; - return c.val; + if (! sys_setjmp (c->jmp)) + { + Lisp_Object val = (*func) (arg); + eassert (handlerlist == c); + handlerlist = c->next; + return val; + } + else + { /* Throw works by a longjmp that comes right here. */ + Lisp_Object val = handlerlist->val; + eassert (handlerlist == c); + handlerlist = handlerlist->next; + return val; + } } /* Unwind the specbind, catch, and handler stacks back to CATCH, and @@ -1134,7 +1119,7 @@ internal_catch (Lisp_Object tag, Lisp_Object (*func) (Lisp_Object), Lisp_Object This is used for correct unwinding in Fthrow and Fsignal. */ static _Noreturn void -unwind_to_catch (struct catchtag *catch, Lisp_Object value) +unwind_to_catch (struct handler *catch, Lisp_Object value) { bool last_time; @@ -1148,16 +1133,17 @@ unwind_to_catch (struct catchtag *catch, Lisp_Object value) do { - last_time = catchlist == catch; - /* Unwind the specpdl stack, and then restore the proper set of handlers. */ - unbind_to (catchlist->pdlcount, Qnil); - handlerlist = catchlist->handlerlist; - catchlist = catchlist->next; + unbind_to (handlerlist->pdlcount, Qnil); + last_time = handlerlist == catch; + if (! last_time) + handlerlist = handlerlist->next; } while (! last_time); + eassert (handlerlist == catch); + byte_stack_list = catch->byte_stack; gcprolist = catch->gcpro; #ifdef DEBUG_GCPRO @@ -1173,12 +1159,12 @@ DEFUN ("throw", Fthrow, Sthrow, 2, 2, 0, Both TAG and VALUE are evalled. */) (register Lisp_Object tag, Lisp_Object value) { - register struct catchtag *c; + struct handler *c; if (!NILP (tag)) - for (c = catchlist; c; c = c->next) + for (c = handlerlist; c; c = c->next) { - if (EQ (c->tag, tag)) + if (c->type == CATCHER && EQ (c->tag_or_ch, tag)) unwind_to_catch (c, value); } xsignal2 (Qno_catch, tag, value); @@ -1244,15 +1230,16 @@ internal_lisp_condition_case (volatile Lisp_Object var, Lisp_Object bodyform, Lisp_Object handlers) { Lisp_Object val; - struct catchtag c; - struct handler h; + struct handler *c; + struct handler *oldhandlerlist = handlerlist; + int clausenb = 0; CHECK_SYMBOL (var); for (val = handlers; CONSP (val); val = XCDR (val)) { - Lisp_Object tem; - tem = XCAR (val); + Lisp_Object tem = XCAR (val); + clausenb++; if (! (NILP (tem) || (CONSP (tem) && (SYMBOLP (XCAR (tem)) @@ -1261,39 +1248,50 @@ internal_lisp_condition_case (volatile Lisp_Object var, Lisp_Object bodyform, SDATA (Fprin1_to_string (tem, Qt))); } - c.tag = Qnil; - c.val = Qnil; - c.handlerlist = handlerlist; - c.lisp_eval_depth = lisp_eval_depth; - c.pdlcount = SPECPDL_INDEX (); - c.poll_suppress_count = poll_suppress_count; - c.interrupt_input_blocked = interrupt_input_blocked; - c.gcpro = gcprolist; - c.byte_stack = byte_stack_list; - if (sys_setjmp (c.jmp)) - { - if (!NILP (h.var)) - specbind (h.var, c.val); - val = Fprogn (Fcdr (h.chosen_clause)); - - /* Note that this just undoes the binding of h.var; whoever - longjumped to us unwound the stack to c.pdlcount before - throwing. */ - unbind_to (c.pdlcount, Qnil); - return val; + { /* The first clause is the one that should be checked first, so it should + be added to handlerlist last. So we build in `clauses' a table that + contains `handlers' but in reverse order. */ + Lisp_Object *clauses = alloca (clausenb * sizeof (Lisp_Object *)); + int i = clausenb; + for (val = handlers; CONSP (val); val = XCDR (val)) + clauses[--i] = XCAR (val); + for (i = 0; i < clausenb; i++) + { + Lisp_Object clause = clauses[i]; + Lisp_Object condition = XCAR (clause); + if (!CONSP (condition)) + condition = Fcons (condition, Qnil); + PUSH_HANDLER (c, condition, CONDITION_CASE); + if (sys_setjmp (c->jmp)) + { + ptrdiff_t count = SPECPDL_INDEX (); + Lisp_Object val = handlerlist->val; + Lisp_Object *chosen_clause = clauses; + for (c = handlerlist->next; c != oldhandlerlist; c = c->next) + chosen_clause++; + handlerlist = oldhandlerlist; + if (!NILP (var)) + { + if (!NILP (Vinternal_interpreter_environment)) + specbind (Qinternal_interpreter_environment, + Fcons (Fcons (var, val), + Vinternal_interpreter_environment)); + else + specbind (var, val); + } + val = Fprogn (XCDR (*chosen_clause)); + /* Note that this just undoes the binding of var; whoever + longjumped to us unwound the stack to c.pdlcount before + throwing. */ + if (!NILP (var)) + unbind_to (count, Qnil); + return val; + } + } } - c.next = catchlist; - catchlist = &c; - - h.var = var; - h.handler = handlers; - h.next = handlerlist; - h.tag = &c; - handlerlist = &h; val = eval_sub (bodyform); - catchlist = c.next; - handlerlist = h.next; + handlerlist = oldhandlerlist; return val; } @@ -1312,33 +1310,20 @@ internal_condition_case (Lisp_Object (*bfun) (void), Lisp_Object handlers, Lisp_Object (*hfun) (Lisp_Object)) { Lisp_Object val; - struct catchtag c; - struct handler h; - - c.tag = Qnil; - c.val = Qnil; - c.handlerlist = handlerlist; - c.lisp_eval_depth = lisp_eval_depth; - c.pdlcount = SPECPDL_INDEX (); - c.poll_suppress_count = poll_suppress_count; - c.interrupt_input_blocked = interrupt_input_blocked; - c.gcpro = gcprolist; - c.byte_stack = byte_stack_list; - if (sys_setjmp (c.jmp)) - { - return (*hfun) (c.val); - } - c.next = catchlist; - catchlist = &c; - h.handler = handlers; - h.var = Qnil; - h.next = handlerlist; - h.tag = &c; - handlerlist = &h; + struct handler *c; + + PUSH_HANDLER (c, handlers, CONDITION_CASE); + if (sys_setjmp (c->jmp)) + { + Lisp_Object val = handlerlist->val; + eassert (handlerlist == c); + handlerlist = handlerlist->next; + return (*hfun) (val); + } val = (*bfun) (); - catchlist = c.next; - handlerlist = h.next; + eassert (handlerlist == c); + handlerlist = c->next; return val; } @@ -1349,33 +1334,20 @@ internal_condition_case_1 (Lisp_Object (*bfun) (Lisp_Object), Lisp_Object arg, Lisp_Object handlers, Lisp_Object (*hfun) (Lisp_Object)) { Lisp_Object val; - struct catchtag c; - struct handler h; - - c.tag = Qnil; - c.val = Qnil; - c.handlerlist = handlerlist; - c.lisp_eval_depth = lisp_eval_depth; - c.pdlcount = SPECPDL_INDEX (); - c.poll_suppress_count = poll_suppress_count; - c.interrupt_input_blocked = interrupt_input_blocked; - c.gcpro = gcprolist; - c.byte_stack = byte_stack_list; - if (sys_setjmp (c.jmp)) - { - return (*hfun) (c.val); - } - c.next = catchlist; - catchlist = &c; - h.handler = handlers; - h.var = Qnil; - h.next = handlerlist; - h.tag = &c; - handlerlist = &h; + struct handler *c; + + PUSH_HANDLER (c, handlers, CONDITION_CASE); + if (sys_setjmp (c->jmp)) + { + Lisp_Object val = handlerlist->val; + eassert (handlerlist == c); + handlerlist = handlerlist->next; + return (*hfun) (val); + } val = (*bfun) (arg); - catchlist = c.next; - handlerlist = h.next; + eassert (handlerlist == c); + handlerlist = c->next; return val; } @@ -1390,33 +1362,20 @@ internal_condition_case_2 (Lisp_Object (*bfun) (Lisp_Object, Lisp_Object), Lisp_Object (*hfun) (Lisp_Object)) { Lisp_Object val; - struct catchtag c; - struct handler h; - - c.tag = Qnil; - c.val = Qnil; - c.handlerlist = handlerlist; - c.lisp_eval_depth = lisp_eval_depth; - c.pdlcount = SPECPDL_INDEX (); - c.poll_suppress_count = poll_suppress_count; - c.interrupt_input_blocked = interrupt_input_blocked; - c.gcpro = gcprolist; - c.byte_stack = byte_stack_list; - if (sys_setjmp (c.jmp)) - { - return (*hfun) (c.val); - } - c.next = catchlist; - catchlist = &c; - h.handler = handlers; - h.var = Qnil; - h.next = handlerlist; - h.tag = &c; - handlerlist = &h; + struct handler *c; + + PUSH_HANDLER (c, handlers, CONDITION_CASE); + if (sys_setjmp (c->jmp)) + { + Lisp_Object val = handlerlist->val; + eassert (handlerlist == c); + handlerlist = handlerlist->next; + return (*hfun) (val); + } val = (*bfun) (arg1, arg2); - catchlist = c.next; - handlerlist = h.next; + eassert (handlerlist == c); + handlerlist = c->next; return val; } @@ -1433,33 +1392,20 @@ internal_condition_case_n (Lisp_Object (*bfun) (ptrdiff_t, Lisp_Object *), Lisp_Object *args)) { Lisp_Object val; - struct catchtag c; - struct handler h; - - c.tag = Qnil; - c.val = Qnil; - c.handlerlist = handlerlist; - c.lisp_eval_depth = lisp_eval_depth; - c.pdlcount = SPECPDL_INDEX (); - c.poll_suppress_count = poll_suppress_count; - c.interrupt_input_blocked = interrupt_input_blocked; - c.gcpro = gcprolist; - c.byte_stack = byte_stack_list; - if (sys_setjmp (c.jmp)) - { - return (*hfun) (c.val, nargs, args); - } - c.next = catchlist; - catchlist = &c; - h.handler = handlers; - h.var = Qnil; - h.next = handlerlist; - h.tag = &c; - handlerlist = &h; + struct handler *c; + + PUSH_HANDLER (c, handlers, CONDITION_CASE); + if (sys_setjmp (c->jmp)) + { + Lisp_Object val = handlerlist->val; + eassert (handlerlist == c); + handlerlist = handlerlist->next; + return (*hfun) (val, nargs, args); + } val = (*bfun) (nargs, args); - catchlist = c.next; - handlerlist = h.next; + eassert (handlerlist == c); + handlerlist = c->next; return val; } @@ -1551,7 +1497,9 @@ See also the function `condition-case'. */) for (h = handlerlist; h; h = h->next) { - clause = find_handler_clause (h->handler, conditions); + if (h->type != CONDITION_CASE) + continue; + clause = find_handler_clause (h->tag_or_ch, conditions); if (!NILP (clause)) break; } @@ -1568,7 +1516,7 @@ See also the function `condition-case'. */) && !NILP (Fmemq (Qdebug, XCAR (clause)))) /* Special handler that means "print a message and run debugger if requested". */ - || EQ (h->handler, Qerror))) + || EQ (h->tag_or_ch, Qerror))) { bool debugger_called = maybe_call_debugger (conditions, error_symbol, data); @@ -1583,12 +1531,11 @@ See also the function `condition-case'. */) Lisp_Object unwind_data = (NILP (error_symbol) ? data : Fcons (error_symbol, data)); - h->chosen_clause = clause; - unwind_to_catch (h->tag, unwind_data); + unwind_to_catch (h, unwind_data); } else { - if (catchlist != 0) + if (handlerlist != 0) Fthrow (Qtop_level, Qt); } @@ -1774,29 +1721,8 @@ find_handler_clause (Lisp_Object handlers, Lisp_Object conditions) for (h = handlers; CONSP (h); h = XCDR (h)) { Lisp_Object handler = XCAR (h); - Lisp_Object condit, tem; - - if (!CONSP (handler)) - continue; - condit = XCAR (handler); - /* Handle a single condition name in handler HANDLER. */ - if (SYMBOLP (condit)) - { - tem = Fmemq (Fcar (handler), conditions); - if (!NILP (tem)) - return handler; - } - /* Handle a list of condition names in handler HANDLER. */ - else if (CONSP (condit)) - { - Lisp_Object tail; - for (tail = condit; CONSP (tail); tail = XCDR (tail)) - { - tem = Fmemq (XCAR (tail), conditions); - if (!NILP (tem)) - return handler; - } - } + if (!NILP (Fmemq (handler, conditions))) + return handlers; } return Qnil; diff --git a/src/lisp.h b/src/lisp.h index 63597e86be6..688c89c1eee 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -2635,11 +2635,9 @@ typedef jmp_buf sys_jmp_buf; - The specpdl stack: keeps track of active unwind-protect and dynamic-let-bindings. Allocated from the `specpdl' array, a manually managed stack. - - The catch stack: keeps track of active catch tags. - Allocated on the C stack. This is where the setmp data is kept. - - The handler stack: keeps track of active condition-case handlers. - Allocated on the C stack. Every entry there also uses an entry in - the catch stack. */ + - The handler stack: keeps track of active catch tags and condition-case + handlers. Allocated in a manually managed stack implemented by a + doubly-linked list allocated via xmalloc and never freed. */ /* Structure for recording Lisp call stack for backtrace purposes. */ @@ -2709,46 +2707,16 @@ SPECPDL_INDEX (void) return specpdl_ptr - specpdl; } -/* Everything needed to describe an active condition case. +/* This structure helps implement the `catch/throw' and `condition-case/signal' + control structures. A struct handler contains all the information needed to + restore the state of the interpreter after a non-local jump. - Members are volatile if their values need to survive _longjmp when - a 'struct handler' is a local variable. */ -struct handler - { - /* The handler clauses and variable from the condition-case form. */ - /* For a handler set up in Lisp code, this is always a list. - For an internal handler set up by internal_condition_case*, - this can instead be the symbol t or `error'. - t: handle all conditions. - error: handle all conditions, and errors can run the debugger - or display a backtrace. */ - Lisp_Object handler; - - Lisp_Object volatile var; - - /* Fsignal stores here the condition-case clause that applies, - and Fcondition_case thus knows which clause to run. */ - Lisp_Object volatile chosen_clause; - - /* Used to effect the longjump out to the handler. */ - struct catchtag *tag; - - /* The next enclosing handler. */ - struct handler *next; - }; + handler structures are chained together in a doubly linked list; the `next' + member points to the next outer catchtag and the `nextfree' member points in + the other direction to the next inner element (which is typically the next + free element since we mostly use it on the deepest handler). -/* This structure helps implement the `catch' and `throw' control - structure. A struct catchtag contains all the information needed - to restore the state of the interpreter after a non-local jump. - - Handlers for error conditions (represented by `struct handler' - structures) just point to a catch tag to do the cleanup required - for their jumps. - - catchtag structures are chained together in the C calling stack; - the `next' member points to the next outer catchtag. - - A call like (throw TAG VAL) searches for a catchtag whose `tag' + A call like (throw TAG VAL) searches for a catchtag whose `tag_or_ch' member is TAG, and then unbinds to it. The `val' member is used to hold VAL while the stack is unwound; `val' is returned as the value of the catch form. @@ -2757,24 +2725,63 @@ struct handler state. Members are volatile if their values need to survive _longjmp when - a 'struct catchtag' is a local variable. */ -struct catchtag + a 'struct handler' is a local variable. */ + +enum handlertype { CATCHER, CONDITION_CASE }; + +struct handler { - Lisp_Object tag; - Lisp_Object volatile val; - struct catchtag *volatile next; + enum handlertype type; + Lisp_Object tag_or_ch; + Lisp_Object val; + struct handler *next; + struct handler *nextfree; + + /* The bytecode interpreter can have several handlers active at the same + time, so when we longjmp to one of them, it needs to know which handler + this was and what was the corresponding internal state. This is stored + here, and when we longjmp we make sure that handlerlist points to the + proper handler. */ + Lisp_Object *bytecode_top; + int bytecode_dest; + + /* Most global vars are reset to their value via the specpdl mechanism, + but a few others are handled by storing their value here. */ #if 1 /* GC_MARK_STACK == GC_MAKE_GCPROS_NOOPS, but they're defined later. */ struct gcpro *gcpro; #endif sys_jmp_buf jmp; - struct handler *handlerlist; EMACS_INT lisp_eval_depth; - ptrdiff_t volatile pdlcount; + ptrdiff_t pdlcount; int poll_suppress_count; int interrupt_input_blocked; struct byte_stack *byte_stack; }; +/* Fill in the components of c, and put it on the list. */ +#define PUSH_HANDLER(c, tag_ch_val, handlertype) \ + if (handlerlist && handlerlist->nextfree) \ + (c) = handlerlist->nextfree; \ + else \ + { \ + (c) = xmalloc (sizeof (struct handler)); \ + (c)->nextfree = NULL; \ + if (handlerlist) \ + handlerlist->nextfree = (c); \ + } \ + (c)->type = (handlertype); \ + (c)->tag_or_ch = (tag_ch_val); \ + (c)->val = Qnil; \ + (c)->next = handlerlist; \ + (c)->lisp_eval_depth = lisp_eval_depth; \ + (c)->pdlcount = SPECPDL_INDEX (); \ + (c)->poll_suppress_count = poll_suppress_count; \ + (c)->interrupt_input_blocked = interrupt_input_blocked;\ + (c)->gcpro = gcprolist; \ + (c)->byte_stack = byte_stack_list; \ + handlerlist = (c); + + extern Lisp_Object memory_signal_data; /* An address near the bottom of the stack. @@ -3677,10 +3684,8 @@ extern Lisp_Object Qand_rest; extern Lisp_Object Vautoload_queue; extern Lisp_Object Vsignaling_function; extern Lisp_Object inhibit_lisp_code; -#if BYTE_MARK_STACK -extern struct catchtag *catchlist; extern struct handler *handlerlist; -#endif + /* To run a normal hook, use the appropriate function from the list below. The calling convention: