Commit 916094a8 authored by Tom Tromey's avatar Tom Tromey

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.
parent a6b4b9b4
Pipeline #3 failed with stage
......@@ -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)
......
......@@ -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.
......
......@@ -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))
......
......@@ -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. */
......
;;; 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
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment