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
"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*"
"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"
\f
;;;; 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))
(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))
(: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))
(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))
\f
;;;; 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)
`(eval-when (:compile-toplevel :load-toplevel :execute)
(setq *package* (find-undeleted-package-or-lose ',package-designator))))
\f
-;;; MULTIPLE-VALUE-FOO
+;;;; MULTIPLE-VALUE-FOO
(defun list-of-symbols-p (x)
(and (listp x)
(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)
;(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
(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)
(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")
;;; 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
;;; 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
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))
(!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)
(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)
;;; 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
(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)
;;
;; (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)
((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))
;;; 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))))
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*)))
\f
;;;; built-in types
;;(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))
\f
(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))
(!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))
\f
;;;; numeric types
;;;
;;; ### 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)
(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))))
(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)
\f
;;;; 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
(!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.
((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)))
\f
;;;; CONS types
;;; 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))
(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)))
(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)))))
\f
(!def-type-translator array (&optional (element-type '*)
(dimensions '*))
,specifically
,form)))))
\f
-;;;; 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)
,(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)
consing 0
profiles 0)))))
\f
-;;; interfaces
+;;;; interfaces
;;; A symbol or (SETF FOO) list names a function, a string names all
;;; the functions named by symbols in the named package.
) ; EVAL-WHEN
\f
-;;; POSITION
+;;;; POSITION
(eval-when (:compile-toplevel :execute)
#!+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)
\f
;;;; 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))
(%pathname-host pathname))
:lower)))))
-;;; PATHNAME-TYPE
(defun pathname-type (pathname &key (case :local))
#!+sb-doc
"Accessor for the pathname's name."
(%pathname-host pathname))
:lower)))))
-;;; PATHNAME-VERSION
(defun pathname-version (pathname)
#!+sb-doc
"Accessor for the pathname's version."
(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)))))))))
\f
-;;; 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)))
(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
;; 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)
: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)
'((: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-=)
(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)
(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
(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*)
(interval-expt-< pos y))))))
;;; Compute bounds for (expt x y).
-
(defun interval-expt (x y)
(case (interval-range-info x 1)
('+
(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)
(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
(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
(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.
(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)
(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
(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)
(>= (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
(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)
('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)
(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)
(<= (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))
;; 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.
(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.
;;;
(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)
(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))
(t
(error "This shouldn't happen!"))))))
-;;; INTERVAL-DIV
-;;;
;;; Divide two intervals.
(defun interval-div (top bot)
(declare (type interval top bot))
(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
(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)
;; 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)
(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)
(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))
\f
;;;; 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))
#!+(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)
(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 '()))
#!+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))
member-type)
,member ,member))))
-;;; ONE-ARG-DERIVE-TYPE
-;;;
;;; This is used in defoptimizers for computing the resulting type of
;;; a function.
;;;
(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
(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)
(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
) ; 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)
(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*))
#!+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
(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.
(def-source-transform / (&rest args)
(source-transform-intransitive '/ args '(/ 1)))
\f
-;;;; 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
(butlast args))
(values-list ,(car (last args))))))
\f
-;;;; 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
;;;; 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)))
(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)))))
`(or (class-cell-class ',cell)
(error "class not yet defined: ~S" name))))
\f
-;;;; 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)
(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)
\f
;;;; transforms for type predicates not implemented primitively
;;;;
(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)
;;; 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*
:offset 31)) ; Offset doesn't get used.
|#
\f
-;;; 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)
(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)
\f
;;; 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)
(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
(in-package "SB-PCL")
\f
-;;; 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.
\f
;;;; 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)))
(in-package "SB-PCL")
\f
-;;; 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))
`(wrapper-class* (std-instance-wrapper ,instance)))
\f
-;;; SET-FUNCTION-NAME
-;;;
;;; When given a function should give this function the name <new-name>.
;;; Note that <new-name> is sometimes a list. Some lisps get the upset
;;; in the tummy when they start thinking about functions which have
; 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)
(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
(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 #<HAIRY-TYPE (SATISFIES KEYWORDP)> *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*))))
(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")
;;; 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"
projects / sbcl.git / commitdiff