source: branches/working-0710/ccl/level-0/l0-misc.lisp @ 7689

Last change on this file since 7689 was 7689, checked in by gb, 14 years ago

New locking interface; track lock usage, maintain whostate.

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