src/compiler/generic/late-objdef.lisp

   1 ;;;; late machine-independent aspects of the object representation
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; This software is derived from the CMU CL system, which was
   7 ;;;; written at Carnegie Mellon University and released into the
   8 ;;;; public domain. The software is in the public domain and is
   9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  10 ;;;; files for more information.
  11
  12 (in-package "SB!VM")
  13
  14 (macrolet ((frob ()
  15              `(progn ,@*!late-primitive-object-forms*)))
  16   (frob))
  17
  18 #!+sb-thread
  19 (dolist (slot (primitive-object-slots
  20                (find 'thread *primitive-objects* :key #'primitive-object-name)))
  21   (when (slot-special slot)
  22     (setf (info :variable :wired-tls (slot-special slot))
  23           (ash (slot-offset slot) word-shift))))
  24
  25 #!+gencgc
  26 (defconstant large-object-size
  27   (* 4 (max *backend-page-bytes* gencgc-card-bytes
  28             gencgc-alloc-granularity)))
  29
  30
  31 ;;; Keep this (mostly) lined up with 'early-objdef' for sanity's sake!
  32 #+sb-xc-host
  33 (defparameter *scav/trans/size*
  34  (mapcar
  35   (lambda (entry)
  36     (cons (symbol-value (symbolicate (car entry) "-WIDETAG"))
  37           (cdr entry)))
  38   `((bignum "unboxed")
  39     (ratio "boxed" "ratio_or_complex" "boxed")
  40     (single-float ,(or #!+64-bit "immediate" "unboxed"))
  41     (double-float "unboxed")
  42     (complex "boxed" "ratio_or_complex" "boxed")
  43     (complex-single-float "unboxed")
  44     (complex-double-float "unboxed")
  45
  46     (code-header "code_header")
  47     ;; The scavenge function for fun-header is basically "lose",
  48     ;; but it's only defined on non-x86 platforms for some reason.
  49     (simple-fun ,(or #!+(or x86 x86-64) "lose" "fun_header") "fun_header" "lose")
  50     (closure ,(or #!+(or x86 x86-64) "closure" "short_boxed") "short_boxed")
  51     (funcallable-instance ,(or #!+compact-instance-header "funinstance" "short_boxed")
  52                                  "short_boxed")
  53     ;; These have a scav and trans function, but no size function.
  54     #!-(or x86 x86-64) (return-pc "return_pc_header" "return_pc_header" "lose")
  55
  56     (value-cell "boxed")
  57     (symbol "tiny_boxed")
  58     (character "immediate")
  59     (sap "unboxed")
  60     (unbound-marker "immediate")
  61     (weak-pointer "lose" "weak_pointer" "boxed")
  62     (instance "instance" "instance" "short_boxed")
  63     (fdefn ,(or #!+(or sparc arm) "boxed" "fdefn") "tiny_boxed")
  64
  65     (no-tls-value-marker "immediate")
  66
  67     #!+sb-simd-pack (simd-pack "unboxed")
  68
  69     (simple-array "boxed")
  70     (simple-array-unsigned-byte-2 "vector_unsigned_byte_2")
  71     (simple-array-unsigned-byte-4 "vector_unsigned_byte_4")
  72     (simple-array-unsigned-byte-7 "vector_unsigned_byte_8")
  73     (simple-array-unsigned-byte-8 "vector_unsigned_byte_8")
  74     (simple-array-unsigned-byte-15 "vector_unsigned_byte_16")
  75     (simple-array-unsigned-byte-16 "vector_unsigned_byte_16")
  76     (simple-array-unsigned-fixnum #!-64-bit "vector_unsigned_byte_32"
  77                                   #!+64-bit "vector_unsigned_byte_64")
  78     (simple-array-unsigned-byte-31 "vector_unsigned_byte_32")
  79     (simple-array-unsigned-byte-32 "vector_unsigned_byte_32")
  80     #!+64-bit (simple-array-unsigned-byte-63 "vector_unsigned_byte_64")
  81     #!+64-bit (simple-array-unsigned-byte-64 "vector_unsigned_byte_64")
  82
  83     (simple-array-signed-byte-8 "vector_unsigned_byte_8")
  84     (simple-array-signed-byte-16 "vector_unsigned_byte_16")
  85     (simple-array-signed-byte-32 "vector_unsigned_byte_32")
  86     (simple-array-fixnum #!-64-bit "vector_unsigned_byte_32"
  87                          #!+64-bit "vector_unsigned_byte_64")
  88     #!+64-bit (simple-array-signed-byte-64 "vector_unsigned_byte_64")
  89
  90     (simple-array-single-float "vector_unsigned_byte_32")
  91     (simple-array-double-float "vector_unsigned_byte_64")
  92     (simple-array-complex-single-float "vector_unsigned_byte_64")
  93     (simple-array-complex-double-float "vector_unsigned_byte_128")
  94
  95     (simple-bit-vector "vector_bit")
  96     (simple-vector "vector")
  97
  98     (simple-array-nil "vector_nil")
  99     (simple-base-string "base_string")
 100     #!+sb-unicode (simple-character-string "character_string")
 101     #!+sb-unicode (complex-character-string "boxed")
 102     (complex-base-string "boxed")
 103     (complex-vector-nil "boxed")
 104
 105     (complex-bit-vector "boxed")
 106     (complex-vector "boxed")
 107     (complex-array "boxed"))))
 108
 109 #+sb-xc-host
 110 (defun write-gc-tables (stream)
 111   ;; Compute a bitmask of all specialized vector types,
 112   ;; not including array headers, for maybe_adjust_large_object().
 113   (let ((min #xff) (bits 0))
 114     (dovector (saetp *specialized-array-element-type-properties*)
 115       (unless (eq (saetp-primitive-type-name saetp) 'simple-vector)
 116         (let ((widetag (saetp-typecode saetp)))
 117           (setf min (min widetag min)
 118                 bits (logior bits (ash 1 (ash widetag -2)))))))
 119     (format stream "static inline boolean specialized_vector_widetag_p(unsigned char widetag) {
 120   return widetag>=0x~X && (0x~8,'0XU >> ((widetag-0x80)>>2)) & 1;~%}~%"
 121             min (ldb (byte 32 32) bits))
 122     ;; Union in the bits for other unboxed object types.
 123     (dolist (entry *scav/trans/size*)
 124       (when (string= (second entry) "unboxed")
 125         (setf bits (logior bits (ash 1 (ash (car entry) -2))))))
 126     (format stream "static inline boolean unboxed_obj_widetag_p(unsigned char widetag) {~%")
 127     #!+64-bit (format stream "  return (0x~XLU >> (widetag>>2)) & 1;" bits)
 128     #!-64-bit (format stream "  int bit = widetag>>2;
 129   return (bit<32 ? 0x~XU >> bit : 0x~XU >> (bit-32)) & 1;"
 130                       (ldb (byte 32 0) bits) (ldb (byte 32 32) bits))
 131     (format stream "~%}~%"))
 132
 133   (format stream "extern unsigned char lowtag_for_widetag[64];
 134 static inline lispobj compute_lispobj(lispobj* base_addr) {
 135   lispobj header = *base_addr;
 136   return make_lispobj(base_addr,
 137                       is_cons_half(header) ? LIST_POINTER_LOWTAG :
 138                         lowtag_for_widetag[widetag_of(header)>>2]);~%}~%")
 139
 140   (format stream "~%#ifdef WANT_SCAV_TRANS_SIZE_TABLES~%")
 141   (let ((a (make-array 64 :initial-element 0)))
 142     (dolist (entry *scav/trans/size*)
 143       (destructuring-bind (widetag scav &rest ignore) entry
 144         (declare (ignore ignore))
 145         (unless (eq scav "immediate")
 146           (setf (aref a (ash widetag -2))
 147                 (case widetag
 148                   (#.instance-widetag instance-pointer-lowtag)
 149                   (#.+fun-header-widetags+ fun-pointer-lowtag)
 150                   (t other-pointer-lowtag))))))
 151     (let ((contents (format nil "~{0x~x,~} " (coerce a 'list))))
 152       (format stream
 153               "unsigned char lowtag_for_widetag[64] = {~{~%  ~A~}~%};~%"
 154               ;; write 4 characters per widetag ("0xN,"), 16 per line
 155               (loop for i from 0 by 64 repeat 4
 156                     ;; trailing comma on the last item is OK in C
 157                     collect (subseq contents i (+ i 64))))))
 158   (let ((scavtab  (make-array 256 :initial-element nil))
 159         (transtab (make-array 256 :initial-element nil))
 160         (sizetab  (make-array 256 :initial-element nil)))
 161     (dotimes (i 256)
 162       (cond ((eql 0 (logand i fixnum-tag-mask))
 163              (setf (svref scavtab i) "immediate" (svref sizetab i) "immediate"))
 164             (t
 165              (let ((pointer-kind (case (logand i lowtag-mask)
 166                                    (#.instance-pointer-lowtag "instance")
 167                                    (#.list-pointer-lowtag     "list")
 168                                    (#.fun-pointer-lowtag      "fun")
 169                                    (#.other-pointer-lowtag    "other"))))
 170                (when pointer-kind
 171                  (setf (svref scavtab i) (format nil "~A_pointer" pointer-kind)
 172                        (svref sizetab i) "pointer"))))))
 173     (dolist (entry *scav/trans/size*)
 174       (destructuring-bind (widetag scav &optional (trans scav) (size trans)) entry
 175         (setf (svref scavtab widetag) scav
 176               (svref transtab widetag) trans
 177               (svref sizetab widetag) size)))
 178     (flet ((write-table (decl prefix contents)
 179              (format stream "~A = {" decl)
 180              (loop for i from 0 for x across contents
 181                    when (zerop (mod i 4))
 182                    do (format stream "~%  ")
 183                    do (format stream "~V@<~A~A~:[~;,~]~>"
 184                               (if (= (mod i 4) 3) 0 31)
 185                               prefix (or x "lose") (< i 256)))
 186              (format stream "~%};~%")))
 187       (write-table "sword_t (*scavtab[256])(lispobj *where, lispobj object)"
 188                    "scav_" scavtab)
 189       (write-table "lispobj (*transother[256])(lispobj object)"
 190                    "trans_" transtab)
 191       (format stream "#define size_pointer size_immediate~%")
 192       (format stream "#define size_unboxed size_boxed~%")
 193       (write-table "sword_t (*sizetab[256])(lispobj *where)"
 194                    "size_" sizetab)
 195       (format stream "#undef size_pointer~%")
 196       (format stream "#undef size_unboxed~%")))
 197   (format stream "#endif~%"))