1: %%
    2: %% %CopyrightBegin%
    3: %% 
    4: %% Copyright Ericsson AB 1999-2013. All Rights Reserved.
    5: %% 
    6: %% The contents of this file are subject to the Erlang Public License,
    7: %% Version 1.1, (the "License"); you may not use this file except in
    8: %% compliance with the License. You should have received a copy of the
    9: %% Erlang Public License along with this software. If not, it can be
   10: %% retrieved online at http://www.erlang.org/.
   11: %% 
   12: %% Software distributed under the License is distributed on an "AS IS"
   13: %% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See
   14: %% the License for the specific language governing rights and limitations
   15: %% under the License.
   16: %% 
   17: %% %CopyrightEnd%
   18: %%
   19: 
   20: -module(save_calls_SUITE).
   21: 
   22: -include_lib("test_server/include/test_server.hrl").
   23: 
   24: -export([all/0, suite/0,groups/0,
   25: 	 init_per_suite/1, end_per_suite/1,
   26: 	 init_per_group/2,end_per_group/2,
   27: 	 init_per_testcase/2,end_per_testcase/2]).
   28: 
   29: -export([save_calls_1/1,dont_break_reductions/1]).
   30: 
   31: -export([do_bopp/1, do_bipp/0, do_bepp/0]).
   32: 
   33: suite() -> [{ct_hooks,[ts_install_cth]}].
   34: 
   35: all() -> 
   36:     [save_calls_1, dont_break_reductions].
   37: 
   38: groups() -> 
   39:     [].
   40: 
   41: init_per_suite(Config) ->
   42:     Config.
   43: 
   44: end_per_suite(_Config) ->
   45:     ok.
   46: 
   47: init_per_group(_GroupName, Config) ->
   48:     Config.
   49: 
   50: end_per_group(_GroupName, Config) ->
   51:     Config.
   52: 
   53: init_per_testcase(dont_break_reductions,Config) ->
   54:     %% Skip on --enable-native-libs as hipe rescedules after each
   55:     %% function call.
   56:     case erlang:system_info(hipe_architecture) of
   57: 	undefined ->
   58: 	    Config;
   59: 	Architecture ->
   60: 	    {lists, ListsBinary, _ListsFilename} = code:get_object_code(lists),
   61: 	    ChunkName = hipe_unified_loader:chunk_name(Architecture),
   62: 	    NativeChunk = beam_lib:chunks(ListsBinary, [ChunkName]),
   63: 	    case NativeChunk of
   64: 		{ok,{_,[{_,Bin}]}} when is_binary(Bin) ->
   65: 		    {skip,"Does not work for --enable-native-libs"};
   66: 		{error, beam_lib, _} -> Config
   67: 	    end
   68:     end;
   69: init_per_testcase(_,Config) ->
   70:     Config.
   71: 
   72: end_per_testcase(_,_Config) ->
   73:     ok.
   74: 
   75: dont_break_reductions(suite) ->
   76:     [];
   77: dont_break_reductions(doc) ->
   78:     ["Check that save_calls dont break reduction-based scheduling"];
   79: dont_break_reductions(Config) when is_list(Config) ->
   80:     ?line RPS1 = reds_per_sched(0),
   81:     ?line RPS2 = reds_per_sched(20),
   82:     ?line Diff = abs(RPS1 - RPS2),
   83:     ?line true = (Diff < (0.05 * RPS1)),
   84:     ok.
   85: 
   86: 
   87: reds_per_sched(SaveCalls) ->
   88:     ?line Parent = self(),
   89:     ?line HowMany = 10000,
   90:     ?line Pid = spawn(fun() -> 
   91: 			process_flag(save_calls,SaveCalls), 
   92: 			receive 
   93: 			    go -> 
   94: 				carmichaels_below(HowMany), 
   95: 				Parent ! erlang:process_info(self(),reductions)
   96: 			end 
   97: 		end),
   98:     ?line TH = spawn(fun() -> trace_handler(0,Parent,Pid) end),
   99:     ?line erlang:trace(Pid, true,[running,procs,{tracer,TH}]),
  100:     ?line Pid ! go,
  101:     ?line {Sched,Reds} = receive 
  102: 		       {accumulated,X} -> 
  103: 			   receive {reductions,Y} -> 
  104: 				   {X,Y} 
  105: 			   after 30000 -> 
  106: 				   timeout 
  107: 			   end 
  108: 		   after 30000 -> 
  109: 			   timeout 
  110: 		   end,
  111:     ?line Reds div Sched.
  112: 
  113: 
  114: 
  115: trace_handler(Acc,Parent,Client) ->
  116:     receive
  117: 	{trace,Client,out,_} ->
  118: 	    trace_handler(Acc+1,Parent,Client);
  119: 	{trace,Client,exit,_} ->
  120: 	    Parent ! {accumulated, Acc};
  121: 	_ ->
  122: 	    trace_handler(Acc,Parent,Client)
  123:     after 10000 ->
  124: 	    ok
  125:     end.
  126: 
  127: save_calls_1(doc) -> "Test call saving.";
  128: save_calls_1(Config) when is_list(Config) ->
  129:     case test_server:is_native(?MODULE) of
  130: 	true -> {skipped,"Native code"};
  131: 	false -> save_calls_1()
  132:     end.
  133: 	    
  134: save_calls_1() ->
  135:     ?line erlang:process_flag(self(), save_calls, 0),
  136:     ?line {last_calls, false} = process_info(self(), last_calls),
  137: 
  138:     ?line erlang:process_flag(self(), save_calls, 10),
  139:     ?line {last_calls, _L1} = process_info(self(), last_calls),
  140:     ?line ?MODULE:do_bipp(),
  141:     ?line {last_calls, L2} = process_info(self(), last_calls),
  142:     ?line L21 = lists:filter(fun is_local_function/1, L2),
  143:     ?line case L21 of
  144: 	      [{?MODULE,do_bipp,0},
  145: 	       timeout,
  146: 	       'send',
  147: 	       {?MODULE,do_bopp,1},
  148: 	       'receive',
  149: 	       timeout,
  150: 	       {?MODULE,do_bepp,0}] ->
  151: 		  ok;
  152: 	      X ->
  153: 		  test_server:fail({l21, X})
  154: 	  end,
  155: 
  156:     ?line erlang:process_flag(self(), save_calls, 10),
  157:     ?line {last_calls, L3} = process_info(self(), last_calls),
  158:     ?line L31 = lists:filter(fun is_local_function/1, L3),
  159:     ?line [] = L31,
  160:     ok.
  161: 
  162: do_bipp() ->
  163:     do_bopp(0),
  164:     do_bapp(),
  165:     ?MODULE:do_bopp(0),
  166:     do_bopp(3),
  167:     apply(?MODULE, do_bepp, []).
  168: 
  169: do_bapp() ->
  170:     self() ! heffaklump.
  171: 
  172: do_bopp(T) ->
  173:     receive
  174: 	X -> X
  175:     after T -> ok
  176:     end.
  177: 
  178: do_bepp() ->
  179:     ok.
  180: 
  181: is_local_function({?MODULE, _, _}) ->
  182:     true;
  183: is_local_function({_, _, _}) ->
  184:     false;
  185: is_local_function(_) ->
  186:     true.
  187: 
  188: 
  189: % Number crunching for reds test.
  190: carmichaels_below(N) ->
  191:     random:seed(3172,9814,20125),
  192:     carmichaels_below(1,N).
  193: 
  194: carmichaels_below(N,N2) when N >= N2 ->
  195:     0;
  196: carmichaels_below(N,N2) ->
  197:     X = case fast_prime(N,10) of
  198: 	false -> 0;
  199: 	true ->
  200: 	    case fast_prime2(N,10) of
  201: 		true ->
  202: 		    %io:format("Prime: ~p~n",[N]),
  203: 		    0;
  204: 		false ->
  205: 		    io:format("Carmichael: ~p (dividable by ~p)~n",
  206: 			      [N,smallest_divisor(N)]),
  207: 		    1
  208: 	    end
  209:     end,
  210:     X+carmichaels_below(N+2,N2).
  211: 
  212: expmod(_,E,_) when E == 0 ->
  213:     1;
  214: expmod(Base,Exp,Mod) when (Exp rem 2) == 0 ->
  215:     X = expmod(Base,Exp div 2,Mod),
  216:     (X*X) rem Mod;
  217: expmod(Base,Exp,Mod) -> 
  218:     (Base * expmod(Base,Exp - 1,Mod)) rem Mod.
  219: 
  220: uniform(N) ->
  221:     random:uniform(N-1).
  222: 
  223: fermat(N) ->    
  224:     R = uniform(N),
  225:     expmod(R,N,N) == R.
  226: 
  227: do_fast_prime(1,_) ->
  228:     true;
  229: do_fast_prime(_N,0) ->
  230:     true;
  231: do_fast_prime(N,Times) ->
  232:     case fermat(N) of
  233: 	true ->
  234: 	    do_fast_prime(N,Times-1);
  235: 	false ->
  236: 	    false
  237:     end.
  238:     
  239: fast_prime(N,T) ->
  240:     do_fast_prime(N,T).
  241: 
  242: expmod2(_,E,_) when E == 0 ->
  243:     1;
  244: expmod2(Base,Exp,Mod) when (Exp rem 2) == 0 ->
  245: %% Uncomment the code below to simulate scheduling bug!
  246: %     case erlang:process_info(self(),last_calls) of
  247: % 	{last_calls,false} -> ok;
  248: % 	_ -> erlang:yield()
  249: %     end,
  250:     X = expmod2(Base,Exp div 2,Mod),
  251:     Y=(X*X) rem Mod,
  252:     if 
  253: 	Y == 1, X =/= 1, X =/= (Mod - 1) ->
  254: 	    0;
  255: 	true ->
  256: 	    Y rem Mod
  257:     end;
  258: expmod2(Base,Exp,Mod) -> 
  259:     (Base * expmod2(Base,Exp - 1,Mod)) rem Mod.
  260: 
  261: miller_rabbin(N) ->
  262:     R = uniform(N),
  263:     expmod2(R,N,N) == R.
  264: 
  265: do_fast_prime2(1,_) ->
  266:     true;
  267: do_fast_prime2(_N,0) ->
  268:     true;
  269: do_fast_prime2(N,Times) ->
  270:     case miller_rabbin(N) of
  271: 	true ->
  272: 	    do_fast_prime2(N,Times-1);
  273: 	false ->
  274: 	    false
  275:     end.
  276:     
  277: fast_prime2(N,T) ->
  278:     do_fast_prime2(N,T).
  279: 
  280: smallest_divisor(N) ->
  281:     find_divisor(N,2).
  282: 
  283: find_divisor(N,TD) ->
  284:     if 
  285: 	TD*TD > N ->
  286: 	    N;
  287: 	true ->
  288: 	    case divides(TD,N) of
  289: 		true ->
  290: 		    TD;
  291: 		false ->
  292: 		    find_divisor(N,TD+1)
  293: 	    end
  294:     end.
  295: 
  296: divides(A,B) ->
  297:     (B rem A) == 0.
  298: