X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fgeneric%2Fprimtype.lisp;h=9da94af30619fa607144fccf1a4ad25ec3a6da31;hb=b63c4fb9b98fa8188e17ba926e150ba417a74635;hp=c2df398f6fed8074d69e6adfe9ab0243e87979b8;hpb=cae594ffb04c80cfa70abce4a6a35a9ba5a27e8c;p=sbcl.git diff --git a/src/compiler/generic/primtype.lisp b/src/compiler/generic/primtype.lisp index c2df398..9da94af 100644 --- a/src/compiler/generic/primtype.lisp +++ b/src/compiler/generic/primtype.lisp @@ -23,28 +23,28 @@ ;;; primitive integer types that fit in registers (/show0 "primtype.lisp 24") (!def-primitive-type positive-fixnum (any-reg signed-reg unsigned-reg) - :type (unsigned-byte 29)) + :type (unsigned-byte #.sb!vm:n-positive-fixnum-bits)) (/show0 "primtype.lisp 27") -#!-alpha +#!+#.(cl:if (cl:= sb!vm::n-machine-word-bits 32) '(and) '(or)) (!def-primitive-type unsigned-byte-31 (signed-reg unsigned-reg descriptor-reg) :type (unsigned-byte 31)) (/show0 "primtype.lisp 31") -#!-alpha +#!+#.(cl:if (cl:= sb!vm::n-machine-word-bits 32) '(and) '(or)) (!def-primitive-type unsigned-byte-32 (unsigned-reg descriptor-reg) :type (unsigned-byte 32)) (/show0 "primtype.lisp 35") -#!+alpha +#!+#.(cl:if (cl:= sb!vm::n-machine-word-bits 64) '(and) '(or)) (!def-primitive-type unsigned-byte-63 (signed-reg unsigned-reg descriptor-reg) :type (unsigned-byte 63)) -#!+alpha +#!+#.(cl:if (cl:= sb!vm::n-machine-word-bits 64) '(and) '(or)) (!def-primitive-type unsigned-byte-64 (unsigned-reg descriptor-reg) :type (unsigned-byte 64)) (!def-primitive-type fixnum (any-reg signed-reg) - :type (signed-byte 30)) -#!-alpha + :type (signed-byte #.(1+ sb!vm:n-positive-fixnum-bits))) +#!+#.(cl:if (cl:= sb!vm::n-machine-word-bits 32) '(and) '(or)) (!def-primitive-type signed-byte-32 (signed-reg descriptor-reg) :type (signed-byte 32)) -#!+alpha +#!+#.(cl:if (cl:= sb!vm::n-machine-word-bits 64) '(and) '(or)) (!def-primitive-type signed-byte-64 (signed-reg descriptor-reg) :type (signed-byte 64)) @@ -52,21 +52,20 @@ (/show0 "primtype.lisp 53") (!def-primitive-type-alias tagged-num (:or positive-fixnum fixnum)) -(!def-primitive-type-alias unsigned-num (:or #!-alpha unsigned-byte-32 - #!-alpha unsigned-byte-31 - #!+alpha unsigned-byte-64 - #!+alpha unsigned-byte-63 - positive-fixnum)) -(!def-primitive-type-alias signed-num (:or #!-alpha signed-byte-32 - #!+alpha signed-byte-64 - fixnum - #!-alpha unsigned-byte-31 - #!+alpha unsigned-byte-63 - positive-fixnum)) +(!def-primitive-type-alias unsigned-num + #!+#.(cl:if (cl:= sb!vm::n-machine-word-bits 64) '(and) '(or)) + (:or unsigned-byte-64 unsigned-byte-63 positive-fixnum) + #!-#.(cl:if (cl:= sb!vm::n-machine-word-bits 64) '(and) '(or)) + (:or unsigned-byte-32 unsigned-byte-31 positive-fixnum)) +(!def-primitive-type-alias signed-num + #!+#.(cl:if (cl:= sb!vm::n-machine-word-bits 64) '(and) '(or)) + (:or signed-byte-64 fixnum unsigned-byte-63 positive-fixnum) + #!-#.(cl:if (cl:= sb!vm::n-machine-word-bits 64) '(and) '(or)) + (:or signed-byte-32 fixnum unsigned-byte-31 positive-fixnum)) ;;; other primitive immediate types (/show0 "primtype.lisp 68") -(!def-primitive-type base-char (base-char-reg any-reg)) +(!def-primitive-type character (character-reg any-reg)) ;;; primitive pointer types (/show0 "primtype.lisp 73") @@ -86,59 +85,29 @@ (!def-primitive-type single-float (single-reg descriptor-reg)) (/show0 "about to !DEF-PRIMITIVE-TYPE DOUBLE-FLOAT") (!def-primitive-type double-float (double-reg descriptor-reg)) -#!+long-float -(!def-primitive-type long-float (long-reg descriptor-reg)) + (/show0 "about to !DEF-PRIMITIVE-TYPE COMPLEX-SINGLE-FLOAT") (!def-primitive-type complex-single-float (complex-single-reg descriptor-reg) :type (complex single-float)) (/show0 "about to !DEF-PRIMITIVE-TYPE COMPLEX-DOUBLE-FLOAT") (!def-primitive-type complex-double-float (complex-double-reg descriptor-reg) :type (complex double-float)) -#!+long-float -(!def-primitive-type complex-long-float (complex-long-reg descriptor-reg) - :type (complex long-float)) + ;;; primitive other-pointer array types (/show0 "primtype.lisp 96") -(!def-primitive-type simple-string (descriptor-reg) - :type simple-base-string) -(!def-primitive-type simple-bit-vector (descriptor-reg)) -(!def-primitive-type simple-vector (descriptor-reg)) -(!def-primitive-type simple-array-unsigned-byte-2 (descriptor-reg) - :type (simple-array (unsigned-byte 2) (*))) -(!def-primitive-type simple-array-unsigned-byte-4 (descriptor-reg) - :type (simple-array (unsigned-byte 4) (*))) -(!def-primitive-type simple-array-unsigned-byte-8 (descriptor-reg) - :type (simple-array (unsigned-byte 8) (*))) -(!def-primitive-type simple-array-unsigned-byte-16 (descriptor-reg) - :type (simple-array (unsigned-byte 16) (*))) -(!def-primitive-type simple-array-unsigned-byte-32 (descriptor-reg) - :type (simple-array (unsigned-byte 32) (*))) -(!def-primitive-type simple-array-signed-byte-8 (descriptor-reg) - :type (simple-array (signed-byte 8) (*))) -(!def-primitive-type simple-array-signed-byte-16 (descriptor-reg) - :type (simple-array (signed-byte 16) (*))) -(!def-primitive-type simple-array-signed-byte-30 (descriptor-reg) - :type (simple-array (signed-byte 30) (*))) -(!def-primitive-type simple-array-signed-byte-32 (descriptor-reg) - :type (simple-array (signed-byte 32) (*))) -(!def-primitive-type simple-array-single-float (descriptor-reg) - :type (simple-array single-float (*))) -(!def-primitive-type simple-array-double-float (descriptor-reg) - :type (simple-array double-float (*))) -#!+long-float -(!def-primitive-type simple-array-long-float (descriptor-reg) - :type (simple-array long-float (*))) -(!def-primitive-type simple-array-complex-single-float (descriptor-reg) - :type (simple-array (complex single-float) (*))) -(!def-primitive-type simple-array-complex-double-float (descriptor-reg) - :type (simple-array (complex double-float) (*))) -#!+long-float -(!def-primitive-type simple-array-complex-long-float (descriptor-reg) - :type (simple-array (complex long-float) (*))) - -;;; Note: The complex array types are not included, 'cause it is pointless to -;;; restrict VOPs to them. +(macrolet ((define-simple-array-primitive-types () + `(progn + ,@(map 'list + (lambda (saetp) + `(!def-primitive-type + ,(saetp-primitive-type-name saetp) + (descriptor-reg) + :type (simple-array ,(saetp-specifier saetp) (*)))) + *specialized-array-element-type-properties*)))) + (define-simple-array-primitive-types)) +;;; Note: The complex array types are not included, 'cause it is +;;; pointless to restrict VOPs to them. ;;; other primitive other-pointer types (!def-primitive-type system-area-pointer (sap-reg descriptor-reg)) @@ -149,7 +118,7 @@ ;;;; PRIMITIVE-TYPE-OF and friends -;;; Return the most restrictive primitive type that contains Object. +;;; Return the most restrictive primitive type that contains OBJECT. (/show0 "primtype.lisp 147") (!def-vm-support-routine primitive-type-of (object) (let ((type (ctype-of object))) @@ -159,30 +128,6 @@ (t *backend-t-primitive-type*)))) -(defvar *simple-array-primitive-types* - '((base-char . simple-string) - (bit . simple-bit-vector) - ((unsigned-byte 2) . simple-array-unsigned-byte-2) - ((unsigned-byte 4) . simple-array-unsigned-byte-4) - ((unsigned-byte 8) . simple-array-unsigned-byte-8) - ((unsigned-byte 16) . simple-array-unsigned-byte-16) - ((unsigned-byte 32) . simple-array-unsigned-byte-32) - ((signed-byte 8) . simple-array-signed-byte-8) - ((signed-byte 16) . simple-array-signed-byte-16) - (fixnum . simple-array-signed-byte-30) - ((signed-byte 32) . simple-array-signed-byte-32) - (single-float . simple-array-single-float) - (double-float . simple-array-double-float) - #!+long-float (long-float . simple-array-long-float) - ((complex single-float) . simple-array-complex-single-float) - ((complex double-float) . simple-array-complex-double-float) - #!+long-float - ((complex long-float) . simple-array-complex-long-float) - (t . simple-vector)) - #!+sb-doc - "An a-list for mapping simple array element types to their - corresponding primitive types.") - ;;; Return the primitive type corresponding to a type descriptor ;;; structure. The second value is true when the primitive type is ;;; exactly equivalent to the argument Lisp type. @@ -215,32 +160,48 @@ (case t1-name (positive-fixnum (if (or (eq t2-name 'fixnum) - (eq t2-name #!-alpha 'signed-byte-32 - #!+alpha 'signed-byte-64) - (eq t2-name #!-alpha 'unsigned-byte-31 - #!+alpha 'unsigned-byte-63) - (eq t2-name #!-alpha 'unsigned-byte-32 - #!+alpha 'unsigned-byte-64)) + (eq t2-name + (ecase sb!vm::n-machine-word-bits + (32 'signed-byte-32) + (64 'signed-byte-64))) + (eq t2-name + (ecase sb!vm::n-machine-word-bits + (32 'unsigned-byte-31) + (64 'unsigned-byte-63))) + (eq t2-name + (ecase sb!vm::n-machine-word-bits + (32 'unsigned-byte-32) + (64 'unsigned-byte-64)))) t2)) (fixnum (case t2-name - (#!-alpha signed-byte-32 - #!+alpha signed-byte-64 t2) - (#!-alpha unsigned-byte-31 - #!+alpha unsigned-byte-63 - (primitive-type-or-lose - #!-alpha 'signed-byte-32 - #!+alpha 'signed-byte-64)))) - (#!-alpha signed-byte-32 - #!+alpha signed-byte-64 - (if (eq t2-name #!-alpha 'unsigned-byte-31 - #!+alpha 'unsigned-byte-63) + (#.(ecase sb!vm::n-machine-word-bits + (32 'signed-byte-32) + (64 'signed-byte-64)) + t2) + (#.(ecase sb!vm::n-machine-word-bits + (32 'unsigned-byte-31) + (64 'unsigned-byte-63)) + (primitive-type-or-lose + (ecase sb!vm::n-machine-word-bits + (32 'signed-byte-32) + (64 'signed-byte-64)))))) + (#.(ecase sb!vm::n-machine-word-bits + (32 'signed-byte-32) + (64 'signed-byte-64)) + (if (eq t2-name + (ecase sb!vm::n-machine-word-bits + (32 'unsigned-byte-31) + (64 'unsigned-byte-63))) t1)) - (#!-alpha unsigned-byte-31 - #!+alpha unsigned-byte-63 - (if (eq t2-name #!-alpha 'unsigned-byte-32 - #!+alpha 'unsigned-byte-64) - t2)))))) + (#.(ecase sb!vm::n-machine-word-bits + (32 'unsigned-byte-31) + (64 'unsigned-byte-63)) + (if (eq t2-name + (ecase sb!vm::n-machine-word-bits + (32 'unsigned-byte-32) + (64 'unsigned-byte-64))) + t2)))))) (etypecase type (numeric-type (let ((lo (numeric-type-low type)) @@ -251,25 +212,29 @@ (integer (cond ((and hi lo) (dolist (spec - `((positive-fixnum 0 ,(1- (ash 1 29))) - #!-alpha - (unsigned-byte-31 0 ,(1- (ash 1 31))) - #!-alpha - (unsigned-byte-32 0 ,(1- (ash 1 32))) - #!+alpha - (unsigned-byte-63 0 ,(1- (ash 1 63))) - #!+alpha - (unsigned-byte-64 0 ,(1- (ash 1 64))) - (fixnum ,(ash -1 29) - ,(1- (ash 1 29))) - #!-alpha - (signed-byte-32 ,(ash -1 31) - ,(1- (ash 1 31))) - #!+alpha - (signed-byte-64 ,(ash -1 63) - ,(1- (ash 1 63)))) - (if (or (< hi (ash -1 29)) - (> lo (1- (ash 1 29)))) + `((positive-fixnum 0 ,sb!xc:most-positive-fixnum) + ,@(ecase sb!vm::n-machine-word-bits + (32 + `((unsigned-byte-31 + 0 ,(1- (ash 1 31))) + (unsigned-byte-32 + 0 ,(1- (ash 1 32))))) + (64 + `((unsigned-byte-63 + 0 ,(1- (ash 1 63))) + (unsigned-byte-64 + 0 ,(1- (ash 1 64)))))) + (fixnum ,sb!xc:most-negative-fixnum + ,sb!xc:most-positive-fixnum) + ,(ecase sb!vm::n-machine-word-bits + (32 + `(signed-byte-32 ,(ash -1 31) + ,(1- (ash 1 31)))) + (64 + `(signed-byte-64 ,(ash -1 63) + ,(1- (ash 1 63)))))) + (if (or (< hi sb!xc:most-negative-fixnum) + (> lo sb!xc:most-positive-fixnum)) (part-of bignum) (any))) (let ((type (car spec)) @@ -279,8 +244,8 @@ (return (values (primitive-type-or-lose type) (and (= lo min) (= hi max)))))))) - ((or (and hi (< hi most-negative-fixnum)) - (and lo (> lo most-positive-fixnum))) + ((or (and hi (< hi sb!xc:most-negative-fixnum)) + (and lo (> lo sb!xc:most-positive-fixnum))) (part-of bignum)) (t (any)))) @@ -290,13 +255,9 @@ ((short-float single-float) (values (primitive-type-or-lose 'single-float) exact)) - ((double-float #!-long-float long-float) + ((double-float) (values (primitive-type-or-lose 'double-float) exact)) - #!+long-float - (long-float - (values (primitive-type-or-lose 'long-float) - exact)) (t (any))))) (t @@ -308,13 +269,9 @@ ((short-float single-float) (values (primitive-type-or-lose 'complex-single-float) exact)) - ((double-float #!-long-float long-float) + ((double-float long-float) (values (primitive-type-or-lose 'complex-double-float) exact)) - #!+long-float - (long-float - (values (primitive-type-or-lose 'complex-long-float) - exact)) (t (part-of complex)))) (part-of complex))) @@ -326,6 +283,9 @@ (let* ((dims (array-type-dimensions type)) (etype (array-type-specialized-element-type type)) (type-spec (type-specifier etype)) + ;; FIXME: We're _WHAT_? Testing for type equality + ;; with a specifier and #'EQUAL? *BOGGLE*. -- + ;; CSR, 2003-06-24 (ptype (cdr (assoc type-spec *simple-array-primitive-types* :test #'equal)))) (if (and (consp dims) (null (rest dims)) ptype) @@ -342,12 +302,35 @@ (primitive-type type) (unless ptype-exact (setq exact nil)) (unless (eq ptype res) - (let ((new-ptype - (or (maybe-numeric-type-union res ptype) + (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))))))))))) + (intersection-type + (let ((types (intersection-type-types type)) + (res (any)) + (exact nil)) + (dolist (type types (values res exact)) + (when (eq type (specifier-type 'function)) + ;; KLUDGE: Deal with (and function instance), both of which + ;; have an exact primitive type. + (return (part-of function))) + (multiple-value-bind (ptype ptype-exact) + (primitive-type type) + (when ptype-exact + ;; Apart from the previous kludge exact primitive + ;; types should match, if indeed there are any. It + ;; may be that this assumption isn't really safe, + ;; but at least we'll see what breaks. -- NS 20041104 + (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)))))) (member-type (let* ((members (member-type-members type)) (res (primitive-type-of (first members)))) @@ -363,28 +346,33 @@ (ecase (named-type-name type) ((t *) (values *backend-t-primitive-type* t)) ((nil) (any)))) - (sb!xc:built-in-class - (case (sb!xc:class-name type) - ((complex function instance - system-area-pointer weak-pointer) - (values (primitive-type-or-lose (sb!xc:class-name type)) t)) - (funcallable-instance - (part-of function)) - (base-char - (exactly base-char)) - (cons-type - (part-of list)) - (t - (any)))) - (fun-type - (exactly function)) - (sb!xc:class - (if (csubtypep type (specifier-type 'function)) - (part-of function) - (part-of instance))) - (ctype - (if (csubtypep type (specifier-type 'function)) - (part-of function) - (any))))))) + (character-set-type + (let ((pairs (character-set-type-pairs type))) + (if (and (= (length pairs) 1) + (= (caar pairs) 0) + (= (cdar pairs) (1- sb!xc:char-code-limit))) + (exactly character) + (part-of character)))) + (built-in-classoid + (case (classoid-name type) + ((complex function instance + system-area-pointer weak-pointer) + (values (primitive-type-or-lose (classoid-name type)) t)) + (funcallable-instance + (part-of function)) + (cons-type + (part-of list)) + (t + (any)))) + (fun-type + (exactly function)) + (classoid + (if (csubtypep type (specifier-type 'function)) + (part-of function) + (part-of instance))) + (ctype + (if (csubtypep type (specifier-type 'function)) + (part-of function) + (any))))))) (/show0 "primtype.lisp end of file")