%%
%% %CopyrightBegin%
%%
%% Copyright Ericsson AB 1997-2011. 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_lib("test_server/include/test_server.hrl").
-compile(export_all).
suite() -> [{ct_hooks,[ts_install_cth]}].
all() ->
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,
{group, 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,otp_8949_a,split_cases].
groups() ->
[{vsn, [], [vsn_1, vsn_2, vsn_3]}].
init_per_suite(Config) ->
Config.
end_per_suite(_Config) ->
ok.
init_per_group(_GroupName, Config) ->
Config.
end_per_group(_GroupName, Config) ->
Config.
-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 is_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_1(doc) ->
"Test generation of 'vsn' attribute";
vsn_1(suite) -> [];
vsn_1(Conf) when is_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 is_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 is_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",
CompB = make_compiler_dir(Priv, CompilerB),
?line VsnB = VsnA ++ ".0",
self_compile_node(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",
self_compile_node(CompB, CompC, VsnC, Opts),
?line compare_compilers(CompB, CompC),
?line test_server:timetrap_cancel(Dog),
ok.
self_compile_node(CompilerDir, OutDir, Version, Opts) ->
?line Dog = test_server:timetrap(test_server:minutes(15)),
?line Pa = "-pa " ++ filename:dirname(code:which(?MODULE)) ++
" -pa " ++ CompilerDir,
?line Files = compiler_src(),
%% We don't want the cover server started on the other node,
%% because it will load the same cover-compiled code as on this
%% node. Use a shielded node to prevent the cover server from
%% being started.
?t:run_on_shielded_node(
fun() ->
compile_compiler(Files, OutDir, Version, Opts)
end, Pa),
?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],
test_lib:p_run(fun(File) ->
case compile:file(File, Opts) of
{ok,_} -> ok;
_ -> error
end
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.
otp_8949_b(Config) when is_list(Config) ->
self() ! something,
?line value = otp_8949_b([], false),
?line {'EXIT',_} = (catch otp_8949_b([], true)),
ok.
%% Would cause an endless loop in beam_utils.
otp_8949_b(A, B) ->
Var = id(value),
if
A == [], B == false ->
ok
end,
receive
something ->
id(Var)
end.
split_cases(_) ->
dummy1 = do_split_cases(x),
{'EXIT',{{badmatch,b},_}} = (catch do_split_cases(y)),
ok.
do_split_cases(A) ->
case A of
x ->
Z = dummy1;
_ ->
Z = dummy2,
a=b
end,
Z.
id(I) -> I.
