From f08a1a3c27850b0e79ea5f0fba05c0615342895a Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Wed, 23 Apr 2008 15:42:30 +0000 Subject: [PATCH] 1.0.16.6: slightly faster APPEND * Declare &REST dynamic-extent and remove MAYBE-INLINE declaration. * Micro-optimization for type-checking and list walking. * Compiler-macro into APPEND2 for the common 2 argument case. --- NEWS | 1 + src/code/list.lisp | 56 ++++++++++++++++++++++++++++++++++++++++-------------- version.lisp-expr | 2 +- 3 files changed, 44 insertions(+), 15 deletions(-) diff --git a/NEWS b/NEWS index fb96144aa..14c803e32 100644 --- a/NEWS +++ b/NEWS @@ -2,6 +2,7 @@ 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. * bug fix: dynamic extent allocation of nested lists and vectors could leak to otherwise accessible parts. * bug fix: invalid optimization of heap-allocated alien variable diff --git a/src/code/list.lisp b/src/code/list.lisp index 8f6322684..1e2c8a4d7 100644 --- a/src/code/list.lisp +++ b/src/code/list.lisp @@ -18,7 +18,7 @@ ;;;; -- WHN 20000127 (declaim (maybe-inline - tree-equal nth %setnth nthcdr last last1 make-list append + tree-equal nth %setnth nthcdr last last1 make-list nconc nconc2 member-if member-if-not tailp union nunion intersection nintersection set-difference nset-difference set-exclusive-or nset-exclusive-or subsetp acons @@ -282,33 +282,61 @@ (defun append (&rest lists) #!+sb-doc "Construct a new list by concatenating the list arguments" + (declare (dynamic-extent lists) (optimize speed)) (labels ((fail (object) (error 'type-error :datum object :expected-type 'list)) (append-into (last-cons current rest) - "Set (CDR LAST-CONS) to (APPLY #'APPEND CURRENT REST)." + ;; Set (CDR LAST-CONS) to (APPLY #'APPEND CURRENT REST). (declare (cons last-cons rest)) - (cond ((consp current) - (append-into (setf (cdr last-cons) (list (car current))) - (cdr current) - rest)) - ((not (null current)) (fail current)) - ((null (cdr rest)) (setf (cdr last-cons) (car rest))) - (t (append-into last-cons (car rest) (cdr rest))))) + (if (listp current) + (if (consp current) + ;; normal case, cdr down the list + (append-into (setf (cdr last-cons) (list (car current))) + (cdr current) + rest) + ;; empty list + (let ((more (cdr rest))) + (if (null more) + (setf (cdr last-cons) (car rest)) + (append-into last-cons (car rest) more)))) + (fail current))) (append1 (lists) (let ((current (car lists)) (rest (cdr lists))) - (cond ((null rest) current) + (cond ((null rest) + current) ((consp current) (let ((result (truly-the cons (list (car current))))) (append-into result - (cdr current) - rest) + (cdr current) + rest) result)) - ((null current) (append1 rest)) - (t (fail current)))))) + ((null current) + (append1 rest)) + (t + (fail current)))))) (append1 lists))) + +(defun append2 (x y) + (declare (optimize speed (sb!c::verify-arg-count 0))) + (if (null x) + y + (let ((result (list (car x)))) + (do ((more (cdr x) (cdr more)) + (tail result (cdr tail))) + ((null more) + (rplacd tail y) + result) + (rplacd tail (list (car more))))))) + +(define-compiler-macro append (&whole form &rest lists) + (case (length lists) + (0 nil) + (1 (car lists)) + (2 `(append2 ,@lists)) + (t form))) ;;;; list copying functions diff --git a/version.lisp-expr b/version.lisp-expr index 70ae36374..23d9e5ad8 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.5" +"1.0.16.6" -- 2.11.4.GIT