Avoid some exceptions in WAIT-UNTIL-FD-USABLE on Windows
[sbcl.git] / src / code / late-extensions.lisp
1 ;;;; various extensions (including SB-INT "internal extensions")
2 ;;;; available both in the cross-compilation host Lisp and in the
3 ;;;; target SBCL, but which can't be defined on the target until until
4 ;;;; some significant amount of machinery (e.g. error-handling) is
5 ;;;; defined
6
7 ;;;; This software is part of the SBCL system. See the README file for
8 ;;;; more information.
9 ;;;;
10 ;;;; This software is derived from the CMU CL system, which was
11 ;;;; written at Carnegie Mellon University and released into the
12 ;;;; public domain. The software is in the public domain and is
13 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
14 ;;;; files for more information.
15
16 (in-package "SB!IMPL")
17
18 ;;; Is X a list for which LENGTH is meaningful, i.e. a list which is
19 ;;; not improper and which is not circular?
20 (defun list-with-length-p (x)
21   (values (ignore-errors (list-length x))))
22
23 ;;; not used in 0.7.8, but possibly useful for defensive programming
24 ;;; in e.g. (COERCE ... 'VECTOR)
25 ;;;(defun list-length-or-die (x)
26 ;;;  (or (list-length x)
27 ;;;      ;; not clear how to do this best:
28 ;;;      ;;   * Should this be a TYPE-ERROR? Colloquially that'd make
29 ;;;      ;;     lots of sense, but since I'm not sure how to express
30 ;;;      ;;     "noncircular list" as a Lisp type expression, coding
31 ;;;      ;;     it seems awkward.
32 ;;;      ;;   * Should the ERROR object include the offending value?
33 ;;;      ;;     Ordinarily that's helpful, but if the user doesn't have
34 ;;;      ;;     his printer set up to deal with cyclicity, we might not
35 ;;;      ;;     be doing him a favor by printing the object here.
36 ;;;      ;; -- WHN 2002-10-19
37 ;;;      (error "can't calculate length of cyclic list")))
38
39 ;;; This is used in constructing arg lists for debugger printing,
40 ;;; and when needing to print unbound slots in PCL.
41 (defstruct (unprintable-object
42             (:constructor make-unprintable-object (string))
43             (:print-object (lambda (x s)
44                              (print-unreadable-object (x s)
45                                (write-string (unprintable-object-string x) s))))
46             (:copier nil))
47   string)
48
49 ;;; Used internally, but it would be nice to provide something
50 ;;; like this for users as well.
51 ;;;
52 ;;; FIXME / IMPORTANT: If the slot is raw, the address is correct only for
53 ;;; instances of the specified class, not its subclasses!
54 #!+sb-thread
55 (defmacro define-structure-slot-addressor (name &key structure slot)
56   (let* ((dd (find-defstruct-description structure t))
57          (slotd (when dd (find slot (dd-slots dd) :key #'dsd-name)))
58          (index (when slotd (dsd-index slotd)))
59          (raw-type (dsd-raw-type slotd)))
60     (unless index
61       (error "Slot ~S not found in ~S." slot structure))
62     `(progn
63        (declaim (inline ,name))
64        (defun ,name (instance)
65          (declare (type ,structure instance) (optimize speed))
66          (sb!ext:truly-the
67           sb!vm:word
68           (+ (sb!kernel:get-lisp-obj-address instance)
69              (- (* ,(if (eq t raw-type)
70                         (+ sb!vm:instance-slots-offset index)
71                         (- (1+ (sb!kernel::dd-instance-length dd)) sb!vm:instance-slots-offset index
72                            (1- (sb!kernel::raw-slot-words raw-type))))
73                    sb!vm:n-word-bytes)
74                 sb!vm:instance-pointer-lowtag)))))))
75
76 (defmacro compare-and-swap (place old new &environment env)
77   "Atomically stores NEW in PLACE if OLD matches the current value of PLACE.
78 Two values are considered to match if they are EQ. Returns the previous value
79 of PLACE: if the returned value is EQ to OLD, the swap was carried out.
80
81 PLACE must be an accessor form whose CAR is one of the following:
82
83  CAR, CDR, FIRST, REST, SYMBOL-PLIST, SYMBOL-VALUE, SVREF
84
85 or the name of a DEFSTRUCT created accessor for a slot whose declared type is
86 either FIXNUM or T. Results are unspecified if the slot has a declared type
87 other then FIXNUM or T.
88
89 EXPERIMENTAL: Interface subject to change."
90   (flet ((invalid-place ()
91            (error "Invalid first argument to COMPARE-AND-SWAP: ~S" place)))
92     (unless (consp place)
93       (invalid-place))
94   ;; FIXME: Not the nicest way to do this...
95   (destructuring-bind (op &rest args) place
96     (case op
97       ((car first)
98        `(%compare-and-swap-car (the cons ,@args) ,old ,new))
99       ((cdr rest)
100        `(%compare-and-swap-cdr (the cons ,@args) ,old ,new))
101       (symbol-plist
102        `(%compare-and-swap-symbol-plist (the symbol ,@args) ,old (the list ,new)))
103       (symbol-value
104        (destructuring-bind (name) args
105          (flet ((slow (symbol)
106                   (with-unique-names (n-symbol n-old n-new)
107                     `(let ((,n-symbol ,symbol)
108                            (,n-old ,old)
109                            (,n-new ,new))
110                        (declare (symbol ,n-symbol))
111                        (about-to-modify-symbol-value ,n-symbol 'compare-and-swap ,n-new)
112                        (%compare-and-swap-symbol-value ,n-symbol ,n-old ,n-new)))))
113            (if (sb!xc:constantp name env)
114                (let ((cname (constant-form-value name env)))
115                  (if (eq :special (info :variable :kind cname))
116                      ;; Since we know the symbol is a special, we can just generate
117                      ;; the type check.
118                      `(%compare-and-swap-symbol-value
119                        ',cname ,old (the ,(info :variable :type cname) ,new))
120                      (slow (list 'quote cname))))
121                (slow name)))))
122       (svref
123        (let ((vector (car args))
124              (index (cadr args)))
125          (unless (and vector index (not (cddr args)))
126            (invalid-place))
127          (with-unique-names (v)
128            `(let ((,v ,vector))
129               (declare (simple-vector ,v))
130               (%compare-and-swap-svref ,v (%check-bound ,v (length ,v) ,index) ,old ,new)))))
131       (t
132        (let ((dd (info :function :structure-accessor op)))
133          (if dd
134              (let* ((structure (dd-name dd))
135                     (slotd (find op (dd-slots dd) :key #'dsd-accessor-name))
136                     (index (dsd-index slotd))
137                     (type (dsd-type slotd)))
138                (unless (eq t (dsd-raw-type slotd))
139                  (error "Cannot use COMPARE-AND-SWAP with structure accessor for a typed slot: ~S"
140                         place))
141                (when (dsd-read-only slotd)
142                  (error "Cannot use COMPARE-AND-SWAP with structure accessor for a read-only slot: ~S"
143                         place))
144                `(truly-the (values ,type &optional)
145                            (%compare-and-swap-instance-ref (the ,structure ,@args)
146                                                            ,index
147                                                            (the ,type ,old) (the ,type ,new))))
148              (error "Invalid first argument to COMPARE-AND-SWAP: ~S" place))))))))
149
150 (macrolet ((def (name lambda-list ref &optional set)
151              #!+compare-and-swap-vops
152              (declare (ignore ref set))
153              `(defun ,name (,@lambda-list old new)
154                 #!+compare-and-swap-vops
155                 (,name ,@lambda-list old new)
156                 #!-compare-and-swap-vops
157                 (let ((current (,ref ,@lambda-list)))
158                   (when (eq current old)
159                     ,(if set
160                          `(,set ,@lambda-list new)
161                          `(setf (,ref ,@lambda-list) new)))
162                   current))))
163   (def %compare-and-swap-car (cons) car)
164   (def %compare-and-swap-cdr (cons) cdr)
165   (def %compare-and-swap-instance-ref (instance index) %instance-ref %instance-set)
166   (def %compare-and-swap-symbol-plist (symbol) symbol-plist)
167   (def %compare-and-swap-symbol-value (symbol) symbol-value)
168   (def %compare-and-swap-svref (vector index) svref))
169
170 (defun expand-atomic-frob (name place diff)
171   (flet ((invalid-place ()
172            (error "Invalid first argument to ~S: ~S" name place)))
173     (unless (consp place)
174       (invalid-place))
175     (destructuring-bind (op &rest args) place
176       (case op
177         (aref
178          (when (cddr args)
179            (invalid-place))
180          #!+(or x86 x86-64 ppc)
181          (with-unique-names (array)
182            `(let ((,array (the (simple-array sb!ext:word (*)) ,(car args))))
183               (%array-atomic-incf/word
184                ,array
185                (%check-bound ,array (array-dimension ,array 0) ,(cadr args))
186                (logand #.(1- (ash 1 sb!vm:n-word-bits))
187                        ,(ecase name
188                                (atomic-incf
189                                 `(the sb!vm:signed-word ,diff))
190                                (atomic-decf
191                                 `(- (the sb!vm:signed-word ,diff))))))))
192          #!-(or x86 x86-64 ppc)
193          (with-unique-names (array index old-value)
194            (let ((incremented-value
195                   (ecase name
196                          (atomic-incf
197                           `(+ ,old-value (the sb!vm:signed-word ,diff)))
198                          (atomic-decf
199                           `(- ,old-value (the sb!vm:signed-word ,diff))))))
200              `(sb!sys:without-interrupts
201                (let* ((,array ,(car args))
202                       (,index ,(cadr args))
203                       (,old-value (aref ,array ,index)))
204                  (setf (aref ,array ,index)
205                        (logand #.(1- (ash 1 sb!vm:n-word-bits))
206                                ,incremented-value))
207                  ,old-value)))))
208         (t
209          (when (cdr args)
210            (invalid-place))
211          (let ((dd (info :function :structure-accessor op)))
212            (if dd
213                (let* ((structure (dd-name dd))
214                       (slotd (find op (dd-slots dd) :key #'dsd-accessor-name))
215                       (index (dsd-index slotd))
216                       (type (dsd-type slotd)))
217                  (declare (ignorable structure index))
218                  (unless (and (eq 'sb!vm:word (dsd-raw-type slotd))
219                               (type= (specifier-type type) (specifier-type 'sb!vm:word)))
220                    (error "~S requires a slot of type (UNSIGNED-BYTE ~S), not ~S: ~S"
221                           name sb!vm:n-word-bits type place))
222                  (when (dsd-read-only slotd)
223                    (error "Cannot use ~S with structure accessor for a read-only slot: ~S"
224                           name place))
225                  #!+(or x86 x86-64 ppc)
226                  `(truly-the sb!vm:word
227                              (%raw-instance-atomic-incf/word
228                               (the ,structure ,@args) ,index
229                               (logand #.(1- (ash 1 sb!vm:n-word-bits))
230                                       ,(ecase name
231                                               (atomic-incf
232                                                `(the sb!vm:signed-word ,diff))
233                                               (atomic-decf
234                                                `(- (the sb!vm:signed-word ,diff)))))))
235                  ;; No threads outside x86 and x86-64 for now, so this is easy...
236                  #!-(or x86 x86-64 ppc)
237                  (with-unique-names (structure old)
238                                     `(sb!sys:without-interrupts
239                                       (let* ((,structure ,@args)
240                                              (,old (,op ,structure)))
241                                         (setf (,op ,structure)
242                                               (logand #.(1- (ash 1 sb!vm:n-word-bits))
243                                                       ,(ecase name
244                                                               (atomic-incf
245                                                                `(+ ,old (the sb!vm:signed-word ,diff)))
246                                                               (atomic-decf
247                                                                `(- ,old (the sb!vm:signed-word ,diff))))))
248                                         ,old))))
249              (invalid-place))))))))
250
251 (defmacro atomic-incf (place &optional (diff 1))
252   #!+sb-doc
253   "Atomically increments PLACE by DIFF, and returns the value of PLACE before
254 the increment.
255
256 The incrementation is done using word-size modular arithmetic: on 32 bit
257 platforms ATOMIC-INCF of #xFFFFFFFF by one results in #x0 being stored in
258 PLACE.
259
260 PLACE must be an accessor form whose CAR is the name of a DEFSTRUCT accessor
261 whose declared type is (UNSIGNED-BYTE 32) on 32 bit platforms,
262 and (UNSIGNED-BYTE 64) on 64 bit platforms or an AREF of a (SIMPLE-ARRAY
263 SB-EXT:WORD (*) -- the type SB-EXT:WORD can be used for this purpose.
264
265 DIFF defaults to 1, and must be a (SIGNED-BYTE 32) on 32 bit platforms,
266 and (SIGNED-BYTE 64) on 64 bit platforms.
267
268 EXPERIMENTAL: Interface subject to change."
269   (expand-atomic-frob 'atomic-incf place diff))
270
271 (defmacro atomic-decf (place &optional (diff 1))
272   #!+sb-doc
273   "Atomically decrements PLACE by DIFF, and returns the value of PLACE before
274 the increment.
275
276 The decrementation is done using word-size modular arithmetic: on 32 bit
277 platforms ATOMIC-DECF of #x0 by one results in #xFFFFFFFF being stored in
278 PLACE.
279
280 PLACE must be an accessor form whose CAR is the name of a DEFSTRUCT accessor
281 whose declared type is (UNSIGNED-BYTE 32) on 32 bit platforms,
282 and (UNSIGNED-BYTE 64) on 64 bit platforms or an AREF of a (SIMPLE-ARRAY
283 SB-EXT:WORD (*) -- the type SB-EXT:WORD can be used for this purpose.
284
285 DIFF defaults to 1, and must be a (SIGNED-BYTE 32) on 32 bit platforms,
286 and (SIGNED-BYTE 64) on 64 bit platforms.
287
288 EXPERIMENTAL: Interface subject to change."
289   (expand-atomic-frob 'atomic-decf place diff))
290
291 ;; Interpreter stubs for ATOMIC-INCF.
292 #!+(or x86 x86-64 ppc)
293 (defun %array-atomic-incf/word (array index diff)
294   (declare (type (simple-array word (*)) array)
295            (fixnum index)
296            (type sb!vm:signed-word diff))
297   (%array-atomic-incf/word array index diff))
298
299 (defun call-hooks (kind hooks &key (on-error :error))
300   (dolist (hook hooks)
301     (handler-case
302         (funcall hook)
303       (serious-condition (c)
304         (if (eq :warn on-error)
305             (warn "Problem running ~A hook ~S:~%  ~A" kind hook c)
306             (with-simple-restart (continue "Skip this ~A hook." kind)
307               (error "Problem running ~A hook ~S:~%  ~A" kind hook c)))))))
308
309 ;;;; DEFGLOBAL
310
311 (defmacro-mundanely defglobal (name value &optional (doc nil docp))
312   #!+sb-doc
313   "Defines NAME as a global variable that is always bound. VALUE is evaluated
314 and assigned to NAME both at compile- and load-time, but only if NAME is not
315 already bound.
316
317 Global variables share their values between all threads, and cannot be
318 locally bound, declared special, defined as constants, and neither bound
319 nor defined as symbol macros.
320
321 See also the declarations SB-EXT:GLOBAL and SB-EXT:ALWAYS-BOUND."
322   `(progn
323      (eval-when (:compile-toplevel)
324        (let ((boundp (boundp ',name)))
325          (%compiler-defglobal ',name (unless boundp ,value) boundp)))
326      (eval-when (:load-toplevel :execute)
327        (let ((boundp (boundp ',name)))
328          (%defglobal ',name (unless boundp ,value) boundp ',doc ,docp
329                      (sb!c:source-location))))))
330
331 (defun %compiler-defglobal (name value boundp)
332   (sb!xc:proclaim `(global ,name))
333   (unless boundp
334     #-sb-xc-host
335     (set-symbol-global-value name value)
336     #+sb-xc-host
337     (set name value))
338   (sb!xc:proclaim `(always-bound ,name)))
339
340 (defun %defglobal (name value boundp doc docp source-location)
341   (%compiler-defglobal name value boundp)
342   (when docp
343     (setf (fdocumentation name 'variable) doc))
344   (sb!c:with-source-location (source-location)
345     (setf (info :source-location :variable name) source-location))
346   name)