X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fgeneric%2Fprimtype.lisp;h=ea2e4b65535707d2acc9947f0e2d0070d68c3e6c;hb=19319c931fc1636835dbef71808cc10e252bcf45;hp=1232ca1a39a2546ecc926d50f56206eb64096210;hpb=5ee902ed6ceef841efee4a50459ff545293a1d95;p=sbcl.git diff --git a/src/compiler/generic/primtype.lisp b/src/compiler/generic/primtype.lisp index 1232ca1..ea2e4b6 100644 --- a/src/compiler/generic/primtype.lisp +++ b/src/compiler/generic/primtype.lisp @@ -64,7 +64,7 @@ #!-#.(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") @@ -95,7 +95,16 @@ (/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") @@ -123,10 +132,11 @@ ;;; 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*)))) @@ -141,7 +151,8 @@ ;;; 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 @@ -313,35 +324,55 @@ (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))) @@ -350,8 +381,21 @@ (= (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