vm-type.lisp

;;;; This file contains implementation-dependent parts of the type
;;;; support code. This is stuff which deals with the mapping from
;;;; types defined in Common Lisp to types actually supported by an
;;;; implementation.

;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;;
;;;; This software is derived from the CMU CL system, which was
;;;; written at Carnegie Mellon University and released into the
;;;; public domain. The software is in the public domain and is
;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.

(in-package "SB-KERNEL")

;;;; implementation-dependent DEFTYPEs

;;; Make DOUBLE-FLOAT a synonym for LONG-FLOAT, SINGLE-FLOAT for
;;; SHORT-FLOAT. This is done by way of an "expander", not a "translator".
;;; !PRECOMPUTE-TYPES will turn their :TYPE :KIND into :PRIMITIVE
;;; in the target image so that they become not redefinable.
(sb-xc:deftype long-float (&optional low high) `(double-float ,low ,high))
(sb-xc:deftype short-float (&optional low high) `(single-float ,low ,high))

;;; worst-case values for float attributes
(sb-xc:deftype float-exponent ()
  #-long-float 'double-float-exponent
  #+long-float 'long-float-exponent)
(sb-xc:deftype %float-digits ()
  #-long-float `(integer 0 ,sb-vm:double-float-digits)
  #+long-float `(integer 0 ,sb-vm:long-float-digits))

;;; Better keep this type around just in case we want to port to a machine
;;; that uses decimal or base 16.
(sb-xc:deftype %float-radix () '(integer 2 2))
(sb-xc:deftype float-int-exponent ()
  #-long-float 'double-float-int-exponent
  #+long-float 'long-float-int-exponent)

;;; a code for BOOLE
(sb-xc:deftype boole-code () '(unsigned-byte 4))

;;; a byte specifier (as generated by BYTE)
(sb-xc:deftype byte-specifier () 'cons)

;;; PATHNAME pieces, as returned by the PATHNAME-xxx functions
;;; CLHS conformance mandates that these type names not be CL: symbols.
(sb-xc:deftype sb-impl::%pathname-host () '(or sb-impl::host null))
(sb-xc:deftype sb-impl::%pathname-device ()
  '(or simple-string (member nil :unspecific :unc)))
(sb-xc:deftype sb-impl::%pathname-directory () 'list)
(sb-xc:deftype sb-impl::%pathname-name ()
  '(or simple-string sb-impl::pattern (member nil :unspecific :wild)))
(sb-xc:deftype sb-impl::%pathname-type ()
  '(or simple-string sb-impl::pattern (member nil :unspecific :wild)))
(sb-xc:deftype sb-impl::%pathname-version ()
  '(or integer (member nil :newest :wild :unspecific)))

(sb-xc:deftype internal-time () `(unsigned-byte ,internal-time-bits))

(defconstant internal-seconds-limit
    (floor (ash 1 internal-time-bits) internal-time-units-per-second))
(sb-xc:deftype internal-seconds () `(integer 0 ,internal-seconds-limit))

(sb-xc:deftype bignum-element-type () 'sb-vm:word)
(sb-xc:deftype bignum-index () `(mod ,maximum-bignum-length))
(sb-xc:deftype bignum-length () `(mod ,(1+ maximum-bignum-length)))

(sb-xc:deftype half-bignum-element-type () `(unsigned-byte ,(/ sb-vm:n-word-bits 2)))
(sb-xc:deftype half-bignum-index () `(mod ,(* maximum-bignum-length 2)))
(sb-xc:deftype half-bignum-length () `(mod ,(1+ (* maximum-bignum-length 2))))

;;; an index into an integer
(sb-xc:deftype bit-index ()
  `(integer 0 ,(- (* (1+ maximum-bignum-length) sb-vm:n-word-bits) 1)))


;;;; hooks into the type system

;;; Typically the use for UNBOXED-ARRAY is with foreign APIs where we want to
;;; require that the array being passed has byte nature, and is not SIMPLE-VECTOR.
;;; But (VECTOR NIL) contains no data, so surely there is no reason for
;;; passing it to foreign code.
(sb-xc:deftype unboxed-array (&optional dims)
  (cons 'or (mapcar (lambda (type) `(array ,type ,dims))
                    '#.(delete-if (lambda (x) (member x '(nil t)))
                                  (map 'list 'sb-vm:saetp-specifier
                                       sb-vm:*specialized-array-element-type-properties*)))))
(sb-xc:deftype simple-unboxed-array (&optional dims)
  (cons 'or (mapcar (lambda (type) `(simple-array ,type ,dims))
                    '#.(delete-if (lambda (x) (member x '(nil t)))
                                  (map 'list 'sb-vm:saetp-specifier
                                       sb-vm:*specialized-array-element-type-properties*)))))

(sb-xc:deftype complex-vector (&optional element-type length)
  `(and (vector ,element-type ,length) (not simple-array)))

;;; Return the symbol that describes the format of FLOAT.
(declaim (ftype (function (float) symbol) float-format-name))
(defun float-format-name (x)
  (etypecase x
    (single-float 'single-float)
    (double-float 'double-float)
    #+long-float (long-float 'long-float)))

(declaim (ftype (sfunction (ctype) ctype) %upgraded-array-element-type))
(defun %upgraded-array-element-type (eltype)
  (cond ((eq eltype *universal-type*) eltype) ; don't waste time iterating
        ((or (eq eltype *wild-type*)
          ;; This is slightly dubious, but not as dubious as
          ;; assuming that the upgraded-element-type should be
          ;; equal to T, given the way that the AREF
          ;; DERIVE-TYPE optimizer works.  -- CSR, 2002-08-19
             (contains-unknown-type-p eltype))
         *wild-type*)
        (t
         (dovector (saetp sb-vm:*specialized-array-element-type-properties*
                          *universal-type*)
           (let ((stype (sb-vm:saetp-ctype saetp)))
             (when (csubtypep eltype stype)
               (return stype)))))))

(defun upgraded-array-element-type (spec &optional environment)
  "Return the element type that will actually be used to implement an array
   with the specifier :ELEMENT-TYPE Spec."
  (declare (type lexenv-designator environment) (ignore environment))
  (declare (explicit-check))
  (let ((type (type-or-nil-if-unknown spec)))
    (cond ((not type)
           ;; What about a FUNCTION-TYPE - would (FUNCTION (UNKNOWN) UNKNOWN)
           ;; upgrade to T? Well, it's still ok to say it's an error.
           (error "Undefined type: ~S" spec))
          (t
           (type-specifier (%upgraded-array-element-type type))))))

(defun upgraded-complex-part-type (spec &optional environment)
  "Return the element type of the most specialized COMPLEX number type that
   can hold parts of type SPEC."
  (declare (type lexenv-designator environment) (ignore environment))
  (declare (explicit-check))
  (let ((type (type-or-nil-if-unknown spec)))
    (cond
      ((eq type *empty-type*) nil)
      ((not type) (error "Undefined type: ~S" spec))
      (t
       (let ((ctype (specifier-type `(complex ,spec)))) ; error checking
         (declare (ignore ctype))
         (type-specifier type))))))

;;; Return the most specific integer type that can be quickly checked that
;;; includes the given type.
(defun containing-integer-type (subtype)
  (dolist (type `(fixnum
                  (signed-byte ,sb-vm:n-word-bits)
                  (unsigned-byte ,sb-vm:n-word-bits)
                  integer)
                (error "~S isn't an integer type?" subtype))
    (when (csubtypep subtype (specifier-type type))
      (return type))))

;; Given a union type INPUT, see if it fully covers an ARRAY-* type,
;; and unite into that when possible, taking care to handle more
;; than one dimensionality/complexity of array, and non-array types.
;; If FOR-TYPEP is true, then:
;;  - The input and result are lists of the component types.
;;  - We allow "almost coverings" of ARRAY-* to produce an answer
;;    that results in a quicker test.
;;    e.g. unboxed-array = (and array (not (array t)))
;; Otherwise, if not FOR-TYPEP, the input/result are CTYPES,
;; and we don't introduce negations into the union.
;;
;; Note that in FOR-TYPEP usage, this function should get a chance to see
;; the whole union before WIDETAGS-FROM-UNION-TYPE has removed any types that
;; are testable by their widetag. Otherwise (TYPEP X '(UNBOXED-ARRAY 1))
;; becomes suboptimal. WIDETAGS-FROM-UNION-TYPE knows that strings/bit-vectors,
;; either simple or hairy, all have distinguishing widetags, so if it sees
;; them, reducing to (OR (%OTHER-POINTER-SUBTYPE-P ...) <more-array-types>),
;; the other array-types will not comprise an "almost covering" of ARRAY-*
;; and this code will not do what you want.
;; Additionally, as part of the contract, we don't create a type-difference
;; for a union all of whose types are testable by widetags.
;; e.g. it would be suboptimal to rewrite
;;  (SIMPLE-UNBOXED-ARRAY (*)) -> (AND (SIMPLE-ARRAY * (*)) (NOT (ARRAY T)))
;; because it always better to use %OTHER-POINTER-SUBTYPE-P in that case.

(defun simplify-array-unions (input &optional for-typep)
  (let* ((array-props sb-vm:*specialized-array-element-type-properties*)
         (types (if (listp input) input (union-type-types input)))
         (full-mask (1- (ash 1 (length array-props))))
         buckets output)
    ;; KLUDGE: counting the input types is a fine preliminary check
    ;; to avoid extra work, but importantly it (magically) bypasses all
    ;; this logic during cold-init when CTYPE slots of all SAETPs are nil.
    ;; SBCL sources mostly don't contain type expressions that benefit
    ;; from this transform.
    ;; If, in the not-for-typep case, there aren't at least as many
    ;; array types as SAETPs, there can't be a covering.
    ;; In the for-typep case, if there aren't at least half as many,
    ;; then it couldn't be rewritten as negation.
    ;; Uber-KLUDGE: using (length types) isn't enough to make the
    ;; not-for-typep case make it all the way through cold-init.
    (when (if for-typep
              (< (length types) (floor (length array-props) 2))
              (< (count-if #'array-type-p types) (length array-props)))
      (return-from simplify-array-unions input))
    (flet ((bucket-match-p (a b)
             (and (eq (array-type-complexp a) (array-type-complexp b))
                  (equal (array-type-dimensions a) (array-type-dimensions b))))
           (saetp-index (type)
             (and (array-type-p type)
                  (neq (array-type-specialized-element-type type) *wild-type*)
                  (position (array-type-specialized-element-type type) array-props
                            :key #'sb-vm:saetp-ctype :test #'type=)))
           (wild (type)
             (make-array-type (array-type-dimensions type)
                              :element-type *wild-type*
                              :complexp (array-type-complexp type))))
      ;; Bucket the array types by <dimensions,complexp> where each bucket
      ;; tracks which SAETPs were seen.
      ;; Search actual element types by TYPE=, not upgraded types, so that the
      ;; transform into (ARRAY *) is not lossy. However, if uniting does occur
      ;; and the resultant OR still contains any array type that upgrades to T,
      ;; we might want to do yet another reduction because:
      ;; (SPECIFIER-TYPE '(OR (VECTOR *) (VECTOR BAD))) => #<ARRAY-TYPE VECTOR>
      (dolist (type types)
        (binding* ((bit (saetp-index type) :exit-if-null)
                   (bucket (assoc type buckets :test #'bucket-match-p)))
          (unless bucket
            (push (setq bucket (cons type full-mask)) buckets))
          ;; Each _missing_ type is represented by a '1' bit so that
          ;; a final mask of 0 indicates an exhaustive partitioning.
          ;; (SETF LOGBITP) would work for us, but CLHS doesn't require it.
          (setf (cdr bucket) (logandc2 (cdr bucket) (ash 1 bit)))))
      (cond
        (for-typep
         ;; Maybe compute the complement with respect to (ARRAY *)
         ;; but never express unions of simple-rank-1 as a type-difference,
         ;; because widetag testing of those is better.
         (dolist (type types (nreverse output))
           (let* ((bucket
                   (and (saetp-index type)
                        (or (array-type-complexp type)
                            (not (equal (array-type-dimensions type) '(*))))
                        (assoc type buckets :test #'bucket-match-p)))
                  (disjunct
                   (cond ((and bucket
                               (plusp (cdr bucket))
                               (< (logcount (cdr bucket))
                                  (floor (length array-props) 2)))
                          (let (exclude)
                            (dotimes (i (length array-props))
                              (when (logbitp i (cdr bucket)) ; exclude it
                                (push (sb-vm:saetp-specifier
                                       (svref array-props i)) exclude)))
                            (setf (cdr bucket) -1) ; mark as generated
                            (specifier-type
                             `(and ,(type-specifier (wild type))
                                   ,@(mapcar (lambda (x) `(not (array ,x)))
                                             exclude)))))
                         ((not (eql (cdr bucket) -1))
                          ;; noncanonical input is a bug,
                          ;; so assert that bucket is not full.
                          (aver (not (eql (cdr bucket) 0)))
                          type)))) ; keep
             (when disjunct
               (push disjunct output)))))
        ((rassoc 0 buckets) ; at least one full bucket
         ;; For each input type subsumed by a full bucket,
         ;; insert the wild array type for that bucket.
         (dolist (type types (apply #'type-union (nreverse output)))
           (let* ((bucket (and (saetp-index type)
                               (assoc type buckets :test #'bucket-match-p)))
                  (disjunct (cond ((eql (cdr bucket) 0) ; bucket is full
                                   (setf (cdr bucket) -1) ; mark as generated
                                   (wild type))
                                  ((not (eql (cdr bucket) -1))
                                   type)))) ; keep
             (when disjunct
               (push disjunct output)))))
        (t input))))) ; no change

;;; If TYPE is such that its entirety is represented by 1 widetag
;;; - and that widetag can represent nothing else - then return the widetag.
;;; This is almost but not exactly in correspondence with (SB-C:PRIMITIVE-TYPE X).
;;; But a primitive type can be more specific than the type expressed by a widetag.
;;;   e.g. (SB-C:PRIMITIVE-TYPE (SPECIFIER-TYPE '(SIMD-PACK-256 DOUBLE-FLOAT))))
;;;         => #<SB-C:PRIMITIVE-TYPE :NAME SIMD-PACK-256-DOUBLE> and T
;;; So I guess we don't have a predicate that returns T if and only if a CTYPE
;;; is exactly one and only one of the "most primitive" representations,
;;; hence this.  The computation is just a best effort - it's generally OK to
;;; say NIL for anything nontrivial, even if there should be an exact answer.
(defun widetag-for-exactly-type (type)
  (cond ((built-in-classoid-p type)
         (case (classoid-name type)
           (system-area-pointer sb-vm:sap-widetag)
           (fdefn sb-vm:fdefn-widetag)))
        ((numeric-type-p type)
         (cond ((type= type (specifier-type '(complex single-float)))
                sb-vm:complex-single-float-widetag)
               ((type= type (specifier-type '(complex double-float)))
                sb-vm:complex-double-float-widetag)
               ((type= type (specifier-type '(complex rational)))
                sb-vm:complex-rational-widetag)))
        #+sb-simd-pack
        ((simd-pack-type-p type)
         (cond ((type= type (specifier-type 'simd-pack))
                sb-vm:simd-pack-widetag)))
        #+sb-simd-pack-256
        ((simd-pack-256-type-p type)
         (cond ((type= type (specifier-type 'simd-pack-256))
                sb-vm:simd-pack-256-widetag)))))

;; Given TYPES which is a list of types from a union type, decompose into
;; two unions, one being an OR over types representable as widetags
;; with other-pointer-lowtag, and the other being the difference
;; between the input TYPES and the widetags.
(defun widetags-from-union-type (types)
  (setq types (simplify-array-unions types t))
  (let (widetags remainder)
    ;; A little optimization for (OR BIGNUM other). Without this, there would
    ;; be a two-sided GENERIC-{<,>} test plus whatever test(s) "other" entails.
    (let ((neg-bignum (specifier-type `(integer * (,most-negative-fixnum))))
          (pos-bignum (specifier-type `(integer (,most-positive-fixnum) *))))
      (when (and (member neg-bignum types :test #'type=)
                 (member pos-bignum types :test #'type=))
        (push sb-vm:bignum-widetag widetags)
        (setf types (remove-if (lambda (x) (or (type= x neg-bignum) (type= x pos-bignum)))
                               types))))
    (dolist (x types)
      (let ((adjunct
             (cond
               ((widetag-for-exactly-type x)) ; easiest case
               ((and (array-type-p x)
                     (equal (array-type-dimensions x) '(*))
                     (type= (array-type-specialized-element-type x)
                            (array-type-element-type x)))
                (if (eq (array-type-specialized-element-type x) *wild-type*)
                    ;; could be done, but probably no merit to implementing
                    ;; maybe/definitely-complex wild-type.
                    (unless (array-type-complexp x)
                      (map 'list #'sb-vm:saetp-typecode
                           sb-vm:*specialized-array-element-type-properties*))
                    (let ((saetp
                           (find
                            (array-type-element-type x)
                            sb-vm:*specialized-array-element-type-properties*
                            :key #'sb-vm:saetp-ctype :test #'type=)))
                      (cond ((not (array-type-complexp x))
                             (sb-vm:saetp-typecode saetp))
                            ((sb-vm:saetp-complex-typecode saetp)
                             (list* (sb-vm:saetp-complex-typecode saetp)
                                    (when (eq (array-type-complexp x) :maybe)
                                      (list (sb-vm:saetp-typecode saetp)))))))))
               ((built-in-classoid-p x)
                (case (classoid-name x)
                  (symbol sb-vm:symbol-widetag)))))) ; plus a hack for nil
        (cond ((not adjunct) (push x remainder))
              ((listp adjunct) (setq widetags (nconc adjunct widetags)))
              (t (push adjunct widetags)))))
    (let ((remainder (nreverse remainder)))
      (when (member sb-vm:symbol-widetag widetags)
        ;; If symbol is the only widetag-testable type, it's better
        ;; to just use symbolp. e.g. (OR SYMBOL CHARACTER) should not
        ;; become (OR (%OTHER-POINTER-SUBTYPE-P ...)
        (when (null (rest widetags))
          (return-from widetags-from-union-type (values nil types)))
        ;; Manipulate 'remainder' to include NULL since NIL's lowtag
        ;; isn't other-pointer.
        (let ((null-type (specifier-type 'null)))
          (unless (member null-type remainder :test #'csubtypep)
            (push null-type remainder))))
      (values widetags remainder))))

;; Return T if SYMBOL will have a nonzero TLS index at load time or sooner.
;; True of all specials exported from CL:, all which expose slots of the thread
;; structure, and any symbol that the compiler decides will eventually have a
;; nonzero TLS index due to compiling a dynamic binding of it.
(defun sb-vm::symbol-always-has-tls-index-p (symbol)
  (not (null (info :variable :wired-tls symbol))))

#+(or x86 x86-64)
(defun sb-vm::displacement-bounds (lowtag element-size data-offset)
  (let* (;; The minimum immediate offset in a memory-referencing instruction.
         (minimum-immediate-offset (- (expt 2 31)))
         ;; The maximum immediate offset in a memory-referencing instruction.
         (maximum-immediate-offset (1- (expt 2 31)))
         (adjustment (- (* data-offset sb-vm:n-word-bytes) lowtag))
         (bytes-per-element (ceiling element-size sb-vm:n-byte-bits))
         (min (truncate (+ minimum-immediate-offset adjustment)
                        bytes-per-element))
         (max (truncate (+ maximum-immediate-offset adjustment)
                        bytes-per-element)))
    (values min max)))

#+(or x86 x86-64)
(sb-xc:deftype constant-displacement (lowtag element-size data-offset)
  (flet ((integerify (x)
           (etypecase x
             (integer x)
             (symbol (symbol-value x)))))
    (let ((lowtag (integerify lowtag))
          (element-size (integerify element-size))
          (data-offset (integerify data-offset)))
      (multiple-value-bind (min max)
          (sb-vm::displacement-bounds lowtag element-size data-offset)
        `(integer ,min ,max)))))

;;; A couple of VM-related types that are currently used only on the
;;; alpha and mips platforms. -- CSR, 2002-06-24
(sb-xc:deftype unsigned-byte-with-a-bite-out (size bite)
  (unless (typep size '(integer 1))
    (error "Bad size for the ~S type specifier: ~S."
           'unsigned-byte-with-a-bite-out size))
  (let ((bound (ash 1 size)))
    `(integer 0 ,(- bound bite 1))))

(sb-xc:deftype signed-byte-with-a-bite-out (size bite)
  (unless (typep size '(integer 2))
    (error "Bad size for ~S type specifier: ~S."
            'signed-byte-with-a-bite-out size))
  (let ((bound (ash 1 (1- size))))
    `(integer ,(- bound) ,(- bound bite 1))))