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