source: branches/ia32/level-0/l0-misc.lisp @ 7430

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

Less zeal in SAFE-GET-PTR.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 23.0 KB
Line 
1;;;-*- Mode: Lisp; Package: CCL -*-
2;;;
3;;;   Copyright (C) 1994-2001 Digitool, Inc
4;;;   This file is part of OpenMCL. 
5;;;
6;;;   OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
7;;;   License , known as the LLGPL and distributed with OpenMCL as the
8;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
9;;;   which is distributed with OpenMCL as the file "LGPL".  Where these
10;;;   conflict, the preamble takes precedence. 
11;;;
12;;;   OpenMCL is referenced in the preamble as the "LIBRARY."
13;;;
14;;;   The LLGPL is also available online at
15;;;   http://opensource.franz.com/preamble.html
16
17(in-package "CCL")
18
19; Miscellany.
20
21(defun memq (item list)
22  (do* ((tail list (%cdr tail)))
23       ((null tail))
24    (if (eq item (car tail))
25      (return tail))))
26
27(defun %copy-u8-to-string (u8-vector source-idx string dest-idx n)
28  (declare (optimize (speed 3) (safety 0))
29           (fixnum source-idx dest-idx n)
30           (type (simple-array (unsigned-byte 8) (*)) u8-vector)
31           (simple-base-string string))
32  (do* ((i 0 (1+ i)))
33       ((= i n) string)
34    (declare (fixnum i))
35    (setf (%scharcode string dest-idx) (aref u8-vector source-idx))
36    (incf source-idx)
37    (incf dest-idx)))
38
39(defun %copy-string-to-u8 (string source-idx u8-vector dest-idx n)
40  (declare (optimize (speed 3) (safety 0))
41           (fixnum source-idx dest-idx n)
42           (type (simple-array (unsigned-byte 8) (*)) u8-vector)
43           (simple-base-string string))
44  (do* ((i 0 (1+ i)))
45       ((= i n) u8-vector)
46    (declare (fixnum i))
47    (let* ((code (%scharcode string source-idx)))
48      (declare (type (mod #x11000) code))
49      (if (> code #xff)
50        (setq code (char-code #\Sub)))
51      (setf (aref u8-vector dest-idx) code)
52      (incf source-idx)
53      (incf dest-idx))))
54   
55       
56
57
58(defun append-2 (y z)
59  (if (null y)
60    z
61    (let* ((new (cons (car y) nil))
62           (tail new))
63      (declare (list new tail))
64      (dolist (head (cdr y))
65        (setq tail (cdr (rplacd tail (cons head nil)))))
66      (rplacd tail z)
67      new)))
68
69
70
71
72
73
74
75
76
77(defun dbg (&optional arg)
78  (dbg arg))
79
80
81; This takes a simple-base-string and passes a C string into
82; the kernel "Bug" routine.  Not too fancy, but neither is #_DebugStr,
83; and there's a better chance that users would see this message.
84(defun bug (arg)
85  (if (typep arg 'simple-base-string)
86    #+x8664-target
87    (debug-trap-with-string arg)
88    #-x8664-target
89    (let* ((len (length arg)))
90      (%stack-block ((buf (1+ len)))
91        (%cstr-pointer arg buf)
92        (ff-call 
93         (%kernel-import target::kernel-import-lisp-bug)
94         :address buf
95         :void)))
96    (bug "Bug called with non-simple-base-string.")))
97
98(defun total-bytes-allocated ()
99  (%heap-bytes-allocated)
100  #+not-any-more
101  (+ (unsignedwide->integer *total-bytes-freed*)
102     (%heap-bytes-allocated)))
103
104(defun %freebytes ()
105  (%normalize-areas)
106  (let ((res 0))
107    (with-macptrs (p)
108      (do-consing-areas (area)
109        (when (eql (%fixnum-ref area target::area.code) area-dynamic)
110          (%setf-macptr-to-object p  area)
111          (incf res (- (%get-natural p target::area.high)
112                       (%get-natural p target::area.active))))))
113    res))
114
115(defun %reservedbytes ()
116  (with-macptrs (p)
117    (%setf-macptr-to-object p (%get-kernel-global 'all-areas))
118    (- #+32-bit-target
119       (%get-unsigned-long p target::area.high)
120       #+64-bit-target
121       (%%get-unsigned-longlong p target::area.high)
122       #+32-bit-target
123       (%get-unsigned-long p target::area.low)
124       #+64-bit-target
125       (%%get-unsigned-longlong p target::area.low))))
126
127(defun object-in-application-heap-p (address)
128  (declare (ignore address))
129  t)
130
131
132(defun %usedbytes ()
133  (%normalize-areas)
134  (let ((static 0)
135        (dynamic 0)
136        (library 0))
137      (do-consing-areas (area)
138        (let* ((active (%fixnum-ref area target::area.active))
139               (bytes (ash (- active
140                            (%fixnum-ref area target::area.low))
141                           target::fixnumshift))
142               (code (%fixnum-ref area target::area.code)))
143          (when (object-in-application-heap-p active)
144            (if (eql code area-dynamic)
145              (incf dynamic bytes)
146              (if (eql code area-managed-static)
147                (incf library bytes)
148                (incf static bytes))))))
149      (let* ((hons-size (ash (openmcl-hons:hons-space-size) target::dnode-shift)))
150        (decf dynamic hons-size)
151        (values dynamic static library hons-size))))
152
153
154
155(defun %stack-space ()
156  (%normalize-areas)
157  (let ((free 0)
158        (used 0))
159    (with-macptrs (p)
160      (do-gc-areas (area)
161        (when (member (%fixnum-ref area target::area.code)
162                      '(#.area-vstack
163                        #.area-cstack
164                      #.area-tstack))
165          (%setf-macptr-to-object p area)
166          (let ((active
167                 #+32-bit-target
168                  (%get-unsigned-long p target::area.active)
169                  #+64-bit-target
170                  (%%get-unsigned-longlong p target::area.active))
171                (high
172                 #+32-bit-target
173                  (%get-unsigned-long p target::area.high)
174                  #+64-bit-target
175                  (%%get-unsigned-longlong p target::area.high))
176                (low
177                 #+32-bit-target
178                 (%get-unsigned-long p target::area.low)
179                 #+64-bit-target
180                 (%%get-unsigned-longlong p target::area.low)))
181            (incf used (- high active))
182            (incf free (- active low))))))
183    (values (+ free used) used free)))
184
185
186
187; Returns an alist of the form:
188; ((thread cstack-free cstack-used vstack-free vstack-used tstack-free tstack-used)
189;  ...)
190(defun %stack-space-by-lisp-thread ()
191  (let* ((res nil))
192    (without-interrupts
193     (dolist (p (all-processes))
194       (let* ((thread (process-thread p)))
195         (when thread
196           (push (cons thread (multiple-value-list (%thread-stack-space thread))) res)))))
197    res))
198
199
200
201; Returns six values.
202;   sp free
203;   sp used
204;   vsp free
205;   vsp used
206;   tsp free
207;   tsp used
208(defun %thread-stack-space (&optional (thread *current-lisp-thread*))
209  (when (eq thread *current-lisp-thread*)
210    (%normalize-areas))
211  (labels ((free-and-used (area)
212             (with-macptrs (p)
213               (%setf-macptr-to-object p area)
214               (let* ((low
215                       #+32-bit-target
216                       (%get-unsigned-long p target::area.low)
217                       #+64-bit-target
218                       (%%get-unsigned-longlong p target::area.low))
219                      (high
220                       #+32-bit-target
221                        (%get-unsigned-long p target::area.high)
222                        #+64-bit-target
223                        (%%get-unsigned-longlong p target::area.high))
224                      (active
225                       #+32-bit-target
226                       (%get-unsigned-long p target::area.active)
227                       #+64-bit-target
228                       (%%get-unsigned-longlong p target::area.active))
229                      (free (- active low))
230                      (used (- high active)))
231                 (loop
232                     (setq area (%fixnum-ref area target::area.older))
233                     (when (eql area 0) (return))
234                   (%setf-macptr-to-object p area)
235                   (let ((low
236                          #+32-bit-target
237                           (%get-unsigned-long p target::area.low)
238                           #+64-bit-target
239                           (%%get-unsigned-longlong p target::area.low))
240                         (high
241                          #+32-bit-target
242                           (%get-unsigned-long p target::area.high)
243                           #+64-bit-target
244                           (%%get-unsigned-longlong p target::area.high)))
245                     (declare (fixnum low high))
246                     (incf used (- high low))))
247                 (values free used)))))
248    (let* ((tcr (lisp-thread.tcr thread)))
249      (if (or (null tcr)
250              (zerop (%fixnum-ref (%fixnum-ref tcr target::tcr.cs-area))))
251        (values 0 0 0 0 0 0)
252        (multiple-value-bind (cf cu) (free-and-used (%fixnum-ref tcr target::tcr.cs-area))
253          (multiple-value-bind (vf vu) (free-and-used (%fixnum-ref tcr target::tcr.vs-area))
254            (multiple-value-bind (tf tu) (free-and-used (%fixnum-ref tcr target::tcr.ts-area ))
255              (values cf cu vf vu tf tu))))))))
256
257
258(defun room (&optional (verbose :default))
259  "Print to *STANDARD-OUTPUT* information about the state of internal
260  storage and its management. The optional argument controls the
261  verbosity of output. If it is T, ROOM prints out a maximal amount of
262  information. If it is NIL, ROOM prints out a minimal amount of
263  information. If it is :DEFAULT or it is not supplied, ROOM prints out
264  an intermediate amount of information."
265  (let* ((freebytes nil)
266         (usedbytes nil)
267         (static-used nil)
268         (staticlib-used nil)
269         (hons-space-size nil)
270         (lispheap nil)
271         (reserved nil)
272         (static nil)
273         (stack-total)
274         (stack-used)
275         (stack-free)
276         (stack-used-by-thread nil))
277    (with-other-threads-suspended
278        (without-gcing
279         (setq freebytes (%freebytes))
280         (when verbose
281           (multiple-value-setq (usedbytes static-used staticlib-used hons-space-size)
282             (%usedbytes))
283           (setq lispheap (+ freebytes usedbytes)
284                 reserved (%reservedbytes)
285                 static (+ static-used staticlib-used hons-space-size))
286           (multiple-value-setq (stack-total stack-used stack-free)
287             (%stack-space))
288           (unless (eq verbose :default)
289             (setq stack-used-by-thread (%stack-space-by-lisp-thread))))))
290    (format t "~&Approximately ~:D bytes of memory can be allocated ~%before the next full GC is triggered. ~%" freebytes)
291    (when verbose
292      (flet ((k (n) (round n 1024)))
293        (princ "
294                   Total Size             Free                 Used")
295        (format t "~&Lisp Heap:~15t~10D (~DK)~35t~10D (~DK)~55t~10D (~DK)"
296                lispheap (k lispheap)
297                freebytes (k freebytes)
298                usedbytes (k usedbytes))
299        (format t "~&Stacks:~15t~10D (~DK)~35t~10D (~DK)~55t~10D (~DK)"
300                stack-total (k stack-total)
301                stack-free (k stack-free)
302                stack-used (k stack-used))
303        (format t "~&Static:~15t~10D (~DK)~35t~10D (~DK)~55t~10D (~DK)"
304                static (k static)
305                0 0
306                static (k static))
307        (when (and hons-space-size (not (zerop hons-space-size)))
308          (format t "~&~,3f MB of static memory reserved for hash consing."
309                  (/ hons-space-size (float (ash 1 20)))))
310        (format t "~&~,3f MB reserved for heap expansion."
311                (/ reserved (float (ash 1 20))))
312        (unless (eq verbose :default)
313          (terpri)
314          (let* ((processes (all-processes)))
315            (dolist (thread-info stack-used-by-thread)
316              (destructuring-bind (thread sp-free sp-used vsp-free vsp-used tsp-free tsp-used)
317                  thread-info
318                (let* ((process (dolist (p processes)
319                                  (when (eq (process-thread p) thread)
320                                    (return p)))))
321                  (when process
322                    (let ((sp-total (+ sp-used sp-free))
323                          (vsp-total (+ vsp-used vsp-free))
324                          (tsp-total (+ tsp-used tsp-free)))
325                      (format t "~%~a(~d)~%  cstack:~12T~10D (~DK)  ~33T~10D (~DK)  ~54T~10D (~DK)~
326                               ~%  vstack:~12T~10D (~DK)  ~33T~10D (~DK)  ~54T~10D (~DK)~
327                               ~%  tstack:~12T~10D (~DK)  ~33T~10D (~DK)  ~54T~10D (~DK)"
328                              (process-name process)
329                              (process-serial-number process)
330                              sp-total (k sp-total) sp-free (k sp-free) sp-used (k sp-used)
331                              vsp-total (k vsp-total) vsp-free (k vsp-free) vsp-used (k vsp-used)
332                              tsp-total (k tsp-total) tsp-free (k tsp-free) tsp-used (k tsp-used)))))))))))))
333
334
335(defun list-length (l)
336  "Return the length of the given LIST, or NIL if the LIST is circular."
337  (do* ((n 0 (+ n 2))
338        (fast l (cddr fast))
339        (slow l (cdr slow)))
340       ((null fast) n)
341    (declare (fixnum n))
342    (if (null (cdr fast))
343      (return (the fixnum (1+ n)))
344      (if (and (eq fast slow)
345               (> n 0))
346        (return nil)))))
347
348(defun proper-list-p (l)
349  (and (typep l 'list)
350       (do* ((n 0 (+ n 2))
351             (fast l (if (and (listp fast) (listp (cdr fast)))
352                       (cddr fast)
353                       (return-from proper-list-p nil)))
354             (slow l (cdr slow)))
355            ((null fast) n)
356         (declare (fixnum n))
357         (if (atom fast)
358           (return nil)
359           (if (null (cdr fast))
360             (return t)
361             (if (and (eq fast slow)
362                      (> n 0))
363               (return nil)))))))
364
365(defun proper-sequence-p (x)
366  (cond ((typep x 'vector))
367        ((typep x 'list) (not (null (list-length x))))))
368
369
370(defun length (seq)
371  "Return an integer that is the length of SEQUENCE."
372  (seq-dispatch
373   seq
374   (or (list-length seq)
375       (%err-disp $XIMPROPERLIST seq))
376   (if (= (the fixnum (typecode seq)) target::subtag-vectorH)
377     (%svref seq target::vectorH.logsize-cell)
378     (uvsize seq))))
379
380(defun %str-from-ptr (pointer len &optional (dest (make-string len)))
381  (declare (fixnum len)
382           (optimize (speed 3) (safety 0)))
383  (dotimes (i len dest)
384    (setf (%scharcode dest i) (%get-unsigned-byte pointer i))))
385
386(defun %get-cstring (pointer)
387  (do* ((end 0 (1+ end)))
388       ((zerop (the (unsigned-byte 8) (%get-unsigned-byte pointer end)))
389        (%str-from-ptr pointer end))
390    (declare (fixnum end))))
391
392;;; This is mostly here so we can bootstrap shared libs without
393;;; having to bootstrap #_strcmp.
394;;; Return true if the cstrings are equal, false otherwise.
395(defun %cstrcmp (x y)
396  (do* ((i 0 (1+ i))
397        (bx (%get-byte x i) (%get-byte x i))
398        (by (%get-byte y i) (%get-byte y i)))
399       ((not (= bx by)))
400    (declare (fixnum i bx by))
401    (when (zerop bx)
402      (return t))))
403
404(defvar %documentation nil)
405
406(defvar %documentation-lock% nil)
407
408(setq %documentation
409  (make-hash-table :weak t :size 100 :test 'eq :rehash-threshold .95)
410  %documentation-lock% (make-lock))
411
412(defun %put-documentation (thing doc-id doc)
413  (with-lock-grabbed (%documentation-lock%)
414    (let* ((info (gethash thing %documentation))
415           (pair (assoc doc-id info)))
416      (if doc
417        (progn
418          (unless (typep doc 'string)
419            (report-bad-arg doc 'string))
420          (if pair
421            (setf (cdr pair) doc)
422            (setf (gethash thing %documentation) (cons (cons doc-id doc) info))))
423        (when pair
424          (if (setq info (nremove pair info))
425            (setf (gethash thing %documentation) info)
426            (remhash thing %documentation))))))
427  doc)
428
429(defun %get-documentation (object doc-id)
430  (cdr (assoc doc-id (gethash object %documentation))))
431
432;;; This pretends to be (SETF DOCUMENTATION), until that generic function
433;;; is defined.  It handles a few common cases.
434(defun %set-documentation (thing doc-id doc-string)
435  (case doc-id
436    (function 
437     (if (typep thing 'function)
438       (%put-documentation thing t doc-string)
439       (if (typep thing 'symbol)
440         (let* ((def (fboundp thing)))
441           (if def
442             (%put-documentation def t doc-string)))
443         (if (setf-function-name-p thing)
444           (%set-documentation
445            (setf-function-name thing) doc-id doc-string)))))
446    (variable
447     (if (typep thing 'symbol)
448       (%put-documentation thing doc-id doc-string)))
449    (t (%put-documentation thing doc-id doc-string)))
450  doc-string)
451
452
453(%fhave 'set-documentation #'%set-documentation)
454
455
456
457;;; This is intended for use by debugging tools.  It's a horrible thing
458;;; to do otherwise.  The caller really needs to hold the heap-segment
459;;; lock; this grabs the tcr queue lock as well.
460(defun %suspend-other-threads ()
461  (ff-call (%kernel-import target::kernel-import-suspend-other-threads)
462           :void))
463
464(defun %resume-other-threads ()
465  (ff-call (%kernel-import target::kernel-import-resume-other-threads)
466           :void))
467
468(defparameter *spin-lock-tries* 1)
469
470(defun %get-spin-lock (p)
471  (let* ((self (%current-tcr))
472         (n *spin-lock-tries*))
473    (declare (fixnum n))
474    (loop
475      (dotimes (i n)
476        (when (eql 0 (%ptr-store-fixnum-conditional p 0 self))
477          (return-from %get-spin-lock t)))
478      (yield))))
479
480(defun %lock-recursive-lock (lock &optional flag)
481  (with-macptrs ((p)
482                 (owner (%get-ptr lock target::lockptr.owner))
483                 (signal (%get-ptr lock target::lockptr.signal))
484                 (spin (%inc-ptr lock target::lockptr.spinlock)))
485    (%setf-macptr-to-object p (%current-tcr))
486    (if (istruct-typep flag 'lock-acquisition)
487      (setf (lock-acquisition.status flag) nil)
488      (if flag (report-bad-arg flag 'lock-acquisition)))
489    (loop
490      (without-interrupts
491       (when (eql p owner)
492         (incf (%get-natural lock target::lockptr.count))
493         (when flag
494           (setf (lock-acquisition.status flag) t))
495         (return t))
496       (%get-spin-lock spin)
497       (when (eql 1 (incf (%get-natural lock target::lockptr.avail)))
498         (setf (%get-ptr lock target::lockptr.owner) p
499               (%get-natural lock target::lockptr.count) 1)
500         (setf (%get-natural spin 0) 0)
501         (if flag
502           (setf (lock-acquisition.status flag) t))
503         (return t))
504       (setf (%get-natural spin 0) 0))
505      (%process-wait-on-semaphore-ptr signal 1 0 "waiting for lock"))))
506
507
508;;; Locking the exception lock to inhibit GC (from other threads)
509;;; is probably a bad idea, though it does simplify some issues.
510;;; (One bad consequence is that it means that only one hash table
511;;; can be accessed at a time.)
512#+bad-idea
513(defun %lock-gc-lock ()
514  (with-macptrs ((lock))
515    (%get-kernel-global-ptr exception-lock lock)
516    (%lock-recursive-lock lock)))
517
518#+bad-idea
519(defun %unlock-gc-lock ()
520  (with-macptrs ((lock))
521    (%get-kernel-global-ptr exception-lock lock)
522    (%unlock-recursive-lock lock)))
523
524(defun %try-recursive-lock (lock &optional flag)
525  (with-macptrs ((p)
526                 (owner (%get-ptr lock target::lockptr.owner))
527                 (spin (%inc-ptr lock target::lockptr.spinlock)))
528    (%setf-macptr-to-object p (%current-tcr))
529    (if flag
530      (if (istruct-typep flag 'lock-acquisition)
531        (setf (lock-acquisition.status flag) nil)
532        (report-bad-arg flag 'lock-acquisition)))
533    (without-interrupts
534     (cond ((eql p owner)
535            (incf (%get-natural lock target::lockptr.count))
536            (if flag (setf (lock-acquisition.status flag) t))
537            t)
538           (t
539            (let* ((win nil))
540              (%get-spin-lock spin)
541              (when (setq win (eql 1 (incf (%get-natural lock target::lockptr.avail))))
542                (setf (%get-ptr lock target::lockptr.owner) p
543                      (%get-natural lock target::lockptr.count) 1)
544                (if flag (setf (lock-acquisition.status flag) t)))
545              (setf (%get-ptr spin) (%null-ptr))
546              win))))))
547
548
549(defun %unlock-recursive-lock (lock)
550  (with-macptrs ((signal (%get-ptr lock target::lockptr.signal))
551                 (spin (%inc-ptr lock target::lockptr.spinlock)))
552    (unless (eql (%get-object lock target::lockptr.owner) (%current-tcr))
553      (error 'not-lock-owner :lock lock))
554    (without-interrupts
555     (when (eql 0 (decf (the fixnum
556                          (%get-natural lock target::lockptr.count))))
557       (%get-spin-lock spin)
558       (setf (%get-ptr lock target::lockptr.owner) (%null-ptr))
559       (let* ((pending (+ (the fixnum
560                            (1- (the fixnum (%get-fixnum lock target::lockptr.avail))))
561                          (the fixnum (%get-fixnum lock target::lockptr.waiting)))))
562         (declare (fixnum pending))
563         (setf (%get-natural lock target::lockptr.avail) 0
564               (%get-natural lock target::lockptr.waiting) 0)
565         (decf pending)
566         (if (> pending 0)
567           (setf (%get-natural lock target::lockptr.waiting) pending))
568         (setf (%get-ptr spin) (%null-ptr))
569         (if (>= pending 0)
570           (%signal-semaphore-ptr signal))))))
571    nil)
572
573
574(defun %%lock-owner (lock)
575  "Intended for debugging only; ownership may change while this code
576   is running."
577  (let* ((tcr (%get-object (recursive-lock-ptr lock) target::lockptr.owner)))
578    (unless (zerop tcr)
579      (tcr->process tcr))))
580
581 
582 
583(defun %suspend-tcr (tcr)
584  (with-macptrs (tcrp)
585    (%setf-macptr-to-object tcrp tcr)
586    (not (zerop (the fixnum 
587                  (ff-call (%kernel-import target::kernel-import-suspend-tcr)
588                           :address tcrp
589                           :unsigned-fullword))))))
590
591(defun %resume-tcr (tcr)
592  (with-macptrs (tcrp)
593    (%setf-macptr-to-object tcrp tcr)
594    (not (zerop (the fixnum
595                  (ff-call (%kernel-import target::kernel-import-resume-tcr)
596                           :address tcrp
597                           :unsigned-fullword))))))
598
599
600
601(defun %rplaca-conditional (cons-cell old new)
602  (%store-node-conditional target::cons.car cons-cell old new))
603
604(defun %rplacd-conditional (cons-cell old new)
605  (%store-node-conditional target::cons.cdr cons-cell old new))
606
607;;; Atomically push NEW onto the list in the I'th cell of uvector V.
608
609(defun atomic-push-uvector-cell (v i new)
610  (let* ((cell (cons new nil))
611         (offset (+ target::misc-data-offset (ash i target::word-shift))))
612    (loop
613      (let* ((old (%svref v i)))
614        (rplacd cell old)
615        (when (%store-node-conditional offset v old cell)
616          (return cell))))))
617
618(defun store-gvector-conditional (index gvector old new)
619  (%store-node-conditional (+ target::misc-data-offset
620                              (ash index target::word-shift))
621                           gvector
622                           old
623                           new))
624
625(defun %atomic-incf-car (cell &optional (by 1))
626  (%atomic-incf-node (require-type by 'fixnum)
627                     (require-type cell 'cons)
628                     target::cons.car))
629
630(defun %atomic-incf-cdr (cell &optional (by 1))
631  (%atomic-incf-node (require-type by 'fixnum)
632                     (require-type cell 'cons)
633                     target::cons.cdr))
634
635(defun %atomic-incf-gvector (v i &optional (by 1))
636  (setq v (require-type v 'gvector))
637  (setq i (require-type i 'fixnum))
638  (%atomic-incf-node by v (+ target::misc-data-offset (ash i target::word-shift))))
639
640(defun %atomic-incf-symbol-value (s &optional (by 1))
641  (setq s (require-type s 'symbol))
642  (let* ((binding-address (%symbol-binding-address s)))
643    (declare (fixnum binding-address))
644    (if (zerop binding-address)
645      (%atomic-incf-node by s target::symbol.vcell-cell)
646      (%atomic-incf-node by binding-address (* 2 target::node-size)))))
647
648(defun write-lock-rwlock (lock)
649  (let* ((context (%current-tcr)))
650    (if (eq (%svref lock target::lock.writer-cell) context)
651      (progn
652        (decf (%svref lock target::lock._value-cell))
653        lock)
654      (loop
655        (when (%store-immediate-conditional target::lock._value lock 0 -1)
656          (setf (%svref lock target::lock.writer-cell) context)
657          (return lock))
658        (%nanosleep 0 *ns-per-tick*)))))
659
660
661(defun read-lock-rwlock (lock)
662  (loop
663    (when (%try-read-lock-rwlock lock)
664      (return lock))
665    (%nanosleep 0 *ns-per-tick*)))
666
667(defun safe-get-ptr (p &optional dest)
668  (if (null dest)
669    (setq dest (%null-ptr))
670    (unless (typep dest 'macptr)
671      (check-type dest macptr)))
672  (without-interrupts                   ;reentrancy
673   (%safe-get-ptr p dest)))
Note: See TracBrowser for help on using the repository browser.