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

Last change on this file since 15606 was 15606, checked in by gb, 7 years ago

This is a work-in-progress; there will need to be new binaries
and similar changes for other architectures.

compiler/nx2.lisp: do late constant-folding on comparisons. (This depends

on being able to use operators for T and NIL in the backend; since backends
don't necessarily support that, check first.)

compiler/optimizers.lisp: bind temporaries for 3-arg numeric comparisons.

compiler/vinsn.lisp: do dead-code elimination at the vinsn level. Because

of the way that "aligned labels" work on x86, introduce an :align vinsn
attribute. Add/change some utilities for finding next/previous vinsn, etc.

compiler/X86/x862.lisp: Handle operators for T/NIL. Peephole optimize

things like (if (let ...)) where the LET returns a constant value and
we need to discard some words from the stack.

compiler/X86/X8632/x8632-arch.lisp:
compiler/X86/X8664/x8664-arch.lisp: Bump image version

compiler/X86/X8632/x8632-vinsns.lisp:
compiler/X86/X8664/x8664-vinsns.lisp: EMIT-ALIGNED-LABEL has :align

attribute

level-0/l0-hash.lisp: Don't assume that GC maintains weak-deletions; do

assume that it maintains count/deleted-count, so lock-based code adjusts
those slots atomically.

level-0/l0-misc.lisp: We don't want to use futexes (at least not instead

of spinlocks.)

level-0/X86/x86-misc.lisp: %ATOMIC-INCF-NODE needs to pause while spinning.

(Note that a locked ADD may be faster on x86, but wouldn't return a
meaningful value and some callers expect it to.)

level-1/l1-clos-boot.lisp: no more DESTRUCTURE-STATE.
level-1/l1-files.lisp: indentation change
level-1/l1-utils.lisp: no more DESTRUCTURE-STATE.
level-1/linux-files.lisp: UNSETENV

lib/hash.lisp: no need to %NORMALIZE-HASH-TABLE-COUNT.
lib/macros.lisp: no more DESTRUCTURE-STATE.

library/lispequ.lisp: no more DESTRUCTURE-STATE.

lisp-kernel/gc-common.c: decrement count when removing weak key from

hash vector; increment deleted-count if not lock-free.

lisp-kernel/x86-constants32.h:
lisp-kernel/x86-constants64.h: bump current, max image versions

lisp-kernel/linuxx8632/Makefile:
lisp-kernel/linuxx8664/Makefile: don't define USE_FUTEX.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 42.8 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 no (or x86-target arm-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 on most platforms, 4 on ARM.
222;;;   sp free
223;;;   sp used
224;;;   vsp free
225;;;   vsp used
226;;;   tsp free  (not on ARM)
227;;;   tsp used  (not on ARM)
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           (cs-area #+(and windows-target x8632-target)
270                    (%fixnum-ref (%fixnum-ref tcr (- target::tcr.aux
271                                                     target::tcr-bias))
272                                 target::tcr-aux.cs-area)
273                    #-(and windows-target x8632-target)
274                    (%fixnum-ref tcr target::tcr.cs-area)))
275      (if (or (null tcr)
276              (zerop (%fixnum-ref cs-area)))
277        (values 0 0 0 0 0 0)
278        (multiple-value-bind (cf cu) (free-and-used cs-area)
279          (multiple-value-bind (vf vu)
280              (free-and-used (%fixnum-ref tcr (- target::tcr.vs-area
281                                                 target::tcr-bias)))
282            #+arm-target
283            (values cf cu vf vu)
284            #-arm-target
285            (multiple-value-bind (tf tu)
286                (free-and-used (%fixnum-ref tcr (- target::tcr.ts-area
287                                                   target::tcr-bias)))
288              (values cf cu vf vu tf tu))))))))
289
290
291(defun room (&optional (verbose :default))
292  "Print to *STANDARD-OUTPUT* information about the state of internal
293  storage and its management. The optional argument controls the
294  verbosity of output. If it is T, ROOM prints out a maximal amount of
295  information. If it is NIL, ROOM prints out a minimal amount of
296  information. If it is :DEFAULT or it is not supplied, ROOM prints out
297  an intermediate amount of information."
298  (let* ((freebytes nil)
299         (usedbytes nil)
300         (static-used nil)
301         (staticlib-used nil)
302         (frozen-space-size nil)
303         (lispheap nil)
304         (reserved nil)
305         (static nil)
306         (stack-total)
307         (stack-used)
308         (stack-free)
309         (static-cons-reserved nil)
310         (stack-used-by-thread nil))
311    (progn
312      (progn
313        (setq freebytes (%freebytes))
314        (when verbose
315          (multiple-value-setq (usedbytes static-used staticlib-used frozen-space-size)
316            (%usedbytes))
317          (setq lispheap (+ freebytes usedbytes)
318                reserved (%reservedbytes)
319                static (+ static-used staticlib-used frozen-space-size))
320          (multiple-value-setq (stack-total stack-used stack-free)
321            (%stack-space))
322          (unless (eq verbose :default)
323            (setq stack-used-by-thread (%stack-space-by-lisp-thread))))))
324    (format t "~&Approximately ~:D bytes of memory can be allocated ~%before the next full GC is triggered. ~%" freebytes)
325    (when verbose
326      (flet ((k (n) (round n 1024)))
327        (princ "
328                   Total Size             Free                 Used")
329        (format t "~&Lisp Heap:~15t~10D (~DK)~35t~10D (~DK)~55t~10D (~DK)"
330                lispheap (k lispheap)
331                freebytes (k freebytes)
332                usedbytes (k usedbytes))
333        (format t "~&Stacks:~15t~10D (~DK)~35t~10D (~DK)~55t~10D (~DK)"
334                stack-total (k stack-total)
335                stack-free (k stack-free)
336                stack-used (k stack-used))
337        (format t "~&Static:~15t~10D (~DK)~35t~10D (~DK)~55t~10D (~DK)"
338                static (k static)
339                0 0
340                static (k static))
341        (when (and frozen-space-size (not (zerop frozen-space-size)))
342          (setq static-cons-reserved (ash (reserved-static-conses) target::dnode-shift)
343                frozen-space-size (- frozen-space-size static-cons-reserved))
344          (unless (zerop static-cons-reserved)
345            (format t "~&~,3f MB of reserved static conses (~d free, ~d reserved)"
346                    (/ static-cons-reserved (float (ash 1 20)))
347                    (free-static-conses)
348                    (reserved-static-conses)))
349
350          (unless (zerop frozen-space-size)
351                  (format t "~&~,3f MB of static memory is \"frozen\" dynamic memory"
352                          (/ frozen-space-size (float (ash 1 20))))))
353        (format t "~&~,3f MB reserved for heap expansion."
354                (/ reserved (float (ash 1 20))))
355        (unless (eq verbose :default)
356          (terpri)
357          (let* ((processes (all-processes)))
358            (dolist (thread-info stack-used-by-thread)
359              (destructuring-bind (thread sp-free sp-used vsp-free vsp-used #-arm-target tsp-free #-arm-target tsp-used)
360                  thread-info
361                (let* ((process (dolist (p processes)
362                                  (when (eq (process-thread p) thread)
363                                    (return p)))))
364                  (when process
365                    (let ((sp-total (+ sp-used sp-free))
366                          (vsp-total (+ vsp-used vsp-free))
367                          #-arm-target
368                          (tsp-total (+ tsp-used tsp-free)))
369                      (format t "~%~a(~d)~%  cstack:~12T~10D (~DK)  ~33T~10D (~DK)  ~54T~10D (~DK)~
370                               ~%  vstack:~12T~10D (~DK)  ~33T~10D (~DK)  ~54T~10D (~DK)"
371                              (process-name process)
372                              (process-serial-number process)
373                              sp-total (k sp-total) sp-free (k sp-free) sp-used (k sp-used)
374                              vsp-total (k vsp-total) vsp-free (k vsp-free) vsp-used  (k vsp-used))
375                      #-arm-target
376                      (format t
377                               "~%  tstack:~12T~10D (~DK)  ~33T~10D (~DK)  ~54T~10D (~DK)"
378
379                              tsp-total (k tsp-total) tsp-free (k tsp-free) tsp-used (k tsp-used)))))))))))))
380
381
382(defun list-length (l)
383  "Return the length of the given LIST, or NIL if the LIST is circular."
384  (do* ((n 0 (+ n 2))
385        (fast l (cddr fast))
386        (slow l (cdr slow)))
387       ((null fast) n)
388    (declare (fixnum n))
389    (if (null (cdr fast))
390      (return (the fixnum (1+ n)))
391      (if (and (eq fast slow)
392               (> n 0))
393        (return nil)))))
394
395(defun proper-list-p (l)
396  (and (typep l 'list)
397       (do* ((n 0 (+ n 2))
398             (fast l (if (and (listp fast) (listp (cdr fast)))
399                       (cddr fast)
400                       (return-from proper-list-p nil)))
401             (slow l (cdr slow)))
402            ((null fast) n)
403         (declare (fixnum n))
404         (if (atom fast)
405           (return nil)
406           (if (null (cdr fast))
407             (return t)
408             (if (and (eq fast slow)
409                      (> n 0))
410               (return nil)))))))
411
412(defun proper-sequence-p (x)
413  (cond ((typep x 'vector))
414        ((typep x 'list) (not (null (list-length x))))))
415
416
417(defun length (seq)
418  "Return an integer that is the length of SEQUENCE."
419  (seq-dispatch
420   seq
421   (or (list-length seq)
422       (%err-disp $XIMPROPERLIST seq))
423   (if (= (the fixnum (typecode seq)) target::subtag-vectorH)
424     (%svref seq target::vectorH.logsize-cell)
425     (uvsize seq))))
426
427(defun %str-from-ptr (pointer len &optional (dest (make-string len)))
428  (declare (fixnum len)
429           (optimize (speed 3) (safety 0)))
430  (dotimes (i len dest)
431    (setf (%scharcode dest i) (%get-unsigned-byte pointer i))))
432
433(defun %get-cstring (pointer)
434  (do* ((end 0 (1+ end)))
435       ((zerop (the (unsigned-byte 8) (%get-unsigned-byte pointer end)))
436        (%str-from-ptr pointer end))
437    (declare (fixnum end))))
438
439(defun %get-utf-8-cstring (pointer)
440  (do* ((end 0 (1+ end)))
441       ((zerop (the (unsigned-byte 8) (%get-unsigned-byte pointer end)))
442        (let* ((len (utf-8-length-of-memory-encoding pointer end 0))
443               (string (make-string len)))
444          (utf-8-memory-decode pointer end 0 string)
445          string))
446    (declare (fixnum end))))
447
448;;; Assumes that pointer is terminated by a 0-valued 16-bit word
449;;; and that it points to a valid utf-16 string with native endianness.
450(defun %get-native-utf-16-cstring (pointer)
451  (do* ((nchars 0 (1+ nchars))
452        (i 0 (+ i 2))
453        (code (%get-unsigned-word pointer i) (%get-unsigned-word pointer i)))
454       ((zerop code)
455        (do* ((string (make-string nchars))
456              (out 0 (1+ out))
457              (i 0 (+ i 2)))
458             ((= out nchars) string)
459          (declare (fixnum i out))
460          (let* ((code (%get-unsigned-word pointer i)))
461            (declare (type (unsigned-byte 16) code))
462            (when (and (>= code #xd800)
463                       (< code #xdc00))
464              (incf i 2)
465              (let* ((code2 (%get-unsigned-word pointer i)))
466                (declare (type (unsigned-byte 16) code2))
467                (setq code (utf-16-combine-surrogate-pairs code code2))))
468            (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         (decf pending)
761         (if (> pending 0)
762           (setf (%get-natural ptr target::lockptr.waiting) pending))
763         (setf (%get-ptr spin) (%null-ptr))
764         (if (>= pending 0)
765           (%signal-semaphore-ptr signal)))))
766    nil))
767
768
769
770
771#+futex
772(defun %unlock-recursive-lock-ptr (ptr lock)
773  (unless (eql (%get-object ptr target::lockptr.owner) (%current-tcr))
774    (error 'not-lock-owner :lock lock))
775  (without-interrupts
776   (when (eql 0 (decf (the fixnum
777                        (%get-natural ptr target::lockptr.count))))
778     (setf (%get-natural ptr target::lockptr.owner) 0)
779     (%unlock-futex ptr)))
780  nil)
781
782(defun %unlock-recursive-lock-object (lock)
783  (%unlock-recursive-lock-ptr (%svref lock target::lock._value-cell) lock))
784
785
786
787
788(defun %%lock-owner (lock)
789  "Intended for debugging only; ownership may change while this code
790   is running."
791  (let* ((tcr (%get-object (recursive-lock-ptr lock) target::lockptr.owner)))
792    (unless (zerop tcr)
793      (tcr->process tcr))))
794
795 
796 
797
798
799
800
801(defun %rplaca-conditional (cons-cell old new)
802  (%store-node-conditional target::cons.car cons-cell old new))
803
804(defun %rplacd-conditional (cons-cell old new)
805  (%store-node-conditional target::cons.cdr cons-cell old new))
806
807;;; Atomically push NEW onto the list in the I'th cell of uvector V.
808
809(defun atomic-push-uvector-cell (v i new)
810  (let* ((cell (cons new nil))
811         (offset (+ target::misc-data-offset (ash i target::word-shift))))
812    (loop
813      (let* ((old (%svref v i)))
814        (rplacd cell old)
815        (when (%store-node-conditional offset v old cell)
816          (return cell))))))
817
818(defun atomic-pop-uvector-cell (v i)
819  (let* ((offset (+ target::misc-data-offset (ash i target::word-shift))))
820    (loop
821      (let* ((old (%svref v i)))
822        (if (null old)
823          (return (values nil nil))
824          (let* ((tail (cdr old)))
825            (when (%store-node-conditional offset v old tail)
826              (return (values (car old) t)))))))))
827
828
829(defun store-gvector-conditional (index gvector old new)
830  (declare (index index))
831  (%store-node-conditional (the fixnum
832                             (+ target::misc-data-offset
833                                (the fixnum (ash index target::word-shift))))
834                           gvector
835                           old
836                           new))
837
838(defun %atomic-incf-car (cell &optional (by 1))
839  (%atomic-incf-node (require-type by 'fixnum)
840                     (require-type cell 'cons)
841                     target::cons.car))
842
843(defun %atomic-incf-cdr (cell &optional (by 1))
844  (%atomic-incf-node (require-type by 'fixnum)
845                     (require-type cell 'cons)
846                     target::cons.cdr))
847
848(defun %atomic-incf-gvector (v i &optional (by 1))
849  (setq v (require-type v 'gvector))
850  (setq i (require-type i 'fixnum))
851  (%atomic-incf-node by v (+ target::misc-data-offset (ash i target::word-shift))))
852
853(defun %atomic-incf-symbol-value (s &optional (by 1))
854  (setq s (require-type s 'symbol))
855  (multiple-value-bind (base offset) (%symbol-binding-address s)
856    (%atomic-incf-node by base offset)))
857
858;;; What happens if there are some pending readers and another writer,
859;;; and we abort out of the semaphore wait ?  If the writer semaphore is
860;;; signaled before we abandon interest in it
861#-futex
862(defun %write-lock-rwlock-ptr (ptr lock &optional flag)
863  (with-macptrs ((write-signal (%get-ptr ptr target::rwlock.writer-signal)) )
864    (if (istruct-typep flag 'lock-acquisition)
865      (setf (lock-acquisition.status flag) nil)
866      (if flag (report-bad-arg flag 'lock-acquisition)))
867    (let* ((level *interrupt-level*)
868           (tcr (%current-tcr)))
869      (declare (fixnum tcr))
870      (without-interrupts
871       (%get-spin-lock ptr)               ;(%get-spin-lock (%inc-ptr ptr target::rwlock.spin))
872       (if (eq (%get-object ptr target::rwlock.writer) tcr)
873         (progn
874           (incf (%get-signed-natural ptr target::rwlock.state))
875           (setf (%get-natural ptr target::rwlock.spin) 0)
876           (if flag
877             (setf (lock-acquisition.status flag) t))
878           t)
879         (do* ()
880              ((eql 0 (%get-signed-natural ptr target::rwlock.state))
881               ;; That wasn't so bad, was it ?  We have the spinlock now.
882               (setf (%get-signed-natural ptr target::rwlock.state) 1
883                     (%get-natural ptr target::rwlock.spin) 0)
884               (%set-object ptr target::rwlock.writer tcr)
885               (if flag
886                 (setf (lock-acquisition.status flag) t))
887               t)
888           (incf (%get-natural ptr target::rwlock.blocked-writers))
889           (setf (%get-natural ptr target::rwlock.spin) 0)
890           (let* ((*interrupt-level* level))
891                  (%process-wait-on-semaphore-ptr write-signal 1 0 (rwlock-write-whostate lock)))
892           (%get-spin-lock ptr)))))))
893#+futex
894(defun %write-lock-rwlock-ptr (ptr lock &optional flag)
895  (with-macptrs ((write-signal (%INC-ptr ptr target::rwlock.writer-signal)) )
896    (if (istruct-typep flag 'lock-acquisition)
897      (setf (lock-acquisition.status flag) nil)
898      (if flag (report-bad-arg flag 'lock-acquisition)))
899    (let* ((level *interrupt-level*)
900           (tcr (%current-tcr)))
901      (declare (fixnum tcr))
902      (without-interrupts
903       (%lock-futex ptr level lock nil)
904       (if (eq (%get-object ptr target::rwlock.writer) tcr)
905         (progn
906           (incf (%get-signed-natural ptr target::rwlock.state))
907           (%unlock-futex ptr)
908           (if flag
909             (setf (lock-acquisition.status flag) t))
910           t)
911         (do* ()
912              ((eql 0 (%get-signed-natural ptr target::rwlock.state))
913               ;; That wasn't so bad, was it ?  We have the spinlock now.
914               (setf (%get-signed-natural ptr target::rwlock.state) 1)
915               (setf (%get-signed-long write-signal) -1)
916               (%unlock-futex ptr)
917               (%set-object ptr target::rwlock.writer tcr)
918               (if flag
919                 (setf (lock-acquisition.status flag) t))
920               t)
921           (incf (%get-natural ptr target::rwlock.blocked-writers))
922           (let* ((waitval -1))
923             (%unlock-futex ptr)
924             (with-process-whostate ((rwlock-write-whostate lock))
925               (let* ((*interrupt-level* level))
926                 (futex-wait write-signal waitval (rwlock-write-whostate lock)))))
927           (%lock-futex ptr level lock nil)
928           (decf (%get-natural ptr target::rwlock.blocked-writers))))))))
929
930
931
932(defun write-lock-rwlock (lock &optional flag)
933  (%write-lock-rwlock-ptr (read-write-lock-ptr lock) lock flag))
934
935#-futex
936(defun %read-lock-rwlock-ptr (ptr lock &optional flag)
937  (with-macptrs ((read-signal (%get-ptr ptr target::rwlock.reader-signal)))
938    (if (istruct-typep flag 'lock-acquisition)
939      (setf (lock-acquisition.status flag) nil)
940      (if flag (report-bad-arg flag 'lock-acquisition)))
941    (let* ((level *interrupt-level*)
942           (tcr (%current-tcr)))
943      (declare (fixnum tcr))
944      (without-interrupts
945       (%get-spin-lock ptr)             ;(%get-spin-lock (%inc-ptr ptr target::rwlock.spin))
946       (if (eq (%get-object ptr target::rwlock.writer) tcr)
947         (progn
948           (setf (%get-natural ptr target::rwlock.spin) 0)
949           (error 'deadlock :lock lock))
950         (do* ((state
951                (%get-signed-natural ptr target::rwlock.state)
952                (%get-signed-natural ptr target::rwlock.state)))
953              ((<= state 0)
954               ;; That wasn't so bad, was it ?  We have the spinlock now.
955               (setf (%get-signed-natural ptr target::rwlock.state)
956                     (the fixnum (1- state))
957                     (%get-natural ptr target::rwlock.spin) 0)
958               (if flag
959                 (setf (lock-acquisition.status flag) t))
960               t)
961           (declare (fixnum state))
962           (incf (%get-natural ptr target::rwlock.blocked-readers))
963           (setf (%get-natural ptr target::rwlock.spin) 0)
964           (let* ((*interrupt-level* level))
965             (%process-wait-on-semaphore-ptr read-signal 1 0 (rwlock-read-whostate lock)))
966           (%get-spin-lock ptr)))))))
967
968#+futex
969(defun %read-lock-rwlock-ptr (ptr lock &optional flag) 
970  (with-macptrs ((reader-signal (%INC-ptr ptr target::rwlock.reader-signal)))
971    (if (istruct-typep flag 'lock-acquisition)
972      (setf (lock-acquisition.status flag) nil)
973      (if flag (report-bad-arg flag 'lock-acquisition)))
974    (let* ((level *interrupt-level*)
975           (tcr (%current-tcr)))
976      (declare (fixnum tcr))
977      (without-interrupts
978       (%lock-futex ptr level lock nil)
979       (if (eq (%get-object ptr target::rwlock.writer) tcr)
980         (progn
981           (%unlock-futex ptr)
982           (error 'deadlock :lock lock))
983         (do* ((state
984                (%get-signed-natural ptr target::rwlock.state)
985                (%get-signed-natural ptr target::rwlock.state)))
986              ((<= state 0)
987               ;; That wasn't so bad, was it ?  We have the spinlock now.
988               (setf (%get-signed-natural ptr target::rwlock.state)
989                     (the fixnum (1- state)))
990               (setf (%get-signed-long reader-signal) -1) ; can happen multiple times, but that's harmless
991               (%unlock-futex ptr)
992               (if flag
993                 (setf (lock-acquisition.status flag) t))
994               t)
995           (declare (fixnum state))
996           (incf (%get-natural ptr target::rwlock.blocked-readers))
997           (let* ((waitval -1))
998             (%unlock-futex ptr)
999             (let* ((*interrupt-level* level))
1000               (futex-wait reader-signal waitval (rwlock-read-whostate lock))))
1001           (%lock-futex ptr level lock nil)
1002           (decf (%get-natural ptr target::rwlock.blocked-readers))))))))
1003
1004
1005
1006(defun read-lock-rwlock (lock &optional flag)
1007  (%read-lock-rwlock-ptr (read-write-lock-ptr lock) lock flag))
1008
1009
1010
1011#-futex
1012(defun %unlock-rwlock-ptr (ptr lock)
1013  (with-macptrs ((reader-signal (%get-ptr ptr target::rwlock.reader-signal))
1014                 (writer-signal (%get-ptr ptr target::rwlock.writer-signal)))
1015    (without-interrupts
1016     (%get-spin-lock ptr)
1017     (let* ((state (%get-signed-natural ptr target::rwlock.state))
1018            (tcr (%current-tcr)))
1019       (declare (fixnum state tcr))
1020       (cond ((> state 0)
1021              (unless (eql tcr (%get-object ptr target::rwlock.writer))
1022                (setf (%get-natural ptr target::rwlock.spin) 0)
1023                (error 'not-lock-owner :lock lock))
1024              (decf state))
1025             ((< state 0) (incf state))
1026             (t (setf (%get-natural ptr target::rwlock.spin) 0)
1027                (error 'not-locked :lock lock)))
1028       (setf (%get-signed-natural ptr target::rwlock.state) state)
1029       (when (zerop state)
1030         ;; We want any thread waiting for a lock semaphore to
1031         ;; be able to wait interruptibly.  When a thread waits,
1032         ;; it increments either the "blocked-readers" or "blocked-writers"
1033         ;; field, but since it may get interrupted before obtaining
1034         ;; the semaphore that's more of "an expression of interest"
1035         ;; in taking the lock than it is "a firm commitment to take it."
1036         ;; It's generally (much) better to signal the semaphore(s)
1037         ;; too often than it would be to not signal them often
1038         ;; enough; spurious wakeups are better than deadlock.
1039         ;; So: if there are blocked writers, the writer-signal
1040         ;; is raised once for each apparent blocked writer.  (At most
1041         ;; one writer will actually succeed in taking the lock.)
1042         ;; If there are blocked readers, the reader-signal is raised
1043         ;; once for each of them.  (It's possible for both the
1044         ;; reader and writer semaphores to be raised on the same
1045         ;; unlock; the writer semaphore is raised first, so in that
1046         ;; sense, writers still have priority but it's not guaranteed.)
1047         ;; Both the "blocked-writers" and "blocked-readers" fields
1048         ;; are cleared here (they can't be changed from another thread
1049         ;; until this thread releases the spinlock.)
1050         (setf (%get-signed-natural ptr target::rwlock.writer) 0)
1051         (let* ((nwriters (%get-natural ptr target::rwlock.blocked-writers))
1052                (nreaders (%get-natural ptr target::rwlock.blocked-readers)))
1053           (declare (fixnum nreaders nwriters))
1054           (when (> nwriters 0)
1055             (setf (%get-natural ptr target::rwlock.blocked-writers) 0)
1056             (dotimes (i nwriters)
1057               (%signal-semaphore-ptr writer-signal)))
1058           (when (> nreaders 0)
1059             (setf (%get-natural ptr target::rwlock.blocked-readers) 0)
1060             (dotimes (i nreaders)
1061               (%signal-semaphore-ptr reader-signal)))))
1062       (setf (%get-natural ptr target::rwlock.spin) 0)
1063       t))))
1064
1065#+futex
1066(defun %unlock-rwlock-ptr (ptr lock)
1067  (with-macptrs ((reader-signal (%INC-ptr ptr target::rwlock.reader-signal))
1068                 (writer-signal (%INC-ptr ptr target::rwlock.writer-signal)))
1069    (let* ((signal nil)
1070           (wakeup 0))
1071    (without-interrupts
1072     (%lock-futex ptr -1 lock nil)
1073     (let* ((state (%get-signed-natural ptr target::rwlock.state))
1074            (tcr (%current-tcr)))
1075       (declare (fixnum state tcr))
1076       (cond ((> state 0)
1077              (unless (eql tcr (%get-object ptr target::rwlock.writer))
1078                (%unlock-futex ptr)
1079                (error 'not-lock-owner :lock lock))
1080              (decf state))
1081             ((< state 0) (incf state))
1082             (t (%unlock-futex ptr)
1083                (error 'not-locked :lock lock)))
1084       (setf (%get-signed-natural ptr target::rwlock.state) state)
1085       (when (zerop state)
1086         (setf (%get-signed-natural ptr target::rwlock.writer) 0)
1087         (let* ((nwriters (%get-natural ptr target::rwlock.blocked-writers))
1088                (nreaders (%get-natural ptr target::rwlock.blocked-readers)))
1089           (declare (fixnum nreaders nwriters))
1090           (if (> nwriters 0)
1091             (setq signal writer-signal wakeup 1)
1092             (if (> nreaders 0)
1093               (setq signal reader-signal wakeup #$INT_MAX)))))
1094       (when signal (setf (%get-signed-long signal) 0))
1095       (%unlock-futex ptr)
1096       (when signal (futex-wake signal wakeup))
1097       t)))))
1098
1099
1100(defun unlock-rwlock (lock)
1101  (%unlock-rwlock-ptr (read-write-lock-ptr lock) lock))
1102
1103;;; There are all kinds of ways to lose here.
1104;;; The caller must have read access to the lock exactly once,
1105;;; or have write access.
1106;;; there's currently no way to detect whether the caller has
1107;;; read access at all.
1108;;; If we have to block and get interrupted, cleanup code may
1109;;; try to unlock a lock that we don't hold. (It might be possible
1110;;; to circumvent that if we use the same notifcation object here
1111;;; that controls that cleanup process.)
1112
1113(defun %promote-rwlock (lock &optional flag)
1114  (let* ((ptr (read-write-lock-ptr lock)))
1115    (if (istruct-typep flag 'lock-acquisition)
1116      (setf (lock-acquisition.status flag) nil)
1117      (if flag (report-bad-arg flag 'lock-acquisition)))
1118    (let* ((level *interrupt-level*)
1119           (tcr (%current-tcr)))
1120      (without-interrupts
1121       #+futex
1122       (%lock-futex ptr level lock nil)
1123       #-futex
1124       (%get-spin-lock ptr)
1125       (let* ((state (%get-signed-natural ptr target::rwlock.state)))
1126         (declare (fixnum state))
1127         (cond ((> state 0)
1128                (unless (eql (%get-object ptr target::rwlock.writer) tcr)
1129                  #+futex
1130                  (%unlock-futex ptr)
1131                  #-futex
1132                  (setf (%get-natural ptr target::rwlock.spin) 0)
1133                  (error :not-lock-owner :lock lock)))
1134               ((= state 0)
1135                #+futex (%unlock-futex ptr)
1136                #-futex (setf (%get-natural ptr target::rwlock.spin) 0)
1137                (error :not-locked :lock lock))
1138               (t
1139                (if (= state -1)
1140                  (progn
1141                    (setf (%get-signed-natural ptr target::rwlock.state) 1)
1142                    (%set-object ptr target::rwlock.writer tcr)
1143                    #+futex
1144                    (%unlock-futex ptr)
1145                    #-futex
1146                    (setf (%get-natural ptr target::rwlock.spin) 0)
1147                    (if flag
1148                      (setf (lock-acquisition.status flag) t))
1149                    t)
1150                  (progn                   
1151                    #+futex
1152                    (%unlock-futex ptr)
1153                    #-futex
1154                    (setf (%get-natural ptr target::rwlock.spin) 0)
1155                    (%unlock-rwlock-ptr ptr lock)
1156                    (let* ((*interrupt-level* level))
1157                      (%write-lock-rwlock-ptr ptr lock flag)))))))))))
1158                     
1159
1160
1161(defun safe-get-ptr (p &optional dest)
1162  (if (null dest)
1163    (setq dest (%null-ptr))
1164    (unless (typep dest 'macptr)
1165      (check-type dest macptr)))
1166  (without-interrupts                   ;reentrancy
1167   (%safe-get-ptr p dest)))
1168
1169
Note: See TracBrowser for help on using the repository browser.