From: William Harold Newman Date: Mon, 19 Mar 2001 23:10:58 +0000 (+0000) Subject: 0.6.11.17: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=cbaa1997bb097a55d108df592ac3b7eb4a703fff;p=sbcl.git 0.6.11.17: (like the changes in 0.6.11.13, except for -UNION this time instead of -INTERSECTION) converted SIMPLE-/COMPLEX- -UNION to -UNION2 The old UNION :COMPLEX-UNION and UNION :SIMPLE-UNION methods go away in favor of TYPE-UNION and TYPE-UNION2 logic renamed old 2-arg TYPE-UNION to TYPE-UNION2, and revised it to be more like TYPE-INTERSECTION2 defined new &REST-arg TYPE-UNION similar to the &REST-arg TYPE-INTERSECTION defined in 0.6.11.13 made some old TYPE-UNION calls use &REST-arg generality MAKE-UNION-TYPE-OR-SOMETHING goes away in favor of new TYPE-UNION. VANILLA-UNION becomes HIERARCHICAL-UNION2. removed support for pre-ANSI SATISFIES types in CTYPEP --- diff --git a/BUGS b/BUGS index 8d402dc..dc96595 100644 --- a/BUGS +++ b/BUGS @@ -832,6 +832,16 @@ Error in function C::GET-LAMBDA-TO-COMPILE: but ordinary COMPILE-FILE of a file containing (DECLAIM (SPEED 0)) does not. +88: + The type system doesn't understand that the intersection of the + types (MEMBER :FOO) and (OR KEYWORD NULL) is (MEMBER :FOO). + +89: + The type system doesn't understand the the intersection of the types + KEYWORD and (OR KEYWORD NULL) is KEYWORD, perhaps because KEYWORD + is itself an intersection type and that causes technical problems + with the simplification. + KNOWN BUGS RELATED TO THE IR1 INTERPRETER diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index ee19b69..9834167 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -923,7 +923,8 @@ is a good idea, but see SB-SYS for blurring of boundaries." "CLOSED-FLAME" "CODE-COMPONENT" "CODE-COMPONENT-P" "CODE-DEBUG-INFO" "CODE-HEADER-REF" "CODE-HEADER-SET" - "CODE-INSTRUCTIONS" "COERCE-TO-BIT-VECTOR" "COERCE-TO-FUNCTION" + "CODE-INSTRUCTIONS" + "COERCE-TO-BIT-VECTOR" "COERCE-TO-FUNCTION" "COERCE-TO-LIST" "COERCE-TO-SIMPLE-STRING" "COERCE-TO-SIMPLE-VECTOR" "COERCE-TO-VECTOR" "*COLD-INIT-COMPLETE-P*" @@ -1005,7 +1006,6 @@ is a good idea, but see SB-SYS for blurring of boundaries." "MAKE-NULL-LEXENV" "MAKE-NUMERIC-TYPE" "MAKE-SINGLE-FLOAT" "MAKE-SPECIALIZABLE-ARRAY" "%MAKE-INSTANCE" - "MAKE-UNION-TYPE-OR-SOMETHING" "MAKE-VALUES-TYPE" "MAYBE-GC" "MEMBER-TYPE" "MEMBER-TYPE-MEMBERS" "MEMBER-TYPE-P" "MERGE-BITS" diff --git a/src/code/bit-bash.lisp b/src/code/bit-bash.lisp index f9611cf..4550787 100644 --- a/src/code/bit-bash.lisp +++ b/src/code/bit-bash.lisp @@ -13,17 +13,15 @@ ;;;; constants and types -(defconstant unit-bits sb!vm:word-bits - #!+sb-doc - "The number of bits to process at a time.") +;;; the number of bits to process at a time +(defconstant unit-bits sb!vm:word-bits) -(defconstant max-bits (ash most-positive-fixnum -2) - #!+sb-doc - "The maximum number of bits that can be delt with during a single call.") +;;; the maximum number of bits that can be dealt with in a single call +(defconstant max-bits (ash most-positive-fixnum -2)) -;;; FIXME: Do we really need EVAL-WHEN around these DEFTYPEs? (eval-when (:compile-toplevel :load-toplevel :execute) +;;; FIXME: Do we really need EVAL-WHEN around the DEFTYPEs? (deftype unit () `(unsigned-byte ,unit-bits)) @@ -61,12 +59,11 @@ (def-frob 32bit-logical-orc1 x y) (def-frob 32bit-logical-orc2 x y)) +;;; Shift NUMBER by the low-order bits of COUNTOID, adding zero bits +;;; at the "end" and removing bits from the "start". On big-endian +;;; machines this is a left-shift and on little-endian machines this +;;; is a right-shift. (defun shift-towards-start (number countoid) - #!+sb-doc - "Shift NUMBER by the low-order bits of COUNTOID, adding zero bits at - the ``end'' and removing bits from the ``start.'' On big-endian - machines this is a left-shift and on little-endian machines this is a - right-shift." (declare (type unit number) (fixnum countoid)) (let ((count (ldb (byte (1- (integer-length unit-bits)) 0) countoid))) (declare (type bit-offset count)) @@ -78,11 +75,10 @@ (:little-endian (ash number (- count))))))) +;;; Shift NUMBER by COUNT bits, adding zero bits at the "start" and +;;; removing bits from the "end". On big-endian machines this is a +;;; right-shift and on little-endian machines this is a left-shift. (defun shift-towards-end (number count) - #!+sb-doc - "Shift NUMBER by COUNT bits, adding zero bits at the ``start'' and removing - bits from the ``end.'' On big-endian machines this is a right-shift and - on little-endian machines this is a left-shift." (declare (type unit number) (fixnum count)) (let ((count (ldb (byte (1- (integer-length unit-bits)) 0) count))) (declare (type bit-offset count)) @@ -95,24 +91,25 @@ (ash (ldb (byte (- unit-bits count) 0) number) count)))))) #!-sb-fluid (declaim (inline start-mask end-mask fix-sap-and-offset)) + +;;; Produce a mask that contains 1's for the COUNT "start" bits and +;;; 0's for the remaining "end" bits. Only the lower 5 bits of COUNT +;;; are significant (KLUDGE: because of hardwired implicit dependence +;;; on 32-bit word size -- WHN 2001-03-19). (defun start-mask (count) - #!+sb-doc - "Produce a mask that contains 1's for the COUNT ``start'' bits and 0's for - the remaining ``end'' bits. Only the lower 5 bits of COUNT are significant." (declare (fixnum count)) (shift-towards-start (1- (ash 1 unit-bits)) (- count))) +;;; Produce a mask that contains 1's for the COUNT "end" bits and 0's +;;; for the remaining "start" bits. Only the lower 5 bits of COUNT are +;;; significant (KLUDGE: because of hardwired implicit dependence on +;;; 32-bit word size -- WHN 2001-03-19). (defun end-mask (count) - #!+sb-doc - "Produce a mask that contains 1's for the COUNT ``end'' bits and 0's for - the remaining ``start'' bits. Only the lower 5 bits of COUNT are - significant." (declare (fixnum count)) (shift-towards-end (1- (ash 1 unit-bits)) (- count))) +;;; Align the SAP to a word boundary, and update the offset accordingly. (defun fix-sap-and-offset (sap offset) - #!+sb-doc - "Align the SAP to a word boundary, and update the offset accordingly." (declare (type system-area-pointer sap) (type index offset) (values system-area-pointer index)) @@ -138,10 +135,10 @@ ;;;; DO-CONSTANT-BIT-BASH +;;; Fill DST with VALUE starting at DST-OFFSET and continuing for +;;; LENGTH bits. #!-sb-fluid (declaim (inline do-constant-bit-bash)) (defun do-constant-bit-bash (dst dst-offset length value dst-ref-fn dst-set-fn) - #!+sb-doc - "Fill DST with VALUE starting at DST-OFFSET and continuing for LENGTH bits." (declare (type offset dst-offset) (type unit value) (type function dst-ref-fn dst-set-fn)) (multiple-value-bind (dst-word-offset dst-bit-offset) diff --git a/src/code/defboot.lisp b/src/code/defboot.lisp index 4c4d897..89c3111 100644 --- a/src/code/defboot.lisp +++ b/src/code/defboot.lisp @@ -26,7 +26,7 @@ `(eval-when (:compile-toplevel :load-toplevel :execute) (setq *package* (find-undeleted-package-or-lose ',package-designator)))) -;;; MULTIPLE-VALUE-FOO +;;;; MULTIPLE-VALUE-FOO (defun list-of-symbols-p (x) (and (listp x) diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp index 4ac42bc..c48bc58 100644 --- a/src/code/defstruct.lisp +++ b/src/code/defstruct.lisp @@ -248,11 +248,13 @@ (if (class-structure-p dd) (let ((inherits (inherits-for-structure dd))) `(progn + (/noshow0 "doing CLASS-STRUCTURE-P case for DEFSTRUCT " ,name) (eval-when (:compile-toplevel :load-toplevel :execute) (%compiler-only-defstruct ',dd ',inherits)) (%defstruct ',dd ',inherits) ,@(when (eq (dd-type dd) 'structure) `((%compiler-defstruct ',dd))) + (/noshow0 "starting not-for-the-xc-host section in DEFSTRUCT") ,@(unless expanding-into-code-for-xc-host-p (append (raw-accessor-definitions dd) (predicate-definitions dd) @@ -262,8 +264,10 @@ ;(copier-definition dd) (constructor-definitions dd) (class-method-definitions dd))) + (/noshow0 "done with DEFSTRUCT " ,name) ',name)) `(progn + (/show0 "doing NOT CLASS-STRUCTURE-P case for DEFSTRUCT " ,name) (eval-when (:compile-toplevel :load-toplevel :execute) (setf (info :typed-structure :info ',name) ',dd)) ,@(unless expanding-into-code-for-xc-host-p @@ -271,6 +275,7 @@ (typed-predicate-definitions dd) (typed-copier-definitions dd) (constructor-definitions dd))) + (/noshow0 "done with DEFSTRUCT " ,name) ',name))))) (sb!xc:defmacro defstruct (name-and-options &rest slot-descriptions) diff --git a/src/code/early-defstructs.lisp b/src/code/early-defstructs.lisp index fdcc2ee..051043c 100644 --- a/src/code/early-defstructs.lisp +++ b/src/code/early-defstructs.lisp @@ -9,7 +9,11 @@ (in-package "SB!KERNEL") +(/show0 "entering early-defstructs.lisp") + #.`(progn ,@(mapcar (lambda (args) `(defstruct ,@args)) (sb-cold:read-from-file "src/code/early-defstruct-args.lisp-expr"))) + +(/show0 "done with early-defstructs.lisp") diff --git a/src/code/early-type.lisp b/src/code/early-type.lisp index 6b64686..0ae1186 100644 --- a/src/code/early-type.lisp +++ b/src/code/early-type.lisp @@ -29,7 +29,7 @@ ;;; type is defined (or redefined). (defun-cached (values-specifier-type :hash-function (lambda (x) - ;; FIXME: the THE FIXNUM stuff is + ;; FIXME: The THE FIXNUM stuff is ;; redundant in SBCL (or modern CMU ;; CL) because of type inference. (the fixnum @@ -183,8 +183,7 @@ ;;; A NUMERIC-TYPE represents any numeric type, including things ;;; such as FIXNUM. (defstruct (numeric-type (:include ctype - (class-info (type-class-or-lose - 'number))) + (class-info (type-class-or-lose 'number))) #!+negative-zero-is-not-zero (:constructor %make-numeric-type)) ;; the kind of numeric type we have, or NIL if not specified (just diff --git a/src/code/fop.lisp b/src/code/fop.lisp index 6f8cb3b..3d1df11 100644 --- a/src/code/fop.lisp +++ b/src/code/fop.lisp @@ -489,10 +489,8 @@ sb!vm:byte-bits)) res))) -;;; FOP-SIGNED-INT-VECTOR -;;; -;;; Same as FOP-INT-VECTOR, except this is for signed simple-arrays. -;;; It appears that entry 50 and 51 are clear. +;;; This is the same as FOP-INT-VECTOR, except this is for signed +;;; SIMPLE-ARRAYs. (define-fop (fop-signed-int-vector 50) (prepare-for-fast-read-byte *fasl-file* (let* ((len (fast-read-u-integer 4)) diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp index 20da765..ecf460a 100644 --- a/src/code/late-type.lisp +++ b/src/code/late-type.lisp @@ -215,7 +215,7 @@ (!define-superclasses function ((function)) !cold-init-forms) ;;; The union or intersection of two FUNCTION types is FUNCTION. -(!define-type-method (function :simple-union) (type1 type2) +(!define-type-method (function :simple-union2) (type1 type2) (declare (ignore type1 type2)) (specifier-type 'function)) (!define-type-method (function :simple-intersection2) (type1 type2) @@ -330,7 +330,7 @@ (t type))) -;;; Return the minmum number of arguments that a function can be +;;; Return the minimum number of arguments that a function can be ;;; called with, and the maximum number or NIL. If not a function ;;; type, return NIL, NIL. (defun function-type-nargs (type) @@ -414,7 +414,7 @@ ;;; This has the virtue of always keeping the VALUES type specifier ;;; outermost, and retains all of the information that is really ;;; useful for static type analysis. We want to know what is always -;;; true of each value independently. It is worthless to know that IF +;;; true of each value independently. It is worthless to know that if ;;; the first value is B0 then the second will be B1. ;;; ;;; If the VALUES count signatures differ, then we produce a result with @@ -606,27 +606,55 @@ (values (not res) t) (values nil nil)))) +;;; the type method dispatch case of TYPE-UNION2 +(defun %type-union2 (type1 type2) + ;; As in %TYPE-INTERSECTION2, it seems to be a good idea to give + ;; both argument orders a chance at COMPLEX-INTERSECTION2. Unlike + ;; %TYPE-INTERSECTION2, though, I don't have a specific case which + ;; demonstrates this is actually necessary. Also unlike + ;; %TYPE-INTERSECTION2, there seems to be no need to distinguish + ;; between not finding a method and having a method return NIL. + (flet ((1way (x y) + (let ((result (!invoke-type-method :simple-union2 :complex-union2 + x y + :default nil))) + ;; UNION2 type methods are supposed to return results + ;; which are better than just brute-forcibly smashing the + ;; terms together into UNION-TYPEs. But they're derived + ;; from old CMU CL UNION type methods which played by + ;; somewhat different rules. Here we check to make sure + ;; we don't get ambushed by diehard old-style code. + (assert (not (union-type-p result))) + result))) + (declare (inline 1way)) + (or (1way type1 type2) + (1way type2 type1)))) + ;;; Find a type which includes both types. Any inexactness is ;;; represented by the fuzzy element types; we return a single value ;;; that is precise to the best of our knowledge. This result is -;;; simplified into the canonical form, thus is not a UNION type -;;; unless there is no other way to represent the result. -(defun-cached (type-union :hash-function type-cache-hash - :hash-bits 8 - :init-wrapper !cold-init-forms) +;;; simplified into the canonical form, thus is not a UNION-TYPE +;;; unless we find no other way to represent the result. +(defun-cached (type-union2 :hash-function type-cache-hash + :hash-bits 8 + :init-wrapper !cold-init-forms) ((type1 eq) (type2 eq)) + ;; KLUDGE: This was generated from TYPE-INTERSECTION2 by Ye Olde Cut And + ;; Paste technique of programming. If it stays around (as opposed to + ;; e.g. fading away in favor of some CLOS solution) the shared logic + ;; should probably become shared code. -- WHN 2001-03-16 (declare (type ctype type1 type2)) - (if (eq type1 type2) - type1 - (let ((res (!invoke-type-method :simple-union :complex-union - type1 type2 - :default :vanilla))) - (cond ((eq res :vanilla) - (or (vanilla-union type1 type2) - (make-union-type-or-something (list type1 type2)))) - (res) - (t - (make-union-type-or-something (list type1 type2))))))) + (cond ((eq type1 type2) + type1) + ((or (union-type-p type1) + (union-type-p type2)) + ;; Unions of UNION-TYPE should have the UNION-TYPE-TYPES + ;; values broken out and united separately. The full TYPE-UNION + ;; function knows how to do this, so let it handle it. + (type-union type1 type2)) + (t + ;; the ordinary case: we dispatch to type methods + (%type-union2 type1 type2)))) ;;; the type method dispatch case of TYPE-INTERSECTION2 (defun %type-intersection2 (type1 type2) @@ -647,9 +675,20 @@ ;; ;; (Why yes, CLOS probably *would* be nicer..) (flet ((1way (x y) - (!invoke-type-method :simple-intersection2 :complex-intersection2 - x y - :default :no-type-method-found))) + (let ((result + (!invoke-type-method :simple-intersection2 + :complex-intersection2 + x y + :default :no-type-method-found))) + ;; INTERSECTION2 type methods are supposed to return + ;; results which are better than just brute-forcibly + ;; smashing the terms together into INTERSECTION-TYPEs. + ;; But they're derived from old CMU CL INTERSECTION type + ;; methods which played by somewhat different rules. Here + ;; we check to make sure we don't get ambushed by diehard + ;; old-style code. + (assert (not (intersection-type-p result))) + result))) (declare (inline 1way)) (let ((xy (1way type1 type2))) (or (and (not (eql xy :no-type-method-found)) xy) @@ -674,7 +713,7 @@ ((or (intersection-type-p type1) (intersection-type-p type2)) ;; Intersections of INTERSECTION-TYPE should have the - ;; INTERSECTION-TYPE-TYPES objects broken out and intersected + ;; INTERSECTION-TYPE-TYPES values broken out and intersected ;; separately. The full TYPE-INTERSECTION function knows how ;; to do that, so let it handle it. (type-intersection type1 type2)) @@ -742,7 +781,7 @@ ;;; SIMPLIFY2 and replacing them by their simplified forms. (defun accumulate-compound-type (type types simplify2) (declare (type ctype type)) - (declare (type (vector t) types)) + (declare (type (vector ctype) types)) (declare (type function simplify2)) (dotimes (i (length types) (vector-push-extend type types)) (let ((simplified2 (funcall simplify2 type (aref types i)))) @@ -755,48 +794,80 @@ simplify2))))) (values)) +;;; shared logic for unions and intersections: Return a vector of +;;; types representing the same types as INPUT-TYPES, but with +;;; COMPOUND-TYPEs satisfying %COMPOUND-TYPE-P broken up into their +;;; component types, and with any SIMPLY2 simplifications applied. +(defun simplified-compound-types (input-types %compound-type-p simplify2) + (let ((simplified-types (make-array (length input-types) + :fill-pointer 0 + :element-type 'ctype + ;; (This INITIAL-ELEMENT shouldn't + ;; matter, but helps avoid type + ;; warnings at compile time.) + :initial-element *empty-type*))) + (flet ((accumulate (type) + (accumulate-compound-type type simplified-types simplify2))) + (declare (inline accumulate)) + (dolist (type input-types) + (if (funcall %compound-type-p type) + (map nil #'accumulate (compound-type-types type)) + (accumulate type)))) + simplified-types)) + ;;; shared logic for unions and intersections: Make a COMPOUND-TYPE -;;; object whose components are the types in TYPES, or skip to -;;; special cases when TYPES-VECTOR is short. +;;; object whose components are the types in TYPES, or skip to special +;;; cases when TYPES is short. (defun make-compound-type-or-something (constructor types enumerable identity) (declare (type function constructor)) - (declare (type (vector t) types)) + (declare (type (vector ctype) types)) (declare (type ctype identity)) (case (length types) (0 identity) - (1 (the ctype (aref types 0))) - (t (funcall constructor enumerable (coerce types 'list))))) + (1 (aref types 0)) + (t (funcall constructor + enumerable + ;; FIXME: This should be just (COERCE TYPES 'LIST), but as + ;; of sbcl-0.6.11.17 the COERCE optimizer is really + ;; brain-dead, so that would generate a full call to + ;; SPECIFIER-TYPE at runtime, so we get into bootstrap + ;; problems in cold init because 'LIST is a compound + ;; type, so we need to MAKE-COMPOUND-TYPE-OR-SOMETHING + ;; before we know what 'LIST is. Once the COERCE + ;; optimizer is less brain-dead, we can make this + ;; (COERCE TYPES 'LIST) again. + #+sb-xc-host (coerce types 'list) + #-sb-xc-host (coerce-to-list types))))) (defun type-intersection (&rest input-types) - (let (;; components of our result, accumulated as a vector - (simplified-types (make-array (length input-types) :fill-pointer 0))) - (flet ((accumulate (type) - (accumulate-compound-type type - simplified-types - #'type-intersection2))) - (declare (inline accumulate)) - (dolist (type input-types) - (if (intersection-type-p type) - (map nil #'accumulate (intersection-type-types type)) - (accumulate type))) - ;; We want to have a canonical representation of types (or failing - ;; that, punt to HAIRY-TYPE). Canonical representation would have - ;; intersections inside unions but not vice versa, since you can - ;; always achieve that by the distributive rule. But we don't want - ;; to just apply the distributive rule, since it would be too easy - ;; to end up with unreasonably huge type expressions. So instead - ;; we punt to HAIRY-TYPE when this comes up. - (if (and (> (length simplified-types) 1) - (some #'union-type-p simplified-types)) - (make-hairy-type - :specifier `(and ,@(map 'list #'type-specifier simplified-types))) - (make-compound-type-or-something #'%make-intersection-type - simplified-types - (some #'type-enumerable - simplified-types) - *universal-type*))))) - -;;; FIXME: Define TYPE-UNION similar to TYPE-INTERSECTION. + (let ((simplified-types (simplified-compound-types input-types + #'intersection-type-p + #'type-intersection2))) + ;; We want to have a canonical representation of types (or failing + ;; that, punt to HAIRY-TYPE). Canonical representation would have + ;; intersections inside unions but not vice versa, since you can + ;; always achieve that by the distributive rule. But we don't want + ;; to just apply the distributive rule, since it would be too easy + ;; to end up with unreasonably huge type expressions. So instead + ;; we punt to HAIRY-TYPE when this comes up. + (if (and (> (length simplified-types) 1) + (some #'union-type-p simplified-types)) + (make-hairy-type + :specifier `(and ,@(map 'list #'type-specifier simplified-types))) + (make-compound-type-or-something #'%make-intersection-type + simplified-types + (some #'type-enumerable + simplified-types) + *universal-type*)))) + +(defun type-union (&rest input-types) + (let ((simplified-types (simplified-compound-types input-types + #'union-type-p + #'type-union2))) + (make-compound-type-or-something #'%make-union-type + simplified-types + (every #'type-enumerable simplified-types) + *empty-type*))) ;;;; built-in types @@ -867,6 +938,11 @@ ;;(assert (not (eq type2 *wild-type*))) ; * isn't really a type. (hierarchical-intersection2 type1 type2)) +(!define-type-method (named :complex-union2) (type1 type2) + ;; Perhaps when bug 85 is fixed this can be reenabled. + ;;(assert (not (eq type2 *wild-type*))) ; * isn't really a type. + (hierarchical-union2 type1 type2)) + (!define-type-method (named :unparse) (x) (named-type-name x)) @@ -907,9 +983,6 @@ (declare (ignore type1 type2)) nil) -(!define-type-method (hairy :complex-union) (type1 type2) - (make-union-type-or-something (list type1 type2))) - (!define-type-method (hairy :simple-=) (type1 type2) (if (equal (hairy-type-specifier type1) (hairy-type-specifier type2)) @@ -927,15 +1000,16 @@ (!def-type-translator satisfies (&whole whole fun) (declare (ignore fun)) - ;; Check legality of arguments of arguments. + ;; Check legality of arguments. (destructuring-bind (satisfies predicate-name) whole (declare (ignore satisfies)) (unless (symbolp predicate-name) (error 'simple-type-error :datum predicate-name - :expected-type symbol + :expected-type 'symbol :format-control "~S is not a symbol." :format-arguments (list predicate-name)))) + ;; Create object. (make-hairy-type :specifier whole)) ;;;; numeric types @@ -1187,7 +1261,7 @@ ;;; ;;; ### Note: we give up early to keep from dropping lots of information on ;;; the floor by returning overly general types. -(!define-type-method (number :simple-union) (type1 type2) +(!define-type-method (number :simple-union2) (type1 type2) (declare (type numeric-type type1 type2)) (cond ((csubtypep type1 type2) type2) ((csubtypep type2 type1) type1) @@ -1225,9 +1299,9 @@ (make-numeric-type :complexp :complex) (let ((type (specifier-type spec))) (unless (numeric-type-p type) - (error "Component type for Complex is not numeric: ~S." spec)) + (error "The component type for COMPLEX is not numeric: ~S" spec)) (when (eq (numeric-type-complexp type) :complex) - (error "Component type for Complex is complex: ~S." spec)) + (error "The component type for COMPLEX is complex: ~S" spec)) (let ((res (copy-numeric-type type))) (setf (numeric-type-complexp res) :complex) res)))) @@ -1698,10 +1772,10 @@ (t (make-member-type :members (members)))))))) -;;; We don't need a :COMPLEX-UNION, since the only interesting case is +;;; We don't need a :COMPLEX-UNION2, since the only interesting case is ;;; a union type, and the member/union interaction is handled by the ;;; union type method. -(!define-type-method (member :simple-union) (type1 type2) +(!define-type-method (member :simple-union2) (type1 type2) (let ((mem1 (member-type-members type1)) (mem2 (member-type-members type2))) (cond ((subsetp mem1 mem2) type2) @@ -1802,18 +1876,6 @@ ;;;; union types -;;; Make a union type from the specifier types, setting ENUMERABLE in -;;; 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)) - (cond ((null types) - *empty-type*) - ((null (cdr types)) - (first types)) - (t - (%make-union-type (every #'type-enumerable types) types)))) - (!define-type-class union) ;;; The LIST type has a special name. Other union types just get @@ -1861,32 +1923,6 @@ (!define-type-method (union :complex-subtypep-arg2) (type1 type2) (union-complex-subtypep-arg2 type1 type2)) -(!define-type-method (union :complex-union) (type1 type2) - (let ((class1 (type-class-info type1))) - (collect ((res)) - (let ((this-type type1)) - (dolist (type (union-type-types type2) - (if (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) - this-type type))) - (if union - (setq this-type union) - (res type)))) - ((csubtypep type this-type)) - ((csubtypep type1 type) (return type2)) - (t - (res type)))))))) - -;;; For the union of union types, we let the :COMPLEX-UNION method do -;;; the work. -(!define-type-method (union :simple-union) (type1 type2) - (let ((res type1)) - (dolist (t2 (union-type-types type2) res) - (setq res (type-union res t2))))) - (!define-type-method (union :simple-intersection2 :complex-intersection2) (type1 type2) ;; The CSUBTYPEP clauses here let us simplify e.g. @@ -1906,19 +1942,39 @@ ((union-complex-subtypep-arg1 type2 type1) type2) (t - (let (;; a component of TYPE2 whose intersection with TYPE1 - ;; is nonempty - (nontriv-t2 nil)) - (dolist (t2 (union-type-types type2) (or nontriv-t2 *empty-type*)) - (unless (eq *empty-type* (type-intersection type1 t2)) - (if nontriv-t2 ; if this is second nonempty intersection - (return nil) ; too many: can't find nice result - (setf nontriv-t2 t2)))))))) + (let ((accumulator *empty-type*)) + (dolist (t2 (union-type-types type2) accumulator) + (setf accumulator + (type-union2 accumulator + (type-intersection type1 t2))) + ;; When our result isn't simple any more + (when (or + ;; (TYPE-UNION2 couldn't find a sufficiently simple + ;; result, so we can't either.) + (null accumulator) + ;; (A result containing an intersection isn't + ;; sufficiently simple for us. FIXME: Maybe it + ;; should be sufficiently simple for us? + ;; UNION-TYPEs aren't supposed to be nested inside + ;; INTERSECTION-TYPEs, so if we punt with NIL, + ;; we're condemning the expression to become a + ;; HAIRY-TYPE. If it were possible for us to + ;; return an INTERSECTION-TYPE, then the + ;; INTERSECTION-TYPE-TYPES could be merged into + ;; the outer INTERSECTION-TYPE which may be under + ;; construction. E.g. if this function could + ;; return an intersection type, and the calling + ;; functions were smart enough to handle it, then + ;; we could simplify (AND (OR FIXNUM KEYWORD) + ;; SYMBOL) to KEYWORD, even though KEYWORD + ;; is an intersection type.) + (intersection-type-p accumulator)) + (return nil))))))) (!def-type-translator or (&rest type-specifiers) - (reduce #'type-union - (mapcar #'specifier-type type-specifiers) - :initial-value *empty-type*)) + (apply #'type-union + (mapcar #'specifier-type + type-specifiers))) ;;;; CONS types @@ -1953,7 +2009,7 @@ ;;; Give up if a precise type is not possible, to avoid returning ;;; overly general types. -(!define-type-method (cons :simple-union) (type1 type2) +(!define-type-method (cons :simple-union2) (type1 type2) (declare (type cons-type type1 type2)) (let ((car-type1 (cons-type-car-type type1)) (car-type2 (cons-type-car-type type2)) @@ -2013,7 +2069,6 @@ (when val (return)) (when (types-intersect x-type y-type) (return-from type-difference nil)))))) - (let ((y-mem (find-if #'member-type-p y-types))) (when y-mem (let ((members (member-type-members y-mem))) @@ -2023,11 +2078,7 @@ (multiple-value-bind (val win) (ctypep member x-type) (when (or (not win) val) (return-from type-difference nil))))))))) - - (cond ((null (res)) *empty-type*) - ((null (rest (res))) (first (res))) - (t - (make-union-type-or-something (res))))))) + (apply #'type-union (res))))) (!def-type-translator array (&optional (element-type '*) (dimensions '*)) diff --git a/src/code/loop.lisp b/src/code/loop.lisp index 018b656..affebfb 100644 --- a/src/code/loop.lisp +++ b/src/code/loop.lisp @@ -1307,9 +1307,9 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. ,specifically ,form))))) -;;;; value accumulation: aggregate booleans +;;;; value accumulation: aggregate booleans -;;; ALWAYS and NEVER +;;; handling the ALWAYS and NEVER loop keywords ;;; ;;; Under ANSI these are not permitted to appear under conditionalization. (defun loop-do-always (restrictive negate) @@ -1319,7 +1319,7 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. ,(loop-construct-return nil))) (loop-emit-final-value t))) -;;; THEREIS +;;; handling the THEREIS loop keyword ;;; ;;; Under ANSI this is not permitted to appear under conditionalization. (defun loop-do-thereis (restrictive) diff --git a/src/code/profile.lisp b/src/code/profile.lisp index 47414e0..4bb691c 100644 --- a/src/code/profile.lisp +++ b/src/code/profile.lisp @@ -260,7 +260,7 @@ consing 0 profiles 0))))) -;;; interfaces +;;;; interfaces ;;; A symbol or (SETF FOO) list names a function, a string names all ;;; the functions named by symbols in the named package. diff --git a/src/code/seq.lisp b/src/code/seq.lisp index 48c6946..730aceb 100644 --- a/src/code/seq.lisp +++ b/src/code/seq.lisp @@ -1953,7 +1953,7 @@ ) ; EVAL-WHEN -;;; POSITION +;;;; POSITION (eval-when (:compile-toplevel :execute) diff --git a/src/code/show.lisp b/src/code/show.lisp index b1ecc30..9359e54 100644 --- a/src/code/show.lisp +++ b/src/code/show.lisp @@ -101,8 +101,8 @@ #!+sb-show (sb!sys:%primitive print ,(concatenate 'simple-string "/" s))))) -(defmacro /noshow0 (s) - (declare (ignore s))) +(defmacro /noshow0 (&rest rest) + (declare (ignore rest))) ;;; low-level display of a string, works even early in cold init (defmacro /primitive-print (thing) diff --git a/src/code/target-alieneval.lisp b/src/code/target-alieneval.lisp index c0c4861..87b7f68 100644 --- a/src/code/target-alieneval.lisp +++ b/src/code/target-alieneval.lisp @@ -158,8 +158,6 @@ ;;;; runtime C values that don't correspond directly to Lisp types -;;; ALIEN-VALUE -;;; ;;; Note: The DEFSTRUCT for ALIEN-VALUE lives in a separate file ;;; 'cause it has to be real early in the cold-load order. #!-sb-fluid (declaim (freeze-type alien-value)) diff --git a/src/code/target-pathname.lisp b/src/code/target-pathname.lisp index 357d711..39dadfb 100644 --- a/src/code/target-pathname.lisp +++ b/src/code/target-pathname.lisp @@ -570,7 +570,6 @@ a host-structure or string." (%pathname-host pathname)) :lower))))) -;;; PATHNAME-TYPE (defun pathname-type (pathname &key (case :local)) #!+sb-doc "Accessor for the pathname's name." @@ -583,7 +582,6 @@ a host-structure or string." (%pathname-host pathname)) :lower))))) -;;; PATHNAME-VERSION (defun pathname-version (pathname) #!+sb-doc "Accessor for the pathname's version." diff --git a/src/code/target-type.lisp b/src/code/target-type.lisp index de27d70..20945cf 100644 --- a/src/code/target-type.lisp +++ b/src/code/target-type.lisp @@ -105,29 +105,18 @@ (values (not res) t) (values nil nil)))) (satisfies - ;; KLUDGE: This stuff might well blow up if we tried to execute it - ;; when cross-compiling. But since for the foreseeable future the - ;; only code we'll try to cross-compile is SBCL itself, and SBCL is - ;; built without using SATISFIES types, it's arguably not important - ;; to worry about this. -- WHN 19990210. - (let ((fun (second hairy-spec))) - (cond ((and (consp fun) - (eq (car fun) 'lambda)) - (values (not (null (funcall (coerce fun 'function) obj))) - t)) - ((and (symbolp fun) (fboundp fun)) - (values (not (null (funcall fun obj))) t)) - (t - (values nil nil)))))))))) + (let ((predicate-name (second hairy-spec))) + (declare (type symbol predicate-name)) ; by ANSI spec of SATISFIES + (if (fboundp predicate-name) + (values (not (null (funcall predicate-name obj))) t) + (values nil nil))))))))) -;;; LAYOUT-OF -- Exported -;;; -;;; Return the layout for an object. This is the basic operation for -;;; finding out the "type" of an object, and is used for generic function -;;; dispatch. The standard doesn't seem to say as much as it should about what -;;; this returns for built-in objects. For example, it seems that we must -;;; return NULL rather than LIST when X is NIL so that GF's can specialize on -;;; NULL. +;;; Return the layout for an object. This is the basic operation for +;;; finding out the "type" of an object, and is used for generic +;;; function dispatch. The standard doesn't seem to say as much as it +;;; should about what this returns for built-in objects. For example, +;;; it seems that we must return NULL rather than LIST when X is NIL +;;; so that GF's can specialize on NULL. #!-sb-fluid (declaim (inline layout-of)) (defun layout-of (x) (declare (optimize (speed 3) (safety 0))) @@ -171,7 +160,7 @@ (when *type-system-initialized* (dolist (sym '(values-specifier-type-cache-clear values-type-union-cache-clear - type-union-cache-clear + type-union2-cache-clear values-subtypep-cache-clear csubtypep-cache-clear type-intersection2-cache-clear diff --git a/src/code/type-class.lisp b/src/code/type-class.lisp index 379c8a4..9810870 100644 --- a/src/code/type-class.lisp +++ b/src/code/type-class.lisp @@ -79,12 +79,8 @@ ;; TYPE-UNION, and TYPE-INTERSECTION handle those cases specially ;; (and deal with canonicalization/simplification issues at the ;; same time). - ;; - ;; FIXME: SIMPLE-UNION and COMPLEX-UNION methods haven't been - ;; converted to the new scheme yet. (Thus they never return NIL, I - ;; think. -- WHN 2001-03-11) - (simple-union #'vanilla-union :type function) - (complex-union nil :type (or function null)) + (simple-union2 #'hierarchical-union2 :type function) + (complex-union2 nil :type (or function null)) (simple-intersection2 #'hierarchical-intersection2 :type function) (complex-intersection2 nil :type (or function null)) (simple-= #'must-supply-this :type function) @@ -136,8 +132,8 @@ :simple-subtypep (type-class-simple-subtypep x) :complex-subtypep-arg1 (type-class-complex-subtypep-arg1 x) :complex-subtypep-arg2 (type-class-complex-subtypep-arg2 x) - :simple-union (type-class-simple-union x) - :complex-union (type-class-complex-union x) + :simple-union2 (type-class-simple-union2 x) + :complex-union2 (type-class-complex-union2 x) :simple-intersection2 (type-class-simple-intersection2 x) :complex-intersection2 (type-class-complex-intersection2 x) :simple-= (type-class-simple-= x) @@ -150,8 +146,8 @@ '((:simple-subtypep . type-class-simple-subtypep) (:complex-subtypep-arg1 . type-class-complex-subtypep-arg1) (:complex-subtypep-arg2 . type-class-complex-subtypep-arg2) - (:simple-union . type-class-simple-union) - (:complex-union . type-class-complex-union) + (:simple-union2 . type-class-simple-union2) + (:complex-union2 . type-class-complex-union2) (:simple-intersection2 . type-class-simple-intersection2) (:complex-intersection2 . type-class-complex-intersection2) (:simple-= . type-class-simple-=) diff --git a/src/code/typedefs.lisp b/src/code/typedefs.lisp index cc6a4a7..57f432e 100644 --- a/src/code/typedefs.lisp +++ b/src/code/typedefs.lisp @@ -113,8 +113,8 @@ (unless sub-value (return (values nil t))) (setf certain? nil)))))) -;;; Look for a nice intersection for types that intersect only when -;;; one is a hierarchical subtype of the other. +;;; Look for nice relationships for types that have nice relationships +;;; only when one is a hierarchical subtype of the other. (defun hierarchical-intersection2 (type1 type2) (multiple-value-bind (subtypep1 win1) (csubtypep type1 type2) (multiple-value-bind (subtypep2 win2) (csubtypep type2 type1) @@ -122,15 +122,15 @@ (subtypep2 type2) ((and win1 win2) *empty-type*) (t nil))))) - -(defun vanilla-union (type1 type2) +(defun hierarchical-union2 (type1 type2) (cond ((csubtypep type1 type2) type2) ((csubtypep type2 type1) type1) (t nil))) -;;; Hash two things (types) down to 8 bits. In CMU CL this was an EQ hash, but -;;; since it now needs to run in vanilla ANSI Common Lisp at cross-compile -;;; time, it's now based on the CTYPE-HASH-VALUE field instead. +;;; Hash two things (types) down to 8 bits. In CMU CL this was an EQ +;;; hash, but since it now needs to run in vanilla ANSI Common Lisp at +;;; cross-compile time, it's now based on the CTYPE-HASH-VALUE field +;;; instead. ;;; ;;; FIXME: This was a macro in CMU CL, and is now an INLINE function. Is ;;; it important for it to be INLINE, or could be become an ordinary diff --git a/src/code/x86-vm.lisp b/src/code/x86-vm.lisp index 9fb7a80..d4ab6bf 100644 --- a/src/code/x86-vm.lisp +++ b/src/code/x86-vm.lisp @@ -295,18 +295,17 @@ (declare (ignore component)) nil) -;;; FLOAT-WAIT -;;; ;;; This is used in error.lisp to insure that floating-point exceptions ;;; are properly trapped. The compiler translates this to a VOP. (defun float-wait () (float-wait)) -;;; FLOAT CONSTANTS +;;; float constants ;;; -;;; These are used by the FP MOVE-FROM-{SINGLE|DOUBLE} VOPs rather than the -;;; i387 load constant instructions to avoid consing in some cases. Note these -;;; are initialized by GENESIS as they are needed early. +;;; These are used by the FP MOVE-FROM-{SINGLE|DOUBLE} VOPs rather +;;; than the i387 load constant instructions to avoid consing in some +;;; cases. Note these are initialized by GENESIS as they are needed +;;; early. (defvar *fp-constant-0s0*) (defvar *fp-constant-1s0*) (defvar *fp-constant-0d0*) diff --git a/src/compiler/float-tran.lisp b/src/compiler/float-tran.lisp index bdbc2fe..618ac95 100644 --- a/src/compiler/float-tran.lisp +++ b/src/compiler/float-tran.lisp @@ -740,7 +740,6 @@ (interval-expt-< pos y)))))) ;;; Compute bounds for (expt x y). - (defun interval-expt (x y) (case (interval-range-info x 1) ('+ @@ -865,8 +864,8 @@ (defun merged-interval-expt (x y) (let* ((x-int (numeric-type->interval x)) (y-int (numeric-type->interval y))) - (mapcar #'(lambda (type) - (fixup-interval-expt type x-int y-int x y)) + (mapcar (lambda (type) + (fixup-interval-expt type x-int y-int x y)) (flatten-list (interval-expt x-int y-int))))) (defun expt-derive-type-aux (x y same-arg) @@ -901,16 +900,13 @@ (defun log-derive-type-aux-2 (x y same-arg) (let ((log-x (log-derive-type-aux-1 x)) (log-y (log-derive-type-aux-1 y)) - (result '())) - ;; log-x or log-y might be union types. We need to run through - ;; the union types ourselves because /-derive-type-aux doesn't. + (accumulated-list nil)) + ;; LOG-X or LOG-Y might be union types. We need to run through + ;; the union types ourselves because /-DERIVE-TYPE-AUX doesn't. (dolist (x-type (prepare-arg-for-derive-type log-x)) (dolist (y-type (prepare-arg-for-derive-type log-y)) - (push (/-derive-type-aux x-type y-type same-arg) result))) - (setf result (flatten-list result)) - (if (rest result) - (make-union-type-or-something result) - (first result)))) + (push (/-derive-type-aux x-type y-type same-arg) accumulated-list))) + (apply #'type-union (flatten-list accumulated-list)))) (defoptimizer (log derive-type) ((x &optional y)) (if y @@ -1087,10 +1083,9 @@ (rat-result-p (csubtypep element-type (specifier-type 'rational)))) (if rat-result-p - (make-union-type-or-something - (list element-type - (specifier-type - `(complex ,(numeric-type-class element-type))))) + (type-union element-type + (specifier-type + `(complex ,(numeric-type-class element-type)))) (make-numeric-type :class (numeric-type-class element-type) :format (numeric-type-format element-type) :complexp (if rat-result-p diff --git a/src/compiler/globaldb.lisp b/src/compiler/globaldb.lisp index 5b95bc7..f99f6e6 100644 --- a/src/compiler/globaldb.lisp +++ b/src/compiler/globaldb.lisp @@ -1008,7 +1008,11 @@ (define-info-type :class :function :type :assumed-type - :type-spec (or approximate-function-type null)) + ;; FIXME: The type-spec really should be + ;; (or approximate-function-type null)). + ;; It was changed to T as a hopefully-temporary hack while getting + ;; cold init problems untangled. + :type-spec t) ;;; where this information came from: ;;; :DECLARED = from a declaration. diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp index ee67ba7..5fc13af 100644 --- a/src/compiler/srctran.lisp +++ b/src/compiler/srctran.lisp @@ -282,10 +282,7 @@ (bound-value ,y)) (or (consp ,x) (consp ,y)))))) -;;; NUMERIC-TYPE->INTERVAL -;;; ;;; Convert a numeric-type object to an interval object. - (defun numeric-type->interval (x) (declare (type numeric-type x)) (make-interval :low (numeric-type-low x) @@ -301,8 +298,6 @@ (make-interval :low (copy-interval-limit (interval-low x)) :high (copy-interval-limit (interval-high x)))) -;;; INTERVAL-SPLIT -;;; ;;; Given a point P contained in the interval X, split X into two ;;; interval at the point P. If CLOSE-LOWER is T, then the left ;;; interval contains P. If CLOSE-UPPER is T, the right interval @@ -315,8 +310,6 @@ (make-interval :low (if close-upper (list p) p) :high (copy-interval-limit (interval-high x))))) -;;; INTERVAL-CLOSURE -;;; ;;; Return the closure of the interval. That is, convert open bounds ;;; to closed bounds. (defun interval-closure (x) @@ -331,8 +324,6 @@ (>= (float-sign (float x)) (float-sign (float y)))))) -;;; INTERVAL-RANGE-INFO -;;; ;;; For an interval X, if X >= POINT, return '+. If X <= POINT, return ;;; '-. Otherwise return NIL. #+nil @@ -361,8 +352,6 @@ (t nil))))) -;;; INTERVAL-BOUNDED-P -;;; ;;; Test to see whether the interval X is bounded. HOW determines the ;;; test, and should be either ABOVE, BELOW, or BOTH. (defun interval-bounded-p (x how) @@ -375,9 +364,8 @@ ('both (and (interval-low x) (interval-high x))))) -;;; Signed zero comparison functions. Use these functions if we need +;;; signed zero comparison functions. Use these functions if we need ;;; to distinguish between signed zeroes. - (defun signed-zero-< (x y) (declare (real x y)) (or (< x y) @@ -390,13 +378,11 @@ (and (= x y) (> (float-sign (float x)) (float-sign (float y)))))) - (defun signed-zero-= (x y) (declare (real x y)) (and (= x y) (= (float-sign (float x)) (float-sign (float y))))) - (defun signed-zero-<= (x y) (declare (real x y)) (or (< x y) @@ -404,10 +390,8 @@ (<= (float-sign (float x)) (float-sign (float y)))))) -;;; INTERVAL-CONTAINS-P -;;; -;;; See whether the interval X contains the number P, taking into account -;;; that the interval might not be closed. +;;; See whether the interval X contains the number P, taking into +;;; account that the interval might not be closed. (defun interval-contains-p (p x) (declare (type number p) (type interval x)) @@ -441,8 +425,6 @@ ;; Interval with no bounds t)))) -;;; INTERVAL-INTERSECT-P -;;; ;;; Determine if two intervals X and Y intersect. Return T if so. If ;;; CLOSED-INTERVALS-P is T, the treat the intervals as if they were ;;; closed. Otherwise the intervals are treated as they are. @@ -481,8 +463,6 @@ (or (adjacent (interval-low y) (interval-high x)) (adjacent (interval-low x) (interval-high y))))) -;;; INTERVAL-INTERSECTION/DIFFERENCE -;;; ;;; Compute the intersection and difference between two intervals. ;;; Two values are returned: the intersection and the difference. ;;; @@ -545,13 +525,13 @@ (y-hi-in-x (values y-hi (opposite-bound y-hi) x-hi))) (values (make-interval :low lo :high hi) - (list (make-interval :low left-lo :high left-hi) - (make-interval :low right-lo :high right-hi)))))) + (list (make-interval :low left-lo + :high left-hi) + (make-interval :low right-lo + :high right-hi)))))) (t (values nil (list x y)))))))) -;;; INTERVAL-MERGE-PAIR -;;; ;;; If intervals X and Y intersect, return a new interval that is the ;;; union of the two. If they do not intersect, return NIL. (defun interval-merge-pair (x y) @@ -587,36 +567,28 @@ (make-interval :low (select-bound x-lo y-lo #'< #'>) :high (select-bound x-hi y-hi #'> #'<)))))) -;;; Basic arithmetic operations on intervals. We probably should do +;;; basic arithmetic operations on intervals. We probably should do ;;; true interval arithmetic here, but it's complicated because we ;;; have float and integer types and bounds can be open or closed. -;;; INTERVAL-NEG -;;; ;;; The negative of an interval (defun interval-neg (x) (declare (type interval x)) (make-interval :low (bound-func #'- (interval-high x)) :high (bound-func #'- (interval-low x)))) -;;; INTERVAL-ADD -;;; ;;; Add two intervals (defun interval-add (x y) (declare (type interval x y)) (make-interval :low (bound-binop + (interval-low x) (interval-low y)) :high (bound-binop + (interval-high x) (interval-high y)))) -;;; INTERVAL-SUB -;;; ;;; Subtract two intervals (defun interval-sub (x y) (declare (type interval x y)) (make-interval :low (bound-binop - (interval-low x) (interval-high y)) :high (bound-binop - (interval-high x) (interval-low y)))) -;;; INTERVAL-MUL -;;; ;;; Multiply two intervals (defun interval-mul (x y) (declare (type interval x y)) @@ -661,8 +633,6 @@ (t (error "This shouldn't happen!")))))) -;;; INTERVAL-DIV -;;; ;;; Divide two intervals. (defun interval-div (top bot) (declare (type interval top bot)) @@ -712,8 +682,6 @@ (t (error "This shouldn't happen!")))))) -;;; INTERVAL-FUNC -;;; ;;; Apply the function F to the interval X. If X = [a, b], then the ;;; result is [f(a), f(b)]. It is up to the user to make sure the ;;; result makes sense. It will if F is monotonic increasing (or @@ -724,8 +692,6 @@ (hi (bound-func f (interval-high x)))) (make-interval :low lo :high hi))) -;;; INTERVAL-< -;;; ;;; Return T if X < Y. That is every number in the interval X is ;;; always less than any number in the interval Y. (defun interval-< (x y) @@ -751,8 +717,6 @@ ;; Don't overlap if one or the other are open. (or (consp left) (consp right))))))) -;;; INVTERVAL->= -;;; ;;; Return T if X >= Y. That is, every number in the interval X is ;;; always greater than any number in the interval Y. (defun interval->= (x y) @@ -762,10 +726,8 @@ (interval-bounded-p y 'above)) (>= (bound-value (interval-low x)) (bound-value (interval-high y))))) -;;; INTERVAL-ABS -;;; -;;; Return an interval that is the absolute value of X. Thus, if X = -;;; [-1 10], the result is [0, 10]. +;;; Return an interval that is the absolute value of X. Thus, if +;;; X = [-1 10], the result is [0, 10]. (defun interval-abs (x) (declare (type interval x)) (case (interval-range-info x) @@ -777,8 +739,6 @@ (destructuring-bind (x- x+) (interval-split 0 x t t) (interval-merge-pair (interval-neg x-) x+))))) -;;; INTERVAL-SQR -;;; ;;; Compute the square of an interval. (defun interval-sqr (x) (declare (type interval x)) @@ -788,10 +748,10 @@ ;;;; numeric derive-type methods -;;; Utility for defining derive-type methods of integer operations. If the -;;; types of both X and Y are integer types, then we compute a new integer type -;;; with bounds determined Fun when applied to X and Y. Otherwise, we use -;;; Numeric-Contagion. +;;; a utility for defining derive-type methods of integer operations. If +;;; the types of both X and Y are integer types, then we compute a new +;;; integer type with bounds determined Fun when applied to X and Y. +;;; Otherwise, we use Numeric-Contagion. (defun derive-integer-type (x y fun) (declare (type continuation x y) (type function fun)) (let ((x (continuation-type x)) @@ -811,7 +771,7 @@ #!+(or propagate-float-type propagate-fun-type) (progn -;; Simple utility to flatten a list +;;; simple utility to flatten a list (defun flatten-list (x) (labels ((flatten-helper (x r);; 'r' is the stuff to the 'right'. (cond ((null x) r) @@ -996,11 +956,15 @@ (t type-list))) +;;; FIXME: MAKE-CANONICAL-UNION-TYPE and CONVERT-MEMBER-TYPE probably +;;; belong in the kernel's type logic, invoked always, instead of in +;;; the compiler, invoked only during some type optimizations. + ;;; Take a list of types and return a canonical type specifier, -;;; combining any MEMBER types together. If both positive and -;;; negative MEMBER types are present they are converted to a float -;;; type. XXX This would be far simpler if the type-union methods could -;;; handle member/number unions. +;;; combining any MEMBER types together. If both positive and negative +;;; MEMBER types are present they are converted to a float type. +;;; XXX This would be far simpler if the type-union methods could handle +;;; member/number unions. (defun make-canonical-union-type (type-list) (let ((members '()) (misc-types '())) @@ -1027,24 +991,10 @@ #!+negative-zero-is-not-zero (push (specifier-type '(single-float -0f0 0f0)) misc-types) (setf members (set-difference members '(-0f0 0f0)))) - (cond ((null members) - (let ((res (first misc-types))) - (dolist (type (rest misc-types)) - (setq res (type-union res type))) - res)) - ((null misc-types) - (make-member-type :members members)) - (t - (let ((res (first misc-types))) - (dolist (type (rest misc-types)) - (setq res (type-union res type))) - (dolist (type members) - (setq res (type-union - res (make-member-type :members (list type))))) - res))))) - -;;; Convert-Member-Type -;;; + (if members + (apply #'type-union (make-member-type :members members) misc-types) + (apply #'type-union misc-types)))) + ;;; Convert a member type with a single member to a numeric type. (defun convert-member-type (arg) (let* ((members (member-type-members arg)) @@ -1056,8 +1006,6 @@ member-type) ,member ,member)))) -;;; ONE-ARG-DERIVE-TYPE -;;; ;;; This is used in defoptimizers for computing the resulting type of ;;; a function. ;;; @@ -1118,8 +1066,6 @@ (make-canonical-union-type results) (first results))))))) -;;; TWO-ARG-DERIVE-TYPE -;;; ;;; Same as ONE-ARG-DERIVE-TYPE, except we assume the function takes ;;; two arguments. DERIVE-FCN takes 3 args in this case: the two ;;; original args and a third which is T to indicate if the two args @@ -1358,7 +1304,7 @@ (make-numeric-type :class (if (and (eq (numeric-type-class x) 'integer) (eq (numeric-type-class y) 'integer)) - ;; The product of integers is always an integer + ;; The product of integers is always an integer. 'integer (numeric-type-class result-type)) :format (numeric-type-format result-type) @@ -1373,7 +1319,7 @@ (if (and (numeric-type-real-p x) (numeric-type-real-p y)) (let ((result - ;; (/ x x) is always 1, except if x can contain 0. In + ;; (/ X X) is always 1, except if X can contain 0. In ;; that case, we shouldn't optimize the division away ;; because we want 0/0 to signal an error. (if (and same-arg @@ -1403,20 +1349,6 @@ ) ; PROGN -;;; ASH derive type optimizer -;;; -;;; Large resulting bounds are easy to generate but are not -;;; particularly useful, so an open outer bound is returned for a -;;; shift greater than 64 - the largest word size of any of the ports. -;;; Large negative shifts are also problematic as the ASH -;;; implementation only accepts shifts greater than -;;; MOST-NEGATIVE-FIXNUM. These issues are handled by two local -;;; functions: -;;; ASH-OUTER: Perform the shift when within an acceptable range, -;;; otherwise return an open bound. -;;; ASH-INNER: Perform the shift when within range, limited to a -;;; maximum of 64, otherwise returns the inner limit. -;;; ;;; KLUDGE: All this ASH optimization is suppressed under CMU CL ;;; because as of version 2.4.6 for Debian, CMU CL blows up on (ASH ;;; 1000000000 -100000000000) (i.e. ASH of two bignums yielding zero) @@ -1425,7 +1357,24 @@ (progn #!-propagate-fun-type (defoptimizer (ash derive-type) ((n shift)) - (flet ((ash-outer (n s) + ;; Large resulting bounds are easy to generate but are not + ;; particularly useful, so an open outer bound is returned for a + ;; shift greater than 64 - the largest word size of any of the ports. + ;; Large negative shifts are also problematic as the ASH + ;; implementation only accepts shifts greater than + ;; MOST-NEGATIVE-FIXNUM. These issues are handled by two local + ;; functions: + ;; ASH-OUTER: Perform the shift when within an acceptable range, + ;; otherwise return an open bound. + ;; ASH-INNER: Perform the shift when within range, limited to a + ;; maximum of 64, otherwise returns the inner limit. + ;; + ;; FIXME: The magic number 64 should be given a mnemonic name as a + ;; symbolic constant -- perhaps +MAX-REGISTER-SIZE+. And perhaps is + ;; should become an architecture-specific SB!VM:+MAX-REGISTER-SIZE+ + ;; instead of trying to have a single magic number which covers + ;; all possible ports. + (flet ((ash-outer (n s) (when (and (fixnump s) (<= s 64) (> s sb!vm:*target-most-negative-fixnum*)) @@ -1544,29 +1493,29 @@ #!+propagate-float-type (defoptimizer (lognot derive-type) ((int)) (derive-integer-type int int - #'(lambda (type type2) - (declare (ignore type2)) - (let ((lo (numeric-type-low type)) - (hi (numeric-type-high type))) - (values (if hi (lognot hi) nil) - (if lo (lognot lo) nil) - (numeric-type-class type) - (numeric-type-format type)))))) + (lambda (type type2) + (declare (ignore type2)) + (let ((lo (numeric-type-low type)) + (hi (numeric-type-high type))) + (values (if hi (lognot hi) nil) + (if lo (lognot lo) nil) + (numeric-type-class type) + (numeric-type-format type)))))) #!+propagate-float-type (defoptimizer (%negate derive-type) ((num)) (flet ((negate-bound (b) (set-bound (- (bound-value b)) (consp b)))) (one-arg-derive-type num - #'(lambda (type) - (let ((lo (numeric-type-low type)) - (hi (numeric-type-high type)) - (result (copy-numeric-type type))) - (setf (numeric-type-low result) - (if hi (negate-bound hi) nil)) - (setf (numeric-type-high result) - (if lo (negate-bound lo) nil)) - result)) + (lambda (type) + (let ((lo (numeric-type-low type)) + (hi (numeric-type-high type)) + (result (copy-numeric-type type))) + (setf (numeric-type-low result) + (if hi (negate-bound hi) nil)) + (setf (numeric-type-high result) + (if lo (negate-bound lo) nil)) + result)) #'-))) #!-propagate-float-type @@ -1911,8 +1860,8 @@ (frob-opt ffloor floor-quotient-bound floor-rem-bound) (frob-opt fceiling ceiling-quotient-bound ceiling-rem-bound)) -;;; Functions to compute the bounds on the quotient and remainder for -;;; the FLOOR function. +;;; functions to compute the bounds on the quotient and remainder for +;;; the FLOOR function (defun floor-quotient-bound (quot) ;; Take the floor of the quotient and then massage it into what we ;; need. @@ -3436,7 +3385,7 @@ (def-source-transform / (&rest args) (source-transform-intransitive '/ args '(/ 1))) -;;;; APPLY +;;;; transforming APPLY ;;; We convert APPLY into MULTIPLE-VALUE-CALL so that the compiler ;;; only needs to understand one kind of variable-argument call. It is @@ -3449,7 +3398,7 @@ (butlast args)) (values-list ,(car (last args)))))) -;;;; FORMAT +;;;; transforming FORMAT ;;;; ;;;; If the control string is a compile-time constant, then replace it ;;;; with a use of the FORMATTER macro so that the control string is diff --git a/src/compiler/typetran.lisp b/src/compiler/typetran.lisp index 276aa8c..1c72075 100644 --- a/src/compiler/typetran.lisp +++ b/src/compiler/typetran.lisp @@ -37,12 +37,10 @@ ;;;; part of the backend; different backends can support different ;;;; sets of predicates. +;;; Establish an association between the type predicate NAME and the +;;; corresponding TYPE. This causes the type predicate to be +;;; recognized for purposes of optimization. (defmacro define-type-predicate (name type) - #!+sb-doc - "Define-Type-Predicate Name Type - Establish an association between the type predicate Name and the - corresponding Type. This causes the type predicate to be recognized for - purposes of optimization." `(%define-type-predicate ',name ',type)) (defun %define-type-predicate (name specifier) (let ((type (specifier-type specifier))) @@ -74,9 +72,9 @@ (declare (type continuation object) (type ctype type)) (let ((otype (continuation-type object))) (cond ((not (types-intersect otype type)) - 'nil) + nil) ((csubtypep otype type) - 't) + t) (t (give-up-ir1-transform))))) @@ -108,11 +106,15 @@ `(or (class-cell-class ',cell) (error "class not yet defined: ~S" name)))) -;;;; standard type predicates +;;;; standard type predicates, i.e. those defined in package COMMON-LISP, +;;;; plus at least one oddball (%INSTANCEP) +;;;; +;;;; Various other type predicates (e.g. low-level representation +;;;; stuff like SIMPLE-ARRAY-SINGLE-FLOAT-P) are defined elsewhere. -;;; FIXME: needed only at cold load time, can be uninterned afterwards; -;;; or perhaps could just be done at toplevel -(defun define-standard-type-predicates () +;;; FIXME: This function is only called once, at top level. Why not +;;; just expand all its operations into toplevel code? +(defun !define-standard-type-predicates () (define-type-predicate arrayp array) ; (The ATOM predicate is handled separately as (NOT CONS).) (define-type-predicate bit-vector-p bit-vector) @@ -139,8 +141,7 @@ (define-type-predicate funcallable-instance-p funcallable-instance) (define-type-predicate symbolp symbol) (define-type-predicate vectorp vector)) - -(define-standard-type-predicates) +(!define-standard-type-predicates) ;;;; transforms for type predicates not implemented primitively ;;;; @@ -286,21 +287,19 @@ (let* ((types (union-type-types type)) (ltype (specifier-type 'list)) (mtype (find-if #'member-type-p types))) - (cond ((and mtype (csubtypep ltype type)) - (let ((members (member-type-members mtype))) - (once-only ((n-obj object)) - `(if (listp ,n-obj) - t - (typep ,n-obj - '(or ,@(mapcar #'type-specifier - (remove (specifier-type 'cons) - (remove mtype types))) - (member ,@(remove nil members)))))))) - (t - (once-only ((n-obj object)) - `(or ,@(mapcar (lambda (x) - `(typep ,n-obj ',(type-specifier x))) - types))))))) + (if (and mtype (csubtypep ltype type)) + (let ((members (member-type-members mtype))) + (once-only ((n-obj object)) + `(or (listp ,n-obj) + (typep ,n-obj + '(or ,@(mapcar #'type-specifier + (remove (specifier-type 'cons) + (remove mtype types))) + (member ,@(remove nil members))))))) + (once-only ((n-obj object)) + `(or ,@(mapcar (lambda (x) + `(typep ,n-obj ',(type-specifier x))) + types)))))) ;;; Do source transformation for TYPEP of a known intersection type. (defun source-transform-intersection-typep (object type) @@ -487,6 +486,12 @@ ;;; simplification. Instance type tests are converted to ;;; %INSTANCE-TYPEP to allow type propagation. (def-source-transform typep (object spec) + ;; KLUDGE: It looks bad to only do this on explicitly quoted forms, + ;; since that would overlook other kinds of constants. But it turns + ;; out that the DEFTRANSFORM for TYPEP detects any constant + ;; continuation, transforms it into a quoted form, and gives this + ;; source transform another chance, so it all works out OK, in a + ;; weird roundabout way. -- WHN 2001-03-18 (if (and (consp spec) (eq (car spec) 'quote)) (let ((type (specifier-type (cadr spec)))) (or (let ((pred (cdr (assoc type *backend-type-predicates* diff --git a/src/compiler/x86/vm.lisp b/src/compiler/x86/vm.lisp index a46bbbe..6c3cec9 100644 --- a/src/compiler/x86/vm.lisp +++ b/src/compiler/x86/vm.lisp @@ -376,8 +376,6 @@ :offset 31)) ; Offset doesn't get used. |# -;;; IMMEDIATE-CONSTANT-SC -;;; ;;; If value can be represented as an immediate constant, then return ;;; the appropriate SC number, otherwise return NIL. (!def-vm-support-routine immediate-constant-sc (value) @@ -420,8 +418,6 @@ (defconstant cfp-offset ebp-offset) ; pfw - needed by stuff in /code ; related to signal context stuff -;;; SINGLE-VALUE-RETURN-BYTE-OFFSET -;;; ;;; This is used by the debugger. (defconstant single-value-return-byte-offset 2) diff --git a/src/pcl/cache.lisp b/src/pcl/cache.lisp index b41ab58..bf3ce0d 100644 --- a/src/pcl/cache.lisp +++ b/src/pcl/cache.lisp @@ -604,8 +604,6 @@ ;;; ENSURING that the result is a fixnum ;;; MASK the result against the mask argument. -;;; COMPUTE-PRIMARY-CACHE-LOCATION -;;; ;;; The basic functional version. This is used by the cache miss code to ;;; compute the primary location of an entry. (defun compute-primary-cache-location (field mask wrappers) @@ -634,8 +632,6 @@ (incf i)) (the fixnum (1+ (logand mask location)))))) -;;; COMPUTE-PRIMARY-CACHE-LOCATION-FROM-LOCATION -;;; ;;; This version is called on a cache line. It fetches the wrappers ;;; from the cache line and determines the primary location. Various ;;; parts of the cache filling code call this to determine whether it diff --git a/src/pcl/cpl.lisp b/src/pcl/cpl.lisp index 8fdd038..e8c7b58 100644 --- a/src/pcl/cpl.lisp +++ b/src/pcl/cpl.lisp @@ -23,8 +23,8 @@ (in-package "SB-PCL") -;;; compute-class-precedence-list -;;; +;;;; COMPUTE-CLASS-PRECEDENCE-LIST and friends + ;;; Knuth section 2.2.3 has some interesting notes on this. ;;; ;;; What appears here is basically the algorithm presented there. diff --git a/src/pcl/defs.lisp b/src/pcl/defs.lisp index 5943a8d..ba9ff36 100644 --- a/src/pcl/defs.lisp +++ b/src/pcl/defs.lisp @@ -130,14 +130,14 @@ ;;;; type specifier hackery -;;; internal to this file. +;;; internal to this file (defun coerce-to-class (class &optional make-forward-referenced-class-p) (if (symbolp class) (or (find-class class (not make-forward-referenced-class-p)) (ensure-class class)) class)) -;;; Interface +;;; interface (defun specializer-from-type (type &aux args) (when (consp type) (setq args (cdr type) type (car type))) diff --git a/src/pcl/dlisp.lisp b/src/pcl/dlisp.lisp index 0f69b49..a8400de 100644 --- a/src/pcl/dlisp.lisp +++ b/src/pcl/dlisp.lisp @@ -23,11 +23,11 @@ (in-package "SB-PCL") -;;; This file is (almost) functionally equivalent to dlap.lisp, but easier to -;;; read. +;;; This file is (almost) functionally equivalent to dlap.lisp, but +;;; easier to read. -;;; Might generate faster code, too, depending on the compiler and whether an -;;; implementation-specific lap assembler was used. +;;; Might generate faster code, too, depending on the compiler and +;;; whether an implementation-specific lap assembler was used. (defun emit-one-class-reader (class-slot-p) (emit-reader/writer :reader 1 class-slot-p)) diff --git a/src/pcl/low.lisp b/src/pcl/low.lisp index a8b4658..f09eba4 100644 --- a/src/pcl/low.lisp +++ b/src/pcl/low.lisp @@ -96,8 +96,6 @@ `(wrapper-class* (std-instance-wrapper ,instance))) -;;; SET-FUNCTION-NAME -;;; ;;; When given a function should give this function the name . ;;; Note that is sometimes a list. Some lisps get the upset ;;; in the tummy when they start thinking about functions which have diff --git a/stems-and-flags.lisp-expr b/stems-and-flags.lisp-expr index 06fd563..cf2577b 100644 --- a/stems-and-flags.lisp-expr +++ b/stems-and-flags.lisp-expr @@ -566,9 +566,11 @@ ; from "code/pathname" ("code/sharpm" :not-host) ; uses stuff from "code/reader" - ;; stuff for byte compilation. This works only in the target system, - ;; because fundamental BYTE-FUNCTION-OR-CLOSURE types are implemented - ;; as nonportable FUNCALLABLE-INSTANCEs. + ;; stuff for byte compilation. Note that although byte code is + ;; "portable", it'd be hard to make it work on the cross-compilation + ;; host, because fundamental BYTE-FUNCTION-OR-CLOSURE types are + ;; implemented as FUNCALLABLE-INSTANCEs, and it's + ;; not obvious how to make those portable. ("code/byte-types" :not-host) ("compiler/byte-comp") ("compiler/target-byte-comp" :not-host) diff --git a/tests/type.before-xc.lisp b/tests/type.before-xc.lisp index 5dc0ca3..e123ae1 100644 --- a/tests/type.before-xc.lisp +++ b/tests/type.before-xc.lisp @@ -58,6 +58,23 @@ (type-intersection (specifier-type '(satisfies keywordp)) *empty-type*))) +(assert (type= (specifier-type 'list) + (type-union (specifier-type 'cons) (specifier-type 'null)))) +(assert (type= (specifier-type 'list) + (type-union (specifier-type 'null) (specifier-type 'cons)))) +(assert (type= (specifier-type 'sequence) + (type-union (specifier-type 'list) (specifier-type 'vector)))) +(assert (type= (specifier-type 'sequence) + (type-union (specifier-type 'vector) (specifier-type 'list)))) +(assert (type= (specifier-type 'list) + (type-union (specifier-type 'cons) (specifier-type 'list)))) +(assert (not (csubtypep (type-union (specifier-type 'list) + (specifier-type '(satisfies foo))) + (specifier-type 'list)))) +(assert (csubtypep (specifier-type 'list) + (type-union (specifier-type 'list) + (specifier-type '(satisfies foo))))) + ;;; Identities should be identities. (dolist (type-specifier '(nil t @@ -87,22 +104,15 @@ (assert (type= ctype (type-intersection2 ctype *universal-type*))) (assert (type= ctype (type-intersection2 *universal-type* ctype))) - ;; FIXME: TYPE-UNION still acts CMU-CL-ish as of 0.6.11.13, so - ;; e.g. (TYPE-UNION # *EMPTY-TYPE*) - ;; returns a UNION-TYPE instead of the HAIRY-TYPE. When that's - ;; fixed, these tests should be enabled. - ;;(assert (eql ctype (type-union ctype *empty-type*))) - ;;(assert (eql ctype (type-union *empty-type* ctype))) - - ;; FIXME: TYPE-UNION2 is not defined yet as of 0.6.11.13, and when - ;; it's defined, these tests should be enabled. - ;;(assert (eql *empty-type* (type-union2 ctype *empty-type*))) - ;;(assert (eql *empty-type* (type-union2 *empty-type* ctype))) - - ;;(assert (eql *universal-type* (type-union ctype *universal-type*))) - ;;(assert (eql *universal-type* (type-union *universal-type* ctype))) - ;;(assert (eql ctype (type-union2 ctype *universal-type*))) - ;;(assert (eql ctype (type-union2 *universal-type* ctype))) + (assert (eql *universal-type* (type-union ctype *universal-type*))) + (assert (eql *universal-type* (type-union *universal-type* ctype))) + (assert (eql *universal-type* (type-union2 ctype *universal-type*))) + (assert (eql *universal-type* (type-union2 *universal-type* ctype))) + + (assert (type= ctype (type-union ctype *empty-type*))) + (assert (type= ctype (type-union *empty-type* ctype))) + (assert (type= ctype (type-union2 ctype *empty-type*))) + (assert (type= ctype (type-union2 *empty-type* ctype))) (assert (csubtypep *empty-type* ctype)) (assert (csubtypep ctype *universal-type*)))) @@ -172,5 +182,17 @@ (assert (null (type-intersection2 (specifier-type 'symbol) (specifier-type '(satisfies foo))))) (assert (intersection-type-p (specifier-type '(and symbol (satisfies foo))))) +;; FIXME: As of sbcl-0.6.11.17, the system doesn't know how to do the +;; type simplifications which would let these tests work. (bug 88) +#| +(let* ((type1 (specifier-type '(member :x86))) + (type2 (specifier-type '(or keyword null))) + (isect (type-intersection type1 type2))) + (assert (type= isect (type-intersection type2 type1))) + (assert (type= isect type1)) + (assert (type= isect (type-intersection type2 type1 type2))) + (assert (type= isect (type-intersection type1 type1 type2 type1))) + (assert (type= isect (type-intersection type1 type2 type1 type2)))) +|# (/show "done with tests/type.before-xc.lisp") diff --git a/version.lisp-expr b/version.lisp-expr index 868cd5d..e60e94b 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.11.16" +"0.6.11.17"