[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Emacs-diffs] feature/byte-unwind-protect 916094a 2/2: Add new bytecodes
|
From: |
Tom Tromey |
|
Subject: |
[Emacs-diffs] feature/byte-unwind-protect 916094a 2/2: Add new bytecodes for unwind-protect |
|
Date: |
Tue, 23 Jan 2018 00:12:32 -0500 (EST) |
branch: feature/byte-unwind-protect
commit 916094a84f0ab31be31aa6c3632f14176b4e882a
Author: Tom Tromey <address@hidden>
Commit: Tom Tromey <address@hidden>
Add new bytecodes for 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.
---
lisp/emacs-lisp/byte-opt.el | 3 ++-
lisp/emacs-lisp/bytecomp.el | 66 ++++++++++++++++++++++++++++++++-------------
lisp/emacs-lisp/cconv.el | 7 +++--
src/bytecode.c | 43 ++++++++++++++++++++++++++++-
test/src/bytecode-tests.el | 58 +++++++++++++++++++++++++++++++++++++++
5 files changed, 152 insertions(+), 25 deletions(-)
diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el
index e5e5f4e..5292ded 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 a64c88c..5e04a62 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 02fe794..9252924 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 55b193f..62ba2ca 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 0000000..51cbfe7
--- /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