1 | ;;;-*- Mode: Lisp; Package: CCL -*- |
---|
2 | ;;; |
---|
3 | ;;; Copyright (C) 1994-2001 Digitool, Inc |
---|
4 | ;;; This file is part of OpenMCL. |
---|
5 | ;;; |
---|
6 | ;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public |
---|
7 | ;;; License , known as the LLGPL and distributed with OpenMCL as the |
---|
8 | ;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, |
---|
9 | ;;; which is distributed with OpenMCL as the file "LGPL". Where these |
---|
10 | ;;; conflict, the preamble takes precedence. |
---|
11 | ;;; |
---|
12 | ;;; OpenMCL is referenced in the preamble as the "LIBRARY." |
---|
13 | ;;; |
---|
14 | ;;; The LLGPL is also available online at |
---|
15 | ;;; http://opensource.franz.com/preamble.html |
---|
16 | |
---|
17 | (in-package "CCL") |
---|
18 | |
---|
19 | ; Miscellany. |
---|
20 | |
---|
21 | (defun memq (item list) |
---|
22 | (do* ((tail list (%cdr tail))) |
---|
23 | ((null tail)) |
---|
24 | (if (eq item (car tail)) |
---|
25 | (return tail)))) |
---|
26 | |
---|
27 | (defun %copy-u8-to-string (u8-vector source-idx string dest-idx n) |
---|
28 | (declare (optimize (speed 3) (safety 0)) |
---|
29 | (fixnum source-idx dest-idx n) |
---|
30 | (type (simple-array (unsigned-byte 8) (*)) u8-vector) |
---|
31 | (simple-base-string string)) |
---|
32 | (do* ((i 0 (1+ i))) |
---|
33 | ((= i n) string) |
---|
34 | (declare (fixnum i)) |
---|
35 | (setf (%scharcode string dest-idx) (aref u8-vector source-idx)) |
---|
36 | (incf source-idx) |
---|
37 | (incf dest-idx))) |
---|
38 | |
---|
39 | (defun %copy-string-to-u8 (string source-idx u8-vector dest-idx n) |
---|
40 | (declare (optimize (speed 3) (safety 0)) |
---|
41 | (fixnum source-idx dest-idx n) |
---|
42 | (type (simple-array (unsigned-byte 8) (*)) u8-vector) |
---|
43 | (simple-base-string string)) |
---|
44 | (do* ((i 0 (1+ i))) |
---|
45 | ((= i n) u8-vector) |
---|
46 | (declare (fixnum i)) |
---|
47 | (let* ((code (%scharcode string source-idx))) |
---|
48 | (declare (type (mod #x11000) code)) |
---|
49 | (if (> code #xff) |
---|
50 | (setq code (char-code #\Sub))) |
---|
51 | (setf (aref u8-vector dest-idx) code) |
---|
52 | (incf source-idx) |
---|
53 | (incf dest-idx)))) |
---|
54 | |
---|
55 | |
---|
56 | |
---|
57 | |
---|
58 | (defun append-2 (y z) |
---|
59 | (if (null y) |
---|
60 | z |
---|
61 | (let* ((new (cons (car y) nil)) |
---|
62 | (tail new)) |
---|
63 | (declare (list new tail)) |
---|
64 | (dolist (head (cdr y)) |
---|
65 | (setq tail (cdr (rplacd tail (cons head nil))))) |
---|
66 | (rplacd tail z) |
---|
67 | new))) |
---|
68 | |
---|
69 | |
---|
70 | |
---|
71 | |
---|
72 | |
---|
73 | |
---|
74 | |
---|
75 | |
---|
76 | |
---|
77 | (defun dbg (&optional arg) |
---|
78 | (dbg arg)) |
---|
79 | |
---|
80 | |
---|
81 | ; This takes a simple-base-string and passes a C string into |
---|
82 | ; the kernel "Bug" routine. Not too fancy, but neither is #_DebugStr, |
---|
83 | ; and there's a better chance that users would see this message. |
---|
84 | (defun bug (arg) |
---|
85 | (if (typep arg 'simple-base-string) |
---|
86 | #+x8664-target |
---|
87 | (debug-trap-with-string arg) |
---|
88 | #-x8664-target |
---|
89 | (let* ((len (length arg))) |
---|
90 | (%stack-block ((buf (1+ len))) |
---|
91 | (%cstr-pointer arg buf) |
---|
92 | (ff-call |
---|
93 | (%kernel-import target::kernel-import-lisp-bug) |
---|
94 | :address buf |
---|
95 | :void))) |
---|
96 | (bug "Bug called with non-simple-base-string."))) |
---|
97 | |
---|
98 | (defun total-bytes-allocated () |
---|
99 | (%heap-bytes-allocated) |
---|
100 | #+not-any-more |
---|
101 | (+ (unsignedwide->integer *total-bytes-freed*) |
---|
102 | (%heap-bytes-allocated))) |
---|
103 | |
---|
104 | (defun %freebytes () |
---|
105 | (%normalize-areas) |
---|
106 | (let ((res 0)) |
---|
107 | (with-macptrs (p) |
---|
108 | (do-consing-areas (area) |
---|
109 | (when (eql (%fixnum-ref area target::area.code) area-dynamic) |
---|
110 | (%setf-macptr-to-object p area) |
---|
111 | (incf res (- (%get-natural p target::area.high) |
---|
112 | (%get-natural p target::area.active)))))) |
---|
113 | res)) |
---|
114 | |
---|
115 | (defun %reservedbytes () |
---|
116 | (with-macptrs (p) |
---|
117 | (%setf-macptr-to-object p (%get-kernel-global 'all-areas)) |
---|
118 | (- #+32-bit-target |
---|
119 | (%get-unsigned-long p target::area.high) |
---|
120 | #+64-bit-target |
---|
121 | (%%get-unsigned-longlong p target::area.high) |
---|
122 | #+32-bit-target |
---|
123 | (%get-unsigned-long p target::area.low) |
---|
124 | #+64-bit-target |
---|
125 | (%%get-unsigned-longlong p target::area.low)))) |
---|
126 | |
---|
127 | (defun object-in-application-heap-p (address) |
---|
128 | (declare (ignore address)) |
---|
129 | t) |
---|
130 | |
---|
131 | |
---|
132 | (defun %usedbytes () |
---|
133 | (%normalize-areas) |
---|
134 | (let ((static 0) |
---|
135 | (dynamic 0) |
---|
136 | (library 0)) |
---|
137 | (do-consing-areas (area) |
---|
138 | (let* ((active (%fixnum-ref area target::area.active)) |
---|
139 | (bytes (ash (- active |
---|
140 | (%fixnum-ref area target::area.low)) |
---|
141 | target::fixnumshift)) |
---|
142 | (code (%fixnum-ref area target::area.code))) |
---|
143 | (when (object-in-application-heap-p active) |
---|
144 | (if (eql code area-dynamic) |
---|
145 | (incf dynamic bytes) |
---|
146 | (if (eql code area-managed-static) |
---|
147 | (incf library bytes) |
---|
148 | (incf static bytes)))))) |
---|
149 | (let* ((hons-size (ash (openmcl-hons:hons-space-size) target::dnode-shift))) |
---|
150 | (decf dynamic hons-size) |
---|
151 | (values dynamic static library hons-size)))) |
---|
152 | |
---|
153 | |
---|
154 | |
---|
155 | (defun %stack-space () |
---|
156 | (%normalize-areas) |
---|
157 | (let ((free 0) |
---|
158 | (used 0)) |
---|
159 | (with-macptrs (p) |
---|
160 | (do-gc-areas (area) |
---|
161 | (when (member (%fixnum-ref area target::area.code) |
---|
162 | '(#.area-vstack |
---|
163 | #.area-cstack |
---|
164 | #.area-tstack)) |
---|
165 | (%setf-macptr-to-object p area) |
---|
166 | (let ((active |
---|
167 | #+32-bit-target |
---|
168 | (%get-unsigned-long p target::area.active) |
---|
169 | #+64-bit-target |
---|
170 | (%%get-unsigned-longlong p target::area.active)) |
---|
171 | (high |
---|
172 | #+32-bit-target |
---|
173 | (%get-unsigned-long p target::area.high) |
---|
174 | #+64-bit-target |
---|
175 | (%%get-unsigned-longlong p target::area.high)) |
---|
176 | (low |
---|
177 | #+32-bit-target |
---|
178 | (%get-unsigned-long p target::area.low) |
---|
179 | #+64-bit-target |
---|
180 | (%%get-unsigned-longlong p target::area.low))) |
---|
181 | (incf used (- high active)) |
---|
182 | (incf free (- active low)))))) |
---|
183 | (values (+ free used) used free))) |
---|
184 | |
---|
185 | |
---|
186 | |
---|
187 | ; Returns an alist of the form: |
---|
188 | ; ((thread cstack-free cstack-used vstack-free vstack-used tstack-free tstack-used) |
---|
189 | ; ...) |
---|
190 | (defun %stack-space-by-lisp-thread () |
---|
191 | (let* ((res nil)) |
---|
192 | (without-interrupts |
---|
193 | (dolist (p (all-processes)) |
---|
194 | (let* ((thread (process-thread p))) |
---|
195 | (when thread |
---|
196 | (push (cons thread (multiple-value-list (%thread-stack-space thread))) res))))) |
---|
197 | res)) |
---|
198 | |
---|
199 | |
---|
200 | |
---|
201 | ;;; Returns six values. |
---|
202 | ;;; sp free |
---|
203 | ;;; sp used |
---|
204 | ;;; vsp free |
---|
205 | ;;; vsp used |
---|
206 | ;;; tsp free |
---|
207 | ;;; tsp used |
---|
208 | (defun %thread-stack-space (&optional (thread *current-lisp-thread*)) |
---|
209 | (when (eq thread *current-lisp-thread*) |
---|
210 | (%normalize-areas)) |
---|
211 | (labels ((free-and-used (area) |
---|
212 | (with-macptrs (p) |
---|
213 | (%setf-macptr-to-object p area) |
---|
214 | (let* ((low |
---|
215 | #+32-bit-target |
---|
216 | (%get-unsigned-long p target::area.low) |
---|
217 | #+64-bit-target |
---|
218 | (%%get-unsigned-longlong p target::area.low)) |
---|
219 | (high |
---|
220 | #+32-bit-target |
---|
221 | (%get-unsigned-long p target::area.high) |
---|
222 | #+64-bit-target |
---|
223 | (%%get-unsigned-longlong p target::area.high)) |
---|
224 | (active |
---|
225 | #+32-bit-target |
---|
226 | (%get-unsigned-long p target::area.active) |
---|
227 | #+64-bit-target |
---|
228 | (%%get-unsigned-longlong p target::area.active)) |
---|
229 | (free (- active low)) |
---|
230 | (used (- high active))) |
---|
231 | (loop |
---|
232 | (setq area (%fixnum-ref area target::area.older)) |
---|
233 | (when (eql area 0) (return)) |
---|
234 | (%setf-macptr-to-object p area) |
---|
235 | (let ((low |
---|
236 | #+32-bit-target |
---|
237 | (%get-unsigned-long p target::area.low) |
---|
238 | #+64-bit-target |
---|
239 | (%%get-unsigned-longlong p target::area.low)) |
---|
240 | (high |
---|
241 | #+32-bit-target |
---|
242 | (%get-unsigned-long p target::area.high) |
---|
243 | #+64-bit-target |
---|
244 | (%%get-unsigned-longlong p target::area.high))) |
---|
245 | (declare (fixnum low high)) |
---|
246 | (incf used (- high low)))) |
---|
247 | (values free used))))) |
---|
248 | (let* ((tcr (lisp-thread.tcr thread))) |
---|
249 | (if (or (null tcr) |
---|
250 | (zerop (%fixnum-ref (%fixnum-ref tcr target::tcr.cs-area)))) |
---|
251 | (values 0 0 0 0 0 0) |
---|
252 | (multiple-value-bind (cf cu) (free-and-used (%fixnum-ref tcr target::tcr.cs-area)) |
---|
253 | (multiple-value-bind (vf vu) (free-and-used (%fixnum-ref tcr target::tcr.vs-area)) |
---|
254 | (multiple-value-bind (tf tu) (free-and-used (%fixnum-ref tcr target::tcr.ts-area )) |
---|
255 | (values cf cu vf vu tf tu)))))))) |
---|
256 | |
---|
257 | |
---|
258 | (defun room (&optional (verbose :default)) |
---|
259 | "Print to *STANDARD-OUTPUT* information about the state of internal |
---|
260 | storage and its management. The optional argument controls the |
---|
261 | verbosity of output. If it is T, ROOM prints out a maximal amount of |
---|
262 | information. If it is NIL, ROOM prints out a minimal amount of |
---|
263 | information. If it is :DEFAULT or it is not supplied, ROOM prints out |
---|
264 | an intermediate amount of information." |
---|
265 | (let* ((freebytes nil) |
---|
266 | (usedbytes nil) |
---|
267 | (static-used nil) |
---|
268 | (staticlib-used nil) |
---|
269 | (hons-space-size nil) |
---|
270 | (lispheap nil) |
---|
271 | (reserved nil) |
---|
272 | (static nil) |
---|
273 | (stack-total) |
---|
274 | (stack-used) |
---|
275 | (stack-free) |
---|
276 | (stack-used-by-thread nil)) |
---|
277 | (progn |
---|
278 | (progn |
---|
279 | (setq freebytes (%freebytes)) |
---|
280 | (when verbose |
---|
281 | (multiple-value-setq (usedbytes static-used staticlib-used hons-space-size) |
---|
282 | (%usedbytes)) |
---|
283 | (setq lispheap (+ freebytes usedbytes) |
---|
284 | reserved (%reservedbytes) |
---|
285 | static (+ static-used staticlib-used hons-space-size)) |
---|
286 | (multiple-value-setq (stack-total stack-used stack-free) |
---|
287 | (%stack-space)) |
---|
288 | (unless (eq verbose :default) |
---|
289 | (setq stack-used-by-thread (%stack-space-by-lisp-thread)))))) |
---|
290 | (format t "~&Approximately ~:D bytes of memory can be allocated ~%before the next full GC is triggered. ~%" freebytes) |
---|
291 | (when verbose |
---|
292 | (flet ((k (n) (round n 1024))) |
---|
293 | (princ " |
---|
294 | Total Size Free Used") |
---|
295 | (format t "~&Lisp Heap:~15t~10D (~DK)~35t~10D (~DK)~55t~10D (~DK)" |
---|
296 | lispheap (k lispheap) |
---|
297 | freebytes (k freebytes) |
---|
298 | usedbytes (k usedbytes)) |
---|
299 | (format t "~&Stacks:~15t~10D (~DK)~35t~10D (~DK)~55t~10D (~DK)" |
---|
300 | stack-total (k stack-total) |
---|
301 | stack-free (k stack-free) |
---|
302 | stack-used (k stack-used)) |
---|
303 | (format t "~&Static:~15t~10D (~DK)~35t~10D (~DK)~55t~10D (~DK)" |
---|
304 | static (k static) |
---|
305 | 0 0 |
---|
306 | static (k static)) |
---|
307 | (when (and hons-space-size (not (zerop hons-space-size))) |
---|
308 | (format t "~&~,3f MB of static memory reserved for hash consing." |
---|
309 | (/ hons-space-size (float (ash 1 20))))) |
---|
310 | (format t "~&~,3f MB reserved for heap expansion." |
---|
311 | (/ reserved (float (ash 1 20)))) |
---|
312 | (unless (eq verbose :default) |
---|
313 | (terpri) |
---|
314 | (let* ((processes (all-processes))) |
---|
315 | (dolist (thread-info stack-used-by-thread) |
---|
316 | (destructuring-bind (thread sp-free sp-used vsp-free vsp-used tsp-free tsp-used) |
---|
317 | thread-info |
---|
318 | (let* ((process (dolist (p processes) |
---|
319 | (when (eq (process-thread p) thread) |
---|
320 | (return p))))) |
---|
321 | (when process |
---|
322 | (let ((sp-total (+ sp-used sp-free)) |
---|
323 | (vsp-total (+ vsp-used vsp-free)) |
---|
324 | (tsp-total (+ tsp-used tsp-free))) |
---|
325 | (format t "~%~a(~d)~% cstack:~12T~10D (~DK) ~33T~10D (~DK) ~54T~10D (~DK)~ |
---|
326 | ~% vstack:~12T~10D (~DK) ~33T~10D (~DK) ~54T~10D (~DK)~ |
---|
327 | ~% tstack:~12T~10D (~DK) ~33T~10D (~DK) ~54T~10D (~DK)" |
---|
328 | (process-name process) |
---|
329 | (process-serial-number process) |
---|
330 | sp-total (k sp-total) sp-free (k sp-free) sp-used (k sp-used) |
---|
331 | vsp-total (k vsp-total) vsp-free (k vsp-free) vsp-used (k vsp-used) |
---|
332 | tsp-total (k tsp-total) tsp-free (k tsp-free) tsp-used (k tsp-used))))))))))))) |
---|
333 | |
---|
334 | |
---|
335 | (defun list-length (l) |
---|
336 | "Return the length of the given LIST, or NIL if the LIST is circular." |
---|
337 | (do* ((n 0 (+ n 2)) |
---|
338 | (fast l (cddr fast)) |
---|
339 | (slow l (cdr slow))) |
---|
340 | ((null fast) n) |
---|
341 | (declare (fixnum n)) |
---|
342 | (if (null (cdr fast)) |
---|
343 | (return (the fixnum (1+ n))) |
---|
344 | (if (and (eq fast slow) |
---|
345 | (> n 0)) |
---|
346 | (return nil))))) |
---|
347 | |
---|
348 | (defun proper-list-p (l) |
---|
349 | (and (typep l 'list) |
---|
350 | (do* ((n 0 (+ n 2)) |
---|
351 | (fast l (if (and (listp fast) (listp (cdr fast))) |
---|
352 | (cddr fast) |
---|
353 | (return-from proper-list-p nil))) |
---|
354 | (slow l (cdr slow))) |
---|
355 | ((null fast) n) |
---|
356 | (declare (fixnum n)) |
---|
357 | (if (atom fast) |
---|
358 | (return nil) |
---|
359 | (if (null (cdr fast)) |
---|
360 | (return t) |
---|
361 | (if (and (eq fast slow) |
---|
362 | (> n 0)) |
---|
363 | (return nil))))))) |
---|
364 | |
---|
365 | (defun proper-sequence-p (x) |
---|
366 | (cond ((typep x 'vector)) |
---|
367 | ((typep x 'list) (not (null (list-length x)))))) |
---|
368 | |
---|
369 | |
---|
370 | (defun length (seq) |
---|
371 | "Return an integer that is the length of SEQUENCE." |
---|
372 | (seq-dispatch |
---|
373 | seq |
---|
374 | (or (list-length seq) |
---|
375 | (%err-disp $XIMPROPERLIST seq)) |
---|
376 | (if (= (the fixnum (typecode seq)) target::subtag-vectorH) |
---|
377 | (%svref seq target::vectorH.logsize-cell) |
---|
378 | (uvsize seq)))) |
---|
379 | |
---|
380 | (defun %str-from-ptr (pointer len &optional (dest (make-string len))) |
---|
381 | (declare (fixnum len) |
---|
382 | (optimize (speed 3) (safety 0))) |
---|
383 | (dotimes (i len dest) |
---|
384 | (setf (%scharcode dest i) (%get-unsigned-byte pointer i)))) |
---|
385 | |
---|
386 | (defun %get-cstring (pointer) |
---|
387 | (do* ((end 0 (1+ end))) |
---|
388 | ((zerop (the (unsigned-byte 8) (%get-unsigned-byte pointer end))) |
---|
389 | (%str-from-ptr pointer end)) |
---|
390 | (declare (fixnum end)))) |
---|
391 | |
---|
392 | (defun %get-utf-8-cstring (pointer) |
---|
393 | (do* ((end 0 (1+ end))) |
---|
394 | ((zerop (the (unsigned-byte 8) (%get-unsigned-byte pointer end))) |
---|
395 | (let* ((len (utf-8-length-of-memory-encoding pointer end 0)) |
---|
396 | (string (make-string len))) |
---|
397 | (utf-8-memory-decode pointer end 0 string) |
---|
398 | string)) |
---|
399 | (declare (fixnum end)))) |
---|
400 | |
---|
401 | ;;; This is mostly here so we can bootstrap shared libs without |
---|
402 | ;;; having to bootstrap #_strcmp. |
---|
403 | ;;; Return true if the cstrings are equal, false otherwise. |
---|
404 | (defun %cstrcmp (x y) |
---|
405 | (do* ((i 0 (1+ i)) |
---|
406 | (bx (%get-byte x i) (%get-byte x i)) |
---|
407 | (by (%get-byte y i) (%get-byte y i))) |
---|
408 | ((not (= bx by))) |
---|
409 | (declare (fixnum i bx by)) |
---|
410 | (when (zerop bx) |
---|
411 | (return t)))) |
---|
412 | |
---|
413 | (defvar %documentation nil) |
---|
414 | |
---|
415 | (defvar %documentation-lock% nil) |
---|
416 | |
---|
417 | (setq %documentation |
---|
418 | (make-hash-table :weak t :size 100 :test 'eq :rehash-threshold .95) |
---|
419 | %documentation-lock% (make-lock)) |
---|
420 | |
---|
421 | (defun %put-documentation (thing doc-id doc) |
---|
422 | (with-lock-grabbed (%documentation-lock%) |
---|
423 | (let* ((info (gethash thing %documentation)) |
---|
424 | (pair (assoc doc-id info))) |
---|
425 | (if doc |
---|
426 | (progn |
---|
427 | (unless (typep doc 'string) |
---|
428 | (report-bad-arg doc 'string)) |
---|
429 | (if pair |
---|
430 | (setf (cdr pair) doc) |
---|
431 | (setf (gethash thing %documentation) (cons (cons doc-id doc) info)))) |
---|
432 | (when pair |
---|
433 | (if (setq info (nremove pair info)) |
---|
434 | (setf (gethash thing %documentation) info) |
---|
435 | (remhash thing %documentation)))))) |
---|
436 | doc) |
---|
437 | |
---|
438 | (defun %get-documentation (object doc-id) |
---|
439 | (cdr (assoc doc-id (gethash object %documentation)))) |
---|
440 | |
---|
441 | ;;; This pretends to be (SETF DOCUMENTATION), until that generic function |
---|
442 | ;;; is defined. It handles a few common cases. |
---|
443 | (defun %set-documentation (thing doc-id doc-string) |
---|
444 | (case doc-id |
---|
445 | (function |
---|
446 | (if (typep thing 'function) |
---|
447 | (%put-documentation thing t doc-string) |
---|
448 | (if (typep thing 'symbol) |
---|
449 | (let* ((def (fboundp thing))) |
---|
450 | (if def |
---|
451 | (%put-documentation def t doc-string))) |
---|
452 | (if (setf-function-name-p thing) |
---|
453 | (%set-documentation |
---|
454 | (setf-function-name thing) doc-id doc-string))))) |
---|
455 | (variable |
---|
456 | (if (typep thing 'symbol) |
---|
457 | (%put-documentation thing doc-id doc-string))) |
---|
458 | (t (%put-documentation thing doc-id doc-string))) |
---|
459 | doc-string) |
---|
460 | |
---|
461 | |
---|
462 | (%fhave 'set-documentation #'%set-documentation) |
---|
463 | |
---|
464 | |
---|
465 | |
---|
466 | ;;; This is intended for use by debugging tools. It's a horrible thing |
---|
467 | ;;; to do otherwise. The caller really needs to hold the heap-segment |
---|
468 | ;;; lock; this grabs the tcr queue lock as well. |
---|
469 | (defun %suspend-other-threads () |
---|
470 | (ff-call (%kernel-import target::kernel-import-suspend-other-threads) |
---|
471 | :void)) |
---|
472 | |
---|
473 | (defun %resume-other-threads () |
---|
474 | (ff-call (%kernel-import target::kernel-import-resume-other-threads) |
---|
475 | :void)) |
---|
476 | |
---|
477 | (defparameter *spin-lock-tries* 1) |
---|
478 | |
---|
479 | (defun %get-spin-lock (p) |
---|
480 | (let* ((self (%current-tcr)) |
---|
481 | (n *spin-lock-tries*)) |
---|
482 | (declare (fixnum n)) |
---|
483 | (loop |
---|
484 | (dotimes (i n) |
---|
485 | (when (eql 0 (%ptr-store-fixnum-conditional p 0 self)) |
---|
486 | (return-from %get-spin-lock t))) |
---|
487 | (yield)))) |
---|
488 | |
---|
489 | (defun %lock-recursive-lock (lock &optional flag) |
---|
490 | (with-macptrs ((p) |
---|
491 | (owner (%get-ptr lock target::lockptr.owner)) |
---|
492 | (signal (%get-ptr lock target::lockptr.signal)) |
---|
493 | (spin (%inc-ptr lock target::lockptr.spinlock))) |
---|
494 | (%setf-macptr-to-object p (%current-tcr)) |
---|
495 | (if (istruct-typep flag 'lock-acquisition) |
---|
496 | (setf (lock-acquisition.status flag) nil) |
---|
497 | (if flag (report-bad-arg flag 'lock-acquisition))) |
---|
498 | (loop |
---|
499 | (without-interrupts |
---|
500 | (when (eql p owner) |
---|
501 | (incf (%get-natural lock target::lockptr.count)) |
---|
502 | (when flag |
---|
503 | (setf (lock-acquisition.status flag) t)) |
---|
504 | (return t)) |
---|
505 | (%get-spin-lock spin) |
---|
506 | (when (eql 1 (incf (%get-natural lock target::lockptr.avail))) |
---|
507 | (setf (%get-ptr lock target::lockptr.owner) p |
---|
508 | (%get-natural lock target::lockptr.count) 1) |
---|
509 | (setf (%get-natural spin 0) 0) |
---|
510 | (if flag |
---|
511 | (setf (lock-acquisition.status flag) t)) |
---|
512 | (return t)) |
---|
513 | (setf (%get-natural spin 0) 0)) |
---|
514 | (%process-wait-on-semaphore-ptr signal 1 0 "waiting for lock")))) |
---|
515 | |
---|
516 | |
---|
517 | ;;; Locking the exception lock to inhibit GC (from other threads) |
---|
518 | ;;; is probably a bad idea, though it does simplify some issues. |
---|
519 | ;;; (One bad consequence is that it means that only one hash table |
---|
520 | ;;; can be accessed at a time.) |
---|
521 | #+bad-idea |
---|
522 | (defun %lock-gc-lock () |
---|
523 | (with-macptrs ((lock)) |
---|
524 | (%get-kernel-global-ptr exception-lock lock) |
---|
525 | (%lock-recursive-lock lock))) |
---|
526 | |
---|
527 | #+bad-idea |
---|
528 | (defun %unlock-gc-lock () |
---|
529 | (with-macptrs ((lock)) |
---|
530 | (%get-kernel-global-ptr exception-lock lock) |
---|
531 | (%unlock-recursive-lock lock))) |
---|
532 | |
---|
533 | (defun %try-recursive-lock (lock &optional flag) |
---|
534 | (with-macptrs ((p) |
---|
535 | (owner (%get-ptr lock target::lockptr.owner)) |
---|
536 | (spin (%inc-ptr lock target::lockptr.spinlock))) |
---|
537 | (%setf-macptr-to-object p (%current-tcr)) |
---|
538 | (if flag |
---|
539 | (if (istruct-typep flag 'lock-acquisition) |
---|
540 | (setf (lock-acquisition.status flag) nil) |
---|
541 | (report-bad-arg flag 'lock-acquisition))) |
---|
542 | (without-interrupts |
---|
543 | (cond ((eql p owner) |
---|
544 | (incf (%get-natural lock target::lockptr.count)) |
---|
545 | (if flag (setf (lock-acquisition.status flag) t)) |
---|
546 | t) |
---|
547 | (t |
---|
548 | (let* ((win nil)) |
---|
549 | (%get-spin-lock spin) |
---|
550 | (when (setq win (eql 1 (incf (%get-natural lock target::lockptr.avail)))) |
---|
551 | (setf (%get-ptr lock target::lockptr.owner) p |
---|
552 | (%get-natural lock target::lockptr.count) 1) |
---|
553 | (if flag (setf (lock-acquisition.status flag) t))) |
---|
554 | (setf (%get-ptr spin) (%null-ptr)) |
---|
555 | win)))))) |
---|
556 | |
---|
557 | |
---|
558 | (defun %unlock-recursive-lock (lock) |
---|
559 | (with-macptrs ((signal (%get-ptr lock target::lockptr.signal)) |
---|
560 | (spin (%inc-ptr lock target::lockptr.spinlock))) |
---|
561 | (unless (eql (%get-object lock target::lockptr.owner) (%current-tcr)) |
---|
562 | (error 'not-lock-owner :lock lock)) |
---|
563 | (without-interrupts |
---|
564 | (when (eql 0 (decf (the fixnum |
---|
565 | (%get-natural lock target::lockptr.count)))) |
---|
566 | (%get-spin-lock spin) |
---|
567 | (setf (%get-ptr lock target::lockptr.owner) (%null-ptr)) |
---|
568 | (let* ((pending (+ (the fixnum |
---|
569 | (1- (the fixnum (%get-fixnum lock target::lockptr.avail)))) |
---|
570 | (the fixnum (%get-fixnum lock target::lockptr.waiting))))) |
---|
571 | (declare (fixnum pending)) |
---|
572 | (setf (%get-natural lock target::lockptr.avail) 0 |
---|
573 | (%get-natural lock target::lockptr.waiting) 0) |
---|
574 | (decf pending) |
---|
575 | (if (> pending 0) |
---|
576 | (setf (%get-natural lock target::lockptr.waiting) pending)) |
---|
577 | (setf (%get-ptr spin) (%null-ptr)) |
---|
578 | (if (>= pending 0) |
---|
579 | (%signal-semaphore-ptr signal)))))) |
---|
580 | nil) |
---|
581 | |
---|
582 | |
---|
583 | (defun %%lock-owner (lock) |
---|
584 | "Intended for debugging only; ownership may change while this code |
---|
585 | is running." |
---|
586 | (let* ((tcr (%get-object (recursive-lock-ptr lock) target::lockptr.owner))) |
---|
587 | (unless (zerop tcr) |
---|
588 | (tcr->process tcr)))) |
---|
589 | |
---|
590 | |
---|
591 | |
---|
592 | (defun %suspend-tcr (tcr) |
---|
593 | (with-macptrs (tcrp) |
---|
594 | (%setf-macptr-to-object tcrp tcr) |
---|
595 | (not (zerop (the fixnum |
---|
596 | (ff-call (%kernel-import target::kernel-import-suspend-tcr) |
---|
597 | :address tcrp |
---|
598 | :unsigned-fullword)))))) |
---|
599 | |
---|
600 | (defun %resume-tcr (tcr) |
---|
601 | (with-macptrs (tcrp) |
---|
602 | (%setf-macptr-to-object tcrp tcr) |
---|
603 | (not (zerop (the fixnum |
---|
604 | (ff-call (%kernel-import target::kernel-import-resume-tcr) |
---|
605 | :address tcrp |
---|
606 | :unsigned-fullword)))))) |
---|
607 | |
---|
608 | |
---|
609 | |
---|
610 | (defun %rplaca-conditional (cons-cell old new) |
---|
611 | (%store-node-conditional target::cons.car cons-cell old new)) |
---|
612 | |
---|
613 | (defun %rplacd-conditional (cons-cell old new) |
---|
614 | (%store-node-conditional target::cons.cdr cons-cell old new)) |
---|
615 | |
---|
616 | ;;; Atomically push NEW onto the list in the I'th cell of uvector V. |
---|
617 | |
---|
618 | (defun atomic-push-uvector-cell (v i new) |
---|
619 | (let* ((cell (cons new nil)) |
---|
620 | (offset (+ target::misc-data-offset (ash i target::word-shift)))) |
---|
621 | (loop |
---|
622 | (let* ((old (%svref v i))) |
---|
623 | (rplacd cell old) |
---|
624 | (when (%store-node-conditional offset v old cell) |
---|
625 | (return cell)))))) |
---|
626 | |
---|
627 | (defun store-gvector-conditional (index gvector old new) |
---|
628 | (%store-node-conditional (+ target::misc-data-offset |
---|
629 | (ash index target::word-shift)) |
---|
630 | gvector |
---|
631 | old |
---|
632 | new)) |
---|
633 | |
---|
634 | (defun %atomic-incf-car (cell &optional (by 1)) |
---|
635 | (%atomic-incf-node (require-type by 'fixnum) |
---|
636 | (require-type cell 'cons) |
---|
637 | target::cons.car)) |
---|
638 | |
---|
639 | (defun %atomic-incf-cdr (cell &optional (by 1)) |
---|
640 | (%atomic-incf-node (require-type by 'fixnum) |
---|
641 | (require-type cell 'cons) |
---|
642 | target::cons.cdr)) |
---|
643 | |
---|
644 | (defun %atomic-incf-gvector (v i &optional (by 1)) |
---|
645 | (setq v (require-type v 'gvector)) |
---|
646 | (setq i (require-type i 'fixnum)) |
---|
647 | (%atomic-incf-node by v (+ target::misc-data-offset (ash i target::word-shift)))) |
---|
648 | |
---|
649 | (defun %atomic-incf-symbol-value (s &optional (by 1)) |
---|
650 | (setq s (require-type s 'symbol)) |
---|
651 | (multiple-value-bind (base offset) (%symbol-binding-address s) |
---|
652 | (%atomic-incf-node by base offset))) |
---|
653 | |
---|
654 | ;;; What happens if there are some pending readers and another writer, |
---|
655 | ;;; and we abort out of the semaphore wait ? If the writer semaphore is |
---|
656 | ;;; signaled before we abandon interest in it |
---|
657 | (defun %write-lock-rwlock-ptr (ptr &optional flag) |
---|
658 | (with-macptrs ((write-signal (%get-ptr ptr target::rwlock.writer-signal)) ) |
---|
659 | (if (istruct-typep flag 'lock-acquisition) |
---|
660 | (setf (lock-acquisition.status flag) nil) |
---|
661 | (if flag (report-bad-arg flag 'lock-acquisition))) |
---|
662 | (let* ((level *interrupt-level*) |
---|
663 | (tcr (%current-tcr))) |
---|
664 | (declare (fixnum tcr)) |
---|
665 | (without-interrupts |
---|
666 | (%get-spin-lock ptr) ;(%get-spin-lock (%inc-ptr ptr target::rwlock.spin)) |
---|
667 | (if (eq (%get-object ptr target::rwlock.writer) tcr) |
---|
668 | (progn |
---|
669 | (incf (%get-signed-natural ptr target::rwlock.state)) |
---|
670 | (setf (%get-natural ptr target::rwlock.spin) 0) |
---|
671 | (if flag |
---|
672 | (setf (lock-acquisition.status flag) t)) |
---|
673 | t) |
---|
674 | (do* () |
---|
675 | ((eql 0 (%get-signed-natural ptr target::rwlock.state)) |
---|
676 | ;; That wasn't so bad, was it ? We have the spinlock now. |
---|
677 | (setf (%get-signed-natural ptr target::rwlock.state) 1 |
---|
678 | (%get-natural ptr target::rwlock.spin) 0) |
---|
679 | (%set-object ptr target::rwlock.writer tcr) |
---|
680 | (if flag |
---|
681 | (setf (lock-acquisition.status flag) t)) |
---|
682 | t) |
---|
683 | (incf (%get-natural ptr target::rwlock.blocked-writers)) |
---|
684 | (setf (%get-natural ptr target::rwlock.spin) 0) |
---|
685 | (let* ((*interrupt-level* level)) |
---|
686 | (%process-wait-on-semaphore-ptr write-signal 1 0 "write lock wait")) |
---|
687 | (%get-spin-lock ptr))))))) |
---|
688 | |
---|
689 | (defun write-lock-rwlock (lock &optional flag) |
---|
690 | (%write-lock-rwlock-ptr (read-write-lock-ptr lock) flag)) |
---|
691 | |
---|
692 | (defun %read-lock-rwlock-ptr (ptr lock &optional flag) |
---|
693 | (with-macptrs ((read-signal (%get-ptr ptr target::rwlock.reader-signal))) |
---|
694 | (if (istruct-typep flag 'lock-acquisition) |
---|
695 | (setf (lock-acquisition.status flag) nil) |
---|
696 | (if flag (report-bad-arg flag 'lock-acquisition))) |
---|
697 | (let* ((level *interrupt-level*) |
---|
698 | (tcr (%current-tcr))) |
---|
699 | (declare (fixnum tcr)) |
---|
700 | (without-interrupts |
---|
701 | (%get-spin-lock ptr) ;(%get-spin-lock (%inc-ptr ptr target::rwlock.spin)) |
---|
702 | (if (eq (%get-object ptr target::rwlock.writer) tcr) |
---|
703 | (progn |
---|
704 | (setf (%get-natural ptr target::rwlock.spin) 0) |
---|
705 | (error 'deadlock :lock lock)) |
---|
706 | (do* ((state |
---|
707 | (%get-signed-natural ptr target::rwlock.state) |
---|
708 | (%get-signed-natural ptr target::rwlock.state))) |
---|
709 | ((<= state 0) |
---|
710 | ;; That wasn't so bad, was it ? We have the spinlock now. |
---|
711 | (setf (%get-signed-natural ptr target::rwlock.state) |
---|
712 | (the fixnum (1- state)) |
---|
713 | (%get-natural ptr target::rwlock.spin) 0) |
---|
714 | (if flag |
---|
715 | (setf (lock-acquisition.status flag) t)) |
---|
716 | t) |
---|
717 | (declare (fixnum state)) |
---|
718 | (incf (%get-natural ptr target::rwlock.blocked-readers)) |
---|
719 | (setf (%get-natural ptr target::rwlock.spin) 0) |
---|
720 | (let* ((*interrupt-level* level)) |
---|
721 | (%process-wait-on-semaphore-ptr read-signal 1 0 "read lock wait")) |
---|
722 | (%get-spin-lock ptr))))))) |
---|
723 | |
---|
724 | (defun read-lock-rwlock (lock &optional flag) |
---|
725 | (%read-lock-rwlock-ptr (read-write-lock-ptr lock) lock flag)) |
---|
726 | |
---|
727 | ;;; If the current thread already owns the lock for writing, increment |
---|
728 | ;;; the lock's state. Otherwise, try to lock the lock for reading. |
---|
729 | (defun %ensure-at-least-read-locked (lock &optional flag) |
---|
730 | (if (istruct-typep flag 'lock-acquisition) |
---|
731 | (setf (lock-acquisition.status flag) nil) |
---|
732 | (if flag (report-bad-arg flag 'lock-acquisition))) |
---|
733 | (let* ((ptr (read-write-lock-ptr lock)) |
---|
734 | (tcr (%current-tcr))) |
---|
735 | (declare (fixnum tcr)) |
---|
736 | (or |
---|
737 | (without-interrupts |
---|
738 | (%get-spin-lock ptr) |
---|
739 | (let* ((state (%get-signed-natural ptr target::rwlock.state))) |
---|
740 | (declare (fixnum state)) |
---|
741 | (let ((win |
---|
742 | (cond ((<= state 0) |
---|
743 | (setf (%get-signed-natural ptr target::rwlock.state) |
---|
744 | (the fixnum (1- state))) |
---|
745 | t) |
---|
746 | ((%ptr-eql (%get-ptr ptr target::rwlock.writer) tcr) |
---|
747 | (setf (%get-signed-natural ptr target::rwlock.state) |
---|
748 | (the fixnum (1+ state))) |
---|
749 | t)))) |
---|
750 | (setf (%get-natural ptr target::rwlock.spin) 0) |
---|
751 | (when win |
---|
752 | (if flag |
---|
753 | (setf (lock-acquisition.status flag) t)) |
---|
754 | t)))) |
---|
755 | (%read-lock-rwlock-ptr ptr lock flag)))) |
---|
756 | |
---|
757 | (defun %unlock-rwlock-ptr (ptr lock) |
---|
758 | (with-macptrs ((reader-signal (%get-ptr ptr target::rwlock.reader-signal)) |
---|
759 | (writer-signal (%get-ptr ptr target::rwlock.writer-signal))) |
---|
760 | (without-interrupts |
---|
761 | (%get-spin-lock ptr) |
---|
762 | (let* ((state (%get-signed-natural ptr target::rwlock.state)) |
---|
763 | (tcr (%current-tcr))) |
---|
764 | (declare (fixnum state tcr)) |
---|
765 | (cond ((> state 0) |
---|
766 | (unless (eql tcr (%get-object ptr target::rwlock.writer)) |
---|
767 | (setf (%get-natural ptr target::rwlock.spin) 0) |
---|
768 | (error 'not-lock-owner :lock lock)) |
---|
769 | (decf state)) |
---|
770 | ((< state 0) (incf state)) |
---|
771 | (t (setf (%get-natural ptr target::rwlock.spin) 0) |
---|
772 | (error 'not-locked :lock lock))) |
---|
773 | (setf (%get-signed-natural ptr target::rwlock.state) state) |
---|
774 | (when (zerop state) |
---|
775 | ;; We want any thread waiting for a lock semaphore to |
---|
776 | ;; be able to wait interruptibly. When a thread waits, |
---|
777 | ;; it increments either the "blocked-readers" or "blocked-writers" |
---|
778 | ;; field, but since it may get interrupted before obtaining |
---|
779 | ;; the semaphore that's more of "an expression of interest" |
---|
780 | ;; in taking the lock than it is "a firm commitment to take it." |
---|
781 | ;; It's generally (much) better to signal the semaphore(s) |
---|
782 | ;; too often than it would be to not signal them often |
---|
783 | ;; enough; spurious wakeups are better than deadlock. |
---|
784 | ;; So: if there are blocked writers, the writer-signal |
---|
785 | ;; is raised once for each apparent blocked writer. (At most |
---|
786 | ;; one writer will actually succeed in taking the lock.) |
---|
787 | ;; If there are blocked readers, the reader-signal is raised |
---|
788 | ;; once for each of them. (It's possible for both the |
---|
789 | ;; reader and writer semaphores to be raised on the same |
---|
790 | ;; unlock; the writer semaphore is raised first, so in that |
---|
791 | ;; sense, writers still have priority but it's not guaranteed.) |
---|
792 | ;; Both the "blocked-writers" and "blocked-readers" fields |
---|
793 | ;; are cleared here (they can't be changed from another thread |
---|
794 | ;; until this thread releases the spinlock.) |
---|
795 | (setf (%get-signed-natural ptr target::rwlock.writer) 0) |
---|
796 | (let* ((nwriters (%get-natural ptr target::rwlock.blocked-writers)) |
---|
797 | (nreaders (%get-natural ptr target::rwlock.blocked-readers))) |
---|
798 | (declare (fixnum nreaders nwriters)) |
---|
799 | (when (> nwriters 0) |
---|
800 | (setf (%get-natural ptr target::rwlock.blocked-writers) 0) |
---|
801 | (dotimes (i nwriters) |
---|
802 | (%signal-semaphore-ptr writer-signal))) |
---|
803 | (when (> nreaders 0) |
---|
804 | (setf (%get-natural ptr target::rwlock.blocked-readers) 0) |
---|
805 | (dotimes (i nreaders) |
---|
806 | (%signal-semaphore-ptr reader-signal))))) |
---|
807 | (setf (%get-natural ptr target::rwlock.spin) 0) |
---|
808 | t)))) |
---|
809 | |
---|
810 | (defun unlock-rwlock (lock) |
---|
811 | (%unlock-rwlock-ptr (read-write-lock-ptr lock) lock)) |
---|
812 | |
---|
813 | ;;; There are all kinds of ways to lose here. |
---|
814 | ;;; The caller must have read access to the lock exactly once, |
---|
815 | ;;; or have write access. |
---|
816 | ;;; there's currently no way to detect whether the caller has |
---|
817 | ;;; read access at all. |
---|
818 | ;;; If we have to block and get interrupted, cleanup code may |
---|
819 | ;;; try to unlock a lock that we don't hold. (It might be possible |
---|
820 | ;;; to circumvent that if we use the same notifcation object here |
---|
821 | ;;; that controls that cleanup process.) |
---|
822 | |
---|
823 | (defun %promote-rwlock (lock &optional flag) |
---|
824 | (let* ((ptr (read-write-lock-ptr lock))) |
---|
825 | (if (istruct-typep flag 'lock-acquisition) |
---|
826 | (setf (lock-acquisition.status flag) nil) |
---|
827 | (if flag (report-bad-arg flag 'lock-acquisition))) |
---|
828 | (let* ((level *interrupt-level*) |
---|
829 | (tcr (%current-tcr))) |
---|
830 | (without-interrupts |
---|
831 | (%get-spin-lock ptr) |
---|
832 | (let* ((state (%get-signed-natural ptr target::rwlock.state))) |
---|
833 | (declare (fixnum state)) |
---|
834 | (cond ((> state 0) |
---|
835 | (unless (eql (%get-object ptr target::tcr.writer) tcr) |
---|
836 | (setf (%get-natural ptr target::rwlock.spin) 0) |
---|
837 | (error :not-lock-owner :lock lock))) |
---|
838 | ((= state 0) |
---|
839 | (setf (%get-natural ptr target::rwlock.spin) 0) |
---|
840 | (error :not-locked :lock lock)) |
---|
841 | (t |
---|
842 | (if (= state -1) |
---|
843 | (progn |
---|
844 | (setf (%get-signed-natural ptr target::rwlock.state) 1 |
---|
845 | (%get-natural ptr target::rwlock.spin) 0) |
---|
846 | (%set-object ptr target::rwlock.writer tcr) |
---|
847 | (if flag |
---|
848 | (setf (lock-acquisition.status flag) t)) |
---|
849 | t) |
---|
850 | (progn |
---|
851 | (%unlock-rwlock-ptr ptr lock) |
---|
852 | (let* ((*interrupt-level* level)) |
---|
853 | (%write-lock-rwlock-ptr ptr flag))))))))))) |
---|
854 | |
---|
855 | |
---|
856 | |
---|
857 | |
---|
858 | |
---|
859 | |
---|
860 | |
---|
861 | (defun safe-get-ptr (p &optional dest) |
---|
862 | (if (null dest) |
---|
863 | (setq dest (%null-ptr)) |
---|
864 | (unless (typep dest 'macptr) |
---|
865 | (check-type dest macptr))) |
---|
866 | (without-interrupts ;reentrancy |
---|
867 | (%safe-get-ptr p dest))) |
---|