source: trunk/source/level-0/l0-aprims.lisp @ 15601

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

Try to clean up code which uses CMPXCHG: imm0 should contain the expected
value (which may or may not be the current value, as of a few cycles before
the CMPXCHG ...). In general, we don't need or want to repeat the CMPXCHG
in order to do a conditional store (failures aren't transient). In cases
where we repeat a CMPXCHG in a loop, ensure that the loop contains a PAUSE
instruction to work correctly with hyperthreading.

Change the x86 pc_luser_xp() to account for changes in
_SPstore_node_conditional and _SPset_hash_key_conditional.

Introduce a WITH-EXCEPTION-LOCK macro; refactor
%LOCK-RECURSIVE-LOCK-OBJECT and friends so that we can lock/unlock a
kernel lock (with no lisp LOCK object around it) without having to
call into the kernel. RECURSIVE-LOCK-WHOSTATE allows its argument to
be a string. (WITH-EXCEPTION-LOCK isn't used anywhere yet; it may be
a better alternative to things like WITHOUT-GCING, where (a) it's
preferable to delay exception handing in other threads than to let
the heap grow and (b) the body is short and doesn't try to grab other
locks.)

This is all intended to fix ticket:1030 in the trunk.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 7.6 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
19(in-package "CCL")
20
21; l0-aprims.lisp
22
23;;; This weak list is used to track semaphores as well as locks.
24(defvar %system-locks% nil)
25
26
27(defun record-system-lock (l)
28  (atomic-push-uvector-cell %system-locks% population.data l)
29  l)
30
31;;; This has to run very early in the initial thread.
32(defun %revive-system-locks ()
33  (dolist (s (population-data %system-locks%))
34    (%revive-macptr s)
35    (%setf-macptr s
36                  (case (uvref s target::xmacptr.flags-cell)
37                    (#.$flags_DisposeRecursiveLock
38                     (ff-call
39                      (%kernel-import target::kernel-import-new-recursive-lock)
40                      :address))
41                    (#.$flags_DisposeRwlock
42                     (ff-call
43                      (%kernel-import target::kernel-import-rwlock-new)
44                      :address))
45                    (#.$flags_DisposeSemaphore
46                     (ff-call
47                      (%kernel-import target::kernel-import-new-semaphore)
48                      :signed-fullword 0
49                      :address))))
50    (set-%gcable-macptrs% s)))
51
52(dolist (p %all-packages%)
53  (setf (pkg.lock p) (make-read-write-lock)))
54
55(defparameter %all-packages-lock% nil)
56
57
58
59(defun %cstr-pointer (string pointer &optional (nul-terminated t))
60  (if (typep string 'simple-base-string)
61    (locally (declare (simple-base-string string)
62                      (optimize (speed 3) (safety 0)))
63      (let* ((n (length string)))
64        (declare (fixnum n))
65        (dotimes (i n)
66          (setf (%get-unsigned-byte pointer i)
67                (let* ((code (%scharcode string i)))
68                  (declare (type (mod #x110000) code))
69                  (if (< code 256)
70                    code
71                    (char-code #\Sub)))))
72        (when nul-terminated
73          (setf (%get-byte pointer n) 0)))
74      nil)
75    (%cstr-segment-pointer string pointer 0 (length string) nul-terminated)))
76
77(defun %cstr-segment-pointer (string pointer start end &optional (nul-terminated t))
78  (declare (fixnum start end))
79  (let* ((n (- end start)))
80    (multiple-value-bind (s o) (dereference-base-string string)
81      (declare (fixnum o))
82      (do* ((i 0 (1+ i))
83            (o (the fixnum (+ o start)) (1+ o)))
84           ((= i n))
85        (declare (fixnum i o))
86        (setf (%get-unsigned-byte pointer i)
87              (let* ((code (char-code (schar s o))))
88                (declare (type (mod #x110000) code))
89                (if (< code 256)
90                  code
91                  (char-code #\Sub))))))
92    (when nul-terminated
93      (setf (%get-byte pointer n) 0))
94    nil))
95
96(defun string (thing)
97  "Coerces X into a string. If X is a string, X is returned. If X is a
98   symbol, X's pname is returned. If X is a character then a one element
99   string containing that character is returned. If X cannot be coerced
100   into a string, an error occurs."
101  (etypecase thing
102    (string thing)
103    (symbol (symbol-name thing))
104    (character
105     (let* ((s (make-string 1)))
106       (setf (schar s 0) thing)
107       s))))
108
109
110(defun dereference-base-string (s)
111  (multiple-value-bind (vector offset) (array-data-and-offset s)
112    (unless (typep vector 'simple-base-string) (report-bad-arg s 'base-string))
113    (values vector offset (length s))))
114
115(defun make-gcable-macptr (flags)
116  (let ((v (%alloc-misc target::xmacptr.element-count target::subtag-macptr)))
117    (setf (uvref v target::xmacptr.address-cell) 0) ; ?? yup.
118    (setf (uvref v target::xmacptr.flags-cell) flags)
119    (set-%gcable-macptrs% v)
120    v))
121
122(defun %make-recursive-lock-ptr ()
123  (record-system-lock
124   (%setf-macptr
125    (make-gcable-macptr $flags_DisposeRecursiveLock)
126    (ff-call (%kernel-import target::kernel-import-new-recursive-lock)
127             :address))))
128
129(defun %make-rwlock-ptr ()
130  (record-system-lock
131   (%setf-macptr
132    (make-gcable-macptr $flags_DisposeRwLock)
133    (ff-call (%kernel-import target::kernel-import-rwlock-new)
134             :address))))
135 
136(defun make-recursive-lock ()
137  (make-lock nil))
138
139(defun %make-lock (pointer name)
140  (gvector :lock pointer 'recursive-lock 0 name nil nil))
141
142(defun make-lock (&optional name)
143  "Create and return a lock object, which can be used for synchronization
144between threads."
145  (%make-lock (%make-recursive-lock-ptr) name))
146
147(defun lock-name (lock)
148  (uvref (require-type lock 'lock) target::lock.name-cell))
149
150(defun recursive-lock-ptr (r)
151  (if (and (eq target::subtag-lock (typecode r))
152           (eq (%svref r target::lock.kind-cell) 'recursive-lock))
153    (%svref r target::lock._value-cell)
154    (report-bad-arg r 'recursive-lock)))
155
156(defun recursive-lock-whostate (r)
157  (if (and (eq target::subtag-lock (typecode r))
158           (eq (%svref r target::lock.kind-cell) 'recursive-lock))
159    (or (%svref r target::lock.whostate-cell)
160        (setf (%svref r target::lock.whostate-cell)
161              (%lock-whostate-string "Lock wait" r)))
162    (if (typep r 'string)
163      r
164      (report-bad-arg r 'recursive-lock))))
165
166
167(defun read-write-lock-ptr (rw)
168  (if (and (eq target::subtag-lock (typecode rw))
169           (eq (%svref rw target::lock.kind-cell) 'read-write-lock))
170    (%svref rw target::lock._value-cell)
171    (report-bad-arg rw 'read-write-lock)))
172
173(defun make-read-write-lock ()
174  "Create and return a read-write lock, which can be used for
175synchronization between threads."
176  (gvector :lock (%make-rwlock-ptr) 'read-write-lock 0 nil nil nil))
177
178(defun rwlock-read-whostate (rw)
179  (if (and (eq target::subtag-lock (typecode rw))
180           (eq (%svref rw target::lock.kind-cell) 'read-write-lock))
181    (or (%svref rw target::lock.whostate-cell)
182        (setf (%svref rw target::lock.whostate-cell)
183              (%lock-whostate-string "Read lock wait" rw)))
184    (report-bad-arg rw 'read-write-lock)))
185
186(defun rwlock-write-whostate (rw)
187  (if (and (eq target::subtag-lock (typecode rw))
188           (eq (%svref rw target::lock.kind-cell) 'read-write-lock))
189    (or (%svref rw target::lock.whostate-2-cell)
190        (setf (%svref rw target::lock.whostate-2-cell)
191              (%lock-whostate-string "Write lock wait" rw)))
192    (report-bad-arg rw 'read-write-lock)))
193 
194
195(defun %make-semaphore-ptr ()
196  (let* ((p (ff-call (%kernel-import target::kernel-import-new-semaphore)
197             :signed-fullword 0
198             :address)))
199    (if (%null-ptr-p p)
200      (error "Can't create semaphore.")
201      (record-system-lock
202       (%setf-macptr
203        (make-gcable-macptr $flags_DisposeSemaphore)
204        p)))))
205
206(defun make-semaphore ()
207  "Create and return a semaphore, which can be used for synchronization
208between threads."
209  (%istruct 'semaphore (%make-semaphore-ptr)))
210
211(defun semaphorep (x)
212  (istruct-typep x 'semaphore))
213
214(setf (type-predicate 'semaphore) 'semaphorep)
215
216(defun make-list (size &key initial-element)
217  "Constructs a list with size elements each set to value"
218  (unless (and (typep size 'fixnum)
219               (>= (the fixnum size) 0))
220    (report-bad-arg size '(and fixnum unsigned-byte)))
221  (locally (declare (fixnum size))
222    (if (>= size (ash 1 16))
223      (values (%allocate-list initial-element size))
224      (do* ((result '() (cons initial-element result)))
225           ((zerop size) result)
226        (decf size)))))
227
228; end
Note: See TracBrowser for help on using the repository browser.