source: trunk/source/level-0/l0-misc.lisp

Last change on this file was 16685, checked in by rme, 3 years ago

Update copyright/license headers in files.

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