source: branches/working-0709/ccl/level-0/l0-misc.lisp @ 7196

Last change on this file since 7196 was 7196, checked in by gb, 13 years ago

New READ-WRITE-LOCK stuff.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 29.1 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
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 (lock &optional flag)
658  (with-macptrs (tcr
659                 (write-signal (%get-ptr lock target::rwlock.writer-signal)))
660    (%setf-macptr-to-object tcr (%current-tcr))
661    (if (istruct-typep flag 'lock-acquisition)
662      (setf (lock-acquisition.status flag) nil)
663      (if flag (report-bad-arg flag 'lock-acquisition)))
664    (let* ((level *interrupt-level*))
665      (without-interrupts
666       (%get-spin-lock lock)               ;(%get-spin-lock (%inc-ptr lock target::rwlock.spin))
667       (if (%ptr-eql (%get-ptr lock target::rwlock.writer) tcr)
668         (progn
669           (incf (%get-signed-natural lock target::rwlock.state))
670           (setf (%get-natural lock target::rwlock.spin) 0)
671           (if flag
672             (setf (lock-acquisition.status flag) t))
673           t)
674         (do* ()
675              ((eql 0 (%get-signed-natural lock target::rwlock.state))
676               ;; That wasn't so bad, was it ?  We have the spinlock now.
677               (setf (%get-signed-natural lock target::rwlock.state) 1
678                     (%get-ptr lock target::rwlock.writer) tcr
679                     (%get-natural lock target::rwlock.spin) 0)
680               (if flag
681                 (setf (lock-acquisition.status flag) t))
682               t)
683           (incf (%get-natural lock target::rwlock.blocked-writers))
684           (setf (%get-natural lock 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 lock)))))))
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 (tcr
694                 (read-signal (%get-ptr ptr target::rwlock.reader-signal)))
695    (%setf-macptr-to-object tcr (%current-tcr))
696    (if (istruct-typep flag 'lock-acquisition)
697      (setf (lock-acquisition.status flag) nil)
698      (if flag (report-bad-arg flag 'lock-acquisition)))
699    (let* ((level *interrupt-level*))
700      (without-interrupts
701       (%get-spin-lock ptr)             ;(%get-spin-lock (%inc-ptr ptr target::rwlock.spin))
702       (if (%ptr-eql (%get-ptr 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
728(defun %unlock-rwlock-ptr (ptr lock)
729  (with-macptrs (tcr
730                 (reader-signal (%get-ptr ptr target::rwlock.reader-signal))
731                 (writer-signal (%get-ptr ptr target::rwlock.writer-signal)))
732    (%setf-macptr-to-object tcr (%current-tcr))
733    (without-interrupts
734     (%get-spin-lock ptr)
735     (let* ((state (%get-signed-natural ptr target::rwlock.state)))
736       (declare (fixnum state))
737       (cond ((> state 0)
738              (unless (%ptr-eql tcr (%get-ptr ptr target::rwlock.writer))
739                (format t "~& state = ~s" state)
740                (setf (%get-natural ptr target::rwlock.spin) 0)
741                (error 'not-lock :lock lock))
742              (decf state))
743             ((< state 0) (incf state))
744             (t (setf (%get-natural ptr target::rwlock.spin) 0)
745                (error 'not-lock-owner :lock lock)))
746       (setf (%get-signed-natural ptr target::rwlock.state) state)
747       (when (zerop state)
748         ;; We want any thread waiting for a lock semaphore to
749         ;; be able to wait interruptibly.  When a thread waits,
750         ;; it increments either the "blocked-readers" or "blocked-writers"
751         ;; field, but since it may get interrupted before obtaining
752         ;; the semaphore that's more of "an expression of interest"
753         ;; in taking the lock than it is "a firm commitment to take it."
754         ;; It's generally (much) better to signal the semaphore(s)
755         ;; too often than it would be to not signal them often
756         ;; enough; spurious wakeups are better than deadlock.
757         ;; So: if there are blocked writers, the writer-signal
758         ;; is raised once for each apparent blocked writer.  (At most
759         ;; one writer will actually succeed in taking the lock.)
760         ;; If there are blocked readers, the reader-signal is raised
761         ;; once for each of them.  (It's possible for both the
762         ;; reader and writer semaphores to be raised on the same
763         ;; unlock; the writer semaphore is raised first, so in that
764         ;; sense, writers still have priority but it's not guaranteed.)
765         ;; Both the "blocked-writers" and "blocked-readers" fields
766         ;; are cleared here (they can't be changed from another thread
767         ;; until this thread releases the spinlock.)
768         (setf (%get-signed-natural ptr target::rwlock.writer) 0)
769         (let* ((nwriters (%get-natural ptr target::rwlock.blocked-writers))
770                (nreaders (%get-natural ptr target::rwlock.blocked-readers)))
771           (declare (fixnum nreaders nwriters))
772           (when (> nwriters 0)
773             (setf (%get-natural ptr target::rwlock.blocked-writers) 0)
774             (dotimes (i nwriters)
775               (%signal-semaphore-ptr writer-signal)))
776           (when (> nreaders 0)
777             (setf (%get-natural ptr target::rwlock.blocked-readers) 0)
778             (dotimes (i nreaders)
779               (%signal-semaphore-ptr reader-signal)))))
780       (setf (%get-natural ptr target::rwlock.spin) 0)
781       t))))
782
783(defun unlock-rwlock (lock)
784  (%unlock-rwlock-ptr (read-write-lock-ptr lock) lock))
785
786
787(defun safe-get-ptr (p &optional dest)
788  (if (null dest)
789    (setq dest (%null-ptr))
790    (unless (typep dest 'macptr)
791      (check-type dest macptr)))
792  (without-interrupts                   ;reentrancy
793   (%safe-get-ptr p dest)))
Note: See TracBrowser for help on using the repository browser.