1 ;;;; late machine-independent aspects of the object representation
3 ;;;; This software is part of the SBCL system. See the README file for
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.
15 `(progn ,@*!late-primitive-object-forms
*)))
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
))))
26 (defconstant large-object-size
27 (* 4 (max +backend-page-bytes
+ gencgc-card-bytes
28 gencgc-alloc-granularity
)))
31 ;;; Keep this (mostly) lined up with 'early-objdef' for sanity's sake!
33 (defparameter *scav
/trans
/size
*
36 (cons (symbol-value (symbolicate (car entry
) "-WIDETAG"))
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")
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")
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")
58 (character "immediate")
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")
65 (no-tls-value-marker "immediate")
67 #!+sb-simd-pack
(simd-pack "unboxed")
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")
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")
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")
95 (simple-bit-vector "vector_bit")
96 (simple-vector "vector")
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")
105 (complex-bit-vector "boxed")
106 (complex-vector "boxed")
107 (complex-array "boxed"))))
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
"~%}~%"))
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]);~%}~%")
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))
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
))))
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 64 :initial-element nil
))
160 (sizetab (make-array 256 :initial-element nil
)))
162 (cond ((eql 0 (logand i fixnum-tag-mask
))
163 (setf (svref scavtab i
) "immediate" (svref sizetab i
) "immediate"))
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"))))
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
(ash widetag -
2)) 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
(length contents
))))
186 (format stream
"~%};~%")))
187 (write-table "sword_t (*scavtab[256])(lispobj *where, lispobj object)"
189 (write-table "static lispobj (*transother[64])(lispobj object)"
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)"
195 (format stream
"#undef size_pointer~%")
196 (format stream
"#undef size_unboxed~%")))
197 (format stream
"#endif~%"))