diff options
Diffstat (limited to 'lisp/emacs-lisp/bytecomp.el')
| -rw-r--r-- | lisp/emacs-lisp/bytecomp.el | 187 |
1 files changed, 152 insertions, 35 deletions
diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 63be7e208b3..2bc469b17f8 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,135 @@ 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) + (cond + ((symbolp obj) (keywordp obj)) + ((consp obj) (eq (car obj) 'quote)) + (t 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) + (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 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 (length cases)) + donetag (byte-compile-make-tag)) + (byte-compile-variable-ref var) + (byte-compile-push-constant jump-table) + (byte-compile-out 'byte-switch) + + (when (assq 'default cases) + (setq default-case (cadr (assq 'default cases)) + default-tag (byte-compile-make-tag)) + (setq cases (butlast cases 1)) + ;; 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))) + + (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' (which probably doesn't need to . + (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))) + + (if default-case + (progn (byte-compile-out-tag default-tag) + (byte-compile-body-do-effect default-case)) + (byte-compile-push-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)) + ;; (message "out %s" donetag) + (if (null (cdr clause)) + ;; First clause is a singleton. + (byte-compile-goto-if t byte-compile--for-effect donetag) + ;; (message "inside %s" 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 +4645,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) |