~ chicken-core (chicken-5) 0493e298ee6f04ade06ae6e2f391703a5d48296c

commit 0493e298ee6f04ade06ae6e2f391703a5d48296c
Author:     Evan Hanson <evhan@foldling.org>
AuthorDate: Fri Jun 10 15:24:43 2016 +1200
Commit:     Peter Bex <peter@more-magic.net>
CommitDate: Thu Jun 16 14:14:07 2016 +0200

    Make `sleep` suspend thread if scheduler is loaded, process otherwise
    
    Makes `sleep` change its behaviour based on whether the scheduler is
    loaded: when it is, the current thread is suspended (allowing other
    threads to continue executing), and when it isn't the whole process is
    suspended with sleep(3). Also adds a `process-sleep` procedure to the
    posix unit as a way to sleep the process unconditionally.
    
    Signed-off-by: Peter Bex <peter@more-magic.net>

diff --git a/NEWS b/NEWS
index 5c6a36fd..31b3270a 100644
--- a/NEWS
+++ b/NEWS
@@ -25,6 +25,9 @@
   - Added the `executable-pathname` procedure for retrieving a path to
     the currently-running executable.
   - Removed all support for SWIG.
+  - `sleep` now suspends the current thread when threading is enabled,
+    otherwise it sleeps the process. The new `process-sleep` procedure
+    in unit posix can be used to sleep the process unconditionally.
 
 - Module system
   - The compiler has been modularised, for improved namespacing.  This
diff --git a/chicken.h b/chicken.h
index 6d29f70f..dc8cff02 100644
--- a/chicken.h
+++ b/chicken.h
@@ -1597,15 +1597,18 @@ typedef void (C_ccall *C_proc)(C_word, C_word *) C_noret;
 #define C_ub_i_pointer_f32_set(p, n)    (*((float *)(p)) = (n))
 #define C_ub_i_pointer_f64_set(p, n)    (*((double *)(p)) = (n))
 
+#if defined(_WIN32) && !defined(__CYGWIN__)
+# define C_process_sleep(n) (Sleep(C_unfix(n) * 1000), C_fix(0))
+#else
+# define C_process_sleep(n) C_fix(sleep(C_unfix(n)))
+#endif
+
 #ifdef C_PRIVATE_REPOSITORY
 # define C_private_repository()         C_use_private_repository(C_executable_dirname())
 #else
 # define C_private_repository()
 #endif
 
-/* left for backwards-compatibility */
-#define C_gui_nongui_marker
-
 #ifdef C_GUI
 # define C_set_gui_mode                 C_gui_mode = 1
 #else
diff --git a/chicken.import.scm b/chicken.import.scm
index cb2ded1d..2b30f54f 100644
--- a/chicken.import.scm
+++ b/chicken.import.scm
@@ -168,6 +168,7 @@
    signal
    signum
    singlestep
+   sleep
    software-type
    software-version
    string->blob
diff --git a/library.scm b/library.scm
index 9acd2796..20dd7bfa 100644
--- a/library.scm
+++ b/library.scm
@@ -39,8 +39,9 @@
 	make-complex flonum->ratnum ratnum
 	+maximum-allowed-exponent+ mantexp->dbl ldexp round-quotient
 	##sys#string->compnum ##sys#internal-gcd)
-  (not inline ##sys#user-read-hook ##sys#error-hook ##sys#signal-hook ##sys#schedule
-       ##sys#default-read-info-hook ##sys#infix-list-hook ##sys#sharp-number-hook
+  (not inline ##sys#user-read-hook ##sys#error-hook ##sys#signal-hook
+       ##sys#sleep-hook ##sys#schedule ##sys#default-read-info-hook
+       ##sys#infix-list-hook ##sys#sharp-number-hook
        ##sys#user-print-hook ##sys#user-interrupt-hook)
   (foreign-declare #<<EOF
 #include <errno.h>
@@ -5161,6 +5162,17 @@ EOF
   (thunk))	     ; does nothing, will be modified by scheduler.scm
 
 
+;;; Sleeping:
+
+(define (##sys#sleep-hook n) ; modified by scheduler.scm
+  (##core#inline "C_process_sleep" n))
+
+(define (sleep n)
+  (##sys#check-fixnum n 'sleep)
+  (##sys#sleep-hook n)
+  (##core#undefined))
+
+
 ;;; Interrupt-handling:
 
 (define ##sys#context-switch (##core#primitive "C_context_switch"))
diff --git a/manual/Unit library b/manual/Unit library
index 3d6ad5b3..27f66960 100644
--- a/manual/Unit library	
+++ b/manual/Unit library	
@@ -648,6 +648,16 @@ of the last top-level form. Note that finalizers for unreferenced finalized
 data are run before exit procedures.
 
 
+==== sleep
+
+<procedure>(sleep SECONDS)</procedure>
+
+Puts the program to sleep for {{SECONDS}}. If the scheduler is loaded
+(for example when srfi-18 is in use) then only the calling thread is put
+to sleep and other threads may continue executing. Otherwise, the whole
+process is put to sleep.
+
+
 ==== software-type
 
 <procedure>(software-type)</procedure>
diff --git a/manual/Unit posix b/manual/Unit posix
index 72b448d0..cecbcb01 100644
--- a/manual/Unit posix	
+++ b/manual/Unit posix	
@@ -744,9 +744,9 @@ which any data written to will be received as input in the sub-process,
 the process-id of the started sub-process, and an input port from
 which data written by the sub-process to {{stderr}} can be read.
 
-==== sleep
+==== process-sleep
 
-<procedure>(sleep SECONDS)</procedure>
+<procedure>(process-sleep SECONDS)</procedure>
 
 Puts the process to sleep for {{SECONDS}}. Returns either 0 if
 the time has completely elapsed, or the number of remaining seconds,
@@ -1279,6 +1279,7 @@ not be obtained. On Windows, this procedure always returns {{0}},
 ; {{process-fork}} : {{fork}}
 ; {{process-group-id}} : {{getpgid}}
 ; {{process-signal}} : {{kill}}
+; {{process-sleep}} : {{sleep}}
 ; {{process-wait}} : {{waitpid}}
 ; {{close-input-pipe}} : {{pclose}}
 ; {{close-output-pipe}} : {{pclose}}
@@ -1294,7 +1295,6 @@ not be obtained. On Windows, this procedure always returns {{0}},
 ; {{set-user-id!}} : {{setuid}}
 ; {{set-root-directory!}} : {{chroot}}
 ; {{set-environment-variable!}} : {{setenv/putenv}}
-; {{sleep}} : {{sleep}}
 ; {{system-information}} : {{uname}}
 ; {{terminal-name}} : {{ttyname}}
 ; {{terminal-port?}} : {{isatty}}
diff --git a/posix-common.scm b/posix-common.scm
index a6f8105f..991ac7d2 100644
--- a/posix-common.scm
+++ b/posix-common.scm
@@ -686,6 +686,10 @@ EOF
 
 (define (current-process-id) (##sys#fudge 33))
 
+(define (process-sleep n)
+  (##sys#check-fixnum n 'process-sleep)
+  (##core#inline "C_process_sleep" n))
+
 (define process-wait
   (lambda args
     (let-optionals* args ([pid #f] [nohang #f])
diff --git a/posixunix.scm b/posixunix.scm
index 671064e6..3e25ff5c 100644
--- a/posixunix.scm
+++ b/posixunix.scm
@@ -63,7 +63,7 @@
    perm/irwxo perm/irwxu perm/isgid perm/isuid perm/isvtx perm/iwgrp
    perm/iwoth perm/iwusr perm/ixgrp perm/ixoth perm/ixusr pipe/buf
    port->fileno process process* process-execute process-fork
-   process-group-id process-run process-signal process-wait
+   process-group-id process-run process-signal process-sleep process-wait
    read-symbolic-link regular-file? seconds->local-time seconds->string
    seconds->utc-time seek/cur seek/end seek/set set-alarm!
    set-buffering-mode! set-root-directory!
@@ -74,7 +74,7 @@
    signal/pipe signal/prof signal/quit signal/segv signal/stop
    signal/term signal/trap signal/tstp signal/urg signal/usr1
    signal/usr2 signal/vtalrm signal/winch signal/xcpu signal/xfsz
-   signals-list sleep block-device? character-device? fifo? socket?
+   signals-list block-device? character-device? fifo? socket?
    string->time symbolic-link? system-information terminal-name
    terminal-port? terminal-size time->string user-information
    set-environment-variable! unset-environment-variable!
@@ -220,7 +220,6 @@ static C_TLS struct stat C_statbuf;
 #define C_setvbuf(p, m, s)  C_fix(setvbuf(C_port_file(p), NULL, C_unfix(m), C_unfix(s)))
 #define C_test_access(fn, m)     C_fix(access((char *)C_data_pointer(fn), C_unfix(m)))
 #define C_close(fd)         C_fix(close(C_unfix(fd)))
-#define C_sleep             sleep
 #define C_umask(m)          C_fix(umask(C_unfix(m)))
 
 #define C_lstat(fn)         C_fix(lstat((char *)C_data_pointer(fn), &C_statbuf))
@@ -1508,8 +1507,6 @@ EOF
 
 (define parent-process-id (foreign-lambda int "C_getppid"))
 
-(define sleep (foreign-lambda int "C_sleep" int))
-
 (define process-signal
   (lambda (id . sig)
     (let ([sig (if (pair? sig) (car sig) _sigterm)])
diff --git a/posixwin.scm b/posixwin.scm
index 7f6611ae..59776b24 100644
--- a/posixwin.scm
+++ b/posixwin.scm
@@ -356,7 +356,6 @@ process_wait(C_word h, C_word t)
 }
 
 #define C_process_wait(p, t) (process_wait(C_unfix(p), C_truep(t)) ? C_SCHEME_TRUE : C_SCHEME_FALSE)
-#define C_sleep(t) (Sleep(C_unfix(t) * 1000), C_fix(0))
 
 static int C_fcall
 get_hostname()
@@ -686,7 +685,7 @@ EOF
    perm/irwxo perm/irwxu perm/isgid perm/isuid perm/isvtx perm/iwgrp
    perm/iwoth perm/iwusr perm/ixgrp perm/ixoth perm/ixusr pipe/buf
    port->fileno process process* process-execute process-fork
-   process-group-id process-run process-signal process-wait
+   process-group-id process-run process-signal process-sleep process-wait
    read-symbolic-link regular-file? seconds->local-time seconds->string
    seconds->utc-time seek/cur seek/end seek/set set-alarm!
    set-buffering-mode! set-root-directory!
@@ -697,7 +696,7 @@ EOF
    signal/pipe signal/prof signal/quit signal/segv signal/stop
    signal/term signal/trap signal/tstp signal/urg signal/usr1
    signal/usr2 signal/vtalrm signal/winch signal/xcpu signal/xfsz
-   signals-list sleep block-device? character-device? fifo? socket?
+   signals-list block-device? character-device? fifo? socket?
    string->time symbolic-link? system-information terminal-name
    terminal-port? terminal-size time->string user-information
    set-environment-variable! unset-environment-variable!
@@ -1337,10 +1336,6 @@ EOF
     (values pid #t _exstatus)
     (values -1 #f #f) ) )
 
-(define (sleep s)
-  (##sys#check-fixnum s 'sleep)
-  (##core#inline "C_sleep" s))
-
 (define-foreign-variable _hostname c-string "C_hostname")
 (define-foreign-variable _osver c-string "C_osver")
 (define-foreign-variable _osrel c-string "C_osrel")
diff --git a/scheduler.scm b/scheduler.scm
index fd0562e6..04f1fb26 100644
--- a/scheduler.scm
+++ b/scheduler.scm
@@ -36,7 +36,7 @@
 	; ##sys#force-primordial
 	remove-from-ready-queue fdset-test create-fdset stderr delq
 	##sys#clear-i/o-state-for-thread! ##sys#abandon-mutexes) 
-  (not inline ##sys#interrupt-hook ##sys#force-primordial)
+  (not inline ##sys#interrupt-hook ##sys#sleep-hook ##sys#force-primordial)
   (unsafe)
   (foreign-declare #<<EOF
 #ifdef HAVE_ERRNO_H
@@ -582,6 +582,26 @@ EOF
     (##sys#thread-basic-unblock! t) ) )
 
 
+;;; Put a thread to sleep:
+
+(define (##sys#thread-sleep! tm)
+  (##sys#call-with-current-continuation
+   (lambda (return)
+     (let ((ct ##sys#current-thread))
+       (##sys#setslot ct 1 (lambda () (return (##core#undefined))))
+       (##sys#thread-block-for-timeout! ct tm)
+       (##sys#schedule)))))
+
+
+;;; Override `sleep` in library.scm to operate on the current thread:
+
+(set! ##sys#sleep-hook
+  (lambda (n)
+    (##sys#thread-sleep!
+     (+ (##core#inline_allocate ("C_a_i_current_milliseconds" 7) #f)
+	(* 1000.0 n)))))
+
+
 ;;; Kill all threads in fd-, io- and timeout-lists and assign one thread as the
 ;   new primordial one. Overrides "##sys#kill-all-threads" in library.scm.
 
diff --git a/types.db b/types.db
index 7b1e1f1b..d4cb270b 100644
--- a/types.db
+++ b/types.db
@@ -1302,6 +1302,7 @@
 	 (##core#inline "C_u_i_integer_signum" (##sys#slot #(1) '1)))
 	((cplxnum) ((or float cplxnum)) (##sys#extended-signum #(1))))
 
+(sleep (#(procedure #:clean #:enforce) sleep (fixnum) undefined))
 (software-type (#(procedure #:pure) software-type () symbol))
 (software-version (#(procedure #:pure) software-version () symbol))
 (string->blob (#(procedure #:clean #:enforce) string->blob (string) blob))
@@ -2059,7 +2060,7 @@
 (chicken.posix#signal/xcpu fixnum)
 (chicken.posix#signal/xfsz fixnum)
 (chicken.posix#signals-list list)
-(chicken.posix#sleep (#(procedure #:clean #:enforce) chicken.posix#sleep (fixnum) fixnum))
+(chicken.posix#process-sleep (#(procedure #:clean #:enforce) chicken.posix#process-sleep (fixnum) fixnum))
 (chicken.posix#block-device? (#(procedure #:clean #:enforce) chicken.posix#block-device? ((or string fixnum)) boolean))
 (chicken.posix#character-device? (#(procedure #:clean #:enforce) chicken.posix#character-device? ((or string fixnum)) boolean))
 (chicken.posix#fifo? (#(procedure #:clean #:enforce) chicken.posix#fifo? ((or string fixnum)) boolean))