From 9a2bacfe6912e180cc9ac7b3fbf302ca3f3d33d1 Mon Sep 17 00:00:00 2001 From: William Harold Newman Date: Sun, 14 Jan 2001 18:54:21 +0000 Subject: [PATCH] 0.6.9.23: fixes in code-extra and compiler-extra Don't use deprecated POSITION-IF-NOT. --- contrib/code-extras.lisp | 170 ++++++++++++++++++----------------- contrib/compiler-extras.lisp | 61 +++++++++++-- src/compiler/ir1tran.lisp | 4 +- version.lisp-expr | 2 +- 4 files changed, 144 insertions(+), 93 deletions(-) diff --git a/contrib/code-extras.lisp b/contrib/code-extras.lisp index 41e395431..6df26a157 100644 --- a/contrib/code-extras.lisp +++ b/contrib/code-extras.lisp @@ -7,8 +7,6 @@ (defun %with-array-data (array start end) (%with-array-data-macro array start end :fail-inline? t)) -;;; FIXME: vector-push-extend patch - ;;; Like CMU CL, we use HEAPSORT. However, instead of trying to ;;; generalize the CMU CL code to allow START and END values, this ;;; code has been written from scratch following Chapter 7 of @@ -122,18 +120,22 @@ (defun vector-push-extend (new-element vector &optional - (extension (1+ (length vector)))) + (extension nil extension-p)) (declare (type vector vector)) - (declare (type (integer 1 #.most-positive-fixnum) extension)) (let ((old-fill-pointer (fill-pointer vector))) (declare (type index old-fill-pointer)) (when (= old-fill-pointer (%array-available-elements vector)) - (adjust-array vector (+ old-fill-pointer extension))) + (adjust-array vector (+ old-fill-pointer + (if extension-p + (the (integer 1 #.most-positive-fixnum) + extension) + (1+ old-fill-pointer))))) (setf (%array-fill-pointer vector) (1+ old-fill-pointer)) ;; Wrapping the type test and the AREF in the same WITH-ARRAY-DATA ;; saves some time. - (with-array-data ((v vector) (i old-fill-pointer) (end)) + (with-array-data ((v vector) (i old-fill-pointer) (end) + :force-inline t) (declare (ignore end) (optimize (safety 0))) (if (simple-vector-p v) ; if common special case (setf (aref v i) new-element) @@ -142,6 +144,16 @@ ;;; FIXME: should DEFUN REPLACE in terms of same expansion as ;;; DEFTRANSFORM +#+nil +(defun replace (..) + (cond ((and (typep seq1 'simple-vector) + (typep seq2 'simple-vector)) + (%replace-vector-vector ..)) + ((and (typep seq1 'simple-string) + (typep seq2 'simple-string)) + (%replace-vector-vector ..)) + (t + ..))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; POSITION/FIND stuff @@ -154,9 +166,10 @@ ;; NIL is never returned; and give (NEED (FIND ..)) workaround. (error "need to fix FIXMEs")) -;;; logic to unravel :TEST and :TEST-NOT options in FIND/POSITION/etc. -(declaim (inline %effective-test)) -(defun %effective-find-position-test (test test-not) +;;; logic to unravel :TEST, :TEST-NOT, and :KEY options in FIND, +;;; POSITION-IF, etc. +(declaim (inline effective-find-position-test effective-find-position-key)) +(defun effective-find-position-test (test test-not) (cond ((and test test-not) (error "can't specify both :TEST and :TEST-NOT")) (test (%coerce-callable-to-function test)) @@ -166,79 +179,12 @@ ;; anyway, we don't care.) (complement (%coerce-callable-to-function test-not))) (t #'eql))) +(defun effective-find-position-key (key) + (if key + (%coerce-callable-to-function key) + #'identity)) -;;; the user interface to FIND and POSITION: Get all our ducks in a row, -;;; then call %FIND-POSITION -;;; -;;; FIXME: These should probably be (MACROLET (..) (DEF-SOURCE-TRANSFORM ..)) -;;; instead of this DEFCONSTANT silliness. -(eval-when (:compile-toplevel :execute) - (defconstant +find-fun-args+ - '(item - sequence - &key - from-end - (start 0) - end - key - test - test-not)) - (defconstant +find-fun-frob+ - '(%find-position item - sequence - from-end - start - end - (if key (%coerce-callable-to-function key) #'identity) - (%effective-find-position-test test test-not)))) -(declaim (inline find position)) -(defun find #.+find-fun-args+ - (nth-value 0 #.+find-fun-frob+)) -(defun position #.+find-fun-args+ - (nth-value 1 #.+find-fun-frob+)) - -;;; the user interface to FIND-IF and POSITION-IF, entirely analogous -;;; to the interface to FIND and POSITION -(eval-when (:compile-toplevel :execute) - (defconstant +find-if-fun-args+ - '(predicate - sequence - &key - from-end - (start 0) - end - (key #'identity))) - (defconstant +find-if-fun-frob+ - '(%find-position-if (%coerce-callable-to-function predicate) - sequence - from-end - start - end - (%coerce-callable-to-function key)))) -;;; FIXME: A running SBCL doesn't like to have its FIND-IF and -;;; POSITION-IF DEFUNed, dunno why yet.. -#| -;;(declaim (maybe-inline find-if cl-user::%position-if)) -(defun find-if #.+find-if-fun-args+ - (nth-value 0 #.+find-if-fun-frob+)) -(defun cl-user::%position-if #.+find-if-fun-args+ - (nth-value 1 #.+find-if-fun-frob+)) -(setf (symbol-function 'position-if) - #'cl-user::%position-if) -;;(declaim (inline find-if cl-user::%position-if)) -|# - -;;; the deprecated functions FIND-IF-NOT and POSITION-IF-NOT -(defun find-if-not (predicate sequence &key from-end (start 0) end key) - (nth-value 0 (%find-position-if (complement (%coerce-callable-to-function - predicate)) - sequence from-end start end key))) -(defun position-if-not (predicate sequence &key from-end (start 0) end key) - (nth-value 1 (%find-position-if (complement (%coerce-callable-to-function - predicate)) - sequence from-end start end key))) -;;; FIXME: Remove uses of these deprecated functions, and of :TEST-NOT too. - +;;; shared guts of out-of-line FIND, POSITION, FIND-IF, and POSITION-IF (macrolet (;; shared logic for defining %FIND-POSITION and ;; %FIND-POSITION-IF in terms of various inlineable cases ;; of the expression defined in FROB and VECTOR*-FROB @@ -275,3 +221,65 @@ `(%find-position-if-vector-macro predicate ,sequence from-end start end key))) (frobs)))) + +;;; the user interface to FIND and POSITION: Get all our ducks in a row, +;;; then call %FIND-POSITION +(declaim (inline find position)) +(macrolet ((def-find-position (fun-name values-index) + `(defun ,fun-name (item + sequence + &key + from-end + (start 0) + end + key + test + test-not) + (nth-value + ,values-index + (%find-position item + sequence + from-end + start + end + (effective-find-position-key key) + (effective-find-position-test test + test-not)))))) + (def-find-position find 0) + (def-find-position position 1)) + +;;; the user interface to FIND-IF and POSITION-IF, entirely analogous +;;; to the interface to FIND and POSITION +(declaim (inline find-if position-if)) +(macrolet ((def-find-position-if (fun-name values-index) + `(defun ,fun-name (predicate sequence + &key from-end (start 0) end key) + (nth-value + ,values-index + (%find-position-if (%coerce-callable-to-function predicate) + sequence + from-end + start + end + (effective-find-position-key key)))))) + + (def-find-position-if find-if 0) + (def-find-position-if position-if 1)) + +;;; the deprecated functions FIND-IF-NOT and POSITION-IF-NOT +(macrolet ((def-find-position-if-not (fun-name values-index) + `(defun ,fun-name (predicate sequence + &key from-end (start 0) end key) + (nth-value + ,values-index + (%find-position-if (complement (%coerce-callable-to-function + predicate)) + sequence + from-end + start + end + (effective-find-position-key key)))))) + (def-find-position-if-not find-if-not 0) + (def-find-position-if-not position-if-not 1)) +;;; FIXME: Remove uses of these deprecated functions, and of :TEST-NOT too. + diff --git a/contrib/compiler-extras.lisp b/contrib/compiler-extras.lisp index 14c9c6541..d04a308ab 100644 --- a/contrib/compiler-extras.lisp +++ b/contrib/compiler-extras.lisp @@ -30,6 +30,58 @@ (declaim (optimize (speed 1) (space 2))) +;;; This checks to see whether the array is simple and the start and +;;; end are in bounds. If so, it proceeds with those values. +;;; Otherwise, it calls %WITH-ARRAY-DATA. Note that %WITH-ARRAY-DATA +;;; may be further optimized. +;;; +;;; Given any ARRAY, bind DATA-VAR to the array's data vector and +;;; START-VAR and END-VAR to the start and end of the designated +;;; portion of the data vector. SVALUE and EVALUE are any start and +;;; end specified to the original operation, and are factored into the +;;; bindings of START-VAR and END-VAR. OFFSET-VAR is the cumulative +;;; offset of all displacements encountered, and does not include +;;; SVALUE. +;;; +;;; When FORCE-INLINE is set, the underlying %WITH-ARRAY-DATA form is +;;; forced to be inline, overriding the ordinary judgment of the +;;; %WITH-ARRAY-DATA DEFTRANSFORMs. Ordinarily the DEFTRANSFORMs are +;;; fairly picky about their arguments, figuring that if you haven't +;;; bothered to get all your ducks in a row, you probably don't care +;;; that much about speed anyway! But in some cases it makes sense to +;;; do type testing inside %WITH-ARRAY-DATA instead of outside, and +;;; the DEFTRANSFORM can't tell that that's going on, so it can make +;;; sense to use FORCE-INLINE option in that case. +(defmacro with-array-data (((data-var array &key offset-var) + (start-var &optional (svalue 0)) + (end-var &optional (evalue nil)) + &key force-inline) + &body forms) + (once-only ((n-array array) + (n-svalue `(the index ,svalue)) + (n-evalue `(the (or index null) ,evalue))) + `(multiple-value-bind (,data-var + ,start-var + ,end-var + ,@(when offset-var `(,offset-var))) + (if (not (array-header-p ,n-array)) + (let ((,n-array ,n-array)) + (declare (type (simple-array * (*)) ,n-array)) + ,(once-only ((n-len `(length ,n-array)) + (n-end `(or ,n-evalue ,n-len))) + `(if (<= ,n-svalue ,n-end ,n-len) + ;; success + (values ,n-array ,n-svalue ,n-end 0) + ;; failure: Make a NOTINLINE call to + ;; %WITH-ARRAY-DATA with our bad data + ;; to cause the error to be signalled. + (locally + (declare (notinline %with-array-data)) + (%with-array-data ,n-array ,n-svalue ,n-evalue))))) + (,(if force-inline '%with-array-data-macro '%with-array-data) + ,n-array ,n-svalue ,n-evalue)) + ,@forms))) + ;;; This is the fundamental definition of %WITH-ARRAY-DATA, for use in ;;; DEFTRANSFORMs and DEFUNs. (defmacro %with-array-data-macro (array @@ -39,7 +91,6 @@ (element-type '*) unsafe? fail-inline?) - (format t "~&/in %WITH-ARRAY-DATA-MACRO, ELEMENT-TYPE=~S~%" element-type) (let ((size (gensym "SIZE-")) (data (gensym "DATA-")) (cumulative-offset (gensym "CUMULATIVE-OFFSET-"))) @@ -92,8 +143,6 @@ :policy (> speed space)) "inline non-SIMPLE-vector-handling logic" (let ((element-type (upgraded-element-type-specifier-or-give-up array))) - (format t "~&/in DEFTRANSFORM %WITH-ARRAY-DATA, ELEMENT-TYPE=~S~%" - element-type) `(%with-array-data-macro array start end :unsafe? ,(policy node (= safety 0)) :element-type ,element-type))) @@ -182,7 +231,6 @@ (setf (function-info-transforms (info :function :info 'coerce)) nil) (deftransform coerce ((x type) (* *) * :when :both) - (format t "~&/looking at DEFTRANSFORM COERCE~%") (unless (constant-continuation-p type) (give-up-ir1-transform)) (let ((tspec (specifier-type (continuation-value type)))) @@ -314,14 +362,9 @@ (end (gensym "END-"))) `(let ((,n-sequence ,sequence-arg) (,n-end ,end-arg)) - ;;(format t "~&/n-sequence=~S~%" ,n-sequence) - ;;(format t "~&/simplicity=~S~%" (typep ,n-sequence 'simple-array)) - ;;(describe ,n-sequence) (with-array-data ((,sequence ,n-sequence :offset-var ,offset) (,start ,start) (,end (or ,n-end (length ,n-sequence)))) - ;;(format t "~&sequence=~S~%start=~S~%end=~S~%" ,sequence ,start ,end) - ;;(format t "~&/n-sequence=~S~%" ,n-sequence) (block ,block (macrolet ((maybe-return () '(let ((,element (aref ,sequence ,index))) diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index c15321e1e..70d4cecc0 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -1927,7 +1927,7 @@ (prev-link exit value-cont) (use-continuation exit (second found)))) -;;; Return a list of the segments of a tagbody. Each segment looks +;;; Return a list of the segments of a TAGBODY. Each segment looks ;;; like (
* (go )). That is, we break up the ;;; tagbody into segments of non-tag statements, and explicitly ;;; represent the drop-through with a GO. The first segment has a @@ -1939,7 +1939,7 @@ (collect ((segments)) (let ((current (cons nil body))) (loop - (let ((tag-pos (position-if-not #'listp current :start 1))) + (let ((tag-pos (position-if (complement #'listp) current :start 1))) (unless tag-pos (segments `(,@current nil)) (return)) diff --git a/version.lisp-expr b/version.lisp-expr index fbc5ba256..539075792 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -15,4 +15,4 @@ ;;; versions, and a string like "0.6.5.12" is used for versions which ;;; aren't released but correspond only to CVS tags or snapshots. -"0.6.9.22" +"0.6.9.23"