1 ;;;; Lisp-side allocation (used currently only for direct allocation
2 ;;;; to static and immobile spaces).
4 ;;;; This software is part of the SBCL system. See the README file for
7 ;;;; This software is derived from the CMU CL system, which was
8 ;;;; written at Carnegie Mellon University and released into the
9 ;;;; public domain. The software is in the public domain and is
10 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
11 ;;;; files for more information.
15 #!-sb-fluid
(declaim (inline store-word
))
16 (defun store-word (word base
&optional
(offset 0) (lowtag 0))
17 (declare (type (unsigned-byte #.n-word-bits
) word base offset
)
18 (type (unsigned-byte #.n-lowtag-bits
) lowtag
))
19 (setf (sap-ref-word (int-sap base
) (- (ash offset word-shift
) lowtag
)) word
))
21 (defun allocate-static-vector (widetag length words
)
22 (declare (type (unsigned-byte #.n-widetag-bits
) widetag
)
23 (type (unsigned-byte #.n-word-bits
) words
)
25 ;; WITHOUT-GCING implies WITHOUT-INTERRUPTS
28 (let* ((pointer (ash *static-space-free-pointer
* n-fixnum-tag-bits
))
29 (vector (logior pointer other-pointer-lowtag
))
30 (nbytes (pad-data-block (+ words vector-data-offset
)))
31 (new-pointer (+ pointer nbytes
)))
32 (when (> static-space-end new-pointer
)
34 vector
0 other-pointer-lowtag
)
35 (store-word (fixnumize length
)
36 vector vector-length-slot other-pointer-lowtag
)
37 (store-word 0 new-pointer
)
38 (setf *static-space-free-pointer
*
39 (ash new-pointer
(- n-fixnum-tag-bits
)))
40 (%make-lisp-obj vector
))))
41 (error 'simple-storage-condition
42 :format-control
"Not enough memory left in static space to ~
48 (defglobal *immobile-space-mutex
* (sb!thread
:make-mutex
:name
"Immobile space"))
50 (eval-when (:compile-toplevel
)
51 (assert (eql code-code-size-slot
1))
52 (assert (eql code-debug-info-slot
2)))
54 (define-alien-variable "varyobj_holes" long
)
55 (define-alien-variable "varyobj_page_touched_bits" (* (unsigned 32)))
56 (define-alien-variable "varyobj_page_scan_start_offset" (* (unsigned 16)))
57 (define-alien-variable "varyobj_page_header_gens" (* (unsigned 8)))
58 (define-alien-routine "find_preceding_object" long
(where long
))
60 ;;; Lazily created freelist, used only when unallocate is called:
61 ;;; A cons whose car is a sorted list of hole sizes available
62 ;;; and whose cdr is a hashtable.
63 ;;; The keys in the hashtable are hole sizes, values are lists of holes.
64 ;;; A better structure would be just a sorted array of sizes
65 ;;; with each entry pointing to the holes which are threaded through
66 ;;; some bytes in the storage itself rather than through cons cells.
67 (!defglobal
*immobile-freelist
* nil
)
69 ;;; Return the zero-based index within the varyobj subspace of immobile space.
70 (defun varyobj-page-index (address)
71 (declare (type (and fixnum unsigned-byte
) address
))
72 (values (floor (- address
(+ immobile-space-start immobile-fixedobj-subspace-size
))
73 immobile-card-bytes
)))
75 (defun varyobj-page-address (index)
76 (+ immobile-space-start immobile-fixedobj-subspace-size
77 (* index immobile-card-bytes
)))
79 ;;; Convert a zero-based varyobj page index into a scan start address.
80 (defun varyobj-page-scan-start (index)
81 (- (+ immobile-space-start immobile-fixedobj-subspace-size
82 (* (1+ index
) immobile-card-bytes
))
83 (* 2 n-word-bytes
(deref varyobj-page-scan-start-offset index
))))
85 (declaim (inline hole-p
))
86 (defun hole-p (raw-address)
87 (eql (sap-ref-32 (int-sap raw-address
) 0)
88 (logior (ash 2 n-widetag-bits
) code-header-widetag
)))
90 (defun freed-hole-p (address)
92 ;; A hole is not considered to have been freed until it is
93 ;; no longer in the chain of objects linked through
94 ;; the debug_info slot.
95 (eql (sap-ref-word (int-sap address
)
96 (ash code-debug-info-slot word-shift
))
99 (declaim (inline hole-size
))
100 (defun hole-size (hole-address) ; in bytes
101 (+ (sap-ref-lispobj (int-sap hole-address
) (ash code-code-size-slot word-shift
))
102 (ash 2 word-shift
))) ; add 2 boxed words
104 (declaim (inline (setf hole-size
)))
105 (defun (setf hole-size
) (new-size hole
) ; NEW-SIZE is in bytes
106 (setf (sap-ref-lispobj (int-sap hole
) (ash code-code-size-slot word-shift
))
107 (- new-size
(ash 2 word-shift
)))) ; account for 2 boxed words
109 (declaim (inline hole-end-address
))
110 (defun hole-end-address (hole-address)
111 (+ hole-address
(hole-size hole-address
)))
113 (defun sorted-list-insert (item list key-fn
)
114 (declare (function key-fn
))
115 (let ((key (funcall key-fn item
)) (tail list
) prev
)
118 (let ((new-tail (list item
)))
119 (return (cond ((not prev
) new-tail
)
120 (t (setf (cdr prev
) new-tail
) list
)))))
121 (let ((head (car tail
)))
122 (when (< key
(funcall key-fn head
))
124 (rplacd tail
(cons head
(cdr tail
)))
126 (setq prev tail tail
(cdr tail
)))))
128 ;;; These routines are not terribly efficient, but very straightforward
129 ;;; since we can assume the existence of hashtables.
130 (defun add-to-freelist (hole)
131 (let* ((size (hole-size hole
))
132 (freelist *immobile-freelist
*)
133 (table (cdr freelist
))
134 (old (gethash (hole-size hole
) table
)))
135 ;; Check for double-free error
136 #!+immobile-space-debug
(aver (not (member hole
(gethash size table
))))
139 (sorted-list-insert size
(car freelist
) #'identity
)))
140 (setf (gethash size table
) (cons hole old
))))
142 (defun remove-from-freelist (hole)
143 (let* ((key (hole-size hole
))
144 (freelist *immobile-freelist
*)
145 (table (cdr freelist
))
146 (list (gethash key table
))
147 (old-length (length list
))
148 (new (delete hole list
:count
1)))
149 (declare (ignorable old-length
))
150 #!+immobile-space-debug
(aver (= (length new
) (1- old-length
)))
152 (setf (gethash key table
) new
))
154 (setf (car freelist
) (delete key
(car freelist
) :count
1))
155 (remhash key table
)))))
157 (defun find-in-freelist (size test
)
158 (let* ((freelist *immobile-freelist
*)
161 (let ((sizes (member size
(car freelist
) :test
'<=)))
163 (return-from find-in-freelist nil
))
166 (found (car (gethash hole-size
(cdr freelist
)))))
168 (remove-from-freelist found
))
171 (defun set-immobile-space-free-pointer (free-ptr)
172 (declare (type (and fixnum unsigned-byte
) free-ptr
))
173 (setq *immobile-space-free-pointer
* (ash free-ptr
(- n-fixnum-tag-bits
)))
174 ;; When the free pointer is not page-aligned - it usually won't be -
175 ;; then we create an unboxed array from the pointer to the page end
176 ;; so that it appears as one contiguous object when scavenging.
177 ;; instead of a bunch of cons cells.
178 (when (logtest free-ptr
(1- immobile-card-bytes
))
179 (let ((n-trailing-bytes
180 (- (nth-value 1 (ceiling free-ptr immobile-card-bytes
)))))
181 (setf (sap-ref-word (int-sap free-ptr
) 0) simple-array-fixnum-widetag
182 (sap-ref-word (int-sap free-ptr
) n-word-bytes
)
183 ;; Convert bytes to words, subtract the header and vector length.
184 (ash (- (ash n-trailing-bytes
(- word-shift
)) 2)
185 n-fixnum-tag-bits
)))))
187 (defun unallocate (hole)
188 #!+immobile-space-debug
189 (awhen *in-use-bits
* (mark-range it hole
(hole-size hole
) nil
))
190 (let* ((hole-end (hole-end-address hole
))
191 (end-is-free-ptr (eql (ash hole-end
(- n-fixnum-tag-bits
))
192 *immobile-space-free-pointer
*)))
193 ;; First, ensure that no page's scan-start points to this hole.
194 ;; For smaller-than-page objects, this will do nothing if the hole
195 ;; was not the scan-start. For larger-than-page, we have to update
196 ;; a range of pages. Example:
197 ;; | page1 | page2 | page3 | page4 |
198 ;; |-- hole A ------ | -- hole B --
199 ;; If page1 had an object preceding the hole, then it is not empty,
200 ;; but if it pointed to the hole, and the hole extended to the end
201 ;; of the first page, then that page is empty.
202 ;; Pages (1+ first-page) through (1- last-page) inclusive
203 ;; must become empty. last-page may or may not be depending
204 ;; on whether another object can be found on it.
205 (let ((first-page (varyobj-page-index hole
))
206 (last-page (varyobj-page-index (1- hole-end
))))
207 (when (and (eql (varyobj-page-scan-start first-page
) hole
)
208 (< first-page last-page
))
209 (setf (deref varyobj-page-scan-start-offset first-page
) 0))
210 (loop for page from
(1+ first-page
) below last-page
211 do
(setf (deref varyobj-page-scan-start-offset page
) 0))
212 ;; Only touch the offset for the last page if it pointed to this hole.
213 ;; If the following object is a hole that is in the pending free list,
214 ;; it's ok, but if it's a hole that is already in the freelist,
215 ;; it's not OK, so look beyond that object. We don't have to iterate,
216 ;; since there can't be two consecutive holes - so it's either the
217 ;; object after this hole, or the one after that.
218 (when (eql (varyobj-page-scan-start last-page
) hole
)
219 (let* ((page-end (varyobj-page-address (1+ last-page
)))
220 (new-scan-start (cond (end-is-free-ptr page-end
)
221 ((freed-hole-p hole-end
)
222 (hole-end-address hole-end
))
224 (setf (deref varyobj-page-scan-start-offset last-page
)
225 (if (< new-scan-start page-end
)
226 ;; Compute new offset backwards relative to the page end.
227 (/ (- page-end new-scan-start
) (* 2 n-word-bytes
))
228 0))))) ; Page becomes empty
230 (unless *immobile-freelist
*
231 (setf *immobile-freelist
* (cons nil
(make-hash-table :test
#'eq
))))
233 ;; find-preceding is the most expensive operation in this sequence
234 ;; of steps. Not sure how to improve it, but I doubt it's a problem.
235 (let* ((predecessor (find-preceding-object hole
))
236 (pred-is-free (and (not (eql predecessor
0))
237 (freed-hole-p predecessor
))))
239 (remove-from-freelist predecessor
)
240 (setf hole predecessor
))
241 (when end-is-free-ptr
242 ;; Give back space below the free pointer for better space conservation.
243 ;; Consider when the hole touching the free pointer is equal in size
244 ;; to another hole that could have been used instead. Taking space at
245 ;; the free pointer diminishes the opportunity to use the frontier
246 ;; to later allocate a larger object that would not have fit
247 ;; into any existing hole.
248 (set-immobile-space-free-pointer hole
)
249 (return-from unallocate
))
250 (let* ((successor hole-end
)
251 (succ-is-free (freed-hole-p successor
)))
253 (setf hole-end
(hole-end-address successor
))
254 (remove-from-freelist successor
)))
255 ;; The hole must be an integral number of doublewords.
256 (aver (zerop (rem (- hole-end hole
) 16)))
257 (setf (hole-size hole
) (- hole-end hole
))))
258 (add-to-freelist hole
))
260 (defun allocate-immobile-bytes (n-bytes word0 word1 lowtag
)
261 (declare (type (and fixnum unsigned-byte
) n-bytes
))
262 (setq n-bytes
(logandc2 (+ n-bytes
(1- (* 2 n-word-bytes
)))
263 (1- (* 2 n-word-bytes
))))
264 ;; Can't allocate fewer than 4 words due to min hole size.
265 (aver (>= n-bytes
(* 4 n-word-bytes
)))
266 (sb!thread
::with-system-mutex
(*immobile-space-mutex
* :without-gcing t
)
267 (unless (zerop varyobj-holes
)
268 ;; If deferred sweep needs to happen, do so now.
269 ;; Concurrency could potentially be improved here: at most one thread
270 ;; should do this step, but it doesn't need to be exclusive with GC
271 ;; as long as we can atomically pop items off the list of holes.
272 (let ((hole-addr varyobj-holes
))
273 (setf varyobj-holes
0)
275 (let ((next (sap-ref-word (int-sap hole-addr
)
276 (ash code-debug-info-slot word-shift
))))
277 (setf (sap-ref-word (int-sap hole-addr
)
278 (ash code-debug-info-slot word-shift
))
280 (unallocate hole-addr
)
281 (if (eql (setq hole-addr next
) 0) (return))))))
283 (or (and *immobile-freelist
*
284 (or (find-in-freelist n-bytes
'=) ; 1. Exact match?
285 ;; 2. Try splitting a hole, adding some slack so that
286 ;; both pieces can potentially be used.
287 (let ((found (find-in-freelist (+ n-bytes
192) '<=)))
289 (let* ((actual-size (hole-size found
))
290 (remaining (- actual-size n-bytes
)))
291 (aver (zerop (rem actual-size
16)))
292 (setf (hole-size found
) remaining
) ; Shorten the lower piece
293 (add-to-freelist found
)
294 (+ found remaining
)))))) ; Consume the upper piece
295 ;; 3. Extend the frontier.
296 (let* ((addr (ash *immobile-space-free-pointer
* n-fixnum-tag-bits
))
297 (free-ptr (+ addr n-bytes
)))
298 ;; The last page can't be used, because GC uses it as scratch space.
299 (when (> free-ptr
(- immobile-space-end immobile-card-bytes
))
300 (format t
"~&Immobile space exhausted~%")
302 (set-immobile-space-free-pointer free-ptr
)
304 (aver (not (logtest addr lowtag-mask
))) ; Assert proper alignment
305 ;; Compute the start and end of the first page consumed.
306 (let* ((page-start (logandc2 addr
(1- immobile-card-bytes
)))
307 (page-end (+ page-start immobile-card-bytes
))
308 (index (varyobj-page-index addr
))
309 (obj-end (+ addr n-bytes
)))
310 ;; Mark the page as being used by a nursery object.
311 (setf (deref varyobj-page-header-gens index
)
312 (logior (deref varyobj-page-header-gens index
) 1))
313 ;; On the object's first page, set the scan start only if addr
314 ;; is lower than the current page-scan-start object.
315 ;; Note that offsets are expressed in doublewords backwards from
316 ;; page end, so that we can direct the scan start to any doubleword
317 ;; on the page or in the preceding 1MiB (approximately).
318 (when (< addr
(varyobj-page-scan-start index
))
319 (setf (deref varyobj-page-scan-start-offset index
)
320 (ash (- page-end addr
) (- (1+ word-shift
)))))
321 ;; On subsequent pages, always set the scan start, since there can not
322 ;; be a lower-addressed object touching those pages.
324 (setq page-start page-end
)
325 (incf page-end immobile-card-bytes
)
327 (when (>= page-start obj-end
) (return))
328 (setf (deref varyobj-page-scan-start-offset index
)
329 (ash (- page-end addr
) (- (1+ word-shift
))))))
330 #!+immobile-space-debug
; "address sanitizer"
331 (awhen *in-use-bits
* (mark-range it addr n-bytes t
))
332 (setf (sap-ref-word (int-sap addr
) 0) word0
333 (sap-ref-word (int-sap addr
) n-word-bytes
) word1
)
334 ;; 0-fill the remainder of the object
335 (system-area-ub64-fill 0 (int-sap addr
) 2 (- (ash n-bytes
(- word-shift
)) 2))
336 (%make-lisp-obj
(logior addr lowtag
)))))
338 (defun allocate-immobile-vector (widetag length words
)
339 (allocate-immobile-bytes (pad-data-block (+ words vector-data-offset
))
342 other-pointer-lowtag
))
344 (defun allocate-immobile-simple-vector (n-elements)
345 (allocate-immobile-vector simple-vector-widetag n-elements n-elements
))
346 (defun allocate-immobile-bit-vector (n-elements)
347 (allocate-immobile-vector simple-bit-vector-widetag n-elements
348 (ceiling n-elements n-word-bits
)))
349 (defun allocate-immobile-byte-vector (n-elements)
350 (allocate-immobile-vector simple-array-unsigned-byte-8-widetag n-elements
351 (ceiling n-elements n-word-bytes
)))
352 (defun allocate-immobile-word-vector (n-elements)
353 (allocate-immobile-vector simple-array-unsigned-byte-64-widetag n-elements
356 ;;; This is called when we're already inside WITHOUT-GCing
357 (defun allocate-immobile-code (n-boxed-words n-unboxed-bytes
)
358 (let* ((unrounded-header-n-words (+ code-constants-offset n-boxed-words
))
359 (rounded-header-words (* 2 (ceiling unrounded-header-n-words
2)))
360 (total-bytes (+ (* rounded-header-words n-word-bytes
)
361 (logandc2 (+ n-unboxed-bytes lowtag-mask
) lowtag-mask
)))
362 (code (allocate-immobile-bytes
364 (logior (ash rounded-header-words n-widetag-bits
) code-header-widetag
)
365 (ash n-unboxed-bytes n-fixnum-tag-bits
)
366 other-pointer-lowtag
)))
367 (setf (%code-debug-info code
) nil
)
370 (defun show-fragmentation ()
374 (+ immobile-space-start immobile-fixedobj-subspace-size
))
375 (free-pointer *immobile-space-free-pointer
*))
376 (map-objects-in-range
377 (lambda (obj type size
)
379 (when (hole-p (- (get-lisp-obj-address obj
) (lowtag-of obj
)))
380 (let ((hole (- (get-lisp-obj-address obj
) (lowtag-of obj
))))
382 (incf n-hole-bytes size
)
383 (format t
"~X..~X ~6d~%" hole
(+ hole size
) size
))))
384 (ash subspace-start
(- n-fixnum-tag-bits
))
386 (format t
" ~18d (total ~D holes)~%" n-hole-bytes n-holes
)
387 (let ((total-space-used
388 (- (ash free-pointer n-fixnum-tag-bits
) subspace-start
)))
389 (values n-hole-bytes total-space-used
390 (* 100.0 (/ n-hole-bytes total-space-used
))))))