From 18d4de696bc5063aad026ba62be613c7b07f5fc8 Mon Sep 17 00:00:00 2001 From: William Harold Newman Date: Wed, 8 Aug 2001 22:46:16 +0000 Subject: [PATCH] 0.pre7.5: moved remaining contrib/*-extras.lisp stuff to main system deleted unused *CHAR=-FUNCTIONS* Since some of the new transforms use LOOP, and are used in cross-compilation, it'd be nice if LOOP worked more correctly in cross-compilation.. ..changed SUBTYPEP to SB!XC:SUBTYPEP in loop.lisp ..changed TYPEP to SB!XC:TYPEP in loop.lisp Now that LOOP calls SB!XC:TYPEP, CROSS-TYPEP needs to be smart enough to type-expand its arguments, so that e.g. (SB!XC:TYPEP 0 'INDEX) works. moved definition of INDEX-OR-MINUS-1 type alongside INDEX deleted obsolute LOOP NODECLARE stuff miscellaneous other tidying in loop.lisp added various bug 117 workarounds so SBCL code builds without bogus WARNINGs from FIND/POSITION inline expansions --- BUGS | 32 +++- NEWS | 12 ++ contrib/code-extras.lisp | 128 ------------- contrib/compiler-extras.lisp | 199 ++----------------- package-data-list.lisp-expr | 2 + src/code/cross-type.lisp | 383 ++++++++++++++++++++----------------- src/code/defstruct.lisp | 1 + src/code/deftypes-for-target.lisp | 6 - src/code/extensions.lisp | 6 + src/code/late-target-error.lisp | 13 +- src/code/loop.lisp | 162 ++++++++-------- src/code/seq.lisp | 130 ++++++++++++- src/compiler/byte-comp.lisp | 1 + src/compiler/fndb.lisp | 8 + src/compiler/seqtran.lisp | 185 +++++++++++++++--- version.lisp-expr | 2 +- 16 files changed, 643 insertions(+), 627 deletions(-) diff --git a/BUGS b/BUGS index fb0ced3..fb6a143 100644 --- a/BUGS +++ b/BUGS @@ -1070,11 +1070,33 @@ Error in function C::GET-LAMBDA-TO-COMPILE: internal error, failed AVER: "(COMMON-LISP:EQ (SB!C::TN-ENVIRONMENT SB!C:TN) SB!C::TN-ENV)" -116: - The error message from compiling - (LAMBDA (X) (LET ((NIL 1)) X)) - is - +117: + When the compiler inline expands functions, it may be that different + kinds of return values are generated from different code branches. + E.g. an inline expansion of POSITION generates integer results + from one branch, and NIL results from another. When that inline + expansion is used in a context where only one of those results + is acceptable, e.g. + (defun foo (x) + (aref *a1* (position x *a2*))) + and the compiler can't prove that the unacceptable branch is + never taken, then bogus type mismatch warnings can be generated. + If you need to suppress the type mismatch warnings, you can + suppress the inline expansion, + (defun foo (x) + #+sbcl (declare (notinline position)) ; to suppress bug 117 bogowarnings + (aref *a1* (position x *a2*))) + or, sometimes, suppress them by declaring the result to be of an + appropriate type, + (defun foo (x) + (aref *a1* (the integer (position x *a2*)))) + + This is not a new compiler problem in 0.7.0, but the new compiler + transforms for FIND, POSITION, FIND-IF, and POSITION-IF make it + more conspicuous. If you don't need performance from these functions, + and the bogus warnings are a nuisance for you, you can return to + your pre-0.7.0 state of grace with + #+sbcl (declaim (notinline find position find-if position-if)) ; bug 117.. KNOWN BUGS RELATED TO THE IR1 INTERPRETER diff --git a/NEWS b/NEWS index ac3f413..1a3a1bf 100644 --- a/NEWS +++ b/NEWS @@ -812,6 +812,18 @@ changes in sbcl-0.6.13 relative to sbcl-0.6.12: the byte fasl file version is now equal to the ordinary fasl file version. +changes in sbcl-0.7.0 relative to sbcl-0.6.13: +* There are new compiler optimizations for various functions: FIND, + POSITION, FIND-IF, POSITION-IF, FILL, COERCE, TRUNCATE, FLOOR, and + CEILING. Mostly these should be transparent, but there's one + potentially-annoying problem (bug 117): when the compiler inline + expands the FIND/POSITION family of functions and does type + analysis on the result, it can find control paths which have + type mismatches, and when it can't prove that they're not taken, + it will issue WARNINGs about the type mismatches. It's not clear + how to make the compiler smart enough to fix this in general, but + a workaround is given in the entry for 117 in the BUGS file. + planned incompatible changes in 0.7.x: * The debugger prompt sequence now goes "5]", "5[2]", "5[3]", etc. as you get deeper into recursive calls to the debugger command loop, diff --git a/contrib/code-extras.lisp b/contrib/code-extras.lisp index fe1b715..cc14fcf 100644 --- a/contrib/code-extras.lisp +++ b/contrib/code-extras.lisp @@ -17,131 +17,3 @@ (t ..))) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;; 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, :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)) - (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))) -(defun effective-find-position-key (key) - (if key - (%coerce-callable-to-function key) - #'identity)) - -;;; 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 - (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)))) - -;;; 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 1d8ca7f..0bbee06 100644 --- a/contrib/compiler-extras.lisp +++ b/contrib/compiler-extras.lisp @@ -5,23 +5,18 @@ ;;;; 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 like living dangerously, you don't want to be running +;;;; these. But there might be some 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. ;;;; -;;;; 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 '(index-or-minus-1 - %find-position %find-position-vector-macro - %find-position-if %find-position-if-vector-macro))) +;;;; Throughout 0.6.x, these were 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 prematurely replacing old slow +;;;; correct code with new fast code that I haven't yet discovered to +;;;; be wrong. (in-package "SB-C") @@ -82,175 +77,3 @@ (aref seq index2)) (incf index2)))))) seq1))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;; 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)) - (with-array-data ((,sequence ,n-sequence :offset-var ,offset) - (,start ,start) - (,end (or ,n-end (length ,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/package-data-list.lisp-expr b/package-data-list.lisp-expr index bf2ca3e..074958c 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -914,6 +914,8 @@ is a good idea, but see SB-SYS re. blurring of boundaries." "%CLOSURE-INDEX-REF" "%COS" "%COS-QUICK" "%COSH" "%DEPOSIT-FIELD" "%DOUBLE-FLOAT" "%DPB" "%EXP" "%EXPM1" + "%FIND-POSITION" "%FIND-POSITION-VECTOR-MACRO" + "%FIND-POSITION-IF" "%FIND-POSITION-IF-VECTOR-MACRO" "%HYPOT" "%INSTANCE-SET-CONDITIONAL" "%LDB" "%LOG" "%LOGB" "%LOG10" "%LOG1P" "%LONG-FLOAT" "%MAKE-COMPLEX" "%MAKE-FUNCALLABLE-INSTANCE" "%MAKE-RATIO" diff --git a/src/code/cross-type.lisp b/src/code/cross-type.lisp index a987067..b59bd3b 100644 --- a/src/code/cross-type.lisp +++ b/src/code/cross-type.lisp @@ -25,7 +25,7 @@ ((call :initarg :call :reader cross-type-style-warning-call) (message :reader cross-type-style-warning-message - #+cmu :initarg #+cmu :message ; to stop bogus non-STYLE WARNING + #+cmu :initarg #+cmu :message ; (to stop bogus non-STYLE WARNING) )) (:report (lambda (c s) (format @@ -108,198 +108,221 @@ ;;; like SUBTYPEP: the first value for its conservative opinion (never ;;; T unless it's certain) and the second value to tell whether it's ;;; certain. -(defun cross-typep (host-object target-type) - (flet ((warn-and-give-up () - ;; We don't have to keep track of this as long as system performance - ;; is acceptable, since giving up conservatively is a safe way out. +(defun cross-typep (host-object raw-target-type) + (let ((target-type (type-expand raw-target-type))) + (flet ((warn-and-give-up () + ;; We don't have to keep track of this as long as system + ;; performance is acceptable, since giving up + ;; conservatively is a safe way out. #+nil (warn 'cross-type-giving-up-conservatively - :call `(cross-typep ,host-object ,target-type)) + :call `(cross-typep ,host-object ,raw-target-type)) (values nil nil)) - (warn-about-possible-float-info-loss () - (warn-possible-cross-type-float-info-loss - `(cross-typep ,host-object ,target-type)))) - (cond (;; Handle various SBCL-specific types which can't exist on - ;; the ANSI cross-compilation host. KLUDGE: This code will - ;; need to be tweaked by hand if the names of these types - ;; ever change, ugh! - (if (consp target-type) - (member (car target-type) - '(sb!alien:alien)) - (member target-type - '(system-area-pointer - funcallable-instance - sb!alien-internals:alien-value))) - (values nil t)) - (;; special case when TARGET-TYPE isn't a type spec, but - ;; instead a CLASS object - (typep target-type 'sb!xc::structure-class) - ;; SBCL-specific types which have an analogue specially - ;; created on the host system - (if (sb!xc:subtypep (sb!xc:class-name target-type) - 'sb!kernel::structure!object) - (values (typep host-object (sb!xc:class-name target-type)) t) - (values nil t))) - ((and (symbolp target-type) - (find-class target-type nil) - (subtypep target-type 'sb!kernel::structure!object)) - (values (typep host-object target-type) t)) - ((and (symbolp target-type) - (sb!xc:find-class target-type nil) - (sb!xc:subtypep target-type 'cl:structure-object) - (typep host-object '(or symbol number list character))) - (values nil t)) - (;; easy cases of arrays and vectors - (member target-type - '(array simple-string simple-vector string vector)) - (values (typep host-object target-type) t)) - (;; general cases of vectors - (and (not (unknown-type-p (values-specifier-type target-type))) - (sb!xc:subtypep target-type 'cl:vector)) - (if (vectorp host-object) - (warn-and-give-up) ; general case of vectors being way too hard - (values nil t))) ; but "obviously not a vector" being easy - (;; general cases of arrays - (and (not (unknown-type-p (values-specifier-type target-type))) - (sb!xc:subtypep target-type 'cl:array)) - (if (arrayp host-object) - (warn-and-give-up) ; general case of arrays being way too hard - (values nil t))) ; but "obviously not an array" being easy - ((consp target-type) - (let ((first (first target-type)) - (rest (rest target-type))) - (case first - ;; Many complex types are guaranteed to correspond exactly - ;; between any host ANSI Common Lisp and the target SBCL. - ((integer member mod rational real signed-byte unsigned-byte) - (values (typep host-object target-type) t)) - ;; Floating point types are guaranteed to correspond, - ;; too, but less exactly. - ((single-float double-float) - (cond ((floatp host-object) - (warn-about-possible-float-info-loss) - (values (typep host-object target-type) t)) - (t - (values nil t)))) - ;; Some complex types have translations that are less - ;; trivial. - (and (every/type #'cross-typep host-object rest)) - (or (any/type #'cross-typep host-object rest)) - ;; If we want to work with the KEYWORD type, we need - ;; to grok (SATISFIES KEYWORDP). - (satisfies - (destructuring-bind (predicate-name) rest - (if (and (in-cl-package-p predicate-name) - (fboundp predicate-name)) - ;; Many things like KEYWORDP, ODDP, PACKAGEP, - ;; and NULL correspond between host and target. - (values (not (null (funcall predicate-name host-object))) - t) - ;; For symbols not in the CL package, it's not - ;; in general clear how things correspond - ;; between host and target, so we punt. - (warn-and-give-up)))) - ;; Some complex types are too hard to handle in the positive - ;; case, but at least we can be confident in a large fraction of - ;; the negative cases.. - ((base-string simple-base-string simple-string) - (if (stringp host-object) - (warn-and-give-up) - (values nil t))) - ((vector simple-vector) - (if (vectorp host-object) - (warn-and-give-up) - (values nil t))) - ((array simple-array) - (if (arrayp host-object) - (warn-and-give-up) - (values nil t))) - (function - (if (functionp host-object) - (warn-and-give-up) - (values nil t))) - ;; And the Common Lisp type system is complicated, and - ;; we don't try to implement everything. - (otherwise (warn-and-give-up))))) - (t - (case target-type - ((*) - ;; KLUDGE: SBCL has * as an explicit wild type. While this is - ;; sort of logical (because (e.g. (ARRAY * 1)) is a valid type) - ;; it's not ANSI: looking at the ANSI definitions of complex - ;; types like like ARRAY shows that they consider * different - ;; from other type names. Someday we should probably get rid of - ;; this non-ANSIism in base SBCL, but until we do, we might as - ;; well here in the cross compiler. And in order to make sure - ;; that we don't continue doing it after we someday patch SBCL's - ;; type system so that * is no longer a type, we make this - ;; assertion: - (aver (typep (specifier-type '*) 'named-type)) - (values t t)) - ;; Many simple types are guaranteed to correspond exactly + (warn-about-possible-float-info-loss () + (warn-possible-cross-type-float-info-loss + `(cross-typep ,host-object ,raw-target-type))) + ;; a convenient idiom for making more matches to special cases: + ;; Test both forms of target type for membership in LIST. + ;; + ;; (In order to avoid having to use too much deep knowledge + ;; of types, it's sometimes convenient to test RAW-TARGET-TYPE + ;; as well as the expanded type, since we can get matches with + ;; just EQL. E.g. SIMPLE-STRING can be matched with EQL, while + ;; safely matching its expansion, + ;; (OR (SIMPLE-ARRAY CHARACTER (*)) (SIMPLE-BASE-STRING *)) + ;; would require logic clever enough to know that, e.g., OR is + ;; commutative.) + (target-type-is-in (list) + (or (member raw-target-type list) + (member target-type list)))) + (cond (;; Handle various SBCL-specific types which can't exist on + ;; the ANSI cross-compilation host. KLUDGE: This code will + ;; need to be tweaked by hand if the names of these types + ;; ever change, ugh! + (if (consp target-type) + (member (car target-type) + '(sb!alien:alien)) + (member target-type + '(system-area-pointer + funcallable-instance + sb!alien-internals:alien-value))) + (values nil t)) + (;; special case when TARGET-TYPE isn't a type spec, but + ;; instead a CLASS object + (typep target-type 'sb!xc::structure-class) + ;; SBCL-specific types which have an analogue specially + ;; created on the host system + (if (sb!xc:subtypep (sb!xc:class-name target-type) + 'sb!kernel::structure!object) + (values (typep host-object (sb!xc:class-name target-type)) t) + (values nil t))) + ((and (symbolp target-type) + (find-class target-type nil) + (subtypep target-type 'sb!kernel::structure!object)) + (values (typep host-object target-type) t)) + ((and (symbolp target-type) + (sb!xc:find-class target-type nil) + (sb!xc:subtypep target-type 'cl:structure-object) + (typep host-object '(or symbol number list character))) + (values nil t)) + (;; easy cases of arrays and vectors + (target-type-is-in + '(array simple-string simple-vector string vector)) + (values (typep host-object target-type) t)) + (;; general cases of vectors + (and (not (unknown-type-p (values-specifier-type target-type))) + (sb!xc:subtypep target-type 'cl:vector)) + (if (vectorp host-object) + (warn-and-give-up) ; general-case vectors being way too hard + (values nil t))) ; but "obviously not a vector" being easy + (;; general cases of arrays + (and (not (unknown-type-p (values-specifier-type target-type))) + (sb!xc:subtypep target-type 'cl:array)) + (if (arrayp host-object) + (warn-and-give-up) ; general-case arrays being way too hard + (values nil t))) ; but "obviously not an array" being easy + ((target-type-is-in '(*)) + ;; KLUDGE: SBCL has * as an explicit wild type. While + ;; this is sort of logical (because (e.g. (ARRAY * 1)) is + ;; a valid type) it's not ANSI: looking at the ANSI + ;; definitions of complex types like like ARRAY shows + ;; that they consider * different from other type names. + ;; Someday we should probably get rid of this non-ANSIism + ;; in base SBCL, but until we do, we might as well here + ;; in the cross compiler. And in order to make sure that + ;; we don't continue doing it after we someday patch + ;; SBCL's type system so that * is no longer a type, we + ;; make this assertion. -- WHN 2001-08-08 + (aver (typep (specifier-type '*) 'named-type)) + (values t t)) + (;; Many simple types are guaranteed to correspond exactly ;; between any host ANSI Common Lisp and the target ;; Common Lisp. (Some array types are too, but they ;; were picked off earlier.) - ((bit character complex cons float function integer keyword - list nil null number rational real signed-byte symbol t - unsigned-byte) - (values (typep host-object target-type) t)) - ;; Floating point types are guaranteed to correspond, + (target-type-is-in + '(bit character complex cons float function integer keyword + list nil null number rational real signed-byte symbol t + unsigned-byte)) + (values (typep host-object target-type) t)) + (;; Floating point types are guaranteed to correspond, ;; too, but less exactly. - ((single-float double-float) - (cond ((floatp host-object) - (warn-about-possible-float-info-loss) - (values (typep host-object target-type) t)) - (t - (values nil t)))) - ;; Some types require translation between the cross-compilation - ;; host Common Lisp and the target SBCL. - (sb!xc:class (values (typep host-object 'sb!xc:class) t)) - (fixnum (values (fixnump host-object) t)) - ;; Some types are too hard to handle in the positive - ;; case, but at least we can be confident in a large - ;; fraction of the negative cases.. - ((base-string simple-base-string simple-string) - (if (stringp host-object) - (warn-and-give-up) - (values nil t))) - ((character base-char) - (cond ((typep host-object 'standard-char) - (values t t)) - ((not (characterp host-object)) - (values nil t)) - (t - (warn-and-give-up)))) - ((stream instance) - ;; Neither target CL:STREAM nor target - ;; SB!KERNEL:INSTANCE is implemented as a - ;; STRUCTURE-OBJECT, so they'll fall through the tests - ;; above. We don't want to assume too much about them - ;; here, but at least we know enough about them to say - ;; that neither T nor NIL nor indeed any other symbol in - ;; the cross-compilation host is one. That knowledge - ;; suffices to answer so many of the questions that the - ;; cross-compiler asks that it's well worth - ;; special-casing it here. - (if (symbolp host-object) - (values nil t) - (warn-and-give-up))) - ;; And the Common Lisp type system is complicated, and we - ;; don't try to implement everything. - (otherwise (warn-and-give-up))))))) + (target-type-is-in + '(single-float double-float)) + (cond ((floatp host-object) + (warn-about-possible-float-info-loss) + (values (typep host-object target-type) t)) + (t + (values nil t)))) + ;; Some types require translation between the cross-compilation + ;; host Common Lisp and the target SBCL. + ((target-type-is-in '(sb!xc:class)) + (values (typep host-object 'sb!xc:class) t)) + ((target-type-is-in '(fixnum)) + (values (fixnump host-object) t)) + ;; Some types are too hard to handle in the positive + ;; case, but at least we can be confident in a large + ;; fraction of the negative cases.. + ((target-type-is-in + '(base-string simple-base-string simple-string)) + (if (stringp host-object) + (warn-and-give-up) + (values nil t))) + ((target-type-is-in '(character base-char)) + (cond ((typep host-object 'standard-char) + (values t t)) + ((not (characterp host-object)) + (values nil t)) + (t + (warn-and-give-up)))) + ((target-type-is-in '(stream instance)) + ;; Neither target CL:STREAM nor target SB!KERNEL:INSTANCE + ;; is implemented as a STRUCTURE-OBJECT, so they'll fall + ;; through the tests above. We don't want to assume too + ;; much about them here, but at least we know enough + ;; about them to say that neither T nor NIL nor indeed + ;; any other symbol in the cross-compilation host is one. + ;; That knowledge suffices to answer so many of the + ;; questions that the cross-compiler asks that it's well + ;; worth special-casing it here. + (if (symbolp host-object) + (values nil t) + (warn-and-give-up))) + ;; various hacks for composite types.. + ((consp target-type) + (let ((first (first target-type)) + (rest (rest target-type))) + (case first + ;; Many complex types are guaranteed to correspond exactly + ;; between any host ANSI Common Lisp and the target SBCL. + ((integer member mod rational real signed-byte unsigned-byte) + (values (typep host-object target-type) t)) + ;; Floating point types are guaranteed to correspond, + ;; too, but less exactly. + ((single-float double-float) + (cond ((floatp host-object) + (warn-about-possible-float-info-loss) + (values (typep host-object target-type) t)) + (t + (values nil t)))) + ;; Some complex types have translations that are less + ;; trivial. + (and (every/type #'cross-typep host-object rest)) + (or (any/type #'cross-typep host-object rest)) + ;; If we want to work with the KEYWORD type, we need + ;; to grok (SATISFIES KEYWORDP). + (satisfies + (destructuring-bind (predicate-name) rest + (if (and (in-cl-package-p predicate-name) + (fboundp predicate-name)) + ;; Many things like KEYWORDP, ODDP, PACKAGEP, + ;; and NULL correspond between host and target. + (values (not (null (funcall predicate-name + host-object))) + t) + ;; For symbols not in the CL package, it's not + ;; in general clear how things correspond + ;; between host and target, so we punt. + (warn-and-give-up)))) + ;; Some complex types are too hard to handle in the + ;; positive case, but at least we can be confident in + ;; a large fraction of the negative cases.. + ((base-string simple-base-string simple-string) + (if (stringp host-object) + (warn-and-give-up) + (values nil t))) + ((vector simple-vector) + (if (vectorp host-object) + (warn-and-give-up) + (values nil t))) + ((array simple-array) + (if (arrayp host-object) + (warn-and-give-up) + (values nil t))) + (function + (if (functionp host-object) + (warn-and-give-up) + (values nil t))) + ;; And the Common Lisp type system is complicated, + ;; and we don't try to implement everything. + (otherwise (warn-and-give-up))))) + ;; And the Common Lisp type system is complicated, and + ;; we don't try to implement everything. + (t + (warn-and-give-up)))))) -;;; An incomplete TYPEP which runs at cross-compile time to tell whether OBJECT -;;; is the host Lisp representation of a target SBCL type specified by -;;; TARGET-TYPE-SPEC. It need make no pretense to completeness, since it -;;; need only handle the cases which arise when building SBCL itself, e.g. -;;; testing that range limits FOO and BAR in (INTEGER FOO BAR) are INTEGERs. +;;; This is an incomplete TYPEP which runs at cross-compile time to +;;; tell whether OBJECT is the host Lisp representation of a target +;;; SBCL type specified by TARGET-TYPE-SPEC. It need make no pretense +;;; to completeness, since it need only handle the cases which arise +;;; when building SBCL itself, e.g. testing that range limits FOO and +;;; BAR in (INTEGER FOO BAR) are INTEGERs. (defun sb!xc:typep (host-object target-type-spec &optional (env nil env-p)) (declare (ignore env)) (aver (null env-p)) ; 'cause we're too lazy to think about it (multiple-value-bind (opinion certain-p) (cross-typep host-object target-type-spec) - ;; A program that calls TYPEP doesn't want uncertainty and probably - ;; can't handle it. + ;; A program that calls TYPEP doesn't want uncertainty and + ;; probably can't handle it. (if certain-p opinion (error "uncertain in SB!XC:TYPEP ~S ~S" diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp index 40f7ba9..7b16ef2 100644 --- a/src/code/defstruct.lisp +++ b/src/code/defstruct.lisp @@ -604,6 +604,7 @@ (let* ((accname (symbolicate (or (dd-conc-name defstruct) "") name)) (existing (info :function :accessor-for accname))) + (declare (notinline find)) ; to avoid bug 117 bogowarnings (if (and (structure-class-p existing) (not (eq (sb!xc:class-name existing) (dd-name defstruct))) (string= (dsd-%name (find accname diff --git a/src/code/deftypes-for-target.lisp b/src/code/deftypes-for-target.lisp index 9efcd36..ff2401d 100644 --- a/src/code/deftypes-for-target.lisp +++ b/src/code/deftypes-for-target.lisp @@ -126,12 +126,6 @@ (sb!xc:deftype logical-host-designator () '(or host string)) -;;; like INDEX, but augmented with -1 (useful when using the index -;;; to count downwards to 0, e.g. LOOP FOR I FROM N DOWNTO 0, with -;;; an implementation which terminates the loop by testing for the -;;; index leaving the loop range) -(sb!xc:deftype index-or-minus-1 () `(integer -1 ,(1- most-positive-fixnum))) - ;;; a thing returned by the irrational functions. We assume that they ;;; never compute a rational result. (sb!xc:deftype irrational () diff --git a/src/code/extensions.lisp b/src/code/extensions.lisp index 1ea0c92..cde7c9b 100644 --- a/src/code/extensions.lisp +++ b/src/code/extensions.lisp @@ -42,6 +42,12 @@ ;;; bound because ANSI specifies it as an exclusive bound.) (def!type index () `(integer 0 (,sb!xc:array-dimension-limit))) +;;; like INDEX, but augmented with -1 (useful when using the index +;;; to count downwards to 0, e.g. LOOP FOR I FROM N DOWNTO 0, with +;;; an implementation which terminates the loop by testing for the +;;; index leaving the loop range) +(def!type index-or-minus-1 () `(integer -1 (,sb!xc:array-dimension-limit))) + ;;; the default value used for initializing character data. The ANSI ;;; spec says this is arbitrary. CMU CL used #\NULL, which we avoid ;;; because it's not in the ANSI table of portable characters. diff --git a/src/code/late-target-error.lisp b/src/code/late-target-error.lisp index 320a8c2..86732a5 100644 --- a/src/code/late-target-error.lisp +++ b/src/code/late-target-error.lisp @@ -312,14 +312,19 @@ ) ; EVAL-WHEN -;;; Compute the effective slots of class, copying inherited slots and -;;; side-effecting direct slots. +;;; Compute the effective slots of CLASS, copying inherited slots and +;;; destructively modifying direct slots. +;;; +;;; FIXME: It'd be nice to explain why it's OK to destructively modify +;;; direct slots. Presumably it follows from the semantics of +;;; inheritance and redefinition of conditions, but finding the cite +;;; and documenting it here would be good. (Or, if this is not in fact +;;; ANSI-compliant, fixing it would also be good.:-) (defun compute-effective-slots (class) (collect ((res (copy-list (condition-class-slots class)))) (dolist (sclass (condition-class-cpl class)) (dolist (sslot (condition-class-slots sclass)) - (let ((found (find (condition-slot-name sslot) (res) - :test #'eq))) + (let ((found (find (condition-slot-name sslot) (res)))) (cond (found (setf (condition-slot-initargs found) (union (condition-slot-initargs found) diff --git a/src/code/loop.lisp b/src/code/loop.lisp index bc4202a..3ffe823 100644 --- a/src/code/loop.lisp +++ b/src/code/loop.lisp @@ -248,7 +248,7 @@ constructed. (defun make-loop-minimax (answer-variable type) (let ((infinity-data (cdr (assoc type *loop-minimax-type-infinities-alist* - :test #'subtypep)))) + :test #'sb!xc:subtypep)))) (make-loop-minimax-internal :answer-variable answer-variable :type type @@ -478,109 +478,103 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. ;;;; LOOP-local variables -;;;This is the "current" pointer into the LOOP source code. +;;; This is the "current" pointer into the LOOP source code. (defvar *loop-source-code*) -;;;This is the pointer to the original, for things like NAMED that -;;;insist on being in a particular position +;;; This is the pointer to the original, for things like NAMED that +;;; insist on being in a particular position (defvar *loop-original-source-code*) -;;;This is *loop-source-code* as of the "last" clause. It is used -;;;primarily for generating error messages (see loop-error, loop-warn). +;;; This is *loop-source-code* as of the "last" clause. It is used +;;; primarily for generating error messages (see loop-error, loop-warn). (defvar *loop-source-context*) -;;;List of names for the LOOP, supplied by the NAMED clause. +;;; list of names for the LOOP, supplied by the NAMED clause (defvar *loop-names*) -;;;The macroexpansion environment given to the macro. +;;; The macroexpansion environment given to the macro. (defvar *loop-macro-environment*) -;;;This holds variable names specified with the USING clause. +;;; This holds variable names specified with the USING clause. ;;; See LOOP-NAMED-VARIABLE. (defvar *loop-named-variables*) ;;; LETlist-like list being accumulated for one group of parallel bindings. (defvar *loop-variables*) -;;;List of declarations being accumulated in parallel with -;;;*loop-variables*. +;;; list of declarations being accumulated in parallel with *LOOP-VARIABLES* (defvar *loop-declarations*) -;;;Used by LOOP for destructuring binding, if it is doing that itself. -;;; See loop-make-variable. +;;; This is used by LOOP for destructuring binding, if it is doing +;;; that itself. See LOOP-MAKE-VARIABLE. (defvar *loop-desetq-crocks*) -;;; List of wrapping forms, innermost first, which go immediately inside -;;; the current set of parallel bindings being accumulated in -;;; *loop-variables*. The wrappers are appended onto a body. E.g., -;;; this list could conceivably has as its value ((with-open-file (g0001 -;;; g0002 ...))), with g0002 being one of the bindings in -;;; *loop-variables* (this is why the wrappers go inside of the variable -;;; bindings). +;;; list of wrapping forms, innermost first, which go immediately +;;; inside the current set of parallel bindings being accumulated in +;;; *LOOP-VARIABLES*. The wrappers are appended onto a body. E.g., +;;; this list could conceivably have as its value +;;; ((WITH-OPEN-FILE (G0001 G0002 ...))), +;;; with G0002 being one of the bindings in *LOOP-VARIABLES* (This is +;;; why the wrappers go inside of the variable bindings). (defvar *loop-wrappers*) -;;;This accumulates lists of previous values of *loop-variables* and the -;;;other lists above, for each new nesting of bindings. See -;;;loop-bind-block. +;;; This accumulates lists of previous values of *LOOP-VARIABLES* and +;;; the other lists above, for each new nesting of bindings. See +;;; LOOP-BIND-BLOCK. (defvar *loop-bind-stack*) -;;;This is a LOOP-global variable for the (obsolete) NODECLARE clause -;;;which inhibits LOOP from actually outputting a type declaration for -;;;an iteration (or any) variable. -(defvar *loop-nodeclare*) - -;;;This is simply a list of LOOP iteration variables, used for checking -;;;for duplications. +;;; This is simply a list of LOOP iteration variables, used for +;;; checking for duplications. (defvar *loop-iteration-variables*) -;;;List of prologue forms of the loop, accumulated in reverse order. +;;; list of prologue forms of the loop, accumulated in reverse order (defvar *loop-prologue*) (defvar *loop-before-loop*) (defvar *loop-body*) (defvar *loop-after-body*) -;;;This is T if we have emitted any body code, so that iteration driving -;;;clauses can be disallowed. This is not strictly the same as -;;;checking *loop-body*, because we permit some clauses such as RETURN -;;;to not be considered "real" body (so as to permit the user to "code" -;;;an abnormal return value "in loop"). +;;; This is T if we have emitted any body code, so that iteration +;;; driving clauses can be disallowed. This is not strictly the same +;;; as checking *LOOP-BODY*, because we permit some clauses such as +;;; RETURN to not be considered "real" body (so as to permit the user +;;; to "code" an abnormal return value "in loop"). (defvar *loop-emitted-body*) -;;;List of epilogue forms (supplied by FINALLY generally), accumulated -;;; in reverse order. +;;; list of epilogue forms (supplied by FINALLY generally), accumulated +;;; in reverse order (defvar *loop-epilogue*) -;;;List of epilogue forms which are supplied after the above "user" -;;;epilogue. "normal" termination return values are provide by putting -;;;the return form in here. Normally this is done using -;;;loop-emit-final-value, q.v. +;;; list of epilogue forms which are supplied after the above "user" +;;; epilogue. "Normal" termination return values are provide by +;;; putting the return form in here. Normally this is done using +;;; LOOP-EMIT-FINAL-VALUE, q.v. (defvar *loop-after-epilogue*) -;;;The "culprit" responsible for supplying a final value from the loop. -;;;This is so loop-emit-final-value can moan about multiple return -;;;values being supplied. +;;; the "culprit" responsible for supplying a final value from the +;;; loop. This is so LOOP-EMIT-FINAL-VALUE can moan about multiple +;;; return values being supplied. (defvar *loop-final-value-culprit*) -;;;If not NIL, we are in some branch of a conditional. Some clauses may -;;;be disallowed. +;;; If this is true, we are in some branch of a conditional. Some +;;; clauses may be disallowed. (defvar *loop-inside-conditional*) -;;;If not NIL, this is a temporary bound around the loop for holding the -;;;temporary value for "it" in things like "when (f) collect it". It -;;;may be used as a supertemporary by some other things. +;;; If not NIL, this is a temporary bound around the loop for holding +;;; the temporary value for "it" in things like "when (f) collect it". +;;; It may be used as a supertemporary by some other things. (defvar *loop-when-it-variable*) -;;;Sometimes we decide we need to fold together parts of the loop, but -;;;some part of the generated iteration code is different for the first -;;;and remaining iterations. This variable will be the temporary which -;;;is the flag used in the loop to tell whether we are in the first or -;;;remaining iterations. +;;; Sometimes we decide we need to fold together parts of the loop, +;;; but some part of the generated iteration code is different for the +;;; first and remaining iterations. This variable will be the +;;; temporary which is the flag used in the loop to tell whether we +;;; are in the first or remaining iterations. (defvar *loop-never-stepped-variable*) -;;;List of all the value-accumulation descriptor structures in the loop. -;;; See loop-get-collection-info. -(defvar *loop-collection-cruft*) ; for multiple COLLECTs (etc) +;;; list of all the value-accumulation descriptor structures in the +;;; loop. See LOOP-GET-COLLECTION-INFO. +(defvar *loop-collection-cruft*) ; for multiple COLLECTs (etc.) ;;;; code analysis stuff @@ -589,7 +583,7 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. (when (setq constantp (constantp new-form)) (setq constant-value (eval new-form))) (when (and constantp expected-type) - (unless (typep constant-value expected-type) + (unless (sb!xc:typep constant-value expected-type) (loop-warn "The form ~S evaluated to ~S, which was not of the anticipated type ~S." form constant-value expected-type) (setq constantp nil constant-value nil))) @@ -608,10 +602,11 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. (defun loop-code-duplication-threshold (env) (declare (ignore env)) - (let (;; If we could read optimization declaration information (as with - ;; the DECLARATION-INFORMATION function (present in CLTL2, removed - ;; from ANSI standard) we could set these values flexibly. Without - ;; DECLARATION-INFORMATION, we have to set them to constants. + (let (;; If we could read optimization declaration information (as + ;; with the DECLARATION-INFORMATION function (present in + ;; CLTL2, removed from ANSI standard) we could set these + ;; values flexibly. Without DECLARATION-INFORMATION, we have + ;; to set them to constants. (speed 1) (space 1)) (+ 40 (* (- speed space) 10)))) @@ -659,7 +654,7 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. (push (pop rbefore) main-body) (pop rafter)) (unless rbefore (return (makebody))) - ;; The first forms in rbefore & rafter (which are the chronologically + ;; The first forms in RBEFORE & RAFTER (which are the chronologically ;; last forms in the list) differ, therefore they cannot be moved ;; into the main body. If everything that chronologically precedes ;; them either differs or is equal but is okay to duplicate, we can @@ -680,9 +675,10 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. ((or (not (setq inc (estimate-code-size (car bb) env))) (> (incf count inc) threshold)) ;; Ok, we have found a non-duplicatable piece of code. - ;; Everything chronologically after it must be in the central - ;; body. Everything chronologically at and after lastdiff goes - ;; into the central body under a flag test. + ;; Everything chronologically after it must be in the + ;; central body. Everything chronologically at and + ;; after LASTDIFF goes into the central body under a + ;; flag test. (let ((then nil) (else nil)) (do () (nil) (push (pop rbefore) else) @@ -695,8 +691,8 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. (push `(if ,flagvar ,(pify (psimp then)) ,(pify (psimp else))) main-body)) ;; Everything chronologically before lastdiff until the - ;; non-duplicatable form (car bb) is the same in rbefore and - ;; rafter so just copy it into the body + ;; non-duplicatable form (CAR BB) is the same in + ;; RBEFORE and RAFTER, so just copy it into the body. (do () (nil) (pop rafter) (push (pop rbefore) main-body) @@ -828,7 +824,7 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. &optional (default-type required-type)) (if (null specified-type) default-type - (multiple-value-bind (a b) (subtypep specified-type required-type) + (multiple-value-bind (a b) (sb!xc:subtypep specified-type required-type) (cond ((not b) (loop-warn "LOOP couldn't verify that ~S is a subtype of the required type ~S." specified-type required-type)) @@ -844,7 +840,6 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. (*loop-source-context* nil) (*loop-iteration-variables* nil) (*loop-variables* nil) - (*loop-nodeclare* nil) (*loop-named-variables* nil) (*loop-declarations* nil) (*loop-desetq-crocks* nil) @@ -968,8 +963,9 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. ;;;; loop types (defun loop-typed-init (data-type) - (when (and data-type (subtypep data-type 'number)) - (if (or (subtypep data-type 'float) (subtypep data-type '(complex float))) + (when (and data-type (sb!xc:subtypep data-type 'number)) + (if (or (sb!xc:subtypep data-type 'float) + (sb!xc:subtypep data-type '(complex float))) (coerce 0 data-type) 0))) @@ -1084,13 +1080,7 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. (push (list newvar initialization) *loop-variables*) ;; *LOOP-DESETQ-CROCKS* gathered in reverse order. (setq *loop-desetq-crocks* - (list* name newvar *loop-desetq-crocks*)) - ;; FIXME: We can delete this, right? - #+ignore - (loop-make-variable name - nil - dtype - iteration-variable-p))))) + (list* name newvar *loop-desetq-crocks*)))))) (t (let ((tcar nil) (tcdr nil)) (if (atom dtype) (setq tcar (setq tcdr dtype)) (setq tcar (car dtype) tcdr (cdr dtype))) @@ -1104,11 +1094,11 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. (defun loop-declare-variable (name dtype) (cond ((or (null name) (null dtype) (eq dtype t)) nil) ((symbolp name) - (unless (or (eq dtype t) (member (the symbol name) *loop-nodeclare*)) + (unless (sb!xc:subtypep t dtype) (let ((dtype (let ((init (loop-typed-init dtype))) - (if (typep init dtype) - dtype - `(or (member ,init) ,dtype))))) + (if (sb!xc:typep init dtype) + dtype + `(or (member ,init) ,dtype))))) (push `(type ,dtype ,name) *loop-declarations*)))) ((consp name) (cond ((consp dtype) @@ -1432,7 +1422,9 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. (let ((form (loop-get-form)) (type (loop-check-data-type (loop-optional-type) *loop-real-data-type*))) - (when (and (consp form) (eq (car form) 'the) (subtypep (second form) type)) + (when (and (consp form) + (eq (car form) 'the) + (sb!xc:subtypep (second form) type)) (setq type (second form))) (multiple-value-bind (number constantp value) (loop-constant-fold-if-possible form type) diff --git a/src/code/seq.lisp b/src/code/seq.lisp index ed14624..98d616e 100644 --- a/src/code/seq.lisp +++ b/src/code/seq.lisp @@ -1844,7 +1844,12 @@ (setf (aref sequence index) new) (setq count (1- count))))) -;;; locater macros used by FIND and POSITION + +;;; REMOVEME: old POSITION/FIND stuff + +#| + +;;;; locater macros used by FIND and POSITION (eval-when (:compile-toplevel :execute) @@ -2114,6 +2119,129 @@ (seq-dispatch sequence (list-find-if-not test sequence) (vector-find-if-not test sequence)))) +|# + +;;;; FIND, POSITION, and their -IF and -IF-NOT variants + +;;; 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)) + (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))) +(defun effective-find-position-key (key) + (if key + (%coerce-callable-to-function key) + #'identity)) + +;;; 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 + (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)))) + +;;; 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. We don't +;;; bother to worry about optimizing them. +;;; +;;; FIXME: Remove uses of these deprecated functions (and of :TEST-NOT +;;; too) within the implementation of SBCL. +(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)) ;;;; COUNT diff --git a/src/compiler/byte-comp.lisp b/src/compiler/byte-comp.lisp index 4c527f8..0c825be 100644 --- a/src/compiler/byte-comp.lisp +++ b/src/compiler/byte-comp.lisp @@ -784,6 +784,7 @@ ;;; we reach the mess-up node. After then, we can keep the values from ;;; being discarded by placing a marker on the simulated stack. (defun byte-stack-analyze (component) + (declare (notinline find)) ; to avoid bug 117 bogowarnings (let ((head nil)) (let ((*byte-continuation-counter* 0)) (do-blocks (block component) diff --git a/src/compiler/fndb.lisp b/src/compiler/fndb.lisp index 6439b19..b40f453 100644 --- a/src/compiler/fndb.lisp +++ b/src/compiler/fndb.lisp @@ -1301,6 +1301,14 @@ (defknown %coerce-name-to-function ((or symbol cons)) function (flushable)) (defknown %coerce-callable-to-function (callable) function (flushable)) (defknown failed-%with-array-data (t t t) nil) +(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)) ;;; Structure slot accessors or setters are magically "known" to be ;;; these functions, although the var remains the Slot-Accessor diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp index 6e39e29..d218ceb 100644 --- a/src/compiler/seqtran.lisp +++ b/src/compiler/seqtran.lisp @@ -312,35 +312,6 @@ ;; it'd be wasteful to check again on every AREF. (declare (optimize (safety 0))) (setf (aref data i) item))))) - -(deftransform position ((item list &key (test #'eql)) (t list)) - "open code" - '(do ((i 0 (1+ i)) - (l list (cdr l))) - ((endp l) nil) - (declare (type index i)) - (when (funcall test item (car l)) (return i)))) - -(deftransform position ((item vec &key (test #'eql) (start 0) - (end (length vec))) - (t simple-array &key (:start t) (:end index))) - "open code" - '(do ((i start (1+ i))) - ((= i end) nil) - (declare (type index i)) - (when (funcall test item (aref vec i)) (return i)))) - -;;; names of predicates that compute the same value as CHAR= when -;;; applied to characters -(defparameter *char=-functions* '(eql equal char=)) - -(deftransform find ((item sequence &key from-end (test #'eql) (start 0) end) - (t simple-string &rest t)) - `(if (position item sequence - ,@(when from-end `(:from-end from-end)) - :test test :start start :end end) - item - nil)) ;;;; utilities @@ -715,3 +686,159 @@ null-type) ((cons-type-p type) (cons-type-cdr-type type))))) + +;;;; FIND, POSITION, and their -IF and -IF-NOT variants + +;;; 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)) + (with-array-data ((,sequence ,n-sequence :offset-var ,offset) + (,start ,start) + (,end (or ,n-end (length ,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)))))) + +(def!macro %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))))) + +(def!macro %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/version.lisp-expr b/version.lisp-expr index dc1ba94..a5a04d4 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -16,4 +16,4 @@ ;;; four numeric fields, is used for versions which aren't released ;;; but correspond only to CVS tags or snapshots. -"0.pre7.4" +"0.pre7.5" -- 1.7.10.4