X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fgeneric%2Fvm-type.lisp;h=9d0a031e2efc8a1e4b052a74f61b9cfe913b3c15;hb=a189a69454ef7635149319ae213b337f17c50d20;hp=4a1b4fa74247c02e81949e4f4a0509da833ba59d;hpb=a8fa26a6e9804d3548f5bca9361a91345a689099;p=sbcl.git diff --git a/src/compiler/generic/vm-type.lisp b/src/compiler/generic/vm-type.lisp index 4a1b4fa..9d0a031 100644 --- a/src/compiler/generic/vm-type.lisp +++ b/src/compiler/generic/vm-type.lisp @@ -14,19 +14,17 @@ (in-package "SB!KERNEL") -(/show0 "vm-type.lisp 17") - -(!begin-collecting-cold-init-forms) - ;;;; FIXME: I'm not sure where to put this. -- WHN 19990817 -(deftype sb!vm:word () `(unsigned-byte ,sb!vm:word-bits)) +(def!type sb!vm:word () `(unsigned-byte ,sb!vm:n-word-bits)) +(def!type sb!vm:signed-word () `(signed-byte ,sb!vm:n-word-bits)) + ;;;; implementation-dependent DEFTYPEs -;;; Make DOUBLE-FLOAT a synonym for LONG-FLOAT, SINGLE-FLOAT for SHORT-FLOAT. -;;; This is expanded before the translator gets a chance, so we will get -;;; precedence. +;;; Make DOUBLE-FLOAT a synonym for LONG-FLOAT, SINGLE-FLOAT for +;;; SHORT-FLOAT. This is expanded before the translator gets a chance, +;;; so we will get precedence. #!-long-float (setf (info :type :kind 'long-float) :defined) #!-long-float @@ -37,7 +35,7 @@ `(single-float ,low ,high)) ;;; an index into an integer -(sb!xc:deftype bit-index () `(integer 0 ,most-positive-fixnum)) +(sb!xc:deftype bit-index () `(integer 0 ,sb!xc:most-positive-fixnum)) ;;; worst-case values for float attributes (sb!xc:deftype float-exponent () @@ -47,6 +45,9 @@ #!-long-float `(integer 0 ,sb!vm:double-float-digits) #!+long-float `(integer 0 ,sb!vm:long-float-digits)) (sb!xc:deftype float-radix () '(integer 2 2)) +(sb!xc:deftype float-int-exponent () + #!-long-float 'double-float-int-exponent + #!+long-float 'long-float-int-exponent) ;;; a code for BOOLE (sb!xc:deftype boole-code () '(unsigned-byte 4)) @@ -60,7 +61,7 @@ ;;; PATHNAME pieces, as returned by the PATHNAME-xxx functions (sb!xc:deftype pathname-host () '(or sb!impl::host null)) (sb!xc:deftype pathname-device () - '(or simple-string (member nil :unspecific))) + '(or simple-string (member nil :unspecific :unc))) (sb!xc:deftype pathname-directory () 'list) (sb!xc:deftype pathname-name () '(or simple-string sb!impl::pattern (member nil :unspecific :wild))) @@ -72,48 +73,32 @@ ;;; internal time format. (Note: not a FIXNUM, ouch..) (sb!xc:deftype internal-time () 'unsigned-byte) -(sb!xc:deftype bignum-element-type () `(unsigned-byte ,sb!vm:word-bits)) +(sb!xc:deftype bignum-element-type () `(unsigned-byte ,sb!vm:n-word-bits)) (sb!xc:deftype bignum-type () 'bignum) -(sb!xc:deftype bignum-index () 'index) +;;; FIXME: see also DEFCONSTANT MAXIMUM-BIGNUM-LENGTH in +;;; src/code/bignum.lisp. -- CSR, 2004-07-19 +(sb!xc:deftype bignum-index () + '(integer 0 #.(1- (ash 1 (- sb!vm:n-word-bits sb!vm:n-widetag-bits))))) ;;;; hooks into the type system -;;; the kinds of specialized array that actually exist in this implementation -(defvar *specialized-array-element-types*) -(!cold-init-forms - (setf *specialized-array-element-types* - '(bit - (unsigned-byte 2) - (unsigned-byte 4) - (unsigned-byte 8) - (unsigned-byte 16) - (unsigned-byte 32) - (signed-byte 8) - (signed-byte 16) - (signed-byte 30) - (signed-byte 32) - (complex single-float) - (complex double-float) - #!+long-float (complex long-float) - base-char - single-float - double-float - #!+long-float long-float))) - (sb!xc:deftype unboxed-array (&optional dims) (collect ((types (list 'or))) (dolist (type *specialized-array-element-types*) (when (subtypep type '(or integer character float (complex float))) - (types `(array ,type ,dims)))) + (types `(array ,type ,dims)))) (types))) (sb!xc:deftype simple-unboxed-array (&optional dims) (collect ((types (list 'or))) (dolist (type *specialized-array-element-types*) (when (subtypep type '(or integer character float (complex float))) - (types `(simple-array ,type ,dims)))) + (types `(simple-array ,type ,dims)))) (types))) +(sb!xc:deftype complex-vector (&optional element-type length) + `(and (vector ,element-type ,length) (not simple-array))) + ;;; Return the symbol that describes the format of FLOAT. (declaim (ftype (function (float) symbol) float-format-name)) (defun float-format-name (x) @@ -122,6 +107,13 @@ (double-float 'double-float) #!+long-float (long-float 'long-float))) +(defun contains-unknown-type-p (ctype) + (cond ((unknown-type-p ctype) t) + ((intersection-type-p ctype) + (some #'contains-unknown-type-p (intersection-type-types ctype))) + ((union-type-p ctype) + (some #'contains-unknown-type-p (union-type-types ctype))))) + ;;; This function is called when the type code wants to find out how ;;; an array will actually be implemented. We set the ;;; SPECIALIZED-ELEMENT-TYPE to correspond to the actual @@ -130,28 +122,75 @@ (defun specialize-array-type (type) (let ((eltype (array-type-element-type type))) (setf (array-type-specialized-element-type type) - (if (eq eltype *wild-type*) - *wild-type* - (dolist (stype-name *specialized-array-element-types* - *universal-type*) - ;; FIXME: Mightn't it be better to have - ;; *SPECIALIZED-ARRAY-ELEMENT-TYPES* be stored as precalculated - ;; SPECIFIER-TYPE results, instead of having to calculate - ;; them on the fly this way? (Call the new array - ;; *SPECIALIZED-ARRAY-ELEMENT-SPECIFIER-TYPES* or something..) - (let ((stype (specifier-type stype-name))) - (when (csubtypep eltype stype) - (return stype)))))) + (if (or (eq eltype *wild-type*) + ;; This is slightly dubious, but not as dubious as + ;; assuming that the upgraded-element-type should be + ;; equal to T, given the way that the AREF + ;; DERIVE-TYPE optimizer works. -- CSR, 2002-08-19 + (contains-unknown-type-p eltype)) + *wild-type* + (dolist (stype-name *specialized-array-element-types* + *universal-type*) + ;; FIXME: Mightn't it be better to have + ;; *SPECIALIZED-ARRAY-ELEMENT-TYPES* be stored as precalculated + ;; SPECIFIER-TYPE results, instead of having to calculate + ;; them on the fly this way? (Call the new array + ;; *SPECIALIZED-ARRAY-ELEMENT-SPECIFIER-TYPES* or something..) + (let ((stype (specifier-type stype-name))) + (aver (not (unknown-type-p stype))) + (when (csubtypep eltype stype) + (return stype)))))) type)) +(defun sb!xc:upgraded-array-element-type (spec &optional environment) + #!+sb-doc + "Return the element type that will actually be used to implement an array + with the specifier :ELEMENT-TYPE Spec." + (declare (ignore environment)) + (handler-case + ;; Can't rely on SPECIFIER-TYPE to signal PARSE-UNKNOWN-TYPE in + ;; the case of (AND KNOWN UNKNOWN), since the result of the + ;; outter call to SPECIFIER-TYPE can be cached by the code that + ;; doesn't catch PARSE-UNKNOWN-TYPE signal. + (if (contains-unknown-type-p (specifier-type spec)) + (error "Undefined type: ~S" spec) + (type-specifier (array-type-specialized-element-type + (specifier-type `(array ,spec))))) + (parse-unknown-type (c) + (error "Undefined type: ~S" (parse-unknown-type-specifier c))))) + +(defun sb!xc:upgraded-complex-part-type (spec &optional environment) + #!+sb-doc + "Return the element type of the most specialized COMPLEX number type that + can hold parts of type SPEC." + (declare (ignore environment)) + (let ((type (specifier-type spec))) + (cond + ((eq type *empty-type*) nil) + ((unknown-type-p type) (error "undefined type: ~S" spec)) + (t + (let ((ctype (specifier-type `(complex ,spec)))) + (cond + ((eq ctype *empty-type*) '(eql 0)) + ((csubtypep ctype (specifier-type '(complex single-float))) + 'single-float) + ((csubtypep ctype (specifier-type '(complex double-float))) + 'double-float) + #!+long-float + ((csubtypep ctype (specifier-type '(complex long-float))) + 'long-float) + ((csubtypep ctype (specifier-type '(complex rational))) + 'rational) + (t 'real))))))) + ;;; Return the most specific integer type that can be quickly checked that ;;; includes the given type. (defun containing-integer-type (subtype) - (dolist (type '(fixnum - (signed-byte 32) - (unsigned-byte 32) - integer) - (error "~S isn't an integer type?" subtype)) + (dolist (type `(fixnum + (signed-byte ,sb!vm:n-word-bits) + (unsigned-byte ,sb!vm:n-word-bits) + integer) + (error "~S isn't an integer type?" subtype)) (when (csubtypep subtype (specifier-type type)) (return type)))) @@ -162,25 +201,29 @@ (typecase type (cons-type (if (type= type (specifier-type 'cons)) - 'sb!c:check-cons - nil)) - (built-in-class + 'sb!c:check-cons + nil)) + (built-in-classoid (if (type= type (specifier-type 'symbol)) - 'sb!c:check-symbol - nil)) + 'sb!c:check-symbol + nil)) (numeric-type (cond ((type= type (specifier-type 'fixnum)) - 'sb!c:check-fixnum) - ((type= type (specifier-type '(signed-byte 32))) - 'sb!c:check-signed-byte-32) - ((type= type (specifier-type '(unsigned-byte 32))) - 'sb!c:check-unsigned-byte-32) - (t nil))) - (function-type - 'sb!c:check-function) + 'sb!c:check-fixnum) + #!+#.(cl:if (cl:= 32 sb!vm:n-word-bits) '(and) '(or)) + ((type= type (specifier-type '(signed-byte 32))) + 'sb!c:check-signed-byte-32) + #!+#.(cl:if (cl:= 32 sb!vm:n-word-bits) '(and) '(or)) + ((type= type (specifier-type '(unsigned-byte 32))) + 'sb!c:check-unsigned-byte-32) + #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or)) + ((type= type (specifier-type '(signed-byte 64))) + 'sb!c:check-signed-byte-64) + #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or)) + ((type= type (specifier-type '(unsigned-byte 64))) + 'sb!c:check-unsigned-byte-64) + (t nil))) + (fun-type + 'sb!c:check-fun) (t nil))) - -(!defun-from-collected-cold-init-forms !vm-type-cold-init) - -(/show0 "vm-type.lisp end of file")