arch-assem.S: Update fun-end breakpoint magic for pickier make-lisp-obj.

[sbcl.git] / src / code / late-extensions.lisp

diff --git a/src/code/late-extensions.lisp b/src/code/late-extensions.lisp
index 947d450..45fe8b4 100644 (file)
--- a/src/code/late-extensions.lisp
+++ b/src/code/late-extensions.lisp
@@ -177,7 +177,7 @@ EXPERIMENTAL: Interface subject to change."
         (aref
          (when (cddr args)
            (invalid-place))
-         #!+(or x86-64)
+         #!+(or x86 x86-64 ppc)
          (with-unique-names (array)
            `(let ((,array (the (simple-array sb!ext:word (*)) ,(car args))))
               (%array-atomic-incf/word
@@ -189,7 +189,7 @@ EXPERIMENTAL: Interface subject to change."
                                 `(the sb!vm:signed-word ,diff))
                                (atomic-decf
                                 `(- (the sb!vm:signed-word ,diff))))))))
-         #!-(or x86-64)
+         #!-(or x86 x86-64 ppc)
          (with-unique-names (array index old-value)
            (let ((incremented-value
                   (ecase name
@@ -289,13 +289,18 @@ EXPERIMENTAL: Interface subject to change."
   (expand-atomic-frob 'atomic-decf place diff))
 
 ;; Interpreter stubs for ATOMIC-INCF.
-#!+(or x86-64)
+#!+(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
@@ -344,3 +349,88 @@ See also the declarations SB-EXT:GLOBAL and SB-EXT:ALWAYS-BOUND."
   (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 stop-sec stop-usec)
+  (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)))))
+    (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))))
+                       (t
+                        (return-from %%wait-for nil))))))))
+
+(defun %wait-for (test timeout)
+  (declare (function test))
+  (tagbody
+   :restart
+     (multiple-value-bind (to-sec to-usec stop-sec stop-usec deadlinep)
+         (decode-timeout timeout)
+       (declare (ignore to-sec to-usec))
+       (return-from %wait-for
+         (or (%%wait-for test stop-sec stop-usec)
+             (when deadlinep
+               (signal-deadline)
+               (go :restart)))))))
+
+(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)))