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 (file-comment
  18   "$Header$")
  19
  20 (!begin-collecting-cold-init-forms)
  21 \f
  22 ;;;; FIXME: I'm not sure where to put this. -- WHN 19990817
  23
  24 (deftype sb!vm:word () `(unsigned-byte ,sb!vm:word-bits))
  25 \f
  26 ;;;; implementation-dependent DEFTYPEs
  27
  28 ;;; Make DOUBLE-FLOAT a synonym for LONG-FLOAT, SINGLE-FLOAT for SHORT-FLOAT.
  29 ;;; This is expanded before the translator gets a chance, so we will get
  30 ;;; precedence.
  31 #!-long-float
  32 (setf (info :type :kind 'long-float) :defined)
  33 #!-long-float
  34 (sb!xc:deftype long-float (&optional low high)
  35   `(double-float ,low ,high))
  36 (setf (info :type :kind 'short-float) :defined)
  37 (sb!xc:deftype short-float (&optional low high)
  38   `(single-float ,low ,high))
  39
  40 ;;; an index into an integer
  41 (sb!xc:deftype bit-index () `(integer 0 ,most-positive-fixnum))
  42
  43 ;;; worst-case values for float attributes
  44 (sb!xc:deftype float-exponent ()
  45   #!-long-float 'double-float-exponent
  46   #!+long-float 'long-float-exponent)
  47 (sb!xc:deftype float-digits ()
  48   #!-long-float `(integer 0 ,sb!vm:double-float-digits)
  49   #!+long-float `(integer 0 ,sb!vm:long-float-digits))
  50 (sb!xc:deftype float-radix () '(integer 2 2))
  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)))
  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:word-bits))
  77 (sb!xc:deftype bignum-type () 'bignum)
  78 (sb!xc:deftype bignum-index () 'index)
  79 \f
  80 ;;;; hooks into the type system
  81
  82 ;;; the kinds of specialized array that actually exist in this implementation
  83 (defvar *specialized-array-element-types*)
  84 (!cold-init-forms
  85   (setf *specialized-array-element-types*
  86         '(bit
  87           (unsigned-byte 2)
  88           (unsigned-byte 4)
  89           (unsigned-byte 8)
  90           (unsigned-byte 16)
  91           (unsigned-byte 32)
  92           (signed-byte 8)
  93           (signed-byte 16)
  94           (signed-byte 30)
  95           (signed-byte 32)
  96           (complex single-float)
  97           (complex double-float)
  98           #!+long-float (complex long-float)
  99           base-char
 100           single-float
 101           double-float
 102           #!+long-float long-float)))
 103
 104 (sb!xc:deftype unboxed-array (&optional dims)
 105   (collect ((types (list 'or)))
 106     (dolist (type *specialized-array-element-types*)
 107       (when (subtypep type '(or integer character float (complex float)))
 108         (types `(array ,type ,dims))))
 109     (types)))
 110
 111 (sb!xc:deftype simple-unboxed-array (&optional dims)
 112   (collect ((types (list 'or)))
 113     (dolist (type *specialized-array-element-types*)
 114       (when (subtypep type '(or integer character float (complex float)))
 115         (types `(simple-array ,type ,dims))))
 116     (types)))
 117
 118 ;;; Return the symbol that describes the format of FLOAT.
 119 (declaim (ftype (function (float) symbol) float-format-name))
 120 (defun float-format-name (x)
 121   (etypecase x
 122     (single-float 'single-float)
 123     (double-float 'double-float)
 124     #!+long-float (long-float 'long-float)))
 125
 126 ;;; This function is called when the type code wants to find out how
 127 ;;; an array will actually be implemented. We set the
 128 ;;; Specialized-Element-Type to correspond to the actual
 129 ;;; specialization used in this implementation.
 130 (declaim (ftype (function (array-type) array-type) specialize-array-type))
 131 (defun specialize-array-type (type)
 132   (let ((eltype (array-type-element-type type)))
 133     (setf (array-type-specialized-element-type type)
 134           (if (eq eltype *wild-type*)
 135               *wild-type*
 136               (dolist (stype-name *specialized-array-element-types*
 137                                   ;; FIXME: Use *UNIVERSAL-TYPE* here?
 138                                   (specifier-type 't))
 139                 ;; FIXME: Mightn't it be better to have
 140                 ;; *SPECIALIZED-ARRAY-ELEMENT-TYPES* be stored as precalculated
 141                 ;; SPECIFIER-TYPE results, instead of having to calculate
 142                 ;; them on the fly this way? (Call the new array
 143                 ;; *SPECIALIZED-ARRAY-ELEMENT-SPECIFIER-TYPES* or something..)
 144                 (let ((stype (specifier-type stype-name)))
 145                   (when (csubtypep eltype stype)
 146                     (return stype))))))
 147     type))
 148
 149 ;;; Return the most specific integer type that can be quickly checked that
 150 ;;; includes the given type.
 151 (defun containing-integer-type (subtype)
 152   (dolist (type '(fixnum
 153                   (signed-byte 32)
 154                   (unsigned-byte 32)
 155                   integer)
 156                 (error "~S isn't an integer type?" subtype))
 157     (when (csubtypep subtype (specifier-type type))
 158       (return type))))
 159
 160 ;;; If Type has a CHECK-xxx template, but doesn't have a corresponding
 161 ;;; primitive-type, then return the template's name. Otherwise, return NIL.
 162 (defun hairy-type-check-template-name (type)
 163   (declare (type ctype type))
 164   (typecase type
 165     (named-type
 166      (case (named-type-name type)
 167        (cons 'sb!c:check-cons)
 168        (symbol 'sb!c:check-symbol)
 169        (t nil)))
 170     (numeric-type
 171      (cond ((type= type (specifier-type 'fixnum))
 172             'sb!c:check-fixnum)
 173            ((type= type (specifier-type '(signed-byte 32)))
 174             'sb!c:check-signed-byte-32)
 175            ((type= type (specifier-type '(unsigned-byte 32)))
 176             'sb!c:check-unsigned-byte-32)
 177            (t nil)))
 178     (function-type
 179      'sb!c:check-function)
 180     (t
 181      nil)))
 182 \f
 183 (!defun-from-collected-cold-init-forms !vm-type-cold-init)