X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdeadline.lisp;h=d2577dc255735168f356e6156413fbf834a8a4fe;hb=6d9e2243954872457115bbb9ac1ecb1d161acced;hp=97a147b717cec8dddef6284da01060f5af104b6c;hpb=b93cd5f21f8161783f8d40fb6ade28aa04ecf193;p=sbcl.git

diff --git a/src/code/deadline.lisp b/src/code/deadline.lisp
index 97a147b..d2577dc 100644
--- a/src/code/deadline.lisp
+++ b/src/code/deadline.lisp
@@ -12,13 +12,17 @@
 
 (in-package "SB!IMPL")
 
+(!begin-collecting-cold-init-forms)
+
 ;;; Current deadline as internal time units or NIL.
-(defvar *deadline* nil)
 (declaim (type (or unsigned-byte null) *deadline*))
+(defvar *deadline*)
+(!cold-init-forms (setq *deadline* nil))
 
 ;;; The relative number of seconds the current deadline corresponds
 ;;; to. Used for continuing from TIMEOUT conditions.
-(defvar *deadline-seconds* nil)
+(defvar *deadline-seconds*)
+(!cold-init-forms (setq *deadline-seconds* nil))
 
 (declaim (inline seconds-to-internal-time))
 (defun seconds-to-internal-time (seconds)
@@ -39,18 +43,22 @@ not extended. Deadlines are per thread: children are unaffected by
 their parent's deadlines.
 
 Experimental."
-  (with-unique-names (deadline-seconds deadline)
+  (with-unique-names (tmp deadline-seconds deadline)
     ;; We're operating on a millisecond precision, so a single-float
     ;; is enough, and is an immediate on 64bit platforms.
-    `(let* ((,deadline-seconds (coerce ,seconds 'single-float))
+    `(let* ((,tmp ,seconds)
+            (,deadline-seconds
+              (when ,tmp
+                (coerce ,tmp 'single-float)))
             (,deadline
-             (+ (seconds-to-internal-time ,deadline-seconds)
-                (get-internal-real-time))))
+              (when ,deadline-seconds
+                (+ (seconds-to-internal-time ,deadline-seconds)
+                   (get-internal-real-time)))))
        (multiple-value-bind (*deadline* *deadline-seconds*)
            (if ,override
                (values ,deadline ,deadline-seconds)
                (let ((old *deadline*))
-                 (if (and old (< old ,deadline))
+                 (if (and old (or (not ,deadline) (< old ,deadline)))
                      (values old *deadline-seconds*)
                      (values ,deadline ,deadline-seconds))))
          ,@body))))
@@ -113,6 +121,21 @@ seconds.) Otherwise return NIL if the restart is not found."
 CONDITION, or return NIL if the restart is not found."
   (try-restart 'cancel-deadline condition))
 
+(declaim (inline relative-decoded-times))
+(defun relative-decoded-times (abs-sec abs-usec)
+  #!+sb-doc
+  "Returns relative decoded times: difference between SEC and USEC and
+current real time."
+  (multiple-value-bind (now-sec now-usec)
+      (decode-internal-time (get-internal-real-time))
+    (let ((rel-sec (- abs-sec now-sec)))
+      (cond ((> now-usec abs-usec)
+             (values (max 0 (1- rel-sec))
+                     (- (+ abs-usec 1000000) now-usec)))
+            (t
+             (values (max 0 rel-sec)
+                     (- abs-usec now-usec)))))))
+
 ;;; Returns TIMEOUT-SEC, TIMEOUT-USEC, DEADLINE-SEC, DEADLINE-USEC, SIGNALP
 ;;;
 ;;; Takes *DEADLINE* into account: if it occurs before given SECONDS,
@@ -168,6 +191,7 @@ it will signal a timeout condition."
                    (decode-internal-time final-timeout)
                  (multiple-value-bind (stop-sec stop-usec)
                      (decode-internal-time final-deadline)
-                   (values to-sec to-usec stop-sec stop-usec signalp)))
+                   (values (max 0 to-sec) (max 0 to-usec) stop-sec stop-usec signalp)))
                (values nil nil nil nil nil)))))))
 
+(!defun-from-collected-cold-init-forms !deadline-cold-init)