From ecad36c71e99fa4155b80af8bed38d02b9bdb83d Mon Sep 17 00:00:00 2001 From: Alexey Dejneka Date: Fri, 6 Jun 2003 09:09:12 +0000 Subject: [PATCH] 0.8.0.39: * Convert proclaimed function result type into a type check. ... recanned several incautious worms. --- BUGS | 57 -------------------------------------- src/code/array.lisp | 4 ++- src/code/irrat.lisp | 2 +- src/code/target-pathname.lisp | 23 +++++++-------- src/compiler/ctype.lisp | 16 +++++------ src/compiler/fndb.lisp | 9 +++--- src/compiler/ir1tran-lambda.lisp | 2 +- src/compiler/srctran.lisp | 2 +- version.lisp-expr | 2 +- 9 files changed, 29 insertions(+), 88 deletions(-) diff --git a/BUGS b/BUGS index 95fa250..1d1a83d 100644 --- a/BUGS +++ b/BUGS @@ -722,63 +722,6 @@ WORKAROUND: :ACCRUED-EXCEPTIONS (:INEXACT) :FAST-MODE NIL) -187: "type inference confusion around DEFTRANSFORM time" - (reported even more verbosely on sbcl-devel 2002-06-28 as "strange - bug in DEFTRANSFORM") - After the file below is compiled and loaded in sbcl-0.7.5, executing - (TCX (MAKE-ARRAY 4 :FILL-POINTER 2) 0) - at the REPL returns an adjustable vector, which is wrong. Presumably - somehow the DERIVE-TYPE information for the output values of %WAD is - being mispropagated as a type constraint on the input values of %WAD, - and so causing the type test to be optimized away. It's unclear how - hand-expanding the DEFTRANSFORM would change this, but it suggests - the DEFTRANSFORM machinery (or at least the way DEFTRANSFORMs are - invoked at a particular phase) is involved. - (cl:in-package :sb-c) - (eval-when (:compile-toplevel) - ;;; standin for %DATA-VECTOR-AND-INDEX - (defknown %dvai (array index) - (values t t) - (foldable flushable)) - (deftransform %dvai ((array index) - (vector t) - * - :important t) - (let* ((atype (continuation-type array)) - (eltype (array-type-specialized-element-type atype))) - (when (eq eltype *wild-type*) - (give-up-ir1-transform - "specialized array element type not known at compile-time")) - (when (not (array-type-complexp atype)) - (give-up-ir1-transform "SIMPLE array!")) - `(if (array-header-p array) - (%wad array index nil) - (values array index)))) - ;;; standin for %WITH-ARRAY-DATA - (defknown %wad (array index (or index null)) - (values (simple-array * (*)) index index index) - (foldable flushable)) - ;;; (Commenting out this optimizer causes the bug to go away.) - (defoptimizer (%wad derive-type) ((array start end)) - (let ((atype (continuation-type array))) - (when (array-type-p atype) - (values-specifier-type - `(values (simple-array ,(type-specifier - (array-type-specialized-element-type atype)) - (*)) - index index index))))) - ) ; EVAL-WHEN - (defun %wad (array start end) - (format t "~&in %WAD~%") - (%with-array-data array start end)) - (cl:in-package :cl-user) - (defun tcx (v i) - (declare (type (vector t) v)) - (declare (notinline sb-kernel::%with-array-data)) - ;; (Hand-expending DEFTRANSFORM %DVAI here also causes the bug to - ;; go away.) - (sb-c::%dvai v i)) - 188: "compiler performance fiasco involving type inference and UNION-TYPE" (In sbcl-0.7.6.10, DEFTRANSFORM CONCATENATE was commented out until this bug could be fixed properly, so you won't see the bug unless you restore diff --git a/src/code/array.lisp b/src/code/array.lisp index 3993a91..2b817a3 100644 --- a/src/code/array.lisp +++ b/src/code/array.lisp @@ -51,7 +51,9 @@ (defun %data-vector-and-index (array index) (if (array-header-p array) - (%with-array-data array index nil) + (multiple-value-bind (vector index) + (%with-array-data array index nil) + (values vector index)) (values array index))) ;;; It'd waste space to expand copies of error handling in every diff --git a/src/code/irrat.lisp b/src/code/irrat.lisp index fe13620..68e5d9f 100644 --- a/src/code/irrat.lisp +++ b/src/code/irrat.lisp @@ -296,7 +296,7 @@ "Return the logarithm of NUMBER in the base BASE, which defaults to e." (if base-p (cond - ((zerop base) base) ; ANSI spec + ((zerop base) 0f0) ; FIXME: type ((and (typep number '(integer (0) *)) (typep base '(integer (0) *))) (coerce (/ (log2 number) (log2 base)) 'single-float)) diff --git a/src/code/target-pathname.lisp b/src/code/target-pathname.lisp index e7de625..c76ee42 100644 --- a/src/code/target-pathname.lisp +++ b/src/code/target-pathname.lisp @@ -817,8 +817,7 @@ a host-structure or string." (defun namestring (pathname) #!+sb-doc "Construct the full (name)string form of the pathname." - (declare (type pathname-designator pathname) - (values (or null simple-base-string))) + (declare (type pathname-designator pathname)) (with-pathname (pathname pathname) (when pathname (let ((host (%pathname-host pathname))) @@ -830,8 +829,7 @@ a host-structure or string." (defun host-namestring (pathname) #!+sb-doc "Return a string representation of the name of the host in the pathname." - (declare (type pathname-designator pathname) - (values (or null simple-base-string))) + (declare (type pathname-designator pathname)) (with-pathname (pathname pathname) (let ((host (%pathname-host pathname))) (if host @@ -843,8 +841,7 @@ a host-structure or string." (defun directory-namestring (pathname) #!+sb-doc "Return a string representation of the directories used in the pathname." - (declare (type pathname-designator pathname) - (values (or null simple-base-string))) + (declare (type pathname-designator pathname)) (with-pathname (pathname pathname) (let ((host (%pathname-host pathname))) (if host @@ -856,8 +853,7 @@ a host-structure or string." (defun file-namestring (pathname) #!+sb-doc "Return a string representation of the name used in the pathname." - (declare (type pathname-designator pathname) - (values (or null simple-base-string))) + (declare (type pathname-designator pathname)) (with-pathname (pathname pathname) (let ((host (%pathname-host pathname))) (if host @@ -1429,11 +1425,12 @@ a host-structure or string." ;; DEF-DIRECTORY is :ABSOLUTE, as handled above. so return ;; the original directory. path-directory)))) - (make-pathname :host (pathname-host pathname) - :directory enough-directory - :name (pathname-name pathname) - :type (pathname-type pathname) - :version (pathname-version pathname)))) + (unparse-logical-namestring + (make-pathname :host (pathname-host pathname) + :directory enough-directory + :name (pathname-name pathname) + :type (pathname-type pathname) + :version (pathname-version pathname))))) (defun unparse-logical-namestring (pathname) (declare (type logical-pathname pathname)) diff --git a/src/compiler/ctype.lisp b/src/compiler/ctype.lisp index d58a2af..d331db6 100644 --- a/src/compiler/ctype.lisp +++ b/src/compiler/ctype.lisp @@ -725,23 +725,21 @@ (find-lambda-types functional type where)))) (let* ((type-returns (fun-type-returns type)) (return (lambda-return (main-entry functional))) - (atype (when return - nil - #+nil(continuation-derived-type (return-result return))))) ; !! + (dtype (when return + (continuation-derived-type (return-result return))))) (cond - ((and atype (not (values-types-equal-or-intersect atype + ((and dtype (not (values-types-equal-or-intersect dtype type-returns))) (note-lossage "The result type from ~A:~% ~S~@ - conflicts with the definition's result type assertion:~% ~S" - where (type-specifier type-returns) (type-specifier atype)) + conflicts with the definition's result type:~% ~S" + where (type-specifier type-returns) (type-specifier dtype)) nil) (*lossage-detected* nil) ((not really-assert) t) (t - (when atype - (assert-continuation-type (return-result return) atype - (lexenv-policy (functional-lexenv functional)))) + (assert-continuation-type (return-result return) type-returns + (lexenv-policy (functional-lexenv functional))) (loop for var in vars and type in types do (cond ((basic-var-sets var) (when (and unwinnage-fun diff --git a/src/compiler/fndb.lisp b/src/compiler/fndb.lisp index 1bb7372..7112bf1 100644 --- a/src/compiler/fndb.lisp +++ b/src/compiler/fndb.lisp @@ -634,7 +634,8 @@ (defknown (stable-sort sort) (sequence callable &key (:key callable)) sequence (call) :derive-type (sequence-result-nth-arg 1)) -(defknown sb!impl::sort-vector (vector index index function (or function null)) vector +(defknown sb!impl::sort-vector (vector index index function (or function null)) + * ; SORT-VECTOR works through side-effect (call)) (defknown merge (type-specifier sequence sequence callable @@ -1065,9 +1066,9 @@ (member nil :host :device :directory :name :type :version)) - boolean + t ()) -(defknown pathname-match-p (pathname-designator pathname-designator) boolean +(defknown pathname-match-p (pathname-designator pathname-designator) t ()) (defknown translate-pathname (pathname-designator pathname-designator @@ -1131,7 +1132,7 @@ pathname-version (flushable)) (defknown (namestring file-namestring directory-namestring host-namestring) - (pathname-designator) simple-string + (pathname-designator) (or simple-string null) (unsafely-flushable)) (defknown enough-namestring (pathname-designator &optional pathname-designator) diff --git a/src/compiler/ir1tran-lambda.lisp b/src/compiler/ir1tran-lambda.lisp index c57459a..15943b7 100644 --- a/src/compiler/ir1tran-lambda.lisp +++ b/src/compiler/ir1tran-lambda.lisp @@ -47,7 +47,7 @@ ;;; Make the default keyword for a &KEY arg, checking that the keyword ;;; isn't already used by one of the VARS. -(declaim (ftype (sfunction (symbol list t) keyword) make-keyword-for-arg)) +(declaim (ftype (sfunction (symbol list t) symbol) make-keyword-for-arg)) (defun make-keyword-for-arg (symbol vars keywordify) (let ((key (if (and keywordify (not (keywordp symbol))) (keywordicate symbol) diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp index c1a53a9..124d841 100644 --- a/src/compiler/srctran.lisp +++ b/src/compiler/srctran.lisp @@ -3431,7 +3431,7 @@ (loop for i of-type index from (ash current-heap-size -1) downto 1 do (%heapify i)) - (loop + (loop (when (< current-heap-size 2) (return)) (rotatef (%elt 1) (%elt current-heap-size)) diff --git a/version.lisp-expr b/version.lisp-expr index 3ea0b99..fab9773 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.8.0.38" +"0.8.0.39" -- 1.7.10.4