Merge branch 'master' into sverker/enif_select

1 files changed, 583 insertions, 0 deletions

diff --git a/erts/emulator/test/dirty_bif_SUITE.erl b/erts/emulator/test/dirty_bif_SUITE.erl
new file mode 100644
index 0000000000..308323594d
--- /dev/null
+++ b/erts/emulator/test/dirty_bif_SUITE.erl
@@ -0,0 +1,583 @@
+%%
+%% %CopyrightBegin%
+%%
+%% Copyright Ericsson AB 2010-2014. All Rights Reserved.
+%%
+%% Licensed under the Apache License, Version 2.0 (the "License");
+%% you may not use this file except in compliance with the License.
+%% You may obtain a copy of the License at
+%%
+%%     http://www.apache.org/licenses/LICENSE-2.0
+%%
+%% Unless required by applicable law or agreed to in writing, software
+%% distributed under the License is distributed on an "AS IS" BASIS,
+%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+%% See the License for the specific language governing permissions and
+%% limitations under the License.
+%%
+%% %CopyrightEnd%
+%%
+
+-module(dirty_bif_SUITE).
+
+%%-define(line_trace,true).
+-define(CHECK(Exp,Got), check(Exp,Got,?LINE)).
+%%-define(CHECK(Exp,Got), Exp = Got).
+
+-include_lib("common_test/include/ct.hrl").
+
+-export([all/0, suite/0,
+	 init_per_suite/1, end_per_suite/1,
+	 init_per_testcase/2, end_per_testcase/2,
+	 dirty_bif/1, dirty_bif_exception/1,
+	 dirty_bif_multischedule/1,
+	 dirty_bif_multischedule_exception/1,
+	 dirty_scheduler_exit/1,
+	 dirty_call_while_terminated/1,
+	 dirty_heap_access/1,
+	 dirty_process_info/1,
+	 dirty_process_register/1,
+	 dirty_process_trace/1,
+	 code_purge/1]).
+
+suite() -> [{ct_hooks,[ts_install_cth]}].
+
+%%
+%% All these tests utilize the debug BIFs:
+%% - erts_debug:dirty_cpu/2 - Statically determined
+%%   to (begin to) execute on a dirty CPU scheduler.
+%% - erts_debug:dirty_io/2 - Statically determined
+%%   to (begin to) execute on a dirty IO scheduler.
+%% - erts_debug:dirty/3
+%% Their implementations are located in
+%% $ERL_TOP/erts/emulator/beam/beam_debug.c
+%%
+
+all() ->
+    [dirty_bif,
+     dirty_bif_multischedule,
+     dirty_bif_exception,
+     dirty_bif_multischedule_exception,
+     dirty_scheduler_exit,
+     dirty_call_while_terminated,
+     dirty_heap_access,
+     dirty_process_info,
+     dirty_process_register,
+     dirty_process_trace,
+     code_purge].
+
+init_per_suite(Config) ->
+    case erlang:system_info(dirty_cpu_schedulers) of
+	N when N > 0 ->
+	    Config;
+        _ ->
+	    {skipped, "No dirty scheduler support"}
+    end.
+
+end_per_suite(_Config) ->
+    ok.
+
+init_per_testcase(Case, Config) ->
+    [{testcase, Case} | Config].
+
+end_per_testcase(_Case, _Config) ->
+    ok.
+
+dirty_bif(Config) when is_list(Config) ->
+    dirty_cpu = erts_debug:dirty_cpu(scheduler,type),
+    dirty_io = erts_debug:dirty_io(scheduler,type),
+    normal = erts_debug:dirty(normal,scheduler,type),
+    dirty_cpu = erts_debug:dirty(dirty_cpu,scheduler,type),
+    dirty_io = erts_debug:dirty(dirty_io,scheduler,type),
+    ok.
+
+dirty_bif_multischedule(Config) when is_list(Config) ->
+    ok = erts_debug:dirty_cpu(reschedule,1000),
+    ok = erts_debug:dirty_io(reschedule,1000),
+    ok = erts_debug:dirty(normal,reschedule,1000),
+    ok.
+    
+
+dirty_bif_exception(Config) when is_list(Config) ->
+    lists:foreach(fun (Error) ->
+			  ErrorType = case Error of
+					  _ when is_atom(Error) -> Error;
+					  _ -> badarg
+				      end,
+			  try
+			      erts_debug:dirty_cpu(error, Error),
+			      ct:fail(expected_exception)
+			  catch
+			      error:ErrorType ->
+				  [{erts_debug,dirty_cpu,[error, Error],_}|_]
+				      = erlang:get_stacktrace(),
+				  ok
+			  end,
+			  try
+			      apply(erts_debug,dirty_cpu,[error, Error]),
+			      ct:fail(expected_exception)
+			  catch
+			      error:ErrorType ->
+				  [{erts_debug,dirty_cpu,[error, Error],_}|_]
+				      = erlang:get_stacktrace(),
+				  ok
+			  end,
+			  try
+			      erts_debug:dirty_io(error, Error),
+			      ct:fail(expected_exception)
+			  catch
+			      error:ErrorType ->
+				  [{erts_debug,dirty_io,[error, Error],_}|_]
+				      = erlang:get_stacktrace(),
+				  ok
+			  end,
+			  try
+			      apply(erts_debug,dirty_io,[error, Error]),
+			      ct:fail(expected_exception)
+			  catch
+			      error:ErrorType ->
+				  [{erts_debug,dirty_io,[error, Error],_}|_]
+				      = erlang:get_stacktrace(),
+				  ok
+			  end,
+			  try
+			      erts_debug:dirty(normal, error, Error),
+			      ct:fail(expected_exception)
+			  catch
+			      error:ErrorType ->
+				  [{erts_debug,dirty,[normal, error, Error],_}|_]
+				      = erlang:get_stacktrace(),
+				  ok
+			  end,
+			  try
+			      apply(erts_debug,dirty,[normal, error, Error]),
+			      ct:fail(expected_exception)
+			  catch
+			      error:ErrorType ->
+				  [{erts_debug,dirty,[normal, error, Error],_}|_]
+				      = erlang:get_stacktrace(),
+				  ok
+			  end,
+			  try
+			      erts_debug:dirty(dirty_cpu, error, Error),
+			      ct:fail(expected_exception)
+			  catch
+			      error:ErrorType ->
+				  [{erts_debug,dirty,[dirty_cpu, error, Error],_}|_]
+				      = erlang:get_stacktrace(),
+				  ok
+			  end,
+			  try
+			      apply(erts_debug,dirty,[dirty_cpu, error, Error]),
+			      ct:fail(expected_exception)
+			  catch
+			      error:ErrorType ->
+				  [{erts_debug,dirty,[dirty_cpu, error, Error],_}|_]
+				      = erlang:get_stacktrace(),
+				  ok
+			  end,
+			  try
+			      erts_debug:dirty(dirty_io, error, Error),
+			      ct:fail(expected_exception)
+			  catch
+			      error:ErrorType ->
+				  [{erts_debug,dirty,[dirty_io, error, Error],_}|_]
+				      = erlang:get_stacktrace(),
+				  ok
+			  end,
+			  try
+			      apply(erts_debug,dirty,[dirty_io, error, Error]),
+			      ct:fail(expected_exception)
+			  catch
+			      error:ErrorType ->
+				  [{erts_debug,dirty,[dirty_io, error, Error],_}|_]
+				      = erlang:get_stacktrace(),
+				  ok
+			  end
+		  end,
+		  [badarg, undef, badarith, system_limit, noproc,
+		   make_ref(), {another, "heap", term_to_binary("term")}]),
+    ok.
+
+
+dirty_bif_multischedule_exception(Config) when is_list(Config) ->
+    try
+	erts_debug:dirty_cpu(reschedule,1001)
+    catch
+	error:badarg ->
+	    [{erts_debug,dirty_cpu,[reschedule, 1001],_}|_]
+		= erlang:get_stacktrace(),
+	    ok
+    end,
+    try
+	erts_debug:dirty_io(reschedule,1001)
+    catch
+	error:badarg ->
+	    [{erts_debug,dirty_io,[reschedule, 1001],_}|_]
+		= erlang:get_stacktrace(),
+	    ok
+    end,
+    try
+	erts_debug:dirty(normal,reschedule,1001)
+    catch
+	error:badarg ->
+	    [{erts_debug,dirty,[normal,reschedule,1001],_}|_]
+		= erlang:get_stacktrace(),
+	    ok
+    end.
+
+dirty_scheduler_exit(Config) when is_list(Config) ->
+    {ok, Node} = start_node(Config, "+SDio 1"),
+    [ok] = mcall(Node,
+                 [fun() ->
+			  Start = erlang:monotonic_time(millisecond),
+                          ok = test_dirty_scheduler_exit(),
+			  End = erlang:monotonic_time(millisecond),
+			  io:format("Time=~p ms~n", [End-Start]),
+			  ok
+                  end]),
+    stop_node(Node),
+    ok.
+
+test_dirty_scheduler_exit() ->
+    process_flag(trap_exit,true),
+    test_dse(10,[]).
+test_dse(0,Pids) ->
+    timer:sleep(100),
+    kill_dse(Pids,[]);
+test_dse(N,Pids) ->
+    Pid = spawn_link(fun () -> erts_debug:dirty_io(wait, 5000) end),
+    test_dse(N-1,[Pid|Pids]).
+
+kill_dse([],Killed) ->
+    wait_dse(Killed);
+kill_dse([Pid|Pids],AlreadyKilled) ->
+    exit(Pid,kill),
+    kill_dse(Pids,[Pid|AlreadyKilled]).
+
+wait_dse([]) ->
+    ok;
+wait_dse([Pid|Pids]) ->
+    receive
+        {'EXIT',Pid,Reason} ->
+	    killed = Reason
+    end,
+    wait_dse(Pids).
+
+dirty_call_while_terminated(Config) when is_list(Config) ->
+    Me = self(),
+    Bin = list_to_binary(lists:duplicate(4711, $r)),
+    {value, {BinAddr, 4711, 1}} = lists:keysearch(4711, 2,
+						  element(2,
+							  process_info(self(),
+								       binary))),
+    {Dirty, DM} = spawn_opt(fun () ->
+				    erts_debug:dirty_cpu(alive_waitexiting, Me),
+				    blipp:blupp(Bin)
+			    end,
+			    [monitor,link]),
+    receive {alive, Dirty} -> ok end,
+    {value, {BinAddr, 4711, 2}} = lists:keysearch(4711, 2,
+						  element(2,
+							  process_info(self(),
+								       binary))),
+    Reason = die_dirty_process,
+    OT = process_flag(trap_exit, true),
+    exit(Dirty, Reason),
+    receive
+	{'DOWN', DM, process, Dirty, R0} ->
+	    R0 = Reason
+    end,
+    receive
+	{'EXIT', Dirty, R1} ->
+	    R1 = Reason
+    end,
+    undefined = process_info(Dirty),
+    undefined = process_info(Dirty, status),
+    false = erlang:is_process_alive(Dirty),
+    false = lists:member(Dirty, processes()),
+    %% Binary still refered by Dirty process not yet cleaned up
+    %% since the dirty bif has not yet returned...
+    {value, {BinAddr, 4711, 2}} = lists:keysearch(4711, 2,
+						  element(2,
+							  process_info(self(),
+								       binary))),
+    receive after 2000 -> ok end,
+    receive
+	Msg ->
+	    ct:fail({unexpected_message, Msg})
+    after
+	0 ->
+	    ok
+    end,
+    {value, {BinAddr, 4711, 1}} = lists:keysearch(4711, 2,
+						  element(2,
+							  process_info(self(),
+								       binary))),
+    process_flag(trap_exit, OT),
+    try
+	blipp:blupp(Bin)
+    catch
+	_ : _ -> ok
+    end.
+
+dirty_heap_access(Config) when is_list(Config) ->
+    {ok, Node} = start_node(Config),
+    Me = self(),
+    RGL = rpc:call(Node,erlang,whereis,[init]),
+    Ref = rpc:call(Node,erlang,make_ref,[]),
+    Dirty = spawn_link(fun () ->
+			       Res = erts_debug:dirty_cpu(copy, Ref),
+			       garbage_collect(),
+			       Me ! {self(), Res},
+			       receive after infinity -> ok end
+		       end),
+    {N, R} = access_dirty_heap(Dirty, RGL, 0, 0),
+    receive
+	{_Pid, Res} ->
+	    1000 = length(Res),
+	    lists:foreach(fun (X) -> Ref = X end, Res)
+    end,
+    unlink(Dirty),
+    exit(Dirty, kill),
+    stop_node(Node),
+    {comment, integer_to_list(N) ++ " GL change loops; "
+     ++ integer_to_list(R) ++ " while running dirty"}.
+
+access_dirty_heap(Dirty, RGL, N, R) ->
+    case process_info(Dirty, status) of
+	{status, waiting} ->
+	    {N, R};
+	{status, Status} ->
+	    {group_leader, GL} = process_info(Dirty, group_leader),
+	    true = group_leader(RGL, Dirty),
+	    {group_leader, RGL} = process_info(Dirty, group_leader),
+	    true = group_leader(GL, Dirty),
+	    {group_leader, GL} = process_info(Dirty, group_leader),
+	    access_dirty_heap(Dirty, RGL, N+1, case Status of
+						   running ->
+						       R+1;
+						   _ ->
+						       R
+					       end)
+    end.
+
+%% These tests verify that processes that access a process executing a
+%% dirty BIF where the main lock is needed for that access do not get
+%% blocked. Each test passes its pid to dirty_sleeper, which sends an
+%% 'alive' message when it's running on a dirty scheduler and just before
+%% it starts a 6 second sleep. When it receives the message, it verifies
+%% that access to the dirty process is as it expects.  After the dirty
+%% process finishes its 6 second sleep but before it returns from the dirty
+%% scheduler, it sends a 'done' message. If the tester already received
+%% that message, the test fails because it means attempting to access the
+%% dirty process waited for that process to return to a regular scheduler,
+%% so verify that we haven't received that message, and also verify that
+%% the dirty process is still alive immediately after accessing it.
+dirty_process_info(Config) when is_list(Config) ->
+    access_dirty_process(
+      Config,
+      fun() -> ok end,
+      fun(BifPid) ->
+	      PI = process_info(BifPid),
+	      {current_function,{erts_debug,dirty_io,2}} =
+		  lists:keyfind(current_function, 1, PI),
+	      ok
+      end,
+      fun(_) -> ok end).
+
+dirty_process_register(Config) when is_list(Config) ->
+    access_dirty_process(
+      Config,
+      fun() -> ok end,
+      fun(BifPid) ->
+	      register(test_dirty_process_register, BifPid),
+	      BifPid = whereis(test_dirty_process_register),
+	      unregister(test_dirty_process_register),
+	      false = lists:member(test_dirty_process_register,
+				   registered()),
+	      ok
+      end,
+      fun(_) -> ok end).
+
+dirty_process_trace(Config) when is_list(Config) ->
+    access_dirty_process(
+      Config,
+      fun() ->
+	      erlang:trace_pattern({erts_debug,dirty_io,2},
+				   [{'_',[],[{return_trace}]}],
+				   [local,meta]),
+	      ok
+      end,
+      fun(BifPid) ->
+	      erlang:trace(BifPid, true, [call,timestamp]),
+	      ok
+      end,
+      fun(BifPid) ->
+	      receive
+		  {done, BifPid} ->
+		      receive
+			  {trace_ts,BifPid,call,{erts_debug,dirty_io,_},_} ->
+			      ok
+		      after
+			  0 ->
+			      error(missing_trace_call_message)
+		      end %%,
+		      %% receive
+		      %% 	  {trace_ts,BifPid,return_from,{erts_debug,dirty_io,2},
+		      %% 	   ok,_} ->
+		      %% 	      ok
+		      %% after
+		      %% 	  100 ->
+		      %% 	      error(missing_trace_return_message)
+		      %% end
+	      after
+		  6500 ->
+		      error(missing_done_message)
+	      end,
+	      ok
+      end).
+
+dirty_code_test_code() ->
+    "
+-module(dirty_code_test).
+
+-export([func/1]).
+
+func(Fun) ->
+  Fun(),
+  blipp:blapp().
+
+".
+
+code_purge(Config) when is_list(Config) ->
+    Path = ?config(data_dir, Config),
+    File = filename:join(Path, "dirty_code_test.erl"),
+    ok = file:write_file(File, dirty_code_test_code()),
+    {ok, dirty_code_test, Bin} = compile:file(File, [binary]),
+    {module, dirty_code_test} = erlang:load_module(dirty_code_test, Bin),
+    Start = erlang:monotonic_time(),
+    {Pid1, Mon1} = spawn_monitor(fun () ->
+				       dirty_code_test:func(fun () ->
+								    %% Sleep for 6 seconds
+								    %% in dirty bif...
+								    erts_debug:dirty_io(wait,6000)
+							    end)
+			       end),
+    {module, dirty_code_test} = erlang:load_module(dirty_code_test, Bin),
+    {Pid2, Mon2} = spawn_monitor(fun () ->
+				       dirty_code_test:func(fun () ->
+								    %% Sleep for 6 seconds
+								    %% in dirty bif...
+								    erts_debug:dirty_io(wait,6000)
+							    end)
+				 end),
+    receive
+	{'DOWN', Mon1, process, Pid1, _} ->
+	    ct:fail(premature_death)
+    after 100 ->
+	    ok
+    end,
+    true = erlang:purge_module(dirty_code_test),
+    receive
+	{'DOWN', Mon1, process, Pid1, Reason1} ->
+	    killed = Reason1
+    end,
+    receive
+	{'DOWN', Mon2, process, Pid2, _} ->
+	    ct:fail(premature_death)
+    after 100 ->
+	    ok
+    end,
+    true = erlang:delete_module(dirty_code_test),
+    receive
+	{'DOWN', Mon2, process, Pid2, _} ->
+	    ct:fail(premature_death)
+    after 100 ->
+	    ok
+    end,
+    true = erlang:purge_module(dirty_code_test),
+    receive
+	{'DOWN', Mon2, process, Pid2, Reason2} ->
+	    killed = Reason2
+    end,
+    End = erlang:monotonic_time(),
+    Time = erlang:convert_time_unit(End-Start, native, milli_seconds),
+    io:format("Time=~p~n", [Time]),
+    true = Time =< 1000,
+    ok.
+
+%%
+%% Internal...
+%%
+
+access_dirty_process(Config, Start, Test, Finish) ->
+    {ok, Node} = start_node(Config, ""),
+    [ok] = mcall(Node,
+		 [fun() ->
+			  ok = test_dirty_process_access(Start, Test, Finish)
+		  end]),
+    stop_node(Node),
+    ok.
+
+test_dirty_process_access(Start, Test, Finish) ->
+    ok = Start(),
+    Self = self(),
+    BifPid = spawn_link(fun() ->
+				ok = erts_debug:dirty_io(ready_wait6_done, Self)
+			end),
+    ok = receive
+	     {ready, BifPid} ->
+		 ok = Test(BifPid),
+		 receive
+		     {done, BifPid} ->
+			 error(dirty_process_info_blocked)
+		 after
+		     0 ->
+			 true = erlang:is_process_alive(BifPid),
+			 ok
+		 end
+	 after
+	     3000 ->
+		 error(timeout)
+	 end,
+    ok = Finish(BifPid).
+
+receive_any() ->
+    receive M -> M end.
+
+start_node(Config) ->
+    start_node(Config, "").
+
+start_node(Config, Args) when is_list(Config) ->
+    Pa = filename:dirname(code:which(?MODULE)),
+    Name = list_to_atom(atom_to_list(?MODULE)
+			++ "-"
+			++ atom_to_list(proplists:get_value(testcase, Config))
+			++ "-"
+			++ integer_to_list(erlang:system_time(second))
+			++ "-"
+			++ integer_to_list(erlang:unique_integer([positive]))),
+    test_server:start_node(Name, slave, [{args, "-pa "++Pa++" "++Args}]).
+
+stop_node(Node) ->
+    test_server:stop_node(Node).
+
+mcall(Node, Funs) ->
+    Parent = self(),
+    Refs = lists:map(fun (Fun) ->
+                             Ref = make_ref(),
+                             spawn_link(Node,
+                                        fun () ->
+                                                Res = Fun(),
+                                                unlink(Parent),
+                                                Parent ! {Ref, Res}
+                                        end),
+                             Ref
+                     end, Funs),
+    lists:map(fun (Ref) ->
+                      receive
+                          {Ref, Res} ->
+                              Res
+                      end
+              end, Refs).