From: Nikodemus Siivola Date: Tue, 29 Apr 2008 13:58:51 +0000 (+0000) Subject: 1.0.16.13: use TRANSFORM-LIST-ITEM-SEEK for ADJOIN as well X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=08fe30555857c1928e00a8267b42740aa739631b;p=sbcl.git 1.0.16.13: use TRANSFORM-LIST-ITEM-SEEK for ADJOIN as well * Now that the freeze was cancelled, do this properly... --- diff --git a/NEWS b/NEWS index 720f6bb..c1bef9e 100644 --- a/NEWS +++ b/NEWS @@ -1,5 +1,7 @@ ;;;; -*- coding: utf-8; -*- changes in sbcl-1.0.17 relative to 1.0.16: + * optimization: ADJOIN and PUSHNEW are upto ~70% faster in normal + SPEED policies. * optimization: APPEND is upto ~10% faster in normal SPEED policies. * optimization: two argument forms of LAST are upto ~10% faster in normal SPEED policies. diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 405580f..4c7049c 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -1159,7 +1159,16 @@ is a good idea, but see SB-SYS re. blurring of boundaries." "SB!EXT" "SB!FASL" "SB!INT" "SB!SYS" "SB!GRAY") :reexport ("DEF!STRUCT" "DEF!MACRO") :export ("%ACOS" - "%ACOSH" "%ARRAY-AVAILABLE-ELEMENTS" "%ARRAY-DATA-VECTOR" + "%ACOSH" + "%ADJOIN" + "%ADJOIN-EQ" + "%ADJOIN-KEY" + "%ADJOIN-KEY-EQ" + "%ADJOIN-KEY-TEST" + "%ADJOIN-KEY-TEST-NOT" + "%ADJOIN-TEST" + "%ADJOIN-TEST-NOT" + "%ARRAY-AVAILABLE-ELEMENTS" "%ARRAY-DATA-VECTOR" "%ARRAY-DIMENSION" "%ARRAY-DISPLACED-P" "%ARRAY-DISPLACEMENT" "%ARRAY-FILL-POINTER" "%ARRAY-FILL-POINTER-P" "%ARRAY-RANK" diff --git a/src/code/list.lisp b/src/code/list.lisp index 4d03a1a..551420d 100644 --- a/src/code/list.lisp +++ b/src/code/list.lisp @@ -18,7 +18,7 @@ ;;;; -- WHN 20000127 (declaim (maybe-inline - adjoin tree-equal nth %setnth nthcdr make-list + tree-equal nth %setnth nthcdr make-list member-if member-if-not tailp union nunion intersection nintersection set-difference nset-difference set-exclusive-or nset-exclusive-or subsetp acons @@ -1290,44 +1290,58 @@ ;;;; Specialized versions -;;; %MEMBER-* and %ASSOC-* functions. The transforms for MEMBER and -;;; ASSOC pick the appropriate version. These win because they have -;;; only positional arguments, the TEST, TEST-NOT & KEY functions are -;;; known to exist (or not), and are known to be functions instead of -;;; function designators. We are also able to transform many common -;;; cases to -EQ versions, which are substantially faster then EQL -;;; using ones. +;;; %ADJOIN-*, %ASSOC-*, and %MEMBER-* functions. Deftransforms +;;; delegate to TRANSFORM-LIST-ITEM-SEEK which picks the appropriate +;;; version. These win because they have only positional arguments, +;;; the TEST, TEST-NOT & KEY functions are known to exist (or not), +;;; and are known to be functions instead of function designators. We +;;; are also able to transform many common cases to -EQ versions, +;;; which are substantially faster then EQL using ones. (macrolet ((def (funs form &optional variant) (flet ((%def (name) - `(defun ,(intern (format nil "%~A~{-~A~}~@[-~A~]" name funs variant)) - (item list ,@funs) - (declare (optimize speed)) - ,@(when funs `((declare (function ,@funs)))) - (do ((list list (cdr list))) - ((null list) nil) - (declare (list list)) - (let ((this (car list))) - ,(ecase name - (assoc - (if funs - `(when this - (let ((target (car this))) + (let* ((body-loop + `(do ((list list (cdr list))) + ((null list) nil) + (declare (list list)) + (let ((this (car list))) + ,(ecase name + (assoc + (if funs + `(when this + (let ((target (car this))) + (when ,form + (return this)))) + ;; If there is no TEST/TEST-NOT or + ;; KEY, do the EQ/EQL test first, + ;; before checking for NIL. + `(let ((target (car this))) + (when (and ,form this) + (return this))))) + (member + `(let ((target this)) (when ,form - (return this)))) - ;; If there is no TEST/TEST-NOT or - ;; KEY, do the EQ/EQL test first, - ;; before checking for NIL. - `(let ((target (car this))) - (when (and ,form this) - (return this))))) - (member - `(let ((target this)) - (when ,form - (return list)))))))))) + (return list)))) + (adjoin + `(let ((target this)) + (when ,form + (return t)))))))) + (body (if (eq 'adjoin name) + `(if (let ,(when (member 'key funs) + `((item (funcall key item)))) + ,body-loop) + list + (cons item list)) + body-loop))) + `(defun ,(intern (format nil "%~A~{-~A~}~@[-~A~]" name funs variant)) + (item list ,@funs) + (declare (optimize speed (sb!c::verify-arg-count 0))) + ,@(when funs `((declare (function ,@funs)))) + ,body)))) `(progn - ,(%def 'member) - ,(%def 'assoc))))) + ,(%def 'adjoin) + ,(%def 'assoc) + ,(%def 'member))))) (def () (eql item target)) (def () @@ -1345,4 +1359,4 @@ (def (test) (funcall test item target)) (def (test-not) - (not (funcall test-not item target)))) + (not (funcall test-not item target)))) diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp index 3d4dc91..4c5e02d 100644 --- a/src/compiler/seqtran.lisp +++ b/src/compiler/seqtran.lisp @@ -381,6 +381,9 @@ (deftransform assoc ((item list &key key test test-not) * * :node node) (transform-list-item-seek 'assoc item list key test test-not node)) +(deftransform adjoin ((item list &key key test test-not) * * :node node) + (transform-list-item-seek 'adjoin item list key test test-not node)) + (deftransform memq ((item list) (t (constant-arg list))) (labels ((rec (tail) (if tail diff --git a/version.lisp-expr b/version.lisp-expr index f7104fe..d6e8588 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -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.16.12" +"1.0.16.13"