summaryrefslogtreecommitdiff
path: root/lisp
diff options
context:
space:
mode:
Diffstat (limited to 'lisp')
-rw-r--r--lisp/emacs-lisp/byte-opt.el40
-rw-r--r--lisp/emacs-lisp/bytecomp.el199
-rw-r--r--lisp/emacs-lisp/disass.el18
3 files changed, 213 insertions, 44 deletions
diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el
index 13f885448ae..b775976efb2 100644
--- a/lisp/emacs-lisp/byte-opt.el
+++ b/lisp/emacs-lisp/byte-opt.el
@@ -185,6 +185,7 @@
(require 'bytecomp)
(eval-when-compile (require 'cl-lib))
(require 'macroexp)
+(require 'subr-x)
(defun byte-compile-log-lap-1 (format &rest args)
;; Newer byte codes for stack-ref make the slot 0 non-nil again.
@@ -1356,7 +1357,7 @@
(defun byte-decompile-bytecode-1 (bytes constvec &optional make-spliceable)
(let ((length (length bytes))
(bytedecomp-ptr 0) optr tags bytedecomp-op offset
- lap tmp)
+ lap tmp last-constant)
(while (not (= bytedecomp-ptr length))
(or make-spliceable
(push bytedecomp-ptr lap))
@@ -1385,7 +1386,8 @@
(or (assq tmp byte-compile-variables)
(let ((new (list tmp)))
(push new byte-compile-variables)
- new)))))
+ new)))
+ last-constant tmp))
((eq bytedecomp-op 'byte-stack-set2)
(setq bytedecomp-op 'byte-stack-set))
((and (eq bytedecomp-op 'byte-discardN) (>= offset #x80))
@@ -1394,7 +1396,27 @@
;; lapcode, we represent this by using a different opcode
;; (with the flag removed from the operand).
(setq bytedecomp-op 'byte-discardN-preserve-tos)
- (setq offset (- offset #x80))))
+ (setq offset (- offset #x80)))
+ ((eq bytedecomp-op 'byte-switch)
+ (cl-assert (hash-table-p last-constant) nil
+ "byte-switch used without preceeding hash table")
+ ;; make a copy of constvec to avoid making changes to the
+ ;; original jump table for the compiled function.
+ (setq constvec (cl-map 'vector
+ #'(lambda (e)
+ (if (eq last-constant e)
+ (setq last-constant (copy-hash-table e))
+ e))
+ constvec))
+ (maphash #'(lambda (value tag)
+ (let (newtag)
+ (cl-assert (consp tag)
+ nil "Invalid address for byte-switch")
+ (setq newtag (byte-compile-make-tag))
+ (push (cons (+ (car tag) (lsh (cdr tag) 8)) newtag) tags)
+ (puthash value newtag last-constant)))
+ last-constant)
+ (setf (nth 2 (cadr lap)) last-constant)))
;; lap = ( [ (pc . (op . arg)) ]* )
(push (cons optr (cons bytedecomp-op (or offset 0)))
lap)
@@ -1728,7 +1750,10 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
;; unused-TAG: --> <deleted>
;;
((and (eq 'TAG (car lap0))
- (not (rassq lap0 lap)))
+ (not (rassq lap0 lap))
+ (cl-loop for table in byte-compile-jump-tables
+ when (member lap0 (hash-table-values table))
+ return nil finally return t))
(and (memq byte-optimize-log '(t byte))
(byte-compile-log " unused tag %d removed" (nth 1 lap0)))
(setq lap (delq lap0 lap)
@@ -1736,9 +1761,12 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
;;
;; goto ... --> goto <delete until TAG or end>
;; return ... --> return <delete until TAG or end>
- ;;
+ ;; (unless a jump-table is being used, where deleting may affect
+ ;; other valid case bodies)
+ ;;
((and (memq (car lap0) '(byte-goto byte-return))
- (not (memq (car lap1) '(TAG nil))))
+ (not (memq (car lap1) '(TAG nil)))
+ (not byte-compile-jump-tables))
(setq tmp rest)
(let ((i 0)
(opt-p (memq byte-optimize-log '(t lap)))
diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el
index 63be7e208b3..eb297288c63 100644
--- a/lisp/emacs-lisp/bytecomp.el
+++ b/lisp/emacs-lisp/bytecomp.el
@@ -223,6 +223,11 @@ This includes variable references and calls to functions such as `car'."
:group 'bytecomp
:type 'boolean)
+(defcustom byte-compile-cond-use-jump-table t
+ "Compile `cond' clauses to a jump table implementation (using a hash-table)."
+ :group 'bytecomp
+ :type 'boolean)
+
(defvar byte-compile-dynamic nil
"If non-nil, compile function bodies so they load lazily.
They are hidden in comments in the compiled file,
@@ -412,6 +417,8 @@ specify different fields to sort on."
(const calls+callers) (const nil)))
(defvar byte-compile-debug nil)
+(defvar byte-compile-jump-tables nil
+ "List of all jump tables used during compilation of this form.")
(defvar byte-compile-constants nil
"List of all constants encountered during compilation of this form.")
(defvar byte-compile-variables nil
@@ -747,6 +754,10 @@ otherwise pop it")
;; `byte-compile-lapcode').
(defconst byte-discardN-preserve-tos byte-discardN)
+(byte-defop 183 -2 byte-switch
+ "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
(byte-defop 192 1 byte-constant "for reference to a constant")
@@ -823,7 +834,7 @@ CONST2 may be evaluated multiple times."
op off ; Operation & offset
opcode ; numeric value of OP
(bytes '()) ; Put the output bytes here
- (patchlist nil)) ; List of gotos to patch
+ (patchlist nil)) ; List of gotos to patch
(dolist (lap-entry lap)
(setq op (car lap-entry)
off (cdr lap-entry))
@@ -905,6 +916,11 @@ CONST2 may be evaluated multiple times."
;; FIXME: Replace this by some workaround.
(if (> (car bytes-tail) 255) (error "Bytecode overflow")))
+ (dolist (hash-table byte-compile-jump-tables)
+ (cl-loop for k being the hash-keys of hash-table do
+ (let ((tag (cdr (gethash k hash-table))))
+ (setq pc (car tag))
+ (puthash k (cons (logand pc 255) (lsh pc -8)) hash-table))))
(apply 'unibyte-string (nreverse bytes))))
@@ -1954,7 +1970,8 @@ With argument ARG, insert value in current buffer after the form."
;; (edebug-all-defs nil)
;; (edebug-all-forms nil)
;; Simulate entry to byte-compile-top-level
- (byte-compile-constants nil)
+ (byte-compile-jump-tables nil)
+ (byte-compile-constants nil)
(byte-compile-variables nil)
(byte-compile-tag-number 0)
(byte-compile-depth 0)
@@ -2250,7 +2267,8 @@ list that represents a doc string reference.
byte-compile-variables nil
byte-compile-depth 0
byte-compile-maxdepth 0
- byte-compile-output nil))))
+ byte-compile-output nil
+ byte-compile-jump-tables nil))))
(defvar byte-compile-force-lexical-warnings nil)
@@ -2862,7 +2880,8 @@ for symbols generated by the byte compiler itself."
(byte-compile-maxdepth 0)
(byte-compile--lexical-environment lexenv)
(byte-compile-reserved-constants (or reserved-csts 0))
- (byte-compile-output nil))
+ (byte-compile-output nil)
+ (byte-compile-jump-tables nil))
(if (memq byte-optimize '(t source))
(setq form (byte-optimize-form form byte-compile--for-effect)))
(while (and (eq (car-safe form) 'progn) (null (cdr (cdr form))))
@@ -3951,37 +3970,147 @@ that suppresses all warnings during execution of BODY."
(byte-compile-out-tag donetag))))
(setq byte-compile--for-effect nil))
+(defun byte-compile-cond-valid-obj2-p (obj)
+ (if (consp obj)
+ (and (eq (car obj) 'quote)
+ (= (length obj) 2)
+ (symbolp (cadr obj)))
+ t))
+
+(defun byte-compile-cond-vars (obj1 obj2)
+ (or
+ (and (symbolp obj1) (byte-compile-cond-valid-obj2-p obj2) (cons obj1 obj2))
+ (and (symbolp obj2) (byte-compile-cond-valid-obj2-p obj1) (cons obj2 obj1))))
+
+(defun byte-compile-cond-jump-table-info (clauses)
+ "If CLAUSES is a `cond' form where:
+The condition for each clause is of the form (TEST VAR VALUE).
+VAR is a variable.
+TEST and VAR are the same throughtout all conditions.
+VALUE is either a constant or a quoted form.
+
+Return a list of the form ((TEST . VAR) ((VALUE BODY) ...))"
+ (let ((cases '())
+ (ok t)
+ prev-var prev-test)
+ (and (catch 'break
+ (dolist (clause (cdr clauses) ok)
+ (let* ((condition (car clause))
+ (test (car-safe condition))
+ (vars (when (consp condition)
+ (byte-compile-cond-vars (cadr condition) (cl-caddr condition))))
+ (obj1 (car-safe vars))
+ (obj2 (cdr-safe vars))
+ (body (cdr-safe clause)))
+ (unless prev-var
+ (setq prev-var obj1))
+ (unless prev-test
+ (setq prev-test test))
+ (if (and obj1 (memq test '(eq eql equal))
+ (consp condition)
+ (eq test prev-test)
+ (eq obj1 prev-var)
+ ;; discard duplicate clauses
+ (not (assq obj2 cases)))
+ (push (list (if (consp obj2) (eval obj2) obj2) body) cases)
+ (if (eq condition t)
+ (progn (push (list 'default body) cases)
+ (throw 'break t))
+ (setq ok nil)
+ (throw 'break nil))))))
+ (list (cons prev-test prev-var) (nreverse cases)))))
+
+(defun byte-compile-cond-jump-table (clauses)
+ (let* ((table-info (byte-compile-cond-jump-table-info clauses))
+ (test (caar table-info))
+ (var (cdar table-info))
+ (cases (cadr table-info))
+ jump-table test-obj body tag donetag default-tag default-case)
+ (when (and cases (not (= (length cases) 1)))
+ (setq jump-table (make-hash-table :test test
+ :size (if (assq 'default cases)
+ (1- (length cases))
+ (length cases)))
+ default-tag (byte-compile-make-tag)
+ donetag (byte-compile-make-tag))
+ (byte-compile-variable-ref var)
+ (byte-compile-push-constant jump-table)
+ (byte-compile-out 'byte-switch)
+
+ ;; When the opcode argument is `byte-goto', `byte-compile-goto' sets
+ ;; `byte-compile-depth' to `nil'. However, we need `byte-compile-depth'
+ ;; to be non-nil for generating tags for all cases. Since
+ ;; `byte-compile-depth' will increase by atmost 1 after compiling
+ ;; all of the clause (which is further enforced by cl-assert below)
+ ;; it should be safe to preserve it's value.
+ (let ((byte-compile-depth byte-compile-depth))
+ (byte-compile-goto 'byte-goto default-tag))
+
+ (when (assq 'default cases)
+ (setq default-case (cadr (assq 'default cases))
+ cases (butlast cases 1)))
+
+ (dolist (case cases)
+ (setq tag (byte-compile-make-tag)
+ test-obj (nth 0 case)
+ body (nth 1 case))
+ (byte-compile-out-tag tag)
+ (puthash test-obj tag jump-table)
+
+ (let ((byte-compile-depth byte-compile-depth)
+ (init-depth byte-compile-depth))
+ ;; Since `byte-compile-body' might increase `byte-compile-depth'
+ ;; by 1, not preserving it's value will cause it to potentially
+ ;; increase by one for every clause body compiled, causing
+ ;; depth/tag conflicts or violating asserts down the road.
+ ;; To make sure `byte-compile-body' itself doesn't violate this,
+ ;; we use `cl-assert'.
+ (byte-compile-body body byte-compile--for-effect)
+ (cl-assert (or (= byte-compile-depth init-depth)
+ (= byte-compile-depth (1+ init-depth))))
+ (byte-compile-goto 'byte-goto donetag)
+ (setcdr (cdr donetag) nil)))
+
+ (byte-compile-out-tag default-tag)
+ (if default-case
+ (byte-compile-body-do-effect default-case)
+ (byte-compile-constant nil))
+ (byte-compile-out-tag donetag)
+ (push jump-table byte-compile-jump-tables))))
+
(defun byte-compile-cond (clauses)
- (let ((donetag (byte-compile-make-tag))
- nexttag clause)
- (while (setq clauses (cdr clauses))
- (setq clause (car clauses))
- (cond ((or (eq (car clause) t)
- (and (eq (car-safe (car clause)) 'quote)
- (car-safe (cdr-safe (car clause)))))
- ;; Unconditional clause
- (setq clause (cons t clause)
- clauses nil))
- ((cdr clauses)
- (byte-compile-form (car clause))
- (if (null (cdr clause))
- ;; First clause is a singleton.
- (byte-compile-goto-if t byte-compile--for-effect donetag)
- (setq nexttag (byte-compile-make-tag))
- (byte-compile-goto 'byte-goto-if-nil nexttag)
- (byte-compile-maybe-guarded (car clause)
- (byte-compile-body (cdr clause) byte-compile--for-effect))
- (byte-compile-goto 'byte-goto donetag)
- (byte-compile-out-tag nexttag)))))
- ;; Last clause
- (let ((guard (car clause)))
- (and (cdr clause) (not (eq guard t))
- (progn (byte-compile-form guard)
- (byte-compile-goto-if nil byte-compile--for-effect donetag)
- (setq clause (cdr clause))))
- (byte-compile-maybe-guarded guard
- (byte-compile-body-do-effect clause)))
- (byte-compile-out-tag donetag)))
+ (or (and byte-compile-cond-use-jump-table
+ (byte-compile-cond-jump-table clauses))
+ (let ((donetag (byte-compile-make-tag))
+ nexttag clause)
+ (while (setq clauses (cdr clauses))
+ (setq clause (car clauses))
+ (cond ((or (eq (car clause) t)
+ (and (eq (car-safe (car clause)) 'quote)
+ (car-safe (cdr-safe (car clause)))))
+ ;; Unconditional clause
+ (setq clause (cons t clause)
+ clauses nil))
+ ((cdr clauses)
+ (byte-compile-form (car clause))
+ (if (null (cdr clause))
+ ;; First clause is a singleton.
+ (byte-compile-goto-if t byte-compile--for-effect donetag)
+ (setq nexttag (byte-compile-make-tag))
+ (byte-compile-goto 'byte-goto-if-nil nexttag)
+ (byte-compile-maybe-guarded (car clause)
+ (byte-compile-body (cdr clause) byte-compile--for-effect))
+ (byte-compile-goto 'byte-goto donetag)
+ (byte-compile-out-tag nexttag)))))
+ ;; Last clause
+ (let ((guard (car clause)))
+ (and (cdr clause) (not (eq guard t))
+ (progn (byte-compile-form guard)
+ (byte-compile-goto-if nil byte-compile--for-effect donetag)
+ (setq clause (cdr clause))))
+ (byte-compile-maybe-guarded guard
+ (byte-compile-body-do-effect clause)))
+ (byte-compile-out-tag donetag))))
(defun byte-compile-and (form)
(let ((failtag (byte-compile-make-tag))
@@ -4528,7 +4657,7 @@ binding slots have been popped."
(and byte-compile-depth
(not (= (cdr (cdr tag)) byte-compile-depth))
(error "Compiler bug: depth conflict at tag %d" (car (cdr tag))))
- (setq byte-compile-depth (cdr (cdr tag))))
+ (setq byte-compile-depth (cdr (cdr tag))))
(setcdr (cdr tag) byte-compile-depth)))
(defun byte-compile-goto (opcode tag)
diff --git a/lisp/emacs-lisp/disass.el b/lisp/emacs-lisp/disass.el
index 97e45e070d0..66673b4d26c 100644
--- a/lisp/emacs-lisp/disass.el
+++ b/lisp/emacs-lisp/disass.el
@@ -221,9 +221,21 @@ OBJ should be a call to BYTE-CODE generated by the byte compiler."
((memq op '(byte-constant byte-constant2))
;; it's a constant
(setq arg (car arg))
- ;; but if the value of the constant is compiled code, then
- ;; recursively disassemble it.
- (cond ((or (byte-code-function-p arg)
+ ;; if the succeeding op is byte-switch, display the jump table
+ ;; used
+ (cond ((eq (car-safe (car-safe (cdr lap))) 'byte-switch)
+ (insert (format "<jump-table-%s (" (hash-table-test arg)))
+ (let ((first-time t))
+ (maphash #'(lambda (value tag)
+ (if first-time
+ (setq first-time nil)
+ (insert " "))
+ (insert (format "%s %s" value (cadr tag))))
+ arg))
+ (insert ")>"))
+ ;; if the value of the constant is compiled code, then
+ ;; recursively disassemble it.
+ ((or (byte-code-function-p arg)
(and (consp arg) (functionp arg)
(assq 'byte-code arg))
(and (eq (car-safe arg) 'macro)
generated by cgit v1.2.3 (git 2.39.1) at 2025-05-03 09:21:23 +0000