#!-#.(cl:if (cl:= sb!vm::n-machine-word-bits 64) '(and) '(or))
(:or signed-byte-32 fixnum unsigned-byte-31 positive-fixnum))
(!def-primitive-type-alias untagged-num
- (:or . #.(print (union (cdr '#1#) (cdr '#2#))))))
+ (:or . #.(sort (copy-list (union (cdr '#1#) (cdr '#2#))) #'string<))))
;;; other primitive immediate types
(/show0 "primtype.lisp 68")
(/show0 "about to !DEF-PRIMITIVE-TYPE COMPLEX-DOUBLE-FLOAT")
(!def-primitive-type complex-double-float (complex-double-reg descriptor-reg)
:type (complex double-float))
-
+#!+sb-simd-pack
+(progn
+ (/show0 "about to !DEF-PRIMITIVE-TYPE SIMD-PACK")
+ (!def-primitive-type simd-pack-single (single-sse-reg descriptor-reg)
+ :type (simd-pack single-float))
+ (!def-primitive-type simd-pack-double (double-sse-reg descriptor-reg)
+ :type (simd-pack double-float))
+ (!def-primitive-type simd-pack-int (int-sse-reg descriptor-reg)
+ :type (simd-pack integer))
+ (!def-primitive-type-alias simd-pack (:or simd-pack-single simd-pack-double simd-pack-int)))
;;; primitive other-pointer array types
(/show0 "primtype.lisp 96")
;;; Return the most restrictive primitive type that contains OBJECT.
(/show0 "primtype.lisp 147")
-(!def-vm-support-routine primitive-type-of (object)
+(defun primitive-type-of (object)
(let ((type (ctype-of object)))
(cond ((not (member-type-p type)) (primitive-type type))
- ((equal (member-type-members type) '(nil))
+ ((and (eql 1 (member-type-size type))
+ (equal (member-type-members type) '(nil)))
(primitive-type-or-lose 'list))
(t
*backend-t-primitive-type*))))
;;; We need an aux function because we need to use both
;;; !DEF-VM-SUPPORT-ROUTINE and DEFUN-CACHED.
(/show0 "primtype.lisp 188")
-(!def-vm-support-routine primitive-type (type)
+(defun primitive-type (type)
+ (sb!kernel::maybe-reparse-specifier! type)
(primitive-type-aux type))
(/show0 "primtype.lisp 191")
(defun-cached (primitive-type-aux
(return (any)))))))))))
(intersection-type
(let ((types (intersection-type-types type))
- (res (any))
- (exact nil))
- (dolist (type types (values res exact))
- (multiple-value-bind (ptype ptype-exact)
+ (res (any)))
+ ;; why NIL for the exact? Well, we assume that the
+ ;; intersection type is in fact doing something for us:
+ ;; that is, that each of the types in the intersection is
+ ;; in fact cutting off some of the type lattice. Since no
+ ;; intersection type is represented by a primitive type and
+ ;; primitive types are mutually exclusive, it follows that
+ ;; no intersection type can represent the entirety of the
+ ;; primitive type. (And NIL is the conservative answer,
+ ;; anyway). -- CSR, 2006-09-14
+ (dolist (type types (values res nil))
+ (multiple-value-bind (ptype)
(primitive-type type)
- (when ptype-exact
- (aver (or (not exact) (eq ptype res)))
- (setq exact t))
- (when (or ptype-exact (and (not exact) (eq res (any))))
- ;; Try to find a narrower representation then
- ;; (any). Takes care of undecidable types in
- ;; intersections with decidable ones.
- (setq res ptype))))))
+ (cond
+ ;; if the result so far is (any), any improvement on
+ ;; the specificity of the primitive type is valid.
+ ((eq res (any))
+ (setq res ptype))
+ ;; if the primitive type returned is (any), the
+ ;; result so far is valid. Likewise, if the
+ ;; primitive type is the same as the result so far,
+ ;; everything is fine.
+ ((or (eq ptype (any)) (eq ptype res)))
+ ;; otherwise, we have something hairy and confusing,
+ ;; such as (and condition funcallable-instance).
+ ;; Punt.
+ (t (return (any))))))))
(member-type
- (let* ((members (member-type-members type))
- (res (primitive-type-of (first members))))
- (dolist (mem (rest members) (values res nil))
- (let ((ptype (primitive-type-of mem)))
- (unless (eq ptype res)
- (let ((new-ptype (or (maybe-numeric-type-union res ptype)
- (maybe-numeric-type-union ptype res))))
- (if new-ptype
- (setq res new-ptype)
- (return (any)))))))))
+ (let (res)
+ (block nil
+ (mapc-member-type-members
+ (lambda (member)
+ (let ((ptype (primitive-type-of member)))
+ (if res
+ (unless (eq ptype res)
+ (let ((new-ptype (or (maybe-numeric-type-union res ptype)
+ (maybe-numeric-type-union ptype res))))
+ (if new-ptype
+ (setq res new-ptype)
+ (return (any)))))
+ (setf res ptype))))
+ type)
+ res)))
(named-type
(ecase (named-type-name type)
((t *) (values *backend-t-primitive-type* t))
((instance) (exactly instance))
((funcallable-instance) (part-of function))
+ ((extended-sequence) (any))
((nil) (any))))
(character-set-type
(let ((pairs (character-set-type-pairs type)))
(= (cdar pairs) (1- sb!xc:char-code-limit)))
(exactly character)
(part-of character))))
+ #!+sb-simd-pack
+ (simd-pack-type
+ (let ((eltypes (simd-pack-type-element-type type)))
+ (cond ((member 'integer eltypes)
+ (exactly simd-pack-int))
+ ((member 'single-float eltypes)
+ (exactly simd-pack-single))
+ ((member 'double-float eltypes)
+ (exactly simd-pack-double)))))
(built-in-classoid
(case (classoid-name type)
+ #!+sb-simd-pack
+ ;; Can't tell what specific type; assume integers.
+ (simd-pack
+ (exactly simd-pack-int))
((complex function system-area-pointer weak-pointer)
(values (primitive-type-or-lose (classoid-name type)) t))
(cons-type