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

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

New (x86-64) version of %GET-SPING-LOCK; uses PAUSE instruction in the loop.

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