1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
|
(* TEST
hassysthreads;
include systhreads;
not-target-windows;
no-tsan;
{
bytecode;
}{
native;
}
*)
(* PR #11307. The following program deadlocks when input in the
toplevel and interrupted by the user with Ctrl-C, by busy-waiting
on signals to be processed.
{[
let break_trap s =
(try while true do () done
with Sys.Break -> print_endline "[Sys.Break caught]" ) ;
print_endline s
let () =
Sys.catch_break true ;
let d = Domain.spawn (fun () -> break_trap "Domain 1") in
break_trap "Domain 0 - 1" ;
Domain.join d ;
break_trap "Domain 0 - 2";
print_endline "Success."
]}
*)
let verbose = false
(* Expected when verbose (depending on scheduling and platform):
[Sys.Break caught]
Domain 1
[Sys.Break caught]
Domain 0 - 1
[Sys.Break caught]
Domain 0 - 2
Success.
*)
let delay = 0.001 (* 1 ms *)
let fuel = Atomic.make 1000 (* = 1s max retry duration *)
let print = if verbose then print_endline else fun _ -> ()
(* start sending interrupts when reaches 1 or 2 *)
let ready_count = Atomic.make 0
(* Does not poll *)
let sleep () =
if Atomic.get fuel <= 0 then (
print "[Reached max attempts without succeeding]";
Unix._exit 1
);
Atomic.decr fuel;
Unix.sleepf delay
let rec wait n =
if Atomic.get ready_count <> n then (
sleep ();
wait n
)
(* We busy-wait because other synchronisation mechanisms involve
blocking calls, which may exercise other parts of the async
callback implementation than we want.*)
let break_trap s =
begin
try Atomic.incr ready_count; while true do () done
with Sys.Break -> print "[Sys.Break caught]"
end;
print s;
Atomic.decr ready_count
(* Simulate repeated Ctrl-C from a parallel thread *)
let interruptor_domain () =
Domain.spawn @@ fun () ->
ignore (Thread.sigmask Unix.SIG_BLOCK [Sys.sigint]);
let kill () = sleep () ; Unix.kill (Unix.getpid ()) Sys.sigint in
wait 2;
kill (); (* interrupt Domain 1 or Domain 0-1 *)
wait 1;
kill (); (* interrupt the other one of Domain 1 or Domain 0-1 *)
wait 2;
kill () (* interrupt Domain 0-2 *)
let run () =
(* We simulate the user pressing Ctrl-C repeatedly. Goal: joining
the domain [d] must be achievable by Ctrl-C. This tests proper
reception of SIGINT. *)
let d = Domain.spawn (fun () -> break_trap "Domain 1") in
let d2 = interruptor_domain () in
break_trap "Domain 0 - 1";
Domain.join d;
assert (Atomic.get ready_count = 0);
Atomic.incr ready_count; (* Make sure it reaches 2 *)
break_trap "Domain 0 - 2";
Domain.join d2
let () =
Sys.catch_break true;
(try run () with Sys.Break ->
print ("Test could not complete due to scheduling hazard"
^ " (possible false positive)."));
print "Success.";
exit 0
|
