X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fgeneric%2Fvm-type.lisp;h=7782457b14227643dbd4cb4cd07a301b29fd2222;hb=5dcf5905dc38232b3cc5ec6b309ea5c6424db957;hp=2fac91bb931e557a90e45924eada04618bcacd36;hpb=a530bbe337109d898d5b4a001fc8f1afa3b5dc39;p=sbcl.git diff --git a/src/compiler/generic/vm-type.lisp b/src/compiler/generic/vm-type.lisp index 2fac91b..7782457 100644 --- a/src/compiler/generic/vm-type.lisp +++ b/src/compiler/generic/vm-type.lisp @@ -14,20 +14,15 @@ (in-package "SB!KERNEL") -(file-comment - "$Header$") - -(!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)) +(deftype sb!vm:word () `(unsigned-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 @@ -48,6 +43,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)) @@ -73,34 +71,12 @@ ;;; 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) ;;;; 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*) @@ -125,27 +101,42 @@ ;;; 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 +;;; SPECIALIZED-ELEMENT-TYPE to correspond to the actual ;;; specialization used in this implementation. (declaim (ftype (function (array-type) array-type) specialize-array-type)) (defun specialize-array-type (type) (let ((eltype (array-type-element-type type))) (setf (array-type-specialized-element-type type) - (if (eq eltype *wild-type*) + (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 + (unknown-type-p eltype)) *wild-type* (dolist (stype-name *specialized-array-element-types* - ;; FIXME: Use *UNIVERSAL-TYPE* here? - (specifier-type 't)) + *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)) + (if (unknown-type-p (specifier-type spec)) + (error "undefined type: ~S" spec) + (type-specifier (array-type-specialized-element-type + (specifier-type `(array ,spec)))))) + ;;; Return the most specific integer type that can be quickly checked that ;;; includes the given type. (defun containing-integer-type (subtype) @@ -157,16 +148,19 @@ (when (csubtypep subtype (specifier-type type)) (return type)))) -;;; If Type has a CHECK-xxx template, but doesn't have a corresponding -;;; primitive-type, then return the template's name. Otherwise, return NIL. +;;; If TYPE has a CHECK-xxx template, but doesn't have a corresponding +;;; PRIMITIVE-TYPE, then return the template's name. Otherwise, return NIL. (defun hairy-type-check-template-name (type) (declare (type ctype type)) (typecase type - (named-type - (case (named-type-name type) - (cons 'sb!c:check-cons) - (symbol 'sb!c:check-symbol) - (t nil))) + (cons-type + (if (type= type (specifier-type 'cons)) + 'sb!c:check-cons + nil)) + (built-in-classoid + (if (type= type (specifier-type 'symbol)) + 'sb!c:check-symbol + nil)) (numeric-type (cond ((type= type (specifier-type 'fixnum)) 'sb!c:check-fixnum) @@ -175,9 +169,7 @@ ((type= type (specifier-type '(unsigned-byte 32))) 'sb!c:check-unsigned-byte-32) (t nil))) - (function-type - 'sb!c:check-function) + (fun-type + 'sb!c:check-fun) (t nil))) - -(!defun-from-collected-cold-init-forms !vm-type-cold-init)