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