From: William Harold Newman Date: Tue, 9 Jan 2001 22:13:22 +0000 (+0000) Subject: 0.6.9.22: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=41de6817aef4ccf69b0780969ad79e232c3a798c;p=sbcl.git 0.6.9.22: moved my optimization patches to contrib/ so that I can keep them under the same revision control as SBCL itself Fix declarations in host-alieneval.lisp so that DEF-ALIEN-VARIABLE will work. --- diff --git a/BUGS b/BUGS index 0e4abea..353c71a 100644 --- a/BUGS +++ b/BUGS @@ -844,6 +844,17 @@ Error in function C::GET-LAMBDA-TO-COMPILE: :ELEMENT-TYPE, but in sbcl-0.6.9 this is not defined for WITH-OUTPUT-TO-STRING. +77: + As reported by Martin Atzmueller on sbcl-devel 2000-01-09, + DEF-ALIEN-VARIABLE doesn't work. With either the example in the + old CMU CL docs, + (def-alien-variable "errno" integer) + or another test avoiding any peculiarities of modern errno-as-macro + implementations, + (def-alien-variable "from_space" integer) + in sbcl-0.6.9 the operation fails with + TYPE-ERROR in SB-KERNEL::OBJECT-NOT-TYPE-ERROR-HANDLER: + NIL is not of type SB-KERNEL:LEXENV. KNOWN BUGS RELATED TO THE IR1 INTERPRETER diff --git a/contrib/code-extras.lisp b/contrib/code-extras.lisp new file mode 100644 index 0000000..41e3954 --- /dev/null +++ b/contrib/code-extras.lisp @@ -0,0 +1,277 @@ +;;;; (See the comments at the head of the file compiler-extras.lisp.) + +(in-package "SB-IMPL") + +(declaim (optimize (speed 3) (space 1))) + +(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 +;;; _Introduction to Algorithms_ by Corman, Rivest, and Shamir. +(macrolet ((%index (x) `(truly-the index ,x)) + (%parent (i) `(ash ,i -1)) + (%left (i) `(%index (ash ,i 1))) + (%right (i) `(%index (1+ (ash ,i 1)))) + (%heapify (i) + `(do* ((i ,i) + (left (%left i) (%left i))) + ((> left current-heap-size)) + (declare (type index i left)) + (let* ((i-elt (%elt i)) + (i-key (funcall keyfun i-elt)) + (left-elt (%elt left)) + (left-key (funcall keyfun left-elt))) + (multiple-value-bind (large large-elt large-key) + (if (funcall predicate i-key left-key) + (values left left-elt left-key) + (values i i-elt i-key)) + (let ((right (%right i))) + (multiple-value-bind (largest largest-elt) + (if (> right current-heap-size) + (values large large-elt) + (let* ((right-elt (%elt right)) + (right-key (funcall keyfun right-elt))) + (if (funcall predicate large-key right-key) + (values right right-elt) + (values large large-elt)))) + (cond ((= largest i) + (return)) + (t + (setf (%elt i) largest-elt + (%elt largest) i-elt + i largest))))))))) + (%srt-vector (keyfun &optional (vtype 'vector)) + `(macrolet (;; In SBCL ca. 0.6.10, I had trouble getting + ;; type inference to propagate all the way + ;; through this tangled mess of inlining. The + ;; TRULY-THE here works around that. -- WHN + (%elt (i) + `(aref (truly-the ,',vtype vector) + (%index (+ (%index ,i) start-1))))) + (let ((start-1 (1- start)) ; Heaps prefer 1-based addressing. + (current-heap-size (- end start)) + (keyfun ,keyfun)) + (declare (type (integer -1 #.(1- most-positive-fixnum)) + start-1)) + (declare (type index current-heap-size)) + (declare (type function keyfun)) + (/noshow "doing SRT-VECTOR" keyfun) + (loop for i of-type index + from (ash current-heap-size -1) downto 1 do + (/noshow vector "about to %HEAPIFY" i) + (%heapify i)) + (loop + (/noshow current-heap-size vector) + (when (< current-heap-size 2) + (/noshow "returning") + (return)) + (/noshow "setting" current-heap-size "element to" (%elt 1)) + (rotatef (%elt 1) (%elt current-heap-size)) + (decf current-heap-size) + (%heapify 1)) + (/noshow "falling out of %SRT-VECTOR"))))) + + (declaim (inline srt-vector)) + (defun srt-vector (vector start end predicate key) + (declare (type vector vector)) + (declare (type index start end)) + (declare (type function predicate)) + (declare (type (or function null) key)) + (declare (optimize (speed 3) (safety 3) (debug 1) (space 1))) + (if (typep vector 'simple-vector) + ;; (VECTOR T) is worth optimizing for, and SIMPLE-VECTOR is + ;; what we get from (VECTOR T) inside WITH-ARRAY-DATA. + (if (null key) + ;; Special-casing the KEY=NIL case lets us avoid some + ;; function calls. + (%srt-vector #'identity simple-vector) + (%srt-vector key simple-vector)) + ;; It's hard to imagine many important applications for + ;; sorting vector types other than (VECTOR T), so we just lump + ;; them all together in one slow dynamically typed mess. + (locally + (declare (optimize (speed 2) (space 2) (inhibit-warnings 3))) + (error "stub: suppressed to hide notes") + #+nil (%srt-vector (or key #'identity)))))) + +(declaim (maybe-inline sort)) +(defun sort (sequence predicate &key key) + (let ((predicate-function (%coerce-callable-to-function predicate)) + (key-function (and key (%coerce-callable-to-function key)))) + (typecase sequence + (list (sort-list sequence predicate-function key-function)) + (vector + (with-array-data ((vector (the vector sequence)) + (start 0) + (end (length sequence))) + (srt-vector vector start end predicate-function key-function)) + (/noshow "back from SRT-VECTOR" sequence) + sequence) + (t + (error 'simple-type-error + :datum sequence + :expected-type 'sequence + :format-control "~S is not a sequence." + :format-arguments (list sequence)))))) + +(defun vector-push-extend (new-element + vector + &optional + (extension (1+ (length vector)))) + (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))) + (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)) + (declare (ignore end) (optimize (safety 0))) + (if (simple-vector-p v) ; if common special case + (setf (aref v i) new-element) + (setf (aref v i) new-element))) + old-fill-pointer)) + +;;; FIXME: should DEFUN REPLACE in terms of same expansion as +;;; DEFTRANSFORM + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; POSITION/FIND stuff + +#+sb-xc-host +(eval-when (:compile-toplevel :load-toplevel :execute) + ;; FIXME: Report seq.impure.lisp test failures to cmucl-imp@cons.org. + ;; FIXME: Add BUGS entry for the way that inline expansions offunctions + ;; like FIND cause compiler warnings when the system can't prove that + ;; 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) + (cond ((and test test-not) + (error "can't specify both :TEST and :TEST-NOT")) + (test (%coerce-callable-to-function test)) + (test-not + ;; (Without DYNAMIC-EXTENT, this is potentially horribly + ;; inefficient, but since the TEST-NOT option is deprecated + ;; anyway, we don't care.) + (complement (%coerce-callable-to-function test-not))) + (t #'eql))) + +;;; 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. + +(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 + (frobs () + `(etypecase sequence-arg + (list (frob sequence-arg from-end)) + (vector + (with-array-data ((sequence sequence-arg :offset-var offset) + (start start) + (end (or end (length sequence-arg)))) + (multiple-value-bind (f p) + (macrolet ((frob2 () '(if from-end + (frob sequence t) + (frob sequence nil)))) + (typecase sequence + (simple-vector (frob2)) + (simple-string (frob2)) + (t (vector*-frob sequence)))) + (declare (type (or index null) p)) + (values f (and p (the index (+ p offset)))))))))) + (defun %find-position (item sequence-arg from-end start end key test) + (macrolet ((frob (sequence from-end) + `(%find-position item ,sequence + ,from-end start end key test)) + (vector*-frob (sequence) + `(%find-position-vector-macro item ,sequence + from-end start end key test))) + (frobs))) + (defun %find-position-if (predicate sequence-arg from-end start end key) + (macrolet ((frob (sequence from-end) + `(%find-position-if predicate ,sequence + ,from-end start end key)) + (vector*-frob (sequence) + `(%find-position-if-vector-macro predicate ,sequence + from-end start end key))) + (frobs)))) diff --git a/contrib/compiler-extras.lisp b/contrib/compiler-extras.lisp new file mode 100644 index 0000000..14c9c65 --- /dev/null +++ b/contrib/compiler-extras.lisp @@ -0,0 +1,383 @@ +;;;; The files +;;;; compiler-extras.lisp +;;;; code-extras.lisp +;;;; hold things that I (WHN) am working on which are sufficiently +;;;; closely tied to the system that they want to be under the same +;;;; revision control, but which aren't yet ready for prime time. +;;;; +;;;; As of around sbcl-0.6.10, these are mostly performance fixes. +;;;; Fixes for logical bugs tend to go straight into the system, but +;;;; fixes for performance problems can easily introduce logical bugs, +;;;; and no one's going to thank me for replacing old slow correct +;;;; code with new fast wrong code. +;;;; +;;;; Unless you want to live *very* dangerously, you don't want to be +;;;; running these. There might be some small value to looking at +;;;; these files to see whether I'm working on optimizing something +;;;; whose performance you care about, so that you can patch it, or +;;;; write test cases for it, or pester me to release it, or whatever. + +(in-package "SB-KERNEL") +(eval-when (:compile-toplevel :load-toplevel :execute) + (export '(%with-array-data-macro + index-or-minus-1 + %find-position %find-position-vector-macro + %find-position-if %find-position-if-vector-macro))) + +(in-package "SB-C") + +(deftype index-or-minus-1 () `(integer -1 ,(1- most-positive-fixnum))) + +(declaim (optimize (speed 1) (space 2))) + +;;; This is the fundamental definition of %WITH-ARRAY-DATA, for use in +;;; DEFTRANSFORMs and DEFUNs. +(defmacro %with-array-data-macro (array + start + end + &key + (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-"))) + `(let* ((,size (array-total-size ,array)) + (,end (cond (,end + (unless (or ,unsafe? (<= ,end ,size)) + ,(if fail-inline? + `(error "End ~D is greater than total size ~D." + ,end ,size) + `(failed-%with-array-data ,array ,start ,end))) + ,end) + (t ,size)))) + (unless (or ,unsafe? (<= ,start ,end)) + ,(if fail-inline? + `(error "Start ~D is greater than end ~D." ,start ,end) + `(failed-%with-array-data ,array ,start ,end))) + (do ((,data ,array (%array-data-vector ,data)) + (,cumulative-offset 0 + (+ ,cumulative-offset + (%array-displacement ,data)))) + ((not (array-header-p ,data)) + (values (the (simple-array ,element-type 1) ,data) + (the index (+ ,cumulative-offset ,start)) + (the index (+ ,cumulative-offset ,end)) + (the index ,cumulative-offset))) + (declare (type index ,cumulative-offset)))))) + +(defun upgraded-element-type-specifier-or-give-up (continuation) + (let* ((element-ctype (extract-upgraded-element-type continuation)) + (element-type-specifier (type-specifier element-ctype))) + (if (eq element-type-specifier '*) + (give-up-ir1-transform + "upgraded array element type not known at compile time") + element-type-specifier))) + +(deftransform %with-array-data ((array start end) + ;; Note: This transform is limited to + ;; VECTOR only because I happened to + ;; create it in order to get sequence + ;; function operations to be more + ;; efficient. It might very well be + ;; reasonable to allow general ARRAY + ;; here, I just haven't tried to + ;; understand the performance issues + ;; involved. -- WHN + (vector index (or index null)) + * + :important t + :node node + :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))) + +;;; It'd waste space to expand copies of error handling in every +;;; inline %WITH-ARRAY-DATA, so we have them call this function +;;; instead. This is just a wrapper which is known never to return. +(defknown failed-%with-array-data (t t t) nil) +(defun failed-%with-array-data (array start end) + (declare (notinline %with-array-data)) + (%with-array-data array start end) + (error "internal error: shouldn't be here with valid parameters")) + +(deftransform fill ((seq item &key (start 0) (end (length seq))) + (vector t &key (:start t) (:end index)) + * + :policy (> speed space)) + "open code" + (let ((element-type (upgraded-element-type-specifier-or-give-up seq))) + `(with-array-data ((data seq) + (start start) + (end end)) + (declare (type (simple-array ,element-type 1) data)) + (do ((i start (1+ i))) + ((= i end) seq) + (declare (type index i)) + ;; WITH-ARRAY-DATA does our range checks once and for all, so + ;; it'd be wasteful to check again on every AREF. + (declare (optimize (safety 0))) + (setf (aref data i) item))))) +;;; TO DO for DEFTRANSFORM FILL: +;;; ?? This DEFTRANSFORM, and the old DEFTRANSFORMs, should only +;;; apply when SPEED > SPACE. +;;; ?? Add test cases. + +#+nil ; not tested yet.. +(deftransform replace ((seq1 seq2 &key (start1 0) end1 (start2 0) end2) + (vector vector &key + (:start1 index) (:end1 (or index null)) + (:start2 index) (:end2 (or index null))) + * + ;; This is potentially an awfully big transform + ;; (if things like (EQ SEQ1 SEQ2) aren't known + ;; at runtime). We need to make it available + ;; inline, since otherwise there's no way to do + ;; it efficiently on all array types, but it + ;; probably doesn't belong inline all the time. + :policy (> speed (1+ space))) + "open code" + (let ((et1 (upgraded-element-type-specifier-or-give-up seq1)) + (et2 (upgraded-element-type-specifier-or-give-up seq2))) + `(let* ((n-copied (min (- end1 start1) (- end2 start2))) + (effective-end1 (+ start1 n-copied))) + (if (eq seq1 seq2) + (with-array-data ((seq seq1) + (start (min start1 start2)) + (end (max end1 end2))) + (declare (type (simple-array ,et1 1) seq)) + (if (<= start1 start2) + (let ((index2 start2)) + (declare (type index index2)) + (loop for index1 of-type index + from start1 below effective-end1 do + (setf (aref seq index1) + (aref seq index2)) + (incf index2))) + (let ((index2 (1- end2))) + (declare (type (integer -2 #.most-positive-fixnum) index2)) + (loop for index1 of-type index-or-minus-1 + from (1- effective-end1) downto start1 do + (setf (aref seq index1) + (aref seq index2)) + (decf index2))))) + (with-array-data ((seq1 seq1) (start1 start1) (end1 end1)) + (declare (type (simple-array ,et1 1) seq1)) + (with-array-data ((seq2 seq2) (start2 start2) (end2 end2)) + (declare (type (simple-array ,et2 1) seq2)) + (let ((index2 start2)) + (declare (type index index2)) + (loop for index1 of-type index + from start1 below effective-end1 do + (setf (aref seq index1) + (aref seq index2)) + (incf index2)))))) + seq1))) + +(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)))) + (if (csubtypep (continuation-type x) tspec) + 'x + ;; Note: The THE here makes sure that specifiers like + ;; (SINGLE-FLOAT 0.0 1.0) can raise a TYPE-ERROR. + `(the ,(continuation-value type) + ,(cond + ((csubtypep tspec (specifier-type 'double-float)) + '(%double-float x)) + ;; FIXME: #!+long-float (t ,(error "LONG-FLOAT case needed")) + ((csubtypep tspec (specifier-type 'float)) + '(%single-float x)) + ((csubtypep tspec (specifier-type 'simple-vector)) + '(coerce-to-simple-vector x)) ; FIXME: needs DEFKNOWN return type + (t + (give-up-ir1-transform))))))) +(defun coerce-to-simple-vector (x) + (if (simple-vector-p x) + x + (replace (make-array (length x)) x))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; setting up for POSITION/FIND stuff + +(defknown %find-position + (t sequence t index sequence-end function function) + (values t (or index null)) + (flushable call)) +(defknown %find-position-if + (function sequence t index sequence-end function) + (values t (or index null)) + (call)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; POSITION, POSITION-IF, FIND, and FIND-IF proper + +;;; FIXME: Blow away old CMU CL implementation: +;;; * the section of seq.lisp with VECTOR-LOCATER-MACRO and LOCATER-TEST-NOT +;;; * matches to 'find' and 'position' in seq.lisp + +;;; We want to make sure that %FIND-POSITION is inline-expanded into +;;; %FIND-POSITION-IF only when %FIND-POSITION-IF has an inline +;;; expansion, so we factor out the condition into this function. +(defun check-inlineability-of-find-position-if (sequence from-end) + (let ((ctype (continuation-type sequence))) + (cond ((csubtypep ctype (specifier-type 'vector)) + ;; It's not worth trying to inline vector code unless we know + ;; a fair amount about it at compile time. + (upgraded-element-type-specifier-or-give-up sequence) + (unless (constant-continuation-p from-end) + (give-up-ir1-transform + "FROM-END argument value not known at compile time"))) + ((csubtypep ctype (specifier-type 'list)) + ;; Inlining on lists is generally worthwhile. + ) + (t + (give-up-ir1-transform + "sequence type not known at compile time"))))) + +;;; %FIND-POSITION-IF for LIST data +(deftransform %find-position-if ((predicate sequence from-end start end key) + (function list t t t function) + * + :policy (> speed space) + :important t) + "expand inline" + '(let ((index 0) + (find nil) + (position nil)) + (declare (type index index)) + (dolist (i sequence (values find position)) + (let ((key-i (funcall key i))) + (when (and end (>= index end)) + (return (values find position))) + (when (>= index start) + (when (funcall predicate key-i) + ;; This hack of dealing with non-NIL FROM-END for list data + ;; by iterating forward through the list and keeping track of + ;; the last time we found a match might be more screwy than + ;; what the user expects, but it seems to be allowed by the + ;; ANSI standard. (And if the user is screwy enough to ask + ;; for FROM-END behavior on list data, turnabout is fair play.) + ;; + ;; It's also not enormously efficient, calling PREDICATE and + ;; KEY more often than necessary; but all the alternatives + ;; seem to have their own efficiency problems. + (if from-end + (setf find i + position index) + (return (values i index)))))) + (incf index)))) + +;;; %FIND-POSITION for LIST data can be expanded into %FIND-POSITION-IF +;;; without loss of efficiency. (I.e., the optimizer should be able +;;; to straighten everything out.) +(deftransform %find-position ((item sequence from-end start end key test) + (t list t t t t t) + * + :policy (> speed space) + :important t) + "expand inline" + '(%find-position-if (let ((test-fun (%coerce-callable-to-function test))) + (lambda (i) + (funcall test-fun i item))) + sequence + from-end + start + end + (%coerce-callable-to-function key))) + +;;; The inline expansions for the VECTOR case are saved as macros so +;;; that we can share them between the DEFTRANSFORMs and the default +;;; cases in the DEFUNs. (This isn't needed for the LIST case, because +;;; the DEFTRANSFORMs for LIST are less choosy about when to expand.) +(defun %find-position-or-find-position-if-vector-expansion (sequence-arg + from-end + start + end-arg + element + done-p-expr) + (let ((offset (gensym "OFFSET")) + (block (gensym "BLOCK")) + (index (gensym "INDEX")) + (n-sequence (gensym "N-SEQUENCE-")) + (sequence (gensym "SEQUENCE")) + (n-end (gensym "N-END-")) + (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))) + (when ,done-p-expr + (return-from ,block + (values ,element + (- ,index ,offset))))))) + (if ,from-end + (loop for ,index + ;; (If we aren't fastidious about declaring that + ;; INDEX might be -1, then (FIND 1 #() :FROM-END T) + ;; can send us off into never-never land, since + ;; INDEX is initialized to -1.) + of-type index-or-minus-1 + from (1- ,end) downto ,start do + (maybe-return)) + (loop for ,index of-type index from ,start below ,end do + (maybe-return)))) + (values nil nil)))))) +(defmacro %find-position-vector-macro (item sequence + from-end start end key test) + (let ((element (gensym "ELEMENT"))) + (%find-position-or-find-position-if-vector-expansion + sequence + from-end + start + end + element + `(funcall ,test ,item (funcall ,key ,element))))) +(defmacro %find-position-if-vector-macro (predicate sequence + from-end start end key) + (let ((element (gensym "ELEMENT"))) + (%find-position-or-find-position-if-vector-expansion + sequence + from-end + start + end + element + `(funcall ,predicate (funcall ,key ,element))))) + +;;; %FIND-POSITION and %FIND-POSITION-IF for VECTOR data +(deftransform %find-position-if ((predicate sequence from-end start end key) + (function vector t t t function) + * + :policy (> speed space) + :important t) + "expand inline" + (check-inlineability-of-find-position-if sequence from-end) + '(%find-position-if-vector-macro predicate sequence + from-end start end key)) +(deftransform %find-position ((item sequence from-end start end key test) + (t vector t t t function function) + * + :policy (> speed space) + :important t) + "expand inline" + (check-inlineability-of-find-position-if sequence from-end) + '(%find-position-vector-macro item sequence + from-end start end key test)) diff --git a/src/code/boot-extensions.lisp b/src/code/boot-extensions.lisp index b4eabcc..63c57a9 100644 --- a/src/code/boot-extensions.lisp +++ b/src/code/boot-extensions.lisp @@ -155,13 +155,12 @@ ;;; ONCE-ONLY is a utility useful in writing source transforms and ;;; macros. It provides a concise way to wrap a LET around some code ;;; to ensure that some forms are only evaluated once. +;;; +;;; Create a LET* which evaluates each value expression, binding a +;;; temporary variable to the result, and wrapping the LET* around the +;;; result of the evaluation of BODY. Within the body, each VAR is +;;; bound to the corresponding temporary variable. (defmacro once-only (specs &body body) - #!+sb-doc - "Once-Only ({(Var Value-Expression)}*) Form* - Create a Let* which evaluates each Value-Expression, binding a temporary - variable to the result, and wrapping the Let* around the result of the - evaluation of Body. Within the body, each Var is bound to the corresponding - temporary variable." (iterate frob ((specs specs) (body body)) @@ -174,7 +173,7 @@ (let* ((name (first spec)) (exp-temp (gensym (symbol-name name)))) `(let ((,exp-temp ,(second spec)) - (,name (gensym "OO-"))) + (,name (gensym "ONCE-ONLY-"))) `(let ((,,name ,,exp-temp)) ,,(frob (rest specs) body)))))))) diff --git a/src/code/host-alieneval.lisp b/src/code/host-alieneval.lisp index adb9eff..2c7bb5c 100644 --- a/src/code/host-alieneval.lisp +++ b/src/code/host-alieneval.lisp @@ -173,14 +173,14 @@ ;;; we no longer need to make a distinction between this and ;;; %PARSE-ALIEN-TYPE. (defun parse-alien-type (type env) - (declare (type sb!kernel:lexenv env)) + (declare (type (or sb!kernel:lexenv null) env)) #!+sb-doc "Parse the list structure TYPE as an alien type specifier and return the resultant ALIEN-TYPE structure." (%parse-alien-type type env)) (defun %parse-alien-type (type env) - (declare (type sb!kernel:lexenv env)) + (declare (type (or sb!kernel:lexenv null) env)) (if (consp type) (let ((translator (info :alien-type :translator (car type)))) (unless translator @@ -199,7 +199,7 @@ (error "unknown alien type: ~S" type))))) (defun auxiliary-alien-type (kind name env) - (declare (type sb!kernel:lexenv env)) + (declare (type (or sb!kernel:lexenv null) env)) (flet ((aux-defn-matches (x) (and (eq (first x) kind) (eq (second x) name)))) (let ((in-auxiliaries @@ -216,7 +216,7 @@ (info :alien-type :enum name))))))) (defun (setf auxiliary-alien-type) (new-value kind name env) - (declare (type sb!kernel:lexenv env)) + (declare (type (or sb!kernel:lexenv null) env)) (flet ((aux-defn-matches (x) (and (eq (first x) kind) (eq (second x) name)))) (when (find-if #'aux-defn-matches *new-auxiliary-types*) @@ -930,7 +930,7 @@ (parse-alien-record-type :union name fields env)) (defun parse-alien-record-type (kind name fields env) - (declare (type sb!kernel:lexenv env)) + (declare (type (or sb!kernel:lexenv null) env)) (cond (fields (let* ((old (and name (auxiliary-alien-type kind name env))) (old-fields (and old (alien-record-type-fields old)))) diff --git a/src/code/interr.lisp b/src/code/interr.lisp index 0a97449..16a07f3 100644 --- a/src/code/interr.lisp +++ b/src/code/interr.lisp @@ -300,7 +300,7 @@ (error 'simple-error :function-name name :format-control - "invalid array index, ~D for ~S (should have been less than ~D)" + "invalid array index ~D for ~S (should be nonnegative and <~D)" :format-arguments (list index array bound))) (deferr object-not-simple-array-error (object) diff --git a/src/code/target-numbers.lisp b/src/code/target-numbers.lisp index c10c22e..6b8f6c6 100644 --- a/src/code/target-numbers.lisp +++ b/src/code/target-numbers.lisp @@ -1274,7 +1274,7 @@ "Returns the root of the nearest integer less than n which is a perfect square." (declare (type unsigned-byte n) (values unsigned-byte)) - ;; theoretically (> n 7), i.e., n-len-quarter > 0 + ;; Theoretically (> n 7), i.e., n-len-quarter > 0. (if (and (fixnump n) (<= n 24)) (cond ((> n 15) 4) ((> n 8) 3) diff --git a/src/code/unix.lisp b/src/code/unix.lisp index cb64f81..4ad861f 100644 --- a/src/code/unix.lisp +++ b/src/code/unix.lisp @@ -749,9 +749,8 @@ ,num-descriptors ,read-fds ,write-fds ,exception-fds (if timeout-secs (alien-sap (addr tv)) (int-sap 0)))))) -;;; Unix-select accepts sets of file descriptors and waits for an event +;;; UNIX-SELECT accepts sets of file descriptors and waits for an event ;;; to happen on one of them or to time out. - (defmacro num-to-fd-set (fdset num) `(if (fixnump ,num) (progn diff --git a/src/compiler/ltn.lisp b/src/compiler/ltn.lisp index e102f64..438102b 100644 --- a/src/compiler/ltn.lisp +++ b/src/compiler/ltn.lisp @@ -473,7 +473,7 @@ (defoptimizer (%unwind-protect ltn-annotate) ((escape cleanup) node ltn-policy) - (declare (ignore ltn-policy)) + ltn-policy ; a hack to effectively (DECLARE (IGNORE LTN-POLICY)) (setf (basic-combination-info node) :funny) (setf (node-tail-p node) nil)) @@ -904,7 +904,8 @@ recursive))))) (let ((*compiler-error-context* call)) (compiler-warning "recursion in known function definition~2I ~ - ~_arg types=~S" + ~_policy=~S ~_arg types=~S" + (lexenv-policy (node-lexenv call)) (mapcar (lambda (arg) (type-specifier (continuation-type arg))) diff --git a/tests/seq.impure.lisp b/tests/seq.impure.lisp index d5fd7f4..7ab6163 100644 --- a/tests/seq.impure.lisp +++ b/tests/seq.impure.lisp @@ -46,20 +46,37 @@ (vector (destructuring-bind (eltype) type-rest (if (entirely eltype) - (replace (make-array (length base-seq) - :element-type eltype - :adjustable t) - base-seq) + (let ((initial-element + (cond ((subtypep eltype 'character) + #\!) + ((subtypep eltype 'number) + 0) + (t #'error)))) + (replace (make-array + (+ (length base-seq) + (random 3)) + :element-type eltype + :fill-pointer + (length base-seq) + :initial-element + initial-element) + base-seq)) (return)))))))) (lambda-expr `(lambda (seq) ,@(when declaredness `((declare (type ,seq-type seq)))) (declare (optimize ,@optimization)) ,snippet))) + (format t "~&~S~%" lambda-expr) (multiple-value-bind (fun warnings-p failure-p) (compile nil lambda-expr) (when (or warnings-p failure-p) - (error "~@" lambda-expr)) + (error "~@" + lambda-expr warnings-p failure-p)) + (format t "~&~S ~S ~S ~S ~S~%" + base-seq snippet seq-type declaredness optimization) + (format t "~&(TYPEP SEQ 'SIMPLE-ARRAY)=~S~%" + (typep seq 'simple-array)) (unless (funcall fun seq) (error "~@" base-seq @@ -70,17 +87,23 @@ (defun for-every-seq (base-seq snippets) (dolist (snippet snippets) (for-every-seq-1 base-seq snippet))) - + +;;; a wrapper to hide declared type information from the compiler, so +;;; we don't get stopped by compiler warnings about e.g. compiling +;;; (POSITION 1 #() :KEY #'ABS) when #() has been coerced to a string. +(defun indiscriminate (fun) + (lambda (&rest rest) (apply fun rest))) + ;;; tests of FIND, POSITION, FIND-IF, and POSITION-IF (and a few for ;;; deprecated FIND-IF-NOT and POSITION-IF-NOT too) (for-every-seq #() '((null (find 1 seq)) (null (find 1 seq :from-end t)) - (null (position 1 seq :key #'abs)) + (null (position 1 seq :key (indiscriminate #'abs))) (null (position nil seq :test (constantly t))) (null (position nil seq :test nil)) (null (position nil seq :test-not nil)) - (null (find-if #'1+ seq :key #'log)) + (null (find-if #'1+ seq :key (indiscriminate #'log))) (null (position-if #'identity seq :from-end t)) (null (find-if-not #'packagep seq)) (null (position-if-not #'packagep seq :key nil)))) @@ -88,6 +111,7 @@ '((null (find 2 seq)) (find 2 seq :key #'1+) (find 1 seq :from-end t) + (null (find 1 seq :from-end t :start 1)) (null (find 0 seq :from-end t)) (eql 0 (position 1 seq :key #'abs)) (null (position nil seq :test 'equal)) @@ -103,6 +127,9 @@ (eql 2 (position 4 seq :key '1+)) (eql 2 (position 4 seq :key '1+ :from-end t)) (eql 1 (position 2 seq)) + (eql 1 (position 2 seq :start 1)) + (null (find 2 seq :start 1 :end 1)) + (eql 3 (position 2 seq :start 2)) (eql 3 (position 2 seq :key nil :from-end t)) (eql 2 (position 3 seq :test '=)) (eql 0 (position 3 seq :test-not 'equalp)) @@ -113,6 +140,9 @@ (eql 3 (position-if #'plusp seq :key #'1- :from-end t)) (eql 1 (position-if #'evenp seq)) (eql 3 (position-if #'evenp seq :from-end t)) + (eql 2 (position-if #'plusp seq :from-end nil :key '1- :start 2)) + (eql 3 (position-if #'plusp seq :from-end t :key '1- :start 2)) + (null (position-if #'plusp seq :from-end t :key '1- :start 2 :end 2)) (null (find-if-not #'plusp seq)) (eql 0 (position-if-not #'evenp seq)))) (for-every-seq "string test" @@ -131,6 +161,6 @@ (find-if #'characterp seq) (find-if #'(lambda (c) (typep c 'base-char)) seq :from-end t) (null (find-if 'upper-case-p seq)))) - + ;;; success (quit :unix-status 104) diff --git a/version.lisp-expr b/version.lisp-expr index eaf0446..fbc5ba2 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.21" +"0.6.9.22"