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