Merge branch 'legoscia/io-message-queue-optimisation' into maint

* legoscia/io-message-queue-optimisation:
  Optimise io requests for long message queues

3 files changed, 65 insertions, 31 deletions

diff --git a/lib/stdlib/doc/src/io_protocol.xml b/lib/stdlib/doc/src/io_protocol.xml
index 9328704e11..d6da205f07 100644
--- a/lib/stdlib/doc/src/io_protocol.xml
+++ b/lib/stdlib/doc/src/io_protocol.xml
@@ -76,10 +76,11 @@ the server eventually sends a corresponding <c>io_reply</c> tuple.</p>
 the I/O server sends the IO reply to.</item>
 
 <item><c>ReplyAs</c> can be any datum and is returned in the corresponding
-<c>io_reply</c>. The <seealso marker="stdlib:io">io</seealso> module simply uses the pid()
-of the I/O server as the <c>ReplyAs</c> datum, but a more complicated client
+<c>io_reply</c>. The <seealso marker="stdlib:io">io</seealso> module monitors
+the I/O server, and uses the monitor reference as the <c>ReplyAs</c> datum.
+A more complicated client
 could have several outstanding I/O requests to the same I/O server and
-would then use i.e. a <c>reference()</c> or something else to differentiate among
+would then use different references (or something else) to differentiate among
 the incoming IO replies. The <c>ReplyAs</c> element should be considered
 opaque by the I/O server. Note that the <c>pid()</c> of the I/O server is not
 explicitly present in the <c>io_reply</c> tuple. The reply can be sent from any
diff --git a/lib/stdlib/src/io.erl b/lib/stdlib/src/io.erl
index 27e2a82b41..b9ace2f442 100644
--- a/lib/stdlib/src/io.erl
+++ b/lib/stdlib/src/io.erl
@@ -566,12 +566,23 @@ request(Name, Request) when is_atom(Name) ->
 
 execute_request(Pid, {Convert,Converted}) ->
     Mref = erlang:monitor(process, Pid),
-    Pid ! {io_request,self(),Pid,Converted},
-    if
-	Convert ->
-	    convert_binaries(wait_io_mon_reply(Pid, Mref));
-	true ->
-	    wait_io_mon_reply(Pid, Mref)
+    Pid ! {io_request,self(),Mref,Converted},
+
+    receive
+	{io_reply, Mref, Reply} ->
+	    erlang:demonitor(Mref, [flush]),
+	    if
+		Convert ->
+		    convert_binaries(Reply);
+		true ->
+		    Reply
+	    end;
+	{'DOWN', Mref, _, _, _} ->
+	    receive
+		{'EXIT', Pid, _What} -> true
+	    after 0 -> true
+	    end,
+	    {error,terminated}
     end.
 
 requests(Requests) ->				%Requests as atomic action
@@ -597,26 +608,6 @@ default_input() ->
 default_output() ->
     group_leader().
 
-wait_io_mon_reply(From, Mref) ->
-    receive
-	{io_reply, From, Reply} ->
-	    erlang:demonitor(Mref, [flush]),
-	    Reply;
-	{'EXIT', From, _What} ->
-	    receive
-		{'DOWN', Mref, _, _, _} -> true
-	    after 0 -> true
-	    end,
-	    {error,terminated};
-	{'DOWN', Mref, _, _, _} ->
-	    receive
-		{'EXIT', From, _What} -> true
-	    after 0 -> true
-	    end,
-	    {error,terminated}
-    end.
-
-
 %% io_requests(Requests)
 %%  Transform requests into correct i/o server messages. Only handle the
 %%  one we KNOW must be changed, others, including incorrect ones, are
diff --git a/lib/stdlib/test/io_SUITE.erl b/lib/stdlib/test/io_SUITE.erl
index 3a76275f31..2203dd8f51 100644
--- a/lib/stdlib/test/io_SUITE.erl
+++ b/lib/stdlib/test/io_SUITE.erl
@@ -30,7 +30,8 @@
 	 io_fread_newlines/1, otp_8989/1, io_lib_fread_literal/1,
 	 printable_range/1,
 	 io_lib_print_binary_depth_one/1, otp_10302/1, otp_10755/1,
-         otp_10836/1, io_lib_width_too_small/1]).
+         otp_10836/1, io_lib_width_too_small/1,
+         io_with_huge_message_queue/1]).
 
 -export([pretty/2]).
 
@@ -70,7 +71,7 @@ all() ->
      io_fread_newlines, otp_8989, io_lib_fread_literal,
      printable_range,
      io_lib_print_binary_depth_one, otp_10302, otp_10755, otp_10836,
-     io_lib_width_too_small].
+     io_lib_width_too_small, io_with_huge_message_queue].
 
 groups() -> 
     [].
@@ -2219,3 +2220,44 @@ io_lib_width_too_small(Config) ->
     "**" = lists:flatten(io_lib:format("~2.3w", [3.14])),
     "**" = lists:flatten(io_lib:format("~2.5w", [3.14])),
     ok.
+
+%% Test that the time for a huge message queue is not
+%% significantly slower than with an empty message queue.
+io_with_huge_message_queue(Config) when is_list(Config) ->
+    case test_server:is_native(gen) of
+	true ->
+	    {skip,
+	     "gen is native - huge message queue optimization "
+	     "is not implemented"};
+	false ->
+	    do_io_with_huge_message_queue(Config)
+    end.
+
+do_io_with_huge_message_queue(Config) ->
+    PrivDir = ?privdir(Config),
+    File = filename:join(PrivDir, "slask"),
+    {ok, F1} = file:open(File, [write]),
+
+    {Time,ok} = timer:tc(fun() -> writes(1000, F1) end),
+
+    [self() ! {msg,N} || N <- lists:seq(1, 500000)],
+    erlang:garbage_collect(),
+    {NewTime,ok} = timer:tc(fun() -> writes(1000, F1) end),
+    file:close(F1),
+    io:format("Time for empty message queue: ~p", [Time]),
+    io:format("Time for huge message queue: ~p", [NewTime]),
+
+    IsCover = test_server:is_cover(),
+    case (NewTime+1) / (Time+1) of
+	Q when Q < 10; IsCover ->
+	    ok;
+	Q ->
+	    io:format("Q = ~p", [Q]),
+	    ?t:fail()
+    end,
+    ok.
+
+writes(0, _) -> ok;
+writes(N, F1) ->
+    file:write(F1, "hello\n"),
+    writes(N - 1, F1).