diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index 44cca6136c..7087c5799b 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -1324,7 +1324,7 @@ byte-decompile-bytecode (defun byte-decompile-bytecode-1 (bytes constvec &optional make-spliceable) (let ((length (length bytes)) (bytedecomp-ptr 0) optr tags bytedecomp-op offset - lap tmp last-constant) + lap tmp last-constant auxp) (while (not (= bytedecomp-ptr length)) (or make-spliceable (push bytedecomp-ptr lap)) @@ -1332,7 +1332,10 @@ byte-decompile-bytecode-1 optr bytedecomp-ptr ;; This uses dynamic-scope magic. offset (disassemble-offset bytes)) - (let ((opcode (aref byte-code-vector bytedecomp-op))) + (let ((opcode (if auxp + (progn (setq auxp nil) + (aref aux-byte-code-vector bytedecomp-op)) + (aref byte-code-vector bytedecomp-op)))) (cl-assert opcode) (setq bytedecomp-op opcode)) (cond ((memq bytedecomp-op byte-goto-ops) @@ -1390,7 +1393,9 @@ byte-decompile-bytecode-1 (eq (nth 2 el) orig-table)) ;; Jump tables are never reused, so do this exactly ;; once. - do (setf (nth 2 el) last-constant) and return nil)))) + do (setf (nth 2 el) last-constant) and return nil))) + ((eq bytedecomp-op 'byte-aux) + (setq auxp t))) ;; lap = ( [ (pc . (op . arg)) ]* ) (push (cons optr (cons bytedecomp-op (or offset 0))) lap) diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 8bbe6292d9..b81b138522 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -557,7 +557,13 @@ byte-code-vector (defvar byte-stack+-info nil "An array with the stack adjustment for each byte-code.") -(defmacro byte-defop (opcode stack-adjust opname &optional docstring) +(defvar aux-byte-code-vector nil + "An array containing byte-code names indexed by auxiliary byte-code values.") + +(defvar aux-byte-stack+-info nil + "An array with the stack adjustment for each auxiliary byte-code.") + +(defmacro byte--defop-internal (bcv bsi opcode stack-adjust opname &optional docstring) ;; This is a speed-hack for building the byte-code-vector at compile-time. ;; We fill in the vector at macroexpand-time, and then after the last call ;; to byte-defop, we write the vector out as a constant instead of writing @@ -565,11 +571,11 @@ byte-defop ;; Actually, we don't fill in the vector itself, because that could make ;; it problematic to compile big changes to this compiler; we store the ;; values on its plist, and remove them later in -extrude. - (let ((v1 (or (get 'byte-code-vector 'tmp-compile-time-value) - (put 'byte-code-vector 'tmp-compile-time-value + (let ((v1 (or (get bcv 'tmp-compile-time-value) + (put bcv 'tmp-compile-time-value (make-vector 256 nil)))) - (v2 (or (get 'byte-stack+-info 'tmp-compile-time-value) - (put 'byte-stack+-info 'tmp-compile-time-value + (v2 (or (get bsi 'tmp-compile-time-value) + (put bsi 'tmp-compile-time-value (make-vector 256 nil))))) (aset v1 opcode opname) (aset v2 opcode stack-adjust)) @@ -577,14 +583,36 @@ byte-defop (list 'defconst opname opcode (concat "Byte code opcode " docstring ".")) (list 'defconst opname opcode))) +(defmacro byte-defop (opcode stack-adjust opname &optional docstring) + `(byte--defop-internal byte-code-vector + byte-stack+-info + ,opcode + ,stack-adjust + ,opname + ,docstring)) + +(defmacro byte-defauxop (opcode stack-adjust opname &optional docstring) + `(byte--defop-internal aux-byte-code-vector + aux-byte-stack+-info + ,opcode + ,stack-adjust + ,opname + ,docstring)) + +(defmacro byte--extrude-byte-code-vectors-internal (bcv bsi) + (prog1 (list 'setq bcv + (get bcv 'tmp-compile-time-value) + bsi + (get bsi 'tmp-compile-time-value)) + (put bcv 'tmp-compile-time-value nil) + (put bsi 'tmp-compile-time-value nil))) + (defmacro byte-extrude-byte-code-vectors () - (prog1 (list 'setq 'byte-code-vector - (get 'byte-code-vector 'tmp-compile-time-value) - 'byte-stack+-info - (get 'byte-stack+-info 'tmp-compile-time-value)) - (put 'byte-code-vector 'tmp-compile-time-value nil) - (put 'byte-stack+-info 'tmp-compile-time-value nil))) + (byte--extrude-byte-code-vectors-internal byte-code-vector byte-stack+-info)) +(defmacro byte-extrude-aux-byte-code-vectors () + (byte--extrude-byte-code-vectors-internal aux-byte-code-vector + aux-byte-stack+-info)) ;; These opcodes are special in that they pack their argument into the ;; opcode word. @@ -770,13 +798,18 @@ byte-discardN-preserve-tos "to take a hash table and a value from the stack, and jump to the address the value maps to, if any.") -;; unused: 182-191 +;; unused: 182-190 +(byte-defop 191 0 byte-aux) ; New in 27.1 (byte-defop 192 1 byte-constant "for reference to a constant") ;; codes 193-255 are consumed by byte-constant. (defconst byte-constant-limit 64 "Exclusive maximum index usable in the `byte-constant' opcode.") +;; Auxiliary byteops + +(byte-defauxop 56 0 byte-vector-memq) + (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 @@ -786,6 +819,8 @@ byte-goto-ops (defconst byte-goto-always-pop-ops '(byte-goto-if-nil byte-goto-if-not-nil)) (byte-extrude-byte-code-vectors) +(byte-extrude-aux-byte-code-vectors) + ;;; lapcode generator ;; @@ -3449,6 +3484,7 @@ byte-defop-compiler (0-1 . byte-compile-zero-or-one-arg) (1-2 . byte-compile-one-or-two-args) (2-3 . byte-compile-two-or-three-args) + (2-aux . byte-compile-aux-two-args) ))) compile-handler (intern (concat "byte-compile-" @@ -3559,6 +3595,8 @@ byte-defop-compiler-1 (byte-defop-compiler (% byte-rem) 2) (byte-defop-compiler aset 3) +(byte-defop-compiler vector-memq 2-aux) + (byte-defop-compiler max byte-compile-associative) (byte-defop-compiler min byte-compile-associative) (byte-defop-compiler (+ byte-plus) byte-compile-associative) @@ -3587,11 +3625,13 @@ byte-compile-one-arg (byte-compile-form (car (cdr form))) ;; Push the argument (byte-compile-out (get (car form) 'byte-opcode) 0))) -(defun byte-compile-two-args (form) +(defun byte-compile-two-args (form &optional aux) (if (not (= (length form) 3)) (byte-compile-subr-wrong-args form 2) (byte-compile-form (car (cdr form))) ;; Push the arguments (byte-compile-form (nth 2 form)) + (when aux + (byte-compile-out 'byte-aux)) (byte-compile-out (get (car form) 'byte-opcode) 0))) (defun byte-compile-and-folded (form) @@ -3633,6 +3673,9 @@ byte-compile-two-or-three-args ((= len 4) (byte-compile-three-args form)) (t (byte-compile-subr-wrong-args form "2-3"))))) +(defun byte-compile-aux-two-args (form) + (byte-compile-two-args form t)) + (defun byte-compile-noop (_form) (byte-compile-constant nil)) diff --git a/src/bytecode.c b/src/bytecode.c index 40977799bf..81d1ff6a8a 100644 --- a/src/bytecode.c +++ b/src/bytecode.c @@ -270,8 +270,13 @@ DEFINE (BdiscardN, 0266) \ \ DEFINE (Bswitch, 0267) \ \ +DEFINE (Baux, 0277) \ DEFINE (Bconstant, 0300) +#define AUX_BYTE_CODES \ +DEFINE (Bvector_memq, 070) \ + + enum byte_code_op { #define DEFINE(name, value) name = value, @@ -283,6 +288,14 @@ enum byte_code_op Bset_mark = 0163, /* this loser is no longer generated as of v18 */ #endif }; + +enum aux_byte_code_op +{ +#define DEFINE(name, value) name = value, + AUX_BYTE_CODES +#undef DEFINE +}; + /* Fetch the next byte from the bytecode stream. */ @@ -429,10 +442,13 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, next instruction. It is either a computed goto, or a plain break. */ #define NEXT goto *(targets[op = FETCH]) + /* Same as NEXT, but with auxiliary operations. */ +#define NEXT_AUX goto *(aux_targets[op = FETCH]) /* FIRST is like NEXT, but is only used at the start of the interpreter body. In the switch-based interpreter it is the switch, so the threaded definition must include a semicolon. */ #define FIRST NEXT; +#define FIRST_AUX NEXT_AUX; /* Most cases are labeled with the CASE macro, above. CASE_DEFAULT is one exception; it is used if the interpreter being built requires a default case. The threaded @@ -445,7 +461,9 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, /* See above for the meaning of the various defines. */ #define CASE(OP) case OP #define NEXT break +#define NEXT_AUX NEXT #define FIRST switch (op) +#define FIRST_AUX FIRST #define CASE_DEFAULT case 255: default: #define CASE_ABORT case 0 #endif @@ -464,9 +482,15 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, #define DEFINE(name, value) LABEL (name) , BYTE_CODES -#undef DEFINE }; + /* This is the auxiliary dispatch table. */ + static const void *const aux_targets[256] = + { + [0 ... 255] = &&insn_default, + AUX_BYTE_CODES +#undef DEFINE + }; #endif @@ -1434,6 +1458,24 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, } NEXT; + CASE (Baux): + { + FIRST_AUX + { + CASE (Bvector_memq): + { + Lisp_Object v1 = POP; + TOP = Fvector_memq (TOP, v1); + NEXT; + } + CASE_DEFAULT + if (BYTE_CODE_SAFE) + emacs_abort (); + /* Not sure what to do here. */ + NEXT; + } + } + CASE_DEFAULT CASE (Bconstant): if (BYTE_CODE_SAFE diff --git a/src/fns.c b/src/fns.c index c3202495da..2349c1b169 100644 --- a/src/fns.c +++ b/src/fns.c @@ -2134,6 +2134,20 @@ merge (Lisp_Object org_l1, Lisp_Object org_l2, Lisp_Object pred) } +DEFUN ("vector-memq", Fvector_memq, Svector_memq, 2, 2, 0, + doc: /* Return index of ELT is an element of VECTOR. Comparison done with `eq'. +The value is nil if ELT is not found in VECTOR. */) + (Lisp_Object elt, Lisp_Object vector) +{ + CHECK_VECTOR (vector); + ptrdiff_t len = ASIZE (vector); + + for (ptrdiff_t i = 0; i < len; ++i) + if (EQ (elt, AREF (vector, i))) + return make_fixnum (i); + + return Qnil; +} /* This does not check for quits. That is safe since it must terminate. */ DEFUN ("plist-get", Fplist_get, Splist_get, 2, 2, 0, @@ -5417,6 +5431,7 @@ this variable. */); defsubr (&Sdelete); defsubr (&Snreverse); defsubr (&Sreverse); + defsubr (&Svector_memq); defsubr (&Ssort); defsubr (&Splist_get); defsubr (&Sget);