path: root/lib/compiler/test/compilation_SUITE.erl

%%
%% %CopyrightBegin%
%% 
%% Copyright Ericsson AB 1997-2010. All Rights Reserved.
%% 
%% The contents of this file are subject to the Erlang Public License,
%% Version 1.1, (the "License"); you may not use this file except in
%% compliance with the License. You should have received a copy of the
%% Erlang Public License along with this software. If not, it can be
%% retrieved online at http://www.erlang.org/.
%% 
%% Software distributed under the License is distributed on an "AS IS"
%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See
%% the License for the specific language governing rights and limitations
%% under the License.
%% 
%% %CopyrightEnd%
%%
%%% Purpose : Compiles various modules with tough code

-module(compilation_SUITE).

-include("test_server.hrl").

-compile(export_all).

all(suite) ->
    test_lib:recompile(?MODULE),
    [self_compile_old_inliner,self_compile,
     compiler_1,compiler_3,compiler_5,
     beam_compiler_1, beam_compiler_2, beam_compiler_3,
     beam_compiler_4, beam_compiler_5, beam_compiler_6,
     beam_compiler_7, beam_compiler_8, beam_compiler_9,
     beam_compiler_10, beam_compiler_11, beam_compiler_12,
     nested_tuples_in_case_expr,
     otp_2330, guards, vsn,
     otp_2380, otp_2141, otp_2173, otp_4790,
     const_list_256,
     bin_syntax_1, bin_syntax_2, bin_syntax_3,
     bin_syntax_4, bin_syntax_5, bin_syntax_6,
     live_var, convopts,
     bad_functional_value,
     catch_in_catch, redundant_case, long_string,
     otp_5076, complex_guard, otp_5092, otp_5151,
     otp_5235,otp_5244,
     trycatch_4, opt_crash,
     otp_5404,otp_5436,otp_5481,otp_5553,otp_5632,
     otp_5714,otp_5872,otp_6121,otp_6121a,otp_6121b,
     otp_7202,otp_7345,on_load,string_table,otp_8949_a
    ].

-define(comp(N),
	N(Config) when is_list(Config) -> try_it(N, Config)).

-define(comp_fail(N),
	N(Config) when is_list(Config) -> failure(N, Config)).

?comp(compiler_1).
?comp(compiler_3).
?comp(compiler_4).
?comp(compiler_5).

?comp(beam_compiler_1).
?comp(beam_compiler_2).
?comp(beam_compiler_3).
?comp(beam_compiler_4).
?comp(beam_compiler_5).
?comp(beam_compiler_6).
?comp(beam_compiler_8).
?comp(beam_compiler_9).
?comp(beam_compiler_10).
?comp(beam_compiler_11).
?comp(beam_compiler_12).
?comp(beam_compiler_13).

?comp(nested_tuples_in_case_expr).

?comp(otp_2330).
?comp(otp_2380).
?comp(otp_2141).
?comp(otp_2173).
?comp(otp_4790).
?comp(otp_5235).

?comp(otp_5244).

?comp(guards).

?comp(pattern_expr).

?comp(const_list_256).

?comp(bin_syntax_1).
?comp(bin_syntax_2).
?comp(bin_syntax_3).
?comp(bin_syntax_4).

?comp(bin_syntax_6).

?comp(otp_5076).

?comp(complex_guard).

?comp(otp_5092).
?comp(otp_5151).

%%% By Per Gustafsson <[email protected]>

bin_syntax_5(Config) when is_list(Config) ->
    {<<45>>,<<>>} = split({int, 1}, <<1:16,45>>).   

split({int, N}, <<N:16,B:N/binary,T/binary>>) ->
    {B,T}.

%% This program works with the old version of the compiler
%% but, the core erlang that it produces have the same variable appearing
%% looks like this:
%%
%% split({int, N}, <<_core1:16, B:N/binary, T/binary>>) when _core1==N
%%
%% with my change it will look like this:
%%
%% split({int, N}, <<_core1:16, B:_core1/binary, T/binary>>) when _core1==N
%%
%% This means that everything worked fine as long as the pattern
%% matching order was left-to-right but on core erlang any order should be possible

?comp(live_var).

?comp(trycatch_4).
?comp(bad_functional_value).

?comp(catch_in_catch).

?comp(opt_crash).

?comp(otp_5404).
?comp(otp_5436).
?comp(otp_5481).
?comp(otp_5553).
?comp(otp_5632).
?comp(otp_5714).
?comp(otp_5872).
?comp(otp_6121).
?comp(otp_6121a).
?comp(otp_6121b).
?comp(convopts).
?comp(otp_7202).
?comp(on_load).

beam_compiler_7(doc) ->
    "Code snippet submitted from Ulf Wiger which fails in R3 Beam.";
beam_compiler_7(suite) -> [];
beam_compiler_7(Config) when list(Config) ->
    ?line done = empty(2, false).

empty(N, Toggle) when N > 0 ->
    %% R3 Beam copies the second argument to the first before call.
    empty(N-1, not(Toggle));
empty(_, _) ->
    done.

redundant_case(Config) when is_list(Config) ->
    d = redundant_case_1(1),
    d = redundant_case_1(2),
    d = redundant_case_1(3),
    d = redundant_case_1(4),
    d = redundant_case_1(5),
    d = redundant_case_1({glurf,glarf}),
    ok.

%% This function always returns 'd'. Check that the compiler otptimizes
%% it properly.
redundant_case_1(1) -> d;
redundant_case_1(2) -> d;
redundant_case_1(3) -> d;
redundant_case_1(4) -> d;
redundant_case_1(_) -> d.

failure(Module, Conf) ->
    ?line Src = filename:join(?config(data_dir, Conf), atom_to_list(Module)),
    ?line Out = ?config(priv_dir,Conf),
    ?line io:format("Compiling: ~s\n", [Src]),
    ?line CompRc = compile:file(Src, [{outdir,Out},return,time]),
    ?line io:format("Result: ~p\n",[CompRc]),
    ?line case CompRc of
	      error -> ok;
	      {error,Errors,_} -> check_errors(Errors);
	      _ -> test_server:fail({no_error, CompRc})
	  end,
    ok.

check_errors([{_,Eds}|T]) ->
    check_error(Eds),
    check_errors(T);
check_errors([]) -> ok.

check_error([{_,Mod,Error}|T]) ->
    check_error_1(Mod:format_error(Error)),
    check_error(T);
check_error([{Mod,Error}|T]) ->
    check_error_1(Mod:format_error(Error)),
    check_error(T);
check_error([]) -> ok.

check_error_1(Str0) ->
    Str = lists:flatten(Str0),
    io:format("~s\n", [Str]),
    case Str of
	"internal"++_=Str ->
	    ?t:fail(internal_compiler_error);
	_ ->
	    ok
    end.

-define(TC(Body), tc(fun() -> Body end, ?LINE)).

try_it(Module, Conf) ->
    %% Change 'false' to 'true' to start a new node for every module.
    try_it(false, Module, Conf).
		       
try_it(StartNode, Module, Conf) ->
    ?line OtherOpts = [],			%Can be changed to [time] if needed
    ?line Src = filename:join(?config(data_dir, Conf), atom_to_list(Module)),
    ?line Out = ?config(priv_dir,Conf),
    ?line io:format("Compiling: ~s\n", [Src]),
    ?line CompRc0 = compile:file(Src, [clint,{outdir,Out},report,
				       bin_opt_info|OtherOpts]),
    ?line io:format("Result: ~p\n",[CompRc0]),
    ?line {ok,_Mod} = CompRc0,

    ?line Dog = test_server:timetrap(test_server:minutes(10)),
    Node = case StartNode of
	       false ->
		   node();
	       true ->
		   ?line Pa = "-pa " ++ filename:dirname(code:which(?MODULE)),
		   ?line {ok,Node0} = start_node(compiler, Pa),
		   Node0
	   end,
		   
    ?line ok = rpc:call(Node, ?MODULE, load_and_call, [Out, Module]),
    ?line load_and_call(Out, Module),
    ?line test_server:timetrap_cancel(Dog),

    ?line NewDog = test_server:timetrap(test_server:minutes(10)),
    ?line io:format("Compiling (without optimization): ~s\n", [Src]),
    ?line CompRc1 = compile:file(Src,
				 [no_copt,no_postopt,{outdir,Out},report|OtherOpts]),

    ?line io:format("Result: ~p\n",[CompRc1]),
    ?line {ok,_Mod} = CompRc1,
    ?line ok = rpc:call(Node, ?MODULE, load_and_call, [Out, Module]),
    ?line test_server:timetrap_cancel(NewDog),

    ?line LastDog = test_server:timetrap(test_server:minutes(10)),
    ?line io:format("Compiling (with old inliner): ~s\n", [Src]),
    ?line CompRc2 = compile:file(Src, [{outdir,Out},report,bin_opt_info,
				       {inline,1000}|OtherOpts]),
    ?line io:format("Result: ~p\n",[CompRc2]),
    ?line {ok,_Mod} = CompRc2,
    ?line ok = rpc:call(Node, ?MODULE, load_and_call, [Out, Module]),
    ?line test_server:timetrap_cancel(LastDog),

    case StartNode of
	false -> ok;
	true -> ?line test_server:stop_node(Node)
    end,
    ?line test_server:timetrap_cancel(LastDog),
    ok.

load_and_call(Out, Module) ->
    ?line io:format("Loading...\n",[]),
    ?line {module,Module} = code:load_abs(filename:join(Out, Module)),

    ?line io:format("Calling...\n",[]),
    %% Call M:M, and expect ok back, that's our interface
    ?line CallRc = Module:Module(),
    ?line io:format("Got value: ~p\n",[CallRc]),

    ?line ok = CallRc,

    %% Smoke-test of beam disassembler.
    ?line test_lib:smoke_disasm(Module),

    ?line true = erlang:delete_module(Module),
    ?line true = erlang:purge_module(Module),

    %% Restore state of trap_exit just in case. (Since the compiler
    %% uses a temporary process, we will get {'EXIT',Pid,normal} messages
    %% if trap_exit is true.)

    process_flag(trap_exit, false),
    ok.


tc(F, Line) ->
    {Diff,Value} = timer:tc(erlang, apply, [F,[]]),
    io:format("~p: ~p\n", [Line,Diff]),
    Value.
    
start_node(Name, Args) ->
    case test_server:start_node(Name, slave, [{args, Args}]) of
	{ok, Node} ->
	    {ok, Node};
	Error  ->
	    ?line test_server:fail(Error)
    end.

from(H, [H | T]) -> T;
from(H, [_ | T]) -> from(H, T);
from(_, []) -> [].

vsn(suite) -> [vsn_1, vsn_2, vsn_3].

vsn_1(doc) ->
    "Test generation of 'vsn' attribute";
vsn_1(suite) -> [];
vsn_1(Conf) when list(Conf) ->
    ?line M = vsn_1,

    ?line compile_load(M, ?config(data_dir, Conf), Conf),
    ?line Vsn1 = get_vsn(M),
    ?line timer:sleep(1000),

    ?line compile_load(M, ?config(data_dir, Conf), Conf),
    ?line Vsn2 = get_vsn(M),

    ?line compile_load(M, filename:join(?config(data_dir, Conf), "other"),
		       Conf),
    ?line Vsn3 = get_vsn(M),
    ?line if
	      Vsn1 == Vsn2, Vsn2 == Vsn3 ->
		  ok;
	      true ->
		  test_server:fail({vsn, Vsn1, Vsn2, Vsn3})
	  end,
    ok.

vsn_2(doc) ->
    "Test overriding of generation of 'vsn' attribute";
vsn_2(suite) -> [];
vsn_2(Conf) when list(Conf) ->
    ?line M = vsn_2,

    ?line compile_load(M, ?config(data_dir, Conf), Conf),
    ?line Vsn = get_vsn(M),
    ?line case Vsn of
	      [34] ->
		  ok;
	      _ ->
		  test_server:fail({vsn, Vsn})
	  end,
    ok.

vsn_3(doc) ->
    "Test that different code yields different generated 'vsn'";
vsn_3(suite) -> [];
vsn_3(Conf) when list(Conf) ->
    ?line M = vsn_3,

    ?line compile_load(M, ?config(data_dir, Conf), Conf),
    ?line Vsn1 = get_vsn(M),

    ?line compile_load(M, filename:join(?config(data_dir, Conf), "other"),
		       Conf),
    ?line Vsn2 = get_vsn(M),
    ?line if
	      Vsn1 /= Vsn2 ->
		  ok;
	      true ->
		  test_server:fail({vsn, Vsn1, Vsn2})
	  end,
    ok.

get_vsn(M) ->
    {value, {vsn, V}} = lists:keysearch(vsn, 1, M:module_info(attributes)),
    V.

long_string(Config) when is_list(Config) ->
    %% The test must complete in one minute - it should be plenty of time.
    ?line Dog = test_server:timetrap(test_server:minutes(1)),
    ?line try_it(long_string, Config),
    ?line test_server:timetrap_cancel(Dog),
    ok.

compile_load(Module, Dir, Conf) ->
    ?line Src = filename:join(Dir, atom_to_list(Module)),
    ?line Out = ?config(priv_dir,Conf),
    ?line CompRc = compile:file(Src, [{outdir,Out}]),
    ?line {ok, Module} = CompRc,
    ?line code:purge(Module),
    ?line {module, Module} =
	code:load_abs(filename:join(Out, atom_to_list(Module))),
    ok.

self_compile(Config) when is_list(Config) ->
    self_compile_1(Config, "new", [inline]).

self_compile_old_inliner(Config) when is_list(Config) ->
    %% The old inliner is useful for testing that sys_core_fold does not
    %% introduce name capture problems.
    self_compile_1(Config, "old", [verbose,{inline,500}]).

self_compile_1(Config, Prefix, Opts) ->
    ?line Dog = test_server:timetrap(test_server:minutes(40)),

    ?line Priv = ?config(priv_dir,Config),
    ?line Version = compiler_version(),

    %% Compile the compiler. (In this node to get better coverage.)
    ?line CompA = make_compiler_dir(Priv, Prefix++"compiler_a"),
    ?line VsnA = Version ++ ".0",
    ?line compile_compiler(compiler_src(), CompA, VsnA, [clint|Opts]),

    %% Compile the compiler again using the newly compiled compiler.
    %% (In another node because reloading the compiler would disturb cover.)
    CompilerB = Prefix++"compiler_b",
    ?line CompB = make_compiler_dir(Priv, Prefix++"compiler_b"),
    ?line VsnB = VsnA ++ ".0",
    ?line self_compile_node(CompilerB, CompA, CompB, VsnB, Opts),

    %% Compare compiler directories.
    ?line compare_compilers(CompA, CompB),

    %% Compile and compare compiler C.
    ?line CompilerC = Prefix++"compiler_c",
    ?line CompC = make_compiler_dir(Priv, CompilerC),
    ?line VsnC = VsnB ++ ".0",
    ?line self_compile_node(CompilerC, CompB, CompC, VsnC, Opts),
    ?line compare_compilers(CompB, CompC),

    ?line test_server:timetrap_cancel(Dog),
    ok.

self_compile_node(NodeName0, CompilerDir, OutDir, Version, Opts) ->
    ?line NodeName = list_to_atom(NodeName0),
    ?line Dog = test_server:timetrap(test_server:minutes(10)),
    ?line Pa = "-pa " ++ filename:dirname(code:which(?MODULE)) ++
	" -pa " ++ CompilerDir,
    ?line {ok,Node} = start_node(NodeName, Pa),
    ?line Files = compiler_src(),
    ?line ok = rpc:call(Node, ?MODULE, compile_compiler, [Files,OutDir,Version,Opts]),
    ?line test_server:stop_node(Node),
    ?line test_server:timetrap_cancel(Dog),
    ok.

compile_compiler(Files, OutDir, Version, InlineOpts) ->
    io:format("~s", [code:which(compile)]),
    io:format("Compiling ~s into ~s", [Version,OutDir]),
    Opts = [report,
	    bin_opt_info,
	    {outdir,OutDir},
	    {d,'COMPILER_VSN',"\""++Version++"\""},
	    nowarn_shadow_vars,
	    {i,filename:join(code:lib_dir(stdlib), "include")}|InlineOpts],
    lists:foreach(fun(File) ->
			  {ok,_} = compile:file(File, Opts)
		  end, Files).

compiler_src() ->
    filelib:wildcard(filename:join([code:lib_dir(compiler), "src", "*.erl"])).

compiler_modules(Dir) ->
    Files = filelib:wildcard(filename:join(Dir, "*.beam")),
    [list_to_atom(filename:rootname(filename:basename(F))) || F <- Files].

make_compiler_dir(Priv, Dir0) ->
    ?line Dir = filename:join(Priv, Dir0),
    ?line ok = file:make_dir(Dir),
    Dir.

make_current(Dir) ->    
    true = code:add_patha(Dir),
    lists:foreach(fun(File) ->
			  c:l(File)
		  end, compiler_modules(Dir)),
    io:format("~p\n", [code:which(compile)]).

compiler_version() ->
    {value,{version,Version}} = lists:keysearch(version, 1,
						compile:module_info(compile)),
    Version.

compare_compilers(ADir, BDir) ->
    {[],[],D} = beam_lib:cmp_dirs(ADir, BDir),
    [] = [T || {A,_}=T <- D,
	       filename:basename(A) =/= "beam_asm.beam"]. %Contains compiler version.


%%%
%%% The only test of the following code is that it compiles.
%%%

%% Slightly simplifed from megaco_binary_term_id_gen.
%%  beam_block failed to note that the {gc_bif,'-'...} instruction could
%%  fail, and that therefore {y,0} need to be initialized.
%%    {allocate,8,6}.
%%                     %% {init,{y,0}} needed here.       
%%    {get_list,{x,1},{x,6},{x,7}}.
%%    {'catch',{y,7},{f,3}}.
%%    {move,{x,4},{y,1}}.
%%    {move,{x,3},{y,2}}.
%%    {move,{x,2},{y,3}}.
%%    {move,{x,5},{y,4}}.
%%    {move,{x,7},{y,5}}.
%%    {move,{x,6},{y,6}}.
%%    {gc_bif,'-',{f,0},8,[{x,3},{x,6}],{x,0}}.
%%    {move,{x,0},{y,0}}.

encode_wildcards3([],[],_,_) -> [];
encode_wildcards3([Level|Levels],[BitsInLevel|BitsRest],LevelNo,TotSize) ->
    case (catch ?MODULE:encode_wildcard(Level,BitsInLevel,TotSize-BitsInLevel,
					length(Levels))) of
	{'EXIT',{Reason,Info}} ->
	    exit({Reason,{LevelNo,Info}});

	no_wildcard ->
	    encode_wildcards3(Levels,BitsRest,LevelNo+1,TotSize-BitsInLevel);
	    
	{level,Wl} ->  
	    [Wl|
	     encode_wildcards3(Levels,BitsRest,LevelNo+1,TotSize-BitsInLevel)];

	{recursive,Wr} ->  
	    [Wr]
    end.

%% Slightly simplified code from hipe_rtl_ssapre.
%%  beam_block used to do the following incorrect optimization:
%%
%%    {gc_bif,length,{f,0},1,[{x,0}],{x,3}}.
%%                                   ^^^^^ Was {x,0} - changing to {x,3} is not safe.
%%    {gc_bif,'+',{f,0},0,[{y,2},{integer,1}],{x,0}}.
%%                     ^^^ Only one register live
%%     . . .
%%    {call_last,4,{f,2},4}.   %% beam_validator noted that {x,3} wasn't live.

find_operands(Cfg,XsiGraph,[],_Count) ->
    {Cfg,XsiGraph};
find_operands(Cfg,XsiGraph,ActiveList,Count) ->
    {NewCfg,TempActiveList}=?MODULE:find_operands_for_active_list(Cfg,XsiGraph,
								  ActiveList,[]),
    NewActiveList=lists:reverse(TempActiveList),
    [Count+1, length(NewActiveList), length(digraph:vertices(XsiGraph))],
    find_operands(NewCfg,XsiGraph,NewActiveList,Count+1).


%% The following code
%%
%%    {get_list,{x,2},{x,0},{x,1}}.
%%    {gc_bif,length,{f,0},1,[{x,0}],{x,0}}.
%%    {move,{x,0},{x,1}}.
%%
%% was incorrectly optimized to
%%
%%    {get_list,{x,2},{x,0},{y,0}}.
%%    {gc_bif,length,{f,0},3,[{x,0}],{x,1}}.
%%
%% because beam_block:is_transparent({x,1},
%%                                  {gc_bif,length,{f,0},3,[{x,0}],{x,1}}
%% incorrectly returned true.

-record(contextId,{cid,device_type,contextRef}).
-record(dpRef,{cid,tlli,ms_device_context_id}).
-record(qosProfileBssgp,{peak_bit_rate_msb,
                              peak_bit_rate_lsb,
                              t_a_precedence}).
-record(llUnitdataReq,{sapi,
                            l3_pdu_length,
                            pdu_life}).
-record(ptmsi,{value}).

otp_7345(Config) when is_list(Config) ->
    #llUnitdataReq{l3_pdu_length=3,pdu_life=4} =
	otp_7345(#contextId{}, 0, [[1,2,3],4,5]).


otp_7345(ObjRef, _RdEnv, Args) ->
    Cid = ObjRef#contextId.cid,
    _DpRef =
	#dpRef{cid = Cid,
		     ms_device_context_id = cid_id,
		     tlli = #ptmsi{value = 0}},
    _QosProfile =
	#qosProfileBssgp{peak_bit_rate_msb = 0,
			 peak_bit_rate_lsb = 80,
			 t_a_precedence = 49},
    [Cpdu|_] = Args,
    LlUnitdataReq =
	#llUnitdataReq{sapi = 7,
		       l3_pdu_length = length(Cpdu),
		       pdu_life =
		       id(42)
		       div
		       10},
    id(LlUnitdataReq).

%% Check the generation of the string table.

string_table(Config) when is_list(Config) ->
    ?line DataDir = ?config(data_dir, Config),
    ?line File = filename:join(DataDir, "string_table.erl"),
    ?line {ok,string_table,Beam,[]} = compile:file(File, [return, binary]),
    ?line {ok,{string_table,[StringTableChunk]}} = beam_lib:chunks(Beam, ["StrT"]),
    ?line {"StrT", <<"stringabletringtable">>} = StringTableChunk,
    ok.

otp_8949_a(Config) when is_list(Config) ->
    value = otp_8949_a(),
    ok.

-record(cs, {exs,keys = [],flags = 1}).
-record(exs, {children = []}).

otp_8949_a() ->
    case id([#cs{}]) of
        [#cs{}=Cs] ->
            SomeVar = id(value),
	    if
		Cs#cs.flags band 1 =/= 0 ->
		    id(SomeVar);
		(((Cs#cs.exs)#exs.children /= [])
                 and
		   (Cs#cs.flags band (1 bsl 0 bor (1 bsl 22)) == 0));
		Cs#cs.flags band (1 bsl 22) =/= 0 ->
		    ok
	    end
    end.
    

id(I) -> I.