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.

1 files changed, 92 insertions, 12 deletions

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