source: branches/new-random/level-0/l0-misc.lisp @ 14546

Last change on this file since 14546 was 13279, checked in by gb, 10 years ago

Lots of changes from "purify" branch, mostly involving:

  • new memory layout, to support x86 function purification, static cons
  • fasloader changes to load/save string constants faster

Fasl version, image version changed; new binaries for all platforms soon.

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