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