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 #.sb!vm:n-positive-fixnum-bits))
  27 (/show0 "primtype.lisp 27")
  28 #!-64-bit-registers
  29 (!def-primitive-type unsigned-byte-31 (signed-reg unsigned-reg descriptor-reg)
  30   :type (unsigned-byte 31))
  31 (/show0 "primtype.lisp 31")
  32 #!-64-bit-registers
  33 (!def-primitive-type unsigned-byte-32 (unsigned-reg descriptor-reg)
  34   :type (unsigned-byte 32))
  35 (/show0 "primtype.lisp 35")
  36 #!+64-bit-registers
  37 (!def-primitive-type unsigned-byte-63 (signed-reg unsigned-reg descriptor-reg)
  38   :type (unsigned-byte 63))
  39 #!+64-bit-registers
  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 #.(1+ n-positive-fixnum-bits)))
  44 #!-64-bit-registers
  45 (!def-primitive-type signed-byte-32 (signed-reg descriptor-reg)
  46   :type (signed-byte 32))
  47 #!+64-bit-registers
  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 (multiple-value-bind (unsigned signed)
  56     (case sb!vm::n-machine-word-bits
  57       (64 (values '(unsigned-byte-64 unsigned-byte-63 positive-fixnum)
  58                   '(signed-byte-64 fixnum unsigned-byte-63 positive-fixnum)))
  59       (32 (values '(unsigned-byte-32 unsigned-byte-31 positive-fixnum)
  60                   '(signed-byte-32 fixnum unsigned-byte-31 positive-fixnum))))
  61   (!def-primitive-type-alias unsigned-num `(:or ,@unsigned))
  62   (!def-primitive-type-alias signed-num `(:or ,@signed))
  63   (!def-primitive-type-alias untagged-num
  64     `(:or ,@(sort (copy-list (union unsigned signed)) #'string<))))
  65
  66 ;;; other primitive immediate types
  67 (/show0 "primtype.lisp 68")
  68 (!def-primitive-type character (character-reg any-reg))
  69
  70 ;;; primitive pointer types
  71 (/show0 "primtype.lisp 73")
  72 (!def-primitive-type function (descriptor-reg))
  73 (!def-primitive-type list (descriptor-reg))
  74 (!def-primitive-type instance (descriptor-reg))
  75
  76 (/show0 "primtype.lisp 77")
  77 (!def-primitive-type funcallable-instance (descriptor-reg))
  78
  79 ;;; primitive other-pointer number types
  80 (/show0 "primtype.lisp 81")
  81 (!def-primitive-type bignum (descriptor-reg))
  82 (!def-primitive-type ratio (descriptor-reg))
  83 (!def-primitive-type complex (descriptor-reg))
  84 (/show0 "about to !DEF-PRIMITIVE-TYPE SINGLE-FLOAT")
  85 (!def-primitive-type single-float (single-reg descriptor-reg))
  86 (/show0 "about to !DEF-PRIMITIVE-TYPE DOUBLE-FLOAT")
  87 (!def-primitive-type double-float (double-reg descriptor-reg))
  88
  89 (/show0 "about to !DEF-PRIMITIVE-TYPE COMPLEX-SINGLE-FLOAT")
  90 (!def-primitive-type complex-single-float (complex-single-reg descriptor-reg)
  91   :type (complex single-float))
  92 (/show0 "about to !DEF-PRIMITIVE-TYPE COMPLEX-DOUBLE-FLOAT")
  93 (!def-primitive-type complex-double-float (complex-double-reg descriptor-reg)
  94   :type (complex double-float))
  95 #!+sb-simd-pack
  96 (progn
  97   (/show0 "about to !DEF-PRIMITIVE-TYPE SIMD-PACK")
  98   (!def-primitive-type simd-pack-single (single-sse-reg descriptor-reg)
  99     :type (simd-pack single-float))
 100   (!def-primitive-type simd-pack-double (double-sse-reg descriptor-reg)
 101     :type (simd-pack double-float))
 102   (!def-primitive-type simd-pack-int (int-sse-reg descriptor-reg)
 103    :type (simd-pack integer))
 104   (!def-primitive-type-alias simd-pack
 105    '(:or simd-pack-single simd-pack-double simd-pack-int)))
 106
 107 ;;; primitive other-pointer array types
 108 (/show0 "primtype.lisp 96")
 109 (macrolet ((define-simple-array-primitive-types ()
 110                `(progn
 111                  ,@(map 'list
 112                         (lambda (saetp)
 113                           `(!def-primitive-type
 114                             ,(saetp-primitive-type-name saetp)
 115                             (descriptor-reg)
 116                             :type (simple-array ,(saetp-specifier saetp) (*))))
 117                         *specialized-array-element-type-properties*))))
 118   (define-simple-array-primitive-types))
 119 ;;; Note: The complex array types are not included, 'cause it is
 120 ;;; pointless to restrict VOPs to them.
 121
 122 ;;; other primitive other-pointer types
 123 (!def-primitive-type system-area-pointer (sap-reg descriptor-reg))
 124 (!def-primitive-type weak-pointer (descriptor-reg))
 125
 126 ;;; miscellaneous primitive types that don't exist at the LISP level
 127 (!def-primitive-type catch-block (catch-block) :type nil)
 128 (!def-primitive-type unwind-block (unwind-block) :type nil)
 129 \f
 130 ;;;; PRIMITIVE-TYPE-OF and friends
 131
 132 ;;; Return the most restrictive primitive type that contains OBJECT.
 133 (/show0 "primtype.lisp 147")
 134 (defun primitive-type-of (object)
 135   (let ((type (ctype-of object)))
 136     (cond ((not (member-type-p type)) (primitive-type type))
 137           ((and (eql 1 (member-type-size type))
 138                 (equal (member-type-members type) '(nil)))
 139            (primitive-type-or-lose 'list))
 140           (t
 141            *backend-t-primitive-type*))))
 142
 143 ;;; Return the primitive type corresponding to a type descriptor
 144 ;;; structure. The second value is true when the primitive type is
 145 ;;; exactly equivalent to the argument Lisp type.
 146 ;;;
 147 ;;; In a bootstrapping situation, we should be careful to use the
 148 ;;; correct values for the system parameters.
 149 ;;;
 150 ;;; Meta: the following comment is not true. Should remove the AUX fn.
 151 ;;; We need an aux function because we need to use both
 152 ;;; !DEF-VM-SUPPORT-ROUTINE and DEFUN-CACHED.
 153 (/show0 "primtype.lisp 188")
 154 (defun primitive-type (type)
 155   (sb!kernel::maybe-reparse-specifier! type)
 156   (primitive-type-aux type))
 157 (/show0 "primtype.lisp 191")
 158 (defun-cached (primitive-type-aux
 159                :hash-function #'type-hash-value
 160                :hash-bits 9
 161                :values 2)
 162               ((type eq))
 163   (declare (type ctype type))
 164   (macrolet ((any () '(values *backend-t-primitive-type* nil))
 165              (exactly (type)
 166                `(values (primitive-type-or-lose ',type) t))
 167              (part-of (type)
 168                `(values (primitive-type-or-lose ',type) nil)))
 169     (flet ((maybe-numeric-type-union (t1 t2)
 170              (let ((t1-name (primitive-type-name t1))
 171                    (t2-name (primitive-type-name t2)))
 172                (case t1-name
 173                  (positive-fixnum
 174                   (if (or (eq t2-name 'fixnum)
 175                           (eq t2-name
 176                               (ecase n-machine-word-bits
 177                                 (32 'signed-byte-32)
 178                                 (64 'signed-byte-64)))
 179                           (eq t2-name
 180                               (ecase n-machine-word-bits
 181                                 (32 'unsigned-byte-31)
 182                                 (64 'unsigned-byte-63)))
 183                           (eq t2-name
 184                               (ecase n-machine-word-bits
 185                                 (32 'unsigned-byte-32)
 186                                 (64 'unsigned-byte-64))))
 187                       t2))
 188                  (fixnum
 189                   (case t2-name
 190                     (#.(ecase n-machine-word-bits
 191                          (32 'signed-byte-32)
 192                          (64 'signed-byte-64))
 193                        t2)
 194                     (#.(ecase n-machine-word-bits
 195                          (32 'unsigned-byte-31)
 196                          (64 'unsigned-byte-63))
 197                        (primitive-type-or-lose
 198                         (ecase n-machine-word-bits
 199                           (32 'signed-byte-32)
 200                           (64 'signed-byte-64))))))
 201                  (#.(ecase n-machine-word-bits
 202                       (32 'signed-byte-32)
 203                       (64 'signed-byte-64))
 204                   (if (eq t2-name
 205                           (ecase n-machine-word-bits
 206                             (32 'unsigned-byte-31)
 207                             (64 'unsigned-byte-63)))
 208                       t1))
 209                  (#.(ecase n-machine-word-bits
 210                       (32 'unsigned-byte-31)
 211                       (64 'unsigned-byte-63))
 212                     (if (eq t2-name
 213                             (ecase n-machine-word-bits
 214                               (32 'unsigned-byte-32)
 215                               (64 'unsigned-byte-64)))
 216                         t2))))))
 217       (etypecase type
 218         (numeric-type
 219          (let ((lo (numeric-type-low type))
 220                (hi (numeric-type-high type)))
 221            (case (numeric-type-complexp type)
 222              (:real
 223               (case (numeric-type-class type)
 224                 (integer
 225                  (cond ((and hi lo)
 226                         (dolist (spec
 227                                   `((positive-fixnum 0 ,sb!xc:most-positive-fixnum)
 228                                     ,@(ecase n-machine-word-bits
 229                                         (32
 230                                          `((unsigned-byte-31
 231                                             0 ,(1- (ash 1 31)))
 232                                            (unsigned-byte-32
 233                                             0 ,(1- (ash 1 32)))))
 234                                         (64
 235                                          `((unsigned-byte-63
 236                                             0 ,(1- (ash 1 63)))
 237                                            (unsigned-byte-64
 238                                             0 ,(1- (ash 1 64))))))
 239                                     (fixnum ,sb!xc:most-negative-fixnum
 240                                             ,sb!xc:most-positive-fixnum)
 241                                     ,(ecase n-machine-word-bits
 242                                        (32
 243                                         `(signed-byte-32 ,(ash -1 31)
 244                                                          ,(1- (ash 1 31))))
 245                                        (64
 246                                         `(signed-byte-64 ,(ash -1 63)
 247                                                          ,(1- (ash 1 63))))))
 248                                  (if (or (< hi sb!xc:most-negative-fixnum)
 249                                          (> lo sb!xc:most-positive-fixnum))
 250                                      (part-of bignum)
 251                                      (any)))
 252                           (let ((type (car spec))
 253                                 (min (cadr spec))
 254                                 (max (caddr spec)))
 255                             (when (<= min lo hi max)
 256                               (return (values
 257                                        (primitive-type-or-lose type)
 258                                        (and (= lo min) (= hi max))))))))
 259                        ((or (and hi (< hi sb!xc:most-negative-fixnum))
 260                             (and lo (> lo sb!xc:most-positive-fixnum)))
 261                         (part-of bignum))
 262                        (t
 263                         (any))))
 264                 (float
 265                  (let ((exact (and (null lo) (null hi))))
 266                    (case (numeric-type-format type)
 267                      ((short-float single-float)
 268                       (values (primitive-type-or-lose 'single-float)
 269                               exact))
 270                      ((double-float)
 271                       (values (primitive-type-or-lose 'double-float)
 272                               exact))
 273                      (t
 274                       (any)))))
 275                 (t
 276                  (any))))
 277              (:complex
 278               (if (eq (numeric-type-class type) 'float)
 279                   (let ((exact (and (null lo) (null hi))))
 280                     (case (numeric-type-format type)
 281                       ((short-float single-float)
 282                        (values (primitive-type-or-lose 'complex-single-float)
 283                                exact))
 284                       ((double-float long-float)
 285                        (values (primitive-type-or-lose 'complex-double-float)
 286                                exact))
 287                       (t
 288                        (part-of complex))))
 289                   (part-of complex)))
 290              (t
 291               (any)))))
 292         (array-type
 293          (if (or (array-type-complexp type)
 294                  (not (singleton-p (array-type-dimensions type))))
 295              (any)
 296              ;; EQ is ok to compare by because all CTYPEs representing
 297              ;; array specializations are interned objects.
 298              (let ((saetp (find (array-type-specialized-element-type type)
 299                                 *specialized-array-element-type-properties*
 300                                 :key #'saetp-ctype :test #'eq)))
 301                (if saetp
 302                    (values (primitive-type-or-lose
 303                             (saetp-primitive-type-name saetp))
 304                            (eq (first (array-type-dimensions type)) '*))
 305                    (any)))))
 306         (union-type
 307          (if (type= type (specifier-type 'list))
 308              (exactly list)
 309              (let ((types (union-type-types type)))
 310                (multiple-value-bind (res exact) (primitive-type (first types))
 311                  (dolist (type (rest types) (values res exact))
 312                    (multiple-value-bind (ptype ptype-exact)
 313                        (primitive-type type)
 314                      (unless ptype-exact (setq exact nil))
 315                      (unless (eq ptype res)
 316                        (let ((new-ptype
 317                               (or (maybe-numeric-type-union res ptype)
 318                                   (maybe-numeric-type-union ptype res))))
 319                          (if new-ptype
 320                              (setq res new-ptype)
 321                              (return (any)))))))))))
 322         (intersection-type
 323          (let ((types (intersection-type-types type))
 324                (res (any)))
 325            ;; why NIL for the exact?  Well, we assume that the
 326            ;; intersection type is in fact doing something for us:
 327            ;; that is, that each of the types in the intersection is
 328            ;; in fact cutting off some of the type lattice.  Since no
 329            ;; intersection type is represented by a primitive type and
 330            ;; primitive types are mutually exclusive, it follows that
 331            ;; no intersection type can represent the entirety of the
 332            ;; primitive type.  (And NIL is the conservative answer,
 333            ;; anyway).  -- CSR, 2006-09-14
 334            (dolist (type types (values res nil))
 335              (multiple-value-bind (ptype)
 336                  (primitive-type type)
 337                (cond
 338                  ;; if the result so far is (any), any improvement on
 339                  ;; the specificity of the primitive type is valid.
 340                  ((eq res (any))
 341                   (setq res ptype))
 342                  ;; if the primitive type returned is (any), the
 343                  ;; result so far is valid.  Likewise, if the
 344                  ;; primitive type is the same as the result so far,
 345                  ;; everything is fine.
 346                  ((or (eq ptype (any)) (eq ptype res)))
 347                  ;; otherwise, we have something hairy and confusing,
 348                  ;; such as (and condition funcallable-instance).
 349                  ;; Punt.
 350                  (t (return (any))))))))
 351         (member-type
 352          (let (res)
 353            (block nil
 354              (mapc-member-type-members
 355               (lambda (member)
 356                 (let ((ptype (primitive-type-of member)))
 357                   (if res
 358                       (unless (eq ptype res)
 359                         (let ((new-ptype (or (maybe-numeric-type-union res ptype)
 360                                              (maybe-numeric-type-union ptype res))))
 361                           (if new-ptype
 362                               (setq res new-ptype)
 363                               (return (any)))))
 364                       (setf res ptype))))
 365               type)
 366              res)))
 367         (named-type
 368          (ecase (named-type-name type)
 369            ((t *) (values *backend-t-primitive-type* t))
 370            ((instance) (exactly instance))
 371            ((funcallable-instance) (part-of function))
 372            ((extended-sequence) (any))
 373            ((nil) (any))))
 374         (character-set-type
 375          (if (eq type (specifier-type 'character))
 376              (exactly character)
 377              (part-of character)))
 378         #!+sb-simd-pack
 379         (simd-pack-type
 380          (let ((eltypes (simd-pack-type-element-type type)))
 381            (cond ((member 'integer eltypes)
 382                   (exactly simd-pack-int))
 383                  ((member 'single-float eltypes)
 384                   (exactly simd-pack-single))
 385                  ((member 'double-float eltypes)
 386                   (exactly simd-pack-double)))))
 387         (built-in-classoid
 388          (case (classoid-name type)
 389            #!+sb-simd-pack
 390            ;; Can't tell what specific type; assume integers.
 391            (simd-pack
 392             (exactly simd-pack-int))
 393            ((complex function system-area-pointer weak-pointer)
 394             (values (primitive-type-or-lose (classoid-name type)) t))
 395            (cons-type
 396             (part-of list))
 397            (t
 398             (any))))
 399         (fun-type
 400          (exactly function))
 401         (classoid
 402          (if (csubtypep type (specifier-type 'function))
 403              (part-of function)
 404              (part-of instance)))
 405         (ctype
 406          (if (csubtypep type (specifier-type 'function))
 407              (part-of function)
 408              (any)))))))
 409
 410 (/show0 "primtype.lisp end of file")