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 spin-loop-hint ()
 300   #!+sb-doc
 301   "Hints the processor that the current thread is spin-looping."
 302   (spin-loop-hint))
 303
 304 (defun call-hooks (kind hooks &key (on-error :error))
 305   (dolist (hook hooks)
 306     (handler-case
 307         (funcall hook)
 308       (serious-condition (c)
 309         (if (eq :warn on-error)
 310             (warn "Problem running ~A hook ~S:~%  ~A" kind hook c)
 311             (with-simple-restart (continue "Skip this ~A hook." kind)
 312               (error "Problem running ~A hook ~S:~%  ~A" kind hook c)))))))
 313
 314 ;;;; DEFGLOBAL
 315
 316 (defmacro-mundanely defglobal (name value &optional (doc nil docp))
 317   #!+sb-doc
 318   "Defines NAME as a global variable that is always bound. VALUE is evaluated
 319 and assigned to NAME both at compile- and load-time, but only if NAME is not
 320 already bound.
 321
 322 Global variables share their values between all threads, and cannot be
 323 locally bound, declared special, defined as constants, and neither bound
 324 nor defined as symbol macros.
 325
 326 See also the declarations SB-EXT:GLOBAL and SB-EXT:ALWAYS-BOUND."
 327   `(progn
 328      (eval-when (:compile-toplevel)
 329        (let ((boundp (boundp ',name)))
 330          (%compiler-defglobal ',name (unless boundp ,value) boundp)))
 331      (eval-when (:load-toplevel :execute)
 332        (let ((boundp (boundp ',name)))
 333          (%defglobal ',name (unless boundp ,value) boundp ',doc ,docp
 334                      (sb!c:source-location))))))
 335
 336 (defun %compiler-defglobal (name value boundp)
 337   (sb!xc:proclaim `(global ,name))
 338   (unless boundp
 339     #-sb-xc-host
 340     (set-symbol-global-value name value)
 341     #+sb-xc-host
 342     (set name value))
 343   (sb!xc:proclaim `(always-bound ,name)))
 344
 345 (defun %defglobal (name value boundp doc docp source-location)
 346   (%compiler-defglobal name value boundp)
 347   (when docp
 348     (setf (fdocumentation name 'variable) doc))
 349   (sb!c:with-source-location (source-location)
 350     (setf (info :source-location :variable name) source-location))
 351   name)
 352
 353 ;;;; WAIT-FOR -- waiting on arbitrary conditions
 354
 355 (defun %wait-for (test timeout)
 356   (declare (function test))
 357   (labels ((try ()
 358              (declare (optimize (safety 0)))
 359              (awhen (funcall test)
 360                (return-from %wait-for it)))
 361            (tick (sec usec)
 362              (declare (fixnum sec usec))
 363              ;; TICK is microseconds
 364              (+ usec (* 1000000 sec)))
 365            (get-tick ()
 366              (multiple-value-call #'tick
 367                (decode-internal-time (get-internal-real-time)))))
 368     ;; Compute timeout: must come first so that deadlines already passed
 369     ;; are noticed before the first try.
 370     (multiple-value-bind (to-sec to-usec stop-sec stop-usec deadlinep)
 371         (decode-timeout timeout)
 372       (declare (ignore to-sec to-usec))
 373       (let* ((timeout-tick (when stop-sec (tick stop-sec stop-usec)))
 374              (start (get-tick))
 375              ;; Rough estimate of how long a single attempt takes.
 376              (try-ticks (progn
 377                             (try) (try) (try)
 378                             (max 1 (truncate (- (get-tick) start) 3)))))
 379         ;; Scale sleeping between attempts:
 380         ;;
 381         ;; Start by sleeping for as many ticks as an average attempt
 382         ;; takes, then doubling for each attempt.
 383         ;;
 384         ;; Max out at 0.1 seconds, or the 2 x time of a single try,
 385         ;; whichever is longer -- with a hard cap of 10 seconds.
 386         ;;
 387         ;; FIXME: Maybe the API should have a :MAX-SLEEP argument?
 388         (loop with max-ticks = (max 100000 (min (* 2 try-ticks)
 389                                                 (expt 10 7)))
 390               for scale of-type fixnum = 1
 391               then (let ((x (logand most-positive-fixnum (* 2 scale))))
 392                      (if (> scale x)
 393                          most-positive-fixnum
 394                          x))
 395               do (try)
 396                  (let* ((now (get-tick))
 397                         (sleep-ticks (min (* try-ticks scale) max-ticks))
 398                         (sleep
 399                           (if timeout-tick
 400                               ;; If sleep would take us past the
 401                               ;; timeout, shorten it so it's just
 402                               ;; right.
 403                               (if (>= (+ now sleep-ticks) timeout-tick)
 404                                   (- timeout-tick now)
 405                                   sleep-ticks)
 406                               sleep-ticks)))
 407                    (declare (fixnum sleep))
 408                    (cond ((plusp sleep)
 409                           ;; microseconds to seconds and nanoseconds
 410                           (multiple-value-bind (sec nsec)
 411                               (truncate (* 1000 sleep) (expt 10 9))
 412                             (with-interrupts
 413                               (sb!unix:nanosleep sec nsec))))
 414                          (deadlinep
 415                           (signal-deadline))
 416                          (t
 417                           (return-from %wait-for nil)))))))))
 418
 419 (defmacro wait-for (test-form &key timeout)
 420   "Wait until TEST-FORM evaluates to true, then return its primary value.
 421 If TIMEOUT is provided, waits at most approximately TIMEOUT seconds before
 422 returning NIL.
 423
 424 If WITH-DEADLINE has been used to provide a global deadline, signals a
 425 DEADLINE-TIMEOUT if TEST-FORM doesn't evaluate to true before the
 426 deadline.
 427
 428 Experimental: subject to change without prior notice."
 429   `(dx-flet ((wait-for-test () (progn ,test-form)))
 430      (%wait-for #'wait-for-test ,timeout)))