+2013-10-03 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * 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 <monnier@iro.umontreal.ca>
* subr.el (error): Use `declare'.
(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
(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
"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)
(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)
(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)
(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))
;; (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))
(_ `(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
(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))))
;; 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,
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)))
(`(,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)))
(`(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))
+2013-10-03 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * 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 <monnier@iro.umontreal.ca>
* charset.c (Fdecode_char, Fencode_char): Remove description of
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
DEFINE (Bunbind6, 056) \
DEFINE (Bunbind7, 057) \
\
+DEFINE (Bpophandler, 060) \
+DEFINE (Bpushconditioncase, 061) \
+DEFINE (Bpushcatch, 062) \
+ \
DEFINE (Bnth, 070) \
DEFINE (Bsymbolp, 071) \
DEFINE (Bconsp, 072) \
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
struct byte_stack stack;
Lisp_Object *top;
Lisp_Object result;
+ enum handlertype type;
#if 0 /* CHECK_FRAME_FONT */
{
save_restriction_save ());
NEXT;
- CASE (Bcatch): /* FIXME: ill-suited for lexbind. */
+ CASE (Bcatch): /* Obsolete since 24.4. */
{
Lisp_Object v1;
BEFORE_POTENTIAL_GC ();
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;
/* 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):
/* 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;
}
#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
/* 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
init_eval (void)
{
specpdl_ptr = specpdl;
- catchlist = 0;
- handlerlist = 0;
+ handlerlist = NULL;
Vquit_flag = Qnil;
debug_on_next_call = 0;
lisp_eval_depth = 0;
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
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;
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
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);
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))
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;
}
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;
}
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;
}
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;
}
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;
}
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;
}
&& !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);
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);
}
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;
- 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. */
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.
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.
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:
projects / emacs.git / commitdiff