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

Last change on this file since 10453 was 10453, checked in by gb, 11 years ago

Split off %MAKE-LOCK from MAKE-LOCK, so that we can ... make lisp
lock objects that encapsulate locks allocated in the kernel (without
going through the system-lock/gcable-pointer stuff.)

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