From 0979026ea99240e9a5cdda0b5580bbdc8f7b00d7 Mon Sep 17 00:00:00 2001 From: William Harold Newman Date: Wed, 14 Feb 2001 14:20:31 +0000 Subject: [PATCH] 0.6.10.17: removed LIST-FIRST arg from ANY/TYPE and EVERY/TYPE replaced MAKE-UNION-TYPE with MAKE-UNION-TYPE-OR-SOMETHING increased *COMPILER-ERROR-PRINT-FOO* values at MNA's suggestion MNA pointed out that bug 80 was fixed by his earlier patch. --- BUGS | 4 +- package-data-list.lisp-expr | 5 +- src/code/late-type.lisp | 121 +++++++++++++++++++++++++++--------------- src/code/typedefs.lisp | 38 ++++++------- src/compiler/float-tran.lisp | 4 +- src/compiler/ir1util.lisp | 12 ++--- version.lisp-expr | 2 +- 7 files changed, 111 insertions(+), 75 deletions(-) diff --git a/BUGS b/BUGS index 2afa760..a464bdb 100644 --- a/BUGS +++ b/BUGS @@ -845,9 +845,7 @@ Error in function C::GET-LAMBDA-TO-COMPILE: files and make it share the same new safe logic. 80: - The subtle CMU CL bug discussed by Douglas Thomas Crosher on - cmucl-imp@cons.org 29 Jan 2001 sounds like something that probably - still exists in the corresponding SBCL code. + (fixed early Feb 2001 by MNA) KNOWN BUGS RELATED TO THE IR1 INTERPRETER diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 64fcebc..5f7a98c 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -997,7 +997,10 @@ is a good idea, but see SB-SYS for blurring of boundaries." "MAKE-MEMBER-TYPE" "MAKE-NAMED-TYPE" "MAKE-NULL-LEXENV" "MAKE-NUMERIC-TYPE" "MAKE-SINGLE-FLOAT" "MAKE-SPECIALIZABLE-ARRAY" - "%MAKE-INSTANCE" "MAKE-UNION-TYPE" "MAKE-VALUES-TYPE" + "%MAKE-INSTANCE" + "MAKE-INTERSECTION-TYPE-OR-SOMETHING" + "MAKE-UNION-TYPE-OR-SOMETHING" + "MAKE-VALUES-TYPE" "MAYBE-GC" "MEMBER-TYPE" "MEMBER-TYPE-MEMBERS" "MEMBER-TYPE-P" "MERGE-BITS" "DEFMACRO-MUNDANELY" "MUTATOR-SELF" diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp index e61294d..1cfe57e 100644 --- a/src/code/late-type.lisp +++ b/src/code/late-type.lisp @@ -619,13 +619,13 @@ :default :vanilla))) (cond ((eq res :vanilla) (or (vanilla-union type1 type2) - (make-union-type (list type1 type2)))) + (make-union-type-or-something (list type1 type2)))) (res) (t - (make-union-type (list type1 type2))))))) + (make-union-type-or-something (list type1 type2))))))) ;;; Return as restrictive a type as we can discover that is no more -;;; restrictive than the intersection of Type1 and Type2. The second +;;; restrictive than the intersection of TYPE1 and TYPE2. The second ;;; value is true if the result is exact. At worst, we randomly return ;;; one of the arguments as the first value (trying not to return a ;;; hairy type). @@ -762,7 +762,7 @@ (values type1 nil)) (!define-type-method (hairy :complex-union) (type1 type2) - (make-union-type (list type1 type2))) + (make-union-type-or-something (list type1 type2))) (!define-type-method (hairy :simple-=) (type1 type2) (if (equal (hairy-type-specifier type1) @@ -1513,10 +1513,9 @@ t)) (!define-type-method (member :complex-subtypep-arg1) (type1 type2) - (every/type #'ctypep + (every/type (swapped-args-fun #'ctypep) type2 - (member-type-members type1) - :list-first t)) + (member-type-members type1))) ;;; We punt if the odd type is enumerable and intersects with the ;;; MEMBER type. If not enumerable, then it is definitely not a @@ -1680,10 +1679,9 @@ (!define-type-method (intersection :complex-subtypep-arg1) (type1 type2) (/show0 "entering INTERSECTION :COMPLEX-SUBTYPEP-ARG1") - (any/type #'csubtypep + (any/type (swapped-args-fun #'csubtypep) type2 - (intersection-type-types type1) - :list-first t)) + (intersection-type-types type1))) (defun intersection-complex-subtypep-arg2 (type1 type2) (every/type #'csubtypep type1 (intersection-type-types type2))) @@ -1691,27 +1689,35 @@ (/show0 "entering INTERSECTION :COMPLEX-SUBTYPEP-ARG2") (intersection-complex-subtypep-arg2 type1 type2)) -;;; Return a new type list where pairs of types whose intersections -;;; can be represented simply have been replaced by their simple -;;; representations. -(defun simplify-intersection-type-types (%types) - (/show0 "entering SIMPLE-INTERSECTION-TYPE-TYPES") - (do* ((types (copy-list %types)) ; (to undestructivize the algorithm below) - (i-types types (cdr i-types)) - (i-type (car i-types) (car i-types))) - ((null i-types)) - (do* ((pre-j-types i-types (cdr pre-j-types)) - (j-types (cdr pre-j-types) (cdr pre-j-types)) - (j-type (car j-types) (car j-types))) - ((null j-types)) - (multiple-value-bind (isect win) (type-intersection i-type j-type) - (when win - ;; Overwrite I-TYPES with the intersection, and delete - ;; J-TYPES from the list. - (setf (car i-types) isect - (cdr pre-j-types) (cdr j-types))))) - (/show0 "leaving SIMPLE-INTERSECTION-TYPE-TYPES") - types)) +;;; shared logic for unions and intersections: Return a new type list +;;; where pairs of types which can be simplified by SIMPLIFY2-FUN have +;;; been replaced by their simplified forms. +(defun simplify-types (types simplify2-fun) + (declare (type function simplify2-fun)) + (let (;; our result, accumulated as a vector + (a (make-array (length types) :fill-pointer 0))) + (dolist (%type types (coerce a 'list)) + ;; Merge TYPE into RESULT. + (iterate again ((type %type)) + (dotimes (i (length a) (vector-push-extend type a)) + (let ((ai (aref a i))) + (multiple-value-bind (simplified win?) + (funcall simplify2-fun type ai) + (when win? + (setf (aref a i) (vector-pop a)) + ;; Give the new SIMPLIFIED its own chance to be + ;; pairwise simplified w.r.t. elements of A. + (return (again simplified)))))))))) + +;;; FIXME: See FIXME note for DEFUN SIMPLIFY2-UNION. +(defun simplify2-intersection (x y) + (let ((intersection (type-intersection x y))) + (if (and (or (intersection-type-p intersection) + (hairy-type-p intersection)) + (not (intersection-type-p x)) + (not (intersection-type-p y))) + (values nil nil) + (values intersection t)))) (!define-type-method (intersection :simple-intersection :complex-intersection) (type1 type2) @@ -1734,8 +1740,8 @@ ;; could handle usefully (i.e. could without punting to HAIRY-TYPE). (/show0 "entering type translator for AND") (make-intersection-type-or-something - (simplify-intersection-type-types - (mapcar #'specifier-type type-specifiers)))) + (simplify-types (mapcar #'specifier-type type-specifiers) + #'simplify2-intersection))) |# ;;; (REMOVEME once INTERSECTION-TYPE works.) (!def-type-translator and (&whole spec &rest types) @@ -1750,10 +1756,17 @@ ;;;; union types ;;; Make a union type from the specifier types, setting ENUMERABLE in -;;; the result if all are enumerable. -(defun make-union-type (types) +;;; the result if all are enumerable; or take the easy way out if we +;;; recognize a special case which can be represented more simply. +(defun make-union-type-or-something (types) (declare (list types)) - (%make-union-type (every #'type-enumerable types) types)) + (/show0 "entering MAKE-UNION-TYPE-OR-SOMETHING") + (cond ((null types) + *empty-type*) + ((null (cdr types)) + (first types)) + (t + (%make-union-type (every #'type-enumerable types) types)))) (!define-type-class union) @@ -1791,10 +1804,9 @@ (return (values nil t))))))) (!define-type-method (union :complex-subtypep-arg1) (type1 type2) - (every/type #'csubtypep + (every/type (swapped-args-fun #'csubtypep) type2 - (union-type-types type1) - :list-first t)) + (union-type-types type1))) (defun union-complex-subtypep-arg2 (type1 type2) (any/type #'csubtypep type1 (union-type-types type2))) @@ -1807,7 +1819,7 @@ (let ((this-type type1)) (dolist (type (union-type-types type2) (if (res) - (make-union-type (cons this-type (res))) + (make-union-type-or-something (cons this-type (res))) this-type)) (cond ((eq (type-class-info type) class1) (let ((union (funcall (type-class-simple-union class1) @@ -1836,10 +1848,33 @@ (setq res (type-union res int)) (unless w (setq win nil)))))) +;;; FIXME: Obviously, this could be implemented more efficiently if it +;;; were a primitive. (Making it construct the entire result before +;;; discarding it because it turns out to be insufficiently simple is +;;; less than optimum.) A little less obviously, if it were a +;;; primitive, we could use it a lot more -- basically everywhere we +;;; do MAKE-UNION-TYPE-OR-SOMETHING. So perhaps this should become +;;; a primitive; and SIMPLIFY2-INTERSECTION, too, for the same reason. +(defun simplify2-union (x y) + (let ((union (type-union x y))) + (if (and (or (union-type-p union) + (hairy-type-p union)) + (not (union-type-p x)) + (not (union-type-p y))) + (values nil nil) + (values union t)))) + (!def-type-translator or (&rest type-specifiers) + ;; FIXME: new code -- doesn't work? + #| + (make-union-type-or-something + (simplify-types (mapcar #'specifier-type type-specifiers) + #'simplify2-union)) + |# + ;; old code (reduce #'type-union - (mapcar #'specifier-type type-specifiers) - :initial-value *empty-type*)) + (mapcar #'specifier-type type-specifiers) + :initial-value *empty-type*)) ;;;; CONS types @@ -1949,7 +1984,7 @@ (cond ((null (res)) *empty-type*) ((null (rest (res))) (first (res))) (t - (make-union-type (res))))))) + (make-union-type-or-something (res))))))) (!def-type-translator array (&optional (element-type '*) (dimensions '*)) diff --git a/src/code/typedefs.lisp b/src/code/typedefs.lisp index 2f4dc44..5695daf 100644 --- a/src/code/typedefs.lisp +++ b/src/code/typedefs.lisp @@ -91,38 +91,38 @@ ;;;; utilities -;;; Like ANY and EVERY, except that we handle two-VALUES predicate -;;; functions like SUBTYPEP. If the result is uncertain, then we -;;; return (VALUES NIL NIL). -;;; -;;; If LIST-FIRST is true, then the list element is the first arg, -;;; otherwise the second. -(defun any/type (op thing list &key list-first) +;;; sort of like ANY and EVERY, except: +;;; * We handle two-VALUES predicate functions like SUBTYPEP. (And +;;; if the result is uncertain, then we return (VALUES NIL NIL).) +;;; * THING is just an atom, and we apply OP (an arity-2 function) +;;; successively to THING and each element of LIST. +(defun any/type (op thing list) (declare (type function op)) (let ((certain? t)) (dolist (i list (values nil certain?)) (multiple-value-bind (sub-value sub-certain?) - (if list-first - (funcall op i thing) - (funcall op thing i)) + (funcall op thing i) (unless sub-certain? (setf certain? nil)) (when sub-value (return (values t t))))))) -(defun every/type (op thing list &key list-first) +(defun every/type (op thing list) (declare (type function op)) (dolist (i list (values t t)) (multiple-value-bind (sub-value sub-certain?) - (if list-first - (funcall op i thing) - (funcall op thing i)) + (funcall op thing i) (unless sub-certain? (return (values nil nil))) (unless sub-value (return (values nil t)))))) -;;; Reverse the order of arguments of a SUBTYPEP-like function. -(declaim (inline swapped/type)) -(defun swapped/type (op) - (declare (type function op)) +;;; Return a function like FUN, but expecting its (two) arguments in +;;; the opposite order that FUN does. +;;; +;;; (This looks like a sort of general utility, but currently it's +;;; used only in the implementation of the type system, so it's +;;; internal to SB-KERNEL. -- WHN 2001-02-13) +(declaim (inline swapped-args-fun)) +(defun swapped-args-fun (fun) + (declare (type function fun)) (lambda (x y) - (funcall op y x))) + (funcall fun y x))) ;;; Compute the intersection for types that intersect only when one is a ;;; hierarchical subtype of the other. diff --git a/src/compiler/float-tran.lisp b/src/compiler/float-tran.lisp index 282923c..f3d252e 100644 --- a/src/compiler/float-tran.lisp +++ b/src/compiler/float-tran.lisp @@ -913,7 +913,7 @@ (push (/-derive-type-aux x-type y-type same-arg) result))) (setf result (flatten-list result)) (if (rest result) - (make-union-type result) + (make-union-type-or-something result) (first result)))) (defoptimizer (log derive-type) ((x &optional y)) @@ -1095,7 +1095,7 @@ (rat-result-p (csubtypep element-type (specifier-type 'rational)))) (if rat-result-p - (make-union-type + (make-union-type-or-something (list element-type (specifier-type `(complex ,(numeric-type-class element-type))))) diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp index 0705907..5e407c3 100644 --- a/src/compiler/ir1util.lisp +++ b/src/compiler/ir1util.lisp @@ -1283,15 +1283,15 @@ *compiler-error-print-level* *compiler-error-print-length* *compiler-error-print-lines*)) -(defvar *compiler-error-print-level* 3 +(defvar *compiler-error-print-level* 5 #!+sb-doc - "The value for *PRINT-LEVEL* when printing compiler error messages.") -(defvar *compiler-error-print-length* 5 + "the value for *PRINT-LEVEL* when printing compiler error messages") +(defvar *compiler-error-print-length* 10 #!+sb-doc - "The value for *PRINT-LENGTH* when printing compiler error messages.") -(defvar *compiler-error-print-lines* 5 + "the value for *PRINT-LENGTH* when printing compiler error messages") +(defvar *compiler-error-print-lines* 12 #!+sb-doc - "The value for *PRINT-LINES* when printing compiler error messages.") + "the value for *PRINT-LINES* when printing compiler error messages") (defvar *enclosing-source-cutoff* 1 #!+sb-doc diff --git a/version.lisp-expr b/version.lisp-expr index 6ce9af0..5b8413c 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.10.16" +"0.6.10.17" -- 1.7.10.4