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 @@ ...@@ -1324,7 +1324,8 @@
(<= bytedecomp-op byte-goto-if-not-nil-else-pop)) (<= bytedecomp-op byte-goto-if-not-nil-else-pop))
(memq bytedecomp-op (eval-when-compile (memq bytedecomp-op (eval-when-compile
(list byte-stack-set2 byte-pushcatch (list byte-stack-set2 byte-pushcatch
byte-pushconditioncase)))) byte-pushconditioncase
byte-pushunwindprotect))))
;; Offset in next 2 bytes. ;; Offset in next 2 bytes.
(setq bytedecomp-ptr (1+ bytedecomp-ptr)) (setq bytedecomp-ptr (1+ bytedecomp-ptr))
(+ (aref bytes bytedecomp-ptr) (+ (aref bytes bytedecomp-ptr)
......
...@@ -603,8 +603,12 @@ Each element is (INDEX . VALUE)") ...@@ -603,8 +603,12 @@ Each element is (INDEX . VALUE)")
(byte-defop 48 0 byte-pophandler) (byte-defop 48 0 byte-pophandler)
(byte-defop 50 -1 byte-pushcatch) (byte-defop 50 -1 byte-pushcatch)
(byte-defop 49 -1 byte-pushconditioncase) (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 56 -1 byte-nth)
(byte-defop 57 0 byte-symbolp) (byte-defop 57 0 byte-symbolp)
...@@ -781,7 +785,8 @@ the value maps to, if any.") ...@@ -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 (defconst byte-goto-ops '(byte-goto byte-goto-if-nil byte-goto-if-not-nil
byte-goto-if-nil-else-pop byte-goto-if-nil-else-pop
byte-goto-if-not-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.") "List of byte-codes whose offset is a pc.")
(defconst byte-goto-always-pop-ops '(byte-goto-if-nil byte-goto-if-not-nil)) (defconst byte-goto-always-pop-ops '(byte-goto-if-nil byte-goto-if-not-nil))
...@@ -4459,18 +4464,33 @@ binding slots have been popped." ...@@ -4459,18 +4464,33 @@ binding slots have been popped."
(byte-compile-out 'byte-catch 0))) (byte-compile-out 'byte-catch 0)))
(defun byte-compile-unwind-protect (form) (defun byte-compile-unwind-protect (form)
(pcase (cddr form) (if (not byte-compile--use-old-handlers)
(`(:fun-body ,f) (let ((except-tag (byte-compile-make-tag)))
(byte-compile-form ;; If the goto is called, we'll have 2 extra items on the
(if byte-compile--use-old-handlers `(list (list 'funcall ,f)) f))) ;; stack.
(handlers (byte-compile-goto 'byte-pushunwindprotect except-tag)
(if byte-compile--use-old-handlers (byte-compile-form (cadr form) nil)
(byte-compile-push-constant (byte-compile-out 'byte-pophandler)
(byte-compile-top-level-body handlers t)) ;; The value of the body is on the stack; now push a flag so
(byte-compile-form `#'(lambda () ,@handlers))))) ;; that the coming endunwindprotect instruction knows what to
(byte-compile-out 'byte-unwind-protect 0) ;; do.
(byte-compile-form-do-effect (car (cdr form))) (byte-compile-push-constant nil)
(byte-compile-out 'byte-unbind 1)) ;; 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) (defun byte-compile-condition-case (form)
(if byte-compile--use-old-handlers (if byte-compile--use-old-handlers
...@@ -4810,11 +4830,19 @@ binding slots have been popped." ...@@ -4810,11 +4830,19 @@ binding slots have been popped."
(defun byte-compile-goto (opcode tag) (defun byte-compile-goto (opcode tag)
(push (cons opcode tag) byte-compile-output) (push (cons opcode tag) byte-compile-output)
(setcdr (cdr tag) (if (memq opcode byte-goto-always-pop-ops) (setcdr (cdr tag)
(1- byte-compile-depth) (cond
byte-compile-depth)) ((memq opcode byte-goto-always-pop-ops)
(setq byte-compile-depth (and (not (eq opcode 'byte-goto)) (1- byte-compile-depth))
(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) (defun byte-compile-stack-adjustment (op operand)
"Return the amount by which an operation adjusts the stack. "Return the amount by which an operation adjusts the stack.
......
...@@ -87,7 +87,6 @@ ...@@ -87,7 +87,6 @@
;; command-history). ;; command-history).
;; - canonize code in macro-expand so we don't have to handle (let (var) body) ;; - canonize code in macro-expand so we don't have to handle (let (var) body)
;; and other oddities. ;; 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 ;; - 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. ;; 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, ;; Hmm... right, that's called constant propagation and could be done here,
...@@ -487,7 +486,8 @@ places where they originally did not directly appear." ...@@ -487,7 +486,8 @@ places where they originally did not directly appear."
handlers)))) handlers))))
(`(,(and head (or (and `catch (guard byte-compile--use-old-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) ,form . ,body)
`(,head ,(cconv-convert form env extend) `(,head ,(cconv-convert form env extend)
:fun-body ,(cconv--convert-function () body env form))) :fun-body ,(cconv--convert-function () body env form)))
...@@ -728,9 +728,8 @@ and updates the data stored in ENV." ...@@ -728,9 +728,8 @@ and updates the data stored in ENV."
(if var (cconv--analyze-use (cons (list var) (cdr varstruct)) (if var (cconv--analyze-use (cons (list var) (cdr varstruct))
form "variable")))) form "variable"))))
;; FIXME: The bytecode for unwind-protect forces us to wrap the unwind.
(`(,(or (and `catch (guard byte-compile--use-old-handlers)) (`(,(or (and `catch (guard byte-compile--use-old-handlers))
`unwind-protect) (and `unwind-protect (guard byte-compile--use-old-handlers)))
,form . ,body) ,form . ,body)
(cconv-analyze-form form env) (cconv-analyze-form form env)
(cconv--analyze-function () body env form)) (cconv--analyze-function () body env form))
......
...@@ -132,6 +132,8 @@ DEFINE (Bunbind7, 057) \ ...@@ -132,6 +132,8 @@ DEFINE (Bunbind7, 057) \
DEFINE (Bpophandler, 060) \ DEFINE (Bpophandler, 060) \
DEFINE (Bpushconditioncase, 061) \ DEFINE (Bpushconditioncase, 061) \
DEFINE (Bpushcatch, 062) \ DEFINE (Bpushcatch, 062) \
DEFINE (Bpushunwindprotect, 063) \
DEFINE (Bendunwindprotect, 064) \
\ \
DEFINE (Bnth, 070) \ DEFINE (Bnth, 070) \
DEFINE (Bsymbolp, 071) \ DEFINE (Bsymbolp, 071) \
...@@ -770,6 +772,45 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, ...@@ -770,6 +772,45 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth,
NEXT; 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. */ CASE (Bpushcatch): /* New in 24.4. */
type = CATCHER; type = CATCHER;
goto pushhandler; goto pushhandler;
...@@ -798,7 +839,7 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, ...@@ -798,7 +839,7 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth,
handlerlist = handlerlist->next; handlerlist = handlerlist->next;
NEXT; NEXT;
CASE (Bunwind_protect): /* FIXME: avoid closure for lexbind. */ CASE (Bunwind_protect): /* Obsolete since 27.1. */
{ {
Lisp_Object handler = POP; Lisp_Object handler = POP;
/* Support for a function here is new in 24.4. */ /* 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