source: branches/working-0710/ccl/level-0/l0-aprims.lisp @ 7390

Last change on this file since 7390 was 7390, checked in by gb, 13 years ago

%SYSTEM-LOCK% needs to be made even earlier now.
Some new rwlock stuff.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 5.9 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 (&optional name)
136  "Create and return a lock object, which can be used for synchronization
137between threads."
138  (gvector :lock (%make-recursive-lock-ptr) 'recursive-lock 0 name))
139
140(defun lock-name (lock)
141  (uvref (require-type lock 'lock) target::lock.name-cell))
142
143(defun recursive-lock-ptr (r)
144  (if (and (eq target::subtag-lock (typecode r))
145           (eq (%svref r target::lock.kind-cell) 'recursive-lock))
146    (%svref r target::lock._value-cell)
147    (report-bad-arg r 'recursive-lock)))
148
149(defun read-write-lock-ptr (rw)
150  (if (and (eq target::subtag-lock (typecode rw))
151           (eq (%svref rw target::lock.kind-cell) 'read-write-lock))
152    (%svref rw target::lock._value-cell)
153    (report-bad-arg rw 'read-write-lock)))
154
155(defun make-read-write-lock ()
156  "Create and return a read-write lock, which can be used for
157synchronization between threads."
158  (gvector :lock (%make-rwlock-ptr) 'read-write-lock 0 nil))
159
160
161(defun %make-semaphore-ptr ()
162  (let* ((p (ff-call (%kernel-import target::kernel-import-new-semaphore)
163             :signed-fullword 0
164             :address)))
165    (if (%null-ptr-p p)
166      (error "Can't create semaphore.")
167      (record-system-lock
168       (%setf-macptr
169        (make-gcable-macptr $flags_DisposeSemaphore)
170        p)))))
171
172(defun make-semaphore ()
173  "Create and return a semaphore, which can be used for synchronization
174between threads."
175  (%istruct 'semaphore (%make-semaphore-ptr)))
176
177(defun semaphorep (x)
178  (istruct-typep x 'semaphore))
179
180(setf (type-predicate 'semaphore) 'semaphorep)
181
182; end
Note: See TracBrowser for help on using the repository browser.