[b85af7]: src / code / late-extensions.lisp Maximize Restore History

Download this file

late-extensions.lisp    431 lines (393 with data), 19.4 kB

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