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 21df767..45fe8b4 100644 (file)
--- a/src/code/late-extensions.lisp
+++ b/src/code/late-extensions.lisp
@@ -296,6 +296,11 @@ EXPERIMENTAL: Interface subject to change."
            (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
@@ -345,15 +350,87 @@ See also the declarations SB-EXT:GLOBAL and SB-EXT:ALWAYS-BOUND."
     (setf (info :source-location :variable name) source-location))
   name)
 
-;;; Needs WITH-COMPILATION-UNIT, hence not in toplevel.lisp.
-(defun load-script (pathname)
-  ;; WITH-COMPILATION-UNIT to avoid style-warnings for
-  ;; forward-referenced functions in scripts. Needs to be around
-  ;; HANDLING-END-OF-THE-WORLD so that we don't unwind from it, which
-  ;; would cause a bogus complaint about a fatal error...
-  (sb!xc:with-compilation-unit ()
-    (handling-end-of-the-world
-      (with-open-file (f pathname :element-type :default)
-        (sb!fasl::maybe-skip-shebang-line f)
-        (load f :verbose nil :print nil))
-      (quit))))
+;;;; 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)))