Add new bytecodes for unwind-protectfeature/byte-unwind-protect

* lisp/emacs-lisp/byte-opt.el (disassemble-offset): Handle
byte-pushunwindprotect.
* lisp/emacs-lisp/bytecomp.el (byte-pushunwindprotect)
(byte-endunwindprotect): New bytecodes.
(byte-goto-ops): Add byte-pushunwindprotect.
(byte-compile-unwind-protect): Emit new bytecodes.
(byte-compile-goto): Handle byte-pushunwindprotect.
* lisp/emacs-lisp/cconv.el (cconv-convert): Don't special-case
unwind-protect when byte-compile--use-old-handlers.
(cconv-analyze-form): Likewise.
* src/bytecode.c (Bpushunwindprotect, Bendunwindprotect): New bytecodes.
(exec_byte_code): Implement new bytecodes.
* test/src/bytecode-tests.el: New file.

5 files changed, 152 insertions, 25 deletions

diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el
index e5e5f4ee590..5292deda6ea 100644
--- a/lisp/emacs-lisp/byte-opt.el
+++ b/lisp/emacs-lisp/byte-opt.el
@@ -1324,7 +1324,8 @@
                   (<= bytedecomp-op byte-goto-if-not-nil-else-pop))
              (memq bytedecomp-op (eval-when-compile
                                    (list byte-stack-set2 byte-pushcatch
-                                         byte-pushconditioncase))))
+                                         byte-pushconditioncase
+                                         byte-pushunwindprotect))))
 	 ;; 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 a64c88c4f0d..5e04a620f33 100644
--- a/lisp/emacs-lisp/bytecomp.el
+++ b/lisp/emacs-lisp/bytecomp.el
@@ -603,8 +603,12 @@ Each element is (INDEX . VALUE)")
 (byte-defop  48  0 byte-pophandler)
 (byte-defop  50 -1 byte-pushcatch)
 (byte-defop  49 -1 byte-pushconditioncase)
+;; New (in Emacs 27.1) bytecode for efficient handling of
+;; unwind-protect.
+(byte-defop  51  0 byte-pushunwindprotect)
+(byte-defop  52 -1 byte-endunwindprotect)
 
-;; unused: 51-55
+;; unused: 53-55
 
 (byte-defop  56 -1 byte-nth)
 (byte-defop  57  0 byte-symbolp)
@@ -781,7 +785,8 @@ the value maps to, if any.")
 (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-pushcatch byte-pushconditioncase)
+                          byte-pushcatch byte-pushconditioncase
+                          byte-pushunwindprotect)
   "List of byte-codes whose offset is a pc.")
 
 (defconst byte-goto-always-pop-ops '(byte-goto-if-nil byte-goto-if-not-nil))
@@ -4459,18 +4464,33 @@ binding slots have been popped."
     (byte-compile-out 'byte-catch 0)))
 
 (defun byte-compile-unwind-protect (form)
-  (pcase (cddr form)
-    (`(:fun-body ,f)
-     (byte-compile-form
-      (if byte-compile--use-old-handlers `(list (list 'funcall ,f)) f)))
-    (handlers
-     (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))
+  (if (not byte-compile--use-old-handlers)
+      (let ((except-tag (byte-compile-make-tag)))
+        ;; If the goto is called, we'll have 2 extra items on the
+        ;; stack.
+        (byte-compile-goto 'byte-pushunwindprotect except-tag)
+        (byte-compile-form (cadr form) nil)
+        (byte-compile-out 'byte-pophandler)
+        ;; The value of the body is on the stack; now push a flag so
+        ;; that the coming endunwindprotect instruction knows what to
+        ;; do.
+        (byte-compile-push-constant nil)
+        ;; The unwind forms.
+        (byte-compile-out-tag except-tag)
+        (byte-compile-body (cddr form) t)
+        (byte-compile-out 'byte-endunwindprotect))
+    (pcase (cddr form)
+      (`(:fun-body ,f)
+       (byte-compile-form
+        (if byte-compile--use-old-handlers `(list (list 'funcall ,f)) f)))
+      (handlers
+       (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)))
 
 (defun byte-compile-condition-case (form)
   (if byte-compile--use-old-handlers
@@ -4810,11 +4830,19 @@ binding slots have been popped."
 
 (defun byte-compile-goto (opcode tag)
   (push (cons opcode tag) byte-compile-output)
-  (setcdr (cdr tag) (if (memq opcode byte-goto-always-pop-ops)
-			(1- byte-compile-depth)
-		      byte-compile-depth))
-  (setq byte-compile-depth (and (not (eq opcode 'byte-goto))
-				(1- byte-compile-depth))))
+  (setcdr (cdr tag)
+          (cond
+           ((memq opcode byte-goto-always-pop-ops)
+            (1- byte-compile-depth))
+           ((eq opcode 'byte-pushunwindprotect)
+            (+ 2 byte-compile-depth))
+           (t byte-compile-depth)))
+  (setq byte-compile-depth
+        (cond
+         ((eq opcode 'byte-goto) nil)
+         ((eq opcode 'byte-pushunwindprotect)
+          byte-compile-depth)
+	 (t (1- byte-compile-depth)))))
 
 (defun byte-compile-stack-adjustment (op operand)
   "Return the amount by which an operation adjusts the stack.
diff --git a/lisp/emacs-lisp/cconv.el b/lisp/emacs-lisp/cconv.el
index 02fe794467b..925292483fd 100644
--- a/lisp/emacs-lisp/cconv.el
+++ b/lisp/emacs-lisp/cconv.el
@@ -87,7 +87,6 @@
 ;;   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 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,
@@ -487,7 +486,8 @@ places where they originally did not directly appear."
              handlers))))
 
     (`(,(and head (or (and `catch (guard byte-compile--use-old-handlers))
-                      `unwind-protect))
+                      (and `unwind-protect
+                           (guard byte-compile--use-old-handlers))))
        ,form . ,body)
      `(,head ,(cconv-convert form env extend)
         :fun-body ,(cconv--convert-function () body env form)))
@@ -728,9 +728,8 @@ and updates the data stored in ENV."
        (if var (cconv--analyze-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)
+            (and `unwind-protect (guard byte-compile--use-old-handlers)))
        ,form . ,body)
      (cconv-analyze-form form env)
      (cconv--analyze-function () body env form))
diff --git a/src/bytecode.c b/src/bytecode.c
index 55b193ffb2f..62ba2ca69d0 100644
--- a/src/bytecode.c
+++ b/src/bytecode.c
@@ -132,6 +132,8 @@ DEFINE (Bunbind7, 057)							\
 DEFINE (Bpophandler, 060)						\
 DEFINE (Bpushconditioncase, 061)					\
 DEFINE (Bpushcatch, 062)						\
+DEFINE (Bpushunwindprotect, 063)					\
+DEFINE (Bendunwindprotect, 064)						\
 									\
 DEFINE (Bnth, 070)							\
 DEFINE (Bsymbolp, 071)							\
@@ -770,6 +772,45 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth,
 	    NEXT;
 	  }
 
+	CASE (Bpushunwindprotect): /* New in 27.1.  */
+	  {
+	    struct handler *c = push_handler (Qt, CATCHER_ALL);
+	    c->bytecode_dest = FETCH2;
+	    c->bytecode_top = top;
+
+	    if (sys_setjmp (c->jmp))
+	      {
+		struct handler *c = handlerlist;
+		top = c->bytecode_top;
+		op = c->bytecode_dest;
+		handlerlist = c->next;
+		/* Push the exception value, plus a flag indicating
+		   that re-throwing is necessary.  This will be used
+		   by Bendunwindprotect.  */
+		PUSH (c->val);
+		PUSH (Qt);
+		goto op_branch;
+	      }
+
+	    NEXT;
+	  }
+	CASE (Bendunwindprotect): /* New in 27.1.  */
+	  {
+	    Lisp_Object flag = POP;
+
+	    if (!NILP (flag))
+	      {
+		Lisp_Object err = POP;
+
+		if (EQ (XCAR (err), Qsignal))
+		  Fsignal (XCAR (XCDR (err)), XCDR (XCDR (err)));
+		else
+		  Fthrow (XCAR (XCDR (err)), XCDR (XCDR (err)));
+	      }
+
+	    NEXT;
+	  }
+
 	CASE (Bpushcatch):	/* New in 24.4.  */
 	  type = CATCHER;
 	  goto pushhandler;
@@ -798,7 +839,7 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth,
 	  handlerlist = handlerlist->next;
 	  NEXT;
 
-	CASE (Bunwind_protect):	/* FIXME: avoid closure for lexbind.  */
+	CASE (Bunwind_protect):	/* Obsolete since 27.1.  */
 	  {
 	    Lisp_Object handler = POP;
 	    /* Support for a function here is new in 24.4.  */
diff --git a/test/src/bytecode-tests.el b/test/src/bytecode-tests.el
new file mode 100644
index 00000000000..51cbfe7576c
--- /dev/null
+++ b/test/src/bytecode-tests.el
@@ -0,0 +1,58 @@
+;;; bytecode-tests.el --- unit tests for src/bytecode.c      -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2018 Free Software Foundation, Inc.
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs.  If not, see <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Unit tests for src/bytecode.c.
+
+;;; Code:
+
+(require 'ert)
+
+(defun bctest-throw-something ()
+  (throw 'something 23))
+
+(defun bctest-signal ()
+  (signal 'error 23))
+
+(ert-deftest bctest-unwind-protect-signal ()
+  (let ((val nil))
+    (should-error (unwind-protect
+                      (bctest-signal)
+                    (setq val t)))
+    (should val)))
+
+(ert-deftest bctest-unwind-protect-throw ()
+  (let ((val nil))
+    (should (eq (catch 'something
+                  (unwind-protect
+                      (bctest-throw-something)
+                    (setq val t))
+                  'fail)
+                23))
+    (should val)))
+
+(ert-deftest bctest-unwind-protect-fallthrough ()
+  (let ((val nil))
+    (unwind-protect
+        (setq val 'x)
+      (setq val t))
+    (should val)))
+
+;;; bytecode-tests.el ends here