Help with adding new setq-based bytecodes (was: Help with adding an auxiliary bytecode table)

[Alex Gramiak <agrambot@gmail.com>]

[-- Attachment #1: Type: text/plain, Size: 2233 bytes --]

Stefan Monnier <monnier@iro.umontreal.ca> writes:

>> My initial reaction is that the stale bytecode is somehow incompatible,
>
> What/which stale bytecode?

I meant the bytecode of the previous byte compiler. It turned out not to
be the case (it was a faulty macro that caused this).

>> The problem is that since memq is a bytecode operation, it turns out
>> to be faster than vector-memq for small input
>
> Why is that a problem?

It'd be annoying (to me), since it would mean searching a small vector
of constants would be slower than searching a small list of constants.
Only by a bit, but still.

>> unless I make sure that memq isn't turned into a bytecode op.
>> So since the current space in the lookup table is limited, I figured
>> that a prefix command that looks up in a secondary table would be
>> a good solution.
>
> We don't have too many bytecodes left, indeed, but there are still some,
> IIRC, so it's not indispensable to go a 2-byte bytecodes.

No, but at least for vector-memq, I don't think it warrants taking up
that limited room. Also, I figured that there might be other primitives
that weren't added as a bytecode previously due to the lack of space
that could now be added to this secondary table. Possible candidates:

- append
- assoc
- string-match/match-string
- re-search-forward
- looking-at
- make-byte-code
- fboundp, functionp
- vector/vectorp
- apply
- gethash/puthash


Now I'm having a problem with adding certain bytecodes that (attempt to)
optimize these forms (since they're common in loops):

  (setq X (P X))
  (setq X (cons Y X))

But now when trying to build with the attached patch I get this error:

  make[2]: Entering directory '/home/alex/emacs-test/lisp'
    ELC      ../lisp/emacs-lisp/byte-run.elc

  emacs-lisp/byte-run.el:230:1:Error: Symbol’s value as variable is void: lambda


Is there a way to trigger the lisp debugger here? Calling (debug) before
the error line didn't help, nor did setting debug-on-error non-nil.

Do you have any idea what I did wrong? Making the optimization checks in
byte-compile-setq always fail allows me to build, and I've verified that
the checks don't pass false positives.


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: WIP --]
[-- Type: text/x-patch, Size: 18844 bytes --]

From a49cbc7052bf8a1d1ac38d898b2f554ddadbd9b9 Mon Sep 17 00:00:00 2001
From: Alexander Gramiak <agrambot@gmail.com>
Date: Sun, 21 Apr 2019 13:11:57 -0600
Subject: [PATCH] Auxiliary bytecode table WIP

---
 lisp/emacs-lisp/byte-opt.el |  11 ++-
 lisp/emacs-lisp/bytecomp.el | 153 +++++++++++++++++++++++++++---------
 src/bytecode.c              |  80 ++++++++++++++++++-
 src/fns.c                   |  15 ++++
 4 files changed, 220 insertions(+), 39 deletions(-)

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 4c61e1a447..89870bf041 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,29 @@ byte-defop
       (list 'defconst opname opcode (concat "Byte code opcode " docstring "."))
       (list 'defconst opname opcode)))
 
-(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)))
-
+(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 (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)))
 
 ;; These opcodes are special in that they pack their argument into the
 ;; opcode word.
@@ -770,13 +791,21 @@ 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 10 -1 byte-push)
+(byte-defauxop 11  0 byte-setq-cdr)
+(byte-defauxop 12  0 byte-setq-1+)
+(byte-defauxop 13  0 byte-setq-1-)
+(byte-defauxop 56 -1 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
@@ -785,7 +814,9 @@ 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-byte-code-vectors byte-code-vector byte-stack+-info)
+(byte--extrude-byte-code-vectors aux-byte-code-vector aux-byte-stack+-info)
+
 \f
 ;;; lapcode generator
 ;;
@@ -3373,21 +3404,29 @@ byte-compile-variable-ref
 	(push var byte-compile-free-references))
       (byte-compile-dynamic-variable-op 'byte-varref var))))
 
-(defun byte-compile-variable-set (var)
-  "Generate code to set the variable VAR from the top-of-stack value."
+(defun byte-compile--handle-free-assignment (var)
+  (unless (or (not (byte-compile-warning-enabled-p 'free-vars))
+	      (boundp var)
+	      (memq var byte-compile-bound-variables)
+	      (memq var byte-compile-free-assignments))
+    (byte-compile-warn "assignment to free variable `%s'" var)
+    (push var byte-compile-free-assignments)))
+
+(defun byte-compile-variable-set (var lex-binding custom-op)
+  "Generate code to set the variable VAR from the top-of-stack value.
+If CUSTOM-OP and LEX-BINDING are non-nil, use CUSTOM-OP instead
+of `byte-stack-set'."
   (byte-compile-check-variable var 'assign)
-  (let ((lex-binding (assq var byte-compile--lexical-environment)))
-    (if lex-binding
-	;; VAR is lexically bound.
-        (byte-compile-stack-set (cdr lex-binding))
-      ;; VAR is dynamically bound.
-      (unless (or (not (byte-compile-warning-enabled-p 'free-vars))
-		  (boundp var)
-		  (memq var byte-compile-bound-variables)
-		  (memq var byte-compile-free-assignments))
-	(byte-compile-warn "assignment to free variable `%s'" var)
-	(push var byte-compile-free-assignments))
-      (byte-compile-dynamic-variable-op 'byte-varset var))))
+  (if lex-binding
+      ;; VAR is lexically bound.
+      (if (not custom-op)
+          (byte-compile-stack-set (cdr lex-binding))
+        (byte-compile-out custom-op
+                          (- byte-compile-depth (1+ (cdr lex-binding)))
+                          t))
+    ;; VAR is dynamically bound.
+    (byte-compile--handle-free-assignment var)
+    (byte-compile-dynamic-variable-op 'byte-varset var)))
 
 (defmacro byte-compile-get-constant (const)
   `(or (if (stringp ,const)
@@ -3444,6 +3483,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-"
@@ -3554,6 +3594,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)
@@ -3582,11 +3624,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)
@@ -3628,6 +3672,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))
 
@@ -3908,7 +3955,10 @@ byte-compile-insert
 
 (defun byte-compile-setq (form)
   (let* ((args (cdr form))
-         (len (length args)))
+         (len (length args))
+         var
+         lex-binding
+         custom-op)
     (if (= (logand len 1) 1)
         (progn
           (byte-compile-report-error
@@ -3919,10 +3969,34 @@ byte-compile-setq
            byte-compile--for-effect))
       (if args
           (while args
-            (byte-compile-form (car (cdr args)))
+            (setq var (car args))
+            (setq lex-binding (assq var byte-compile--lexical-environment))
+            ;; Optimize some forms of (setq x (P ... x ...))
+            (if (and byte-optimize
+                     lex-binding
+                     (consp (cadr args)))
+                (cond ((and (eq var
+                                (cadadr args))
+                            ;; (setq x (P x))
+                            (memq (caadr args) '(cdr 1+ 1-))
+                            (eql (length (cadr args)) 2))
+                       (cl-case (caadr args)
+                         (1+   (setq custom-op 'byte-setq-1+))
+                         (1-   (setq custom-op 'byte-setq-1-))
+                         (cdr  (setq custom-op 'byte-setq-cdr))))
+                      ((and (eq var
+                                (car (cddadr args)))
+                            (eq (caadr args) 'cons))
+                       ;; (setq x (cons y x))
+                       (byte-compile-form (cadadr args))
+                       (setq custom-op 'byte-push))
+                      (t
+                       (byte-compile-form (car (cdr args)))))
+              (byte-compile-form (car (cdr args))))
             (or byte-compile--for-effect (cdr (cdr args))
                 (byte-compile-out 'byte-dup 0))
-            (byte-compile-variable-set (car args))
+            (byte-compile-variable-set var lex-binding (prog1 custom-op
+                                                         (setq custom-op nil)))
             (setq args (cdr (cdr args))))
         ;; (setq), with no arguments.
         (byte-compile-form nil byte-compile--for-effect)))
@@ -4841,14 +4915,23 @@ byte-compile-stack-adjustment
 	;; a total of 1 - OPERAND
 	(- 1 operand))))
 
-(defun byte-compile-out (op &optional operand)
+(defun byte-compile-aux-stack-adjustment (op operand)
+  "Return the amount by which an auxiliary operation adjusts the stack.
+OP and OPERAND are as passed to `byte-compile-out'."
+  (or (aref aux-byte-stack+-info (symbol-value op))
+      (- 1 operand)))
+
+(defun byte-compile-out (op &optional operand aux)
   (push (cons op operand) byte-compile-output)
   (if (eq op 'byte-return)
       ;; This is actually an unnecessary case, because there should be no
       ;; more ops behind byte-return.
       (setq byte-compile-depth nil)
     (setq byte-compile-depth
-	  (+ byte-compile-depth (byte-compile-stack-adjustment op operand)))
+	  (+ byte-compile-depth
+             (if (not aux)
+                 (byte-compile-stack-adjustment op operand)
+               (byte-compile-aux-stack-adjustment op operand))))
     (setq byte-compile-maxdepth (max byte-compile-depth byte-compile-maxdepth))
     ;;(if (< byte-compile-depth 0) (error "Compiler error: stack underflow"))
     ))
diff --git a/src/bytecode.c b/src/bytecode.c
index 40977799bf..5f57d8f278 100644
--- a/src/bytecode.c
+++ b/src/bytecode.c
@@ -270,8 +270,17 @@ DEFINE (BdiscardN,   0266)						\
 									\
 DEFINE (Bswitch, 0267)                                                  \
                                                                         \
+DEFINE (Baux, 0277)                                                     \
 DEFINE (Bconstant, 0300)
 
+#define AUX_BYTE_CODES                                                  \
+DEFINE (Bpush, 012)                                                     \
+DEFINE (Bsetq_cdr, 013)                                                 \
+DEFINE (Bsetq_add1, 014)                                                \
+DEFINE (Bsetq_sub1, 015)                                                \
+DEFINE (Bvector_memq, 070)                                              \
+
+
 enum byte_code_op
 {
 #define DEFINE(name, value) name = value,
@@ -283,6 +292,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
+};
+
 \f
 /* Fetch the next byte from the bytecode stream.  */
 
@@ -429,10 +446,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 +465,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 +486,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 +1462,56 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth,
           }
           NEXT;
 
+        CASE (Baux):
+          {
+            FIRST_AUX
+              {
+              CASE (Bpush):
+                {
+                  Lisp_Object *ptr = top - FETCH;
+                  *ptr = Fcons (POP, *ptr);
+                  NEXT;
+                }
+                CASE (Bsetq_cdr):
+                {
+                  Lisp_Object *ptr = top - FETCH;
+                  if (CONSP (*ptr))
+                    *ptr = XCDR (*ptr);
+                  else if (!NILP (*ptr))
+                    wrong_type_argument (Qlistp, *ptr);
+                  NEXT;
+                }
+                CASE (Bsetq_add1):
+                {
+                  Lisp_Object *ptr = top - FETCH;
+                  *ptr = (FIXNUMP (*ptr) && XFIXNUM (*ptr) != MOST_POSITIVE_FIXNUM
+                          ? make_fixnum (XFIXNUM (*ptr) + 1)
+                          : Fadd1 (*ptr));
+                  NEXT;
+                }
+                CASE (Bsetq_sub1):
+                {
+                  Lisp_Object *ptr = top - FETCH;
+                  *ptr = (FIXNUMP (*ptr) && XFIXNUM (*ptr) != MOST_NEGATIVE_FIXNUM
+                          ? make_fixnum (XFIXNUM (*ptr) - 1)
+                          : Fsub1 (*ptr));
+                  NEXT;
+                }
+              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;
+              }
+            NEXT;
+          }
+
 	CASE_DEFAULT
 	CASE (Bconstant):
 	  if (BYTE_CODE_SAFE
diff --git a/src/fns.c b/src/fns.c
index c3202495da..a82bd61ef5 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)
 }
 
 \f
+DEFUN ("vector-memq", Fvector_memq, Svector_memq, 2, 2, 0,
+       doc: /* Return index of ELT in 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);
-- 
2.21.0