Skip to content

Commit

Permalink
Browse files Browse the repository at this point in the history
Improved Thread.yield / thread preemption (ocaml#1533)
* PR#7669 : under Linux, use nanosleep(1) as the implementation of Thread.yield.
This results in a scheduling of threads that is much more fair than before.

* Add a testpreempt.ml test to check that thread preemption is fair.
This is not yet the case for the Windows ports, so disable the test on Windows.

* Use Unix.sleepf as an implementation of Thread.delay instead of Unix.select.
Unix.sleepf can have better resolution than Unix.select.

* Fix signal.ml test
Add "wait" in the runner shell script in order to make sure that the process has properly exited
before its output is compared with the reference output.
  • Loading branch information
jhjourdan authored and hhugo committed Feb 12, 2018
1 parent a20b69f commit 533461a
Show file tree
Hide file tree
Showing 6 changed files with 41 additions and 2 deletions.
9 changes: 8 additions & 1 deletion otherlibs/systhreads/st_posix.h
Expand Up @@ -24,6 +24,7 @@
#define _POSIX_PTHREAD_SEMANTICS
#endif
#include <signal.h>
#include <time.h>
#include <sys/time.h>
#ifdef __linux__
#include <unistd.h>
Expand Down Expand Up @@ -90,8 +91,14 @@ static void st_thread_join(st_thread_id thr)

static void INLINE st_thread_yield(void)
{
#ifndef __linux__
#ifdef __linux__
/* sched_yield() doesn't do what we want in Linux 2.6 and up (PR#2663) */
/* but not doing anything here would actually disable preemption (PR#7669) */
struct timespec t;
t.tv_sec = 0;
t.tv_nsec = 1;
nanosleep(&t, NULL);
#else
sched_yield();
#endif
}
Expand Down
2 changes: 1 addition & 1 deletion otherlibs/systhreads/thread.ml
Expand Up @@ -71,7 +71,7 @@ let () =

(* Wait functions *)

let delay time = ignore(Unix.select [] [] [] time)
let delay = Unix.sleepf

let wait_read fd = ()
let wait_write fd = ()
Expand Down
23 changes: 23 additions & 0 deletions testsuite/tests/lib-systhreads/testpreempt.ml
@@ -0,0 +1,23 @@
let rec generate_list n =
let rec aux acc = function
| 0 -> acc
| n -> aux (float n :: acc) (n-1)
in
aux [] n

let rec long_computation time0 =
let long_list = generate_list 100000 in
let res = List.length (List.rev_map sin long_list) in
if Sys.time () -. time0 > 2. then
Printf.printf "Long computation result: %d\n%!" res
else long_computation time0

let interaction () =
Thread.delay 0.1;
Printf.printf "Interaction 1\n";
Thread.delay 0.1;
Printf.printf "Interaction 2\n"

let () =
ignore (Thread.create interaction ());
long_computation (Sys.time ())
5 changes: 5 additions & 0 deletions testsuite/tests/lib-systhreads/testpreempt.precheck
@@ -0,0 +1,5 @@
# On Windows, we use Sleep(0) for triggering preemption of threads.
# However, this does not seem very reliable, so that this test fails
# on some Windows configurations. See GPR #1533.

test "$OS" != "Windows_NT"
3 changes: 3 additions & 0 deletions testsuite/tests/lib-systhreads/testpreempt.reference
@@ -0,0 +1,3 @@
Interaction 1
Interaction 2
Long computation result: 100000
1 change: 1 addition & 0 deletions testsuite/tests/lib-threads/signal.runner
Expand Up @@ -17,3 +17,4 @@ $RUNTIME ./program >signal.result &
pid=$!
sleep 2
test -e ./sigint.exe && ./sigint $pid || kill -INT $pid
wait

0 comments on commit 533461a

Please sign in to comment.