src/compiler/generic/vm-type.lisp

   1 ;;;; This file contains implementation-dependent parts of the type
   2 ;;;; support code. This is stuff which deals with the mapping from
   3 ;;;; types defined in Common Lisp to types actually supported by an
   4 ;;;; implementation.
   5
   6 ;;;; This software is part of the SBCL system. See the README file for
   7 ;;;; more information.
   8 ;;;;
   9 ;;;; This software is derived from the CMU CL system, which was
  10 ;;;; written at Carnegie Mellon University and released into the
  11 ;;;; public domain. The software is in the public domain and is
  12 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  13 ;;;; files for more information.
  14
  15 (in-package "SB!KERNEL")
  16
  17 ;;;; implementation-dependent DEFTYPEs
  18
  19 ;;; Make DOUBLE-FLOAT a synonym for LONG-FLOAT, SINGLE-FLOAT for
  20 ;;; SHORT-FLOAT. This is done by way of an "expander", not a "translator".
  21 ;;; !PRECOMPUTE-TYPES will turn their :TYPE :KIND into :PRIMITIVE
  22 ;;; in the target image so that they become not redefinable.
  23 (sb!xc:deftype long-float (&optional low high) `(double-float ,low ,high))
  24 (sb!xc:deftype short-float (&optional low high) `(single-float ,low ,high))
  25
  26 ;;; worst-case values for float attributes
  27 (sb!xc:deftype float-exponent ()
  28   #!-long-float 'double-float-exponent
  29   #!+long-float 'long-float-exponent)
  30 (sb!xc:deftype float-digits ()
  31   #!-long-float `(integer 0 ,sb!vm:double-float-digits)
  32   #!+long-float `(integer 0 ,sb!vm:long-float-digits))
  33 (sb!xc:deftype float-radix () '(integer 2 2))
  34 (sb!xc:deftype float-int-exponent ()
  35   #!-long-float 'double-float-int-exponent
  36   #!+long-float 'long-float-int-exponent)
  37
  38 ;;; a code for BOOLE
  39 (sb!xc:deftype boole-code () '(unsigned-byte 4))
  40
  41 ;;; a byte specifier (as generated by BYTE)
  42 (sb!xc:deftype byte-specifier () 'cons)
  43
  44 ;;; result of CHAR-INT
  45 (sb!xc:deftype char-int () 'char-code)
  46
  47 ;;; PATHNAME pieces, as returned by the PATHNAME-xxx functions
  48 (sb!xc:deftype pathname-host () '(or sb!impl::host null))
  49 (sb!xc:deftype pathname-device ()
  50   '(or simple-string (member nil :unspecific :unc)))
  51 (sb!xc:deftype pathname-directory () 'list)
  52 (sb!xc:deftype pathname-name ()
  53   '(or simple-string sb!impl::pattern (member nil :unspecific :wild)))
  54 (sb!xc:deftype pathname-type ()
  55   '(or simple-string sb!impl::pattern (member nil :unspecific :wild)))
  56 (sb!xc:deftype pathname-version ()
  57   '(or integer (member nil :newest :wild :unspecific)))
  58
  59 ;;; Internal time format.
  60 ;;; 62 bits should give
  61 ;;; one hundred forty-six million one hundred thirty-five thousand five hundred twenty years of runtime
  62 ;;; It's dangerous to run SBCL for that long without updating.
  63 ;;; And it'll be a fixnum on 64-bit targets.
  64 ;;; The result from querying get-internal-run-time with multiple cores
  65 ;;; running full tilt will exhaust this faster, but it's still plenty enough.
  66 (sb!xc:deftype internal-time () '(unsigned-byte 62))
  67 (sb!xc:deftype internal-seconds ()
  68   '(unsigned-byte
  69     #.(- 62 (floor (log sb!xc:internal-time-units-per-second 2)))))
  70
  71 (sb!xc:deftype bignum-element-type () `(unsigned-byte ,sb!vm:n-word-bits))
  72 (sb!xc:deftype bignum-type () 'bignum)
  73 ;;; FIXME: see also DEFCONSTANT MAXIMUM-BIGNUM-LENGTH in
  74 ;;; src/code/bignum.lisp.  -- CSR, 2004-07-19
  75 (sb!xc:deftype bignum-index ()
  76   '(mod #.(1- (ash 1 (- sb!vm:n-word-bits sb!vm:n-widetag-bits)))))
  77 (sb!xc:deftype bignum-length ()
  78   '(unsigned-byte #.(- sb!vm:n-word-bits sb!vm:n-widetag-bits)))
  79
  80 ;;; an index into an integer
  81 (sb!xc:deftype bit-index ()
  82   `(integer 0 #.(* (1- (ash 1 (- sb!vm:n-word-bits sb!vm:n-widetag-bits)))
  83                    sb!vm:n-word-bits)))
  84
  85 \f
  86 ;;;; hooks into the type system
  87
  88 (sb!xc:deftype unboxed-array (&optional dims)
  89   (collect ((types (list 'or)))
  90     (dolist (type *specialized-array-element-types*)
  91       (when (subtypep type '(or integer character float (complex float)))
  92         (types `(array ,type ,dims))))
  93     (types)))
  94
  95 (sb!xc:deftype simple-unboxed-array (&optional dims)
  96   (collect ((types (list 'or)))
  97     (dolist (type *specialized-array-element-types*)
  98       (when (subtypep type '(or integer character float (complex float)))
  99         (types `(simple-array ,type ,dims))))
 100     (types)))
 101
 102 (sb!xc:deftype complex-vector (&optional element-type length)
 103   `(and (vector ,element-type ,length) (not simple-array)))
 104
 105 ;;; Return the symbol that describes the format of FLOAT.
 106 (declaim (ftype (function (float) symbol) float-format-name))
 107 (defun float-format-name (x)
 108   (etypecase x
 109     (single-float 'single-float)
 110     (double-float 'double-float)
 111     #!+long-float (long-float 'long-float)))
 112
 113 (declaim (ftype (sfunction (ctype) ctype) %upgraded-array-element-type))
 114 (defun %upgraded-array-element-type (eltype)
 115   (if (or (eq eltype *wild-type*)
 116           ;; This is slightly dubious, but not as dubious as
 117           ;; assuming that the upgraded-element-type should be
 118           ;; equal to T, given the way that the AREF
 119           ;; DERIVE-TYPE optimizer works.  -- CSR, 2002-08-19
 120           (contains-unknown-type-p eltype))
 121       *wild-type*
 122       (dovector (stype
 123                  (literal-ctype-vector *parsed-specialized-array-element-types*)
 124                  *universal-type*)
 125        (when (csubtypep eltype stype)
 126          (return stype)))))
 127
 128 (defun sb!xc:upgraded-array-element-type (spec &optional environment)
 129   #!+sb-doc
 130   "Return the element type that will actually be used to implement an array
 131    with the specifier :ELEMENT-TYPE Spec."
 132   (declare (type lexenv-designator environment) (ignore environment))
 133   (declare (explicit-check))
 134   (let ((type (type-or-nil-if-unknown spec)))
 135     (cond ((not type)
 136            ;; What about a FUNCTION-TYPE - would (FUNCTION (UNKNOWN) UNKNOWN)
 137            ;; upgrade to T? Well, it's still ok to say it's an error.
 138            (error "Undefined type: ~S" spec))
 139           (t
 140            (type-specifier (%upgraded-array-element-type type))))))
 141
 142 (defun sb!xc:upgraded-complex-part-type (spec &optional environment)
 143   #!+sb-doc
 144   "Return the element type of the most specialized COMPLEX number type that
 145    can hold parts of type SPEC."
 146   (declare (type lexenv-designator environment) (ignore environment))
 147   (declare (explicit-check))
 148   (let ((type (type-or-nil-if-unknown spec)))
 149     (cond
 150       ((eq type *empty-type*) nil)
 151       ((not type) (error "Undefined type: ~S" spec))
 152       (t
 153        (let ((ctype (specifier-type `(complex ,spec))))
 154          (cond
 155            ((eq ctype *empty-type*) '(eql 0))
 156            ((csubtypep ctype (specifier-type '(complex single-float)))
 157             'single-float)
 158            ((csubtypep ctype (specifier-type '(complex double-float)))
 159             'double-float)
 160            #!+long-float
 161            ((csubtypep ctype (specifier-type '(complex long-float)))
 162             'long-float)
 163            ((csubtypep ctype (specifier-type '(complex rational)))
 164             'rational)
 165            (t 'real)))))))
 166
 167 ;;; Return the most specific integer type that can be quickly checked that
 168 ;;; includes the given type.
 169 (defun containing-integer-type (subtype)
 170   (dolist (type `(fixnum
 171                   (signed-byte ,sb!vm:n-word-bits)
 172                   (unsigned-byte ,sb!vm:n-word-bits)
 173                   integer)
 174                 (error "~S isn't an integer type?" subtype))
 175     (when (csubtypep subtype (specifier-type type))
 176       (return type))))
 177
 178 ;; Given a union type INPUT, see if it fully covers an ARRAY-* type,
 179 ;; and unite into that when possible, taking care to handle more
 180 ;; than one dimensionality/complexity of array, and non-array types.
 181 ;; If FOR-TYPEP is true, then:
 182 ;;  - The input and result are lists of the component types.
 183 ;;  - We allow "almost coverings" of ARRAY-* to produce an answer
 184 ;;    that results in a quicker test.
 185 ;;    e.g. unboxed-array = (and array (not (array t)))
 186 ;; Otherwise, if not FOR-TYPEP, the input/result are CTYPES,
 187 ;; and we don't introduce negations into the union.
 188 ;;
 189 ;; Note that in FOR-TYPEP usage, this function should get a chance to see
 190 ;; the whole union before WIDETAGS-FROM-UNION-TYPE has removed any types that
 191 ;; are testable by their widetag. Otherwise (TYPEP X '(UNBOXED-ARRAY 1))
 192 ;; becomes suboptimal. WIDETAGS-FROM-UNION-TYPE knows that strings/bit-vectors,
 193 ;; either simple or hairy, all have distinguishing widetags, so if it sees
 194 ;; them, reducing to (OR (%OTHER-POINTER-SUBTYPE-P ...) <more-array-types>),
 195 ;; the other array-types will not comprise an "almost covering" of ARRAY-*
 196 ;; and this code will not do what you want.
 197 ;; Additionally, as part of the contract, we don't create a type-difference
 198 ;; for a union all of whose types are testable by widetags.
 199 ;; e.g. it would be suboptimal to rewrite
 200 ;;  (SIMPLE-UNBOXED-ARRAY (*)) -> (AND (SIMPLE-ARRAY * (*)) (NOT (ARRAY T)))
 201 ;; because it always better to use %OTHER-POINTER-SUBTYPE-P in that case.
 202
 203 (defun simplify-array-unions (input &optional for-typep)
 204   (let* ((array-props sb!vm:*specialized-array-element-type-properties*)
 205          (types (if (listp input) input (union-type-types input)))
 206          (full-mask (1- (ash 1 (length array-props))))
 207          buckets output)
 208     ;; KLUDGE: counting the input types is a fine preliminary check
 209     ;; to avoid extra work, but importantly it (magically) bypasses all
 210     ;; this logic during cold-init when CTYPE slots of all SAETPs are nil.
 211     ;; SBCL sources mostly don't contain type expressions that benefit
 212     ;; from this transform.
 213     ;; If, in the not-for-typep case, there aren't at least as many
 214     ;; array types as SAETPs, there can't be a covering.
 215     ;; In the for-typep case, if there aren't at least half as many,
 216     ;; then it couldn't be rewritten as negation.
 217     ;; Uber-KLUDGE: using (length types) isn't enough to make the
 218     ;; not-for-typep case make it all the way through cold-init.
 219     (when (if for-typep
 220               (< (length types) (floor (length array-props) 2))
 221               (< (count-if #'array-type-p types) (length array-props)))
 222       (return-from simplify-array-unions input))
 223     (flet ((bucket-match-p (a b)
 224              (and (eq (array-type-complexp a) (array-type-complexp b))
 225                   (equal (array-type-dimensions a) (array-type-dimensions b))))
 226            (saetp-index (type)
 227              (and (array-type-p type)
 228                   (neq (array-type-specialized-element-type type) *wild-type*)
 229                   (position (array-type-specialized-element-type type) array-props
 230                             :key #'sb!vm:saetp-ctype :test #'type=)))
 231            (wild (type)
 232              (make-array-type (array-type-dimensions type)
 233                               :element-type *wild-type*
 234                               :complexp (array-type-complexp type))))
 235       ;; Bucket the array types by <dimensions,complexp> where each bucket
 236       ;; tracks which SAETPs were seen.
 237       ;; Search actual element types by TYPE=, not upgraded types, so that the
 238       ;; transform into (ARRAY *) is not lossy. However, if uniting does occur
 239       ;; and the resultant OR still contains any array type that upgrades to T,
 240       ;; we might want to do yet another reduction because:
 241       ;; (SPECIFIER-TYPE '(OR (VECTOR *) (VECTOR BAD))) => #<ARRAY-TYPE VECTOR>
 242       (dolist (type types)
 243         (binding* ((bit (saetp-index type) :exit-if-null)
 244                    (bucket (assoc type buckets :test #'bucket-match-p)))
 245           (unless bucket
 246             (push (setq bucket (cons type full-mask)) buckets))
 247           ;; Each _missing_ type is represented by a '1' bit so that
 248           ;; a final mask of 0 indicates an exhaustive partitioning.
 249           ;; (SETF LOGBITP) would work for us, but CLHS doesn't require it.
 250           (setf (cdr bucket) (logandc2 (cdr bucket) (ash 1 bit)))))
 251       (cond
 252         (for-typep
 253          ;; Maybe compute the complement with respect to (ARRAY *)
 254          ;; but never express unions of simple-rank-1 as a type-difference,
 255          ;; because widetag testing of those is better.
 256          (dolist (type types (nreverse output))
 257            (let* ((bucket
 258                    (and (saetp-index type)
 259                         (or (array-type-complexp type)
 260                             (not (equal (array-type-dimensions type) '(*))))
 261                         (assoc type buckets :test #'bucket-match-p)))
 262                   (disjunct
 263                    (cond ((and bucket
 264                                (plusp (cdr bucket))
 265                                (< (logcount (cdr bucket))
 266                                   (floor (length array-props) 2)))
 267                           (let (exclude)
 268                             (dotimes (i (length array-props))
 269                               (when (logbitp i (cdr bucket)) ; exclude it
 270                                 (push (sb!vm:saetp-specifier
 271                                        (svref array-props i)) exclude)))
 272                             (setf (cdr bucket) -1) ; mark as generated
 273                             (specifier-type
 274                              `(and ,(type-specifier (wild type))
 275                                    ,@(mapcar (lambda (x) `(not (array ,x)))
 276                                              exclude)))))
 277                          ((not (eql (cdr bucket) -1))
 278                           ;; noncanonical input is a bug,
 279                           ;; so assert that bucket is not full.
 280                           (aver (not (eql (cdr bucket) 0)))
 281                           type)))) ; keep
 282              (when disjunct
 283                (push disjunct output)))))
 284         ((rassoc 0 buckets) ; at least one full bucket
 285          ;; For each input type subsumed by a full bucket,
 286          ;; insert the wild array type for that bucket.
 287          (dolist (type types (apply #'type-union (nreverse output)))
 288            (let* ((bucket (and (saetp-index type)
 289                                (assoc type buckets :test #'bucket-match-p)))
 290                   (disjunct (cond ((eql (cdr bucket) 0) ; bucket is full
 291                                    (setf (cdr bucket) -1) ; mark as generated
 292                                    (wild type))
 293                                   ((not (eql (cdr bucket) -1))
 294                                    type)))) ; keep
 295              (when disjunct
 296                (push disjunct output)))))
 297         (t input))))) ; no change
 298
 299 ;; Given TYPES which is a list of types from a union type, decompose into
 300 ;; two unions, one being an OR over types representable as widetags
 301 ;; with other-pointer-lowtag, and the other being the difference
 302 ;; between the input TYPES and the widetags.
 303 ;; This is architecture-independent, but unfortunately the needed VOP can't
 304 ;; be defined using DEFINE-TYPE-VOPS, so return (VALUES NIL TYPES) for
 305 ;; unsupported backends which can't generate an arbitrary call to %TEST-HEADERS.
 306 (defun widetags-from-union-type (types)
 307   (setq types (simplify-array-unions types t))
 308   ;; This seems preferable to a reader-conditional in generic code.
 309   ;; There is a unit test that the supported architectures don't generate
 310   ;; excessively large code, so hopefully it'll not get broken.
 311   (let ((info (info :function :info '%other-pointer-subtype-p)))
 312     (unless (and info (sb!c::fun-info-templates info))
 313       (return-from widetags-from-union-type (values nil types))))
 314   (let (widetags remainder)
 315     (dolist (x types)
 316       (let ((adjunct
 317              (cond
 318                ((and (array-type-p x)
 319                      (equal (array-type-dimensions x) '(*))
 320                      (type= (array-type-specialized-element-type x)
 321                             (array-type-element-type x)))
 322                 (if (eq (array-type-specialized-element-type x) *wild-type*)
 323                     ;; could be done, but probably no merit to implementing
 324                     ;; maybe/definitely-complex wild-type.
 325                     (unless (array-type-complexp x)
 326                       (map 'list #'sb!vm::saetp-typecode
 327                            sb!vm:*specialized-array-element-type-properties*))
 328                     (let ((saetp
 329                            (find
 330                             (array-type-element-type x)
 331                             sb!vm:*specialized-array-element-type-properties*
 332                             :key #'sb!vm:saetp-ctype :test #'type=)))
 333                       (cond ((not (array-type-complexp x))
 334                              (sb!vm:saetp-typecode saetp))
 335                             ((sb!vm:saetp-complex-typecode saetp)
 336                              (list* (sb!vm:saetp-complex-typecode saetp)
 337                                     (when (eq (array-type-complexp x) :maybe)
 338                                       (list (sb!vm:saetp-typecode saetp)))))))))
 339                ((classoid-p x)
 340                 (case (classoid-name x)
 341                   (symbol sb!vm:symbol-header-widetag) ; plus a hack for nil
 342                   (system-area-pointer sb!vm:sap-widetag))))))
 343         (cond ((not adjunct) (push x remainder))
 344               ((listp adjunct) (setq widetags (nconc adjunct widetags)))
 345               (t (push adjunct widetags)))))
 346     (let ((remainder (nreverse remainder)))
 347       (when (member sb!vm:symbol-header-widetag widetags)
 348         ;; If symbol is the only widetag-testable type, it's better
 349         ;; to just use symbolp. e.g. (OR SYMBOL CHARACTER) should not
 350         ;; become (OR (%OTHER-POINTER-SUBTYPE-P ...)
 351         (when (null (rest widetags))
 352           (return-from widetags-from-union-type (values nil types)))
 353         ;; Manipulate 'remainder' to include NULL since NIL's lowtag
 354         ;; isn't other-pointer.
 355         (let ((null-type (specifier-type 'null)))
 356           (unless (member null-type remainder :test #'csubtypep)
 357             (push null-type remainder))))
 358       (values widetags remainder))))