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 | (with-other-threads-suspended |
---|
278 | (without-gcing |
---|
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 | ;;; This is mostly here so we can bootstrap shared libs without |
---|
393 | ;;; having to bootstrap #_strcmp. |
---|
394 | ;;; Return true if the cstrings are equal, false otherwise. |
---|
395 | (defun %cstrcmp (x y) |
---|
396 | (do* ((i 0 (1+ i)) |
---|
397 | (bx (%get-byte x i) (%get-byte x i)) |
---|
398 | (by (%get-byte y i) (%get-byte y i))) |
---|
399 | ((not (= bx by))) |
---|
400 | (declare (fixnum i bx by)) |
---|
401 | (when (zerop bx) |
---|
402 | (return t)))) |
---|
403 | |
---|
404 | (defvar %documentation nil) |
---|
405 | |
---|
406 | (defvar %documentation-lock% nil) |
---|
407 | |
---|
408 | (setq %documentation |
---|
409 | (make-hash-table :weak t :size 100 :test 'eq :rehash-threshold .95) |
---|
410 | %documentation-lock% (make-lock)) |
---|
411 | |
---|
412 | (defun %put-documentation (thing doc-id doc) |
---|
413 | (with-lock-grabbed (%documentation-lock%) |
---|
414 | (let* ((info (gethash thing %documentation)) |
---|
415 | (pair (assoc doc-id info))) |
---|
416 | (if doc |
---|
417 | (progn |
---|
418 | (unless (typep doc 'string) |
---|
419 | (report-bad-arg doc 'string)) |
---|
420 | (if pair |
---|
421 | (setf (cdr pair) doc) |
---|
422 | (setf (gethash thing %documentation) (cons (cons doc-id doc) info)))) |
---|
423 | (when pair |
---|
424 | (if (setq info (nremove pair info)) |
---|
425 | (setf (gethash thing %documentation) info) |
---|
426 | (remhash thing %documentation)))))) |
---|
427 | doc) |
---|
428 | |
---|
429 | (defun %get-documentation (object doc-id) |
---|
430 | (cdr (assoc doc-id (gethash object %documentation)))) |
---|
431 | |
---|
432 | ;;; This pretends to be (SETF DOCUMENTATION), until that generic function |
---|
433 | ;;; is defined. It handles a few common cases. |
---|
434 | (defun %set-documentation (thing doc-id doc-string) |
---|
435 | (case doc-id |
---|
436 | (function |
---|
437 | (if (typep thing 'function) |
---|
438 | (%put-documentation thing t doc-string) |
---|
439 | (if (typep thing 'symbol) |
---|
440 | (let* ((def (fboundp thing))) |
---|
441 | (if def |
---|
442 | (%put-documentation def t doc-string))) |
---|
443 | (if (setf-function-name-p thing) |
---|
444 | (%set-documentation |
---|
445 | (setf-function-name thing) doc-id doc-string))))) |
---|
446 | (variable |
---|
447 | (if (typep thing 'symbol) |
---|
448 | (%put-documentation thing doc-id doc-string))) |
---|
449 | (t (%put-documentation thing doc-id doc-string))) |
---|
450 | doc-string) |
---|
451 | |
---|
452 | |
---|
453 | (%fhave 'set-documentation #'%set-documentation) |
---|
454 | |
---|
455 | |
---|
456 | |
---|
457 | ;;; This is intended for use by debugging tools. It's a horrible thing |
---|
458 | ;;; to do otherwise. The caller really needs to hold the heap-segment |
---|
459 | ;;; lock; this grabs the tcr queue lock as well. |
---|
460 | (defun %suspend-other-threads () |
---|
461 | (ff-call (%kernel-import target::kernel-import-suspend-other-threads) |
---|
462 | :void)) |
---|
463 | |
---|
464 | (defun %resume-other-threads () |
---|
465 | (ff-call (%kernel-import target::kernel-import-resume-other-threads) |
---|
466 | :void)) |
---|
467 | |
---|
468 | (defparameter *spin-lock-tries* 1) |
---|
469 | |
---|
470 | (defun %get-spin-lock (p) |
---|
471 | (let* ((self (%current-tcr)) |
---|
472 | (n *spin-lock-tries*)) |
---|
473 | (declare (fixnum n)) |
---|
474 | (loop |
---|
475 | (dotimes (i n) |
---|
476 | (when (eql 0 (%ptr-store-fixnum-conditional p 0 self)) |
---|
477 | (return-from %get-spin-lock t))) |
---|
478 | (yield)))) |
---|
479 | |
---|
480 | (defun %lock-recursive-lock (lock &optional flag) |
---|
481 | (with-macptrs ((p) |
---|
482 | (owner (%get-ptr lock target::lockptr.owner)) |
---|
483 | (signal (%get-ptr lock target::lockptr.signal)) |
---|
484 | (spin (%inc-ptr lock target::lockptr.spinlock))) |
---|
485 | (%setf-macptr-to-object p (%current-tcr)) |
---|
486 | (if (istruct-typep flag 'lock-acquisition) |
---|
487 | (setf (lock-acquisition.status flag) nil) |
---|
488 | (if flag (report-bad-arg flag 'lock-acquisition))) |
---|
489 | (loop |
---|
490 | (without-interrupts |
---|
491 | (when (eql p owner) |
---|
492 | (incf (%get-natural lock target::lockptr.count)) |
---|
493 | (when flag |
---|
494 | (setf (lock-acquisition.status flag) t)) |
---|
495 | (return t)) |
---|
496 | (%get-spin-lock spin) |
---|
497 | (when (eql 1 (incf (%get-natural lock target::lockptr.avail))) |
---|
498 | (setf (%get-ptr lock target::lockptr.owner) p |
---|
499 | (%get-natural lock target::lockptr.count) 1) |
---|
500 | (setf (%get-natural spin 0) 0) |
---|
501 | (if flag |
---|
502 | (setf (lock-acquisition.status flag) t)) |
---|
503 | (return t)) |
---|
504 | (setf (%get-natural spin 0) 0)) |
---|
505 | (%process-wait-on-semaphore-ptr signal 1 0 "waiting for lock")))) |
---|
506 | |
---|
507 | |
---|
508 | ;;; Locking the exception lock to inhibit GC (from other threads) |
---|
509 | ;;; is probably a bad idea, though it does simplify some issues. |
---|
510 | ;;; (One bad consequence is that it means that only one hash table |
---|
511 | ;;; can be accessed at a time.) |
---|
512 | #+bad-idea |
---|
513 | (defun %lock-gc-lock () |
---|
514 | (with-macptrs ((lock)) |
---|
515 | (%get-kernel-global-ptr exception-lock lock) |
---|
516 | (%lock-recursive-lock lock))) |
---|
517 | |
---|
518 | #+bad-idea |
---|
519 | (defun %unlock-gc-lock () |
---|
520 | (with-macptrs ((lock)) |
---|
521 | (%get-kernel-global-ptr exception-lock lock) |
---|
522 | (%unlock-recursive-lock lock))) |
---|
523 | |
---|
524 | (defun %try-recursive-lock (lock &optional flag) |
---|
525 | (with-macptrs ((p) |
---|
526 | (owner (%get-ptr lock target::lockptr.owner)) |
---|
527 | (spin (%inc-ptr lock target::lockptr.spinlock))) |
---|
528 | (%setf-macptr-to-object p (%current-tcr)) |
---|
529 | (if flag |
---|
530 | (if (istruct-typep flag 'lock-acquisition) |
---|
531 | (setf (lock-acquisition.status flag) nil) |
---|
532 | (report-bad-arg flag 'lock-acquisition))) |
---|
533 | (without-interrupts |
---|
534 | (cond ((eql p owner) |
---|
535 | (incf (%get-natural lock target::lockptr.count)) |
---|
536 | (if flag (setf (lock-acquisition.status flag) t)) |
---|
537 | t) |
---|
538 | (t |
---|
539 | (let* ((win nil)) |
---|
540 | (%get-spin-lock spin) |
---|
541 | (when (setq win (eql 1 (incf (%get-natural lock target::lockptr.avail)))) |
---|
542 | (setf (%get-ptr lock target::lockptr.owner) p |
---|
543 | (%get-natural lock target::lockptr.count) 1) |
---|
544 | (if flag (setf (lock-acquisition.status flag) t))) |
---|
545 | (setf (%get-ptr spin) (%null-ptr)) |
---|
546 | win)))))) |
---|
547 | |
---|
548 | |
---|
549 | (defun %unlock-recursive-lock (lock) |
---|
550 | (with-macptrs ((signal (%get-ptr lock target::lockptr.signal)) |
---|
551 | (spin (%inc-ptr lock target::lockptr.spinlock))) |
---|
552 | (unless (eql (%get-object lock target::lockptr.owner) (%current-tcr)) |
---|
553 | (error 'not-lock-owner :lock lock)) |
---|
554 | (without-interrupts |
---|
555 | (when (eql 0 (decf (the fixnum |
---|
556 | (%get-natural lock target::lockptr.count)))) |
---|
557 | (%get-spin-lock spin) |
---|
558 | (setf (%get-ptr lock target::lockptr.owner) (%null-ptr)) |
---|
559 | (let* ((pending (+ (the fixnum |
---|
560 | (1- (the fixnum (%get-fixnum lock target::lockptr.avail)))) |
---|
561 | (the fixnum (%get-fixnum lock target::lockptr.waiting))))) |
---|
562 | (declare (fixnum pending)) |
---|
563 | (setf (%get-natural lock target::lockptr.avail) 0 |
---|
564 | (%get-natural lock target::lockptr.waiting) 0) |
---|
565 | (decf pending) |
---|
566 | (if (> pending 0) |
---|
567 | (setf (%get-natural lock target::lockptr.waiting) pending)) |
---|
568 | (setf (%get-ptr spin) (%null-ptr)) |
---|
569 | (if (>= pending 0) |
---|
570 | (%signal-semaphore-ptr signal)))))) |
---|
571 | nil) |
---|
572 | |
---|
573 | |
---|
574 | (defun %%lock-owner (lock) |
---|
575 | "Intended for debugging only; ownership may change while this code |
---|
576 | is running." |
---|
577 | (let* ((tcr (%get-object (recursive-lock-ptr lock) target::lockptr.owner))) |
---|
578 | (unless (zerop tcr) |
---|
579 | (tcr->process tcr)))) |
---|
580 | |
---|
581 | |
---|
582 | |
---|
583 | (defun %suspend-tcr (tcr) |
---|
584 | (with-macptrs (tcrp) |
---|
585 | (%setf-macptr-to-object tcrp tcr) |
---|
586 | (not (zerop (the fixnum |
---|
587 | (ff-call (%kernel-import target::kernel-import-suspend-tcr) |
---|
588 | :address tcrp |
---|
589 | :unsigned-fullword)))))) |
---|
590 | |
---|
591 | (defun %resume-tcr (tcr) |
---|
592 | (with-macptrs (tcrp) |
---|
593 | (%setf-macptr-to-object tcrp tcr) |
---|
594 | (not (zerop (the fixnum |
---|
595 | (ff-call (%kernel-import target::kernel-import-resume-tcr) |
---|
596 | :address tcrp |
---|
597 | :unsigned-fullword)))))) |
---|
598 | |
---|
599 | |
---|
600 | |
---|
601 | (defun %rplaca-conditional (cons-cell old new) |
---|
602 | (%store-node-conditional target::cons.car cons-cell old new)) |
---|
603 | |
---|
604 | (defun %rplacd-conditional (cons-cell old new) |
---|
605 | (%store-node-conditional target::cons.cdr cons-cell old new)) |
---|
606 | |
---|
607 | ;;; Atomically push NEW onto the list in the I'th cell of uvector V. |
---|
608 | |
---|
609 | (defun atomic-push-uvector-cell (v i new) |
---|
610 | (let* ((cell (cons new nil)) |
---|
611 | (offset (+ target::misc-data-offset (ash i target::word-shift)))) |
---|
612 | (loop |
---|
613 | (let* ((old (%svref v i))) |
---|
614 | (rplacd cell old) |
---|
615 | (when (%store-node-conditional offset v old cell) |
---|
616 | (return cell)))))) |
---|
617 | |
---|
618 | (defun store-gvector-conditional (index gvector old new) |
---|
619 | (%store-node-conditional (+ target::misc-data-offset |
---|
620 | (ash index target::word-shift)) |
---|
621 | gvector |
---|
622 | old |
---|
623 | new)) |
---|
624 | |
---|
625 | (defun %atomic-incf-car (cell &optional (by 1)) |
---|
626 | (%atomic-incf-node (require-type by 'fixnum) |
---|
627 | (require-type cell 'cons) |
---|
628 | target::cons.car)) |
---|
629 | |
---|
630 | (defun %atomic-incf-cdr (cell &optional (by 1)) |
---|
631 | (%atomic-incf-node (require-type by 'fixnum) |
---|
632 | (require-type cell 'cons) |
---|
633 | target::cons.cdr)) |
---|
634 | |
---|
635 | (defun %atomic-incf-gvector (v i &optional (by 1)) |
---|
636 | (setq v (require-type v 'gvector)) |
---|
637 | (setq i (require-type i 'fixnum)) |
---|
638 | (%atomic-incf-node by v (+ target::misc-data-offset (ash i target::word-shift)))) |
---|
639 | |
---|
640 | (defun %atomic-incf-symbol-value (s &optional (by 1)) |
---|
641 | (setq s (require-type s 'symbol)) |
---|
642 | (let* ((binding-address (%symbol-binding-address s))) |
---|
643 | (declare (fixnum binding-address)) |
---|
644 | (if (zerop binding-address) |
---|
645 | (%atomic-incf-node by s target::symbol.vcell-cell) |
---|
646 | (%atomic-incf-node by binding-address (* 2 target::node-size))))) |
---|
647 | |
---|
648 | (defun write-lock-rwlock (lock) |
---|
649 | (let* ((context (%current-tcr))) |
---|
650 | (if (eq (%svref lock target::lock.writer-cell) context) |
---|
651 | (progn |
---|
652 | (decf (%svref lock target::lock._value-cell)) |
---|
653 | lock) |
---|
654 | (loop |
---|
655 | (when (%store-immediate-conditional target::lock._value lock 0 -1) |
---|
656 | (setf (%svref lock target::lock.writer-cell) context) |
---|
657 | (return lock)) |
---|
658 | (%nanosleep 0 *ns-per-tick*))))) |
---|
659 | |
---|
660 | |
---|
661 | (defun read-lock-rwlock (lock) |
---|
662 | (loop |
---|
663 | (when (%try-read-lock-rwlock lock) |
---|
664 | (return lock)) |
---|
665 | (%nanosleep 0 *ns-per-tick*))) |
---|
666 | |
---|
667 | (defun safe-get-ptr (p &optional dest) |
---|
668 | (if (null dest) |
---|
669 | (setq dest (%null-ptr)) |
---|
670 | (check-type dest macptr)) |
---|
671 | (without-interrupts ;reentrancy |
---|
672 | (%safe-get-ptr p dest))) |
---|