From: Daniel Barlow <dan@telent.net>
Date: Wed, 6 Apr 2005 17:16:57 +0000 (+0000)
Subject: 0.8.21.20
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=0834142e83d6a1ee99260baa3a8ca1d1557b3737;p=sbcl.git

0.8.21.20
	Patch SLEEP to use nanosleep() and to restart the sleep if
	interrupted e.g. by a signal, instead of returning early.  Thanks
	to Gabor Melis (ref sbcl-help, "Oddity with make-thread and sleep")
---

diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr
index 2f1ba5f..551f6fc 100644
--- a/package-data-list.lisp-expr
+++ b/package-data-list.lisp-expr
@@ -1894,6 +1894,7 @@ needed by the current implementation of SBCL, and makes
 no guarantees of interface stability."
       :use ("CL" "SB!ALIEN" "SB!EXT" "SB!INT" "SB!SYS")
       :export (	;; wrappers around Unix stuff to give just what Lisp needs
+               "NANOSLEEP"
 	       "UID-USERNAME"
 	       "UID-HOMEDIR"
 
diff --git a/src/code/toplevel.lisp b/src/code/toplevel.lisp
index 2b6dcbd..43a5c0b 100644
--- a/src/code/toplevel.lisp
+++ b/src/code/toplevel.lisp
@@ -147,13 +147,13 @@ steppers to maintain contextual information.")
            :format-arguments (list n)
            :datum n
            :expected-type '(real 0)))
-  (multiple-value-bind (sec usec)
+  (multiple-value-bind (sec nsec)
       (if (integerp n)
 	  (values n 0)
 	  (multiple-value-bind (sec frac)
 	      (truncate n)
-	    (values sec (truncate frac 1e-6))))
-    (sb!unix:unix-select 0 0 0 0 sec usec))
+	    (values sec (truncate frac 1e-9))))
+    (sb!unix:nanosleep sec nsec))
   nil)
 
 ;;;; SCRUB-CONTROL-STACK
diff --git a/src/code/unix.lisp b/src/code/unix.lisp
index 39b23eb..59cf350 100644
--- a/src/code/unix.lisp
+++ b/src/code/unix.lisp
@@ -658,6 +658,18 @@
   (seconds-west sb!alien:int :out)
   (daylight-savings-p sb!alien:boolean :out))
 
+(defun nanosleep (secs nsecs)
+  (with-alien ((req (struct timespec))
+               (rem (struct timespec)))
+    (setf (slot req 'tv-sec) secs)
+    (setf (slot req 'tv-nsec) nsecs)
+    (loop while (eql sb!unix:EINTR
+                     (nth-value 1
+                                (int-syscall ("nanosleep" (* (struct timespec))
+                                                          (* (struct timespec)))
+                                             (addr req) (addr rem))))
+       do (rotatef req rem))))
+
 (defun unix-get-seconds-west (secs)
   (multiple-value-bind (ignore seconds dst) (get-timezone secs)
     (declare (ignore ignore) (ignore dst))
diff --git a/tests/threads.impure.lisp b/tests/threads.impure.lisp
index 1c8b291..f33577a 100644
--- a/tests/threads.impure.lisp
+++ b/tests/threads.impure.lisp
@@ -66,6 +66,14 @@
   (assert (eql (mutex-lock l) 0)  nil "6")
   (describe l))
 
+;; test that SLEEP actually sleeps for at least the given time, even
+;; if interrupted by another thread exiting/a gc/anything
+(let ((start-time (get-universal-time)))
+  (make-thread (lambda () (sleep 1))) ; kid waits 1 then dies ->SIG_THREAD_EXIT
+  (sleep 5)
+  (assert (>= (get-universal-time) (+ 5 start-time))))
+
+
 (let ((queue (make-waitqueue :name "queue"))
       (lock (make-mutex :name "lock")))
   (labels ((in-new-thread ()
diff --git a/tools-for-build/ldso-stubs.lisp b/tools-for-build/ldso-stubs.lisp
index 500336b..5b81bf5 100644
--- a/tools-for-build/ldso-stubs.lisp
+++ b/tools-for-build/ldso-stubs.lisp
@@ -206,6 +206,7 @@ ldso_stub__ ## fct: ;                  \\
                    "malloc"
                    "memmove"
                    "mkdir"
+		   "nanosleep"
                    "nl_langinfo"
                    "open"
                    "opendir"
diff --git a/version.lisp-expr b/version.lisp-expr
index 033d273..085a0ce 100644
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.8.21.19"
+"0.8.21.20"