src/compiler/generic/vm-type.lisp

   1 ;;;; This file contains implementation-dependent parts of the type
   2 ;;;; support code. This is stuff which deals with the mapping from
   3 ;;;; types defined in Common Lisp to types actually supported by an
   4 ;;;; implementation.
   5
   6 ;;;; This software is part of the SBCL system. See the README file for
   7 ;;;; more information.
   8 ;;;;
   9 ;;;; This software is derived from the CMU CL system, which was
  10 ;;;; written at Carnegie Mellon University and released into the
  11 ;;;; public domain. The software is in the public domain and is
  12 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  13 ;;;; files for more information.
  14
  15 (in-package "SB!KERNEL")
  16
  17 ;;;; FIXME: I'm not sure where to put this. -- WHN 19990817
  18
  19 (deftype sb!vm:word () `(unsigned-byte ,sb!vm:n-word-bits))
  20 \f
  21 ;;;; implementation-dependent DEFTYPEs
  22
  23 ;;; Make DOUBLE-FLOAT a synonym for LONG-FLOAT, SINGLE-FLOAT for
  24 ;;; SHORT-FLOAT. This is expanded before the translator gets a chance,
  25 ;;; so we will get precedence.
  26 #!-long-float
  27 (setf (info :type :kind 'long-float) :defined)
  28 #!-long-float
  29 (sb!xc:deftype long-float (&optional low high)
  30   `(double-float ,low ,high))
  31 (setf (info :type :kind 'short-float) :defined)
  32 (sb!xc:deftype short-float (&optional low high)
  33   `(single-float ,low ,high))
  34
  35 ;;; an index into an integer
  36 (sb!xc:deftype bit-index () `(integer 0 ,sb!xc:most-positive-fixnum))
  37
  38 ;;; worst-case values for float attributes
  39 (sb!xc:deftype float-exponent ()
  40   #!-long-float 'double-float-exponent
  41   #!+long-float 'long-float-exponent)
  42 (sb!xc:deftype float-digits ()
  43   #!-long-float `(integer 0 ,sb!vm:double-float-digits)
  44   #!+long-float `(integer 0 ,sb!vm:long-float-digits))
  45 (sb!xc:deftype float-radix () '(integer 2 2))
  46 (sb!xc:deftype float-int-exponent ()
  47   #!-long-float 'double-float-int-exponent
  48   #!+long-float 'long-float-int-exponent)
  49
  50 ;;; a code for BOOLE
  51 (sb!xc:deftype boole-code () '(unsigned-byte 4))
  52
  53 ;;; a byte specifier (as generated by BYTE)
  54 (sb!xc:deftype byte-specifier () 'cons)
  55
  56 ;;; result of CHAR-INT
  57 (sb!xc:deftype char-int () 'char-code)
  58
  59 ;;; PATHNAME pieces, as returned by the PATHNAME-xxx functions
  60 (sb!xc:deftype pathname-host () '(or sb!impl::host null))
  61 (sb!xc:deftype pathname-device ()
  62   '(or simple-string (member nil :unspecific)))
  63 (sb!xc:deftype pathname-directory () 'list)
  64 (sb!xc:deftype pathname-name ()
  65   '(or simple-string sb!impl::pattern (member nil :unspecific :wild)))
  66 (sb!xc:deftype pathname-type ()
  67   '(or simple-string sb!impl::pattern (member nil :unspecific :wild)))
  68 (sb!xc:deftype pathname-version ()
  69   '(or integer (member nil :newest :wild :unspecific)))
  70
  71 ;;; internal time format. (Note: not a FIXNUM, ouch..)
  72 (sb!xc:deftype internal-time () 'unsigned-byte)
  73
  74 (sb!xc:deftype bignum-element-type () `(unsigned-byte ,sb!vm:n-word-bits))
  75 (sb!xc:deftype bignum-type () 'bignum)
  76 (sb!xc:deftype bignum-index () 'index)
  77 \f
  78 ;;;; hooks into the type system
  79
  80 (sb!xc:deftype unboxed-array (&optional dims)
  81   (collect ((types (list 'or)))
  82     (dolist (type *specialized-array-element-types*)
  83       (when (subtypep type '(or integer character float (complex float)))
  84         (types `(array ,type ,dims))))
  85     (types)))
  86
  87 (sb!xc:deftype simple-unboxed-array (&optional dims)
  88   (collect ((types (list 'or)))
  89     (dolist (type *specialized-array-element-types*)
  90       (when (subtypep type '(or integer character float (complex float)))
  91         (types `(simple-array ,type ,dims))))
  92     (types)))
  93
  94 ;;; Return the symbol that describes the format of FLOAT.
  95 (declaim (ftype (function (float) symbol) float-format-name))
  96 (defun float-format-name (x)
  97   (etypecase x
  98     (single-float 'single-float)
  99     (double-float 'double-float)
 100     #!+long-float (long-float 'long-float)))
 101
 102 ;;; This function is called when the type code wants to find out how
 103 ;;; an array will actually be implemented. We set the
 104 ;;; SPECIALIZED-ELEMENT-TYPE to correspond to the actual
 105 ;;; specialization used in this implementation.
 106 (declaim (ftype (function (array-type) array-type) specialize-array-type))
 107 (defun specialize-array-type (type)
 108   (let ((eltype (array-type-element-type type)))
 109     (setf (array-type-specialized-element-type type)
 110           (if (or (eq eltype *wild-type*)
 111                   ;; This is slightly dubious, but not as dubious as
 112                   ;; assuming that the upgraded-element-type should be
 113                   ;; equal to T, given the way that the AREF
 114                   ;; DERIVE-TYPE optimizer works.  -- CSR, 2002-08-19
 115                   (unknown-type-p eltype))
 116               *wild-type*
 117               (dolist (stype-name *specialized-array-element-types*
 118                                   *universal-type*)
 119                 ;; FIXME: Mightn't it be better to have
 120                 ;; *SPECIALIZED-ARRAY-ELEMENT-TYPES* be stored as precalculated
 121                 ;; SPECIFIER-TYPE results, instead of having to calculate
 122                 ;; them on the fly this way? (Call the new array
 123                 ;; *SPECIALIZED-ARRAY-ELEMENT-SPECIFIER-TYPES* or something..)
 124                 (let ((stype (specifier-type stype-name)))
 125                   (aver (not (unknown-type-p stype)))
 126                   (when (csubtypep eltype stype)
 127                     (return stype))))))
 128     type))
 129
 130 (defun sb!xc:upgraded-array-element-type (spec &optional environment)
 131   #!+sb-doc
 132   "Return the element type that will actually be used to implement an array
 133    with the specifier :ELEMENT-TYPE Spec."
 134   (declare (ignore environment))
 135   (if (unknown-type-p (specifier-type spec))
 136       (error "undefined type: ~S" spec)
 137       (type-specifier (array-type-specialized-element-type
 138                        (specifier-type `(array ,spec))))))
 139
 140 (defun sb!xc:upgraded-complex-part-type (spec &optional environment)
 141   #!+sb-doc
 142   "Return the element type of the most specialized COMPLEX number type that
 143    can hold parts of type SPEC."
 144   (declare (ignore environment))
 145   (if (unknown-type-p (specifier-type spec))
 146       (error "undefined type: ~S" spec)
 147       (let ((ctype (specifier-type `(complex ,spec))))
 148         (cond
 149           ((eq ctype *empty-type*) '(eql 0))
 150           ((csubtypep ctype (specifier-type '(complex single-float)))
 151            'single-float)
 152           ((csubtypep ctype (specifier-type '(complex double-float)))
 153            'double-float)
 154           #!+long-float
 155           ((csubtypep ctype (specifier-type '(complex long-float)))
 156            'long-float)
 157           ((csubtypep ctype (specifier-type '(complex rational)))
 158            'rational)
 159           (t 'real)))))
 160
 161 ;;; Return the most specific integer type that can be quickly checked that
 162 ;;; includes the given type.
 163 (defun containing-integer-type (subtype)
 164   (dolist (type '(fixnum
 165                   (signed-byte 32)
 166                   (unsigned-byte 32)
 167                   integer)
 168                 (error "~S isn't an integer type?" subtype))
 169     (when (csubtypep subtype (specifier-type type))
 170       (return type))))
 171
 172 ;;; If TYPE has a CHECK-xxx template, but doesn't have a corresponding
 173 ;;; PRIMITIVE-TYPE, then return the template's name. Otherwise, return NIL.
 174 (defun hairy-type-check-template-name (type)
 175   (declare (type ctype type))
 176   (typecase type
 177     (cons-type
 178      (if (type= type (specifier-type 'cons))
 179          'sb!c:check-cons
 180          nil))
 181     (built-in-classoid
 182      (if (type= type (specifier-type 'symbol))
 183          'sb!c:check-symbol
 184          nil))
 185     (numeric-type
 186      (cond ((type= type (specifier-type 'fixnum))
 187             'sb!c:check-fixnum)
 188            ((type= type (specifier-type '(signed-byte 32)))
 189             'sb!c:check-signed-byte-32)
 190            ((type= type (specifier-type '(unsigned-byte 32)))
 191             'sb!c:check-unsigned-byte-32)
 192            (t nil)))
 193     (fun-type
 194      'sb!c:check-fun)
 195     (t
 196      nil)))