From: Nathan Froyd Date: Tue, 10 Apr 2007 16:36:08 +0000 (+0000) Subject: 1.0.4.56: Make case-insensitive string and character comparisons non-consing X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=d10b036b1d20e6cff820f72b69af2a06dc362327;p=sbcl.git 1.0.4.56: Make case-insensitive string and character comparisons non-consing * Create two-arg versions of case-insensitive character comparison functions; * Use said functions in the general case; * Make source transforms for the general functions use the two-arg functions, thereby avoiding the &REST consing of the general functions. --- diff --git a/NEWS b/NEWS index f3034d9..3934ce2 100644 --- a/NEWS +++ b/NEWS @@ -14,6 +14,10 @@ changes in sbcl-1.0.5 relative to sbcl-1.0.4: platforms. (thanks to James Anderson for the optimization hint) * optimization: REPLACE, SUBSEQ, and COPY-SEQ are now optimized in more cases. + * optimization: STRING-{EQUAL,LESSP,GREATER-P} and their NOT- + variants no longer cons. + * optimization: Direct calls to CHAR-{EQUAL,LESSP,GREATERP} and + their NOT- variants no longer cons. * enhancement: XREF information is now collected to references made to global variables using SYMBOL-VALUE with a constant argument. * bug fix: dead unbound variable references now signal an error. diff --git a/src/code/target-char.lisp b/src/code/target-char.lisp index 7f963b8..ad0f9ee 100644 --- a/src/code/target-char.lisp +++ b/src/code/target-char.lisp @@ -437,16 +437,21 @@ (ucd-value-1 ,ch) (char-code ,ch))))) +(defun two-arg-char-equal (c1 c2) + (= (equal-char-code c1) (equal-char-code c2))) + (defun char-equal (character &rest more-characters) #!+sb-doc "Return T if all of the arguments are the same character. Font, bits, and case are ignored." (do ((clist more-characters (cdr clist))) ((null clist) t) - (unless (= (equal-char-code (car clist)) - (equal-char-code character)) + (unless (two-arg-char-equal (car clist) character) (return nil)))) +(defun two-arg-char-not-equal (c1 c2) + (/= (equal-char-code c1) (equal-char-code c2))) + (defun char-not-equal (character &rest more-characters) #!+sb-doc "Return T if no two of the arguments are the same character. @@ -456,11 +461,13 @@ ((null list) t) (unless (do* ((l list (cdr l))) ((null l) t) - (if (= (equal-char-code head) - (equal-char-code (car l))) + (if (two-arg-char-equal head (car l)) (return nil))) (return nil)))) +(defun two-arg-char-lessp (c1 c2) + (< (equal-char-code c1) (equal-char-code c2))) + (defun char-lessp (character &rest more-characters) #!+sb-doc "Return T if the arguments are in strictly increasing alphabetic order. @@ -468,10 +475,12 @@ (do* ((c character (car list)) (list more-characters (cdr list))) ((null list) t) - (unless (< (equal-char-code c) - (equal-char-code (car list))) + (unless (two-arg-char-lessp c (car list)) (return nil)))) +(defun two-arg-char-greaterp (c1 c2) + (> (equal-char-code c1) (equal-char-code c2))) + (defun char-greaterp (character &rest more-characters) #!+sb-doc "Return T if the arguments are in strictly decreasing alphabetic order. @@ -479,10 +488,12 @@ (do* ((c character (car list)) (list more-characters (cdr list))) ((null list) t) - (unless (> (equal-char-code c) - (equal-char-code (car list))) + (unless (two-arg-char-greaterp c (car list)) (return nil)))) +(defun two-arg-char-not-greaterp (c1 c2) + (<= (equal-char-code c1) (equal-char-code c2))) + (defun char-not-greaterp (character &rest more-characters) #!+sb-doc "Return T if the arguments are in strictly non-decreasing alphabetic order. @@ -490,10 +501,12 @@ (do* ((c character (car list)) (list more-characters (cdr list))) ((null list) t) - (unless (<= (equal-char-code c) - (equal-char-code (car list))) + (unless (two-arg-char-not-greaterp c (car list)) (return nil)))) +(defun two-arg-char-not-lessp (c1 c2) + (>= (equal-char-code c1) (equal-char-code c2))) + (defun char-not-lessp (character &rest more-characters) #!+sb-doc "Return T if the arguments are in strictly non-increasing alphabetic order. @@ -501,8 +514,7 @@ (do* ((c character (car list)) (list more-characters (cdr list))) ((null list) t) - (unless (>= (equal-char-code c) - (equal-char-code (car list))) + (unless (two-arg-char-not-lessp c (car list)) (return nil)))) ;;;; miscellaneous functions diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp index c1a1042..c39aeff 100644 --- a/src/compiler/srctran.lisp +++ b/src/compiler/srctran.lisp @@ -3497,15 +3497,16 @@ ;;; negated test as appropriate. If it is a degenerate one-arg call, ;;; then we transform to code that returns true. Otherwise, we bind ;;; all the arguments and expand into a bunch of IFs. -(declaim (ftype (function (symbol list boolean t) *) multi-compare)) -(defun multi-compare (predicate args not-p type) +(defun multi-compare (predicate args not-p type &optional force-two-arg-p) (let ((nargs (length args))) (cond ((< nargs 1) (values nil t)) ((= nargs 1) `(progn (the ,type ,@args) t)) ((= nargs 2) (if not-p `(if (,predicate ,(first args) ,(second args)) nil t) - (values nil t))) + (if force-two-arg-p + `(,predicate ,(first args) ,(second args)) + (values nil t)))) (t (do* ((i (1- nargs) (1- i)) (last nil current) @@ -3543,15 +3544,15 @@ 'character)) (define-source-transform char-equal (&rest args) - (multi-compare 'char-equal args nil 'character)) + (multi-compare 'sb!impl::two-arg-char-equal args nil 'character t)) (define-source-transform char-lessp (&rest args) - (multi-compare 'char-lessp args nil 'character)) + (multi-compare 'sb!impl::two-arg-char-lessp args nil 'character t)) (define-source-transform char-greaterp (&rest args) - (multi-compare 'char-greaterp args nil 'character)) + (multi-compare 'sb!impl::two-arg-char-greaterp args nil 'character t)) (define-source-transform char-not-greaterp (&rest args) - (multi-compare 'char-greaterp args t 'character)) + (multi-compare 'sb!impl::two-arg-char-greaterp args t 'character t)) (define-source-transform char-not-lessp (&rest args) - (multi-compare 'char-lessp args t 'character)) + (multi-compare 'sb!impl::two-arg-char-lessp args t 'character t)) ;;; This function does source transformation of N-arg inequality ;;; functions such as /=. This is similar to MULTI-COMPARE in the <3 diff --git a/version.lisp-expr b/version.lisp-expr index 8c07c97..aebc90c 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.4.55" +"1.0.4.56"