src/code/primordial-type.lisp

   1 ;;;; This software is part of the SBCL system. See the README file for
   2 ;;;; more information.
   3 ;;;;
   4 ;;;; This software is derived from the CMU CL system, which was
   5 ;;;; written at Carnegie Mellon University and released into the
   6 ;;;; public domain. The software is in the public domain and is
   7 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
   8 ;;;; files for more information.
   9
  10 (in-package "SB-KERNEL")
  11
  12 (!begin-collecting-cold-init-forms)
  13
  14 (define-type-class named :enumerable nil :might-contain-other-types nil)
  15
  16 (macrolet ((frob (type global-sym)
  17              (let* ((name-hash (%sxhash-simple-string (string type)))
  18                     ;; Toggle some bits so that the hash is not equal to the hash
  19                     ;; for a classoid of this name (relevant for named type T only)
  20                     (perturbed-bit-string
  21                       (let ((string (format nil "~32,'0b" name-hash)))
  22                         (concatenate 'string
  23                                      (subseq string 0 22) (reverse (subseq string 22)))))
  24                     (bits `(make-ctype-bits
  25                             'named
  26                             ,(parse-integer perturbed-bit-string :radix 2))))
  27                (declare (ignorable bits)) ; not used in XC
  28                `(progn
  29                   #+sb-xc-host
  30                   (progn (defvar ,global-sym (!make-named-type ,bits ',type))
  31                          ;; Make it known as a constant in the cross-compiler.
  32                          (setf (info :variable :kind ',global-sym) :constant))
  33                   (!cold-init-forms
  34                    #+sb-xc (sb-impl::%defconstant ',global-sym ,(symbol-value global-sym)
  35                                                   (sb-c:source-location))
  36                    (setf (info :type :builtin ',type) #+sb-xc-host ,global-sym #-sb-xc-host ,(symbol-value global-sym)
  37                          (info :type :kind ',type) :primitive))))))
  38   ;; KLUDGE: In ANSI, * isn't really the name of a type, it's just a
  39   ;; special symbol which can be stuck in some places where an
  40   ;; ordinary type can go, e.g. (ARRAY * 1) instead of (ARRAY T 1).
  41   ;; In SBCL it also used to denote universal VALUES type.
  42   (frob * *wild-type*)
  43   (frob nil *empty-type*)
  44   (frob t *universal-type*)
  45   ;; new in sbcl-0.9.5: these used to be CLASSOID types, but that
  46   ;; view of them was incompatible with requirements on the MOP
  47   ;; metaobject class hierarchy: the INSTANCE and
  48   ;; FUNCALLABLE-INSTANCE types are disjoint (instances have
  49   ;; instance-pointer-lowtag; funcallable-instances have
  50   ;; fun-pointer-lowtag), while FUNCALLABLE-STANDARD-OBJECT is
  51   ;; required to be a subclass of STANDARD-OBJECT.  -- CSR,
  52   ;; 2005-09-09
  53   (frob instance *instance-type*)
  54   (frob funcallable-instance *funcallable-instance-type*)
  55   ;; new in sbcl-1.0.3.3: necessary to act as a join point for the
  56   ;; extended sequence hierarchy.  (Might be removed later if we use
  57   ;; a dedicated FUNDAMENTAL-SEQUENCE class for this.)
  58   (frob extended-sequence *extended-sequence-type*))
  59
  60 #-sb-xc-host
  61 (progn
  62 ;;; a vector that maps widetags to layouts, used for quickly finding
  63 ;;; the layouts of built-in classes
  64 (define-load-time-global **primitive-object-layouts** nil)
  65 (declaim (type simple-vector **primitive-object-layouts**)))
  66
  67 #-sb-xc-host
  68 (!cold-init-forms
  69
  70 ;; This vector is allocated into immobile fixedobj space if #+compact-instance-header.
  71 ;; There isn't a way to do that from lisp, so it's special-cased in genesis.
  72 #-compact-instance-header (setq **primitive-object-layouts** (make-array 256))
  73 (map-into **primitive-object-layouts**
  74           (lambda (name) (classoid-layout (find-classoid name)))
  75           #.(let ((table (make-array 256 :initial-element 'sb-kernel::random-class)))
  76               (dolist (x sb-kernel::*builtin-classoids*)
  77                 (destructuring-bind (name &key codes &allow-other-keys) x
  78                   (dolist (code codes)
  79                     (setf (svref table code) name))))
  80               ;; widetag-of can return n-widetag-bits-long result for immediates/conses/functions.
  81               (loop for i from sb-vm:list-pointer-lowtag by (* 2 sb-vm:n-word-bytes)
  82                     below 256
  83                     do (setf (aref table i) 'cons))
  84               (loop for i from sb-vm:fun-pointer-lowtag by (* 2 sb-vm:n-word-bytes)
  85                     below 256
  86                     do (setf (aref table i) 'function))
  87               (loop for i from sb-vm:even-fixnum-lowtag by (ash 1 sb-vm:n-fixnum-tag-bits)
  88                     below 256
  89                     do (setf (aref table i) 'fixnum))
  90               table)))
  91
  92 (!defun-from-collected-cold-init-forms !primordial-type-cold-init)