Skip to content

Commit

Permalink
1.0.19.18: transform ADJOIN, ASSOC, MEMBER, and RASSOC to -EQ version…
Browse files Browse the repository at this point in the history 
…s more often

 * Add transforms from %FOO and %FOO-KEY to %FOO-EQ and %FOO-KEY-EQ,
   so that propagated type information has a chance to work its magic.
  • Loading branch information
@nikodemus
nikodemus committed Aug 4, 2008
1 parent e082422 commit 980efb1
Show file tree
Hide file tree
Showing 5 changed files with 48 additions and 27 deletions.
2 changes: 2 additions & 0 deletions NEWS
View file
Expand Up @@ -7,6 +7,8 @@ changes in sbcl-1.0.20 relative to 1.0.19:
* optimization: ASSOC-IF, ASSOC-IF-NOT, MEMBER-IF, MEMBER-IF-NOT,
RASSOC, RASSOC-IF, and RASSOC-IF-NOT are now equally efficient
as ASSOC and MEMEBER.
* optimization: calls to ASSOC, MEMBER, and RASSOC can be transformed
to more efficient EQ-comparison versions more often.
* optimization: enhanced derivation of DOLIST iteration variable type
for constant lists.
* optimization: constant folding of simple (LIST ...) forms as DOLIST
Expand Down
9 changes: 9 additions & 0 deletions src/compiler/fndb.lisp
View file
Expand Up @@ -1482,6 +1482,15 @@
function
(flushable foldable))

(defknown %adjoin (t list) list (explicit-check foldable flushable))
(defknown %adjoin-key (t list function) list (explicit-check foldable flushable call))
(defknown %assoc (t list) list (explicit-check foldable flushable))
(defknown %assoc-key (t list function) list (explicit-check foldable flushable call))
(defknown %member (t list) list (explicit-check foldable flushable))
(defknown %member-key (t list function) list (explicit-check foldable flushable call))
(defknown %rassoc (t list) list (explicit-check foldable flushable))
(defknown %rassoc-key (t list function) list (explicit-check foldable flushable call))

(defknown %check-vector-sequence-bounds (vector index sequence-end)
index
(unwind))
Expand Down
58 changes: 36 additions & 22 deletions src/compiler/seqtran.lisp
View file
Expand Up @@ -291,6 +291,13 @@
(or end length)
(sequence-bounding-indices-bad-error vector start end)))))

(deftype eq-comparable-type ()
'(or fixnum (not number)))

;;; True if EQL comparisons involving type can be simplified to EQ.
(defun eq-comparable-type-p (type)
(csubtypep type (specifier-type 'eq-comparable-type)))

(defun specialized-list-seek-function-name (function-name key-functions &optional variant)
(or (find-symbol (with-output-to-string (s)
;; Write "%NAME-FUN1-FUN2-FUN3", etc. Not only is
Expand Down Expand Up @@ -330,15 +337,16 @@
(%coerce-callable-to-fun key)
#'identity)))
(t
(values key '(%coerce-callable-to-fun key))))))
(values key (ensure-lvar-fun-form key 'key))))))
(let* ((c-test (cond ((and test (lvar-fun-is test '(eq)))
(setf test nil)
'eq)
((and (not test) (not test-not))
(when (eq-comparable-type-p (lvar-type item))
'eq))))
(funs (remove nil (list (and key 'key) (cond (test 'test)
(test-not 'test-not)))))
(funs (delete nil (list (when key (list key 'key))
(when test (list test 'test))
(when test-not (list test-not 'test-not)))))
(target-expr (if key '(%funcall key target) 'target))
(test-expr (cond (test `(%funcall test item ,target-expr))
(test-not `(not (%funcall test-not item ,target-expr)))
Expand All @@ -359,15 +367,15 @@
((assoc rassoc) (car tail))
(member tail))
,(open-code (cdr tail)))))
(ensure-fun (fun)
(if (eq 'key fun)
(ensure-fun (args)
(if (eq 'key (second args))
key-form
`(%coerce-callable-to-fun ,fun))))
(apply #'ensure-lvar-fun-form args))))
(let* ((cp (constant-lvar-p list))
(c-list (when cp (lvar-value list))))
(cond ((and cp c-list (member name '(assoc rassoc member))
(policy node (>= speed space)))
`(let ,(mapcar (lambda (fun) `(,fun ,(ensure-fun fun))) funs)
`(let ,(mapcar (lambda (fun) `(,(second fun) ,(ensure-fun fun))) funs)
,(open-code c-list)))
((and cp (not c-list))
;; constant nil list
Expand All @@ -376,7 +384,7 @@
nil))
(t
;; specialized out-of-line version
`(,(specialized-list-seek-function-name name funs c-test)
`(,(specialized-list-seek-function-name name (mapcar #'second funs) c-test)
item list ,@(mapcar #'ensure-fun funs)))))))))

(defun transform-list-pred-seek (name pred list key node)
Expand All @@ -397,11 +405,9 @@
(%coerce-callable-to-fun key)
#'identity)))
(t
(values key '(%coerce-callable-to-fun key))))))
(values key (ensure-lvar-fun-form key 'key))))))
(let ((test-expr `(%funcall pred ,(if key '(%funcall key target) 'target)))
(pred-expr (if (csubtypep (lvar-type pred) (specifier-type 'function))
'pred
'(%coerce-callable-to-fun pred))))
(pred-expr (ensure-lvar-fun-form pred 'pred)))
(when (member name '(member-if-not assoc-if-not rassoc-if-not))
(setf test-expr `(not ,test-expr)))
(labels ((open-code (tail)
Expand Down Expand Up @@ -436,16 +442,24 @@
,pred-expr list ,@(when key (list key-form))))))))))

(macrolet ((def (name &optional if/if-not)
`(progn
(deftransform ,name ((item list &key key test test-not) * * :node node)
(transform-list-item-seek ',name item list key test test-not node))
,@(when if/if-not
(let ((if-name (symbolicate name "-IF"))
(if-not-name (symbolicate name "-IF-NOT")))
`((deftransform ,if-name ((pred list &key key) * * :node node)
(transform-list-pred-seek ',if-name pred list key node))
(deftransform ,if-not-name ((pred list &key key) * * :node node)
(transform-list-pred-seek ',if-not-name pred list key node))))))))
(let ((basic (symbolicate "%" name))
(basic-eq (symbolicate "%" name "-EQ"))
(basic-key (symbolicate "%" name "-KEY"))
(basic-key-eq (symbolicate "%" name "-KEY-EQ")))
`(progn
(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) (eq-comparable-type t))
`(,',basic-eq item list))
(deftransform ,basic-key ((item list) (eq-comparable-type t))
`(,',basic-key-eq item list))
,@(when if/if-not
(let ((if-name (symbolicate name "-IF"))
(if-not-name (symbolicate name "-IF-NOT")))
`((deftransform ,if-name ((pred list &key key) * * :node node)
(transform-list-pred-seek ',if-name pred list key node))
(deftransform ,if-not-name ((pred list &key key) * * :node node)
(transform-list-pred-seek ',if-not-name pred list key node)))))))))
(def adjoin)
(def assoc t)
(def member t)
Expand Down
4 changes: 0 additions & 4 deletions src/compiler/srctran.lisp
View file
Expand Up @@ -3392,10 +3392,6 @@
(def eq)
(def char=))

;;; True if EQL comparisons involving type can be simplified to EQ.
(defun eq-comparable-type-p (type)
(csubtypep type (specifier-type '(or fixnum (not number)))))

;;; This is similar to SIMPLE-EQUALITY-TRANSFORM, except that we also
;;; try to convert to a type-specific predicate or EQ:
;;; -- If both args are characters, convert to CHAR=. This is better than
Expand Down
2 changes: 1 addition & 1 deletion version.lisp-expr
View file
Expand Up @@ -17,4 +17,4 @@
;;; checkins which aren't released. (And occasionally for internal
;;; versions, especially for internal versions off the main CVS
;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
"1.0.19.17"
"1.0.19.18"

0 comments on commit 980efb1

Please sign in to comment.