source: branches/working-0710/ccl/level-0/l0-misc.lisp @ 7394

Last change on this file since 7394 was 7394, checked in by gb, 12 years ago

frozen-dnodes changes for ROOM et al, new rwlock stuff.

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