-
Notifications
You must be signed in to change notification settings - Fork 313
/
early-raw-slots.lisp
227 lines (213 loc) · 11.5 KB
/
early-raw-slots.lisp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
;;;; 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-KERNEL")
;;; STRUCTURE-OBJECT supports placement of raw bits within the object
;;; to allow representation of native word and float-point types directly.
;;; Historically the implementation was optimized for GC by placing all
;;; such slots at the end of the instance, and scavenging only up to last
;;; non-raw slot. This imposed significant overhead for access from Lisp,
;;; because "is-a" inheritance was obliged to rearrange raw slots
;;; to comply with the GC requirement, thus forcing ancestor structure
;;; accessors to compensate for physical structure length in all cases.
;;; Assuming that it is more important to simplify Lisp access than
;;; to simplify GC, we use a more flexible strategy that permits
;;; descendant structures to place new slots anywhere without changing
;;; slot placement established in ancestor structures.
;;; The trade-off is that GC (and a few other things - structure dumping,
;;; EQUALP checking, to name a few) have to be able to determine for each
;;; slot whether it is a Lisp descriptor or just bits. This is done
;;; with the LAYOUT-BITMAP of an object's layout.
;;;
;;; The bitmap stores a 1 in each bit index corresponding to a tagged slot
;;; index. If tagged slots follow raw slots and the the number of slots is
;;; large, the bitmap could be a bignum. As a special case, -1 represents
;;; that all slots are tagged regardless of instance length.
;;;
;;; Also note that there are possibly some alignment concerns which must
;;; be accounted for when DEFSTRUCT lays out slots,
;;; by injecting padding words appropriately.
;;; For example COMPLEX-DOUBLE-FLOAT *should* be aligned to twice the
;;; alignment of a DOUBLE-FLOAT. It is not, as things stand,
;;; but this is considered a minor bug.
;; To utilize a word-sized slot in a defstruct without having to resort to
;; writing (myslot :type (unsigned-byte #.sb-vm:n-word-bits)), or even
;; worse (:type #+sb-xc-host <sometype> #-sb-xc-host <othertype>),
;; these abstractions are provided as soon as the raw slots defs are.
(def!type sb-vm:word () `(unsigned-byte ,sb-vm:n-word-bits))
(def!type sb-vm:signed-word () `(signed-byte ,sb-vm:n-word-bits))
;;; This constant has a 1 bit meaning "tagged" for every user data slot.
;;; If LAYOUT is not in the header word, then (%INSTANCE-REF instance 0)
;;; indicates as raw so that GC treats layouts consistently, not scanning
;;; them en passant while visiting the payload. Consequently, 0 means either
;;; no slots or all raw, no matter if the layout consumes a slot.
;;; See remarks above CALCULATE-DD-BITMAP for further details.
(defconstant +layout-all-tagged+ (ash -1 sb-vm:instance-data-start))
;; information about how a slot of a given DSD-RAW-TYPE is to be accessed
(defstruct (raw-slot-data
(:constructor !make-raw-slot-data)
(:copier nil)
(:predicate nil))
;; What operator is used to access a slot of this type?
;; On the host this is a symbol, on the target it is a function
;; from which we can extract a name if needed.
#+sb-xc-host (accessor-name (missing-arg) :type symbol :read-only t)
#-sb-xc-host (accessor-fun (missing-arg) :type function :read-only t)
;; Function to compare slots of this type. Not used on host.
#-sb-xc-host (comparator (missing-arg) :type function :read-only t)
;; the type specifier, which must specify a numeric type.
(raw-type (missing-arg) :type symbol :read-only t)
;; How many words are each value of this type?
(n-words (missing-arg) :type (and index (integer 1)) :read-only t)
;; Necessary alignment in units of words. Note that instances
;; themselves are aligned by exactly two words, so specifying more
;; than two words here would not work.
(alignment 1 :type (integer 1 2) :read-only t))
(declaim (freeze-type raw-slot-data))
(declaim (inline raw-slot-data-reader-name))
(defun raw-slot-data-reader-name (rsd)
#+sb-xc-host (raw-slot-data-accessor-name rsd)
#-sb-xc-host (%simple-fun-name (raw-slot-data-accessor-fun rsd)))
(defun raw-slot-data-writer-name (rsd)
(ecase (raw-slot-data-reader-name rsd)
(%raw-instance-ref/word '%raw-instance-set/word)
(%raw-instance-ref/single '%raw-instance-set/single)
(%raw-instance-ref/double '%raw-instance-set/double)
(%raw-instance-ref/signed-word '%raw-instance-set/signed-word)
(%raw-instance-ref/complex-single '%raw-instance-set/complex-single)
(%raw-instance-ref/complex-double '%raw-instance-set/complex-double)))
;; Simulate DEFINE-LOAD-TIME-GLOBAL - always bound in the image
;; but not eval'd in the compiler.
(defglobal *raw-slot-data* nil)
;; By making this a cold-init function, it is possible to use raw slots
;; in cold toplevel forms.
(defun !raw-slot-data-init ()
(macrolet ((make-raw-slot-data (&rest args)
#+sb-xc-host `(!make-raw-slot-data ,@args)
#-sb-xc-host ; unwrap the QUOTE from the args (this is a macro)
(let ((access (cadr (getf args :accessor-name)))
(type (cadr (getf args :raw-type))))
`(!make-raw-slot-data
:accessor-fun #',access
:comparator #',(symbolicate "RAW-" type "SLOT=")
;; Ignore the :ACCESSOR-NAME initarg
,@args :allow-other-keys t))))
(let ((double-float-alignment
;; alignment in machine words of double-float slots.
;; For 8 byte words, this should be 1 since double-floats are 8 bytes.
;; It can be 1 if the word size is 4 bytes and the machine permits
;; double-floats to be unnaturally aligned (x86 and ppc).
(or #+(or x86 x86-64 ppc ppc64 arm64 riscv) 1
;; other architectures align double-floats to twice the
;; machine word size
2)))
(setq *raw-slot-data*
(vector
(make-raw-slot-data :raw-type 'sb-vm:word
:accessor-name '%raw-instance-ref/word
:n-words 1)
(make-raw-slot-data :raw-type 'sb-vm:signed-word
:accessor-name '%raw-instance-ref/signed-word
:n-words 1)
(make-raw-slot-data :raw-type 'single-float
:accessor-name '%raw-instance-ref/single
;; KLUDGE: On 64 bit architectures, we
;; could pack two SINGLE-FLOATs into the
;; same word if raw slots were indexed
;; using bytes instead of words. However,
;; I don't personally find optimizing
;; SINGLE-FLOAT memory usage worthwile
;; enough. And the other datatype that
;; would really benefit is (UNSIGNED-BYTE
;; 32), but that is a subtype of FIXNUM, so
;; we store it unraw anyway. :-( -- DFL
:n-words 1)
(make-raw-slot-data :raw-type 'double-float
:accessor-name '%raw-instance-ref/double
:alignment double-float-alignment
:n-words (/ 8 sb-vm:n-word-bytes))
(make-raw-slot-data :raw-type 'complex-single-float
:accessor-name '%raw-instance-ref/complex-single
:n-words (/ 8 sb-vm:n-word-bytes))
(make-raw-slot-data :raw-type 'complex-double-float
:accessor-name '%raw-instance-ref/complex-double
:alignment double-float-alignment
:n-words (/ 16 sb-vm:n-word-bytes))
#+long-float
(make-raw-slot-data :raw-type long-float
:accessor-name '%raw-instance-ref/long
:n-words #+x86 3 #+sparc 4)
#+long-float
(make-raw-slot-data :raw-type complex-long-float
:accessor-name '%raw-instance-ref/complex-long
:n-words #+x86 6 #+sparc 8))))))
#+sb-xc-host (!raw-slot-data-init)
#-sb-xc-host
(macrolet ((define-rs= ()
;; Expand by using the host's vector of RSD instances
`(progn
,@(loop for rsd across *raw-slot-data*
collect
(let ((type (raw-slot-data-raw-type rsd))
(reader (raw-slot-data-accessor-name rsd)))
`(defun ,(symbolicate "RAW-" type "SLOT=") (index x y)
(declare (optimize speed (safety 0)))
(= (,reader x index) (,reader y index))))))))
(define-rs=))
#+sb-xc
(declaim (type (simple-vector #.(length *raw-slot-data*)) *raw-slot-data*))
;;; DO-INSTANCE-TAGGED-SLOT iterates over the manifest slots of THING
;;; that contain tagged objects. (The LAYOUT does not count as a manifest slot).
;;; INDEX-VAR is bound to successive slot-indices,
;;; and is usually used as the second argument to %INSTANCE-REF.
#+sb-xc-host
(defmacro do-instance-tagged-slot ((index-var thing) &body body)
(with-unique-names (instance dsd)
`(let ((,instance ,thing))
(dolist (,dsd (dd-slots (find-defstruct-description (type-of ,instance))))
(let ((,index-var (dsd-index ,dsd)))
,@body)))))
#-sb-xc-host
(progn
(defmacro do-layout-bitmap ((index-var taggedp-var layout count) &body guts)
`(let* ((layout ,layout)
(bitmap-word-index (bitmap-start layout))
(bitmap-word-limit (%instance-length layout))
;; Shift out 1 bit if skipping bit 0 of the 0th mask word
;; because it's not user-visible data.
(mask (ash (%raw-instance-ref/signed-word
layout (prog1 bitmap-word-index (incf bitmap-word-index)))
,(- sb-vm:instance-data-start)))
;; If this was the last word of the bitmap, then the high bit
;; is infinitely sign-extended, and we can keep right-shifting
;; the mask word indefinitely. Most bitmaps will have only 1 word.
(nbits (if (= bitmap-word-index bitmap-word-limit)
,sb-vm:instance-length-mask
,(- sb-vm:n-word-bits sb-vm:instance-data-start))))
(declare (type sb-vm:signed-word mask)
(type fixnum nbits))
(do ((,index-var sb-vm:instance-data-start (1+ ,index-var))
(end ,count))
((>= ,index-var end))
(declare (type (unsigned-byte 14) ,index-var end))
;; If mask was fully consumed, fetch the next bitmap word
(when (zerop nbits)
(setq mask (%raw-instance-ref/signed-word layout bitmap-word-index)
nbits (if (= (incf (truly-the index bitmap-word-index))
bitmap-word-limit)
,sb-vm:instance-length-mask
,sb-vm:n-word-bits)))
(let ((,taggedp-var (logbitp 0 mask))) ,@guts)
(setq mask (ash mask -1)
nbits (truly-the fixnum (1- nbits))))))
(defmacro do-instance-tagged-slot ((index-var thing) &body body)
(with-unique-names (instance layout taggedp)
`(let* ((,instance ,thing)
(,layout (%instance-layout ,instance)))
(do-layout-bitmap (,index-var ,taggedp ,layout (%instance-length ,instance))
(when ,taggedp ,@body))))))