procyberian/emacs
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Optimise member and assoc (etc) with constant empty list

Browse source 
* lisp/emacs-lisp/byte-opt.el
(byte-optimize-assq): New.
(byte-optimize-member, byte-optimize-assoc, byte-optimize-memq):
When the list argument is constant nil, the result is always nil.
* test/lisp/emacs-lisp/bytecomp-tests.el (bytecomp-tests--test-cases):
Add test cases.
This commit is contained in:
Mattias Engdegård 2021-07-28 21:07:58 +02:00
parent ba6df55475
commit fab1e220db
2 changed files with 56 additions and 25 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

66
lisp/emacs-lisp/byte-opt.el
View file

@ -967,24 +967,25 @@ See Info node `(elisp) Integer Basics'."
(_ (byte-optimize-binary-predicate form))))
(defun byte-optimize-member (form)
;; Replace `member' or `memql' with `memq' if the first arg is a symbol,
;; or the second arg is a list of symbols. Same with fixnums.
(if (= (length (cdr form)) 2)
(if (or (byte-optimize--constant-symbol-p (nth 1 form))
(byte-optimize--fixnump (nth 1 form))
(let ((arg2 (nth 2 form)))
(and (macroexp-const-p arg2)
(let ((listval (eval arg2)))
(and (listp listval)
(not (memq nil (mapcar
(lambda (o)
(or (symbolp o)
(byte-optimize--fixnump o)))
listval))))))))
(cons 'memq (cdr form))
form)
;; Arity errors reported elsewhere.
form))
(cond
((/= (length (cdr form)) 2) form) ; arity error
((null (nth 2 form)) ; empty list
`(progn ,(nth 1 form) nil))
;; Replace `member' or `memql' with `memq' if the first arg is a symbol
;; or fixnum, or the second arg is a list of symbols or fixnums.
((or (byte-optimize--constant-symbol-p (nth 1 form))
(byte-optimize--fixnump (nth 1 form))
(let ((arg2 (nth 2 form)))
(and (macroexp-const-p arg2)
(let ((listval (eval arg2)))
(and (listp listval)
(not (memq nil (mapcar
(lambda (o)
(or (symbolp o)
(byte-optimize--fixnump o)))
listval))))))))
(cons 'memq (cdr form)))
(t form)))
(defun byte-optimize-assoc (form)
;; Replace 2-argument `assoc' with `assq', `rassoc' with `rassq',
@ -992,22 +993,35 @@ See Info node `(elisp) Integer Basics'."
(cond
((/= (length form) 3)
form)
((null (nth 2 form)) ; empty list
`(progn ,(nth 1 form) nil))
((or (byte-optimize--constant-symbol-p (nth 1 form))
(byte-optimize--fixnump (nth 1 form)))
(cons (if (eq (car form) 'assoc) 'assq 'rassq)
(cdr form)))
(t (byte-optimize-constant-args form))))
(defun byte-optimize-assq (form)
(cond
((/= (length form) 3)
form)
((null (nth 2 form)) ; empty list
`(progn ,(nth 1 form) nil))
(t (byte-optimize-constant-args form))))
(defun byte-optimize-memq (form)
;; (memq foo '(bar)) => (and (eq foo 'bar) '(bar))
(if (= (length (cdr form)) 2)
(let ((list (nth 2 form)))
(if (and (eq (car-safe list) 'quote)
(listp (setq list (cadr list)))
(= (length list) 1))
`(and (eq ,(nth 1 form) ',(nth 0 list))
',list)
form))
(cond
((null list) ; empty list
`(progn ,(nth 1 form) nil))
;; (memq foo '(bar)) => (and (eq foo 'bar) '(bar))
((and (eq (car-safe list) 'quote)
(listp (setq list (cadr list)))
(= (length list) 1))
`(and (eq ,(nth 1 form) ',(nth 0 list))
',list))
(t form)))
;; Arity errors reported elsewhere.
form))
@ -1044,6 +1058,8 @@ See Info node `(elisp) Integer Basics'."
(put 'member 'byte-optimizer #'byte-optimize-member)
(put 'assoc 'byte-optimizer #'byte-optimize-assoc)
(put 'rassoc 'byte-optimizer #'byte-optimize-assoc)
(put 'assq 'byte-optimizer #'byte-optimize-assq)
(put 'rassq 'byte-optimizer #'byte-optimize-assq)
(put '+ 'byte-optimizer #'byte-optimize-plus)
(put '* 'byte-optimizer #'byte-optimize-multiply)

15
test/lisp/emacs-lisp/bytecomp-tests.el
View file

@ -536,6 +536,21 @@
(let ((_a 1)
(_b 2))
'z)
;; Check empty-list optimisations.
(mapcar (lambda (x) (member x nil)) '("a" 2 nil))
(mapcar (lambda (x) (memql x nil)) '(a 2 nil))
(mapcar (lambda (x) (memq x nil)) '(a nil))
(let ((n 0))
(list (mapcar (lambda (x) (member (setq n (1+ n)) nil)) '(a "nil"))
n))
(mapcar (lambda (x) (assoc x nil)) '("a" nil))
(mapcar (lambda (x) (assq x nil)) '(a nil))
(mapcar (lambda (x) (rassoc x nil)) '("a" nil))
(mapcar (lambda (x) (rassq x nil)) '(a nil))
(let ((n 0))
(list (mapcar (lambda (x) (assoc (setq n (1+ n)) nil)) '(a "nil"))
n))
)
"List of expressions for cross-testing interpreted and compiled code.")