Skip to content

Commit

Permalink
Optimise member and assoc (etc) with constant empty list
Browse files Browse the repository at this point in the history
* 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.
  • Loading branch information
mattiase committed Sep 6, 2021
1 parent ba6df55 commit fab1e22
Show file tree
Hide file tree
Showing 2 changed files with 56 additions and 25 deletions.
66 changes: 41 additions & 25 deletions lisp/emacs-lisp/byte-opt.el
Expand Up @@ -967,47 +967,61 @@ 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',
;; if the first arg is a symbol or fixnum.
(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))

Expand Down Expand Up @@ -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)
Expand Down
15 changes: 15 additions & 0 deletions test/lisp/emacs-lisp/bytecomp-tests.el
Expand Up @@ -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.")

Expand Down

0 comments on commit fab1e22

Please sign in to comment.