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 ;;;; ATOMIC-INCF and ATOMIC-DECF
  77
  78 (defun expand-atomic-frob (name place diff)
  79   (flet ((invalid-place ()
  80            (error "Invalid first argument to ~S: ~S" name place)))
  81     (unless (consp place)
  82       (invalid-place))
  83     (destructuring-bind (op &rest args) place
  84       (case op
  85         (aref
  86          (when (cddr args)
  87            (invalid-place))
  88          #!+(or x86 x86-64 ppc)
  89          (with-unique-names (array)
  90            `(let ((,array (the (simple-array sb!ext:word (*)) ,(car args))))
  91               (%array-atomic-incf/word
  92                ,array
  93                (%check-bound ,array (array-dimension ,array 0) ,(cadr args))
  94                (logand #.(1- (ash 1 sb!vm:n-word-bits))
  95                        ,(ecase name
  96                                (atomic-incf
  97                                 `(the sb!vm:signed-word ,diff))
  98                                (atomic-decf
  99                                 `(- (the sb!vm:signed-word ,diff))))))))
 100          #!-(or x86 x86-64 ppc)
 101          (with-unique-names (array index old-value)
 102            (let ((incremented-value
 103                   (ecase name
 104                          (atomic-incf
 105                           `(+ ,old-value (the sb!vm:signed-word ,diff)))
 106                          (atomic-decf
 107                           `(- ,old-value (the sb!vm:signed-word ,diff))))))
 108              `(sb!sys:without-interrupts
 109                (let* ((,array ,(car args))
 110                       (,index ,(cadr args))
 111                       (,old-value (aref ,array ,index)))
 112                  (setf (aref ,array ,index)
 113                        (logand #.(1- (ash 1 sb!vm:n-word-bits))
 114                                ,incremented-value))
 115                  ,old-value)))))
 116         (t
 117          (when (cdr args)
 118            (invalid-place))
 119          (let ((dd (info :function :structure-accessor op)))
 120            (if dd
 121                (let* ((structure (dd-name dd))
 122                       (slotd (find op (dd-slots dd) :key #'dsd-accessor-name))
 123                       (index (dsd-index slotd))
 124                       (type (dsd-type slotd)))
 125                  (declare (ignorable structure index))
 126                  (unless (and (eq 'sb!vm:word (dsd-raw-type slotd))
 127                               (type= (specifier-type type) (specifier-type 'sb!vm:word)))
 128                    (error "~S requires a slot of type (UNSIGNED-BYTE ~S), not ~S: ~S"
 129                           name sb!vm:n-word-bits type place))
 130                  (when (dsd-read-only slotd)
 131                    (error "Cannot use ~S with structure accessor for a read-only slot: ~S"
 132                           name place))
 133                  #!+(or x86 x86-64 ppc)
 134                  `(truly-the sb!vm:word
 135                              (%raw-instance-atomic-incf/word
 136                               (the ,structure ,@args) ,index
 137                               (logand #.(1- (ash 1 sb!vm:n-word-bits))
 138                                       ,(ecase name
 139                                               (atomic-incf
 140                                                `(the sb!vm:signed-word ,diff))
 141                                               (atomic-decf
 142                                                `(- (the sb!vm:signed-word ,diff)))))))
 143                  ;; No threads outside x86 and x86-64 for now, so this is easy...
 144                  #!-(or x86 x86-64 ppc)
 145                  (with-unique-names (structure old)
 146                                     `(sb!sys:without-interrupts
 147                                       (let* ((,structure ,@args)
 148                                              (,old (,op ,structure)))
 149                                         (setf (,op ,structure)
 150                                               (logand #.(1- (ash 1 sb!vm:n-word-bits))
 151                                                       ,(ecase name
 152                                                               (atomic-incf
 153                                                                `(+ ,old (the sb!vm:signed-word ,diff)))
 154                                                               (atomic-decf
 155                                                                `(- ,old (the sb!vm:signed-word ,diff))))))
 156                                         ,old))))
 157              (invalid-place))))))))
 158
 159 (defmacro atomic-incf (place &optional (diff 1))
 160   #!+sb-doc
 161   "Atomically increments PLACE by DIFF, and returns the value of PLACE before
 162 the increment.
 163
 164 The incrementation is done using word-size modular arithmetic: on 32 bit
 165 platforms ATOMIC-INCF of #xFFFFFFFF by one results in #x0 being stored in
 166 PLACE.
 167
 168 PLACE must be an accessor form whose CAR is the name of a DEFSTRUCT accessor
 169 whose declared type is (UNSIGNED-BYTE 32) on 32 bit platforms,
 170 and (UNSIGNED-BYTE 64) on 64 bit platforms or an AREF of a (SIMPLE-ARRAY
 171 SB-EXT:WORD (*) -- the type SB-EXT:WORD can be used for this purpose.
 172
 173 DIFF defaults to 1, and must be a (SIGNED-BYTE 32) on 32 bit platforms,
 174 and (SIGNED-BYTE 64) on 64 bit platforms.
 175
 176 EXPERIMENTAL: Interface subject to change."
 177   (expand-atomic-frob 'atomic-incf place diff))
 178
 179 (defmacro atomic-decf (place &optional (diff 1))
 180   #!+sb-doc
 181   "Atomically decrements PLACE by DIFF, and returns the value of PLACE before
 182 the increment.
 183
 184 The decrementation is done using word-size modular arithmetic: on 32 bit
 185 platforms ATOMIC-DECF of #x0 by one results in #xFFFFFFFF being stored in
 186 PLACE.
 187
 188 PLACE must be an accessor form whose CAR is the name of a DEFSTRUCT accessor
 189 whose declared type is (UNSIGNED-BYTE 32) on 32 bit platforms,
 190 and (UNSIGNED-BYTE 64) on 64 bit platforms or an AREF of a (SIMPLE-ARRAY
 191 SB-EXT:WORD (*) -- the type SB-EXT:WORD can be used for this purpose.
 192
 193 DIFF defaults to 1, and must be a (SIGNED-BYTE 32) on 32 bit platforms,
 194 and (SIGNED-BYTE 64) on 64 bit platforms.
 195
 196 EXPERIMENTAL: Interface subject to change."
 197   (expand-atomic-frob 'atomic-decf place diff))
 198
 199 ;; Interpreter stubs for ATOMIC-INCF.
 200 #!+(or x86 x86-64 ppc)
 201 (defun %array-atomic-incf/word (array index diff)
 202   (declare (type (simple-array word (*)) array)
 203            (fixnum index)
 204            (type sb!vm:signed-word diff))
 205   (%array-atomic-incf/word array index diff))
 206
 207 (defun spin-loop-hint ()
 208   #!+sb-doc
 209   "Hints the processor that the current thread is spin-looping."
 210   (spin-loop-hint))
 211
 212 (defun call-hooks (kind hooks &key (on-error :error))
 213   (dolist (hook hooks)
 214     (handler-case
 215         (funcall hook)
 216       (serious-condition (c)
 217         (if (eq :warn on-error)
 218             (warn "Problem running ~A hook ~S:~%  ~A" kind hook c)
 219             (with-simple-restart (continue "Skip this ~A hook." kind)
 220               (error "Problem running ~A hook ~S:~%  ~A" kind hook c)))))))
 221
 222 ;;;; DEFGLOBAL
 223
 224 (defmacro-mundanely defglobal (name value &optional (doc nil docp))
 225   #!+sb-doc
 226   "Defines NAME as a global variable that is always bound. VALUE is evaluated
 227 and assigned to NAME both at compile- and load-time, but only if NAME is not
 228 already bound.
 229
 230 Global variables share their values between all threads, and cannot be
 231 locally bound, declared special, defined as constants, and neither bound
 232 nor defined as symbol macros.
 233
 234 See also the declarations SB-EXT:GLOBAL and SB-EXT:ALWAYS-BOUND."
 235   `(progn
 236      (eval-when (:compile-toplevel)
 237        (let ((boundp (boundp ',name)))
 238          (%compiler-defglobal ',name (unless boundp ,value) boundp)))
 239      (eval-when (:load-toplevel :execute)
 240        (let ((boundp (boundp ',name)))
 241          (%defglobal ',name (unless boundp ,value) boundp ',doc ,docp
 242                      (sb!c:source-location))))))
 243
 244 (defun %compiler-defglobal (name value boundp)
 245   (sb!xc:proclaim `(global ,name))
 246   (unless boundp
 247     #-sb-xc-host
 248     (set-symbol-global-value name value)
 249     #+sb-xc-host
 250     (set name value))
 251   (sb!xc:proclaim `(always-bound ,name)))
 252
 253 (defun %defglobal (name value boundp doc docp source-location)
 254   (%compiler-defglobal name value boundp)
 255   (when docp
 256     (setf (fdocumentation name 'variable) doc))
 257   (sb!c:with-source-location (source-location)
 258     (setf (info :source-location :variable name) source-location))
 259   name)
 260
 261 ;;;; WAIT-FOR -- waiting on arbitrary conditions
 262
 263 (defun %%wait-for (test stop-sec stop-usec)
 264   (declare (function test))
 265   (labels ((try ()
 266              (declare (optimize (safety 0)))
 267              (awhen (funcall test)
 268                (return-from %%wait-for it)))
 269            (tick (sec usec)
 270              (declare (fixnum sec usec))
 271              ;; TICK is microseconds
 272              (+ usec (* 1000000 sec)))
 273            (get-tick ()
 274              (multiple-value-call #'tick
 275                (decode-internal-time (get-internal-real-time)))))
 276     (let* ((timeout-tick (when stop-sec (tick stop-sec stop-usec)))
 277            (start (get-tick))
 278            ;; Rough estimate of how long a single attempt takes.
 279            (try-ticks (progn
 280                         (try) (try) (try)
 281                         (max 1 (truncate (- (get-tick) start) 3)))))
 282       ;; Scale sleeping between attempts:
 283       ;;
 284       ;; Start by sleeping for as many ticks as an average attempt
 285       ;; takes, then doubling for each attempt.
 286       ;;
 287       ;; Max out at 0.1 seconds, or the 2 x time of a single try,
 288       ;; whichever is longer -- with a hard cap of 10 seconds.
 289       ;;
 290       ;; FIXME: Maybe the API should have a :MAX-SLEEP argument?
 291       (loop with max-ticks = (max 100000 (min (* 2 try-ticks)
 292                                               (expt 10 7)))
 293             for scale of-type fixnum = 1
 294             then (let ((x (logand most-positive-fixnum (* 2 scale))))
 295                    (if (> scale x)
 296                        most-positive-fixnum
 297                        x))
 298             do (try)
 299                (let* ((now (get-tick))
 300                       (sleep-ticks (min (* try-ticks scale) max-ticks))
 301                       (sleep
 302                         (if timeout-tick
 303                             ;; If sleep would take us past the
 304                             ;; timeout, shorten it so it's just
 305                             ;; right.
 306                             (if (>= (+ now sleep-ticks) timeout-tick)
 307                                 (- timeout-tick now)
 308                                 sleep-ticks)
 309                             sleep-ticks)))
 310                  (declare (fixnum sleep))
 311                  (cond ((plusp sleep)
 312                         ;; microseconds to seconds and nanoseconds
 313                         (multiple-value-bind (sec nsec)
 314                             (truncate (* 1000 sleep) (expt 10 9))
 315                           (with-interrupts
 316                             (sb!unix:nanosleep sec nsec))))
 317                        (t
 318                         (return-from %%wait-for nil))))))))
 319
 320 (defun %wait-for (test timeout)
 321   (declare (function test))
 322   (tagbody
 323    :restart
 324      (multiple-value-bind (to-sec to-usec stop-sec stop-usec deadlinep)
 325          (decode-timeout timeout)
 326        (declare (ignore to-sec to-usec))
 327        (return-from %wait-for
 328          (or (%%wait-for test stop-sec stop-usec)
 329              (when deadlinep
 330                (signal-deadline)
 331                (go :restart)))))))
 332
 333 (defmacro wait-for (test-form &key timeout)
 334   #!+sb-doc
 335   "Wait until TEST-FORM evaluates to true, then return its primary value.
 336 If TIMEOUT is provided, waits at most approximately TIMEOUT seconds before
 337 returning NIL.
 338
 339 If WITH-DEADLINE has been used to provide a global deadline, signals a
 340 DEADLINE-TIMEOUT if TEST-FORM doesn't evaluate to true before the
 341 deadline.
 342
 343 Experimental: subject to change without prior notice."
 344   `(dx-flet ((wait-for-test () (progn ,test-form)))
 345      (%wait-for #'wait-for-test ,timeout)))
 346
 347 (defmacro with-progressive-timeout ((name &key seconds)
 348                                     &body body)
 349   #!+sb-doc
 350   "Binds NAME as a local function for BODY. Each time #'NAME is called, it
 351 returns SECONDS minus the time that has elapsed since BODY was entered, or
 352 zero if more time than SECONDS has elapsed. If SECONDS is NIL, #'NAME
 353 returns NIL each time."
 354   (with-unique-names (deadline time-left sec)
 355     `(let* ((,sec ,seconds)
 356             (,deadline
 357               (when ,sec
 358                 (+ (get-internal-real-time)
 359                    (round (* ,seconds internal-time-units-per-second))))))
 360        (flet ((,name ()
 361                 (when ,deadline
 362                   (let ((,time-left (- ,deadline (get-internal-real-time))))
 363                     (if (plusp ,time-left)
 364                         (* (coerce ,time-left 'single-float)
 365                            ,(/ 1.0 internal-time-units-per-second))
 366                         0)))))
 367          ,@body))))
 368
 369 (defmacro atomic-update (place update-fn &rest arguments &environment env)
 370   #!+sb-doc
 371   "Updates PLACE atomically to the value returned by calling function
 372 designated by UPDATE-FN with ARGUMENTS and the previous value of PLACE.
 373
 374 PLACE may be read and UPDATE-FN evaluated and called multiple times before the
 375 update succeeds: atomicity in this context means that value of place did not
 376 change between the time it was read, and the time it was replaced with the
 377 computed value.
 378
 379 PLACE can be any place supported by SB-EXT:COMPARE-AND-SWAP.
 380
 381 Examples:
 382
 383   ;;; Conses T to the head of FOO-LIST.
 384   (defstruct foo list)
 385   (defvar *foo* (make-foo))
 386   (atomic-update (foo-list *foo*) #'cons t)
 387
 388   (let ((x (cons :count 0)))
 389      (mapc #'sb-thread:join-thread
 390            (loop repeat 1000
 391                  collect (sb-thread:make-thread
 392                           (lambda ()
 393                             (loop repeat 1000
 394                                   do (atomic-update (cdr x) #'1+)
 395                                      (sleep 0.00001))))))
 396      ;; Guaranteed to be (:COUNT . 1000000) -- if you replace
 397      ;; atomic update with (INCF (CDR X)) above, the result becomes
 398      ;; unpredictable.
 399      x)
 400 "
 401   (multiple-value-bind (vars vals old new cas-form read-form)
 402       (get-cas-expansion place env)
 403     `(let* (,@(mapcar 'list vars vals)
 404             (,old ,read-form))
 405        (loop for ,new = (funcall ,update-fn ,@arguments ,old)
 406              until (eq ,old (setf ,old ,cas-form))
 407              finally (return ,new)))))
 408
 409 (defmacro atomic-push (obj place &environment env)
 410   #!+sb-doc
 411   "Like PUSH, but atomic. PLACE may be read multiple times before
 412 the operation completes -- the write does not occur until such time
 413 that no other thread modified PLACE between the read and the write.
 414
 415 Works on all CASable places."
 416   (multiple-value-bind (vars vals old new cas-form read-form)
 417       (get-cas-expansion place env)
 418     `(let* (,@(mapcar 'list vars vals)
 419             (,old ,read-form)
 420             (,new (cons ,obj ,old)))
 421        (loop until (eq ,old (setf ,old ,cas-form))
 422              do (setf (cdr ,new) ,old)
 423              finally (return ,new)))))
 424
 425 (defmacro atomic-pop (place &environment env)
 426   #!+sb-doc
 427   "Like POP, but atomic. PLACE may be read multiple times before
 428 the operation completes -- the write does not occur until such time
 429 that no other thread modified PLACE between the read and the write.
 430
 431 Works on all CASable places."
 432   (multiple-value-bind (vars vals old new cas-form read-form)
 433       (get-cas-expansion place env)
 434     `(let* (,@(mapcar 'list vars vals))
 435        (loop for ,old = ,read-form
 436              for ,new = (cdr ,old)
 437              until (eq ,old (setf ,old ,cas-form))
 438              finally (return (car ,old))))))