* Help with adding new setq-based bytecodes (was: Help with adding an auxiliary bytecode table)
2019-04-21 4:11 ` Stefan Monnier
@ 2019-04-21 19:17 ` Alex Gramiak
2019-04-21 20:22 ` Help with adding new setq-based bytecodes Stefan Monnier
0 siblings, 1 reply; 6+ messages in thread
From: Alex Gramiak @ 2019-04-21 19:17 UTC (permalink / raw)
To: Stefan Monnier; +Cc: emacs-devel
[-- 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
^ permalink raw reply related [flat|nested] 6+ messages in thread