source: branches/working-0711/ccl/level-0/l0-misc.lisp @ 11962

Last change on this file since 11962 was 11962, checked in by gb, 11 years ago

Do %FREEBYTES without walking the aread list.
Harder to do %USEDBYTES without the walk, so grab the kernel exception
and area locks around the walk.
This stuff isn't intended to be user-callable, and children shouldn't
play with sharp objects.

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