primtype.lisp

开源跨平台Lisp编译器

;;;; machine-independent aspects of the object representation and
;;;; primitive types

;;;; 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!VM")

;;;; primitive type definitions

(/show0 "primtype.lisp 17")

(!def-primitive-type t (descriptor-reg))
(/show0 "primtype.lisp 20")
(setf *backend-t-primitive-type* (primitive-type-or-lose t))

;;; primitive integer types that fit in registers
(/show0 "primtype.lisp 24")
(!def-primitive-type positive-fixnum (any-reg signed-reg unsigned-reg)
  :type (unsigned-byte #.sb!vm:n-positive-fixnum-bits))
(/show0 "primtype.lisp 27")
#!+#.(cl:if (cl:= sb!vm::n-machine-word-bits 32) '(and) '(or))
(!def-primitive-type unsigned-byte-31 (signed-reg unsigned-reg descriptor-reg)
  :type (unsigned-byte 31))
(/show0 "primtype.lisp 31")
#!+#.(cl:if (cl:= sb!vm::n-machine-word-bits 32) '(and) '(or))
(!def-primitive-type unsigned-byte-32 (unsigned-reg descriptor-reg)
  :type (unsigned-byte 32))
(/show0 "primtype.lisp 35")
#!+#.(cl:if (cl:= sb!vm::n-machine-word-bits 64) '(and) '(or))
(!def-primitive-type unsigned-byte-63 (signed-reg unsigned-reg descriptor-reg)
  :type (unsigned-byte 63))
#!+#.(cl:if (cl:= sb!vm::n-machine-word-bits 64) '(and) '(or))
(!def-primitive-type unsigned-byte-64 (unsigned-reg descriptor-reg)
  :type (unsigned-byte 64))
(!def-primitive-type fixnum (any-reg signed-reg)
  :type (signed-byte #.(1+ sb!vm:n-positive-fixnum-bits)))
#!+#.(cl:if (cl:= sb!vm::n-machine-word-bits 32) '(and) '(or))
(!def-primitive-type signed-byte-32 (signed-reg descriptor-reg)
  :type (signed-byte 32))
#!+#.(cl:if (cl:= sb!vm::n-machine-word-bits 64) '(and) '(or))
(!def-primitive-type signed-byte-64 (signed-reg descriptor-reg)
  :type (signed-byte 64))

(defvar *fixnum-primitive-type* (primitive-type-or-lose 'fixnum))

(/show0 "primtype.lisp 53")
(!def-primitive-type-alias tagged-num (:or positive-fixnum fixnum))
(progn
  (!def-primitive-type-alias unsigned-num #1=
    #!+#.(cl:if (cl:= sb!vm::n-machine-word-bits 64) '(and) '(or))
    (:or unsigned-byte-64 unsigned-byte-63 positive-fixnum)
    #!-#.(cl:if (cl:= sb!vm::n-machine-word-bits 64) '(and) '(or))
    (:or unsigned-byte-32 unsigned-byte-31 positive-fixnum))
  (!def-primitive-type-alias signed-num #2=
    #!+#.(cl:if (cl:= sb!vm::n-machine-word-bits 64) '(and) '(or))
    (:or signed-byte-64 fixnum unsigned-byte-63 positive-fixnum)
    #!-#.(cl:if (cl:= sb!vm::n-machine-word-bits 64) '(and) '(or))
    (:or signed-byte-32 fixnum unsigned-byte-31 positive-fixnum))
  (!def-primitive-type-alias untagged-num
    (:or . #.(print (union (cdr '#1#) (cdr '#2#))))))

;;; other primitive immediate types
(/show0 "primtype.lisp 68")
(!def-primitive-type character (character-reg any-reg))

;;; primitive pointer types
(/show0 "primtype.lisp 73")
(!def-primitive-type function (descriptor-reg))
(!def-primitive-type list (descriptor-reg))
(!def-primitive-type instance (descriptor-reg))

(/show0 "primtype.lisp 77")
(!def-primitive-type funcallable-instance (descriptor-reg))

;;; primitive other-pointer number types
(/show0 "primtype.lisp 81")
(!def-primitive-type bignum (descriptor-reg))
(!def-primitive-type ratio (descriptor-reg))
(!def-primitive-type complex (descriptor-reg))
(/show0 "about to !DEF-PRIMITIVE-TYPE SINGLE-FLOAT")
(!def-primitive-type single-float (single-reg descriptor-reg))
(/show0 "about to !DEF-PRIMITIVE-TYPE DOUBLE-FLOAT")
(!def-primitive-type double-float (double-reg descriptor-reg))

(/show0 "about to !DEF-PRIMITIVE-TYPE COMPLEX-SINGLE-FLOAT")
(!def-primitive-type complex-single-float (complex-single-reg descriptor-reg)
  :type (complex single-float))
(/show0 "about to !DEF-PRIMITIVE-TYPE COMPLEX-DOUBLE-FLOAT")
(!def-primitive-type complex-double-float (complex-double-reg descriptor-reg)
  :type (complex double-float))


;;; primitive other-pointer array types
(/show0 "primtype.lisp 96")
(macrolet ((define-simple-array-primitive-types ()
               `(progn
                 ,@(map 'list
                        (lambda (saetp)
                          `(!def-primitive-type
                            ,(saetp-primitive-type-name saetp)
                            (descriptor-reg)
                            :type (simple-array ,(saetp-specifier saetp) (*))))
                        *specialized-array-element-type-properties*))))
  (define-simple-array-primitive-types))
;;; Note: The complex array types are not included, 'cause it is
;;; pointless to restrict VOPs to them.

;;; other primitive other-pointer types
(!def-primitive-type system-area-pointer (sap-reg descriptor-reg))
(!def-primitive-type weak-pointer (descriptor-reg))

;;; miscellaneous primitive types that don't exist at the LISP level
(!def-primitive-type catch-block (catch-block) :type nil)

;;;; PRIMITIVE-TYPE-OF and friends

;;; Return the most restrictive primitive type that contains OBJECT.
(/show0 "primtype.lisp 147")
(!def-vm-support-routine primitive-type-of (object)
  (let ((type (ctype-of object)))
    (cond ((not (member-type-p type)) (primitive-type type))
          ((and (eql 1 (member-type-size type))
                (equal (member-type-members type) '(nil)))
           (primitive-type-or-lose 'list))
          (t
           *backend-t-primitive-type*))))

;;; Return the primitive type corresponding to a type descriptor
;;; structure. The second value is true when the primitive type is
;;; exactly equivalent to the argument Lisp type.
;;;
;;; In a bootstrapping situation, we should be careful to use the
;;; correct values for the system parameters.
;;;
;;; We need an aux function because we need to use both
;;; !DEF-VM-SUPPORT-ROUTINE and DEFUN-CACHED.
(/show0 "primtype.lisp 188")
(!def-vm-support-routine primitive-type (type)
  (primitive-type-aux type))
(/show0 "primtype.lisp 191")
(defun-cached (primitive-type-aux
               :hash-function (lambda (x)
                                (logand (type-hash-value x) #x1FF))
               :hash-bits 9
               :values 2
               :default (values nil :empty))
              ((type eq))
  (declare (type ctype type))
  (macrolet ((any () '(values *backend-t-primitive-type* nil))
             (exactly (type)
               `(values (primitive-type-or-lose ',type) t))
             (part-of (type)
               `(values (primitive-type-or-lose ',type) nil)))
    (flet ((maybe-numeric-type-union (t1 t2)
             (let ((t1-name (primitive-type-name t1))
                   (t2-name (primitive-type-name t2)))
               (case t1-name
                 (positive-fixnum
                  (if (or (eq t2-name 'fixnum)
                          (eq t2-name
                              (ecase sb!vm::n-machine-word-bits
                                (32 'signed-byte-32)
                                (64 'signed-byte-64)))
                          (eq t2-name
                              (ecase sb!vm::n-machine-word-bits
                                (32 'unsigned-byte-31)
                                (64 'unsigned-byte-63)))
                          (eq t2-name
                              (ecase sb!vm::n-machine-word-bits
                                (32 'unsigned-byte-32)
                                (64 'unsigned-byte-64))))
                      t2))
                 (fixnum
                  (case t2-name
                    (#.(ecase sb!vm::n-machine-word-bits
                         (32 'signed-byte-32)
                         (64 'signed-byte-64))
                       t2)
                    (#.(ecase sb!vm::n-machine-word-bits
                         (32 'unsigned-byte-31)
                         (64 'unsigned-byte-63))
                       (primitive-type-or-lose
                        (ecase sb!vm::n-machine-word-bits
                          (32 'signed-byte-32)
                          (64 'signed-byte-64))))))
                 (#.(ecase sb!vm::n-machine-word-bits
                      (32 'signed-byte-32)
                      (64 'signed-byte-64))
                  (if (eq t2-name
                          (ecase sb!vm::n-machine-word-bits