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 (def!type sb!vm:word () `(unsigned-byte ,sb!vm:n-word-bits))
  20 (def!type sb!vm:signed-word () `(signed-byte ,sb!vm:n-word-bits))
  21
  22 \f
  23 ;;;; implementation-dependent DEFTYPEs
  24
  25 ;;; Make DOUBLE-FLOAT a synonym for LONG-FLOAT, SINGLE-FLOAT for
  26 ;;; SHORT-FLOAT. This is expanded before the translator gets a chance,
  27 ;;; so we will get precedence.
  28 #!-long-float
  29 (setf (info :type :kind 'long-float) :defined)
  30 #!-long-float
  31 (sb!xc:deftype long-float (&optional low high)
  32   `(double-float ,low ,high))
  33 (setf (info :type :kind 'short-float) :defined)
  34 (sb!xc:deftype short-float (&optional low high)
  35   `(single-float ,low ,high))
  36
  37 ;;; an index into an integer
  38 (sb!xc:deftype bit-index () `(integer 0 ,sb!xc:most-positive-fixnum))
  39
  40 ;;; worst-case values for float attributes
  41 (sb!xc:deftype float-exponent ()
  42   #!-long-float 'double-float-exponent
  43   #!+long-float 'long-float-exponent)
  44 (sb!xc:deftype float-digits ()
  45   #!-long-float `(integer 0 ,sb!vm:double-float-digits)
  46   #!+long-float `(integer 0 ,sb!vm:long-float-digits))
  47 (sb!xc:deftype float-radix () '(integer 2 2))
  48 (sb!xc:deftype float-int-exponent ()
  49   #!-long-float 'double-float-int-exponent
  50   #!+long-float 'long-float-int-exponent)
  51
  52 ;;; a code for BOOLE
  53 (sb!xc:deftype boole-code () '(unsigned-byte 4))
  54
  55 ;;; a byte specifier (as generated by BYTE)
  56 (sb!xc:deftype byte-specifier () 'cons)
  57
  58 ;;; result of CHAR-INT
  59 (sb!xc:deftype char-int () 'char-code)
  60
  61 ;;; PATHNAME pieces, as returned by the PATHNAME-xxx functions
  62 (sb!xc:deftype pathname-host () '(or sb!impl::host null))
  63 (sb!xc:deftype pathname-device ()
  64   '(or simple-string (member nil :unspecific :unc)))
  65 (sb!xc:deftype pathname-directory () 'list)
  66 (sb!xc:deftype pathname-name ()
  67   '(or simple-string sb!impl::pattern (member nil :unspecific :wild)))
  68 (sb!xc:deftype pathname-type ()
  69   '(or simple-string sb!impl::pattern (member nil :unspecific :wild)))
  70 (sb!xc:deftype pathname-version ()
  71   '(or integer (member nil :newest :wild :unspecific)))
  72
  73 ;;; internal time format. (Note: not a FIXNUM, ouch..)
  74 (sb!xc:deftype internal-time () 'unsigned-byte)
  75
  76 (sb!xc:deftype bignum-element-type () `(unsigned-byte ,sb!vm:n-word-bits))
  77 (sb!xc:deftype bignum-type () 'bignum)
  78 ;;; FIXME: see also DEFCONSTANT MAXIMUM-BIGNUM-LENGTH in
  79 ;;; src/code/bignum.lisp.  -- CSR, 2004-07-19
  80 (sb!xc:deftype bignum-index ()
  81   '(integer 0 #.(1- (ash 1 (- sb!vm:n-word-bits sb!vm:n-widetag-bits)))))
  82 \f
  83 ;;;; hooks into the type system
  84
  85 (sb!xc:deftype unboxed-array (&optional dims)
  86   (collect ((types (list 'or)))
  87     (dolist (type *specialized-array-element-types*)
  88       (when (subtypep type '(or integer character float (complex float)))
  89         (types `(array ,type ,dims))))
  90     (types)))
  91
  92 (sb!xc:deftype simple-unboxed-array (&optional dims)
  93   (collect ((types (list 'or)))
  94     (dolist (type *specialized-array-element-types*)
  95       (when (subtypep type '(or integer character float (complex float)))
  96         (types `(simple-array ,type ,dims))))
  97     (types)))
  98
  99 (sb!xc:deftype complex-vector (&optional element-type length)
 100   `(and (vector ,element-type ,length) (not simple-array)))
 101
 102 ;;; Return the symbol that describes the format of FLOAT.
 103 (declaim (ftype (function (float) symbol) float-format-name))
 104 (defun float-format-name (x)
 105   (etypecase x
 106     (single-float 'single-float)
 107     (double-float 'double-float)
 108     #!+long-float (long-float 'long-float)))
 109
 110 (defun contains-unknown-type-p (ctype)
 111   (cond ((unknown-type-p ctype) t)
 112         ((intersection-type-p ctype)
 113          (some #'contains-unknown-type-p (intersection-type-types ctype)))
 114         ((union-type-p ctype)
 115          (some #'contains-unknown-type-p (union-type-types ctype)))))
 116
 117 ;;; This function is called when the type code wants to find out how
 118 ;;; an array will actually be implemented. We set the
 119 ;;; SPECIALIZED-ELEMENT-TYPE to correspond to the actual
 120 ;;; specialization used in this implementation.
 121 (declaim (ftype (function (array-type) array-type) specialize-array-type))
 122 (defun specialize-array-type (type)
 123   (let ((eltype (array-type-element-type type)))
 124     (setf (array-type-specialized-element-type type)
 125           (if (or (eq eltype *wild-type*)
 126                   ;; This is slightly dubious, but not as dubious as
 127                   ;; assuming that the upgraded-element-type should be
 128                   ;; equal to T, given the way that the AREF
 129                   ;; DERIVE-TYPE optimizer works.  -- CSR, 2002-08-19
 130                   (contains-unknown-type-p eltype))
 131               *wild-type*
 132               (dolist (stype-name *specialized-array-element-types*
 133                                   *universal-type*)
 134                 ;; FIXME: Mightn't it be better to have
 135                 ;; *SPECIALIZED-ARRAY-ELEMENT-TYPES* be stored as precalculated
 136                 ;; SPECIFIER-TYPE results, instead of having to calculate
 137                 ;; them on the fly this way? (Call the new array
 138                 ;; *SPECIALIZED-ARRAY-ELEMENT-SPECIFIER-TYPES* or something..)
 139                 (let ((stype (specifier-type stype-name)))
 140                   (aver (not (unknown-type-p stype)))
 141                   (when (csubtypep eltype stype)
 142                     (return stype))))))
 143     type))
 144
 145 (defun sb!xc:upgraded-array-element-type (spec &optional environment)
 146   #!+sb-doc
 147   "Return the element type that will actually be used to implement an array
 148    with the specifier :ELEMENT-TYPE Spec."
 149   (declare (ignore environment))
 150   (handler-case
 151       ;; Can't rely on SPECIFIER-TYPE to signal PARSE-UNKNOWN-TYPE in
 152       ;; the case of (AND KNOWN UNKNOWN), since the result of the
 153       ;; outter call to SPECIFIER-TYPE can be cached by the code that
 154       ;; doesn't catch PARSE-UNKNOWN-TYPE signal.
 155       (if (contains-unknown-type-p (specifier-type spec))
 156           (error "Undefined type: ~S" spec)
 157           (type-specifier (array-type-specialized-element-type
 158                            (specifier-type `(array ,spec)))))
 159     (parse-unknown-type (c)
 160       (error "Undefined type: ~S" (parse-unknown-type-specifier c)))))
 161
 162 (defun sb!xc:upgraded-complex-part-type (spec &optional environment)
 163   #!+sb-doc
 164   "Return the element type of the most specialized COMPLEX number type that
 165    can hold parts of type SPEC."
 166   (declare (ignore environment))
 167   (let ((type (specifier-type spec)))
 168     (cond
 169       ((eq type *empty-type*) nil)
 170       ((unknown-type-p type) (error "undefined type: ~S" spec))
 171       (t
 172        (let ((ctype (specifier-type `(complex ,spec))))
 173          (cond
 174            ((eq ctype *empty-type*) '(eql 0))
 175            ((csubtypep ctype (specifier-type '(complex single-float)))
 176             'single-float)
 177            ((csubtypep ctype (specifier-type '(complex double-float)))
 178             'double-float)
 179            #!+long-float
 180            ((csubtypep ctype (specifier-type '(complex long-float)))
 181             'long-float)
 182            ((csubtypep ctype (specifier-type '(complex rational)))
 183             'rational)
 184            (t 'real)))))))
 185
 186 ;;; Return the most specific integer type that can be quickly checked that
 187 ;;; includes the given type.
 188 (defun containing-integer-type (subtype)
 189   (dolist (type `(fixnum
 190                   (signed-byte ,sb!vm:n-word-bits)
 191                   (unsigned-byte ,sb!vm:n-word-bits)
 192                   integer)
 193                 (error "~S isn't an integer type?" subtype))
 194     (when (csubtypep subtype (specifier-type type))
 195       (return type))))
 196
 197 ;;; If TYPE has a CHECK-xxx template, but doesn't have a corresponding
 198 ;;; PRIMITIVE-TYPE, then return the template's name. Otherwise, return NIL.
 199 (defun hairy-type-check-template-name (type)
 200   (declare (type ctype type))
 201   (typecase type
 202     (cons-type
 203      (if (type= type (specifier-type 'cons))
 204          'sb!c:check-cons
 205          nil))
 206     (built-in-classoid
 207      (if (type= type (specifier-type 'symbol))
 208          'sb!c:check-symbol
 209          nil))
 210     (numeric-type
 211      (cond ((type= type (specifier-type 'fixnum))
 212             'sb!c:check-fixnum)
 213            #!+#.(cl:if (cl:= 32 sb!vm:n-word-bits) '(and) '(or))
 214            ((type= type (specifier-type '(signed-byte 32)))
 215             'sb!c:check-signed-byte-32)
 216            #!+#.(cl:if (cl:= 32 sb!vm:n-word-bits) '(and) '(or))
 217            ((type= type (specifier-type '(unsigned-byte 32)))
 218             'sb!c:check-unsigned-byte-32)
 219            #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or))
 220            ((type= type (specifier-type '(signed-byte 64)))
 221             'sb!c:check-signed-byte-64)
 222            #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or))
 223            ((type= type (specifier-type '(unsigned-byte 64)))
 224             'sb!c:check-unsigned-byte-64)
 225            (t nil)))
 226     (fun-type
 227      'sb!c:check-fun)
 228     (t
 229      nil)))