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 ;; x86-64 needs a signed-byte-32 for proper handling of c-call return values.
  45 #!+#.(cl:if (cl:= sb!vm::n-machine-word-bits 32) '(and) '(or x86-64))
  46 (!def-primitive-type signed-byte-32 (signed-reg descriptor-reg)
  47   :type (signed-byte 32))
  48 #!+#.(cl:if (cl:= sb!vm::n-machine-word-bits 64) '(and) '(or))
  49 (!def-primitive-type signed-byte-64 (signed-reg descriptor-reg)
  50   :type (signed-byte 64))
  51
  52 (defvar *fixnum-primitive-type* (primitive-type-or-lose 'fixnum))
  53
  54 (/show0 "primtype.lisp 53")
  55 (!def-primitive-type-alias tagged-num (:or positive-fixnum fixnum))
  56 (!def-primitive-type-alias unsigned-num
  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
  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
  67 ;;; other primitive immediate types
  68 (/show0 "primtype.lisp 68")
  69 (!def-primitive-type character (character-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
  90 (/show0 "about to !DEF-PRIMITIVE-TYPE COMPLEX-SINGLE-FLOAT")
  91 (!def-primitive-type complex-single-float (complex-single-reg descriptor-reg)
  92   :type (complex single-float))
  93 (/show0 "about to !DEF-PRIMITIVE-TYPE COMPLEX-DOUBLE-FLOAT")
  94 (!def-primitive-type complex-double-float (complex-double-reg descriptor-reg)
  95   :type (complex double-float))
  96
  97
  98 ;;; primitive other-pointer array types
  99 (/show0 "primtype.lisp 96")
 100 (macrolet ((define-simple-array-primitive-types ()
 101                `(progn
 102                  ,@(map 'list
 103                         (lambda (saetp)
 104                           `(!def-primitive-type
 105                             ,(saetp-primitive-type-name saetp)
 106                             (descriptor-reg)
 107                             :type (simple-array ,(saetp-specifier saetp) (*))))
 108                         *specialized-array-element-type-properties*))))
 109   (define-simple-array-primitive-types))
 110 ;;; Note: The complex array types are not included, 'cause it is
 111 ;;; pointless to restrict VOPs to them.
 112
 113 ;;; other primitive other-pointer types
 114 (!def-primitive-type system-area-pointer (sap-reg descriptor-reg))
 115 (!def-primitive-type weak-pointer (descriptor-reg))
 116
 117 ;;; miscellaneous primitive types that don't exist at the LISP level
 118 (!def-primitive-type catch-block (catch-block) :type nil)
 119 \f
 120 ;;;; PRIMITIVE-TYPE-OF and friends
 121
 122 ;;; Return the most restrictive primitive type that contains OBJECT.
 123 (/show0 "primtype.lisp 147")
 124 (!def-vm-support-routine primitive-type-of (object)
 125   (let ((type (ctype-of object)))
 126     (cond ((not (member-type-p type)) (primitive-type type))
 127           ((equal (member-type-members type) '(nil))
 128            (primitive-type-or-lose 'list))
 129           (t
 130            *backend-t-primitive-type*))))
 131
 132 ;;; Return the primitive type corresponding to a type descriptor
 133 ;;; structure. The second value is true when the primitive type is
 134 ;;; exactly equivalent to the argument Lisp type.
 135 ;;;
 136 ;;; In a bootstrapping situation, we should be careful to use the
 137 ;;; correct values for the system parameters.
 138 ;;;
 139 ;;; We need an aux function because we need to use both
 140 ;;; !DEF-VM-SUPPORT-ROUTINE and DEFUN-CACHED.
 141 (/show0 "primtype.lisp 188")
 142 (!def-vm-support-routine primitive-type (type)
 143   (primitive-type-aux type))
 144 (/show0 "primtype.lisp 191")
 145 (defun-cached (primitive-type-aux
 146                :hash-function (lambda (x)
 147                                 (logand (type-hash-value x) #x1FF))
 148                :hash-bits 9
 149                :values 2
 150                :default (values nil :empty))
 151               ((type eq))
 152   (declare (type ctype type))
 153   (macrolet ((any () '(values *backend-t-primitive-type* nil))
 154              (exactly (type)
 155                `(values (primitive-type-or-lose ',type) t))
 156              (part-of (type)
 157                `(values (primitive-type-or-lose ',type) nil)))
 158     (flet ((maybe-numeric-type-union (t1 t2)
 159              (let ((t1-name (primitive-type-name t1))
 160                    (t2-name (primitive-type-name t2)))
 161                (case t1-name
 162                  (positive-fixnum
 163                   (if (or (eq t2-name 'fixnum)
 164                           (eq t2-name
 165                               (ecase sb!vm::n-machine-word-bits
 166                                 (32 'signed-byte-32)
 167                                 (64 'signed-byte-64)))
 168                           (eq t2-name
 169                               (ecase sb!vm::n-machine-word-bits
 170                                 (32 'unsigned-byte-31)
 171                                 (64 'unsigned-byte-63)))
 172                           (eq t2-name
 173                               (ecase sb!vm::n-machine-word-bits
 174                                 (32 'unsigned-byte-32)
 175                                 (64 'unsigned-byte-64))))
 176                       t2))
 177                  (fixnum
 178                   (case t2-name
 179                     (#.(ecase sb!vm::n-machine-word-bits
 180                          (32 'signed-byte-32)
 181                          (64 'signed-byte-64))
 182                        t2)
 183                     (#.(ecase sb!vm::n-machine-word-bits
 184                          (32 'unsigned-byte-31)
 185                          (64 'unsigned-byte-63))
 186                        (primitive-type-or-lose
 187                         (ecase sb!vm::n-machine-word-bits
 188                           (32 'signed-byte-32)
 189                           (64 'signed-byte-64))))))
 190                  (#.(ecase sb!vm::n-machine-word-bits
 191                       (32 'signed-byte-32)
 192                       (64 'signed-byte-64))
 193                   (if (eq t2-name
 194                           (ecase sb!vm::n-machine-word-bits
 195                             (32 'unsigned-byte-31)
 196                             (64 'unsigned-byte-63)))
 197                       t1))
 198                  (#.(ecase sb!vm::n-machine-word-bits
 199                       (32 'unsigned-byte-31)
 200                       (64 'unsigned-byte-63))
 201                     (if (eq t2-name
 202                             (ecase sb!vm::n-machine-word-bits
 203                               (32 'unsigned-byte-32)
 204                               (64 'unsigned-byte-64)))
 205                         t2))))))
 206       (etypecase type
 207         (numeric-type
 208          (let ((lo (numeric-type-low type))
 209                (hi (numeric-type-high type)))
 210            (case (numeric-type-complexp type)
 211              (:real
 212               (case (numeric-type-class type)
 213                 (integer
 214                  (cond ((and hi lo)
 215                         (dolist (spec
 216                                   `((positive-fixnum 0 ,sb!xc:most-positive-fixnum)
 217                                     ,@(ecase sb!vm::n-machine-word-bits
 218                                         (32
 219                                          `((unsigned-byte-31
 220                                             0 ,(1- (ash 1 31)))
 221                                            (unsigned-byte-32
 222                                             0 ,(1- (ash 1 32)))))
 223                                         (64
 224                                          `((unsigned-byte-63
 225                                             0 ,(1- (ash 1 63)))
 226                                            (unsigned-byte-64
 227                                             0 ,(1- (ash 1 64))))))
 228                                     (fixnum ,sb!xc:most-negative-fixnum
 229                                             ,sb!xc:most-positive-fixnum)
 230                                     ,(ecase sb!vm::n-machine-word-bits
 231                                        (32
 232                                         `(signed-byte-32 ,(ash -1 31)
 233                                                          ,(1- (ash 1 31))))
 234                                        (64
 235                                         `(signed-byte-64 ,(ash -1 63)
 236                                                          ,(1- (ash 1 63))))))
 237                                  (if (or (< hi sb!xc:most-negative-fixnum)
 238                                          (> lo sb!xc:most-positive-fixnum))
 239                                      (part-of bignum)
 240                                      (any)))
 241                           (let ((type (car spec))
 242                                 (min (cadr spec))
 243                                 (max (caddr spec)))
 244                             (when (<= min lo hi max)
 245                               (return (values
 246                                        (primitive-type-or-lose type)
 247                                        (and (= lo min) (= hi max))))))))
 248                        ((or (and hi (< hi sb!xc:most-negative-fixnum))
 249                             (and lo (> lo sb!xc:most-positive-fixnum)))
 250                         (part-of bignum))
 251                        (t
 252                         (any))))
 253                 (float
 254                  (let ((exact (and (null lo) (null hi))))
 255                    (case (numeric-type-format type)
 256                      ((short-float single-float)
 257                       (values (primitive-type-or-lose 'single-float)
 258                               exact))
 259                      ((double-float)
 260                       (values (primitive-type-or-lose 'double-float)
 261                               exact))
 262                      (t
 263                       (any)))))
 264                 (t
 265                  (any))))
 266              (:complex
 267               (if (eq (numeric-type-class type) 'float)
 268                   (let ((exact (and (null lo) (null hi))))
 269                     (case (numeric-type-format type)
 270                       ((short-float single-float)
 271                        (values (primitive-type-or-lose 'complex-single-float)
 272                                exact))
 273                       ((double-float long-float)
 274                        (values (primitive-type-or-lose 'complex-double-float)
 275                                exact))
 276                       (t
 277                        (part-of complex))))
 278                   (part-of complex)))
 279              (t
 280               (any)))))
 281         (array-type
 282          (if (array-type-complexp type)
 283              (any)
 284              (let* ((dims (array-type-dimensions type))
 285                     (etype (array-type-specialized-element-type type))
 286                     (type-spec (type-specifier etype))
 287                     ;; FIXME: We're _WHAT_?  Testing for type equality
 288                     ;; with a specifier and #'EQUAL?  *BOGGLE*.  --
 289                     ;; CSR, 2003-06-24
 290                     (ptype (cdr (assoc type-spec *simple-array-primitive-types*
 291                                        :test #'equal))))
 292                (if (and (consp dims) (null (rest dims)) ptype)
 293                    (values (primitive-type-or-lose ptype)
 294                            (eq (first dims) '*))
 295                    (any)))))
 296         (union-type
 297          (if (type= type (specifier-type 'list))
 298              (exactly list)
 299              (let ((types (union-type-types type)))
 300                (multiple-value-bind (res exact) (primitive-type (first types))
 301                  (dolist (type (rest types) (values res exact))
 302                    (multiple-value-bind (ptype ptype-exact)
 303                        (primitive-type type)
 304                      (unless ptype-exact (setq exact nil))
 305                      (unless (eq ptype res)
 306                        (let ((new-ptype
 307                               (or (maybe-numeric-type-union res ptype)
 308                                   (maybe-numeric-type-union ptype res))))
 309                          (if new-ptype
 310                              (setq res new-ptype)
 311                              (return (any)))))))))))
 312         (intersection-type
 313          (let ((types (intersection-type-types type))
 314                (res (any))
 315                (exact nil))
 316            (dolist (type types (values res exact))
 317              (when (eq type (specifier-type 'function))
 318                ;; KLUDGE: Deal with (and function instance), both of which
 319                ;; have an exact primitive type.
 320                (return (part-of function)))
 321              (multiple-value-bind (ptype ptype-exact)
 322                    (primitive-type type)
 323                  (when ptype-exact
 324                    ;; Apart from the previous kludge exact primitive
 325                    ;; types should match, if indeed there are any. It
 326                    ;; may be that this assumption isn't really safe,
 327                    ;; but at least we'll see what breaks. -- NS 20041104
 328                    (aver (or (not exact) (eq ptype res)))
 329                    (setq exact t))
 330                  (when (or ptype-exact (and (not exact) (eq res (any))))
 331                    ;; Try to find a narrower representation then
 332                    ;; (any). Takes care of undecidable types in
 333                    ;; intersections with decidable ones.
 334                    (setq res ptype))))))
 335         (member-type
 336          (let* ((members (member-type-members type))
 337                 (res (primitive-type-of (first members))))
 338            (dolist (mem (rest members) (values res nil))
 339              (let ((ptype (primitive-type-of mem)))
 340                (unless (eq ptype res)
 341                  (let ((new-ptype (or (maybe-numeric-type-union res ptype)
 342                                       (maybe-numeric-type-union ptype res))))
 343                    (if new-ptype
 344                        (setq res new-ptype)
 345                        (return (any)))))))))
 346         (named-type
 347          (ecase (named-type-name type)
 348            ((t *) (values *backend-t-primitive-type* t))
 349            ((nil) (any))))
 350        (character-set-type
 351         (let ((pairs (character-set-type-pairs type)))
 352           (if (and (= (length pairs) 1)
 353                    (= (caar pairs) 0)
 354                    (= (cdar pairs) (1- sb!xc:char-code-limit)))
 355               (exactly character)
 356               (part-of character))))
 357        (built-in-classoid
 358         (case (classoid-name type)
 359           ((complex function instance
 360                     system-area-pointer weak-pointer)
 361            (values (primitive-type-or-lose (classoid-name type)) t))
 362           (funcallable-instance
 363            (part-of function))
 364           (cons-type
 365            (part-of list))
 366           (t
 367            (any))))
 368        (fun-type
 369         (exactly function))
 370        (classoid
 371         (if (csubtypep type (specifier-type 'function))
 372             (part-of function)
 373             (part-of instance)))
 374        (ctype
 375         (if (csubtypep type (specifier-type 'function))
 376             (part-of function)
 377             (any)))))))
 378
 379 (/show0 "primtype.lisp end of file")