procyberian/emacs
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Introduce new bytecodes for efficient catch/condition-case in lexbind.

Browse source 
* 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.
This commit is contained in:
Stefan Monnier 2013-10-03 00:58:56 -04:00
parent 328a8179fe
commit adf2aa6140
9 changed files with 475 additions and 306 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

24
lisp/ChangeLog
View file

@ -1,3 +1,27 @@
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'.

32
lisp/emacs-lisp/byte-opt.el
View file

@ -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)

104
lisp/emacs-lisp/bytecomp.el
View file

@ -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))))

63
lisp/emacs-lisp/cconv.el
View file

@ -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))

30
src/ChangeLog
View file

@ -1,3 +1,33 @@
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

24
src/alloc.c
View file

@ -5370,23 +5370,15 @@ See Info node `(elisp)Garbage Collection'. */)
mark_object (tail->var[i]);
}
mark_byte_stack ();
{
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);
}
}
#endif
{
struct handler *handler;
for (handler = handlerlist; handler; handler = handler->next)
{
mark_object (handler->tag_or_ch);
mark_object (handler->val);
}
}
#ifdef HAVE_WINDOW_SYSTEM
mark_fringe_data ();
#endif

81
src/bytecode.c
View file

@ -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 (Bunwind_protect): /* FIXME: avoid closure for lexbind. */
record_unwind_protect (unwind_body, POP);
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;
CASE (Bcondition_case): /* FIXME: ill-suited for lexbind. */
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. */
{
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): /* 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;
}

312
src/eval.c
View file

@ -32,20 +32,8 @@ along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
#include "xterm.h"
#endif
#if !BYTE_MARK_STACK
static
#endif
struct catchtag *catchlist;
/* Chain of condition and catch handlers currently in effect. */
/* 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. */
#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;
struct handler *c;
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))
PUSH_HANDLER (c, handlers, CONDITION_CASE);
if (sys_setjmp (c->jmp))
{
return (*hfun) (c.val);
Lisp_Object val = handlerlist->val;
eassert (handlerlist == c);
handlerlist = handlerlist->next;
return (*hfun) (val);
}
c.next = catchlist;
catchlist = &c;
h.handler = handlers;
h.var = Qnil;
h.next = handlerlist;
h.tag = &c;
handlerlist = &h;
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;
struct handler *c;
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))
PUSH_HANDLER (c, handlers, CONDITION_CASE);
if (sys_setjmp (c->jmp))
{
return (*hfun) (c.val);
Lisp_Object val = handlerlist->val;
eassert (handlerlist == c);
handlerlist = handlerlist->next;
return (*hfun) (val);
}
c.next = catchlist;
catchlist = &c;
h.handler = handlers;
h.var = Qnil;
h.next = handlerlist;
h.tag = &c;
handlerlist = &h;
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;
struct handler *c;
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))
PUSH_HANDLER (c, handlers, CONDITION_CASE);
if (sys_setjmp (c->jmp))
{
return (*hfun) (c.val);
Lisp_Object val = handlerlist->val;
eassert (handlerlist == c);
handlerlist = handlerlist->next;
return (*hfun) (val);
}
c.next = catchlist;
catchlist = &c;
h.handler = handlers;
h.var = Qnil;
h.next = handlerlist;
h.tag = &c;
handlerlist = &h;
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;
struct handler *c;
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))
PUSH_HANDLER (c, handlers, CONDITION_CASE);
if (sys_setjmp (c->jmp))
{
return (*hfun) (c.val, nargs, args);
Lisp_Object val = handlerlist->val;
eassert (handlerlist == c);
handlerlist = handlerlist->next;
return (*hfun) (val, nargs, args);
}
c.next = catchlist;
catchlist = &c;
h.handler = handlers;
h.var = Qnil;
h.next = handlerlist;
h.tag = &c;
handlerlist = &h;
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;

111
src/lisp.h
View file

@ -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;
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).
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;
};
/* 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: