src/compiler/generic/primtype.lisp

   1 ;;;; machine-independent aspects of the object representation and
   2 ;;;; primitive types
   3
   4 ;;;; This software is part of the SBCL system. See the README file for
   5 ;;;; more information.
   6 ;;;;
   7 ;;;; This software is derived from the CMU CL system, which was
   8 ;;;; written at Carnegie Mellon University and released into the
   9 ;;;; public domain. The software is in the public domain and is
  10 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  11 ;;;; files for more information.
  12
  13 (in-package "SB!VM")
  14
  15 (file-comment
  16   "$Header$")
  17 \f
  18 ;;;; primitive type definitions
  19
  20 (def-primitive-type t (descriptor-reg))
  21 (setf *backend-t-primitive-type* (primitive-type-or-lose 't))
  22
  23 ;;; primitive integer types that fit in registers
  24 (def-primitive-type positive-fixnum (any-reg signed-reg unsigned-reg)
  25   :type (unsigned-byte 29))
  26 #!-alpha
  27 (def-primitive-type unsigned-byte-31 (signed-reg unsigned-reg descriptor-reg)
  28   :type (unsigned-byte 31))
  29 #!-alpha
  30 (def-primitive-type unsigned-byte-32 (unsigned-reg descriptor-reg)
  31   :type (unsigned-byte 32))
  32 #!+alpha
  33 (def-primitive-type unsigned-byte-63 (signed-reg unsigned-reg descriptor-reg)
  34   :type (unsigned-byte 63))
  35 #!+alpha
  36 (def-primitive-type unsigned-byte-64 (unsigned-reg descriptor-reg)
  37   :type (unsigned-byte 64))
  38 (def-primitive-type fixnum (any-reg signed-reg)
  39   :type (signed-byte 30))
  40 #!-alpha
  41 (def-primitive-type signed-byte-32 (signed-reg descriptor-reg)
  42   :type (signed-byte 32))
  43 #!+alpha
  44 (def-primitive-type signed-byte-64 (signed-reg descriptor-reg)
  45   :type (signed-byte 64))
  46
  47 (defvar *fixnum-primitive-type* (primitive-type-or-lose 'fixnum))
  48
  49 (def-primitive-type-alias tagged-num (:or positive-fixnum fixnum))
  50 (def-primitive-type-alias unsigned-num (:or #!-alpha unsigned-byte-32
  51                                             #!-alpha unsigned-byte-31
  52                                             #!+alpha unsigned-byte-64
  53                                             #!+alpha unsigned-byte-63
  54                                             positive-fixnum))
  55 (def-primitive-type-alias signed-num (:or #!-alpha signed-byte-32
  56                                           #!+alpha signed-byte-64
  57                                           fixnum
  58                                           #!-alpha unsigned-byte-31
  59                                           #!+alpha unsigned-byte-63
  60                                           positive-fixnum))
  61
  62 ;;; other primitive immediate types
  63 (def-primitive-type base-char (base-char-reg any-reg))
  64
  65 ;;; primitive pointer types
  66 (def-primitive-type function (descriptor-reg))
  67 (def-primitive-type list (descriptor-reg))
  68 (def-primitive-type instance (descriptor-reg))
  69
  70 (def-primitive-type funcallable-instance (descriptor-reg))
  71
  72 ;;; primitive other-pointer number types
  73 (def-primitive-type bignum (descriptor-reg))
  74 (def-primitive-type ratio (descriptor-reg))
  75 (def-primitive-type complex (descriptor-reg))
  76 (def-primitive-type single-float (single-reg descriptor-reg))
  77 (def-primitive-type double-float (double-reg descriptor-reg))
  78 #!+long-float
  79 (def-primitive-type long-float (long-reg descriptor-reg))
  80 (def-primitive-type complex-single-float (complex-single-reg descriptor-reg)
  81   :type (complex single-float))
  82 (def-primitive-type complex-double-float (complex-double-reg descriptor-reg)
  83   :type (complex double-float))
  84 #!+long-float
  85 (def-primitive-type complex-long-float (complex-long-reg descriptor-reg)
  86   :type (complex long-float))
  87
  88 ;;; primitive other-pointer array types
  89 (def-primitive-type simple-string (descriptor-reg)
  90   :type simple-base-string)
  91 (def-primitive-type simple-bit-vector (descriptor-reg))
  92 (def-primitive-type simple-vector (descriptor-reg))
  93 (def-primitive-type simple-array-unsigned-byte-2 (descriptor-reg)
  94   :type (simple-array (unsigned-byte 2) (*)))
  95 (def-primitive-type simple-array-unsigned-byte-4 (descriptor-reg)
  96   :type (simple-array (unsigned-byte 4) (*)))
  97 (def-primitive-type simple-array-unsigned-byte-8 (descriptor-reg)
  98   :type (simple-array (unsigned-byte 8) (*)))
  99 (def-primitive-type simple-array-unsigned-byte-16 (descriptor-reg)
 100   :type (simple-array (unsigned-byte 16) (*)))
 101 (def-primitive-type simple-array-unsigned-byte-32 (descriptor-reg)
 102   :type (simple-array (unsigned-byte 32) (*)))
 103 (def-primitive-type simple-array-signed-byte-8 (descriptor-reg)
 104   :type (simple-array (signed-byte 8) (*)))
 105 (def-primitive-type simple-array-signed-byte-16 (descriptor-reg)
 106   :type (simple-array (signed-byte 16) (*)))
 107 (def-primitive-type simple-array-signed-byte-30 (descriptor-reg)
 108   :type (simple-array (signed-byte 30) (*)))
 109 (def-primitive-type simple-array-signed-byte-32 (descriptor-reg)
 110   :type (simple-array (signed-byte 32) (*)))
 111 (def-primitive-type simple-array-single-float (descriptor-reg)
 112   :type (simple-array single-float (*)))
 113 (def-primitive-type simple-array-double-float (descriptor-reg)
 114   :type (simple-array double-float (*)))
 115 #!+long-float
 116 (def-primitive-type simple-array-long-float (descriptor-reg)
 117   :type (simple-array long-float (*)))
 118 (def-primitive-type simple-array-complex-single-float (descriptor-reg)
 119   :type (simple-array (complex single-float) (*)))
 120 (def-primitive-type simple-array-complex-double-float (descriptor-reg)
 121   :type (simple-array (complex double-float) (*)))
 122 #!+long-float
 123 (def-primitive-type simple-array-complex-long-float (descriptor-reg)
 124   :type (simple-array (complex long-float) (*)))
 125
 126 ;;; Note: The complex array types are not included, 'cause it is pointless to
 127 ;;; restrict VOPs to them.
 128
 129 ;;; other primitive other-pointer types
 130 (def-primitive-type system-area-pointer (sap-reg descriptor-reg))
 131 (def-primitive-type weak-pointer (descriptor-reg))
 132
 133 ;;; miscellaneous primitive types that don't exist at the LISP level
 134 (def-primitive-type catch-block (catch-block) :type nil)
 135 \f
 136 ;;;; PRIMITIVE-TYPE-OF and friends
 137
 138 ;;; Return the most restrictive primitive type that contains Object.
 139 (def-vm-support-routine primitive-type-of (object)
 140   (let ((type (ctype-of object)))
 141     (cond ((not (member-type-p type)) (primitive-type type))
 142           ((equal (member-type-members type) '(nil))
 143            (primitive-type-or-lose 'list))
 144           (t
 145            *backend-t-primitive-type*))))
 146
 147 (defvar *simple-array-primitive-types*
 148   '((base-char . simple-string)
 149     (bit . simple-bit-vector)
 150     ((unsigned-byte 2) . simple-array-unsigned-byte-2)
 151     ((unsigned-byte 4) . simple-array-unsigned-byte-4)
 152     ((unsigned-byte 8) . simple-array-unsigned-byte-8)
 153     ((unsigned-byte 16) . simple-array-unsigned-byte-16)
 154     ((unsigned-byte 32) . simple-array-unsigned-byte-32)
 155     ((signed-byte 8) . simple-array-signed-byte-8)
 156     ((signed-byte 16) . simple-array-signed-byte-16)
 157     (fixnum . simple-array-signed-byte-30)
 158     ((signed-byte 32) . simple-array-signed-byte-32)
 159     (single-float . simple-array-single-float)
 160     (double-float . simple-array-double-float)
 161     #!+long-float (long-float . simple-array-long-float)
 162     ((complex single-float) . simple-array-complex-single-float)
 163     ((complex double-float) . simple-array-complex-double-float)
 164     #!+long-float
 165     ((complex long-float) . simple-array-complex-long-float)
 166     (t . simple-vector))
 167   #!+sb-doc
 168   "An a-list for mapping simple array element types to their
 169   corresponding primitive types.")
 170
 171 ;;; Return the primitive type corresponding to a type descriptor
 172 ;;; structure. The second value is true when the primitive type is
 173 ;;; exactly equivalent to the argument Lisp type.
 174 ;;;
 175 ;;; In a bootstrapping situation, we should be careful to use the
 176 ;;; correct values for the system parameters.
 177 ;;;
 178 ;;; We need an aux function because we need to use both def-vm-support-routine
 179 ;;; and defun-cached.
 180 (def-vm-support-routine primitive-type (type)
 181   (primitive-type-aux type))
 182 (defun-cached (primitive-type-aux
 183                :hash-function (lambda (x)
 184                                 (logand (type-hash-value x) #x1FF))
 185                :hash-bits 9
 186                :values 2
 187                :default (values nil :empty))
 188               ((type eq))
 189   (declare (type ctype type))
 190   (macrolet ((any () '(values *backend-t-primitive-type* nil))
 191              (exactly (type)
 192                `(values (primitive-type-or-lose ',type) t))
 193              (part-of (type)
 194                `(values (primitive-type-or-lose ',type) nil)))
 195     (flet ((maybe-numeric-type-union (t1 t2)
 196              (let ((t1-name (primitive-type-name t1))
 197                    (t2-name (primitive-type-name t2)))
 198                (case t1-name
 199                  (positive-fixnum
 200                   (if (or (eq t2-name 'fixnum)
 201                           (eq t2-name #!-alpha 'signed-byte-32
 202                                       #!+alpha 'signed-byte-64)
 203                           (eq t2-name #!-alpha 'unsigned-byte-31
 204                                       #!+alpha 'unsigned-byte-63)
 205                           (eq t2-name #!-alpha 'unsigned-byte-32
 206                                       #!+alpha 'unsigned-byte-64))
 207                       t2))
 208                  (fixnum
 209                   (case t2-name
 210                     (#!-alpha signed-byte-32
 211                      #!+alpha signed-byte-64 t2)
 212                     (#!-alpha unsigned-byte-31
 213                      #!+alpha unsigned-byte-63
 214                      (primitive-type-or-lose
 215                       #!-alpha 'signed-byte-32
 216                       #!+alpha 'signed-byte-64))))
 217                  (#!-alpha signed-byte-32
 218                   #!+alpha signed-byte-64
 219                   (if (eq t2-name #!-alpha 'unsigned-byte-31
 220                                   #!+alpha 'unsigned-byte-63)
 221                       t1))
 222                  (#!-alpha unsigned-byte-31
 223                   #!+alpha unsigned-byte-63
 224                   (if (eq t2-name #!-alpha 'unsigned-byte-32
 225                                   #!+alpha 'unsigned-byte-64)
 226                       t2))))))
 227       (etypecase type
 228         (numeric-type
 229          (let ((lo (numeric-type-low type))
 230                (hi (numeric-type-high type)))
 231            (case (numeric-type-complexp type)
 232              (:real
 233               (case (numeric-type-class type)
 234                 (integer
 235                  (cond ((and hi lo)
 236                         (dolist (spec
 237                                   `((positive-fixnum 0 ,(1- (ash 1 29)))
 238                                     #!-alpha
 239                                     (unsigned-byte-31 0 ,(1- (ash 1 31)))
 240                                     #!-alpha
 241                                     (unsigned-byte-32 0 ,(1- (ash 1 32)))
 242                                     #!+alpha
 243                                     (unsigned-byte-63 0 ,(1- (ash 1 63)))
 244                                     #!+alpha
 245                                     (unsigned-byte-64 0 ,(1- (ash 1 64)))
 246                                     (fixnum ,(ash -1 29)
 247                                             ,(1- (ash 1 29)))
 248                                     #!-alpha
 249                                     (signed-byte-32 ,(ash -1 31)
 250                                                           ,(1- (ash 1 31)))
 251                                     #!+alpha
 252                                     (signed-byte-64 ,(ash -1 63)
 253                                                     ,(1- (ash 1 63))))
 254                                  (if (or (< hi (ash -1 29))
 255                                          (> lo (1- (ash 1 29))))
 256                                      (part-of bignum)
 257                                      (any)))
 258                           (let ((type (car spec))
 259                                 (min (cadr spec))
 260                                 (max (caddr spec)))
 261                             (when (<= min lo hi max)
 262                               (return (values
 263                                        (primitive-type-or-lose type)
 264                                        (and (= lo min) (= hi max))))))))
 265                        ((or (and hi (< hi most-negative-fixnum))
 266                             (and lo (> lo most-positive-fixnum)))
 267                         (part-of bignum))
 268                        (t
 269                         (any))))
 270                 (float
 271                  (let ((exact (and (null lo) (null hi))))
 272                    (case (numeric-type-format type)
 273                      ((short-float single-float)
 274                       (values (primitive-type-or-lose 'single-float)
 275                               exact))
 276                      ((double-float #!-long-float long-float)
 277                       (values (primitive-type-or-lose 'double-float)
 278                               exact))
 279                      #!+long-float
 280                      (long-float
 281                       (values (primitive-type-or-lose 'long-float)
 282                               exact))
 283                      (t
 284                       (any)))))
 285                 (t
 286                  (any))))
 287              (:complex
 288               (if (eq (numeric-type-class type) 'float)
 289                   (let ((exact (and (null lo) (null hi))))
 290                     (case (numeric-type-format type)
 291                       ((short-float single-float)
 292                        (values (primitive-type-or-lose 'complex-single-float)
 293                                exact))
 294                       ((double-float #!-long-float long-float)
 295                        (values (primitive-type-or-lose 'complex-double-float)
 296                                exact))
 297                       #!+long-float
 298                       (long-float
 299                        (values (primitive-type-or-lose 'complex-long-float)
 300                                exact))
 301                       (t
 302                        (part-of complex))))
 303                   (part-of complex)))
 304              (t
 305               (any)))))
 306         (array-type
 307          (if (array-type-complexp type)
 308              (any)
 309              (let* ((dims (array-type-dimensions type))
 310                     (etype (array-type-specialized-element-type type))
 311                     (type-spec (type-specifier etype))
 312                     (ptype (cdr (assoc type-spec *simple-array-primitive-types*
 313                                        :test #'equal))))
 314                (if (and (consp dims) (null (rest dims)) ptype)
 315                    (values (primitive-type-or-lose ptype)
 316                            (eq (first dims) '*))
 317                    (any)))))
 318         (union-type
 319          (if (type= type (specifier-type 'list))
 320              (exactly list)
 321              (let ((types (union-type-types type)))
 322                (multiple-value-bind (res exact) (primitive-type (first types))
 323                  (dolist (type (rest types) (values res exact))
 324                    (multiple-value-bind (ptype ptype-exact)
 325                        (primitive-type type)
 326                      (unless ptype-exact (setq exact nil))
 327                      (unless (eq ptype res)
 328                        (let ((new-ptype
 329                               (or (maybe-numeric-type-union res ptype)
 330                                   (maybe-numeric-type-union ptype res))))
 331                          (if new-ptype
 332                              (setq res new-ptype)
 333                              (return (any)))))))))))
 334         (member-type
 335          (let* ((members (member-type-members type))
 336                 (res (primitive-type-of (first members))))
 337            (dolist (mem (rest members) (values res nil))
 338              (let ((ptype (primitive-type-of mem)))
 339                (unless (eq ptype res)
 340                  (let ((new-ptype (or (maybe-numeric-type-union res ptype)
 341                                       (maybe-numeric-type-union ptype res))))
 342                    (if new-ptype
 343                        (setq res new-ptype)
 344                        (return (any)))))))))
 345         (named-type
 346          (ecase (named-type-name type)
 347            ((t *) (values *backend-t-primitive-type* t))
 348            ((nil) (any))))
 349         (sb!xc:built-in-class
 350          (case (sb!xc:class-name type)
 351            ((complex function instance
 352              system-area-pointer weak-pointer)
 353             (values (primitive-type-or-lose (sb!xc:class-name type)) t))
 354            (funcallable-instance
 355             (part-of function))
 356            (base-char
 357             (exactly base-char))
 358            (cons
 359             (part-of list))
 360            (t
 361             (any))))
 362         (function-type
 363          (exactly function))
 364         (sb!xc:class
 365          (if (csubtypep type (specifier-type 'function))
 366              (part-of function)
 367              (part-of instance)))
 368         (ctype
 369          (any))))))