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"))
40 (single-float ,(or #!+64-bit
"immediate" "unboxed"))
41 (double-float "unboxed")
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-header ,(or #!+(or x86 x86-64
) "lose" "fun_header") "fun_header" "lose")
50 (closure-header ,(or #!+(or x86 x86-64
) "closure_header" "short_boxed")
52 (funcallable-instance-header ,(or #!+compact-instance-header
"funinstance" "short_boxed")
54 ;; These have a scav and trans function, but no size function.
55 #!-
(or x86 x86-64
) (return-pc-header "return_pc_header" "return_pc_header" "lose")
57 (value-cell-header "boxed")
58 (symbol-header "tiny_boxed")
59 (character "immediate")
61 (unbound-marker "immediate")
62 (weak-pointer "lose" "weak_pointer" "boxed")
63 (instance-header "instance" "instance" "short_boxed")
64 (fdefn ,(or #!+(or sparc arm
) "boxed" "fdefn") "tiny_boxed")
66 (no-tls-value-marker "immediate")
68 #!+sb-simd-pack
(simd-pack "unboxed")
70 (simple-array "boxed")
71 (simple-array-unsigned-byte-2 "vector_unsigned_byte_2")
72 (simple-array-unsigned-byte-4 "vector_unsigned_byte_4")
73 (simple-array-unsigned-byte-7 "vector_unsigned_byte_8")
74 (simple-array-unsigned-byte-8 "vector_unsigned_byte_8")
75 (simple-array-unsigned-byte-15 "vector_unsigned_byte_16")
76 (simple-array-unsigned-byte-16 "vector_unsigned_byte_16")
77 (simple-array-unsigned-fixnum #!-
64-bit
"vector_unsigned_byte_32"
78 #!+64-bit
"vector_unsigned_byte_64")
79 (simple-array-unsigned-byte-31 "vector_unsigned_byte_32")
80 (simple-array-unsigned-byte-32 "vector_unsigned_byte_32")
81 #!+64-bit
(simple-array-unsigned-byte-63 "vector_unsigned_byte_64")
82 #!+64-bit
(simple-array-unsigned-byte-64 "vector_unsigned_byte_64")
84 (simple-array-signed-byte-8 "vector_unsigned_byte_8")
85 (simple-array-signed-byte-16 "vector_unsigned_byte_16")
86 (simple-array-signed-byte-32 "vector_unsigned_byte_32")
87 (simple-array-fixnum #!-
64-bit
"vector_unsigned_byte_32"
88 #!+64-bit
"vector_unsigned_byte_64")
89 #!+64-bit
(simple-array-signed-byte-64 "vector_unsigned_byte_64")
91 (simple-array-single-float "vector_unsigned_byte_32")
92 (simple-array-double-float "vector_unsigned_byte_64")
93 (simple-array-complex-single-float "vector_unsigned_byte_64")
94 (simple-array-complex-double-float "vector_unsigned_byte_128")
96 (simple-bit-vector "vector_bit")
97 (simple-vector "vector")
99 (simple-array-nil "vector_nil")
100 (simple-base-string "base_string")
101 #!+sb-unicode
(simple-character-string "character_string")
102 #!+sb-unicode
(complex-character-string "boxed")
103 (complex-base-string "boxed")
104 (complex-vector-nil "boxed")
106 (complex-bit-vector "boxed")
107 (complex-vector "boxed")
108 (complex-array "boxed"))))
111 (defun write-gc-tables (stream)
112 ;; Compute a bitmask of all specialized vector types,
113 ;; not including array headers, for maybe_adjust_large_object().
114 (let ((min #xff
) (bits 0))
115 (dovector (saetp *specialized-array-element-type-properties
*)
116 (unless (eq (saetp-primitive-type-name saetp
) 'simple-vector
)
117 (let ((widetag (saetp-typecode saetp
)))
118 (setf min
(min widetag min
)
119 bits
(logior bits
(ash 1 (ash widetag -
2)))))))
120 (format stream
"static inline boolean specialized_vector_widetag_p(unsigned char widetag) {
121 return widetag>=0x~X && (0x~8,'0XU >> ((widetag-0x80)>>2)) & 1;~%}~%"
122 min
(ldb (byte 32 32) bits
))
123 ;; Union in the bits for other unboxed object types.
124 (dolist (entry *scav
/trans
/size
*)
125 (when (string= (second entry
) "unboxed")
126 (setf bits
(logior bits
(ash 1 (ash (car entry
) -
2))))))
127 (format stream
"static inline boolean unboxed_obj_widetag_p(unsigned char widetag) {~%")
128 #!+64-bit
(format stream
" return (0x~XLU >> (widetag>>2)) & 1;" bits
)
129 #!-
64-bit
(format stream
" int bit = widetag>>2;
130 return (bit<32 ? 0x~XU >> bit : 0x~XU >> (bit-32)) & 1;"
131 (ldb (byte 32 0) bits
) (ldb (byte 32 32) bits
))
132 (format stream
"~%}~%"))
134 (format stream
"~%#ifdef WANT_SCAV_TRANS_SIZE_TABLES~%")
135 (let ((a (make-array 64 :initial-element
0)))
136 (dolist (entry *scav
/trans
/size
*)
137 (destructuring-bind (widetag scav
&rest ignore
) entry
138 (declare (ignore ignore
))
139 (unless (eq scav
"immediate")
140 (setf (aref a
(ash widetag -
2))
142 (#.instance-header-widetag instance-pointer-lowtag
)
143 ((#.funcallable-instance-header-widetag
144 #.closure-header-widetag
145 #.simple-fun-header-widetag
)
148 other-pointer-lowtag
))))))
149 (let ((contents (format nil
"~{0x~x,~} " (coerce a
'list
))))
151 "unsigned char lowtag_for_widetag[64] = {~{~% ~A~}~%};~%"
152 ;; write 4 characters per widetag ("0xN,"), 16 per line
153 (loop for i from
0 by
64 repeat
4
154 ;; trailing comma on the last item is OK in C
155 collect
(subseq contents i
(+ i
64))))))
156 (let ((scavtab (make-array 256 :initial-element nil
))
157 (transtab (make-array 256 :initial-element nil
))
158 (sizetab (make-array 256 :initial-element nil
)))
160 (cond ((eql 0 (logand i fixnum-tag-mask
))
161 (setf (svref scavtab i
) "immediate" (svref sizetab i
) "immediate"))
163 (let ((pointer-kind (case (logand i lowtag-mask
)
164 (#.instance-pointer-lowtag
"instance")
165 (#.list-pointer-lowtag
"list")
166 (#.fun-pointer-lowtag
"fun")
167 (#.other-pointer-lowtag
"other"))))
169 (setf (svref scavtab i
) (format nil
"~A_pointer" pointer-kind
)
170 (svref sizetab i
) "pointer"))))))
171 (dolist (entry *scav
/trans
/size
*)
172 (destructuring-bind (widetag scav
&optional
(trans scav
) (size trans
)) entry
173 (setf (svref scavtab widetag
) scav
174 (svref transtab widetag
) trans
175 (svref sizetab widetag
) size
)))
176 (flet ((write-table (decl prefix contents
)
177 (format stream
"~A = {" decl
)
178 (loop for i from
0 for x across contents
179 when
(zerop (mod i
4))
180 do
(format stream
"~% ")
181 do
(format stream
"~V@<~A~A~:[~;,~]~>"
182 (if (= (mod i
4) 3) 0 31)
183 prefix
(or x
"lose") (< i
256)))
184 (format stream
"~%};~%")))
185 (write-table "sword_t (*scavtab[256])(lispobj *where, lispobj object)"
187 (write-table "lispobj (*transother[256])(lispobj object)"
189 (format stream
"#define size_pointer size_immediate~%")
190 (format stream
"#define size_unboxed size_boxed~%")
191 (write-table "sword_t (*sizetab[256])(lispobj *where)"
193 (format stream
"#undef size_pointer~%")
194 (format stream
"#undef size_unboxed~%")))
195 (format stream
"#endif~%"))