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

Last change on this file since 11089 was 11089, checked in by gz, 13 years ago

Merge/bootstrap assorted low level stuff from trunk - kernel, syscall stuff, lowmem-bias, formatting tweaks, a few bug fixes included

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