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

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

Try to deal with the "SIMPLE-BASE-STRING, all of it" case in
%CSTR-POINTER; deal with all other cases in %CSTR-SEGMENT-POINTER.

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