(<= 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)
(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)
(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))
(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
(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.
;; 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,
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)))
(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))
DEFINE (Bpophandler, 060) \
DEFINE (Bpushconditioncase, 061) \
DEFINE (Bpushcatch, 062) \
+DEFINE (Bpushunwindprotect, 063) \
+DEFINE (Bendunwindprotect, 064) \
\
DEFINE (Bnth, 070) \
DEFINE (Bsymbolp, 071) \
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;
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. */
--- /dev/null
+;;; 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