[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Chicken-hackers] [PATCH] Make `sleep` suspend thread if scheduler is lo
From: |
Evan Hanson |
Subject: |
[Chicken-hackers] [PATCH] Make `sleep` suspend thread if scheduler is loaded, process otherwise |
Date: |
Fri, 10 Jun 2016 15:24:43 +1200 |
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.
---
NEWS | 3 +++
chicken.h | 9 ++++++---
chicken.import.scm | 1 +
library.scm | 16 ++++++++++++++--
manual/Unit library | 10 ++++++++++
manual/Unit posix | 6 +++---
posix-common.scm | 4 ++++
posixunix.scm | 7 ++-----
posixwin.scm | 9 ++-------
scheduler.scm | 22 +++++++++++++++++++++-
types.db | 3 ++-
11 files changed, 68 insertions(+), 22 deletions(-)
diff --git a/NEWS b/NEWS
index 2c539a4..2ee2900 100644
--- a/NEWS
+++ b/NEWS
@@ -24,6 +24,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 6d29f70..dc8cff0 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 cb2ded1..2b30f54 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 9acd279..20dd7bf 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 3d6ad5b..27f6696 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 6d1d6fb..7a9ebed 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,
@@ -1315,6 +1315,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}}
@@ -1331,7 +1332,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 a6f8105..991ac7d 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 73e52a2..7741064 100644
--- a/posixunix.scm
+++ b/posixunix.scm
@@ -70,7 +70,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-groups! set-root-directory!
@@ -81,7 +81,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!
@@ -247,7 +247,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))
@@ -1658,8 +1657,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 3d60568..1c59719 100644
--- a/posixwin.scm
+++ b/posixwin.scm
@@ -358,7 +358,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()
@@ -695,7 +694,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-groups! set-root-directory!
@@ -706,7 +705,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!
@@ -1388,10 +1387,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 fd0562e..04f1fb2 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 61b4f05..22453ab 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))
@@ -2066,7 +2067,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))
--
2.8.1