master: Recognize the pattern (if (member x `(, this , that)) ...)
snuglas via Sbcl-commits <[email protected]>
| Newsgroups | gmane.lisp.steel-bank.cvs |
|---|---|
| Message-ID | <[email protected]> |
The branch "master" has been updated in SBCL:
via 9b59c02a5824b6114beb120b44ae8acbcc9ff8d9 (commit)
from 5d1babc0ecd4dcc68dfe0cc1e9a7e3a450c7f35d (commit)
- Log -----------------------------------------------------------------
commit 9b59c02a5824b6114beb120b44ae8acbcc9ff8d9
Author: Douglas Katzman <[email protected]>
Date: Thu Aug 13 16:19:06 2026 +0000
Recognize the pattern (if (member x `(,this ,that)) ...)
which is a useful notation for CASE clauses where the symbols to match
are not literals. So you can use a COND without writing an OR over EQL.
---
src/compiler/seqtran.lisp | 82 +++++++++++++++++++++++++++++++++++++++++++--
tests/compiler-ir.pure.lisp | 35 +++++++++++++++++++
2 files changed, 115 insertions(+), 2 deletions(-)
diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp
index c3ff3f0d7..3dc5b0d63 100644
--- a/src/compiler/seqtran.lisp
+++ b/src/compiler/seqtran.lisp
@@ -776,8 +776,9 @@
(test (symbolicate "%" name "-TEST"))
(key-test (symbolicate "%" name "-KEY-TEST")))
`(progn
- (deftransform ,name ((item list &key key test test-not) * * :node node)
- (transform-list-item-seek ',name item list key test test-not node))
+ ,@(unless (eq name 'member) ; tries its own thing first
+ `((deftransform ,name ((item list &key key test test-not) * * :node node)
+ (transform-list-item-seek ',name item list key test test-not node))))
(deftransform ,basic ((item list) * * :important nil :node node)
(transform-list-item-seek ',name item list nil nil nil node 'eql))
(deftransform ,basic ((item list) (eq-comparable-type t) * :important nil)
@@ -825,6 +826,83 @@
(def member t)
(def rassoc t))
+;; In situations where MEMBER is used only as a boolean, if we see (MEMBER x `(...))
+;; where it did not simplify to QUOTE, the instead of constructing a list we can
+;; forward all args of LIST or LIST* to a new lambda that performs the membership
+;; test without consing. There are (at most) three collections of elements:
+;; (1) a bounded set of constants: These can use a hash-based, or range-based,
+;; or bit-test-based comparison, or at worse an IF/ELSE chain.
+;; It'll produce whatever the MEMBER optimizer would ordinarily do.
+;; (2) a bounded set of non-constants: this becomes an IF/ELSE chain.
+;; (3) a variable tail if present becomes another MEMBER call.
+;; If the list elements are all constants, it should have been folded to a constant
+;; list by the #\` optimizer, however the user might have hand-written an expression
+;; such as (MEMBER X (LIST 'a 'b 'c)) but more likely that came from a macro,
+;; in which case LIST would not have been folded.
+;;
+;; TODOs:
+;; - For non-constant lists, in general FIND gets more aggressive open-coding so
+;; we should prefer to transform MEMBER to FIND, taking care to avoid the semantic
+;; difference where NIL is found, which for MEMBER is "true" since it returns a cons.
+;; - Consider similar ways that FIND-IF, MEMBER-IF can avoid constructing the list
+(defun try-member-predicate-transform (list-lvar key test test-not)
+ (let ((list-ctor (lvar-uses list-lvar)))
+ ;; I see no reason to attempt this transform with KEY or TEST-NOT.
+ (unless (and (and (null key) (null test-not))
+ (combination-p list-ctor)
+ (lvar-fun-is (combination-fun list-ctor)
+ '(sb-impl::|List| sb-impl::|List*| list list*)))
+ (return-from try-member-predicate-transform))
+ (binding*
+ ((parameters (make-gensym-list (length (combination-args list-ctor))))
+ ((literals non-literals dotted-tail)
+ (let* ((star (lvar-fun-is (combination-fun list-ctor)
+ '(sb-impl::|List*| list*)))
+ (args (combination-args list-ctor))
+ (last (car (last args)))
+ (formals parameters))
+ (collect ((literals) (non-literals))
+ (dolist (lvar (if star (butlast args) args))
+ (if (constant-lvar-p lvar)
+ (literals (lvar-value lvar))
+ (non-literals (car formals)))
+ (pop formals))
+ (cond ((not star)
+ (values (literals) (non-literals) nil))
+ ((constant-lvar-p last) ; `(a b ,x y z) has a dotted tail of (y z)
+ (unless (proper-list-p (lvar-value last))
+ (return-from try-member-predicate-transform))
+ (values (nconc (literals) (lvar-value last)) (non-literals) nil))
+ (t
+ (values (literals) (non-literals) (car formals)))))))
+ ;; SET-DIFFERENCE does not promise to be order-preserving, but
+ ;; it doesn't matter.
+ (ignore (set-difference parameters (cons dotted-tail non-literals))))
+ (splice-fun-args list-lvar :any nil)
+ (when ignore (setq ignore `((declare (ignore ,@ignore)))))
+ (if (not test)
+ `(lambda (item ,@parameters)
+ ,@ignore
+ (or ,@(if literals `((member item ',literals)))
+ (when (or ,@(mapcar (lambda (varname) `(eql item ,varname))
+ non-literals))
+ '(t)) ; return a non-nil list as MEMBER requires
+ ,@(if dotted-tail `((member item ,dotted-tail)))))
+ `(lambda (item ,@parameters &key test)
+ ,@ignore
+ (or ,@(if literals `((member item ',literals :test test)))
+ (when (or ,@(mapcar (lambda (varname) `(funcall test item ,varname))
+ non-literals))
+ '(t))
+ ,@(if dotted-tail `((member item ,dotted-tail :test test)))))))))
+
+(deftransform member ((item list &key key test test-not) * * :node node)
+ ;; If the list argument is a runtime-constructed list, and the result of MEMBER
+ ;; is used only for its truth value, try to avoid constructing the list.
+ (or (and (if-p (node-dest node))
+ (try-member-predicate-transform list key test test-not))
+ (transform-list-item-seek 'member item list key test test-not node)))
+
;;; A similar transform used to apply to MEMBER and ASSOC, but since
;;; TRANSFORM-LIST-ITEM-SEEK now takes care of them those transform
;;; would never fire, and (%MEMBER-TEST ITEM LIST #'EQ) should be
diff --git a/tests/compiler-ir.pure.lisp b/tests/compiler-ir.pure.lisp
index aea3bc772..628aa4c7e 100644
--- a/tests/compiler-ir.pure.lisp
+++ b/tests/compiler-ir.pure.lisp
@@ -884,3 +884,38 @@
(f p)
(f p))))))
0)))
+
+(defun check-no-list-consing (lexpr)
+ (let* ((calls (ir-calls lexpr))
+ (count (+ (count 'list calls
+ :key (lambda (x) (combination-fun-source-name x nil)))
+ (count 'list* calls
+ :key (lambda (x) (combination-fun-source-name x nil))))))
+ (assert (zerop count))))
+
+(defglobal *thing* 0)
+(with-test (:name :member-as-boolean-quasiquoted-list)
+ (check-no-list-consing
+ '(lambda (x)
+ (not (null (member x (list* 1 2 3 (list 'foo 'bar)))))))
+ (check-no-list-consing
+ '(lambda (e w x y z)
+ (declare (symbol e))
+ (cond ((member e `(,w ,x)) 'this) ((member e `(,y ,z)) 'that))))
+ (check-no-list-consing
+ '(lambda (x a)
+ (if (member (the symbol x) `(,a ,*thing* :all :default :other)) 'yes 'no)))
+ (check-no-list-consing
+ '(lambda (x a)
+ (if (member x `(,a ,*thing* :other) :test 'eq) 'yes 'no)))
+ (check-no-list-consing
+ '(lambda (x a)
+ (if (member x `(,a ,*thing* -1) :test #'=) 'yes 'no)))
+ ;; try one of those to see that it works
+ (let ((f (compile nil
+ '(lambda (x a)
+ (if (member x `(,a ,*thing* :other) :test 'eq) 'yes 'no)))))
+ (assert (eq (funcall f 'foo 'foo) 'yes))
+ (assert (eq (funcall f 0 'whatever) 'yes))
+ (assert (eq (funcall f :other 'ignore) 'yes))
+ (assert (eq (funcall f 3 4) 'no))))
-----------------------------------------------------------------------
hooks/post-receive
--
SBCL