source: branches/qres/ccl/level-0/l0-aprims.lisp @ 14055

Last change on this file since 14055 was 13070, checked in by gz, 10 years ago

r13066, r13067 from trunk: copyrights etc

  • 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 (make-string 1 :initial-element thing))))
105
106
107(defun dereference-base-string (s)
108  (multiple-value-bind (vector offset) (array-data-and-offset s)
109    (unless (typep vector 'simple-base-string) (report-bad-arg s 'base-string))
110    (values vector offset (length s))))
111
112(defun make-gcable-macptr (flags)
113  (let ((v (%alloc-misc target::xmacptr.element-count target::subtag-macptr)))
114    (setf (uvref v target::xmacptr.address-cell) 0) ; ?? yup.
115    (setf (uvref v target::xmacptr.flags-cell) flags)
116    (set-%gcable-macptrs% v)
117    v))
118
119(defun %make-recursive-lock-ptr ()
120  (record-system-lock
121   (%setf-macptr
122    (make-gcable-macptr $flags_DisposeRecursiveLock)
123    (ff-call (%kernel-import target::kernel-import-new-recursive-lock)
124             :address))))
125
126(defun %make-rwlock-ptr ()
127  (record-system-lock
128   (%setf-macptr
129    (make-gcable-macptr $flags_DisposeRwLock)
130    (ff-call (%kernel-import target::kernel-import-rwlock-new)
131             :address))))
132 
133(defun make-recursive-lock ()
134  (make-lock nil))
135
136(defun %make-lock (pointer name)
137  (gvector :lock pointer 'recursive-lock 0 name nil nil))
138
139(defun make-lock (&optional name)
140  "Create and return a lock object, which can be used for synchronization
141between threads."
142  (%make-lock (%make-recursive-lock-ptr) name))
143
144(defun lock-name (lock)
145  (uvref (require-type lock 'lock) target::lock.name-cell))
146
147(defun recursive-lock-ptr (r)
148  (if (and (eq target::subtag-lock (typecode r))
149           (eq (%svref r target::lock.kind-cell) 'recursive-lock))
150    (%svref r target::lock._value-cell)
151    (report-bad-arg r 'recursive-lock)))
152
153(defun recursive-lock-whostate (r)
154  (if (and (eq target::subtag-lock (typecode r))
155           (eq (%svref r target::lock.kind-cell) 'recursive-lock))
156    (or (%svref r target::lock.whostate-cell)
157        (setf (%svref r target::lock.whostate-cell)
158              (%lock-whostate-string "Lock wait" r)))
159    (report-bad-arg r 'recursive-lock)))
160
161
162(defun read-write-lock-ptr (rw)
163  (if (and (eq target::subtag-lock (typecode rw))
164           (eq (%svref rw target::lock.kind-cell) 'read-write-lock))
165    (%svref rw target::lock._value-cell)
166    (report-bad-arg rw 'read-write-lock)))
167
168(defun make-read-write-lock ()
169  "Create and return a read-write lock, which can be used for
170synchronization between threads."
171  (gvector :lock (%make-rwlock-ptr) 'read-write-lock 0 nil nil nil))
172
173(defun rwlock-read-whostate (rw)
174  (if (and (eq target::subtag-lock (typecode rw))
175           (eq (%svref rw target::lock.kind-cell) 'read-write-lock))
176    (or (%svref rw target::lock.whostate-cell)
177        (setf (%svref rw target::lock.whostate-cell)
178              (%lock-whostate-string "Read lock wait" rw)))
179    (report-bad-arg rw 'read-write-lock)))
180
181(defun rwlock-write-whostate (rw)
182  (if (and (eq target::subtag-lock (typecode rw))
183           (eq (%svref rw target::lock.kind-cell) 'read-write-lock))
184    (or (%svref rw target::lock.whostate-2-cell)
185        (setf (%svref rw target::lock.whostate-2-cell)
186              (%lock-whostate-string "Write lock wait" rw)))
187    (report-bad-arg rw 'read-write-lock)))
188 
189
190(defun %make-semaphore-ptr ()
191  (let* ((p (ff-call (%kernel-import target::kernel-import-new-semaphore)
192             :signed-fullword 0
193             :address)))
194    (if (%null-ptr-p p)
195      (error "Can't create semaphore.")
196      (record-system-lock
197       (%setf-macptr
198        (make-gcable-macptr $flags_DisposeSemaphore)
199        p)))))
200
201(defun make-semaphore ()
202  "Create and return a semaphore, which can be used for synchronization
203between threads."
204  (%istruct 'semaphore (%make-semaphore-ptr)))
205
206(defun semaphorep (x)
207  (istruct-typep x 'semaphore))
208
209(setf (type-predicate 'semaphore) 'semaphorep)
210
211(defun make-list (size &key initial-element)
212  "Constructs a list with size elements each set to value"
213  (unless (and (typep size 'fixnum)
214               (>= (the fixnum size) 0))
215    (report-bad-arg size '(and fixnum unsigned-byte)))
216  (locally (declare (fixnum size))
217    (if (>= size (ash 1 16))
218      (values (%allocate-list initial-element size))
219      (do* ((result '() (cons initial-element result)))
220           ((zerop size) result)
221        (decf size)))))
222
223; end
Note: See TracBrowser for help on using the repository browser.