diff options
Diffstat (limited to 'lib')
85 files changed, 4936 insertions, 507 deletions
diff --git a/lib/asn1/src/asn1ct_imm.erl b/lib/asn1/src/asn1ct_imm.erl index 527f4f0ba9..e09256cde9 100644 --- a/lib/asn1/src/asn1ct_imm.erl +++ b/lib/asn1/src/asn1ct_imm.erl @@ -1120,38 +1120,41 @@ per_enc_constrained(Val0, Lb, Ub, false) -> per_enc_constrained(Val0, Lb, Ub, true) -> {Prefix,Val} = sub_lb(Val0, Lb), Range = Ub - Lb + 1, + Check = {ult,Val,Range}, if Range < 256 -> NumBits = per_num_bits(Range), - Check = {ult,Val,Range}, Put = [{put_bits,Val,NumBits,[1]}], {Prefix,Check,Put}; Range =:= 256 -> NumBits = 8, - Check = {ult,Val,Range}, Put = [{put_bits,Val,NumBits,[1,align]}], {Prefix,Check,Put}; Range =< 65536 -> - Check = {ult,Val,Range}, Put = [{put_bits,Val,16,[1,align]}], {Prefix,Check,Put}; true -> - {var,VarBase} = Val, - Bin = {var,VarBase++"@bin"}, - BinSize0 = {var,VarBase++"@bin_size0"}, - BinSize = {var,VarBase++"@bin_size"}, - Check = {ult,Val,Range}, RangeOctsLen = byte_size(binary:encode_unsigned(Range - 1)), BitsNeeded = per_num_bits(RangeOctsLen), - Enc = [{call,binary,encode_unsigned,[Val],Bin}, - {call,erlang,byte_size,[Bin],BinSize0}, - {sub,BinSize0,1,BinSize}, - {'cond',[['_', - {put_bits,BinSize,BitsNeeded,[1]}, - {put_bits,Bin,binary,[8,align]}]]}], - {Prefix,Check,Enc} + {Prefix,Check,per_enc_constrained_huge(BitsNeeded, Val)} end. +per_enc_constrained_huge(BitsNeeded, {var,VarBase}=Val) -> + Bin = {var,VarBase++"@bin"}, + BinSize0 = {var,VarBase++"@bin_size0"}, + BinSize = {var,VarBase++"@bin_size"}, + [{call,binary,encode_unsigned,[Val],Bin}, + {call,erlang,byte_size,[Bin],BinSize0}, + {sub,BinSize0,1,BinSize}, + {'cond',[['_', + {put_bits,BinSize,BitsNeeded,[1]}, + {put_bits,Bin,binary,[8,align]}]]}]; +per_enc_constrained_huge(BitsNeeded, Val) when is_integer(Val) -> + Bin = binary:encode_unsigned(Val), + BinSize = erlang:byte_size(Bin), + [{put_bits,BinSize-1,BitsNeeded,[1]}, + {put_bits,Val,8*BinSize,[1,align]}]. + per_enc_unconstrained(Val, Aligned) -> case Aligned of false -> []; diff --git a/lib/asn1/test/asn1_SUITE_data/Prim.asn1 b/lib/asn1/test/asn1_SUITE_data/Prim.asn1 index b4c011fd39..4fe0901683 100644 --- a/lib/asn1/test/asn1_SUITE_data/Prim.asn1 +++ b/lib/asn1/test/asn1_SUITE_data/Prim.asn1 @@ -60,4 +60,11 @@ BEGIN e BOOLEAN, magic INTEGER } + + Longitude ::= INTEGER { + oneMicrodegreeEast(10), + oneMicrodegreeWest(-10), + unavailable(1800000001) + } (-1799999999..1800000001) + END diff --git a/lib/asn1/test/testPrim.erl b/lib/asn1/test/testPrim.erl index 8fa9973ea5..dc2e0fa2e7 100644 --- a/lib/asn1/test/testPrim.erl +++ b/lib/asn1/test/testPrim.erl @@ -78,8 +78,37 @@ int(Rules) -> roundtrip('ASeq', {'ASeq',false,250,true,200,true,199,true,77788}), roundtrip('ASeq', {'ASeq',true,0,false,0,true,0,true,68789}), + %%========================================================== + %% Longitude ::= INTEGER { + %% oneMicrodegreeEast(10), + %% oneMicrodegreeWest(-10), + %% unavailable(1800000001) + %% } (-1799999999..1800000001) + %%========================================================== + + Enc10 = encoding(Rules, oneMicrodegreeEast), + Enc10 = roundtrip('Longitude', oneMicrodegreeEast), + Enc10 = roundtrip('Longitude', 10, oneMicrodegreeEast), + + Enc20 = encoding(Rules, oneMicrodegreeWest), + Enc20 = roundtrip('Longitude', oneMicrodegreeWest), + Enc20 = roundtrip('Longitude', -10, oneMicrodegreeWest), + + Enc30 = roundtrip('Longitude', unavailable), + Enc30 = roundtrip('Longitude', 1800000001, unavailable), + ok. +encoding(Rules, Type) -> + asn1_test_lib:hex_to_bin(encoding_1(Rules, Type)). + +encoding_1(ber, oneMicrodegreeEast) -> "02010A"; +encoding_1(per, oneMicrodegreeEast) -> "C06B49D2 09"; +encoding_1(uper, oneMicrodegreeEast) -> "6B49D209"; + +encoding_1(ber, oneMicrodegreeWest) -> "0201F6"; +encoding_1(per, oneMicrodegreeWest) -> "C06B49D1 F5"; +encoding_1(uper, oneMicrodegreeWest) -> "6B49D1F5". enum(Rules) -> diff --git a/lib/compiler/src/beam_bool.erl b/lib/compiler/src/beam_bool.erl index 14b6381230..d14be83496 100644 --- a/lib/compiler/src/beam_bool.erl +++ b/lib/compiler/src/beam_bool.erl @@ -142,11 +142,6 @@ bopt_block(Reg, Fail, OldIs, [{block,Bl0}|Acc0], St0) -> throw:not_boolean_expr -> failed; - %% The block contains a 'move' instruction that could - %% not be handled. - throw:move -> - failed; - %% The optimization is not safe. (A register %% used by the instructions following the %% optimized code is either not assigned a @@ -215,37 +210,14 @@ ensure_opt_safe(Bl, NewCode, OldIs, Fail, PrecedingCode, St) -> false -> throw(all_registers_not_killed); true -> ok end, - Same = assigned_same_value(Bl, NewCode), MustBeUnused = ordsets:subtract(ordsets:union(NotSet, NewDst), - ordsets:union(MustBeKilled, Same)), + MustBeKilled), case none_used(MustBeUnused, OldIs, Fail, St) of false -> throw(registers_used); true -> ok end, ok. -%% assigned_same_value(OldCode, NewCodeReversed) -> [DestinationRegs] -%% Return an ordset with a list of all y registers that are always -%% assigned the same value in the old and new code. Currently, we -%% are very conservative in that we only consider identical move -%% instructions in the same order. -%% -assigned_same_value(Old, New) -> - case reverse(New) of - [{block,Bl}|_] -> - assigned_same_value(Old, Bl, []); - _ -> - ordsets:new() - end. - -assigned_same_value([{set,[{y,_}=D],[S],move}|T1], - [{set,[{y,_}=D],[S],move}|T2], Acc) -> - assigned_same_value(T1, T2, [D|Acc]); -assigned_same_value(_, _, Acc) -> - ordsets:from_list(Acc). - -update_fail_label([{set,_,_,move}=I|Is], Fail, Acc) -> - update_fail_label(Is, Fail, [I|Acc]); update_fail_label([{set,Ds,As,{bif,N,{f,_}}}|Is], Fail, Acc) -> update_fail_label(Is, Fail, [{set,Ds,As,{bif,N,{f,Fail}}}|Acc]); update_fail_label([{set,Ds,As,{alloc,Regs,{gc_bif,N,{f,_}}}}|Is], Fail, Acc) -> @@ -314,8 +286,6 @@ split_block_1(Is, Fail, ProhibitFailLabel) -> end end. -split_block_2([{set,_,_,move}=I|Is], Fail, Acc) -> - split_block_2(Is, Fail, [I|Acc]); split_block_2([{set,[_],_,{bif,_,{f,Fail}}}=I|Is], Fail, Acc) -> split_block_2(Is, Fail, [I|Acc]); split_block_2([{set,[_],_,{alloc,_,{gc_bif,_,{f,Fail}}}}=I|Is], Fail, Acc) -> @@ -343,8 +313,6 @@ dst_regs([{set,[D],_,{bif,_,{f,_}}}|Is], Acc) -> dst_regs(Is, [D|Acc]); dst_regs([{set,[D],_,{alloc,_,{gc_bif,_,{f,_}}}}|Is], Acc) -> dst_regs(Is, [D|Acc]); -dst_regs([{set,[D],_,move}|Is], Acc) -> - dst_regs(Is, [D|Acc]); dst_regs([_|Is], Acc) -> dst_regs(Is, Acc); dst_regs([], Acc) -> ordsets:from_list(Acc). @@ -411,13 +379,6 @@ bopt_tree([{protected,[Dst],Code,_}|Is], Forest0, Pre) -> _Res -> throw(not_boolean_expr) end; -bopt_tree([{set,[Dst],[Src],move}=Move|Is], Forest, Pre) -> - case {Src,Dst} of - {{tmp,_},_} -> throw(move); - {_,{tmp,_}} -> throw(move); - _ -> ok - end, - bopt_tree(Is, Forest, [Move|Pre]); bopt_tree([{set,[Dst],As,{bif,N,_}}=Bif|Is], Forest0, Pre) -> Ar = length(As), case safe_bool_op(N, Ar) of @@ -589,10 +550,6 @@ free_variables(Is) -> E = gb_sets:empty(), free_vars_1(Is, E, E, E). -free_vars_1([{set,Ds,As,move}|Is], F0, N0, A) -> - F = gb_sets:union(F0, gb_sets:difference(var_list(As), N0)), - N = gb_sets:union(N0, var_list(Ds)), - free_vars_1(Is, F, N, A); free_vars_1([{set,Ds,As,{bif,_,_}}|Is], F0, N0, A) -> F = gb_sets:union(F0, gb_sets:difference(var_list(As), N0)), N = gb_sets:union(N0, var_list(Ds)), @@ -632,8 +589,6 @@ free_vars_regs(X) -> [{x,X-1}|free_vars_regs(X-1)]. rename_regs(Is, Regs) -> rename_regs(Is, Regs, []). -rename_regs([{set,_,_,move}=I|Is], Regs, Acc) -> - rename_regs(Is, Regs, [I|Acc]); rename_regs([{set,[Dst0],Ss0,{alloc,_,Info}}|Is], Regs0, Acc) -> Live = live_regs(Regs0), Ss = rename_sources(Ss0, Regs0), @@ -737,8 +692,7 @@ ssa_assign({x,_}=R, #ssa{sub=Sub0}=Ssa0) -> Sub1 = gb_trees:update(R, NewReg, Sub0), Sub = gb_trees:insert(NewReg, NewReg, Sub1), Ssa#ssa{sub=Sub} - end; -ssa_assign(_, Ssa) -> Ssa. + end. ssa_sub_list(List, Sub) -> [ssa_sub(E, Sub) || E <- List]. diff --git a/lib/compiler/src/cerl.erl b/lib/compiler/src/cerl.erl index 010327b5e3..e7a2b8177a 100644 --- a/lib/compiler/src/cerl.erl +++ b/lib/compiler/src/cerl.erl @@ -1598,13 +1598,20 @@ is_c_map(#c_literal{val = V}) when is_map(V) -> is_c_map(_) -> false. --spec map_es(c_map()) -> [c_map_pair()]. +-spec map_es(c_map() | c_literal()) -> [c_map_pair()]. +map_es(#c_literal{anno=As,val=M}) when is_map(M) -> + [ann_c_map_pair(As, + #c_literal{anno=As,val='assoc'}, + #c_literal{anno=As,val=K}, + #c_literal{anno=As,val=V}) || {K,V} <- maps:to_list(M)]; map_es(#c_map{es = Es}) -> Es. --spec map_arg(c_map()) -> c_map() | c_literal(). +-spec map_arg(c_map() | c_literal()) -> c_map() | c_literal(). +map_arg(#c_literal{anno=As,val=M}) when is_map(M) -> + #c_literal{anno=As,val=#{}}; map_arg(#c_map{arg=M}) -> M. diff --git a/lib/compiler/src/v3_codegen.erl b/lib/compiler/src/v3_codegen.erl index 34c67b16ca..2a89305f4d 100644 --- a/lib/compiler/src/v3_codegen.erl +++ b/lib/compiler/src/v3_codegen.erl @@ -1327,12 +1327,13 @@ bif_cg(Bif, As, [{var,V}], Le, Vdb, Bef, St0) -> %% that we save any variable that will be live after this BIF call. MayFail = not erl_bifs:is_safe(erlang, Bif, length(As)), - {Sis,Int0} = case St0#cg.in_catch andalso - St0#cg.bfail =:= 0 andalso - MayFail of - true -> adjust_stack(Bef, Le#l.i, Le#l.i+1, Vdb); - false -> {[],Bef} - end, + {Sis,Int0} = + case MayFail of + true -> + maybe_adjust_stack(Bef, Le#l.i, Le#l.i+1, Vdb, St0); + false -> + {[],Bef} + end, Int1 = clear_dead(Int0, Le#l.i, Vdb), Reg = put_reg(V, Int1#sr.reg), Int = Int1#sr{reg=Reg}, @@ -1363,11 +1364,7 @@ gc_bif_cg(Bif, As, [{var,V}], Le, Vdb, Bef, St0) -> %% Currently, we are somewhat pessimistic in %% that we save any variable that will be live after this BIF call. - {Sis,Int0} = - case St0#cg.in_catch andalso St0#cg.bfail =:= 0 of - true -> adjust_stack(Bef, Le#l.i, Le#l.i+1, Vdb); - false -> {[],Bef} - end, + {Sis,Int0} = maybe_adjust_stack(Bef, Le#l.i, Le#l.i+1, Vdb, St0), Int1 = clear_dead(Int0, Le#l.i, Vdb), Reg = put_reg(V, Int1#sr.reg), @@ -1512,8 +1509,7 @@ set_cg([{var,R}], {cons,Es}, Le, Vdb, Bef, St) -> Int1 = Int0#sr{reg=put_reg(R, Int0#sr.reg)}, Ret = fetch_reg(R, Int1#sr.reg), {[{put_list,S1,S2,Ret}], Int1, St}; -set_cg([{var,R}], {binary,Segs}, Le, Vdb, Bef, - #cg{in_catch=InCatch, bfail=Bfail}=St) -> +set_cg([{var,R}], {binary,Segs}, Le, Vdb, Bef, #cg{bfail=Bfail}=St) -> %% At run-time, binaries are constructed in three stages: %% 1) First the size of the binary is calculated. %% 2) Then the binary is allocated. @@ -1532,11 +1528,7 @@ set_cg([{var,R}], {binary,Segs}, Le, Vdb, Bef, %% First generate the code that constructs each field. Fail = {f,Bfail}, PutCode = cg_bin_put(Segs, Fail, Bef), - {Sis,Int1} = - case InCatch of - true -> adjust_stack(Int0, Le#l.i, Le#l.i+1, Vdb); - false -> {[],Int0} - end, + {Sis,Int1} = maybe_adjust_stack(Int0, Le#l.i, Le#l.i+1, Vdb, St), MaxRegs = max_reg(Bef#sr.reg), Aft = clear_dead(Int1, Le#l.i, Vdb), @@ -1545,14 +1537,11 @@ set_cg([{var,R}], {binary,Segs}, Le, Vdb, Bef, {Sis++Code,Aft,St}; % Map single variable key set_cg([{var,R}], {map,Op,Map,[{map_pair,{var,_}=K,V}]}, Le, Vdb, Bef, - #cg{in_catch=InCatch,bfail=Bfail}=St) -> + #cg{bfail=Bfail}=St) -> Fail = {f,Bfail}, - {Sis,Int0} = - case InCatch of - true -> adjust_stack(Bef, Le#l.i, Le#l.i+1, Vdb); - false -> {[],Bef} - end, + {Sis,Int0} = maybe_adjust_stack(Bef, Le#l.i, Le#l.i+1, Vdb, St), + SrcReg = cg_reg_arg(Map,Int0), Line = line(Le#l.a), @@ -1573,17 +1562,13 @@ set_cg([{var,R}], {map,Op,Map,[{map_pair,{var,_}=K,V}]}, Le, Vdb, Bef, % Map (possibly) multiple literal keys set_cg([{var,R}], {map,Op,Map,Es}, Le, Vdb, Bef, - #cg{in_catch=InCatch,bfail=Bfail}=St) -> + #cg{bfail=Bfail}=St) -> %% assert key literals [] = [Var||{map_pair,{var,_}=Var,_} <- Es], Fail = {f,Bfail}, - {Sis,Int0} = - case InCatch of - true -> adjust_stack(Bef, Le#l.i, Le#l.i+1, Vdb); - false -> {[],Bef} - end, + {Sis,Int0} = maybe_adjust_stack(Bef, Le#l.i, Le#l.i+1, Vdb, St), SrcReg = cg_reg_arg(Map,Int0), Line = line(Le#l.a), @@ -2038,6 +2023,19 @@ trim_free([R|Rs0]) -> end; trim_free([]) -> []. +%% maybe_adjust_stack(Bef, FirstBefore, LastFrom, Vdb, St) -> {[Ainstr],Aft}. +%% Adjust the stack, but only if the code is inside a catch and not +%% inside a guard. Use this funtion before instructions that may +%% cause an exception. + +maybe_adjust_stack(Bef, Fb, Lf, Vdb, St) -> + case St of + #cg{in_catch=true,bfail=0} -> + adjust_stack(Bef, Fb, Lf, Vdb); + #cg{} -> + {[],Bef} + end. + %% adjust_stack(Bef, FirstBefore, LastFrom, Vdb) -> {[Ainstr],Aft}. %% Do complete stack adjustment by compressing stack and adding %% variables to be saved. Try to optimise ordering on stack by diff --git a/lib/compiler/src/v3_core.erl b/lib/compiler/src/v3_core.erl index 0941ad5dd5..7d93e2ae16 100644 --- a/lib/compiler/src/v3_core.erl +++ b/lib/compiler/src/v3_core.erl @@ -804,7 +804,7 @@ map_op(map_field_assoc) -> #c_literal{val=assoc}; map_op(map_field_exact) -> #c_literal{val=exact}. is_valid_map_src(#c_literal{val = M}) when is_map(M) -> true; -is_valid_map_src(#c_var{}) -> true; +is_valid_map_src(#c_var{}=Var) -> not cerl:is_c_fname(Var); is_valid_map_src(_) -> false. %% try_exception([ExcpClause], St) -> {[ExcpVar],Handler,St}. diff --git a/lib/compiler/test/guard_SUITE.erl b/lib/compiler/test/guard_SUITE.erl index b3b67155b3..47eb1ba78b 100644 --- a/lib/compiler/test/guard_SUITE.erl +++ b/lib/compiler/test/guard_SUITE.erl @@ -34,7 +34,8 @@ tricky/1,rel_ops/1,rel_op_combinations/1,literal_type_tests/1, basic_andalso_orelse/1,traverse_dcd/1, check_qlc_hrl/1,andalso_semi/1,t_tuple_size/1,binary_part/1, - bad_constants/1,bad_guards/1]). + bad_constants/1,bad_guards/1,scotland/1, + guard_in_catch/1]). suite() -> [{ct_hooks,[ts_install_cth]}]. @@ -52,7 +53,7 @@ groups() -> rel_ops,rel_op_combinations, literal_type_tests,basic_andalso_orelse,traverse_dcd, check_qlc_hrl,andalso_semi,t_tuple_size,binary_part, - bad_constants,bad_guards]}]. + bad_constants,bad_guards,scotland,guard_in_catch]}]. init_per_suite(Config) -> Config. @@ -1831,6 +1832,80 @@ bad_guards_2(M, [_]) when M#{a := 0, b => 0}, map_size(M) -> bad_guards_3(M, [_]) when is_map(M) andalso M#{a := 0, b => 0}, length(M) -> ok. +%% beam_bool would remove the initialization of {y,0}. +%% (Thanks to Thomas Arts and QuickCheck.) + +scotland(_Config) -> + million = do_scotland(placed), + {'EXIT',{{badmatch,placed},_}} = (catch do_scotland(false)), + {'EXIT',{{badmatch,placed},_}} = (catch do_scotland(true)), + {'EXIT',{{badmatch,placed},_}} = (catch do_scotland(echo)), + ok. + +do_scotland(Echo) -> + found(case Echo of + Echo when true; Echo, Echo, Echo -> + Echo; + echo -> + [] + end, + Echo = placed). + +found(_, _) -> million. + +%% Building maps in a guard in a 'catch' would crash v3_codegen. + +guard_in_catch(_Config) -> + {'EXIT',{if_clause,_}} = do_guard_in_catch_map_1(#{}), + {'EXIT',{if_clause,_}} = do_guard_in_catch_map_1(#{a=>b}), + {'EXIT',{if_clause,_}} = do_guard_in_catch_map_1(atom), + + {'EXIT',{if_clause,_}} = do_guard_in_catch_map_2(#{}), + {'EXIT',{if_clause,_}} = do_guard_in_catch_map_2(#{a=>b}), + {'EXIT',{if_clause,_}} = do_guard_in_catch_map_2(atom), + + {'EXIT',{if_clause,_}} = (catch do_guard_in_catch_map_3()), + + {'EXIT',{if_clause,_}} = do_guard_in_catch_bin(42), + {'EXIT',{if_clause,_}} = do_guard_in_catch_bin(<<1,2,3>>), + {'EXIT',{if_clause,_}} = do_guard_in_catch_bin(atom), + {'EXIT',{if_clause,_}} = do_guard_in_catch_bin(#{}), + + ok. + +do_guard_in_catch_map_1(From) -> + catch + if + From#{[] => sufficient} -> + saint + end. + +do_guard_in_catch_map_2(From) -> + catch + if + From#{From => sufficient} -> + saint + end. + +do_guard_in_catch_map_3() -> + try + if [] -> solo end + catch + Friendly when Friendly#{0 => []} -> minutes + after + membership + end. + +do_guard_in_catch_bin(From) -> + %% Would not crash v3_codegen, but there would be an unnecessary + %% 'move' to a Y register. + catch + if + <<From:32>> -> + saint + end. + + %% Call this function to turn off constant propagation. id(I) -> I. diff --git a/lib/compiler/test/map_SUITE.erl b/lib/compiler/test/map_SUITE.erl index 411b15eebe..cff3b5deb4 100644 --- a/lib/compiler/test/map_SUITE.erl +++ b/lib/compiler/test/map_SUITE.erl @@ -883,6 +883,9 @@ t_update_map_expressions(Config) when is_list(Config) -> %% Error cases. {'EXIT',{{badmap,<<>>},_}} = (catch (id(<<>>))#{ a := 42, b => 2 }), {'EXIT',{{badmap,[]},_}} = (catch (id([]))#{ a := 42, b => 2 }), + {'EXIT',{{badmap,_},_}} = + (catch (fun t_update_map_expressions/1)#{u => 42}), + ok. diff --git a/lib/crypto/c_src/crypto.c b/lib/crypto/c_src/crypto.c index 9de8dc74c2..3c73c318ed 100644 --- a/lib/crypto/c_src/crypto.c +++ b/lib/crypto/c_src/crypto.c @@ -2042,6 +2042,7 @@ static ERL_NIF_TERM aes_ecb_crypt(ErlNifEnv* env, int argc, const ERL_NIF_TERM a ErlNifBinary key_bin, data_bin; AES_KEY aes_key; int i; + int j; unsigned char* ret_ptr; ERL_NIF_TERM ret; @@ -2064,7 +2065,9 @@ static ERL_NIF_TERM aes_ecb_crypt(ErlNifEnv* env, int argc, const ERL_NIF_TERM a } ret_ptr = enif_make_new_binary(env, data_bin.size, &ret); - AES_ecb_encrypt(data_bin.data, ret_ptr, &aes_key, i); + for (j = 0; j < data_bin.size; j += 16) { + AES_ecb_encrypt(data_bin.data+j, ret_ptr+j, &aes_key, i); + } CONSUME_REDS(env,data_bin); return ret; } diff --git a/lib/crypto/test/crypto_SUITE.erl b/lib/crypto/test/crypto_SUITE.erl index e84f5e1075..802c8a4df4 100644 --- a/lib/crypto/test/crypto_SUITE.erl +++ b/lib/crypto/test/crypto_SUITE.erl @@ -1301,7 +1301,23 @@ aes_ecb() -> <<"0000000000000000">>}, {aes_ecb, <<"FEDCBA9876543210">>, - <<"FFFFFFFFFFFFFFFF">>} + <<"FFFFFFFFFFFFFFFF">>}, + %% AES ECB test vectors from http://csrc.nist.gov/publications/nistpubs/800-38a/sp800-38a.pdf + %% F.1.1 ECB-AES128.Encrypt, F.1.2 ECB-AES128.Decrypt + {aes_ecb, + hexstr2bin("2b7e151628aed2a6abf7158809cf4f3c"), + hexstr2bin("6bc1bee22e409f96e93d7e117393172a" + "ae2d8a571e03ac9c9eb76fac45af8e51" + "30c81c46a35ce411e5fbc1191a0a52ef" + "f69f2445df4f9b17ad2b417be66c3710")}, + %% F.1.5 ECB-AES256.Encrypt, F.1.6 ECB-AES256.Decrypt + {aes_ecb, + hexstr2bin("603deb1015ca71be2b73aef0857d7781" + "1f352c073b6108d72d9810a30914dff4"), + hexstr2bin("6bc1bee22e409f96e93d7e117393172a" + "ae2d8a571e03ac9c9eb76fac45af8e51" + "30c81c46a35ce411e5fbc1191a0a52ef" + "f69f2445df4f9b17ad2b417be66c3710")} ]. aes_ige256() -> diff --git a/lib/dialyzer/test/small_SUITE_data/results/maps1 b/lib/dialyzer/test/small_SUITE_data/results/maps1 new file mode 100644 index 0000000000..5a78d66a92 --- /dev/null +++ b/lib/dialyzer/test/small_SUITE_data/results/maps1 @@ -0,0 +1,4 @@ + +maps1.erl:43: Function t3/0 has no local return +maps1.erl:44: The call maps1:foo(~{'greger'=>3, ~{'arne'=>'anka'}~=>45}~,1) will never return since it differs in the 2nd argument from the success typing arguments: (#{},'b') +maps1.erl:52: The call Mod:'function'(~{'literal'=>'map'}~,'another_arg') requires that Mod is of type atom() | tuple() not #{} diff --git a/lib/dialyzer/test/small_SUITE_data/src/maps1.erl b/lib/dialyzer/test/small_SUITE_data/src/maps1.erl index 06ced5b69e..bb2f66a498 100644 --- a/lib/dialyzer/test/small_SUITE_data/src/maps1.erl +++ b/lib/dialyzer/test/small_SUITE_data/src/maps1.erl @@ -39,3 +39,15 @@ t2() -> ok. update(#{ id := Id, val := Val } = M, X) when is_integer(Id) -> M#{ val := [Val,X] }. + +t3() -> + foo(#{greger => 3, #{arne=>anka} => 45}, 1). + +foo(#{} = M, b) -> %% Error + M#{alfa => 42, beta := 1337}. + +t4() -> + case #{} of + #{} -> ok; + Mod -> Mod:function(#{literal => map}, another_arg) %% Error + end. diff --git a/lib/diameter/doc/src/diameter.xml b/lib/diameter/doc/src/diameter.xml index 61b7fd1337..5cb29c80e3 100644 --- a/lib/diameter/doc/src/diameter.xml +++ b/lib/diameter/doc/src/diameter.xml @@ -467,7 +467,7 @@ Matches only those peers whose Origin-Host has the specified value, or all peers if the atom <c>any</c>.</p> </item> -<tag><c>{realm, any|&dict_DiameterIdentity;</c></tag> +<tag><c>{realm, any|&dict_DiameterIdentity;}</c></tag> <item> <p> Matches only those peers whose Origin-Realm has the @@ -500,18 +500,22 @@ Matches only those peers matched by each filter in the specified list.</p> <item> <p> Matches only those peers matched by at least one filter in the -specified list.</p> +specified list. +The resulting list will be in match order, peers matching the +first filter of the list sorting before those matched by the second, +and so on.</p> +</item> +<tag><c>{first, [&peer_filter;]}</c></tag> +<item> <p> -The resulting peer list will be in match order, peers matching the -first filter of the list sorting before those matched by the second, -and so on. -For example, the following filter causes peers matching both the host -and realm filters to be presented before those matching only the realm -filter.</p> +Like <c>any</c>, but stops at the first filter for which there are +matches, which can be much more efficient when there are many peers. +For example, the following filter causes only peers best matching +both the host and realm filters to be presented.</p> <pre> -{any, [{all, [host, realm]}, realm]} +{first, [{all, [host, realm]}, realm]} </pre> </item> diff --git a/lib/diameter/test/diameter_traffic_SUITE.erl b/lib/diameter/test/diameter_traffic_SUITE.erl index 7e316c03f1..967a0bf591 100644 --- a/lib/diameter/test/diameter_traffic_SUITE.erl +++ b/lib/diameter/test/diameter_traffic_SUITE.erl @@ -725,7 +725,8 @@ send_any_2(Config) -> Req = ['STR', {'Termination-Cause', ?LOGOUT}, {'Destination-Host', [?HOST(SN, "unknown.org")]}], ?answer_message(?UNABLE_TO_DELIVER) - = call(Config, Req, [{filter, {any, [host, realm]}}]). + = call(Config, Req, [{filter, {first, [{all, [host, realm]}, + realm]}}]). %% Send with a conjunctive filter. send_all_1(Config) -> diff --git a/lib/edoc/doc/overview.edoc b/lib/edoc/doc/overview.edoc index 3639bb43a5..d2bba9d744 100644 --- a/lib/edoc/doc/overview.edoc +++ b/lib/edoc/doc/overview.edoc @@ -755,7 +755,7 @@ following escape sequences may be used: <dl> === Function specifications === -<note>Although the syntax described in the following can still be used +Note that although the syntax described in the following can still be used for specifying functions we recommend that Erlang specifications as described in <seealso marker="doc/reference_manual:typespec"> Types and Function Specification</seealso> should be added to the source @@ -764,7 +764,6 @@ marker="dialyzer:dialyzer">Dialyzer</seealso>'s can be utilized in the process of keeping the documentation consistent and up-to-date. Erlang specifications will be used unless there is also a function specification (a `@spec' tag followed by a type) with the same name. -</note> The following grammar describes the form of the specifications following a `@spec' tag. A '`?'' suffix implies that the element is optional. @@ -973,12 +972,12 @@ contain any annotations at all. === Type definitions === -<note>Although the syntax described in the following can still be used +Note that although the syntax described in the following can still be used for specifying types we recommend that Erlang types as described in <seealso marker="doc/reference_manual:typespec"> Types and Function Specification</seealso> should be added to the source code instead. Erlang types will be used unless there is a type alias with the same -name.</note> +name. The following grammar (see above for auxiliary definitions) describes the form of the definitions that may follow a `@type' tag: diff --git a/lib/edoc/src/edoc.erl b/lib/edoc/src/edoc.erl index 90f1fc3071..d2494b69fe 100644 --- a/lib/edoc/src/edoc.erl +++ b/lib/edoc/src/edoc.erl @@ -555,7 +555,6 @@ read_source(Name) -> %% <dd>Specifies a list of pre-defined Erlang preprocessor (`epp') %% macro definitions, used if the `preprocess' option is turned on. %% The default value is the empty list.</dd> -%% </dl> %% <dt>{@type {report_missing_types, boolean()@}} %% </dt> %% <dd>If the value is `true', warnings are issued for missing types. @@ -563,6 +562,7 @@ read_source(Name) -> %% `no_report_missing_types' is an alias for %% `{report_missing_types, false}'. %% </dd> +%% </dl> %% %% @see get_doc/2 %% @see //syntax_tools/erl_syntax diff --git a/lib/edoc/src/edoc_specs.erl b/lib/edoc/src/edoc_specs.erl index bb98e8b04f..f2e5891c2e 100644 --- a/lib/edoc/src/edoc_specs.erl +++ b/lib/edoc/src/edoc_specs.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1996-2015. All Rights Reserved. +%% Copyright Ericsson AB 1996-2016. 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. @@ -270,12 +270,8 @@ parms([], []) -> parms([A | As], [D | Ds]) -> [param(A, D) | parms(As, Ds)]. -param(#t_list{type = Type}, Default) -> - param(Type, Default); param(#t_paren{type = Type}, Default) -> param(Type, Default); -param(#t_nonempty_list{type = Type}, Default) -> - param(Type, Default); param(#t_record{name = #t_atom{val = Name}}, _Default) -> list_to_atom(capitalize(atom_to_list(Name))); param(T, Default) -> diff --git a/lib/erl_docgen/src/docgen_otp_specs.erl b/lib/erl_docgen/src/docgen_otp_specs.erl index 37baa7c2f9..e154323f07 100644 --- a/lib/erl_docgen/src/docgen_otp_specs.erl +++ b/lib/erl_docgen/src/docgen_otp_specs.erl @@ -729,5 +729,9 @@ annos_type([E=#xmlElement{name = typevar}]) -> annos_elem(E); annos_type([#xmlElement{name = paren, content = Es}]) -> annos(get_elem(type, Es)); +annos_type([#xmlElement{name = map, content = Es}]) -> + lists:flatmap(fun(E) -> annos_type([E]) end, Es); +annos_type([#xmlElement{name = map_field, content = Es}]) -> + lists:flatmap(fun annos_elem/1, get_elem(type,Es)); annos_type(_) -> []. diff --git a/lib/hipe/cerl/cerl_prettypr.erl b/lib/hipe/cerl/cerl_prettypr.erl index 7e8b7f60bd..1a6e6999fe 100644 --- a/lib/hipe/cerl/cerl_prettypr.erl +++ b/lib/hipe/cerl/cerl_prettypr.erl @@ -64,8 +64,8 @@ seq_arg/1, seq_body/1, string_lit/1, try_arg/1, try_body/1, try_vars/1, try_evars/1, try_handler/1, tuple_es/1, type/1, values_es/1, var_name/1, - c_map/1, map_arg/1, map_es/1, is_c_map_empty/1, - c_map_pair/2, map_pair_key/1, map_pair_val/1, map_pair_op/1 + map_arg/1, map_es/1, is_c_map_empty/1, + map_pair_key/1, map_pair_val/1, map_pair_op/1 ]). -define(PAPER, 76). @@ -499,12 +499,8 @@ lay_literal(Node, Ctxt) -> lay_cons(Node, Ctxt); V when is_tuple(V) -> lay_tuple(Node, Ctxt); - M when is_map(M), map_size(M) =:= 0 -> - text("~{}~"); M when is_map(M) -> - lay_map(c_map([c_map_pair(abstract(K),abstract(V)) - || {K,V} <- maps:to_list(M)]), - Ctxt) + lay_map(Node, Ctxt) end. lay_var(Node, Ctxt) -> @@ -627,12 +623,10 @@ lay_map_pair(Node, Ctxt) -> K = map_pair_key(Node), V = map_pair_val(Node), OpTxt = case concrete(map_pair_op(Node)) of - assoc -> "::<"; - exact -> "~<" + assoc -> "=>"; + exact -> ":=" end, - beside(floating(text(OpTxt)), - beside(lay(K,Ctxt),beside(floating(text(",")), beside(lay(V,Ctxt), - floating(text(">")))))). + beside(lay(K,Ctxt),beside(floating(text(OpTxt)),lay(V,Ctxt))). lay_let(Node, Ctxt) -> V = lay_value_list(let_vars(Node), Ctxt), diff --git a/lib/hipe/cerl/erl_types.erl b/lib/hipe/cerl/erl_types.erl index cd2d2fe207..7a2abc226f 100644 --- a/lib/hipe/cerl/erl_types.erl +++ b/lib/hipe/cerl/erl_types.erl @@ -2711,7 +2711,6 @@ is_compat_args([A1|Args1], [A2|Args2]) -> is_compat_args([], []) -> true; is_compat_args(_, _) -> false. -is_compat_arg(A, A) -> true; is_compat_arg(A1, A2) -> is_specialization(A1, A2) orelse is_specialization(A2, A1). @@ -2722,6 +2721,7 @@ is_compat_arg(A1, A2) -> %% any(). For example, {_,_} is a specialization of any(), but not of %% tuple(). Does not handle variables, but any() and unions (sort of). +is_specialization(T, T) -> true; is_specialization(_, ?any) -> true; is_specialization(?any, _) -> false; is_specialization(?function(Domain1, Range1), ?function(Domain2, Range2)) -> @@ -2747,8 +2747,8 @@ is_specialization(?tuple(Elements1, Arity, _), specialization_list(Elements1, sup_tuple_elements(List)); is_specialization(?tuple_set(List1), ?tuple_set(List2)) -> try - specialization_list(lists:append([T || {_Arity, T} <- List1]), - lists:append([T || {_Arity, T} <- List2])) + specialization_list_list([sup_tuple_elements(T) || {_Arity, T} <- List1], + [sup_tuple_elements(T) || {_Arity, T} <- List2]) catch _:_ -> false end; is_specialization(?union(List1)=T1, ?union(List2)=T2) -> @@ -2772,13 +2772,19 @@ is_specialization(T1, ?opaque(_) = T2) -> is_specialization(T1, t_opaque_structure(T2)); is_specialization(?var(_), _) -> exit(error); is_specialization(_, ?var(_)) -> exit(error); -is_specialization(T, T) -> true; is_specialization(?none, _) -> false; is_specialization(_, ?none) -> false; is_specialization(?unit, _) -> false; is_specialization(_, ?unit) -> false; is_specialization(#c{}, #c{}) -> false. +specialization_list_list(LL1, LL2) -> + length(LL1) =:= length(LL2) andalso specialization_list_list1(LL1, LL2). + +specialization_list_list1([], []) -> true; +specialization_list_list1([L1|LL1], [L2|LL2]) -> + specialization_list(L1, L2) andalso specialization_list_list1(LL1, LL2). + specialization_list(L1, L2) -> length(L1) =:= length(L2) andalso specialization_list1(L1, L2). diff --git a/lib/hipe/rtl/hipe_rtl_binary_match.erl b/lib/hipe/rtl/hipe_rtl_binary_match.erl index 51213b71d1..cf1b8e453f 100644 --- a/lib/hipe/rtl/hipe_rtl_binary_match.erl +++ b/lib/hipe/rtl/hipe_rtl_binary_match.erl @@ -333,32 +333,50 @@ float_get_c_code(Dst1, Ms, Size, Flags, TrueLblName, FalseLblName) -> get_c_code(Func, Dst1, Ms, Size, Flags, TrueLblName, FalseLblName) -> SizeReg = hipe_rtl:mk_new_reg_gcsafe(), FlagsReg = hipe_rtl:mk_new_reg_gcsafe(), + RetReg = hipe_rtl:mk_new_reg_gcsafe(), MatchBuf = hipe_rtl:mk_new_reg(), RetLabel = hipe_rtl:mk_new_label(), + OkLabel = hipe_rtl:mk_new_label(), NonVal = hipe_rtl:mk_imm(hipe_tagscheme:mk_non_value()), [hipe_rtl:mk_move(SizeReg, Size), hipe_rtl:mk_move(FlagsReg, hipe_rtl:mk_imm(Flags)), hipe_tagscheme:extract_matchbuffer(MatchBuf, Ms), - hipe_rtl_arch:call_bif([Dst1], Func, [SizeReg, FlagsReg, MatchBuf], + hipe_rtl_arch:call_bif([RetReg], Func, [SizeReg, FlagsReg, MatchBuf], hipe_rtl:label_name(RetLabel), FalseLblName), RetLabel, - hipe_rtl:mk_branch(Dst1, eq, NonVal, FalseLblName, TrueLblName, 0.01)]. + hipe_rtl:mk_branch(RetReg, eq, NonVal, FalseLblName, + hipe_rtl:label_name(OkLabel), 0.01), + OkLabel, + hipe_rtl:mk_move(Dst1, RetReg), + hipe_rtl:mk_goto(TrueLblName)]. utf8_get_c_code(Dst, Ms, TrueLblName, FalseLblName) -> + RetReg = hipe_rtl:mk_new_reg_gcsafe(), + OkLabel = hipe_rtl:mk_new_label(), MatchBuf = hipe_rtl:mk_new_reg(), NonVal = hipe_rtl:mk_imm(hipe_tagscheme:mk_non_value()), [hipe_tagscheme:extract_matchbuffer(MatchBuf, Ms), - hipe_rtl_arch:call_bif([Dst], bs_get_utf8, [MatchBuf], [], []), - hipe_rtl:mk_branch(Dst, eq, NonVal, FalseLblName, TrueLblName, 0.01)]. + hipe_rtl_arch:call_bif([RetReg], bs_get_utf8, [MatchBuf], [], []), + hipe_rtl:mk_branch(RetReg, eq, NonVal, FalseLblName, + hipe_rtl:label_name(OkLabel), 0.01), + OkLabel, + hipe_rtl:mk_move(Dst, RetReg), + hipe_rtl:mk_goto(TrueLblName)]. utf16_get_c_code(Flags, Dst, Ms, TrueLblName, FalseLblName) -> + RetReg = hipe_rtl:mk_new_reg_gcsafe(), + OkLabel = hipe_rtl:mk_new_label(), MatchBuf = hipe_rtl:mk_new_reg(), NonVal = hipe_rtl:mk_imm(hipe_tagscheme:mk_non_value()), FlagsReg = hipe_rtl:mk_new_reg_gcsafe(), [hipe_tagscheme:extract_matchbuffer(MatchBuf, Ms), hipe_rtl:mk_move(FlagsReg, hipe_rtl:mk_imm(Flags)), - hipe_rtl_arch:call_bif([Dst], bs_get_utf16, [MatchBuf, FlagsReg], [], []), - hipe_rtl:mk_branch(Dst, eq, NonVal, FalseLblName, TrueLblName, 0.01)]. + hipe_rtl_arch:call_bif([RetReg], bs_get_utf16, [MatchBuf, FlagsReg], [], []), + hipe_rtl:mk_branch(RetReg, eq, NonVal, FalseLblName, + hipe_rtl:label_name(OkLabel), 0.01), + OkLabel, + hipe_rtl:mk_move(Dst, RetReg), + hipe_rtl:mk_goto(TrueLblName)]. validate_unicode_retract_c_code(Src, Ms, TrueLblName, FalseLblName) -> MatchBuf = hipe_rtl:mk_new_reg(), diff --git a/lib/hipe/test/Makefile b/lib/hipe/test/Makefile index 009f503abb..d781e4f9be 100644 --- a/lib/hipe/test/Makefile +++ b/lib/hipe/test/Makefile @@ -10,8 +10,10 @@ MODULES= \ # .erl files for these modules are automatically generated GEN_MODULES= \ + basic_SUITE \ bs_SUITE \ - maps_SUITE + maps_SUITE \ + sanity_SUITE ERL_FILES= $(MODULES:%=%.erl) diff --git a/lib/hipe/test/basic_SUITE_data/basic_arith.erl b/lib/hipe/test/basic_SUITE_data/basic_arith.erl new file mode 100644 index 0000000000..28e99be053 --- /dev/null +++ b/lib/hipe/test/basic_SUITE_data/basic_arith.erl @@ -0,0 +1,72 @@ +%%% -*- erlang-indent-level: 2 -*- +%%%--------------------------------------------------------------------- +%%% Author: Kostis Sagonas +%%% +%%% Contains tests cases for compilation of arithmetic. +%%%--------------------------------------------------------------------- +-module(basic_arith). + +-export([test/0]). + +test() -> + ok = test_rem(), + ok = test_bit_ops(), + ok = test_uplus(), + ok = test_bsl_errors(), + ok. + +%%---------------------------------------------------------------------- +%% Tests the remainder operator. + +test_rem() -> + 2 = ret_rem(42, 20), + -2 = ret_rem(-42, 20), + -2 = ret_rem(-42, -20), + {'EXIT', {badarith, _}} = ret_rem(3.14, 2), + {'EXIT', {badarith, _}} = ret_rem(42, 3.14), + ok. + +ret_rem(X, Y) -> + catch X rem Y. + +%%---------------------------------------------------------------------- +%% + +test_bit_ops() -> + 2 = bbb(11, 2, 16#3ff), + ok. + +bbb(X, Y, Z) -> + ((1 bsl X) bor Y) band Z. + +%%---------------------------------------------------------------------- +%% Tests unary plus: it used to be the identity function but not anymore + +test_uplus() -> + badarith = try uplus(gazonk) catch error:Err -> Err end, + 42 = uplus(42), + ok. + +uplus(X) -> +(X). + +%%---------------------------------------------------------------------- +%% The first part of this test triggered a bug in the emulator as one +%% of the arguments to bsl is not an integer. +%% +%% The second part triggered a compilation crash since an arithmetic +%% expression resulting in a 'system_limit' exception was statically +%% evaluated and an arithmetic result was expected. + +test_bsl_errors() -> + {'EXIT', {'badarith', _}} = (catch (t1(0, pad, 0))), + badarith = try t2(0, pad, 0) catch error:Err1 -> Err1 end, + system_limit = try (id(1) bsl 100000000) catch error:Err2 -> Err2 end, + ok. + +t1(_, X, _) -> + (1 bsl X) + 1. + +t2(_, X, _) -> + (X bsl 1) + 1. + +id(I) -> I. diff --git a/lib/hipe/test/basic_SUITE_data/basic_beam_instrs.erl b/lib/hipe/test/basic_SUITE_data/basic_beam_instrs.erl new file mode 100644 index 0000000000..6fafea3b09 --- /dev/null +++ b/lib/hipe/test/basic_SUITE_data/basic_beam_instrs.erl @@ -0,0 +1,102 @@ +%%% -*- erlang-indent-level: 2 -*- +%%%------------------------------------------------------------------- +%%% Author: Kostis Sagonas +%%% +%%% Tests for correct translation of various BEAM instructions. +%%%------------------------------------------------------------------- +-module(basic_beam_instrs). + +-export([test/0]). + +test() -> + ok = test_make_fun(), + ok = test_switch_val(), + ok = test_put_literal(), + ok = test_set_tuple_element(), + ok = test_unguarded_unsafe_element(), + ok. + +%%-------------------------------------------------------------------- +%% Tests whether the translation of make_fun works. + +test_make_fun() -> + {F, G} = double_the_fun(), + ok = F(), + {ok, 42} = G(42), + FV1 = {ok, free_var1}, + FV2 = {also, {free, var2}}, + {FV1, {ok, [bv]}, FV2} = contains_fun(FV1, ignored, FV2), + ok. + +double_the_fun() -> + {fun () -> ok end, fun (V) -> {ok, V} end}. + +contains_fun(X, _IGNORED_ARG, Y) -> + calls_fun(fun(Term) -> {X, Term, Y} end). + +calls_fun(F) -> + F({ok, [bv]}). + +%%-------------------------------------------------------------------- +%% Tests whether the translation of switch_val works. + +test_switch_val() -> + 'A' = sv(a), + 'B' = sv(b), + 'C' = sv(c), + foo = sv(d), + ok. + +sv(a) -> 'A'; +sv(b) -> 'B'; +sv(c) -> 'C'; +sv(_) -> foo. + +%%-------------------------------------------------------------------- +%% Tests correct handling of literals (statically constant terms) + +-define(QUADRUPLE, {a,b,c,42}). +-define(DEEP_LIST, [42,[42,[42]]]). + +test_put_literal() -> + ?QUADRUPLE = mk_literal_quadruple(), + ?DEEP_LIST = mk_literal_deep_list(), + ok. + +mk_literal_quadruple() -> + ?QUADRUPLE. + +mk_literal_deep_list() -> + ?DEEP_LIST. + +%%-------------------------------------------------------------------- +%% Tests whether the translation of set_tuple_element works. + +-record(rec, {f1, f2, f3, f4, f5}). + +test_set_tuple_element() -> + F2 = [a,b,c], F4 = {a,b}, + State0 = init_rec(F2, F4), + State1 = simple_set(State0, 42), + #rec{f1 = foo, f2 = F2, f3 = 42, f4 = F4, f5 = 42.0} = odd_set(State1, 21), + ok. + +init_rec(F2, F4) -> + #rec{f1 = bar, f2 = F2, f3 = 10, f4 = F4, f5 = 3.14}. + +simple_set(State, Val) -> %% f3 = Val is the one used in set_element; + State#rec{f3 = Val, f5 = Val*2}. %% this checks the case of variable + +odd_set(State, Val) -> %% f3 = foo is the one used in set_element; + State#rec{f1 = foo, f5 = Val*2.0}. %% this checks the case of constant + +%%-------------------------------------------------------------------- +%% Tests the handling of unguarded unsafe_element operations that BEAM +%% can sometimes construct on records (when it has enough context). + +test_unguarded_unsafe_element() -> + {badrecord, rec} = try unguarded_unsafe_element(42) catch error:E -> E end, + ok. + +unguarded_unsafe_element(X) -> + X#rec{f1 = X#rec.f3}. diff --git a/lib/hipe/test/basic_SUITE_data/basic_bifs.erl b/lib/hipe/test/basic_SUITE_data/basic_bifs.erl new file mode 100644 index 0000000000..e7ee2f3678 --- /dev/null +++ b/lib/hipe/test/basic_SUITE_data/basic_bifs.erl @@ -0,0 +1,257 @@ +%%% -*- erlang-indent-level: 2 -*- +%%%------------------------------------------------------------------- +%%% Author: Kostis Sagonas +%%% +%%% Contains tests for handling of BIFs in guards and body calls. +%%%------------------------------------------------------------------- +-module(basic_bifs). + +-export([test/0]). + +-define(BIG, 1398479237498374913984792374983749). + +test() -> + ok = test_abs(), + ok = test_binary_part(), + ok = test_element(), + ok = test_float(), + ok = test_float_to_list(), + ok = test_integer_to_list(), + ok = test_list_to_float(), + ok = test_list_to_integer(), + ok = test_round(), + ok = test_trunc(), + ok. + +%%-------------------------------------------------------------------- + +test_abs() -> + t_abs(5.5, 0.0, -100.0, 5, 0, -100, ?BIG). + +t_abs(F1, F2, F3, I1, I2, I3, BigNum) -> + %% Floats. + 5.5 = abs(F1), + 0.0 = abs(F2), + 100.0 = abs(F3), + %% Integers. + 5 = abs(I1), + 0 = abs(I2), + 100 = abs(I3), + %% Bignums. + BigNum = abs(BigNum), + BigNum = abs(-BigNum), + ok. + +%%-------------------------------------------------------------------- +%% Checks that 2-ary and 3-ary BIFs can be compiled to native code. + +test_binary_part() -> + Bin = <<1,2,3,4,5,6,7,8,9,10>>, + BinPart = bp3(Bin), + <<7,8>> = bp2(BinPart), + ok. + +bp2(Bin) -> + binary_part(Bin, {1, 2}). + +bp3(Bin) -> + binary_part(Bin, byte_size(Bin), -5). + +%%-------------------------------------------------------------------- + +test_element() -> + true = elem({a, b}), + false = elem({a, c}), + other = elem(gazonk), + ok. + +elem(T) when element(1, T) == a -> element(2, T) == b; +elem(_) -> other. + +%%-------------------------------------------------------------------- + +test_float() -> + t_float(0, 42, -100, 2.5, 0.0, -100.42, ?BIG, -?BIG). + +t_float(I1, I2, I3, F1, F2, F3, B1, B2) -> + 0.0 = float(I1), + 2.5 = float(F1), + 0.0 = float(F2), + -100.42 = float(F3), + 42.0 = float(I2), + -100.0 = float(I3), + %% Bignums. + 1398479237498374913984792374983749.0 = float(B1), + -1398479237498374913984792374983749.0 = float(B2), + %% Extremly big bignums. + Big = list_to_integer(duplicate(2000, $1)), + {'EXIT', _} = (catch float(Big)), + %% Invalid types and lists. + {'EXIT', _} = (catch my_list_to_integer(atom)), + {'EXIT', _} = (catch my_list_to_integer(123)), + {'EXIT', _} = (catch my_list_to_integer([$1, [$2]])), + {'EXIT', _} = (catch my_list_to_integer("1.2")), + {'EXIT', _} = (catch my_list_to_integer("a")), + {'EXIT', _} = (catch my_list_to_integer("")), + ok. + +my_list_to_integer(X) -> + list_to_integer(X). + +%%-------------------------------------------------------------------- + +test_float_to_list() -> + test_ftl("0.0e+0", 0.0), + test_ftl("2.5e+1", 25.0), + test_ftl("2.5e+0", 2.5), + test_ftl("2.5e-1", 0.25), + test_ftl("-3.5e+17", -350.0e15), + ok. + +test_ftl(Expect, Float) -> + %% No \n on the next line -- we want the line number from t_float_to_list. + Expect = remove_zeros(lists:reverse(float_to_list(Float)), []). + +%% Removes any non-significant zeros in a floating point number. +%% Example: 2.500000e+01 -> 2.5e+1 + +remove_zeros([$+, $e|Rest], [$0, X|Result]) -> + remove_zeros([$+, $e|Rest], [X|Result]); +remove_zeros([$-, $e|Rest], [$0, X|Result]) -> + remove_zeros([$-, $e|Rest], [X|Result]); +remove_zeros([$0, $.|Rest], [$e|Result]) -> + remove_zeros(Rest, [$., $0, $e|Result]); +remove_zeros([$0|Rest], [$e|Result]) -> + remove_zeros(Rest, [$e|Result]); +remove_zeros([Char|Rest], Result) -> + remove_zeros(Rest, [Char|Result]); +remove_zeros([], Result) -> + Result. + +%%-------------------------------------------------------------------- + +test_integer_to_list() -> + t_integer_to_list(0, 42, 32768, 268435455, 123456932798748738738). + +t_integer_to_list(I1, I2, I3, I4, BIG) -> + "0" = integer_to_list(I1), + "42" = integer_to_list(I2), + "-42" = integer_to_list(-I2), + "-42" = integer_to_list(-I2), + "32768" = integer_to_list(I3), + "268435455" = integer_to_list(I4), + "-268435455" = integer_to_list(-I4), + "123456932798748738738" = integer_to_list(BIG), + BigList = duplicate(2000, $1), + Big = list_to_integer(BigList), + BigList = integer_to_list(Big), + ok. + +%%-------------------------------------------------------------------- + +test_list_to_float() -> + ok = t_list_to_float_safe(), + ok = t_list_to_float_risky(). + +t_list_to_float_safe() -> + 0.0 = my_list_to_float("0.0"), + 0.0 = my_list_to_float("-0.0"), + 0.5 = my_list_to_float("0.5"), + -0.5 = my_list_to_float("-0.5"), + 100.0 = my_list_to_float("1.0e2"), + 127.5 = my_list_to_float("127.5"), + -199.5 = my_list_to_float("-199.5"), + {'EXIT', _} = (catch my_list_to_float("0")), + {'EXIT', _} = (catch my_list_to_float("0..0")), + {'EXIT', _} = (catch my_list_to_float("0e12")), + {'EXIT', _} = (catch my_list_to_float("--0.0")), + ok. + +my_list_to_float(X) -> + list_to_float(X). + +%% This might crash the emulator. (Used to crash Erlang 4.4.1 on Unix.) + +t_list_to_float_risky() -> + Many_Ones = duplicate(25000, $1), + ok = case list_to_float("2." ++ Many_Ones) of + F when is_float(F), 0.0 < F, F =< 3.14 -> ok + end, + {'EXIT', _} = (catch list_to_float("2" ++ Many_Ones)), + ok. + +%%-------------------------------------------------------------------- + +test_list_to_integer() -> + ok = t_list_to_integer_small("0", "00", "-0", "1", "-1", "42", "-12", + "32768", "268435455", "-268435455"), + ok = t_list_to_integer_bignum("123456932798748738738666"), + ok. + +t_list_to_integer_small(S1, S2, S3, S4, S5, S6, S7, S8, S9, S10) -> + 0 = list_to_integer(S1), + 0 = list_to_integer(S2), + 0 = list_to_integer(S3), + 1 = list_to_integer(S4), + -1 = list_to_integer(S5), + 42 = list_to_integer(S6), + -12 = list_to_integer(S7), + 32768 = list_to_integer(S8), + 268435455 = list_to_integer(S9), + -268435455 = list_to_integer(S10), + ok. + +t_list_to_integer_bignum(S) -> + 123456932798748738738666 = list_to_integer(S), + case list_to_integer(duplicate(2000, $1)) of + I when is_integer(I), I > 123456932798748738738666 -> ok + end. + +%%-------------------------------------------------------------------- + +test_round() -> + ok = t_round_small(0.0, 0.4, 0.5, -0.4, -0.5, 255.3, 255.6, -1033.3, -1033.6), + ok = t_round_big(4294967296.1, 4294967296.9), + ok. + +t_round_small(F1, F2, F3, F4, F5, F6, F7, F8, F9) -> + 0 = round(F1), + 0 = round(F2), + 1 = round(F3), + 0 = round(F4), + -1 = round(F5), + 255 = round(F6), + 256 = round(F7), + -1033 = round(F8), + -1034 = round(F9), + ok. + +t_round_big(B1, B2) -> + 4294967296 = round(B1), + 4294967297 = round(B2), + -4294967296 = round(-B1), + -4294967297 = round(-B2), + ok. + +%%-------------------------------------------------------------------- + +test_trunc() -> + t_trunc(0.0, 5.3333, -10.978987, 4294967305.7). + +t_trunc(F1, F2, F3, B) -> + 0 = trunc(F1), + 5 = trunc(F2), + -10 = trunc(F3), + %% Bignums. + 4294967305 = trunc(B), + -4294967305 = trunc(-B), + ok. + +%%-------------------------------------------------------------------- +%% Auxiliary functions below + +duplicate(N, X) when is_integer(N), N >= 0 -> + duplicate(N, X, []). + +duplicate(0, _, L) -> L; +duplicate(N, X, L) -> duplicate(N-1, X, [X|L]). diff --git a/lib/hipe/test/basic_SUITE_data/basic_bignums.erl b/lib/hipe/test/basic_SUITE_data/basic_bignums.erl new file mode 100644 index 0000000000..e3b523b3f5 --- /dev/null +++ b/lib/hipe/test/basic_SUITE_data/basic_bignums.erl @@ -0,0 +1,143 @@ +%%% -*- erlang-indent-level: 2 -*- +%%%------------------------------------------------------------------- +%%% Author: Kostis Sagonas +%%% +%%% Contains code examples that test bignum arithmetic and matching. +%%%------------------------------------------------------------------- +-module(basic_bignums). + +-export([test/0, test_bsl/0]). + +test() -> + ok = test_ops(), + ok = test_big_fac(), + ok = test_int_overfl_32(), + ok = test_int_overfl_64(), + ok = test_int_overfl_32_guard(), + ok = test_int_overfl_64_guard(), + ok. + +%%-------------------------------------------------------------------- +%% Define some constants for the tests of arithmetic operators + +-define(X, 68719476736). +-define(Y, 98765432101234). +-define(Z, 4722366482869645213696). +-define(W, 339254531512339254531512). + +-define(B1, 4398046511104). +-define(B5, 1645504557321206042154969182557350504982735865633579863348609024). +-define(B17, 86182066610968551542636378241108028056376767329454880514019834315878107616003372189510312530372009184902888961739623919010110377987011442493486117202360415845666384627768436296772219009176743399772868636439042064384). + +%%-------------------------------------------------------------------- + +test_ops() -> + ok = test_mult(), + ok = test_div(), + ok = test_round(), + ok = test_trunc(), + ok = test_bsl(), + ok. + +test_mult() -> + ?Z = mult(?X, ?X), + ok. + +mult(X, Y) -> X * Y. + +test_div() -> + 4 = div_f(339254531512, ?X), + 0 = div_f(?Y, ?Y+1), + 64 = div_f(?B1, ?X), + ?X = div_f(?Z, ?X), + 1073741824 = div_f(?Z, ?B1), + ok. + +div_f(X, Y) -> X div Y. + +test_round() -> + 0 = round_f(?Z, ?W), + 1 = round_f(?Y, ?Y), + 71 = round_f(?W, ?Z), + 1437 = round_f(?Y, ?X), + 47813960 = round_f(?Z, ?Y), + 4936803183406 = round_f(?W, ?X), + ok. + +trunc_f(X, Y) -> round(X/Y). + +test_trunc() -> + 0 = trunc_f(?Z, ?W), + 1 = trunc_f(?Y, ?Y), + 72 = trunc_f(?W, ?Z), + 1437 = trunc_f(?Y, ?X), + 47813961 = trunc_f(?Z, ?Y), + 4936803183407 = trunc_f(?W, ?X), + ok. + +round_f(X, Y) -> trunc(X/Y). + +test_bsl() -> + ?B1 = bsl_f(1, 42), + ?B5 = n(5, fun erlang:'bsl'/2, 1, 42), % use the operator + ?B17 = n(17, fun bsl_f/2, 1, 42), % use the local function + ok. + +bsl_f(X, Y) -> X bsl Y. + +%% applies a binary function N times +n(1, F, X, Y) -> F(X, Y); +n(N, F, X, Y) when N > 1 -> n(N-1, F, F(X, Y), Y). + +%%-------------------------------------------------------------------- + +-define(FAC42, 1405006117752879898543142606244511569936384000000000). + +test_big_fac() -> + ?FAC42 = fac(42), + ok. + +fac(0) -> 1; +fac(N) -> N * fac(N-1). + +%%-------------------------------------------------------------------- +%% Tests for correct handling of integer overflow + +test_int_overfl_32() -> + 16#7FFFFFF = add(16#7FFFFFF, 0), + 16#8000000 = add(16#8000000, 0), + 16#8000001 = add(16#8000000, 1), + case add(16#7FFFFFF, 1) of + 16#8000000 -> ok; + -16#7FFFFFF -> error + end. + +test_int_overfl_64() -> + 16#7FFFFFFFFFFFFFF = add(16#7FFFFFFFFFFFFFF, 0), + 16#800000000000000 = add(16#800000000000000, 0), + 16#800000000000001 = add(16#800000000000000, 1), + case add(16#7FFFFFFFFFFFFFF, 1) of + 16#800000000000000 -> ok; + -16#7FFFFFFFFFFFFFF -> error + end. + +add(X, Y) -> X + Y. + +%%-------------------------------------------------------------------- +%% Tests for correct handling of integer overflow in guards + +test_int_overfl_32_guard() -> + ok = overfl_in_guard(16#7ffffff, 0), + ok = overfl_in_guard(16#7ffffff, 16#7ffffff), + ok. + +test_int_overfl_64_guard() -> + ok = overfl_in_guard(16#7ffffffffffffff, 0), + ok = overfl_in_guard(16#7ffffffffffffff, 16#7ffffffffffffff), + ok. + +overfl_in_guard(X, Y) -> + case ok of + V when X+Y > 12 -> V; + _ -> bad + end. diff --git a/lib/hipe/test/basic_SUITE_data/basic_boolean.erl b/lib/hipe/test/basic_SUITE_data/basic_boolean.erl new file mode 100644 index 0000000000..e4a91ef5af --- /dev/null +++ b/lib/hipe/test/basic_SUITE_data/basic_boolean.erl @@ -0,0 +1,47 @@ +%%% -*- erlang-indent-level: 2 -*- +%%%------------------------------------------------------------------- +%%% Author: Kostis Sagonas +%%% +%%% Tests for correct translation of booleans and their primitives. +%%%------------------------------------------------------------------- +-module(basic_boolean). + +-export([test/0]). + +test() -> + ok = test_boolean_ops(false, true), + ok = test_orelse_redundant(), + ok. + +%%-------------------------------------------------------------------- + +test_boolean_ops(F, T) -> + true = T and T, + false = T and F, + false = F and T, + false = F and F, + true = T or T, + true = T or F, + true = F or T, + false = F or F, + true = T andalso T, + false = T andalso F, + false = F andalso T, + false = F andalso F, + true = T orelse T, + true = T orelse F, + true = F orelse T, + false = F orelse F, + ok. + +%%-------------------------------------------------------------------- +%% Redundant test in BEAM code will generate type warning. + +test_orelse_redundant() -> + true = test_orelse(true, true, true), + ok. + +test_orelse(A, B, C) -> + A andalso B orelse C. + +%%-------------------------------------------------------------------- diff --git a/lib/hipe/test/basic_SUITE_data/basic_bugs_beam.erl b/lib/hipe/test/basic_SUITE_data/basic_bugs_beam.erl new file mode 100644 index 0000000000..964b0f423a --- /dev/null +++ b/lib/hipe/test/basic_SUITE_data/basic_bugs_beam.erl @@ -0,0 +1,138 @@ +%%% -*- erlang-indent-level: 2 -*- +%%%------------------------------------------------------------------- +%%% Author: Kostis Sagonas +%%% +%%% Contains code examples that exhibited bugs in the BEAM compiler. +%%%------------------------------------------------------------------- +-module(basic_bugs_beam). + +-export([test/0]). + +%% the following is needed for the test_weird_message +-export([loop/1]). +%% the following are needed for the test_catch_bug +-behaviour(gen_server). +-export([start_link/1]). +-export([init/1, handle_call/3, handle_cast/2, handle_info/2, + terminate/2, code_change/3]). + +test() -> + ok = test_fp_basic_blocks(), + ok = test_weird_message(), + ok = test_catch_bug(), + ok. + +%%-------------------------------------------------------------------- +%% Test which shows that BEAM's splitting of basic blocks should take +%% into account that arithmetic operations implemented as BIFs can +%% also cause exceptions and thus calls to BIFs should end basic blocks. +%% +%% Investigated and fixed in the beginning of April 2004. +%%-------------------------------------------------------------------- + +test_fp_basic_blocks() -> + ok = t1(), + ok = t2(). + +t1() -> + X = (catch bad_arith1(2.0, 1.7)), + case X of + {'EXIT', {badarith, _}} -> + ok; + _ -> + error + end. + +bad_arith1(X, Y) when is_float(X) -> + X1 = X * 1.7e+308, + X2 = X1 + 1.0, + Y1 = Y * 2, + {X2, Y1}. + +%% Similarly, it is not kosher to have anything that can fail inside +%% the fp block since it will throw the exception before the fp +%% exception and we will get the same problems. + +t2() -> + case catch bad_arith2(2.0, []) of + {'EXIT', {badarith, _}} -> + ok; + _ -> + error + end. + +bad_arith2(X, Y) when is_float(X) -> + X1 = X * 1.7e+308, + Y1 = element(1, Y), + {X1 + 1.0, Y1}. + +%%-------------------------------------------------------------------- +%% Sending 'test' to this process should return 'ok'. But: +%% +%% 1> MOD:test(). +%% Weird: received true +%% timeout +%% +%% Surprisingly, the message has been bound to the value of 'ena' +%% in the record! The problem was visible in the .S file. +%%-------------------------------------------------------------------- + +-record(state, {ena = true}). + +test_weird_message() -> + P = spawn_link(?MODULE, loop, [#state{}]), + P ! {msg, self()}, + receive + What -> What + after 42 -> timeout + end. + +loop(S) -> + receive + _ when S#state.ena == false -> + io:format("Weird: ena is false\n"); + % loop(S); + {msg, Pid} -> + Pid ! ok; + % loop(S); + Other -> + io:format("Weird: received ~p\n", [Other]) + % loop(S) + end. + +%%-------------------------------------------------------------------- +%% This was posted on the Erlang mailing list as a question: +%% +%% Given the module below and the function call +%% "catch_bug:start_link(foo)." +%% from the Erlang shell, why does Erlang crash with "Catch not found"? +%% +%% The BEAM compiler was generating wrong code for this case; +%% this was fixed in R9C-0. Native code generation was OK. +%%-------------------------------------------------------------------- + +test_catch_bug() -> + ignore = start_link(foo), + ok. + +start_link(Param) -> + gen_server:start_link(?MODULE, Param, []). + +init(Param) -> + process_flag(trap_exit, true), + (catch begin + dummy(Param), + (catch exit(bar)) + end + ), + ignore. + +dummy(_) -> ok. + +%% gen_server callbacks below +handle_call(_Call, _From, State) -> {noreply, State}. +handle_cast(_Msg, State) -> {noreply, State}. +handle_info(_Msg, State) -> {noreply, State}. +terminate(_Reason, _State) -> ok. +code_change(_OldVsn, State, _Extra) -> {ok, State}. + diff --git a/lib/hipe/test/basic_SUITE_data/basic_bugs_hipe.erl b/lib/hipe/test/basic_SUITE_data/basic_bugs_hipe.erl new file mode 100644 index 0000000000..caa0e71d0b --- /dev/null +++ b/lib/hipe/test/basic_SUITE_data/basic_bugs_hipe.erl @@ -0,0 +1,463 @@ +%%% -*- erlang-indent-level: 2 -*- +%%%---------------------------------------------------------------------- +%%% Author: Kostis Sagonas +%%% +%%% Contains code examples that exhibited bugs in the HiPE compiler. +%%%---------------------------------------------------------------------- +-module(basic_bugs_hipe). + +-export([test/0]). + +test() -> + ok = test_ets_bifs(), + ok = test_szar_bug(), + ok = test_bit_shift(), + ok = test_match_big_list(), + ok = test_unsafe_bsl(), + ok = test_unsafe_bsr(), + ok = test_R12B5_seg_fault(), + ok = test_switch_neg_int(), + ok = test_icode_range_anal(), + ok. + +%%----------------------------------------------------------------------- +%% From: Bjorn Gustavsson +%% +%% This code, if HiPE compiled, crashed like this (on SPARC) +%% +%% (gdb) where +%% #0 fullsweep_heap (p=0x2c60dc, new_sz=610, objv=0xffbee8b4, nobj=3) +%% at beam/ggc.c:1060 +%% #1 0x7ff24 in erts_garbage_collect (p=0x2c60dc, need=2, objv=0x1128fc, ...) +%% at beam/ggc.c:1648 +%% #2 0xab6fc in hipe_mode_switch (p=0x2c60dc, cmd=704512, reg=0x1128fc) +%% at hipe/hipe_mode_switch.c:180 +%% #3 0x8e27c in process_main () at beam/beam_emu.c:3314 +%% #4 0x31338 in erl_start (argc=9, argv=0xffbeed5c) at beam/erl_init.c:936 +%% #5 0x2d9f4 in main (argc=9, argv=0xffbeed5c) at sys/unix/erl_main.c:28 +%% +%% A guess at what could be the problem: From R8, many ets BIFs trap +%% to other ets BIFs with a *different* arity (i.e. they have more or +%% less arguments). I have probably forgotten to mention that subtle +%% change. +%%----------------------------------------------------------------------- + +test_ets_bifs() -> + Seed = {1032, 15890, 22716}, + put(random_seed, Seed), + do_random_test(). + +do_random_test() -> + OrdSet = ets:new(xxx, [ordered_set]), + Set = ets:new(xxx, []), + do_n_times(fun() -> + Key = create_random_string(25), + Value = create_random_tuple(25), + ets:insert(OrdSet, {Key, Value}), + ets:insert(Set, {Key, Value}) + end, 5000), + %% io:format("~nData inserted~n"), + do_n_times(fun() -> + I = random:uniform(25), + Key = create_random_string(I) ++ '_', + L1 = ets_match_object(OrdSet, {Key, '_'}), + L2 = lists:sort(ets_match_object(Set, {Key, '_'})), + case L1 == L2 of + false -> + %% io:format("~p != ~p~n", [L1, L2]), + exit({not_eq, L1, L2}); + true -> + ok + end + end, 2000), + %% io:format("~nData matched~n"), + ets:match_delete(OrdSet, '_'), + ets:match_delete(Set, '_'), + ok. + +create_random_string(0) -> + []; +create_random_string(OfLength) -> + C = case random:uniform(2) of + 1 -> (random:uniform($Z - $A + 1) - 1) + $A; + _ -> (random:uniform($z - $a + 1) - 1) + $a + end, + [C | create_random_string(OfLength - 1)]. + +create_random_tuple(OfLength) -> + list_to_tuple([list_to_atom([X]) || X <- create_random_string(OfLength)]). + +ets_match_object(Tab,Expr) -> + case random:uniform(2) of + 1 -> ets:match_object(Tab,Expr); + _ -> match_object_chunked(Tab,Expr) + end. + +match_object_chunked(Tab,Expr) -> + match_object_chunked_collect(ets:match_object(Tab, Expr, + random:uniform(1999) + 1)). + +match_object_chunked_collect('$end_of_table') -> + []; +match_object_chunked_collect({Results, Continuation}) -> + Results ++ match_object_chunked_collect(ets:match_object(Continuation)). + +do_n_times(_, 0) -> + ok; +do_n_times(Fun, N) -> + Fun(), + case N rem 1000 of + 0 -> ok; %% WAS: io:format("."); + _ -> ok + end, + do_n_times(Fun, N - 1). + +%%----------------------------------------------------------------------- +%% From: Jozsef Berces (PR/ECZ) +%% Date: Feb 19, 2004 +%% +%% Program which was added to the testsuite as a result of another bug +%% report involving tuples as funs. Thanks God, these are no longer +%% supported, but the following is a good test for testing calling +%% native code funs from BEAM code (lists:map, lists:filter, ...). +%%----------------------------------------------------------------------- + +test_szar_bug() -> + ["A","B","C"] = smartconcat([], "H'A, H'B, H'C"), + ok. + +smartconcat(B, L) -> + LL = tokenize(L, $,), + NewlineDel = fun (X) -> killcontrol(X) end, + StripFun = fun (X) -> string:strip(X) end, + LL2 = lists:map(NewlineDel, lists:map(StripFun, LL)), + EmptyDel = fun(X) -> + case string:len(X) of + 0 -> false; + _ -> true + end + end, + LL3 = lists:filter(EmptyDel, LL2), + HexFormat = fun(X, Acc) -> + case string:str(X, "H'") of + 1 -> + case checkhex(string:substr(X, 3)) of + {ok, Y} -> + {Y, Acc}; + _ -> + {X, Acc + 1} + end; + _ -> + {X, Acc + 1} + end + end, + {LL4,_Ret} = lists:mapfoldl(HexFormat, 0, LL3), + lists:append(B, lists:sublist(LL4, lists:max([0, 25 - length(B)]))). + +checkhex(L) -> + checkhex(L, ""). + +checkhex([H | T], N) when H >= $0, H =< $9 -> + checkhex(T, [H | N]); +checkhex([H | T], N) when H >= $A, H =< $F -> + checkhex(T, [H | N]); +checkhex([H | T], N) when H =< 32 -> + checkhex(T, N); +checkhex([_ | _], _) -> + {error, ""}; +checkhex([], N) -> + {ok, lists:reverse(N)}. + +killcontrol([C | S]) when C < 32 -> + killcontrol(S); +killcontrol([C | S]) -> + [C | killcontrol(S)]; +killcontrol([]) -> + []. + +tokenize(L, C) -> + tokenize(L, C, [], []). + +tokenize([C | T], C, A, B) -> + case A of + [] -> + tokenize(T, C, [], B); + _ -> + tokenize(T, C, [], [lists:reverse(A) | B]) + end; +tokenize([H | T], C, A, B) -> + tokenize(T, C, [H | A], B); +tokenize(_, _, [], B) -> + lists:reverse(B); +tokenize(_, _, A, B) -> + lists:reverse([lists:reverse(A) | B]). + +%%----------------------------------------------------------------------- +%% From: Niclas Pehrsson +%% Date: Apr 20, 2006 +%% +%% We found something weird with the bit shifting in HiPE. It seems +%% that bsr in some cases shifts the bits in the wrong way... +%% +%% Fixed about 10 mins afterwards; was a bug in constant propagation. +%%----------------------------------------------------------------------- + +test_bit_shift() -> + 1 = plain_shift(), % 1 + 6 = length_list_plus(), % 6 + 0 = shift_length_list(), % 0 + 1 = shift_length_list_plus(), % 1 + 1 = shift_length_list_plus2(), % 1 + 24 = shift_length_list_plus_bsl(), % 24 + 1 = shift_fun(), % 1 + %% {1, 6, 0, 1, 1, 24, 1} = {A, B, C, D, E, F, G}, + ok. + +plain_shift() -> + 6 bsr 2. + +length_list() -> + length([0,0]). + +length_list_plus() -> + length([0,0]) + 4. + +shift_length_list() -> + length([0,0]) bsr 2. + +shift_length_list_plus() -> + (length([0,0]) + 4) bsr 2. + +shift_length_list_plus_bsl() -> + (length([0,0]) + 4) bsl 2. + +shift_length_list_plus2() -> + N = length([0,0]) + 4, + N bsr 2. + +shift_fun() -> + (length_list() + 4) bsr 2. + +%%----------------------------------------------------------------------- +%% From: Igor Goryachev +%% Date: June 15, 2006 +%% +%% I have experienced a different behaviour and possibly a weird result +%% while playing with matching a big list on x86 and x86_64 machines. +%%----------------------------------------------------------------------- + +-define(BIG_LIST, + ["uid", "nickname", "n_family", "n_given", "email_pref", + "tel_home_number", "tel_cellular_number", "adr_home_country", + "adr_home_locality", "adr_home_region", "url", "gender", "bday", + "constitution", "height", "weight", "hair", "routine", "smoke", + "maritalstatus", "children", "independence", "school_number", + "school_locality", "school_title", "school_period", "org_orgname", + "title", "adr_work_locality", "photo_type", "photo_binval"]). + +test_match_big_list() -> + case create_tuple_with_big_const_list() of + {selected, ?BIG_LIST, _} -> ok; + _ -> weird + end. + +create_tuple_with_big_const_list() -> + {selected, ?BIG_LIST, [{"test"}]}. + +%%----------------------------------------------------------------------- +%% In October 2006 the HiPE compiler acquired more type-driven +%% optimisations of arithmetic operations. One of these, the +%% transformation of bsl to a pure fixnum bsl fixnum -> fixnum version +%% (unsafe_bsl), was incorrectly performed even when the result +%% wouldn't be a fixnum. The error occurred for all backends, but the +%% only place known to break was hipe_arm:imm_to_am1/2. Some +%% immediates got broken on ARM, causing segmentation faults in +%% compiler_tests when HiPE recompiled itself. +%%----------------------------------------------------------------------- + +test_unsafe_bsl() -> + ok = bsl_check(bsl_test_cases()). + +bsl_test_cases() -> + [{16#FF, {16#FF, 0}}, + {16#F000000F, {16#FF, 2}}]. + +bsl_check([]) -> ok; +bsl_check([{X, Y}|Rest]) -> + case imm_to_am1(X) of + Y -> bsl_check(Rest); + _ -> 'hipe_broke_bsl' + end. + +imm_to_am1(Imm) -> + imm_to_am1(Imm band 16#FFFFFFFF, 16). +imm_to_am1(Imm, RotCnt) -> + if Imm >= 0, Imm =< 255 -> {Imm, RotCnt band 15}; + true -> + NewRotCnt = RotCnt - 1, + if NewRotCnt =:= 0 -> []; % full circle, no joy + true -> + NewImm = (Imm bsr 2) bor ((Imm band 3) bsl 30), + imm_to_am1(NewImm, NewRotCnt) + end + end. + +%%----------------------------------------------------------------------- +%% Another transformation, namely that of bsr to a pure fixnum bsr +%% fixnum -> fixnum version (unsafe_bsr), failed to check for shifts +%% larger than the number of bits in fixnums. Such shifts should +%% return zero, but instead they became plain machine-level shift +%% instructions. Machines often only consider the low-order bits of +%% the shift count, so machine-level shifts larger than the word size +%% do not match the Erlang semantics. +%%----------------------------------------------------------------------- + +test_unsafe_bsr() -> + ok = bsr_check(bsr_test_cases()). + +bsr_test_cases() -> + [{16#FF, 4, 16#0F}, + {16#FF, 64, 0}]. + +bsr_check([]) -> ok; +bsr_check([{X, Y, Z}|Rest]) -> + case do_bsr(X, Y) of + Z -> bsr_check(Rest); + _ -> 'hipe_broke_bsr' + end. + +do_bsr(X, Y) -> + (X band 16#FFFF) bsr (Y band 16#FFFF). + +%%----------------------------------------------------------------------- +%% From: Sergey S, mid January 2009. +%% +%% While I was playing with +native option, I run into a bug in HiPE +%% which leads to segmentation fault using +native and Erlang R12B-5. +%% +%% Eshell V5.6.5 +%% 1> crash:test(). +%% # Some message to be printed here each loop iteration +%% Segmentation fault +%% +%% Diagnosed and fixed by Mikael Pettersson (22 Jan 2009): +%% +%% I've analysed the recently posted HiPE bug report on erlang-bugs +%% <http://www.erlang.org/pipermail/erlang-bugs/2009-January/001162.html>. +%% The segfault is caused by memory corruption, which in turn is caused +%% by RTL removing an update of the HP (heap pointer) register due to +%% what looks like broken liveness information. +%%----------------------------------------------------------------------- + +test_R12B5_seg_fault() -> + _ = spawn(fun() -> init() end), + ok. + +init() -> + repeat(5, fun() -> void end), + receive after infinity -> ok end. + +repeat(0, _) -> + ok; +repeat(N, Fun) -> + %% io:format("# Some message to be printed here each loop iteration\n"), + Fun(), + repeat(N - 1, Fun). + +%%----------------------------------------------------------------------- +%% From: Jon Meredith +%% Date: July 9, 2009 +%% +%% Binary search key tables are sorted by the loader based on the +%% runtime representations of the keys as unsigned words. However, +%% the code generated for the binary search used signed comparisons. +%% That worked for atoms and non-negative fixnums, but not for +%% negative fixnums. Fixed by Mikael Pettersson July 10, 2009. +%%----------------------------------------------------------------------- + +test_switch_neg_int() -> + ok = f(-80, 8). + +f(10, -1) -> ok; +f(X, Y) -> + Y = g(X), + f(X + 10, Y - 1). + +g(X) -> % g(0) should be 0 but became -1 + case X of + 0 -> 0; + -10 -> 1; + -20 -> 2; + -30 -> 3; + -40 -> 4; + -50 -> 5; + -60 -> 6; + -70 -> 7; + -80 -> 8; + _ -> -1 + end. + +%%----------------------------------------------------------------------- +%% From: Paul Guyot +%% Date: Jan 31, 2011 +%% +%% There is a bug in HiPE compilation with the comparison of floats +%% with integers. This bug happens in functions f/1 and g/2 below. +%% BEAM will evaluate f_eq(42) and f_eq(42.0) to true, while HiPE +%% will evaluate them to false. +%% +%% The culprit was the Icode range analysis which was buggy. (On the +%% other hand, HiPE properly evaluated these calls to true if passed +%% the option 'no_icode_range'.) Fixed by Kostis Sagonas. +%% -------------------------------------------------------------------- + +test_icode_range_anal() -> + true = f_eq(42), + true = f_eq(42.0), + false = f_ne(42), + false = f_ne(42.0), + false = f_eq_ex(42), + false = f_eq_ex(42.0), + true = f_ne_ex(42), + true = f_ne_ex(42.0), + false = f_gt(42), + false = f_gt(42.0), + true = f_le(42), + true = f_le(42.0), + zero_test = g(0, test), + zero_test = g(0.0, test), + non_zero_test = g(42, test), + other = g(42, other), + ok. + +f_eq(X) -> + Y = X / 2, + Y == 21. + +f_ne(X) -> + Y = X / 2, + Y /= 21. + +f_eq_ex(X) -> + Y = X / 2, + Y =:= 21. + +f_ne_ex(X) -> + Y = X / 2, + Y =/= 21. + +f_gt(X) -> + Y = X / 2, + Y > 21. + +f_le(X) -> + Y = X / 2, + Y =< 21. + +g(X, Z) -> + Y = X / 2, + case Z of + test when Y == 0 -> zero_test; + test -> non_zero_test; + other -> other + end. diff --git a/lib/hipe/test/basic_SUITE_data/basic_comparisons.erl b/lib/hipe/test/basic_SUITE_data/basic_comparisons.erl new file mode 100644 index 0000000000..8dab2cab1f --- /dev/null +++ b/lib/hipe/test/basic_SUITE_data/basic_comparisons.erl @@ -0,0 +1,157 @@ +%%% -*- erlang-indent-level: 2 -*- +%%%------------------------------------------------------------------- +%%% Author: Kostis Sagonas +%%% +%%% Contains tests for correct execution of comparison operators. +%%%------------------------------------------------------------------- +-module(basic_comparisons). + +-export([test/0]). + +test() -> + Ns = [0, 0.0, 42, 42.0, gazonk], + T1F4 = [true, false, false, false, false], + T2F3 = [true, true, false, false, false], + F1T4 = [false, true, true, true, true], + F2T3 = [false, false, true, true, true], + %% tests for calls + T1F4 = [eq_exact_call(0, N) || N <- Ns], + F1T4 = [ne_exact_call(0, N) || N <- Ns], + T2F3 = [eq_call(0, N) || N <- Ns], + F2T3 = [ne_call(0, N) || N <- Ns], + %% tests for guards + T1F4 = [eq_exact_guard(0, N) || N <- Ns], + F1T4 = [ne_exact_guard(0, N) || N <- Ns], + T2F3 = [eq_guard(0, N) || N <- Ns], + F2T3 = [ne_guard(0, N) || N <- Ns], + %% some more tests + ok = test_against_zero(), + ok = test_against_other_terms(), + ok = test_sofs_func(), + ok. + +test_against_zero() -> + Xs = [0, 1, 0.0], + [true, false, false] = [is_zero_int(X) || X <- Xs], + [true, false, true] = [is_zero_num(X) || X <- Xs], + [false, true, true] = [is_nonzero_int(X) || X <- Xs], + [false, true, false] = [is_nonzero_num(X) || X <- Xs], + ok. + +test_against_other_terms() -> + TTT = {true, true, true}, + FFF = {false, false, false}, + TTT = {is_foo_exact(foo), is_foo_term1(foo), is_foo_term2(foo)}, + FFF = {is_foo_exact(bar), is_foo_term1(bar), is_foo_term2(bar)}, + FFF = {is_nonfoo_exact(foo), is_nonfoo_term1(foo), is_nonfoo_term2(foo)}, + TTT = {is_nonfoo_exact(bar), is_nonfoo_term1(bar), is_nonfoo_term2(bar)}, + Tup = {a, {42}, [c]}, + TTT = {is_tuple_skel(Tup), is_tuple_exact(Tup), is_tuple_term(Tup)}, + BNi = <<42>>, + TTT = {is_bin_exact(BNi), is_bin_term1(BNi), is_bin_term2(BNi)}, + BNf = <<42/float>>, + FFF = {is_bin_exact(BNf), is_bin_term1(BNf), is_bin_term2(BNf)}, + ok. + +test_sofs_func() -> + L = [0, 0.0], + ok = sofs_func(L, L, L). + +%%-------------------------------------------------------------------- +%% Test for comparison operators used in body calls + +eq_exact_call(X, Y) -> X =:= Y. + +ne_exact_call(X, Y) -> X =/= Y. + +eq_call(X, Y) -> X == Y. + +ne_call(X, Y) -> X /= Y. + +%%-------------------------------------------------------------------- +%% Tests for comparison operators used as guards + +eq_exact_guard(X, Y) when X =:= Y -> true; +eq_exact_guard(_, _) -> false. + +ne_exact_guard(X, Y) when X =/= Y -> true; +ne_exact_guard(_, _) -> false. + +eq_guard(X, Y) when X == Y -> true; +eq_guard(_, _) -> false. + +ne_guard(X, Y) when X /= Y -> true; +ne_guard(_, _) -> false. + +%%-------------------------------------------------------------------- + +is_zero_int(N) when N =:= 0 -> true; +is_zero_int(_) -> false. + +is_nonzero_int(N) when N =/= 0 -> true; +is_nonzero_int(_) -> false. + +is_zero_num(N) when N == 0 -> true; +is_zero_num(_) -> false. + +is_nonzero_num(N) when N /= 0 -> true; +is_nonzero_num(_) -> false. + +%%-------------------------------------------------------------------- +%% There should not really be any difference in the generated code +%% for the following three functions. + +is_foo_exact(A) when A =:= foo -> true; +is_foo_exact(_) -> false. + +is_foo_term1(A) when A == foo -> true; +is_foo_term1(_) -> false. + +is_foo_term2(A) when foo == A -> true; +is_foo_term2(_) -> false. + +%%-------------------------------------------------------------------- +%% Same for these cases + +is_nonfoo_exact(A) when A =/= foo -> true; +is_nonfoo_exact(_) -> false. + +is_nonfoo_term1(A) when A /= foo -> true; +is_nonfoo_term1(_) -> false. + +is_nonfoo_term2(A) when foo /= A -> true; +is_nonfoo_term2(_) -> false. + +%%-------------------------------------------------------------------- + +is_tuple_skel({A,{B},[C]}) when is_atom(A), is_integer(B), is_atom(C) -> true; +is_tuple_skel(T) when is_tuple(T) -> false. + +is_tuple_exact(T) when T =:= {a,{42},[c]} -> true; +is_tuple_exact(T) when is_tuple(T) -> false. + +is_tuple_term(T) when T == {a,{42.0},[c]} -> true; +is_tuple_term(T) when is_tuple(T) -> false. + +%%-------------------------------------------------------------------- +%% But for binaries the treatment has to be different, due to the need +%% for construction of the binary in the guard. + +is_bin_exact(B) when B =:= <<42>> -> true; +is_bin_exact(_) -> false. + +is_bin_term1(B) when B == <<42>> -> true; +is_bin_term1(_) -> false. + +is_bin_term2(B) when <<42>> == B -> true; +is_bin_term2(_) -> false. + +%%-------------------------------------------------------------------- +%% a test from sofs.erl which failed at some point + +sofs_func([X | Ts], X0, L) when X /= X0 -> + sofs_func(Ts, X, L); +sofs_func([X | _Ts], X0, _L) when X == X0 -> + ok; +sofs_func([], _X0, L) -> + L. diff --git a/lib/hipe/test/basic_SUITE_data/basic_exceptions.erl b/lib/hipe/test/basic_SUITE_data/basic_exceptions.erl new file mode 100644 index 0000000000..229a0516dc --- /dev/null +++ b/lib/hipe/test/basic_SUITE_data/basic_exceptions.erl @@ -0,0 +1,465 @@ +%%% -*- erlang-indent-level: 2 -*- +%%%------------------------------------------------------------------- +%%% Author: Kostis Sagonas +%%% +%%% Contains tests that raise exceptions and catch them. +%%%------------------------------------------------------------------- +-module(basic_exceptions). + +-export([test/0, test_catches/0]). + +%% functions used as arguments to spawn/3 +-export([bad_guy/2]). + +test() -> + ok = test_catch_exit(42), + ok = test_catch_throw(42), + ok = test_catch_element(), + ok = test_catch_crash(), + ok = test_catch_empty(), + ok = test_catch_merge(), + ok = test_catches_merged(), + ok = test_pending_errors(), + ok = test_bad_fun_call(), + ok = test_guard_bif(), + ok. + +%%-------------------------------------------------------------------- +%% Written in 2001 by Erik Johansson. + +test_catches() -> + ExitBar = {'EXIT', bar}, + L1 = [ExitBar, ok, ExitBar, {ok, ExitBar}], + L1 = [t1(), t2(), t3(), t4()], + badarith = (catch element(1, element(2, t5(a, b)))), + L2 = [42, ExitBar, ExitBar, {no_exception, ok}], + L2 = [t5(21, 21), t6(), t7(), t8()], + ok. + +t1() -> + catch foo(). + +t2() -> + V = (catch ok()), + s(), + V. + +t3() -> + V = (catch foo()), + V. + +t4() -> + V1 = ok(), + V2 = (catch foo()), + {V1, V2}. + +t5(A, B) -> + catch A + B. + +t6() -> + catch {no_exception, ok(), foo()}. + +t7() -> + catch {no_exception, foo(), ok()}. + +t8() -> + catch {no_exception, ok()}. + +foo() -> + s(), + exit(bar). + +ok() -> s(), ok. + +s() -> nada. + +%%-------------------------------------------------------------------- + +test_catch_exit(N) -> + {'EXIT', N} = (catch exit(N)), + {'EXIT', 42} = (catch exit(42)), + 42 = try exit(N) catch exit:R1 -> R1 end, + 42 = try exit(42) catch exit:R2 -> R2 end, + ok. + +%%-------------------------------------------------------------------- + +test_catch_throw(N) -> + N = (catch throw(N)), + 42 = (catch throw(42)), + 42 = try throw(N) catch throw:R1 -> R1 end, + 42 = try throw(42) catch throw:R2 -> R2 end, + ok. + +%%-------------------------------------------------------------------- + +test_catch_element() -> + 'EXIT' = test_catch_element([]), + 'EXIT' = test_catch_element(42), + ok. + +test_catch_element(N) -> + element(1, catch element(N, {1,2,3,4,5,6,7,8,9,10,11})). + +%%-------------------------------------------------------------------- + +-define(try_match(E), + catch ?MODULE:non_existing(), + {'EXIT', {{badmatch, nomatch}, _}} = (catch E = no_match())). + +test_catch_crash() -> + ?try_match(a), + ?try_match(42), + ?try_match({a, b, c}), + ?try_match([]), + ?try_match(1.0), + ok. + +no_match() -> nomatch. + +%% small_test() -> +%% catch ?MODULE:non_existing(), +%% io:format("Before\n",[]), +%% hipe_bifs:show_nstack(self()), +%% io:format("After\n",[]), +%% garbage_collect(). + +%%-------------------------------------------------------------------- +%% Tests whether the HiPE compiler optimizes catches in a way that +%% does not result in an infinite loop. +%%-------------------------------------------------------------------- + +test_catch_empty() -> + badmatch(). + +badmatch() -> + Big = ret_big(), + Float = ret_float(), + catch a = Big, + catch b = Float, + ok = case Big of Big -> ok end, + ok = case Float of Float -> ok end, + ok. + +ret_big() -> + 329847987298478924982978248748729829487298292982972978239874. + +ret_float() -> + 3.1415927. + +%%-------------------------------------------------------------------- +%% Test that shows how BEAM can merge catch-end blocks that belong to +%% different catch-start instructions. Written by Richard Carlsson. +%%-------------------------------------------------------------------- + +test_catch_merge() -> + merge(get(whatever)). + +merge(foo=X) -> + catch f(X), + catch g(X); +merge(X) -> + catch f(X), + catch g(X). + +f(_) -> ok. + +g(_) -> ok. + +%%-------------------------------------------------------------------- +%% Written by Tobias Lindahl. + +test_catches_merged() -> + {'EXIT', _} = merged_catches(foo), + {'EXIT', {badarith, _}} = merged_catches(bar), + {'EXIT', _} = merged_catches(baz), + ok. + +merged_catches(X) -> + case X of + foo -> catch fail1(0); + bar -> catch {catch(1 = X), fail2(0)}; + baz -> catch fail3(0) + end. + +fail1(X) -> 1/X. + +fail2(X) -> 1/X. + +fail3(X) -> 1/X. + +%%-------------------------------------------------------------------- +%% Taken from exception_SUITE.erl +%%-------------------------------------------------------------------- + +test_pending_errors() -> + error_logger:tty(false), % disable printouts of error reports + pending_errors(). + +%% Test various exceptions, in the presence of a previous error +%% suppressed in a guard. +pending_errors() -> + pending(e_badmatch, {badmatch, b}), + pending(x, function_clause), + pending(e_case, {case_clause, xxx}), + pending(e_if, if_clause), + %% pending(e_badarith, badarith), + %% pending(e_undef, undef), + pending(e_timeoutval, timeout_value), + %% pending(e_badarg, badarg), + %% pending(e_badarg_spawn, badarg), + ok. + +bad_guy(pe_badarith, Other) when Other+1 =:= 0 -> % badarith (suppressed) + ok; +bad_guy(pe_badarg, Other) when length(Other) > 0 -> % badarg (suppressed) + ok; +bad_guy(_, e_case) -> + case xxx() of + ok -> ok + end; % case_clause +bad_guy(_, e_if) -> + B = b(), + if + a == B -> ok + end; % if_clause +%% bad_guy(_, e_badarith) -> +%% 1+b; % badarith +bad_guy(_, e_undef) -> + non_existing_module:foo(); % undef +bad_guy(_, e_timeoutval) -> + receive + after gazonk -> ok % timeout_value + end; +bad_guy(_, e_badarg) -> + node(xxx); % badarg +bad_guy(_, e_badarg_spawn) -> + spawn({}, {}, {}); % badarg +bad_guy(_, e_badmatch) -> + a = b(). % badmatch + +xxx() -> xxx. + +b() -> b. + +pending(Arg, Expected) -> + pending(pe_badarith, Arg, Expected), + pending(pe_badarg, Arg, Expected). + +pending(First, Second, Expected) -> + pending_catched(First, Second, Expected), + pending_exit_message([First, Second], Expected). + +pending_catched(First, Second, Expected) -> + %% ok = io:format("Catching bad_guy(~p, ~p)\n", [First, Second]), + case catch bad_guy(First, Second) of + {'EXIT', Reason} -> + pending(Reason, bad_guy, [First, Second], Expected); + Other -> + exit({not_exit, Other}) + end. + +pending_exit_message(Args, Expected) -> + %% ok = io:format("Trapping exits from spawn_link(~p, ~p, ~p)\n", + %% [?MODULE, bad_guy, Args]), + process_flag(trap_exit, true), + Pid = spawn_link(?MODULE, bad_guy, Args), + receive + {'EXIT', Pid, Reason} -> + pending(Reason, bad_guy, Args, Expected); + Other -> + exit({unexpected_message, Other}) + after 10000 -> + exit(timeout) + end, + process_flag(trap_exit, false). + +%% pending({badarg, [{erlang,Bif,BifArgs},{?MODULE,Func,Arity}|_]}, +%% Func, Args, _Code) +%% when atom(Bif), list(BifArgs), length(Args) =:= Arity -> +%% ok; +pending({badarg,Trace}, _, _, _) when is_list(Trace) -> + ok; +%% pending({undef,[{non_existing_module,foo,[]}|_]}, _, _, _) -> +%% ok; +pending({undef,Trace}, _, _, _) when is_list(Trace) -> + ok; +%% pending({function_clause,[{?MODULE,Func,Args}|_]}, Func, Args, _Code) -> +%% ok; +pending({function_clause,Trace}, _, _, _) when is_list(Trace) -> + ok; +%% pending({Code,[{?MODULE,Func,Arity}|_]}, Func, Args, Code) +%% when length(Args) =:= Arity -> +%% ok; +pending({Code,Trace}, _, _, Code) when is_list(Trace) -> + ok; +pending(Reason, _Function, _Args, _Code) -> + exit({bad_exit_reason, Reason}). + +%%-------------------------------------------------------------------- +%% Taken from fun_SUITE.erl +%% +%% Checks correct exception throwing when calling a bad fun. +%%-------------------------------------------------------------------- + +test_bad_fun_call() -> + ok = bad_call_fc(42), + ok = bad_call_fc(xx), + ok = bad_call_fc({}), + ok = bad_call_fc({1}), + ok = bad_call_fc({1,2,3}), + ok = bad_call_fc({1,2,3}), + ok = bad_call_fc({1,2,3,4}), + ok = bad_call_fc({1,2,3,4,5,6}), + ok = bad_call_fc({1,2,3,4,5}), + ok = bad_call_fc({1,2}), + ok. + +bad_call_fc(Fun) -> + Args = [some, stupid, args], + Res = (catch Fun(Fun(Args))), + case Res of + {'EXIT', {{badfun, Fun} ,_Where}} -> + ok; %% = io:format("~p(~p) -> ~p\n", [Fun, Args, Res]); + Other -> + io:format("~p(~p) -> ~p\n", [Fun, Args, Res]), + exit({bad_result, Other}) + end. + +%%-------------------------------------------------------------------- +%% Taken from guard_SUITE.erl +%% +%% Tests correct handling of exceptions by calling guard BIFs with +%% nasty (but legal arguments). +%%-------------------------------------------------------------------- + +test_guard_bif() -> + Big = -237849247829874297658726487367328971246284736473821617265433, + Float = 387924.874, + + %% Succeding use of guard bifs. + + try_gbif('abs/1', Big, -Big), + try_gbif('float/1', Big, float(Big)), + try_gbif('trunc/1', Float, 387924.0), + try_gbif('round/1', Float, 387925.0), + try_gbif('length/1', [], 0), + + try_gbif('length/1', [a], 1), + try_gbif('length/1', [a, b], 2), + try_gbif('length/1', lists:seq(0, 31), 32), + + try_gbif('hd/1', [a], a), + try_gbif('hd/1', [a, b], a), + + try_gbif('tl/1', [a], []), + try_gbif('tl/1', [a, b], [b]), + try_gbif('tl/1', [a, b, c], [b, c]), + + try_gbif('size/1', {}, 0), + try_gbif('size/1', {a}, 1), + try_gbif('size/1', {a, b}, 2), + try_gbif('size/1', {a, b, c}, 3), + try_gbif('size/1', list_to_binary([]), 0), + try_gbif('size/1', list_to_binary([1]), 1), + try_gbif('size/1', list_to_binary([1, 2]), 2), + try_gbif('size/1', list_to_binary([1, 2, 3]), 3), + + try_gbif('element/2', {x}, {1, x}), + try_gbif('element/2', {x, y}, {1, x}), + try_gbif('element/2', {x, y}, {2, y}), + + try_gbif('self/0', 0, self()), + try_gbif('node/0', 0, node()), + try_gbif('node/1', self(), node()), + + %% Failing use of guard bifs. + + try_fail_gbif('abs/1', Big, 1), + try_fail_gbif('abs/1', [], 1), + + try_fail_gbif('float/1', Big, 42), + try_fail_gbif('float/1', [], 42), + + try_fail_gbif('trunc/1', Float, 0.0), + try_fail_gbif('trunc/1', [], 0.0), + + try_fail_gbif('round/1', Float, 1.0), + try_fail_gbif('round/1', [], a), + + try_fail_gbif('length/1', [], 1), + try_fail_gbif('length/1', [a], 0), + try_fail_gbif('length/1', a, 0), + try_fail_gbif('length/1', {a}, 0), + + try_fail_gbif('hd/1', [], 0), + try_fail_gbif('hd/1', [a], x), + try_fail_gbif('hd/1', x, x), + + try_fail_gbif('tl/1', [], 0), + try_fail_gbif('tl/1', [a], x), + try_fail_gbif('tl/1', x, x), + + try_fail_gbif('size/1', {}, 1), + try_fail_gbif('size/1', [], 0), + try_fail_gbif('size/1', [a], 1), + try_fail_gbif('size/1', fun() -> 1 end, 0), + try_fail_gbif('size/1', fun() -> 1 end, 1), + + try_fail_gbif('element/2', {}, {1, x}), + try_fail_gbif('element/2', {x}, {1, y}), + try_fail_gbif('element/2', [], {1, z}), + + try_fail_gbif('self/0', 0, list_to_pid("<0.0.0>")), + try_fail_gbif('node/0', 0, xxxx), + try_fail_gbif('node/1', self(), xxx), + try_fail_gbif('node/1', yyy, xxx), + ok. + +try_gbif(Id, X, Y) -> + case guard_bif(Id, X, Y) of + {Id, X, Y} -> + %% io:format("guard_bif(~p, ~p, ~p) -- ok\n", [Id, X, Y]); + ok; + Other -> + ok = io:format("guard_bif(~p, ~p, ~p) -- bad result: ~p\n", + [Id, X, Y, Other]), + exit({bad_result,try_gbif}) + end. + +try_fail_gbif(Id, X, Y) -> + case catch guard_bif(Id, X, Y) of + %% {'EXIT', {function_clause,[{?MODULE,guard_bif,[Id,X,Y]}|_]}} -> + {'EXIT', {function_clause,_}} -> % in HiPE, a trace is not generated + %% io:format("guard_bif(~p, ~p, ~p) -- ok\n", [Id,X,Y]); + ok; + Other -> + ok = io:format("guard_bif(~p, ~p, ~p) -- bad result: ~p\n", + [Id, X, Y, Other]), + exit({bad_result,try_fail_gbif}) + end. + +guard_bif('abs/1', X, Y) when abs(X) == Y -> + {'abs/1', X, Y}; +guard_bif('float/1', X, Y) when float(X) == Y -> + {'float/1', X, Y}; +guard_bif('trunc/1', X, Y) when trunc(X) == Y -> + {'trunc/1', X, Y}; +guard_bif('round/1', X, Y) when round(X) == Y -> + {'round/1', X, Y}; +guard_bif('length/1', X, Y) when length(X) == Y -> + {'length/1', X, Y}; +guard_bif('hd/1', X, Y) when hd(X) == Y -> + {'hd/1', X, Y}; +guard_bif('tl/1', X, Y) when tl(X) == Y -> + {'tl/1', X, Y}; +guard_bif('size/1', X, Y) when size(X) == Y -> + {'size/1', X, Y}; +guard_bif('element/2', X, {Pos, Expected}) when element(Pos, X) == Expected -> + {'element/2', X, {Pos, Expected}}; +guard_bif('self/0', X, Y) when self() == Y -> + {'self/0', X, Y}; +guard_bif('node/0', X, Y) when node() == Y -> + {'node/0', X, Y}; +guard_bif('node/1', X, Y) when node(X) == Y -> + {'node/1', X, Y}. diff --git a/lib/hipe/test/basic_SUITE_data/basic_floats.erl b/lib/hipe/test/basic_SUITE_data/basic_floats.erl new file mode 100644 index 0000000000..eec175075a --- /dev/null +++ b/lib/hipe/test/basic_SUITE_data/basic_floats.erl @@ -0,0 +1,180 @@ +%%% -*- erlang-indent-level: 2 -*- +%%%------------------------------------------------------------------- +%%% Author: Kostis Sagonas +%%% +%%% Contains tests that manipulate floating point numbers. +%%%------------------------------------------------------------------- +-module(basic_floats). + +-export([test/0]). +-export([test_fmt_double_fpe_leak/0]). % suppress the unused warning + +test() -> + ok = test_arith_ops(), + ok = test_fp_ebb(), + ok = test_fp_phi(), + ok = test_big_bad_float(), + ok = test_catch_bad_fp_arith(), + ok = test_catch_fp_conv(), + ok = test_fp_with_fp_exceptions(), + %% ok = test_fmt_double_fpe_leak(), % this requires printing + ok. + +%%-------------------------------------------------------------------- + +test_arith_ops() -> + E = 2.5617, + 5.703200000000001 = add(E), + 0.5798000000000001 = sub(E), + 8.047580550000001 = mult(E), + -6.023e23 = negate(6.023e23), + ok. + +add(X) -> + 3.1415 + X. + +sub(X) -> + 3.1415 - X. + +mult(X) -> + 3.1415 * X. + +%% tests the translation of the fnegate BEAM instruction. +negate(X) -> + - (X + 0.0). + +%%-------------------------------------------------------------------- +%% Test the construction of overlapping extended basic blocks where +%% BEAM has constructed one and hipe_icode_fp constructs the other. +%%-------------------------------------------------------------------- + +test_fp_ebb() -> + 1.0 = foo(2 * math:pi()), + 1.0 = bar(2 * math:pi()), + ok. + +foo(X) -> + X / (2 * math:pi()). + +bar(X) -> + F = float_two(), + case F < 3.0 of + true -> (X * F) / ((2 * F) * math:pi()); + false -> weird + end. + +float_two() -> + 2.0. + +%%-------------------------------------------------------------------- + +test_fp_phi() -> + 10 = fp_phi(10, 100), + undefined = fp_phi(1.1e302, 0.000000001), + ok. + +fp_phi(A, B) -> + case catch A / B of + {'EXIT', _Reason} -> undefined; + _ -> round(100 * (A / B)) + end. + +%%-------------------------------------------------------------------- + +-define(BS, "93904329458954829589425849258998492384932849328493284932849328493284932389248329432932483294832949245827588578423578435783475834758375837580745807304258924584295924588459834958349589348589345934859384958349583945893458934859438593485995348594385943859438593458934589345938594385934859483958348934589435894859485943859438594594385938459438595034950439504395043950495043593485943758.0"). + +test_big_bad_float() -> + ok = try f2l(?BS) catch error:badarg -> ok end, + ok = case catch f2l(?BS) of {'EXIT', {badarg, _}} -> ok end, + ok. + +f2l(F) -> + float_to_list(list_to_float(F)). + +%%-------------------------------------------------------------------- +%% Tests catching of floating point bad arithmetic. + +test_catch_bad_fp_arith() -> + 5.7 = f(2.56), + {'EXIT', {badarith, _}} = bad_arith(9.9), + ok. + +f(F) when is_float(F) -> F + 3.14. + +bad_arith(F) when is_float(F) -> + catch F * 1.70000e+308. + +%%-------------------------------------------------------------------- +%% Tests proper catching of exceptions due to illegal convertion of +%% bignums to floating point numbers. + +test_catch_fp_conv() -> + F = 1.7e308, %% F is a number very close to a maximum float. + ok = big_arith(F), + ok = big_const_float(F), + ok. + +big_arith(F) -> + I = trunc(F), + {'EXIT', {badarith, _}} = big_int_arith(I), + ok. + +big_int_arith(I) when is_integer(I) -> + catch(3.0 + 2*I). + +big_const_float(F) -> + I = trunc(F), + badarith = try (1/(2*I)) catch error:Err -> Err end, + _ = 2/I, + {'EXIT', _} = (catch 4/(2*I)), + ok. + +%%-------------------------------------------------------------------- +%% Forces floating point exceptions and tests that subsequent, legal, +%% operations are calculated correctly. + +test_fp_with_fp_exceptions() -> + 0.0 = math:log(1.0), + badarith = try math:log(float_minus_one()) catch error:E1 -> E1 end, + 0.0 = math:log(1.0), + badarith = try math:log(float_zero()) catch error:E2 -> E2 end, + 0.0 = math:log(1.0), + %% An old-fashioned exception here just so as to test this case also + {'EXIT', _} = (catch fp_mult(3.23e133, 3.57e257)), + 0.0 = math:log(1.0), + badarith = try fp_div(5.0, 0.0) catch error:E3 -> E3 end, + 0.0 = math:log(1.0), + ok. + +fp_mult(X, Y) -> X * Y. + +fp_div(X, Y) -> X / Y. + +%% The following two function definitions appear here just to shut +%% off 'expression will fail with a badarg' warnings from the compiler + +float_zero() -> 0.0. + +float_minus_one() -> -1.0. + +%%-------------------------------------------------------------------- +%% Test that erl_printf_format.c:fmt_double() does not leak pending FP +%% exceptions to subsequent code. This used to break x87 FP code on +%% 32-bit x86. Based on a problem report from Richard Carlsson. + +test_fmt_double_fpe_leak() -> + test_fmt_double_fpe_leak(float_zero(), int_two()), + ok. + +%% We need the specific sequence of erlang:display/1 on a float that +%% triggers faulting ops in fmt_double() followed by a simple FP BIF. +%% We also need to repeat this at least three times. +test_fmt_double_fpe_leak(X, Y) -> + erlang:display(X), _ = math:log10(Y), + erlang:display(X), _ = math:log10(Y), + erlang:display(X), _ = math:log10(Y), + erlang:display(X), _ = math:log10(Y), + erlang:display(X), + math:log10(Y). + +int_two() -> 2. diff --git a/lib/hipe/test/basic_SUITE_data/basic_fun.erl b/lib/hipe/test/basic_SUITE_data/basic_fun.erl new file mode 100644 index 0000000000..18ba7fdb3f --- /dev/null +++ b/lib/hipe/test/basic_SUITE_data/basic_fun.erl @@ -0,0 +1,124 @@ +%%% -*- erlang-indent-level: 2 -*- +%%%------------------------------------------------------------------- +%%% Author: Kostis Sagonas +%%% +%%% Tests for correct handling of funs. +%%%------------------------------------------------------------------- +-module(basic_fun). + +-export([test/0]). + +-export([dummy_foo/4, add1/1, test_fun03/0]). + +test() -> + ok = test_calls(), + ok = test_is_function(), + ok = test_is_function2(), + ok. + +%%-------------------------------------------------------------------- +%% Tests function and fun calls. + +test_calls() -> + ok = test_apply_call(?MODULE, dummy_foo), + ok = test_fun_call(fun dummy_foo/4), + ok = test_fun_call(fun ?MODULE:dummy_foo/4), + ok. + +test_apply_call(M, F) -> + M:F(bar, 42, foo, 17). + +test_fun_call(Fun) -> + Fun(bar, 42, foo, 17). + +dummy_foo(_, _, foo, _) -> ok. + +%%-------------------------------------------------------------------- +%% Tests handling of funs out of exported functions and 2-tuple funs. + +test_fun03() -> + MFPair = add1_as_2tuple(), + 4712 = do_call(add1_as_export(), 4711), + {badfun, MFPair} = try do_call(MFPair, 88) catch error:Err -> Err end, + true = do_guard(add1_as_export()), + false = do_guard(MFPair), % 2-tuples do not satisfy is_function/1 + ok. + +do_call(F, X) -> F(X). + +do_guard(F) when is_function(F) -> true; +do_guard(_) -> false. + +add1_as_export() -> fun ?MODULE:add1/1. + +add1_as_2tuple() -> {?MODULE, add1}. + +add1(X) -> X+1. + +%%-------------------------------------------------------------------- +%% Tests the is_function guard and BIF. + +test_is_function() -> + Fun = fun (X, foo) -> dummy_foo(X, mnesia_lib, foo, [X]) end, + ok = test_when_guard(Fun), + ok = test_if_guard(Fun), + ok. + +test_when_guard(X) when is_function(X) -> ok. + +test_if_guard(X) -> + if is_function(X) -> ok; + true -> weird + end. + +%%-------------------------------------------------------------------- +%% Tests the is_function2 guard and BIF. + +test_is_function2() -> + ok = test_guard(), + ok = test_guard2(), + ok = test_call(), + ok. + +test_guard() -> + zero_fun = test_f2(fun () -> ok end), + unary_fun = test_f2(fun(X) -> X end), + binary_fun = test_f2(fun (X, Y) -> {X, Y} end), + no_fun = test_f2(gazonk), + ok. + +test_f2(Fun) when is_function(Fun, 0) -> + zero_fun; +test_f2(Fun) when is_function(Fun, 1) -> + unary_fun; +test_f2(Fun) when is_function(Fun, 2) -> + binary_fun; +test_f2(_) -> + no_fun. + +test_guard2() -> + zero_fun = test_f2_n(fun () -> ok end, 0), + unary_fun = test_f2_n(fun (X) -> X end, 1), + binary_fun = test_f2_n(fun (X, Y) -> {X, Y} end, 2), + no_fun = test_f2_n(gazonk, 0), + ok. + +test_f2_n(F, N) when is_function(F, N) -> + case N of + 0 -> zero_fun; + 1 -> unary_fun; + 2 -> binary_fun + end; +test_f2_n(_, _) -> + no_fun. + +test_call() -> + true = test_fn2(fun (X, Y) -> {X,Y} end, 2), + false = test_fn2(fun (X, Y) -> {X,Y} end, 3), + false = test_fn2(gazonk, 2), + {'EXIT', {badarg, _TR1}} = (catch test_fn2(gazonk, gazonk)), + {'EXIT', {badarg, _TR2}} = (catch test_fn2(fun (X, Y) -> {X, Y} end, gazonk)), + ok. + +test_fn2(F, N) -> + is_function(F, N). diff --git a/lib/hipe/test/basic_SUITE_data/basic_guards.erl b/lib/hipe/test/basic_SUITE_data/basic_guards.erl new file mode 100644 index 0000000000..81eeed7c3b --- /dev/null +++ b/lib/hipe/test/basic_SUITE_data/basic_guards.erl @@ -0,0 +1,164 @@ +%%% -*- erlang-indent-level: 2 -*- +%%%------------------------------------------------------------------- +%%% Author: Kostis Sagonas +%%% +%%% Contains tests for correct handling of guards and guard BIFs. +%%%------------------------------------------------------------------- +-module(basic_guards). + +-export([test/0]). +%% Prevent the inlining of the following functions +-export([bad_arith/0, bad_tuple/0, is_strange_guard/0]). + +test() -> + ok = guard0(4.2), + ok = guard1([foo]), + ok = test_guard2(), + ok = test_guard3(), + ok = test_guard4(), + ok = test_is_boolean(), + ok = test_bad_guards(), + ok. + +%%-------------------------------------------------------------------- + +guard0(X) when X /= 0, is_float(X) -> + ok. + +guard1(X) when is_atom(X) orelse is_float(X) -> + error1; +guard1(X) when is_reference(hd(X)) -> + error2; +guard1(X) when is_integer(hd(X)) -> + error3; +guard1(X) when hd(X) == foo -> + ok. + +%%-------------------------------------------------------------------- + +test_guard2() -> + ok1 = guard2(true), + not_boolean = guard2(42), + ok2 = guard2(false), + ok. + +guard2(X) when X -> % gets transformed to: is_boolean(X), X =:= true + ok1; +guard2(X) when X =:= false -> + ok2; +guard2(_) -> + not_boolean. + +%%-------------------------------------------------------------------- + +-define(is_foo(X), (is_atom(X) or (is_tuple(X) and (element(1, X) =:= 'foo')))). + +test_guard3() -> + no = f('foo'), + yes = f({'foo', 42}), + no = f(42), + ok. + +f(X) when ?is_foo(X) -> yes; +f(_) -> no. + +%%-------------------------------------------------------------------- + +-define(EXT_REF, <<131,114,0,3,100,0,19,114,101,102,95,116,101,115,116,95,98,117,103,64,103,111,114,98,97,103,2,0,0,0,125,0,0,0,0,0,0,0,0>>). + +test_guard4() -> + yes = is_ref(make_ref()), + no = is_ref(gazonk), + yes = is_ref(an_external_ref(?EXT_REF)), + ok. + +is_ref(Ref) when is_reference(Ref) -> yes; +is_ref(_Ref) -> no. + +an_external_ref(Bin) -> + binary_to_term(Bin). + +%%-------------------------------------------------------------------- + +test_is_boolean() -> + ok = is_boolean_in_if(), + ok = is_boolean_in_guard(). + +is_boolean_in_if() -> + ok1 = tif(true), + ok2 = tif(false), + not_bool = tif(other), + ok. + +is_boolean_in_guard() -> + ok = tg(true), + ok = tg(false), + not_bool = tg(other), + ok. + +tif(V) -> + Yes = yes(), %% just to prevent the optimizer removing this + if + %% the following line generates an is_boolean instruction + V, Yes == yes -> + %% while the following one does not (?!) + %% Yes == yes, V -> + ok1; + not(not(not(V))) -> + ok2; + V -> + ok3; + true -> + not_bool + end. + +tg(V) when is_boolean(V) -> + ok; +tg(_) -> + not_bool. + +yes() -> yes. + +%%-------------------------------------------------------------------- +%% original test by Bjorn G + +test_bad_guards() -> + ok = bad_arith(), + ok = bad_tuple(), + ok = is_strange_guard(), + ok. + +bad_arith() -> + 13 = bad_arith1(1, 12), + 42 = bad_arith1(1, infinity), + 42 = bad_arith1(infinity, 1), + 42 = bad_arith2(infinity, 1), + 42 = bad_arith3(inf), + 42 = bad_arith4(infinity, 1), + ok. + +bad_arith1(T1, T2) when (T1 + T2) < 17 -> T1 + T2; +bad_arith1(_, _) -> 42. + +bad_arith2(T1, T2) when (T1 * T2) < 17 -> T1 * T2; +bad_arith2(_, _) -> 42. + +bad_arith3(T) when (bnot T) < 17 -> T; +bad_arith3(_) -> 42. + +bad_arith4(T1, T2) when (T1 bsr T2) < 10 -> T1 bsr T2; +bad_arith4(_, _) -> 42. + +bad_tuple() -> + error = bad_tuple1(a), + error = bad_tuple1({a, b}), + x = bad_tuple1({x, b}), + y = bad_tuple1({a, b, y}), + ok. + +bad_tuple1(T) when element(1, T) =:= x -> x; +bad_tuple1(T) when element(3, T) =:= y -> y; +bad_tuple1(_) -> error. + +is_strange_guard() when is_tuple({1, bar, length([1, 2, 3, 4]), self()}) -> ok; +is_strange_guard() -> error. diff --git a/lib/hipe/test/basic_SUITE_data/basic_inline_function.erl b/lib/hipe/test/basic_SUITE_data/basic_inline_function.erl new file mode 100644 index 0000000000..4c08064670 --- /dev/null +++ b/lib/hipe/test/basic_SUITE_data/basic_inline_function.erl @@ -0,0 +1,73 @@ +%%% -*- erlang-indent-level: 2 -*- +%%%------------------------------------------------------------------- +%%% Author: Kostis Sagonas +%%% +%%% Contains tests that depend on the compiler inliner being turned on. +%%%------------------------------------------------------------------- +-module(basic_inline_function). + +-export([test/0]). + +-compile({inline, [{to_objects, 3}]}). + +test() -> + ok = test_inline_match(), + ok. + +%%-------------------------------------------------------------------- + +test_inline_match() -> + bad_object = test1(a, {binary, foo, set}, c), + bad_object = test2(a, {binary, foo, set}, c), + bad_object = test3(a, {binary, foo, set}, c), + ok. + +%% Inlined +test1(KeysObjs, C, Ts) -> + case catch to_objects(KeysObjs, C, Ts) of + {'EXIT', _} -> + bad_object; + ok -> + ok + end. + +%% "Inlined" by hand +test2(KeysObjs, C, _Ts) -> + case catch (case C of + {binary, _, set} -> + <<_ObjSz0:32, _T/binary>> = KeysObjs; + _ -> ok + end) of + {'EXIT', _} -> + bad_object; + ok -> + ok + end. + +%% Not inlined +test3(KeysObjs, C, Ts) -> + case catch fto_objects(KeysObjs, C, Ts) of + {'EXIT', _} -> + bad_object; + ok -> + ok + end. + +%% Inlined. +to_objects(Bin, {binary, _, set}, _Ts) -> + <<_ObjSz0:32, _T/binary>> = Bin, + ok; +to_objects(<<_ObjSz0:32, _T/binary>> ,_, _) -> + ok; +to_objects(_Bin, _, _Ts) -> + ok. + +%% Not Inlined. +fto_objects(Bin, {binary, _, set}, _Ts) -> + <<_ObjSz0:32, _T/binary>> = Bin, + ok; +fto_objects(<<_ObjSz0:32, _T/binary>> ,_,_) -> + ok; +fto_objects(_Bin, _, _Ts) -> + ok. + diff --git a/lib/hipe/test/basic_SUITE_data/basic_inline_module.erl b/lib/hipe/test/basic_SUITE_data/basic_inline_module.erl new file mode 100644 index 0000000000..306c6a39ce --- /dev/null +++ b/lib/hipe/test/basic_SUITE_data/basic_inline_module.erl @@ -0,0 +1,31 @@ +%%% -*- erlang-indent-level: 2 -*- +%%%------------------------------------------------------------------- +%%% Author: Kostis Sagonas +%%% +%%% Contains tests that depend on the compiler inliner being turned on. +%%%------------------------------------------------------------------- +-module(basic_inline_module). + +-export([test/0]). + +-compile([inline]). %% necessary for these tests + +test() -> + ok = test_case_end_atom(), + ok. + +%%-------------------------------------------------------------------- +%% Tests whether the translation of a case_end instruction works even +%% when an exception (no matching case pattern) is to be raised. + +test_case_end_atom() -> + {'EXIT',{{case_clause,some_atom},_Trace}} = (catch test_case_stm_inlining()), + ok. + +test_case_stm_inlining() -> + case some_atom() of + another_atom -> strange_result + end. + +some_atom() -> + some_atom. diff --git a/lib/hipe/test/basic_SUITE_data/basic_issues_beam.erl b/lib/hipe/test/basic_SUITE_data/basic_issues_beam.erl new file mode 100644 index 0000000000..73367c5c45 --- /dev/null +++ b/lib/hipe/test/basic_SUITE_data/basic_issues_beam.erl @@ -0,0 +1,326 @@ +%%% -*- erlang-indent-level: 2 -*- +%%%------------------------------------------------------------------- +%%% Author: Kostis Sagonas +%%% +%%% Contains code examples, mostly taken from the mailing list, that +%%% crashed the BEAM compiler or gave an internal error at some point. +%%%------------------------------------------------------------------- +-module(basic_issues_beam). + +-export([test/0]). + +test() -> + ok = test_crash_R10_hinde(), + ok = test_error_R10_mander(), + ok = test_error_R11_bjorklund(), + ok = test_error_R11_rath(), + ok = test_error_R12_empty_bin_rec(), + ok = test_bug_R12_cornish(), + ok = test_crash_R12_morris(), + ok = test_error_R13_almeida(), + ok = test_error_R13B01_fisher(), + ok = test_error_R13B01_sawatari(), + ok = test_error_R13B01_whongo(), + ok = test_error_R16B03_norell(), + ok = test_error_try_wings(), + ok. + +%%-------------------------------------------------------------------- +%% Fisher R10 compiler crash +%%-------------------------------------------------------------------- + +-record(r, {a, b, c}). + +test_crash_R10_hinde() -> + rec_R10_hinde(#r{}). + +rec_R10_hinde(As) -> + case As of + A when A#r.b == ""; A#r.b == undefined -> ok; + _ -> error + end. + +%%-------------------------------------------------------------------- +%% From: Peter-Henry Mander +%% Date: 27 Jan, 2005 +%% +%% I managed to isolate a non-critical BEAM compilation error +%% (internal error in v3_codegen) when compiling the following code: +%%-------------------------------------------------------------------- + +test_error_R10_mander() -> + try just_compile_me_R10() catch _:_ -> ok end. + +just_compile_me_R10() -> + URI_Before = + {absoluteURI, + {scheme, fun() -> nil end}, + {hier_part, + {net_path, + {srvr, + {userinfo, nil}, + fun() -> nil end}, + nil}, + {port, nil}}}, + {absoluteURI, + {scheme, _}, + {hier_part, + {net_path, + {srvr, + {userinfo, nil}, + _HostportBefore}, + nil}, + {port, nil}}} = URI_Before, + %% ... some funky code ommitted, not relevant ... + {absoluteURI, + {scheme, _}, + {hier_part, + {net_path, + {srvr, + {userinfo, nil}, + HostportAfter}, + nil}, + {port, nil}}} = URI_Before, + %% NOTE: I intended to write URI_After instead of URI_Before + %% but the accident revealed that when you add the line below, + %% it causes internal error in v3_codegen on compilation + {hostport, {hostname, "HostName"}, {port, nil}} = HostportAfter, + ok. + +%%-------------------------------------------------------------------- +%% From: Martin Bjorklund +%% Date: Aug 16, 2006 +%% +%% I found this compiler bug in R10B-10 and R11B-0. +%% +%% Function -just_compile_me/0-fun-2-/1 refers to undefined label 18 +%% ./bjorklund_R11compiler_bug.erl:none: internal error in beam_clean; +%% crash reason: {{case_clause,{'EXIT',{undefined_label,18}}}, +%% [{compile,'-select_passes/2-anonymous-2-',2}, +%% {compile,'-internal_comp/4-anonymous-1-',2}, +%% {compile,fold_comp,3}, +%% {compile,internal_comp,4}, +%% {compile,internal,3}]} +%%-------------------------------------------------------------------- + +test_error_R11_bjorklund() -> + just_compile_me_R11_bjorklund(). + +just_compile_me_R11_bjorklund() -> + G = fun() -> ok end, + try + G() %% fun() -> ok end + after + fun({A, B}) -> A + B end + end. + +%%-------------------------------------------------------------------- +%% From: Tim Rath +%% Date: Sep 13, 2006 +%% Subject: Compiler bug not quite fixed +%% +%% +%% I saw a compiler bug posted to the list by Martin Bjorklund that +%% appeared to be exactly the problem I'm seeing, and then noticed +%% that this was fixed in R11B-1. Unfortunately, though R11B-1 appears +%% to fix the code submitted by Martin, it does not fix my case. +%% +%% Function -just_compile_me/0-fun-2-/1 refers to undefined label 13 +%% ./rath_R11compiler_bug.erl:none: internal error in beam_clean; +%% crash reason: {{case_clause,{'EXIT',{undefined_label,13}}}, +%% [{compile,'-select_passes/2-anonymous-2-',2}, +%% {compile,'-internal_comp/4-anonymous-1-',2}, +%% {compile,fold_comp,3}, +%% {compile,internal_comp,4}, +%% {compile,internal,3}]} +%%-------------------------------------------------------------------- + +test_error_R11_rath() -> + just_compile_me_R11_rath(). + +just_compile_me_R11_rath() -> + A = {6}, + try + io:fwrite("") + after + fun () -> + fun () -> {_} = A end + end + end. + +%%---------------------------------------------------------------------- +%% Program that crashed the R12B-0 compiler: internal error in v3_codegen +%%---------------------------------------------------------------------- + +-record(rec, {a = <<>> :: binary(), b = 42 :: integer()}). + +test_error_R12_empty_bin_rec() -> + 42 = test_empty_bin_rec(#rec{}), + ok. + +test_empty_bin_rec(R) -> + #rec{a = <<>>} = R, + R#rec.b. + +%%---------------------------------------------------------------------- +%% From: Simon Cornish +%% Date: Jan 13, 2008 +%% +%% The attached Erlang code demonstrates an R12B-0 bug with funs. +%% Compile and evaluate the two die/1 calls for two different failure modes. +%% It seems to me that the live register check for call_fun is off by one. +%%---------------------------------------------------------------------- + +-record(b, {c}). + +test_bug_R12_cornish() -> + {a2, a} = die(a), + {a2, {b, c}} = die({b, c}), + ok. + +die(A) -> + F = fun() -> {ok, A} end, + if A#b.c =:= [] -> one; + true -> + case F() of + {ok, A2} -> {a2, A2}; + _ -> three + end + end. + +%%---------------------------------------------------------------------- +%% From: Hunter Morris +%% Date: Nov 20, 2008 +%% +%% The following code (tested with R12B-4 or R12B-5, vanilla compiler +%% options) produces a compiler crash. It's nonsensical, and I realise +%% that andalso can be quite evil, but it's a crash nonetheless. +%%---------------------------------------------------------------------- + +test_crash_R12_morris() -> + foo(42). + +foo(Bar) when (is_integer(Bar) andalso Bar =:= 0) ; Bar =:= 42 -> + ok. + +%%-------------------------------------------------------------------- +%% From: Paulo Sergio Almeida +%% Date: May 20, 2009 +%% +%% The following code when compiled under R13B gives a compiler error. +%% Function loop/1 refers to undefined label 6 +%% ./almeida_R13compiler_bug.erl:none: internal error in beam_peep; +%% crash reason: {{case_clause,{'EXIT',{undefined_label,6}}}, +%% [{compile,'-select_passes/2-anonymous-2-',2}, +%% {compile,'-internal_comp/4-anonymous-1-',2}, +%%-------------------------------------------------------------------- + +test_error_R13_almeida() -> + self() ! {backup, 42, false}, + loop([]). + +loop(Tids) -> + receive + {backup, Tid, Dumping} -> + case Dumping of + false -> ok; + _ -> receive {logged, Tab, Tid} -> put({log, Tab}, Tid) end + end, + collect(Tid, Tids, []) + end. + +collect(_, _, _) -> ok. + +%%-------------------------------------------------------------------- +%% Fisher R13B01 compiler error +%%-------------------------------------------------------------------- + +test_error_R13B01_fisher() -> + perform_select({foo, "42"}). + +perform_select({Type, Keyval}) -> + try + if is_atom(Type) andalso length(Keyval) > 0 -> ok; + true -> ok + end + catch + _:_ -> fail + end. + +%%-------------------------------------------------------------------- +%% From: Mikage Sawatari +%% Date: Jun 12, 2009 +%% +%% I have the following compilation problem on Erlang R13B01. +%% Compiler reports "Internal consistency check failed". +%%-------------------------------------------------------------------- + +test_error_R13B01_sawatari() -> + test_sawatari([1, null, 3], <<1, 2, 3>>). + +test_sawatari([], _Bin) -> ok; +test_sawatari([H|T], Bin) -> + _ = case H of + null -> <<Bin/binary>>; + _ -> ok + end, + test_sawatari(T, Bin). + +%%-------------------------------------------------------------------- + +test_error_R13B01_whongo() -> + S = "gazonk", + S = orgno_alphanum(S), + ok. + +orgno_alphanum(Cs) -> + [C || C <- Cs, ((C >= $0) andalso (C =< $9)) + orelse ((C >= $a) andalso (C =< $z)) + orelse ((C >= $A) andalso (C =< $Z))]. + +%%-------------------------------------------------------------------- +%% I'm getting an Internal Consistency Check error when attempting to +%% build Wings3D on Mac OS X 10.4.2 (Erlang OTP R10B-6): +%% +%% erlc -pa /ebin +warn_unused_vars -I/include -I ../e3d -W +debug_info +%% '-Dwings_version="0.98.31"' -pa ../ebin -o../ebin wings_color.erl +%% wings_color: function internal_rgb_to_hsv/3+97: +%% Internal consistency check failed - please report this bug. +%% Instruction: {test,is_eq_exact,{f,80},[{x,0},{atom,error}]} +%% Error: {unsafe_instruction,{float_error_state,cleared}}: +%% +%% The problem is the interaction of the 'try' construct with the +%% handling of FP exceptions. +%%-------------------------------------------------------------------- + +test_error_try_wings() -> + %% a call with a possible FP exception + {199.99999999999997, 0.045454545454545456, 44} = rgb_to_hsv(42, 43, 44), + ok. + +rgb_to_hsv(R, G, B) -> + Max = lists:max([R, G, B]), + Min = lists:min([R, G, B]), + V = Max, + {Hue, Sat} = try + {if Min == B -> (G-Min)/(R+G-2.0*Min); + Min == R -> (1.0+(B-Min)/(B+G-2.0*Min)); + Min == G -> (2.0+(R-Min)/(B+R-2.0*Min)) + end * 120, (Max-Min)/Max} + catch + error:badarith -> {undefined, 0.0} + end, + {Hue, Sat, V}. + +%%-------------------------------------------------------------------- +%% From: Ulf Norell +%% Date: Feb 28, 2014 +%% +%% This caused an internal error in v3_codegen +%%-------------------------------------------------------------------- + +test_error_R16B03_norell() -> + test_error_R16B03_norell(#r{}, gazonk). + +test_error_R16B03_norell(Rec, Tag) -> + is_record(Rec, Tag, 3) orelse ok. diff --git a/lib/hipe/test/basic_SUITE_data/basic_issues_hipe.erl b/lib/hipe/test/basic_SUITE_data/basic_issues_hipe.erl new file mode 100644 index 0000000000..e71045bfe2 --- /dev/null +++ b/lib/hipe/test/basic_SUITE_data/basic_issues_hipe.erl @@ -0,0 +1,153 @@ +%%% -*- erlang-indent-level: 2 -*- +%%%------------------------------------------------------------------- +%%% Author: Kostis Sagonas +%%% +%%% Contains code examples that exhibited crashes in the HiPE compiler. +%%%------------------------------------------------------------------- +-module(basic_issues_hipe). + +-export([test/0]). + +%% functions that need to be exported so that they are retained. +-export([auth/4]). + +test() -> + ok = test_dominance_trees(), + ok = test_merged_const(), + ok = test_var_pair(), + ok = test_bif_fails(), + ok = test_find_catches(), + ok = test_heap_allocate_trim(), + ok. + +%%-------------------------------------------------------------------- +%% This is taken from a file sent to us by Martin Bjorklund @ Nortel +%% on 14th November 2004. The problem was in the SSA unconvert pass. +%% +%% No tests here; we simply check that the HiPE compiler does not go +%% into an infinite loop when compiling strange functions like this. +%%-------------------------------------------------------------------- + +auth(_, A, B, C) -> + auth(A, B, C, []). + +%%-------------------------------------------------------------------- +%% Exposed a crash in the generation of dominance trees used in SSA. +%%-------------------------------------------------------------------- + +-record(state, {f}). + +test_dominance_trees() -> + {ok, true} = doit(true, #state{f = true}), + ok. + +doit(Foo, S) -> + Fee = case Foo of + Bar when Bar == S#state.f; Bar == [] -> true; + _ -> false + end, + {ok, Fee}. + +%%-------------------------------------------------------------------- +%% Checks that the merging of constants in the constant table uses the +%% appropriate comparison function for this. +%%-------------------------------------------------------------------- + +test_merged_const() -> + Const1 = {'', 1.0000}, + Const2 = {'', 1}, + match(Const1, Const2). + +match(A, A) -> + error; +match(_A, _B) -> + ok. + +%%-------------------------------------------------------------------- +%% Checks that the HiPE compiler does not get confused by constant +%% data structures similar to the internal compiler data structures. +%%-------------------------------------------------------------------- + +test_var_pair() -> + ok = var_pair([gazonk]). + +var_pair([_|_]) -> + var_pair({var, some_atom}); +var_pair(_) -> + ok. + +%%-------------------------------------------------------------------- +%% This module was causing the HiPE compiler to crash in January 2007. +%% The culprit was an "optimization" of the BEAM compiler: postponing +%% the save of x variables when BIFs cannot fail. This was fixed on +%% February 1st, by making the HiPE compiler use the same functions +%% as the BEAM compiler for deciding whether a BIF fails. +%%-------------------------------------------------------------------- + +test_bif_fails() -> + [42] = bif_fails_in_catch([42]), + true = bif_fails_in_try([42]), + ok. + +bif_fails_in_catch(X) -> + case catch get(gazonk) of + _ -> X + end. + +bif_fails_in_try(X) -> + try + true = X =/= [] + catch + _ -> nil(X) + end. + +nil(_) -> []. + +%%-------------------------------------------------------------------- +%% Test that resulted in a native code compiler crash in the code of +%% hipe_icode_exceptions:find_catches/1 when compiling find_catches/2. +%%-------------------------------------------------------------------- + +test_find_catches() -> + 42 = find_catches(a, false), + ok. + +find_catches(X, Y) -> + case X of + a when Y =:= true -> + catch id(X), + X; + b when Y =:= true -> + catch id(X), + X; + a -> + catch id(X), + 42; + b -> + catch id(X), + 42 + end. + +id(X) -> X. + +%%-------------------------------------------------------------------- +%% Date: Dec 28, 2007 +%% +%% This is a test adapted from the file sent to the Erlang mailing +%% list by Eranga Udesh. The file did not compile because of problems +%% with the heap_allocate instruction and stack trimming. +%%-------------------------------------------------------------------- + +test_heap_allocate_trim() -> + {abandon, 42} = get_next_retry(a, 42), + ok. + +get_next_retry(Error, Count) -> + case catch pair(retry_scheme, {Error, Count}) of + _ -> + case pair(Error, Count) of + _ -> {abandon, Count} + end + end. + +pair(A, B) -> {A, B}. diff --git a/lib/hipe/test/basic_SUITE_data/basic_lists.erl b/lib/hipe/test/basic_SUITE_data/basic_lists.erl new file mode 100644 index 0000000000..264a7f86f6 --- /dev/null +++ b/lib/hipe/test/basic_SUITE_data/basic_lists.erl @@ -0,0 +1,61 @@ +%%% -*- erlang-indent-level: 2 -*- +%%%------------------------------------------------------------------- +%%% Author: Kostis Sagonas +%%% +%%% Contains tests that manipulate and pattern match against lists +%%% (perhaps by calling functions from the 'lists' module). +%%%------------------------------------------------------------------- +-module(basic_lists). + +-export([test/0]). + +test() -> + ok = test_length(), + ok = test_lists_key(), + ok = test_lists_and_strings(), + ok. + +%%-------------------------------------------------------------------- + +test_length() -> + Len = 42, + Lst = mklist(Len, []), + Len = iterate(100, Lst), + ok. + +mklist(0, L) -> L; +mklist(X, L) -> mklist(X-1, [X|L]). + +iterate(0, L) -> len(L, 0); +iterate(X, L) -> len(L, 0), iterate(X-1, L). + +len([_|X], L) -> len(X, L+1); +len([], L) -> L. + +%%-------------------------------------------------------------------- + +test_lists_key() -> + First = {x, 42.0}, + Second = {y, -77}, + Third = {z, [a, b, c], {5.0}}, + List = [First, Second, Third], + {value, First} = key_search_find(42, 2, List), + ok. + +key_search_find(Key, Pos, List) -> + case lists:keyfind(Key, Pos, List) of + false -> + false = lists:keysearch(Key, Pos, List); + Tuple when is_tuple(Tuple) -> + {value, Tuple} = lists:keysearch(Key, Pos, List) + end. + +%%-------------------------------------------------------------------- + +test_lists_and_strings() -> + LL = ["H'A", " H'B", " H'C"], + LL2 = lists:map(fun string:strip/1, LL), + HexFormat = fun(X, Acc) -> {string:substr(X, 3), Acc} end, + {LL3,_Ret} = lists:mapfoldl(HexFormat, 0, LL2), + ["A", "B", "C"] = lists:sublist(LL3, 42), + ok. diff --git a/lib/hipe/test/basic_SUITE_data/basic_module_info.erl b/lib/hipe/test/basic_SUITE_data/basic_module_info.erl new file mode 100644 index 0000000000..cab48b10ba --- /dev/null +++ b/lib/hipe/test/basic_SUITE_data/basic_module_info.erl @@ -0,0 +1,32 @@ +%%% -*- erlang-indent-level: 2 -*- +%%%------------------------------------------------------------------- +%%% Author: Kostis Sagonas +%%% Date: Oct 25, 2003 +%%% +%%% Tests whether calling module_info from the same module works. +%%% This seems trivial, but the problem is that the module_info/[0,1] +%%% functions that the BEAM file contains used to be dummy functions +%%% containing crap. So, these functions could not be used for +%%% compilation to native code and the functions that the BEAM loader +%%% generates should have been used instead. This was a HiPE bug +%%% reported by Dan Wallin. +%%%------------------------------------------------------------------- +-module(basic_module_info). + +-export([test/0]). + +test() -> + L = test_local_mi0_call(), + E = test_remote_mi1_call(), + {3, 3} = {L, E}, + ok. + +test_local_mi0_call() -> + ModInfo = module_info(), + %% io:format("ok, ModInfo=~w\n", [ModInfo]), + {exports, FunList} = lists:keyfind(exports, 1, ModInfo), + length(FunList). + +test_remote_mi1_call() -> + FunList = ?MODULE:module_info(exports), + length(FunList). diff --git a/lib/hipe/test/basic_SUITE_data/basic_pattern_match.erl b/lib/hipe/test/basic_SUITE_data/basic_pattern_match.erl new file mode 100644 index 0000000000..93240354a7 --- /dev/null +++ b/lib/hipe/test/basic_SUITE_data/basic_pattern_match.erl @@ -0,0 +1,46 @@ +%%% -*- erlang-indent-level: 2 -*- +%%%------------------------------------------------------------------- +%%% Author: Kostis Sagonas +%%% +%%% Contains code examples that test pattern matching against terms of +%%% various types. +%%%------------------------------------------------------------------- +-module(basic_pattern_match). + +-export([test/0]). + +test() -> + ok = test_hello_world(), + ok = test_list_plus_plus_match(), + ok. + +%%-------------------------------------------------------------------- +%% Trivial test to test pattern matching compilation with atoms, the +%% correct handling of all sorts of alphanumeric types in Erlang, and +%% conversions between them. + +test_hello_world() -> + String = gimme(string), + String = atom_to_list(gimme(atom)), + String = binary_to_list(gimme(binary)), + true = (list_to_atom(String) =:= gimme(atom)), + true = (list_to_binary(String) =:= gimme(binary)), + ok. + +gimme(string) -> + "hello world"; +gimme(atom) -> + 'hello world'; +gimme(binary) -> + <<"hello world">>. + +%%-------------------------------------------------------------------- +%% Makes sure that pattern matching expressions involving ++ work OK. +%% The third expression caused a problem in the Erlang shell of R11B-5. +%% It worked OK in both interpreted and compiled code. + +test_list_plus_plus_match() -> + ok = (fun("X" ++ _) -> ok end)("X"), + ok = (fun([$X | _]) -> ok end)("X"), + ok = (fun([$X] ++ _) -> ok end)("X"), + ok. diff --git a/lib/hipe/test/basic_SUITE_data/basic_random.erl b/lib/hipe/test/basic_SUITE_data/basic_random.erl new file mode 100644 index 0000000000..783947bd31 --- /dev/null +++ b/lib/hipe/test/basic_SUITE_data/basic_random.erl @@ -0,0 +1,238 @@ +%%% -*- erlang-indent-level: 2 -*- +%%%------------------------------------------------------------------- +%%% Author: Kostis Sagonas +%%% +%%% A test for list handling created using the 'random' module. +%%%------------------------------------------------------------------- +-module(basic_random). + +-export([test/0]). + +%% It can be used as a benchmark by playing with the following defines +-define(N, 1000). +-define(Iter, 500). + +test() -> + ok = random(?N). + +random(N) -> + random(N, ?Iter). + +random(N, Iter) -> + random:seed(1, 2, 3), + t(ranlist(N, [], N*100), Iter). + +ranlist(0, L, _N) -> L; +ranlist(N, L, N0) -> ranlist(N-1, [random:uniform(N0)+300 | L], N0). + +t(_, 0) -> ok; +t(L, Iter) -> + %% io:format("Sort starting~n"), + sort(L), + t(L, Iter-1). + +sort([X, Y | L]) when X =< Y -> + split_1(X, Y, L, [], []); +sort([X, Y | L]) -> + split_2(X, Y, L, [], []); +sort(L) -> + L. + +%% Ascending. +split_1(X, Y, [Z | L], R, Rs) when Z >= Y -> + split_1(Y, Z, L, [X | R], Rs); +split_1(X, Y, [Z | L], R, Rs) when Z >= X -> + split_1(Z, Y, L, [X | R], Rs); +split_1(X, Y, [Z | L], [], Rs) -> + split_1(X, Y, L, [Z], Rs); +split_1(X, Y, [Z | L], R, Rs) -> + split_1_1(X, Y, L, R, Rs, Z); +split_1(X, Y, [], R, Rs) -> + rmergel([[Y, X | R] | Rs], []). + +%% One out-of-order element, S. +split_1_1(X, Y, [Z | L], R, Rs, S) when Z >= Y -> + split_1_1(Y, Z, L, [X | R], Rs, S); +split_1_1(X, Y, [Z | L], R, Rs, S) when Z >= X -> + split_1_1(Z, Y, L, [X | R], Rs, S); +split_1_1(X, Y, [Z | L], R, Rs, S) when S =< Z -> + split_1(S, Z, L, [], [[Y, X | R] | Rs]); +split_1_1(X, Y, [Z | L], R, Rs, S) -> + split_1(Z, S, L, [], [[Y, X | R] | Rs]); +split_1_1(X, Y, [], R, Rs, S) -> + rmergel([[S], [Y, X | R] | Rs], []). + +%% Descending. +split_2(X, Y, [Z | L], R, Rs) when Z =< Y -> + split_2(Y, Z, L, [X | R], Rs); +split_2(X, Y, [Z | L], R, Rs) when Z =< X -> + split_2(Z, Y, L, [X | R], Rs); +split_2(X, Y, [Z | L], [], Rs) -> + split_2(X, Y, L, [Z], Rs); +split_2(X, Y, [Z | L], R, Rs) -> + split_2_1(X, Y, L, R, Rs, Z); +split_2(X, Y, [], R, Rs) -> + mergel([[Y, X | R] | Rs], []). + +split_2_1(X, Y, [Z | L], R, Rs, S) when Z =< Y -> + split_2_1(Y, Z, L, [X | R], Rs, S); +split_2_1(X, Y, [Z | L], R, Rs, S) when Z =< X -> + split_2_1(Z, Y, L, [X | R], Rs, S); +split_2_1(X, Y, [Z | L], R, Rs, S) when S > Z -> + split_2(S, Z, L, [], [[Y, X | R] | Rs]); +split_2_1(X, Y, [Z | L], R, Rs, S) -> + split_2(Z, S, L, [], [[Y, X | R] | Rs]); +split_2_1(X, Y, [], R, Rs, S) -> + mergel([[S], [Y, X | R] | Rs], []). + +mergel([[] | L], Acc) -> + mergel(L, Acc); +mergel([A, [H2 | T2], [H3 | T3] | L], Acc) -> + mergel(L, [merge3_1(A, [], H2, T2, H3, T3) | Acc]); +mergel([A, [H | T]], Acc) -> + rmergel([merge2_1(A, H, T, []) | Acc], []); +mergel([L], []) -> + L; +mergel([L], Acc) -> + rmergel([lists:reverse(L, []) | Acc], []); +mergel([], []) -> + []; +mergel([], Acc) -> + rmergel(Acc, []); +mergel([A, [] | L], Acc) -> + mergel([A | L], Acc); +mergel([A, B, [] | L], Acc) -> + mergel([A, B | L], Acc). + +rmergel([A, [H2 | T2], [H3 | T3] | L], Acc) -> + rmergel(L, [rmerge3_1(A, [], H2, T2, H3, T3) | Acc]); +rmergel([A, [H | T]], Acc) -> + mergel([rmerge2_1(A, H, T, []) | Acc], []); +rmergel([L], Acc) -> + mergel([lists:reverse(L, []) | Acc], []); +rmergel([], Acc) -> + mergel(Acc, []). + +%% Take L1 apart. +merge3_1([H1 | T1], M, H2, T2, H3, T3) when H1 =< H2 -> + merge3_12(T1, H1, H2, T2, H3, T3, M); +merge3_1([H1 | T1], M, H2, T2, H3, T3) -> + merge3_21(T1, H1, H2, T2, H3, T3, M); +merge3_1(_nil, M, H2, T2, H3, T3) when H2 =< H3 -> + merge2_1(T2, H3, T3, [H2 | M]); +merge3_1(_nil, M, H2, T2, H3, T3) -> + merge2_1(T3, H2, T2, [H3 | M]). + +%% Take L2 apart. +merge3_2(T1, H1, M, [H2 | T2], H3, T3) when H1 =< H2 -> + merge3_12(T1, H1, H2, T2, H3, T3, M); +merge3_2(T1, H1, M, [H2 | T2], H3, T3) -> + merge3_21(T1, H1, H2, T2, H3, T3, M); +merge3_2(T1, H1, M, _nil, H3, T3) when H1 =< H3 -> + merge2_1(T1, H3, T3, [H1 | M]); +merge3_2(T1, H1, M, _nil, H3, T3) -> + merge2_1(T3, H1, T1, [H3 | M]). + +%% H1 <= H2. Inlined. +merge3_12(T1, H1, H2, T2, H3, T3, M) when H3 < H1 -> + merge3_12_3(T1, H1, H2, T2, [H3 | M], T3); +merge3_12(T1, H1, H2, T2, H3, T3, M) -> + merge3_1(T1, [H1 | M], H2, T2, H3, T3). + +%% H1 <= H2, take L3 apart. +merge3_12_3(T1, H1, H2, T2, M, [H3 | T3]) when H3 < H1 -> + merge3_12_3(T1, H1, H2, T2, [H3 | M], T3); +merge3_12_3(T1, H1, H2, T2, M, [H3 | T3]) -> + merge3_1(T1, [H1 | M], H2, T2, H3, T3); +merge3_12_3(T1, H1, H2, T2, M, _nil) -> + merge2_1(T1, H2, T2, [H1 | M]). + +%% H1 > H2. Inlined. +merge3_21(T1, H1, H2, T2, H3, T3, M) when H3 < H2 -> + merge3_21_3(T1, H1, H2, T2, [H3 | M], T3); +merge3_21(T1, H1, H2, T2, H3, T3, M) -> + merge3_2(T1, H1, [H2 | M], T2, H3, T3). + +%% H1 > H2, take L3 apart. +merge3_21_3(T1, H1, H2, T2, M, [H3 | T3]) when H3 < H2 -> + merge3_21_3(T1, H1, H2, T2, [H3 | M], T3); +merge3_21_3(T1, H1, H2, T2, M, [H3 | T3]) -> + merge3_2(T1, H1, [H2 | M], T2, H3, T3); +merge3_21_3(T1, H1, H2, T2, M, _nil) -> + merge2_1(T2, H1, T1, [H2 | M]). + +%% Take L1 apart. +rmerge3_1([H1 | T1], M, H2, T2, H3, T3) when H1 > H2 -> + rmerge3_12(T1, H1, H2, T2, H3, T3, M); +rmerge3_1([H1 | T1], M, H2, T2, H3, T3) -> + rmerge3_21(T1, H1, H2, T2, H3, T3, M); +rmerge3_1(_nil, M, H2, T2, H3, T3) when H2 > H3 -> + rmerge2_1(T2, H3, T3, [H2 | M]); +rmerge3_1(_nil, M, H2, T2, H3, T3) -> + rmerge2_1(T3, H2, T2, [H3 | M]). + +%% Take L2 apart. +rmerge3_2(T1, H1, M, [H2 | T2], H3, T3) when H1 > H2 -> + rmerge3_12(T1, H1, H2, T2, H3, T3, M); +rmerge3_2(T1, H1, M, [H2 | T2], H3, T3) -> + rmerge3_21(T1, H1, H2, T2, H3, T3, M); +rmerge3_2(T1, H1, M, _nil, H3, T3) when H1 > H3 -> + rmerge2_1(T1, H3, T3, [H1 | M]); +rmerge3_2(T1, H1, M, _nil, H3, T3) -> + rmerge2_1(T3, H1, T1, [H3 | M]). + +%% H1 > H2. Inlined. +rmerge3_12(T1, H1, H2, T2, H3, T3, M) when H3 >= H1 -> + rmerge3_12_3(T1, H1, H2, T2, [H3 | M], T3); +rmerge3_12(T1, H1, H2, T2, H3, T3, M) -> + rmerge3_1(T1, [H1 | M], H2, T2, H3, T3). + +%% H1 > H2, take L3 apart. +rmerge3_12_3(T1, H1, H2, T2, M, [H3 | T3]) when H3 >= H1 -> + rmerge3_12_3(T1, H1, H2, T2, [H3 | M], T3); +rmerge3_12_3(T1, H1, H2, T2, M, [H3 | T3]) -> + rmerge3_1(T1, [H1 | M], H2, T2, H3, T3); +rmerge3_12_3(T1, H1, H2, T2, M, _nil) -> + rmerge2_1(T1, H2, T2, [H1 | M]). + +%% H1 =< H2. Inlined. +rmerge3_21(T1, H1, H2, T2, H3, T3, M) when H3 >= H2 -> + rmerge3_21_3(T1, H1, H2, T2, [H3 | M], T3); +rmerge3_21(T1, H1, H2, T2, H3, T3, M) -> + rmerge3_2(T1, H1, [H2 | M], T2, H3, T3). + +%% H1 =< H2, take L3 apart. +rmerge3_21_3(T1, H1, H2, T2, M, [H3 | T3]) when H3 >= H2 -> + rmerge3_21_3(T1, H1, H2, T2, [H3 | M], T3); +rmerge3_21_3(T1, H1, H2, T2, M, [H3 | T3]) -> + rmerge3_2(T1, H1, [H2 | M], T2, H3, T3); +rmerge3_21_3(T1, H1, H2, T2, M, _nil) -> + rmerge2_1(T2, H1, T1, [H2 | M]). + +merge2_1([H1 | T1], H2, T2, M) when H2 < H1 -> + merge2_2(T1, H1, T2, [H2 | M]); +merge2_1([H1 | T1], H2, T2, M) -> + merge2_1(T1, H2, T2, [H1 | M]); +merge2_1(_nil, H2, T2, M) -> + lists:reverse(T2, [H2 | M]). + +merge2_2(T1, H1, [H2 | T2], M) when H1 < H2 -> + merge2_1(T1, H2, T2, [H1 | M]); +merge2_2(T1, H1, [H2 | T2], M) -> + merge2_2(T1, H1, T2, [H2 | M]); +merge2_2(T1, H1, _nil, M) -> + lists:reverse(T1, [H1 | M]). + +rmerge2_1([H1 | T1], H2, T2, M) when H2 >= H1 -> + rmerge2_2(T1, H1, T2, [H2 | M]); +rmerge2_1([H1 | T1], H2, T2, M) -> + rmerge2_1(T1, H2, T2, [H1 | M]); +rmerge2_1(_nil, H2, T2, M) -> + lists:reverse(T2, [H2 | M]). + +rmerge2_2(T1, H1, [H2 | T2], M) when H1 >= H2 -> + rmerge2_1(T1, H2, T2, [H1 | M]); +rmerge2_2(T1, H1, [H2 | T2], M) -> + rmerge2_2(T1, H1, T2, [H2 | M]); +rmerge2_2(T1, H1, _nil, M) -> + lists:reverse(T1, [H1 | M]). diff --git a/lib/hipe/test/basic_SUITE_data/basic_receive.erl b/lib/hipe/test/basic_SUITE_data/basic_receive.erl new file mode 100644 index 0000000000..5f865d7b7a --- /dev/null +++ b/lib/hipe/test/basic_SUITE_data/basic_receive.erl @@ -0,0 +1,56 @@ +%%% -*- erlang-indent-level: 2 -*- +%%%------------------------------------------------------------------- +%%% Author: Kostis Sagonas +%%% +%%% Contains code examples that test correct handling of receives. +%%%------------------------------------------------------------------- +-module(basic_receive). + +-export([test/0]). + +test() -> + ok = test_wait_timeout(), + ok = test_double_timeout(), + ok = test_reschedule(), + ok. + +%%-------------------------------------------------------------------- + +test_wait_timeout() -> + receive after 42 -> ok end. + +%%-------------------------------------------------------------------- + +test_double_timeout() -> + self() ! foo, + self() ! another_foo, + receive + non_existent -> weird + after 0 -> timeout + end, + receive + foo -> ok + after 1000 -> timeout + end. + +%%-------------------------------------------------------------------- +%% Check that RESCHEDULE returns from BIFs work. + +test_reschedule() -> + erts_debug:set_internal_state(available_internal_state, true), + First = self(), + Second = spawn(fun() -> doit(First) end), + receive + Second -> ok + end, + receive + after 42 -> ok + end, + erts_debug:set_internal_state(hipe_test_reschedule_resume, Second), + ok. + +doit(First) -> + First ! self(), + erts_debug:set_internal_state(hipe_test_reschedule_suspend, 1). + +%%-------------------------------------------------------------------- diff --git a/lib/hipe/test/basic_SUITE_data/basic_records.erl b/lib/hipe/test/basic_SUITE_data/basic_records.erl new file mode 100644 index 0000000000..cbb451196c --- /dev/null +++ b/lib/hipe/test/basic_SUITE_data/basic_records.erl @@ -0,0 +1,28 @@ +%% -*- erlang-indent-level: 2 -*- +%%%------------------------------------------------------------------- +%%% Author: Kostis Sagonas +%%% +%%% Contains tests that manipulate and pattern match against records. +%%%------------------------------------------------------------------- +-module(basic_records). + +-export([test/0]). + +test() -> + ok = test_rec1(), + ok. + +%%-------------------------------------------------------------------- + +-record(r, {ra}). +-record(s, {sa, sb, sc, sd}). + +test_rec1() -> + R = #r{}, + S = #s{}, + S1 = S#s{sc=R, sd=1}, + R1 = S1#s.sc, + undefined = R1#r.ra, + ok. + +%%-------------------------------------------------------------------- diff --git a/lib/hipe/test/basic_SUITE_data/basic_strength_reduce.erl b/lib/hipe/test/basic_SUITE_data/basic_strength_reduce.erl new file mode 100644 index 0000000000..0f94320a33 --- /dev/null +++ b/lib/hipe/test/basic_SUITE_data/basic_strength_reduce.erl @@ -0,0 +1,65 @@ +%%% -*- erlang-indent-level: 2 -*- +%%%------------------------------------------------------------------- +%%% Author: Kostis Sagonas +%%% +%%% Tests the strength reduction component of the HiPE compiler. +%%%------------------------------------------------------------------- +-module(basic_strength_reduce). + +-export([test/0]). +%% These functions are exported so as to not remove them by inlining +-export([crash_0/1, crash_1/1, crash_2/1, crash_3/1, bug_div_2N/1]). + +test() -> + ok = test_strength_reduce1(), + ok. + +%%-------------------------------------------------------------------- + +test_strength_reduce1() -> + ok = crash_0(0), + ok = crash_1(42), + ok = crash_2(42), + ok = crash_3(42), + 5 = 42 bsr 3 = bug_div_2N(42), + -6 = -42 bsr 3 = bug_div_2N(-42) - 1, + ok. + +%% This is a crash report by Peter Wang (10 July 2007) triggering an +%% R11B-5 crash: strength reduction could not handle calls with no +%% destination +crash_0(A) -> + case A of + 0 -> + A div 8, + ok + end. + +%% The above was simplified to the following which showed another +%% crash, this time on RTL +crash_1(A) when is_integer(A), A >= 0 -> + A div 8, + ok. + +%% A similar crash like the first one, but in a different place in the +%% code, was triggered by the following code +crash_2(A) when is_integer(A), A >= 0 -> + A div 1, + ok. + +%% A crash similar to the first one happened in the following code +crash_3(A) -> + case A of + 42 -> + A * 0, + ok + end. + +%% Strength reduction for div/2 and rem/2 with a power of 2 +%% should be performed only for non-negative integers +bug_div_2N(X) when is_integer(X), X >= 0 -> + X div 8; +bug_div_2N(X) when is_integer(X), X < 0 -> + X div 8. + +%%-------------------------------------------------------------------- diff --git a/lib/hipe/test/basic_SUITE_data/basic_switches.erl b/lib/hipe/test/basic_SUITE_data/basic_switches.erl new file mode 100644 index 0000000000..0a7ae5b8b7 --- /dev/null +++ b/lib/hipe/test/basic_SUITE_data/basic_switches.erl @@ -0,0 +1,52 @@ +%%% -*- erlang-indent-level: 2 -*- +%%%------------------------------------------------------------------- +%%% Author: Kostis Sagonas +%%% +%%% Contains tests for pattern matching switches. +%%%------------------------------------------------------------------- +-module(basic_switches). + +-export([test/0]). + +test() -> + ok = test_switch_mix(), + ok. + +%%--------------------------------------------------------------------- + +-define(BIG1, 21323233222132323322). +-define(BIG2, 4242424242424242424242424242424242). + +test_switch_mix() -> + small1 = t(42), + small2 = t(17), + big1 = t(?BIG1), + big2 = t(?BIG2), + atom = t(foo), + pid = t(self()), + float = t(4.2), + ok. + +t(V) -> + S = self(), + case V of + 42 -> small1; + 17 -> small2; + ?BIG1 -> big1; + ?BIG2 -> big2; + 1 -> no; + 2 -> no; + 3 -> no; + 4 -> no; + 5 -> no; + 6 -> no; + 7 -> no; + 8 -> no; + foo -> atom; + 9 -> no; + 4.2 -> float; + S -> pid; + _ -> no + end. + +%%--------------------------------------------------------------------- diff --git a/lib/hipe/test/basic_SUITE_data/basic_tail_rec.erl b/lib/hipe/test/basic_SUITE_data/basic_tail_rec.erl new file mode 100644 index 0000000000..0124f13df6 --- /dev/null +++ b/lib/hipe/test/basic_SUITE_data/basic_tail_rec.erl @@ -0,0 +1,39 @@ +%%% -*- erlang-indent-level: 2 -*- +%%%------------------------------------------------------------------- +%%% Author: Kostis Sagonas +%%% +%%% Contains tests that check that tail recursion optimization occurs. +%%%------------------------------------------------------------------- +-module(basic_tail_rec). + +-export([test/0]). +-export([app0/2]). %% used in an apply/3 call + +test() -> + ok = test_app_tail(), + ok. + +%%-------------------------------------------------------------------- +%% Written by Mikael Pettersson: check that apply is tail recursive. + +%% Increased the following quantity from 20 to 30 so that the test +%% remains valid even with the naive register allocator. - Kostis +-define(SIZE_INCREASE, 30). + +test_app_tail() -> + Inc = start(400), + %% io:format("Inc ~w\n", [Inc]), + case Inc > ?SIZE_INCREASE of + true -> + {error, "apply/3 is not tail recursive in native code"}; + false -> + ok + end. + +start(N) -> + app0(N, hipe_bifs:nstack_used_size()). + +app0(0, Size0) -> + hipe_bifs:nstack_used_size() - Size0; +app0(N, Size) -> + apply(?MODULE, app0, [N-1, Size]). diff --git a/lib/hipe/test/basic_SUITE_data/basic_tuples.erl b/lib/hipe/test/basic_SUITE_data/basic_tuples.erl new file mode 100644 index 0000000000..94c187e364 --- /dev/null +++ b/lib/hipe/test/basic_SUITE_data/basic_tuples.erl @@ -0,0 +1,177 @@ +%%% -*- erlang-indent-level: 2 -*- +%%%------------------------------------------------------------------- +%%% Author: Kostis Sagonas +%%% +%%% Contains tests that manipulate and pattern match against tuples. +%%%------------------------------------------------------------------- +-module(basic_tuples). + +-export([test/0]). + +test() -> + Num = 4711, + ok = test_match({}, {1}, {1,2}, {1,2,3}, {1,2,3,4}, {1,2,3,4,5}, + {1,2,3,4,5,6}, {1,2,3,4,5,6,7}, {1,2,3,4,5,6,7,8}), + ok = test_size({}, {a}, {{a},{b}}, {a,{b},c}), + ok = test_element({}, {a}, {a,b}, Num), + ok = test_setelement({}, {1}, {1,2}, 3, [1,2]), + ok = test_tuple_to_list({}, {a}, {a,b}, {a,b,c}, {a,b,c,d}, Num), + ok = test_list_to_tuple([], [a], [a,b], [a,b,c], [a,b,c,d], Num), + ok = test_tuple_with_case(), + ok = test_tuple_in_guard({a, b}, {a, b, c}), + ok. + +%%-------------------------------------------------------------------- +%% Tests matching of tuples + +test_match(T0, T1, T2, T3, T4, T5, T6, T7, T8) -> + {} = T0, + {1} = T1, + {1, 2} = T2, + {1, 2, 3} = T3, + {1, 2, 3, 4} = T4, + {1, 2, 3, 4, 5} = T5, + {1, 2, 3, 4, 5, 6} = T6, + T6 = {1, 2, 3, 4, 5, 6}, + T7 = {1, 2, 3, 4, 5, 6, 7}, + {1, 2, 3, 4, 5, 6, 7, 8} = T8, + ok. + +%%-------------------------------------------------------------------- +%% Tests the size/1 and tuple_size/1 BIFs. + +test_size(T0, T1, T2, T3) -> + [0, 1, 2, 3] = [size(T) || T <- [T0, T1, T2, T3]], + [0, 1, 2, 3] = [tuple_size(T) || T <- [T0, T1, T2, T3]], + ok. + +%%-------------------------------------------------------------------- +%% Tests element/2. + +test_element(T0, T1, T2, N) -> + a = element(1, T1), + a = element(1, T2), + %% indirect calls to element/2 + List = lists:seq(1, N), + Tuple = list_to_tuple(List), + ok = get_elements(List, Tuple, 1), + %% some cases that throw exceptions + {'EXIT', _} = (catch my_element(0, T2)), + {'EXIT', _} = (catch my_element(3, T2)), + {'EXIT', _} = (catch my_element(1, T0)), + {'EXIT', _} = (catch my_element(1, List)), + {'EXIT', _} = (catch my_element(1, N)), + {'EXIT', _} = (catch my_element(1.5, T2)), + ok. + +my_element(Pos, Term) -> + element(Pos, Term). + +get_elements([Element|Rest], Tuple, Pos) -> + Element = element(Pos, Tuple), + get_elements(Rest, Tuple, Pos + 1); +get_elements([], _Tuple, _Pos) -> + ok. + +%%-------------------------------------------------------------------- +%% Tests set_element/3. + +test_setelement(T0, T1, Pair, Three, L) -> + {x} = setelement(1, T1, x), + {x, 2} = setelement(1, Pair, x), + {1, x} = setelement(2, Pair, x), + %% indirect calls to setelement/3 + Tuple = list_to_tuple(lists:duplicate(2048, x)), + NewTuple = set_all_elements(Tuple, 1), + NewTuple = list_to_tuple(lists:seq(1+7, 2048+7)), + %% the following cases were rewritten to use the Three + %% variable in this weird way so as to silence the compiler + {'EXIT', _} = (catch setelement(Three - Three, Pair, x)), + {'EXIT', _} = (catch setelement(Three, Pair, x)), + {'EXIT', _} = (catch setelement(Three div Three, T0, x)), + {'EXIT', _} = (catch setelement(Three div Three, L, x)), + {'EXIT', _} = (catch setelement(Three / 2, Pair, x)), + ok. + +set_all_elements(Tuple, Pos) when Pos =< tuple_size(Tuple) -> + set_all_elements(setelement(Pos, Tuple, Pos+7), Pos+1); +set_all_elements(Tuple, Pos) when Pos > tuple_size(Tuple) -> + Tuple. + +%%-------------------------------------------------------------------- +%% Tests tuple_to_list/1. + +test_tuple_to_list(T0, T1, T2, T3, T4, Size) -> + [] = tuple_to_list(T0), + [a] = tuple_to_list(T1), + [a, b] = tuple_to_list(T2), + [a, b, c] = tuple_to_list(T3), + [a, b, c, d] = tuple_to_list(T4), + [a, b, c, d] = tuple_to_list(T4), + %% test a big tuple + List = lists:seq(1, Size), + Tuple = list_to_tuple(List), + Size = tuple_size(Tuple), + List = tuple_to_list(Tuple), + %% some cases that should result in errors + {'EXIT', _} = (catch my_tuple_to_list(element(2, T3))), + {'EXIT', _} = (catch my_tuple_to_list(Size)), + ok. + +my_tuple_to_list(X) -> + tuple_to_list(X). + +%%-------------------------------------------------------------------- +%% Tests list_to_tuple/1. + +test_list_to_tuple(L0, L1, L2, L3, L4, Size) -> + {} = list_to_tuple(L0), + {a} = list_to_tuple(L1), + {a, b} = list_to_tuple(L2), + {a, b, c} = list_to_tuple(L3), + {a, b, c, d} = list_to_tuple(L4), + {a, b, c, d, e} = list_to_tuple(L4++[e]), + %% test list_to_tuple with a big list + Tuple = list_to_tuple(lists:seq(1, Size)), + Size = tuple_size(Tuple), + %% some cases that should result in errors + {'EXIT', _} = (catch my_list_to_tuple({a,b})), + {'EXIT', _} = (catch my_list_to_tuple([hd(L1)|hd(L2)])), + ok. + +my_list_to_tuple(X) -> + list_to_tuple(X). + +%%-------------------------------------------------------------------- +%% Tests that a case nested inside a tuple is ok. +%% (This was known to crash earlier versions of BEAM.) + +test_tuple_with_case() -> + {reply, true} = tuple_with_case(), + ok. + +tuple_with_case() -> + %% The following comments apply to the BEAM compiler. + void(), % Reset var count. + {reply, % Compiler will choose {x,1} for tuple. + case void() of % Call will reset var count. + {'EXIT', Reason} -> % Case will return in {x,1} (first free), + {error, Reason}; % but the tuple will be build in {x,1}, + _ -> % so case value is lost and a circular + true % data element is built. + end}. + +void() -> ok. + +%%-------------------------------------------------------------------- +%% Test to build a tuple in a guard. + +test_tuple_in_guard(T2, T3) -> + %% T2 = {a, b}; T3 = {a, b, c} + ok = if T2 == {element(1, T3), element(2, T3)} -> ok; + true -> other + end, + ok = if T3 == {element(1, T3), element(2, T3), element(3, T3)} -> ok; + true -> other + end, + ok. diff --git a/lib/hipe/test/bs_SUITE_data/bs_split.erl b/lib/hipe/test/bs_SUITE_data/bs_split.erl index 2e52308a77..617543f789 100644 --- a/lib/hipe/test/bs_SUITE_data/bs_split.erl +++ b/lib/hipe/test/bs_SUITE_data/bs_split.erl @@ -26,13 +26,13 @@ bs1(L, B, Pos, Sz1, Sz2) -> <<B1:Sz1/binary, B2:Sz2/binary>> = B, bs2(L, B, Pos, B1, B2). -bs2(L, B, Pos, B1, B2)-> +bs2(L, B, Pos, B1, B2) -> B1 = list_to_binary(lists:sublist(L, 1, Pos)), bs3(L, B, Pos, B2). bs3(L, B, Pos, B2) -> B2 = list_to_binary(lists:nthtail(Pos, L)), - byte_split(L, B, Pos-1). + byte_split(L, B, Pos - 1). %%-------------------------------------------------------------------- @@ -56,14 +56,14 @@ bit_split_binary2(_Action, _Bin, [], _Bef) -> ok. bit_split_binary3(Action, Bin, List, Bef, Aft) when Bef =< Aft -> Action(Bin, List, Bef, (Aft-Bef) div 8 * 8), - bit_split_binary3(Action, Bin, List, Bef, Aft-8); + bit_split_binary3(Action, Bin, List, Bef, Aft - 8); bit_split_binary3(_, _, _, _, _) -> ok. make_bin_from_list(_List, 0) -> mkbin([]); make_bin_from_list(List, N) -> list_to_binary([make_int(List, 8, 0), - make_bin_from_list(lists:nthtail(8, List), N-8)]). + make_bin_from_list(lists:nthtail(8, List), N - 8)]). make_int(_List, 0, Acc) -> Acc; make_int([H|T], N, Acc) -> make_int(T, N-1, Acc bsl 1 bor H). @@ -101,5 +101,5 @@ z_split(B, N) -> <<_:N/binary>> -> [B]; _ -> - z_split(B, N+1) + z_split(B, N + 1) end. diff --git a/lib/hipe/test/bs_SUITE_data/bs_utf.erl b/lib/hipe/test/bs_SUITE_data/bs_utf.erl index f50ae08964..24526f574d 100644 --- a/lib/hipe/test/bs_SUITE_data/bs_utf.erl +++ b/lib/hipe/test/bs_SUITE_data/bs_utf.erl @@ -1,18 +1,356 @@ %% -*- erlang-indent-level: 2 -*- %%------------------------------------------------------------------- -%% Purpose: test support for UTF datatypes in binaries - INCOMPLETE +%% Purpose: test support for UTF datatypes in binaries +%% +%% Most of it taken from emulator/test/bs_utf_SUITE.erl %%------------------------------------------------------------------- -module(bs_utf). -export([test/0]). +-include_lib("test_server/include/test_server.hrl"). + test() -> + ok = utf8_cm65(), + ok = utf8_roundtrip(), + ok = utf16_roundtrip(), + ok = utf32_roundtrip(), + %% The following were problematic for the LLVM backend + ok = utf8_illegal_sequences(), + ok = utf16_illegal_sequences(), + ok = utf32_illegal_sequences(), + ok. + +%%------------------------------------------------------------------- +%% A test with construction and matching + +utf8_cm65() -> <<65>> = b65utf8(), ok = m(<<65>>). +b65utf8() -> + <<65/utf8>>. + m(<<65/utf8>>) -> ok. -b65utf8() -> - <<65/utf8>>. +%%------------------------------------------------------------------- + +utf8_roundtrip() -> + ok = utf8_roundtrip(0, 16#D7FF), + ok = utf8_roundtrip(16#E000, 16#10FFFF), + ok. + +utf8_roundtrip(First, Last) when First =< Last -> + Bin = int_to_utf8(First), + Bin = id(<<First/utf8>>), + Bin = id(<<(id(<<>>))/binary,First/utf8>>), + Unaligned = id(<<3:2,First/utf8>>), + <<_:2,Bin/binary>> = Unaligned, + <<First/utf8>> = Bin, + <<First/utf8>> = make_unaligned(Bin), + utf8_roundtrip(First+1, Last); +utf8_roundtrip(_, _) -> + ok. + +%%------------------------------------------------------------------- + +utf16_roundtrip() -> + Big = fun utf16_big_roundtrip/1, + Little = fun utf16_little_roundtrip/1, + PidRefs = [spawn_monitor(fun() -> do_utf16_roundtrip(Fun) end) || + Fun <- [Big,Little]], + [receive {'DOWN', Ref, process, Pid, Reason} -> normal=Reason end || + {Pid, Ref} <- PidRefs], + ok. + +do_utf16_roundtrip(Fun) -> + do_utf16_roundtrip(0, 16#D7FF, Fun), + do_utf16_roundtrip(16#E000, 16#10FFFF, Fun). + +do_utf16_roundtrip(First, Last, Fun) when First =< Last -> + Fun(First), + do_utf16_roundtrip(First+1, Last, Fun); +do_utf16_roundtrip(_, _, _) -> ok. + +utf16_big_roundtrip(Char) -> + Bin = id(<<Char/utf16>>), + Bin = id(<<(id(<<>>))/binary,Char/utf16>>), + Unaligned = id(<<3:2,Char/utf16>>), + <<_:2,Bin/binary>> = Unaligned, + <<Char/utf16>> = Bin, + <<Char/utf16>> = make_unaligned(Bin), + ok. + +utf16_little_roundtrip(Char) -> + Bin = id(<<Char/little-utf16>>), + Bin = id(<<(id(<<>>))/binary,Char/little-utf16>>), + Unaligned = id(<<3:2,Char/little-utf16>>), + <<_:2,Bin/binary>> = Unaligned, + <<Char/little-utf16>> = Bin, + <<Char/little-utf16>> = make_unaligned(Bin), + ok. + +%%------------------------------------------------------------------- + +utf32_roundtrip() -> + Big = fun utf32_big_roundtrip/1, + Little = fun utf32_little_roundtrip/1, + PidRefs = [spawn_monitor(fun() -> do_utf32_roundtrip(Fun) end) || + Fun <- [Big,Little]], + [receive {'DOWN', Ref, process, Pid, Reason} -> normal=Reason end || + {Pid, Ref} <- PidRefs], + ok. + +do_utf32_roundtrip(Fun) -> + do_utf32_roundtrip(0, 16#D7FF, Fun), + do_utf32_roundtrip(16#E000, 16#10FFFF, Fun). + +do_utf32_roundtrip(First, Last, Fun) when First =< Last -> + Fun(First), + do_utf32_roundtrip(First+1, Last, Fun); +do_utf32_roundtrip(_, _, _) -> ok. + +utf32_big_roundtrip(Char) -> + Bin = id(<<Char/utf32>>), + Bin = id(<<(id(<<>>))/binary,Char/utf32>>), + Unaligned = id(<<3:2,Char/utf32>>), + <<_:2,Bin/binary>> = Unaligned, + <<Char/utf32>> = Bin, + <<Char/utf32>> = make_unaligned(Bin), + ok. + +utf32_little_roundtrip(Char) -> + Bin = id(<<Char/little-utf32>>), + Bin = id(<<(id(<<>>))/binary,Char/little-utf32>>), + Unaligned = id(<<3:2,Char/little-utf32>>), + <<_:2,Bin/binary>> = Unaligned, + <<Char/little-utf32>> = Bin, + <<Char/little-utf32>> = make_unaligned(Bin), + ok. + +%%------------------------------------------------------------------- + +utf8_illegal_sequences() -> + fail_range(16#10FFFF+1, 16#10FFFF+512), % Too large. + fail_range(16#D800, 16#DFFF), % Reserved for UTF-16. + + %% Illegal first character. + [fail(<<I,16#8F,16#8F,16#8F>>) || I <- lists:seq(16#80, 16#BF)], + + %% Short sequences. + short_sequences(16#80, 16#10FFFF), + + %% Overlong sequences. (Using more bytes than necessary + %% is not allowed.) + overlong(0, 127, 2), + overlong(128, 16#7FF, 3), + overlong(16#800, 16#FFFF, 4), + ok. + +fail_range(Char, End) when Char =< End -> + {'EXIT', _} = (catch <<Char/utf8>>), + Bin = int_to_utf8(Char), + fail(Bin), + fail_range(Char+1, End); +fail_range(_, _) -> ok. + +short_sequences(Char, End) -> + Step = (End - Char) div erlang:system_info(schedulers) + 1, + PidRefs = short_sequences_1(Char, Step, End), + [receive {'DOWN', Ref, process, Pid, Reason} -> normal=Reason end || + {Pid, Ref} <- PidRefs], + ok. + +short_sequences_1(Char, Step, End) when Char =< End -> + CharEnd = lists:min([Char+Step-1,End]), + [spawn_monitor(fun() -> + %% io:format("~p - ~p\n", [Char, CharEnd]), + do_short_sequences(Char, CharEnd) + end)|short_sequences_1(Char+Step, Step, End)]; +short_sequences_1(_, _, _) -> []. + +do_short_sequences(Char, End) when Char =< End -> + short_sequence(Char), + do_short_sequences(Char+1, End); +do_short_sequences(_, _) -> ok. + +short_sequence(I) -> + case int_to_utf8(I) of + <<S0:3/binary,_:8>> -> + <<S1:2/binary,R1:8>> = S0, + <<S2:1/binary,_:8>> = S1, + fail(S0), + fail(S1), + fail(S2), + fail(<<S2/binary,16#7F,R1,R1>>), + fail(<<S1/binary,16#7F,R1>>), + fail(<<S0/binary,16#7F>>); + <<S0:2/binary,_:8>> -> + <<S1:1/binary,R1:8>> = S0, + fail(S0), + fail(S1), + fail(<<S0/binary,16#7F>>), + fail(<<S1/binary,16#7F>>), + fail(<<S1/binary,16#7F,R1>>); + <<S:1/binary,_:8>> -> + fail(S), + fail(<<S/binary,16#7F>>) + end. + +overlong(Char, Last, NumBytes) when Char =< Last -> + overlong(Char, NumBytes), + overlong(Char+1, Last, NumBytes); +overlong(_, _, _) -> ok. + +overlong(Char, NumBytes) when NumBytes < 5 -> + case int_to_utf8(Char, NumBytes) of + <<Char/utf8>>=Bin -> + ?t:fail({illegal_encoding_accepted,Bin,Char}); + <<OtherChar/utf8>>=Bin -> + ?t:fail({illegal_encoding_accepted,Bin,Char,OtherChar}); + _ -> ok + end, + overlong(Char, NumBytes+1); +overlong(_, _) -> ok. + +fail(Bin) -> + fail_1(Bin), + fail_1(make_unaligned(Bin)). + +fail_1(<<Char/utf8>> = Bin) -> + ?t:fail({illegal_encoding_accepted, Bin, Char}); +fail_1(_) -> ok. + +%%------------------------------------------------------------------- + +utf16_illegal_sequences() -> + utf16_fail_range(16#10FFFF+1, 16#10FFFF+512), % Too large. + utf16_fail_range(16#D800, 16#DFFF), % Reserved for UTF-16. + lonely_hi_surrogate(16#D800, 16#DFFF), + leading_lo_surrogate(16#DC00, 16#DFFF), + ok. + +utf16_fail_range(Char, End) when Char =< End -> + {'EXIT', _} = (catch <<Char/big-utf16>>), + {'EXIT', _} = (catch <<Char/little-utf16>>), + utf16_fail_range(Char+1, End); +utf16_fail_range(_, _) -> ok. + +lonely_hi_surrogate(Char, End) when Char =< End -> + BinBig = <<Char:16/big>>, + BinLittle = <<Char:16/little>>, + case {BinBig,BinLittle} of + {<<Bad/big-utf16>>,_} -> + ?t:fail({lonely_hi_surrogate_accepted,Bad}); + {_,<<Bad/little-utf16>>} -> + ?t:fail({lonely_hi_surrogate_accepted,Bad}); + {_,_} -> + ok + end, + lonely_hi_surrogate(Char+1, End); +lonely_hi_surrogate(_, _) -> ok. + +leading_lo_surrogate(Char, End) when Char =< End -> + leading_lo_surrogate(Char, 16#D800, 16#DFFF), + leading_lo_surrogate(Char+1, End); +leading_lo_surrogate(_, _) -> ok. + +leading_lo_surrogate(HiSurr, LoSurr, End) when LoSurr =< End -> + BinBig = <<HiSurr:16/big,LoSurr:16/big>>, + BinLittle = <<HiSurr:16/little,LoSurr:16/little>>, + case {BinBig,BinLittle} of + {<<Bad/big-utf16,_/bits>>,_} -> + ?t:fail({leading_lo_surrogate_accepted,Bad}); + {_,<<Bad/little-utf16,_/bits>>} -> + ?t:fail({leading_lo_surrogate_accepted,Bad}); + {_,_} -> + ok + end, + leading_lo_surrogate(HiSurr, LoSurr+1, End); +leading_lo_surrogate(_, _, _) -> ok. + +%%------------------------------------------------------------------- + +utf32_illegal_sequences() -> + utf32_fail_range(16#10FFFF+1, 16#10FFFF+512), % Too large. + utf32_fail_range(16#D800, 16#DFFF), % Reserved for UTF-16. + utf32_fail_range(-100, -1), + ok. + +utf32_fail_range(Char, End) when Char =< End -> + {'EXIT', _} = (catch <<Char/big-utf32>>), + {'EXIT', _} = (catch <<Char/little-utf32>>), + case {<<Char:32>>,<<Char:32/little>>} of + {<<Unexpected/utf32>>,_} -> + ?t:fail(Unexpected); + {_,<<Unexpected/little-utf32>>} -> + ?t:fail(Unexpected); + {_,_} -> ok + end, + utf32_fail_range(Char+1, End); +utf32_fail_range(_, _) -> ok. + +%%------------------------------------------------------------------- +%% This function intentionally allows construction of UTF-8 sequence +%% in illegal ranges. + +int_to_utf8(I) when I =< 16#7F -> + <<I>>; +int_to_utf8(I) when I =< 16#7FF -> + B2 = I, + B1 = (I bsr 6), + <<1:1,1:1,0:1,B1:5,1:1,0:1,B2:6>>; +int_to_utf8(I) when I =< 16#FFFF -> + B3 = I, + B2 = (I bsr 6), + B1 = (I bsr 12), + <<1:1,1:1,1:1,0:1,B1:4,1:1,0:1,B2:6,1:1,0:1,B3:6>>; +int_to_utf8(I) when I =< 16#3FFFFF -> + B4 = I, + B3 = (I bsr 6), + B2 = (I bsr 12), + B1 = (I bsr 18), + <<1:1,1:1,1:1,1:1,0:1,B1:3,1:1,0:1,B2:6,1:1,0:1,B3:6,1:1,0:1,B4:6>>; +int_to_utf8(I) when I =< 16#3FFFFFF -> + B5 = I, + B4 = (I bsr 6), + B3 = (I bsr 12), + B2 = (I bsr 18), + B1 = (I bsr 24), + <<1:1,1:1,1:1,1:1,1:1,0:1,B1:2,1:1,0:1,B2:6,1:1,0:1,B3:6,1:1,0:1,B4:6, + 1:1,0:1,B5:6>>. + +%% int_to_utf8(I, NumberOfBytes) -> Binary. +%% This function can be used to construct overlong sequences. +int_to_utf8(I, 1) -> + <<I>>; +int_to_utf8(I, 2) -> + B2 = I, + B1 = (I bsr 6), + <<1:1,1:1,0:1,B1:5,1:1,0:1,B2:6>>; +int_to_utf8(I, 3) -> + B3 = I, + B2 = (I bsr 6), + B1 = (I bsr 12), + <<1:1,1:1,1:1,0:1,B1:4,1:1,0:1,B2:6,1:1,0:1,B3:6>>; +int_to_utf8(I, 4) -> + B4 = I, + B3 = (I bsr 6), + B2 = (I bsr 12), + B1 = (I bsr 18), + <<1:1,1:1,1:1,1:1,0:1,B1:3,1:1,0:1,B2:6,1:1,0:1,B3:6,1:1,0:1,B4:6>>. + +%%------------------------------------------------------------------- + +make_unaligned(Bin0) when is_binary(Bin0) -> + Bin1 = <<0:3,Bin0/binary,31:5>>, + Sz = byte_size(Bin0), + <<0:3,Bin:Sz/binary,31:5>> = id(Bin1), + Bin. + +%%------------------------------------------------------------------- +%% Just to prevent compiler optimizations + +id(X) -> X. diff --git a/lib/hipe/test/hipe_testsuite_driver.erl b/lib/hipe/test/hipe_testsuite_driver.erl index 5f05a716bc..9f5d7421b4 100644 --- a/lib/hipe/test/hipe_testsuite_driver.erl +++ b/lib/hipe/test/hipe_testsuite_driver.erl @@ -176,7 +176,8 @@ run(TestCase, Dir, _OutDir) -> HiPEOpts = try TestCase:hipe_options() catch error:undef -> [] end, {ok, TestCase} = hipe:c(TestCase, HiPEOpts), ok = TestCase:test(), - case is_llvm_opt_available() of + ToLLVM = try TestCase:to_llvm() catch error:undef -> true end, + case ToLLVM andalso hipe:llvm_support_available() of true -> {ok, TestCase} = hipe:c(TestCase, [to_llvm|HiPEOpts]), ok = TestCase:test(); @@ -186,16 +187,3 @@ run(TestCase, Dir, _OutDir) -> %% lists:foreach(fun (DF) -> ok end, % = file:delete(DF) end, %% [filename:join(OutDir, D) || D <- DataFiles]) %% end. - - -%% This function, which is supposed to check whether the right LLVM -%% infrastructure is available, should be probably written in a better -%% and more portable way and moved to the hipe application. - -is_llvm_opt_available() -> - OptStr = os:cmd("opt -version"), - SubStr = "LLVM version ", N = length(SubStr), - case string:str(OptStr, SubStr) of - 0 -> false; - S -> P = S + N, string:sub_string(OptStr, P, P + 2) >= "3.4" - end. diff --git a/lib/hipe/test/sanity_SUITE_data/sanity_comp_timeout.erl b/lib/hipe/test/sanity_SUITE_data/sanity_comp_timeout.erl new file mode 100644 index 0000000000..9f0830574f --- /dev/null +++ b/lib/hipe/test/sanity_SUITE_data/sanity_comp_timeout.erl @@ -0,0 +1,28 @@ +%%% -*- erlang-indent-level: 2 -*- +%%%---------------------------------------------------------------------- +%%% Author: Kostis Sagonas +%%% +%%% Tests that when the native code compilation times out or gets killed +%%% for some other reason, the parent process does not also get killed. +%%% +%%% Problem discovered by Bjorn G. on 1/12/2003 and fixed by Kostis. +%%%---------------------------------------------------------------------- + +-module(sanity_comp_timeout). + +-export([test/0, to_llvm/0]). + +test() -> + ok = write_dummy_mod(), + error_logger:tty(false), % disable printouts of error reports + Self = self(), % get the parent process + c:c(dummy_mod, [native, {hipe, [{timeout, 1}]}]), % This will kill the process + Self = self(), % make sure the parent process stays the same + ok. + +to_llvm() -> false. + +write_dummy_mod() -> + Prog = <<"-module(dummy_mod).\n-export([test/0]).\ntest() -> ok.\n">>, + ok = file:write_file("dummy_mod.erl", Prog). + diff --git a/lib/hipe/test/sanity_SUITE_data/sanity_no_zombies.erl b/lib/hipe/test/sanity_SUITE_data/sanity_no_zombies.erl new file mode 100644 index 0000000000..87e746042e --- /dev/null +++ b/lib/hipe/test/sanity_SUITE_data/sanity_no_zombies.erl @@ -0,0 +1,21 @@ +%%% -*- erlang-indent-level: 2 -*- +%%%---------------------------------------------------------------------- +%%% Author: Per Gustafsson +%%% +%%% Checks that HiPE's concurrent compilation does not leave any zombie +%%% processes around after compilation has finished. +%%% +%%% This was a bug reported on erlang-bugs (Oct 25, 2007). +%%%---------------------------------------------------------------------- + +-module(sanity_no_zombies). + +-export([test/0, to_llvm/0]). + +test() -> + L = length(processes()), + hipe:c(?MODULE, [concurrent_comp]), % force concurrent compilation + L = length(processes()), + ok. + +to_llvm() -> false. diff --git a/lib/kernel/doc/src/code.xml b/lib/kernel/doc/src/code.xml index eb0f4b7a06..1bd52040a0 100644 --- a/lib/kernel/doc/src/code.xml +++ b/lib/kernel/doc/src/code.xml @@ -287,6 +287,46 @@ was given to <c>set_path/1</c>).</p> </section> + <section> + <marker id="error_reasons"></marker> + <title>Error Reasons for Code-Loading Functions</title> + + <p>Functions that load code (such as <c>load_file/1</c>) will + return <c>{error,Reason}</c> if the load operation fails. + Here follows a description of the common reasons.</p> + + <taglist> + <tag><c>badfile</c></tag> + <item> + <p>The object code has an incorrect format or the module + name in the object code is not the expected module name.</p> + </item> + + <tag><c>nofile</c></tag> + <item> + <p>No file with object code was found.</p> + </item> + + <tag><c>not_purged</c></tag> + <item> + <p>The object code could not be loaded because an old version + of the code already existed.</p> + </item> + + <tag><c>on_load_failure</c></tag> + <item> + <p>The module has an + <seealso marker="doc/reference_manual:code_loading#on_load">-on_load function</seealso> + that failed when it was called.</p> + </item> + + <tag><c>sticky_directory</c></tag> + <item> + <p>The object code resides in a sticky directory.</p> + </item> + + </taglist> + </section> <datatypes> <datatype> <name name="load_ret"/> @@ -411,12 +451,8 @@ be used to load object code with a module name that is different from the file name.</p> <p>Returns <c>{module, <anno>Module</anno>}</c> if successful, or - <c>{error, nofile}</c> if no object code is found, or - <c>{error, sticky_directory}</c> if the object code resides in - a sticky directory. Also if the loading fails, an error tuple is - returned. See - <seealso marker="erts:erlang#load_module/2">erlang:load_module/2</seealso> - for possible values of <c><anno>What</anno></c>.</p> + <c>{error, Reason}</c> if loading fails. + See <seealso marker="#error_reasons">Error Reasons for Code-Loading Functions</seealso> for a description of the possible error reasons.</p> </desc> </func> <func> @@ -428,7 +464,7 @@ <desc> <p>Does the same as <c>load_file(<anno>Module</anno>)</c>, but <c><anno>Filename</anno></c> is either an absolute file name, or a - relative file name. The code path is not searched. It returns + relative file name. The code path is not searched. It returns a value in the same way as <seealso marker="#load_file/1">load_file/1</seealso>. Note that <c><anno>Filename</anno></c> should not contain the extension (for @@ -444,7 +480,8 @@ <seealso marker="#load_file/1">load_file/1</seealso>, unless the module is already loaded. In embedded mode, however, it does not load a module which is not - already loaded, but returns <c>{error, embedded}</c> instead.</p> + already loaded, but returns <c>{error, embedded}</c> instead. + See <seealso marker="#error_reasons">Error Reasons for Code-Loading Functions</seealso> for a description of other possible error reasons.</p> </desc> </func> <func> @@ -461,12 +498,8 @@ comes. Accordingly, <c><anno>Filename</anno></c> is not opened and read by the code server.</p> <p>Returns <c>{module, <anno>Module</anno>}</c> if successful, or - <c>{error, sticky_directory}</c> if the object code resides in - a sticky directory, or <c>{error, badarg}</c> if any argument - is invalid. Also if the loading fails, an error tuple is - returned. See - <seealso marker="erts:erlang#load_module/2">erlang:load_module/2</seealso> - for possible values of <c><anno>What</anno></c>.</p> + <c>{error, Reason}</c> if loading fails. + See <seealso marker="#error_reasons">Error Reasons for Code-Loading Functions</seealso> for a description of the possible error reasons.</p> </desc> </func> <func> diff --git a/lib/kernel/src/code.erl b/lib/kernel/src/code.erl index 352c02562b..7237550786 100644 --- a/lib/kernel/src/code.erl +++ b/lib/kernel/src/code.erl @@ -77,10 +77,9 @@ %%---------------------------------------------------------------------------- -type load_error_rsn() :: 'badfile' - | 'native_code' | 'nofile' | 'not_purged' - | 'on_load' + | 'on_load_failure' | 'sticky_directory'. -type load_ret() :: {'error', What :: load_error_rsn()} | {'module', Module :: module()}. @@ -135,14 +134,16 @@ load_file(Mod) when is_atom(Mod) -> -spec ensure_loaded(Module) -> {module, Module} | {error, What} when Module :: module(), - What :: embedded | badfile | native_code | nofile | on_load. + What :: embedded | badfile | nofile | on_load_failure. ensure_loaded(Mod) when is_atom(Mod) -> call({ensure_loaded,Mod}). %% XXX File as an atom is allowed only for backwards compatibility. -spec load_abs(Filename) -> load_ret() when Filename :: file:filename(). -load_abs(File) when is_list(File); is_atom(File) -> call({load_abs,File,[]}). +load_abs(File) when is_list(File); is_atom(File) -> + Mod = list_to_atom(filename:basename(File)), + call({load_abs,File,Mod}). %% XXX Filename is also an atom(), e.g. 'cover_compiled' -spec load_abs(Filename :: loaded_filename(), Module :: module()) -> load_ret(). diff --git a/lib/kernel/src/code_server.erl b/lib/kernel/src/code_server.erl index e461c95d19..614219794c 100644 --- a/lib/kernel/src/code_server.erl +++ b/lib/kernel/src/code_server.erl @@ -313,7 +313,7 @@ handle_call(get_path, {_From,_Tag}, S) -> {reply,S#state.path,S}; %% Messages to load, delete and purge modules/files. -handle_call({load_abs,File,Mod}, Caller, S) -> +handle_call({load_abs,File,Mod}, Caller, S) when is_atom(Mod) -> case modp(File) of false -> {reply,{error,badarg},S}; @@ -1222,15 +1222,10 @@ modp(Atom) when is_atom(Atom) -> true; modp(List) when is_list(List) -> int_list(List); modp(_) -> false. -load_abs(File, Mod0, Caller, St) -> +load_abs(File, Mod, Caller, St) -> Ext = objfile_extension(), FileName0 = lists:concat([File, Ext]), FileName = absname(FileName0), - Mod = if Mod0 =:= [] -> - list_to_atom(filename:basename(FileName0, Ext)); - true -> - Mod0 - end, case erl_prim_loader:get_file(FileName) of {ok,Bin,_} -> try_load_module(FileName, Mod, Bin, Caller, St); diff --git a/lib/kernel/test/code_SUITE.erl b/lib/kernel/test/code_SUITE.erl index ef5303defd..2b77ec8972 100644 --- a/lib/kernel/test/code_SUITE.erl +++ b/lib/kernel/test/code_SUITE.erl @@ -323,6 +323,7 @@ load_abs(Config) when is_list(Config) -> {error, nofile} = code:load_abs(TestDir ++ "/duuuumy_mod"), {error, badfile} = code:load_abs(TestDir ++ "/code_a_test"), {'EXIT', _} = (catch code:load_abs({})), + {'EXIT', _} = (catch code:load_abs("Non-latin-имя-файла")), {module, code_b_test} = code:load_abs(TestDir ++ "/code_b_test"), code:stick_dir(TestDir), {error, sticky_directory} = code:load_abs(TestDir ++ "/code_b_test"), @@ -1599,6 +1600,17 @@ on_load_errors(Config) when is_list(Config) -> ok end, + %% Make sure that the code loading functions return the correct + %% error code. + Simple = simple_on_load_error, + SimpleList = atom_to_list(Simple), + {error,on_load_failure} = code:load_file(Simple), + {error,on_load_failure} = code:ensure_loaded(Simple), + {ok,SimpleCode} = file:read_file("simple_on_load_error.beam"), + {error,on_load_failure} = code:load_binary(Simple, "", SimpleCode), + {error,on_load_failure} = code:load_abs(SimpleList), + {error,on_load_failure} = code:load_abs(SimpleList, Simple), + ok. do_on_load_error(ReturnValue) -> diff --git a/lib/kernel/test/code_SUITE_data/on_load_errors/simple_on_load_error.erl b/lib/kernel/test/code_SUITE_data/on_load_errors/simple_on_load_error.erl new file mode 100644 index 0000000000..603c282257 --- /dev/null +++ b/lib/kernel/test/code_SUITE_data/on_load_errors/simple_on_load_error.erl @@ -0,0 +1,5 @@ +-module(simple_on_load_error). +-on_load(on_load/0). + +on_load() -> + nope. diff --git a/lib/sasl/doc/src/overload.xml b/lib/sasl/doc/src/overload.xml index 5c3d00afeb..2f19cd9088 100644 --- a/lib/sasl/doc/src/overload.xml +++ b/lib/sasl/doc/src/overload.xml @@ -35,6 +35,12 @@ <module>overload</module> <modulesummary>An Overload Regulation Process</modulesummary> <description> + <warning> + <p> + All functions in this module are deprecated and will be + removed in a future release. + </p> + </warning> <p><c>overload</c> is a process that indirectly regulates the CPU usage in the system. The idea is that a main application calls function diff --git a/lib/sasl/doc/src/sasl_app.xml b/lib/sasl/doc/src/sasl_app.xml index 8d79251c7e..bcd446a868 100644 --- a/lib/sasl/doc/src/sasl_app.xml +++ b/lib/sasl/doc/src/sasl_app.xml @@ -34,7 +34,7 @@ <p>The <c>SASL</c> application provides the following services:</p> <list type="bulleted"> <item><c>alarm_handler</c></item> - <item><c>overload</c></item> + <item><c>overload</c> (deprecated)</item> <item><c>rb</c></item> <item><c>release_handler</c></item> <item><c>systools</c></item> @@ -145,11 +145,15 @@ <p>Specifies the maximum intensity for <seealso marker="overload"><c>overload</c></seealso>. Default is <c>0.8</c>.</p> + <p>Note that the <c>overload</c> module is deprected and + will be removed in a future release.</p> </item> <tag><c><![CDATA[overload_weight = float() > 0 ]]></c></tag> <item> <p>Specifies the <seealso marker="overload"><c>overload</c></seealso> weight. Default is <c>0.1</c>.</p> + <p>Note that the <c>overload</c> module is deprected and + will be removed in a future release.</p> </item> <tag><c><![CDATA[start_prg = string() ]]></c></tag> <item> diff --git a/lib/sasl/src/overload.erl b/lib/sasl/src/overload.erl index 61b925d219..bc8ab7d5e4 100644 --- a/lib/sasl/src/overload.erl +++ b/lib/sasl/src/overload.erl @@ -19,6 +19,8 @@ %% -module(overload). +-deprecated(module). + -export([start_link/0, request/0, set_config_data/2, get_overload_info/0]). diff --git a/lib/snmp/src/agent/snmp_view_based_acm_mib.erl b/lib/snmp/src/agent/snmp_view_based_acm_mib.erl index 586b7c7171..9e6aa74d45 100644 --- a/lib/snmp/src/agent/snmp_view_based_acm_mib.erl +++ b/lib/snmp/src/agent/snmp_view_based_acm_mib.erl @@ -34,6 +34,8 @@ %% Internal exports -export([check_vacm/1]). +%% +-export([emask2imask/1]). -include("snmp_types.hrl"). diff --git a/lib/snmp/src/agent/snmpa_acm.erl b/lib/snmp/src/agent/snmpa_acm.erl index 7327575846..0264c6a992 100644 --- a/lib/snmp/src/agent/snmpa_acm.erl +++ b/lib/snmp/src/agent/snmpa_acm.erl @@ -280,7 +280,7 @@ validate_mib_view(Oid, MibView) -> end. get_largest_family([{SubTree, Mask, Type} | T], Oid, Res) -> - case check_mask(Oid, SubTree, Mask) of + case check_mask(Oid, SubTree, snmp_view_based_acm_mib:emask2imask(Mask)) of true -> get_largest_family(T, Oid, add_res(length(SubTree), SubTree, Type, Res)); false -> get_largest_family(T, Oid, Res) @@ -345,7 +345,7 @@ validate_all_mib_view([], _MibView) -> %% intelligent. %%----------------------------------------------------------------- is_definitely_not_in_mib_view(Oid, [{SubTree, Mask,?view_included}|T]) -> - case check_maybe_mask(Oid, SubTree, Mask) of + case check_maybe_mask(Oid, SubTree, snmp_view_based_acm_mib:emask2imask(Mask)) of true -> false; false -> is_definitely_not_in_mib_view(Oid, T) end; diff --git a/lib/snmp/src/app/snmp.appup.src b/lib/snmp/src/app/snmp.appup.src index 77418f920f..ca61782639 100644 --- a/lib/snmp/src/app/snmp.appup.src +++ b/lib/snmp/src/app/snmp.appup.src @@ -1,71 +1,24 @@ -%% -%% %CopyrightBegin% -%% -%% Copyright Ericsson AB 1999-2015. 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% -%% - - +%% -*- erlang -*- {"%VSN%", %% ----- U p g r a d e ------------------------------------------------------- - %% Instruction examples: %% {restart_application, snmp} %% {load_module, snmp_pdus, soft_purge, soft_purge, []} %% {update, snmpa_local_db, soft, soft_purge, soft_purge, []} %% {add_module, snmpm_net_if_mt} [ - {"5.2", [{load_module, snmp_conf, soft_purge, soft_purge, []}]}, - {"5.1.2", [ % Only runtime dependencies change - ]}, - {"5.1.1", [{restart_application, snmp}]}, - {"5.1", [ % Only compiler changes - ]}, - {"5.0", [{restart_application, snmp}]}, - {"4.25.1", [{restart_application, snmp}]}, - {"4.25.0.1", [{restart_application, snmp}]}, - {"4.25.0.0.1", [{restart_application, snmp}]}, - {"4.25", [{restart_application, snmp}]}, - {"4.24.2", [{restart_application, snmp}]}, - {"4.24.1", [{restart_application, snmp}]}, - {"4.24", [{restart_application, snmp}]} - ], - + {<<"5\\..*">>, [{restart_application, snmp}]}, + {<<"4\\..*">>, [{restart_application, snmp}]} + ], + %% ------D o w n g r a d e --------------------------------------------------- - %% Instruction examples: %% {remove, {snmpm_net_if_mt, soft_purge, soft_purge}} - + [ - {"5.2", [{load_module, snmp_conf, soft_purge, soft_purge, []}]}, - {"5.1.2", [ % Only runtime dependencies change - ]}, - {"5.1.1", [{restart_application, snmp}]}, - {"5.1", [ % Only compiler changes - ]}, - {"5.0", [{restart_application, snmp}]}, - {"4.25.1", [{restart_application, snmp}]}, - {"4.25.0.1", [{restart_application, snmp}]}, - {"4.25.0.0.1", [{restart_application, snmp}]}, - {"4.25", [{restart_application, snmp}]}, - {"4.24.2", [{restart_application, snmp}]}, - {"4.24.1", [{restart_application, snmp}]}, - {"4.24", [{restart_application, snmp}]} - ] - -}. + {<<"5\\..*">>, [{restart_application, snmp}]}, + {<<"4\\..*">>, [{restart_application, snmp}]} + ] +}. diff --git a/lib/ssh/doc/src/notes.xml b/lib/ssh/doc/src/notes.xml index 8fb689fdd5..75e1615c09 100644 --- a/lib/ssh/doc/src/notes.xml +++ b/lib/ssh/doc/src/notes.xml @@ -30,6 +30,24 @@ <file>notes.xml</file> </header> +<section><title>Ssh 4.2.1</title> + + <section><title>Fixed Bugs and Malfunctions</title> + <list> + <item> + <p> + The authentication method 'keyboard-interactive' failed + in the Erlang client when the server after successful + authentication continued by asking for zero more + passwords.</p> + <p> + Own Id: OTP-13225</p> + </item> + </list> + </section> + +</section> + <section><title>Ssh 4.2</title> <section><title>Fixed Bugs and Malfunctions</title> diff --git a/lib/ssh/src/ssh_auth.erl b/lib/ssh/src/ssh_auth.erl index fdbb5c152a..b71bed033a 100644 --- a/lib/ssh/src/ssh_auth.erl +++ b/lib/ssh/src/ssh_auth.erl @@ -477,7 +477,7 @@ keyboard_interact_get_responses(_, undefined, Password, _, _, _, _, _, 1) when Password =/= undefined -> [Password]; %% Password auth implemented with keyboard-interaction and passwd is known keyboard_interact_get_responses(_, _, _, _, _, _, _, _, 0) -> - [""]; + []; keyboard_interact_get_responses(false, undefined, undefined, _, _, _, [Prompt|_], Opts, _) -> ssh_no_io:read_line(Prompt, Opts); %% Throws error as keyboard interaction is not allowed keyboard_interact_get_responses(true, undefined, _,IoCb, Name, Instr, PromptInfos, Opts, _) -> diff --git a/lib/ssh/src/ssh_connection_handler.erl b/lib/ssh/src/ssh_connection_handler.erl index f082db136c..ce1931e4f4 100644 --- a/lib/ssh/src/ssh_connection_handler.erl +++ b/lib/ssh/src/ssh_connection_handler.erl @@ -648,10 +648,12 @@ userauth_keyboard_interactive(Msg = #ssh_msg_userauth_failure{}, userauth_keyboard_interactive_info_response(Msg=#ssh_msg_userauth_failure{}, #state{ssh_params = #ssh{role = client}} = State) -> userauth(Msg, State); - userauth_keyboard_interactive_info_response(Msg=#ssh_msg_userauth_success{}, #state{ssh_params = #ssh{role = client}} = State) -> - userauth(Msg, State). + userauth(Msg, State); +userauth_keyboard_interactive_info_response(Msg=#ssh_msg_userauth_info_request{}, + #state{ssh_params = #ssh{role = client}} = State) -> + userauth_keyboard_interactive(Msg, State). %%-------------------------------------------------------------------- -spec connected({#ssh_msg_kexinit{}, binary()}, %%| %% #ssh_msg_kexdh_init{}, diff --git a/lib/ssh/test/ssh_benchmark_SUITE.erl b/lib/ssh/test/ssh_benchmark_SUITE.erl index 2add99de97..e90bfa3d16 100644 --- a/lib/ssh/test/ssh_benchmark_SUITE.erl +++ b/lib/ssh/test/ssh_benchmark_SUITE.erl @@ -37,8 +37,8 @@ all() -> [{group, opensshc_erld} ]. groups() -> - [{opensshc_erld, [{repeat, 3}], [openssh_client_shell]}, - {erlc_opensshd, [{repeat, 3}], [erl_shell]} + [{opensshc_erld, [{repeat, 3}], [openssh_client_shell, + openssh_client_sftp]} ]. @@ -50,7 +50,7 @@ init_per_suite(Config) -> report_client_algorithms(), ok = ssh:start(), {ok,TracerPid} = erlang_trace(), - [{tracer_pid,TracerPid} | Config] + [{tracer_pid,TracerPid} | init_sftp_dirs(Config)] catch C:E -> {skip, io_lib:format("Couldn't start ~p:~p",[C,E])} @@ -71,8 +71,12 @@ init_per_group(opensshc_erld, Config) -> ssh_test_lib:setup_dsa(DataDir, UserDir), ssh_test_lib:setup_rsa(DataDir, UserDir), ssh_test_lib:setup_ecdsa("256", DataDir, UserDir), + Common = ssh_test_lib:intersect_bi_dir( + ssh_test_lib:intersection(ssh:default_algorithms(), + ssh_test_lib:default_algorithms(sshc))), [{c_kexs, ssh_test_lib:sshc(kex)}, - {c_ciphers, ssh_test_lib:sshc(cipher)} + {c_ciphers, ssh_test_lib:sshc(cipher)}, + {common_algs, Common} | Config]; _ -> {skip, "No OpenSsh client found"} @@ -94,20 +98,21 @@ init_per_testcase(_Func, Conf) -> end_per_testcase(_Func, _Conf) -> ok. + +init_sftp_dirs(Config) -> + UserDir = ?config(priv_dir, Config), + SrcDir = filename:join(UserDir, "sftp_src"), + ok = file:make_dir(SrcDir), + SrcFile = "big_data", + DstDir = filename:join(UserDir, "sftp_dst"), + ok = file:make_dir(DstDir), + N = 100 * 1024*1024, + ok = file:write_file(filename:join(SrcDir,SrcFile), crypto:rand_bytes(N)), + [{sftp_src_dir,SrcDir}, {sftp_dst_dir,DstDir}, {src_file,SrcFile}, {sftp_size,N} + | Config]. + %%%================================================================ openssh_client_shell(Config) -> - CommonAlgs = ssh_test_lib:intersect_bi_dir( - ssh_test_lib:intersection(ssh:default_algorithms(), - ssh_test_lib:default_algorithms(sshc))), - KexVariants = - [ [{kex,[Kex]}] - || Kex <- proplists:get_value(kex, CommonAlgs)], - CipherVariants = - [ [{cipher,[{client2server,[Cipher]}, - {server2client,[Cipher]}]}] - || Cipher <- proplists:get_value(cipher, CommonAlgs)], - - lists:foreach( fun(PrefAlgs=[{kex,[Kex]}]) when Kex == 'diffie-hellman-group-exchange-sha256' -> lists:foreach( @@ -120,7 +125,8 @@ openssh_client_shell(Config) -> (PrefAlgs) -> openssh_client_shell(Config, [{preferred_algorithms, PrefAlgs}]) - end, KexVariants ++ CipherVariants). + end, variants(kex,Config) ++ variants(cipher,Config) + ). openssh_client_shell(Config, Options) -> @@ -151,7 +157,7 @@ openssh_client_shell(Config, Options) -> {SlavePid, _ClientResponse} -> %% ct:pal("ClientResponse = ~p",[_ClientResponse]), {ok, List} = get_trace_list(TracerPid), - Times = find_times(List), + Times = find_times(List, [accept_to_hello, kex, kex_to_auth, auth, to_prompt]), Algs = find_algs(List), ct:pal("Algorithms = ~p~n~nTimes = ~p",[Algs,Times]), lists:foreach( @@ -189,6 +195,96 @@ openssh_client_shell(Config, Options) -> %%%================================================================ +openssh_client_sftp(Config) -> + lists:foreach( + fun(PrefAlgs) -> + openssh_client_sftp(Config, [{preferred_algorithms,PrefAlgs}]) + end, variants(cipher,Config)). + + +openssh_client_sftp(Config, Options) -> + SystemDir = ?config(data_dir, Config), + UserDir = ?config(priv_dir, Config), + SftpSrcDir = ?config(sftp_src_dir, Config), + SrcFile = ?config(src_file, Config), + SrcSize = ?config(sftp_size, Config), + KnownHosts = filename:join(UserDir, "known_hosts"), + + {ok, TracerPid} = erlang_trace(), + {ServerPid, _Host, Port} = + ssh_test_lib:daemon([{system_dir, SystemDir}, + {public_key_alg, ssh_dsa}, + {subsystems,[ssh_sftpd:subsystem_spec([%{cwd, SftpSrcDir}, + {root, SftpSrcDir}])]}, + {failfun, fun ssh_test_lib:failfun/2} + | Options]), + ct:sleep(500), + Cmd = lists:concat(["sftp", + " -b -", + " -P ",Port, + " -o UserKnownHostsFile=", KnownHosts, + " -o \"StrictHostKeyChecking no\"", + " localhost:",SrcFile + ]), +%% ct:pal("Cmd = ~p",[Cmd]), + + Parent = self(), + SlavePid = spawn(fun() -> + Parent ! {self(),os:cmd(Cmd)} + end), + receive + {SlavePid, _ClientResponse} -> + ct:pal("ClientResponse = ~p",[_ClientResponse]), + {ok, List} = get_trace_list(TracerPid), +%%ct:pal("List=~p",[List]), + Times = find_times(List, [channel_open_close]), + Algs = find_algs(List), + ct:pal("Algorithms = ~p~n~nTimes = ~p",[Algs,Times]), + lists:foreach( + fun({{A,B},Value,Unit}) when A==encrypt ; A==decrypt -> + Data = [{value, Value}, + {suite, ?MODULE}, + {name, mk_name(["Sftp Cipher ",A," ",B," [",Unit,"]"])} + ], + ct:pal("sftp ct_event:notify ~p",[Data]), + ct_event:notify(#event{name = benchmark_data, + data = Data}); + ({channel_open_close,Value,Unit}) -> + Cipher = fmt_alg(Algs#alg.encrypt, List), + Data = [{value, round( (1024*Value) / SrcSize )}, + {suite, ?MODULE}, + {name, mk_name(["Sftp transfer ",Cipher," [",Unit," per kbyte]"])} + ], + ct:pal("sftp ct_event:notify ~p",[Data]), + ct_event:notify(#event{name = benchmark_data, + data = Data}); + (_) -> + skip + end, Times), + ssh:stop_daemon(ServerPid), + ok + after 10000 -> + ssh:stop_daemon(ServerPid), + exit(SlavePid, kill), + {fail, timeout} + end. + +%%%================================================================ +variants(Tag, Config) -> + TagType = + case proplists:get_value(Tag, ssh:default_algorithms()) of + [{_,_}|_] -> one_way; + [A|_] when is_atom(A) -> two_way + end, + [ [{Tag,tag_value(TagType,Alg)}] + || Alg <- proplists:get_value(Tag, ?config(common_algs,Config)) + ]. + +tag_value(two_way, Alg) -> [Alg]; +tag_value(one_way, Alg) -> [{client2server,[Alg]}, + {server2client,[Alg]}]. + +%%%---------------------------------------------------------------- fmt_alg(Alg, List) when is_atom(Alg) -> fmt_alg(atom_to_list(Alg), List); fmt_alg(Alg = "diffie-hellman-group-exchange-sha" ++ _, List) -> @@ -199,7 +295,7 @@ fmt_alg(Alg = "diffie-hellman-group-exchange-sha" ++ _, List) -> catch _:_ -> Alg end; -fmt_alg(Alg, List) -> +fmt_alg(Alg, _List) -> Alg. %%%---------------------------------------------------------------- @@ -209,10 +305,12 @@ char($-) -> $_; char(C) -> C. %%%---------------------------------------------------------------- -find_times(L) -> - Xs = [accept_to_hello, kex, kex_to_auth, auth, to_prompt], +find_times(L, Xs) -> [find_time(X,L) || X <- Xs] ++ - crypto_algs_times_sizes([encrypt,decrypt], L). + function_algs_times_sizes([{ssh_transport,encrypt,2}, + {ssh_transport,decrypt,2}, + {ssh_message,decode,1}, + {ssh_message,encode,1}], L). -record(call, { mfa, @@ -268,7 +366,13 @@ find_time(to_prompt, L) -> end, ?recv(#ssh_msg_channel_request{request_type="env"}) ], L, []), - {to_prompt, now2micro_sec(now_diff(T1,T0)), microsec}. + {to_prompt, now2micro_sec(now_diff(T1,T0)), microsec}; +find_time(channel_open_close, L) -> + [T0,T1] = find([?recv(#ssh_msg_channel_request{request_type="subsystem"}), + ?send(#ssh_msg_channel_close{}) + ], L, []), + {channel_open_close, now2micro_sec(now_diff(T1,T0)), microsec}. + find([F|Fs], [C|Cs], Acc) when is_function(F,1) -> @@ -295,24 +399,31 @@ find_gex_size_string(L) -> Size. %%%---------------- -crypto_algs_times_sizes(EncDecs, L) -> - Raw = [{_Algorithm = case EncDec of - encrypt -> {encrypt,S#ssh.encrypt}; - decrypt -> {decrypt,S#ssh.decrypt} - end, - size(Data), - now2micro_sec(now_diff(T1, T0)) - } +function_algs_times_sizes(EncDecs, L) -> + Raw = [begin + {Tag,Size} = function_ats_result(EncDec, C), + {Tag, Size, now2micro_sec(now_diff(T1,T0))} + end || EncDec <- EncDecs, - #call{mfa = {ssh_transport,ED,2}, - args = [S,Data], - t_call = T0, - t_return = T1} <- L, + C = #call{mfa = ED, + args = Args, %%[S,Data], + t_call = T0, + t_return = T1} <- L, ED == EncDec ], [{Alg, round(1024*Time/Size), "microsec per kbyte"} % Microseconds per 1k bytes. || {Alg,Size,Time} <- lists:foldl(fun increment/2, [], Raw)]. +function_ats_result({ssh_transport,encrypt,2}, #call{args=[S,Data]}) -> + {{encrypt,S#ssh.encrypt}, size(Data)}; +function_ats_result({ssh_transport,decrypt,2}, #call{args=[S,Data]}) -> + {{decrypt,S#ssh.decrypt}, size(Data)}; +function_ats_result({ssh_message,encode,1}, #call{result=Data}) -> + {encode, size(Data)}; +function_ats_result({ssh_message,decode,1}, #call{args=[Data]}) -> + {decode, size(Data)}. + + increment({Alg,Sz,T}, [{Alg,SumSz,SumT}|Acc]) -> [{Alg,SumSz+Sz,SumT+T} | Acc]; increment(Spec, [X|Acc]) -> @@ -342,6 +453,8 @@ erlang_trace() -> {ssh_transport,select_algorithm,3}, {ssh_transport,encrypt,2}, {ssh_transport,decrypt,2}, + {ssh_message,encode,1}, + {ssh_message,decode,1}, {public_key,dh_gex_group,4} % To find dh_gex group size ]], {ok, TracerPid}. diff --git a/lib/ssh/test/ssh_protocol_SUITE.erl b/lib/ssh/test/ssh_protocol_SUITE.erl index 4c088acabf..fe197f8672 100644 --- a/lib/ssh/test/ssh_protocol_SUITE.erl +++ b/lib/ssh/test/ssh_protocol_SUITE.erl @@ -48,6 +48,7 @@ all() -> [{group,tool_tests}, {group,kex}, {group,service_requests}, + {group,authentication}, {group,packet_size_error}, {group,field_size_error} ]. @@ -78,7 +79,9 @@ groups() -> bad_very_long_service_name, empty_service_name, bad_service_name_then_correct - ]} + ]}, + {authentication, [], [client_handles_keyboard_interactive_0_pwds + ]} ]. @@ -494,6 +497,82 @@ bad_service_name_length(Config, LengthExcess) -> {match, disconnect(), receive_msg} ], InitialState). +%%%-------------------------------------------------------------------- +%%% This is due to a fault report (OTP-13255) with OpenSSH-6.6.1 +client_handles_keyboard_interactive_0_pwds(Config) -> + {User,_Pwd} = server_user_password(Config), + + %% Create a listening socket as server socket: + {ok,InitialState} = ssh_trpt_test_lib:exec(listen), + HostPort = ssh_trpt_test_lib:server_host_port(InitialState), + + %% Start a process handling one connection on the server side: + spawn_link( + fun() -> + {ok,_} = + ssh_trpt_test_lib:exec( + [{set_options, [print_ops, print_messages]}, + {accept, [{system_dir, system_dir(Config)}, + {user_dir, user_dir(Config)}]}, + receive_hello, + {send, hello}, + + {send, ssh_msg_kexinit}, + {match, #ssh_msg_kexinit{_='_'}, receive_msg}, + + {match, #ssh_msg_kexdh_init{_='_'}, receive_msg}, + {send, ssh_msg_kexdh_reply}, + + {send, #ssh_msg_newkeys{}}, + {match, #ssh_msg_newkeys{_='_'}, receive_msg}, + + {match, #ssh_msg_service_request{name="ssh-userauth"}, receive_msg}, + {send, #ssh_msg_service_accept{name="ssh-userauth"}}, + + {match, #ssh_msg_userauth_request{service="ssh-connection", + method="none", + user=User, + _='_'}, receive_msg}, + {send, #ssh_msg_userauth_failure{authentications = "keyboard-interactive", + partial_success = false}}, + + {match, #ssh_msg_userauth_request{service="ssh-connection", + method="keyboard-interactive", + user=User, + _='_'}, receive_msg}, + {send, #ssh_msg_userauth_info_request{name = "", + instruction = "", + language_tag = "", + num_prompts = 1, + data = <<0,0,0,10,80,97,115,115,119,111,114,100,58,32,0>> + }}, + {match, #ssh_msg_userauth_info_response{num_responses = 1, + _='_'}, receive_msg}, + + %% the next is strange, but openssh 6.6.1 does this and this is what this testcase is about + {send, #ssh_msg_userauth_info_request{name = "", + instruction = "", + language_tag = "", + num_prompts = 0, + data = <<>> + }}, + {match, #ssh_msg_userauth_info_response{num_responses = 0, + data = <<>>, + _='_'}, receive_msg}, + %% Here we know that the tested fault is fixed + {send, #ssh_msg_userauth_success{}}, + close_socket, + print_state + ], + InitialState) + end), + + %% and finally connect to it with a regular Erlang SSH client: + {ok,_} = std_connect(HostPort, Config, + [{preferred_algorithms,[{kex,['diffie-hellman-group1-sha1']}]}] + ). + + %%%================================================================ %%%==== Internal functions ======================================== %%%================================================================ diff --git a/lib/ssh/vsn.mk b/lib/ssh/vsn.mk index 25b19133b1..55d12abffe 100644 --- a/lib/ssh/vsn.mk +++ b/lib/ssh/vsn.mk @@ -1,5 +1,5 @@ #-*-makefile-*- ; force emacs to enter makefile-mode -SSH_VSN = 4.2 +SSH_VSN = 4.2.1 APP_VSN = "ssh-$(SSH_VSN)" diff --git a/lib/ssl/src/ssl.appup.src b/lib/ssl/src/ssl.appup.src index 11728128c4..057906bcb3 100644 --- a/lib/ssl/src/ssl.appup.src +++ b/lib/ssl/src/ssl.appup.src @@ -1,6 +1,9 @@ %% -*- erlang -*- {"%VSN%", [ + {<<"7\\.2">>, [{load_module, tls_connection, soft_purge, soft_purge, []}, + {load_module, ssl_tls_dist_proxy, soft_purge, soft_purge, []} + ]}, {<<"7\\..*">>, [{restart_application, ssl}]}, {<<"6\\..*">>, [{restart_application, ssl}]}, {<<"5\\..*">>, [{restart_application, ssl}]}, @@ -8,6 +11,9 @@ {<<"3\\..*">>, [{restart_application, ssl}]} ], [ + {<<"7\\.2">>, [{load_module, tls_connection, soft_purge, soft_purge, []}, + {load_module, ssl_tls_dist_proxy, soft_purge, soft_purge, []} + ]}, {<<"7\\..*">>, [{restart_application, ssl}]}, {<<"6\\..*">>, [{restart_application, ssl}]}, {<<"5\\..*">>, [{restart_application, ssl}]}, diff --git a/lib/ssl/src/ssl_tls_dist_proxy.erl b/lib/ssl/src/ssl_tls_dist_proxy.erl index 3edd352891..080817d204 100644 --- a/lib/ssl/src/ssl_tls_dist_proxy.erl +++ b/lib/ssl/src/ssl_tls_dist_proxy.erl @@ -196,6 +196,7 @@ accept_loop(Proxy, world = Type, Listen, Extra) -> case gen_tcp:accept(Listen) of {ok, Socket} -> Opts = get_ssl_options(server), + wait_for_code_server(), case ssl:ssl_accept(Socket, Opts) of {ok, SslSocket} -> PairHandler = @@ -217,6 +218,35 @@ accept_loop(Proxy, world = Type, Listen, Extra) -> end, accept_loop(Proxy, Type, Listen, Extra). +wait_for_code_server() -> + %% This is an ugly hack. Upgrading a socket to TLS requires the + %% crypto module to be loaded. Loading the crypto module triggers + %% its on_load function, which calls code:priv_dir/1 to find the + %% directory where its NIF library is. However, distribution is + %% started earlier than the code server, so the code server is not + %% necessarily started yet, and code:priv_dir/1 might fail because + %% of that, if we receive an incoming connection on the + %% distribution port early enough. + %% + %% If the on_load function of a module fails, the module is + %% unloaded, and the function call that triggered loading it fails + %% with 'undef', which is rather confusing. + %% + %% Thus, the ssl_tls_dist_proxy process will terminate, and be + %% restarted by ssl_dist_sup. However, it won't have any memory + %% of being asked by net_kernel to listen for incoming + %% connections. Hence, the node will believe that it's open for + %% distribution, but it actually isn't. + %% + %% So let's avoid that by waiting for the code server to start. + case whereis(code_server) of + undefined -> + timer:sleep(10), + wait_for_code_server(); + Pid when is_pid(Pid) -> + ok + end. + try_connect(Port) -> case gen_tcp:connect({127,0,0,1}, Port, [{active, false}, {packet,?PPRE}, nodelay()]) of R = {ok, _S} -> diff --git a/lib/ssl/src/tls_connection.erl b/lib/ssl/src/tls_connection.erl index b2b85eaf8d..c3f0206d25 100644 --- a/lib/ssl/src/tls_connection.erl +++ b/lib/ssl/src/tls_connection.erl @@ -764,6 +764,8 @@ handle_tls_handshake(Handle, StateName, case Handle(Packet, FsmReturn) of {next_state, NextStateName, State, _Timeout} -> handle_tls_handshake(Handle, NextStateName, State); + {next_state, NextStateName, State} -> + handle_tls_handshake(Handle, NextStateName, State); {stop, _,_} = Stop -> Stop end; diff --git a/lib/ssl/test/ssl_test_lib.erl b/lib/ssl/test/ssl_test_lib.erl index 9a76d603b1..77c29668b5 100644 --- a/lib/ssl/test/ssl_test_lib.erl +++ b/lib/ssl/test/ssl_test_lib.erl @@ -1158,23 +1158,27 @@ cipher_restriction(Config0) -> end. check_sane_openssl_version(Version) -> - case {Version, os:cmd("openssl version")} of - {_, "OpenSSL 1.0.2" ++ _} -> - true; - {_, "OpenSSL 1.0.1" ++ _} -> - true; - {'tlsv1.2', "OpenSSL 1.0" ++ _} -> - false; - {'tlsv1.1', "OpenSSL 1.0" ++ _} -> - false; - {'tlsv1.2', "OpenSSL 0" ++ _} -> - false; - {'tlsv1.1', "OpenSSL 0" ++ _} -> - false; - {_, _} -> - true + case supports_ssl_tls_version(Version) of + true -> + case {Version, os:cmd("openssl version")} of + {_, "OpenSSL 1.0.2" ++ _} -> + true; + {_, "OpenSSL 1.0.1" ++ _} -> + true; + {'tlsv1.2', "OpenSSL 1.0" ++ _} -> + false; + {'tlsv1.1', "OpenSSL 1.0" ++ _} -> + false; + {'tlsv1.2', "OpenSSL 0" ++ _} -> + false; + {'tlsv1.1', "OpenSSL 0" ++ _} -> + false; + {_, _} -> + true + end; + false -> + false end. - enough_openssl_crl_support("OpenSSL 0." ++ _) -> false; enough_openssl_crl_support(_) -> true. @@ -1198,7 +1202,9 @@ version_flag('tlsv1.1') -> version_flag('tlsv1.2') -> "-tls1_2"; version_flag(sslv3) -> - "-ssl3". + "-ssl3"; +version_flag(sslv2) -> + "-ssl2". filter_suites(Ciphers0) -> Version = tls_record:highest_protocol_version([]), @@ -1249,3 +1255,25 @@ portable_open_port(Exe, Args) -> ct:pal("open_port({spawn_executable, ~p}, [{args, ~p}, stderr_to_stdout]).", [AbsPath, Args]), open_port({spawn_executable, AbsPath}, [{args, Args}, stderr_to_stdout]). + +supports_ssl_tls_version(Version) -> + VersionFlag = version_flag(Version), + Exe = "openssl", + Args = ["s_client", VersionFlag], + Port = ssl_test_lib:portable_open_port(Exe, Args), + do_supports_ssl_tls_version(Port). + +do_supports_ssl_tls_version(Port) -> + receive + {Port, {data, "unknown option" ++ _}} -> + false; + {Port, {data, Data}} -> + case lists:member("error", string:tokens(Data, ":")) of + true -> + false; + false -> + do_supports_ssl_tls_version(Port) + end + after 500 -> + true + end. diff --git a/lib/ssl/test/ssl_to_openssl_SUITE.erl b/lib/ssl/test/ssl_to_openssl_SUITE.erl index 13523730b0..ecf6c4d6b8 100644 --- a/lib/ssl/test/ssl_to_openssl_SUITE.erl +++ b/lib/ssl/test/ssl_to_openssl_SUITE.erl @@ -175,7 +175,12 @@ special_init(TestCase, Config) check_sane_openssl_renegotaite(Config, Version); special_init(ssl2_erlang_server_openssl_client, Config) -> - check_sane_openssl_sslv2(Config); + case ssl_test_lib:supports_ssl_tls_version(sslv2) of + true -> + Config; + false -> + {skip, "sslv2 not supported by openssl"} + end; special_init(TestCase, Config) when TestCase == erlang_client_alpn_openssl_server_alpn; @@ -1440,7 +1445,7 @@ start_erlang_client_and_openssl_server_for_alpn_negotiation(Config, Data, Callba Exe = "openssl", Args = ["s_server", "-msg", "-alpn", "http/1.1,spdy/2", "-accept", integer_to_list(Port), ssl_test_lib:version_flag(Version), - "-cert", CertFile, "-key" ++ KeyFile], + "-cert", CertFile, "-key", KeyFile], OpensslPort = ssl_test_lib:portable_open_port(Exe, Args), ssl_test_lib:wait_for_openssl_server(Port), @@ -1475,7 +1480,7 @@ start_erlang_server_and_openssl_client_for_alpn_negotiation(Config, Data, Callba Version = tls_record:protocol_version(tls_record:highest_protocol_version([])), Exe = "openssl", - Args = ["s_client", "-alpn", "http/1.0,spdy/2" "-msg" "-port", + Args = ["s_client", "-alpn", "http/1.0,spdy/2", "-msg", "-port", integer_to_list(Port), ssl_test_lib:version_flag(Version), "-host", "localhost"], @@ -1507,7 +1512,7 @@ start_erlang_client_and_openssl_server_for_alpn_npn_negotiation(Config, Data, Ca Exe = "openssl", Args = ["s_server", "-msg", "-alpn", "http/1.1,spdy/2", "-nextprotoneg", "spdy/3", "-accept", integer_to_list(Port), ssl_test_lib:version_flag(Version), - "-cert" ++ CertFile ++ "-key" ++ KeyFile], + "-cert", CertFile, "-key", KeyFile], OpensslPort = ssl_test_lib:portable_open_port(Exe, Args), @@ -1756,32 +1761,6 @@ check_sane_openssl_renegotaite(Config) -> Config end. -check_sane_openssl_sslv2(Config) -> - Exe = "openssl", - Args = ["s_client", "-ssl2"], - Port = ssl_test_lib:portable_open_port(Exe, Args), - case supports_sslv2(Port) of - true -> - Config; - false -> - {skip, "sslv2 not supported by openssl"} - end. - -supports_sslv2(Port) -> - receive - {Port, {data, "unknown option -ssl2" ++ _}} -> - false; - {Port, {data, Data}} -> - case lists:member("error", string:tokens(Data, ":")) of - true -> - false; - false -> - supports_sslv2(Port) - end - after 500 -> - true - end. - workaround_openssl_s_clinent() -> %% http://bugs.debian.org/cgi-bin/bugreport.cgi?bug=683159 %% https://bugs.archlinux.org/task/33919 diff --git a/lib/ssl/vsn.mk b/lib/ssl/vsn.mk index aa1af21990..9f79a7fb34 100644 --- a/lib/ssl/vsn.mk +++ b/lib/ssl/vsn.mk @@ -1 +1 @@ -SSL_VSN = 7.2 +SSL_VSN = 7.2.1 diff --git a/lib/stdlib/src/erl_eval.erl b/lib/stdlib/src/erl_eval.erl index 568eb1c852..40a34aa30f 100644 --- a/lib/stdlib/src/erl_eval.erl +++ b/lib/stdlib/src/erl_eval.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1996-2015. All Rights Reserved. +%% Copyright Ericsson AB 1996-2016. 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. @@ -415,7 +415,7 @@ expr({call,_,{atom,_,Func},As0}, Bs0, Lf, Ef, RBs) -> {As,Bs} = expr_list(As0, Bs0, Lf, Ef), bif(Func, As, Bs, Ef, RBs); false -> - local_func(Func, As0, Bs0, Lf, RBs) + local_func(Func, As0, Bs0, Lf, Ef, RBs) end; expr({call,_,Func0,As0}, Bs0, Lf, Ef, RBs) -> % function or {Mod,Fun} {value,Func,Bs1} = expr(Func0, Bs0, Lf, Ef, none), @@ -542,33 +542,34 @@ unhide_calls([E | Es], MaxLine, D) -> unhide_calls(E, _MaxLine, _D) -> E. -%% local_func(Function, Arguments, Bindings, LocalFuncHandler, RBs) -> +%% local_func(Function, Arguments, Bindings, LocalFuncHandler, +%% ExternalFuncHandler, RBs) -> %% {value,Value,Bindings} | Value when %% LocalFuncHandler = {value,F} | {value,F,Eas} | %% {eval,F} | {eval,F,Eas} | none. -local_func(Func, As0, Bs0, {value,F}, value) -> - {As1,_Bs1} = expr_list(As0, Bs0, {value,F}), +local_func(Func, As0, Bs0, {value,F}, Ef, value) -> + {As1,_Bs1} = expr_list(As0, Bs0, {value,F}, Ef), %% Make tail recursive calls when possible. F(Func, As1); -local_func(Func, As0, Bs0, {value,F}, RBs) -> - {As1,Bs1} = expr_list(As0, Bs0, {value,F}), +local_func(Func, As0, Bs0, {value,F}, Ef, RBs) -> + {As1,Bs1} = expr_list(As0, Bs0, {value,F}, Ef), ret_expr(F(Func, As1), Bs1, RBs); -local_func(Func, As0, Bs0, {value,F,Eas}, RBs) -> +local_func(Func, As0, Bs0, {value,F,Eas}, Ef, RBs) -> Fun = fun(Name, Args) -> apply(F, [Name,Args|Eas]) end, - local_func(Func, As0, Bs0, {value, Fun}, RBs); -local_func(Func, As, Bs, {eval,F}, RBs) -> + local_func(Func, As0, Bs0, {value, Fun}, Ef, RBs); +local_func(Func, As, Bs, {eval,F}, _Ef, RBs) -> local_func2(F(Func, As, Bs), RBs); -local_func(Func, As, Bs, {eval,F,Eas}, RBs) -> +local_func(Func, As, Bs, {eval,F,Eas}, _Ef, RBs) -> local_func2(apply(F, [Func,As,Bs|Eas]), RBs); %% These two clauses are for backwards compatibility. -local_func(Func, As0, Bs0, {M,F}, RBs) -> - {As1,Bs1} = expr_list(As0, Bs0, {M,F}), +local_func(Func, As0, Bs0, {M,F}, Ef, RBs) -> + {As1,Bs1} = expr_list(As0, Bs0, {M,F}, Ef), ret_expr(M:F(Func,As1), Bs1, RBs); -local_func(Func, As, _Bs, {M,F,Eas}, RBs) -> +local_func(Func, As, _Bs, {M,F,Eas}, _Ef, RBs) -> local_func2(apply(M, F, [Func,As|Eas]), RBs); %% Default unknown function handler to undefined function. -local_func(Func, As0, _Bs0, none, _RBs) -> +local_func(Func, As0, _Bs0, none, _Ef, _RBs) -> erlang:raise(error, undef, [{erl_eval,Func,length(As0)}|stacktrace()]). local_func2({value,V,Bs}, RBs) -> diff --git a/lib/stdlib/src/erl_lint.erl b/lib/stdlib/src/erl_lint.erl index 5678e7eebe..e940ad6956 100644 --- a/lib/stdlib/src/erl_lint.erl +++ b/lib/stdlib/src/erl_lint.erl @@ -2,7 +2,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1996-2015. All Rights Reserved. +%% Copyright Ericsson AB 1996-2016. 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. @@ -100,7 +100,7 @@ value_option(Flag, Default, On, OnVal, Off, OffVal, Opts) -> %% 'called' and 'exports' contain {Line, {Function, Arity}}, %% the other function collections contain {Function, Arity}. -record(lint, {state=start :: 'start' | 'attribute' | 'function', - module=[], %Module + module='', %Module behaviour=[], %Behaviour exports=gb_sets:empty() :: gb_sets:set(fa()),%Exports imports=[] :: [fa()], %Imports, an orddict() @@ -729,7 +729,7 @@ start_state(Form, St) -> %% attribute_state(Form, State) -> %% State' -attribute_state({attribute,_L,module,_M}, #lint{module=[]}=St) -> +attribute_state({attribute,_L,module,_M}, #lint{module=''}=St) -> St; attribute_state({attribute,L,module,_M}, St) -> add_error(L, redefine_module, St); diff --git a/lib/stdlib/src/otp_internal.erl b/lib/stdlib/src/otp_internal.erl index 2d77888512..c254ab1e46 100644 --- a/lib/stdlib/src/otp_internal.erl +++ b/lib/stdlib/src/otp_internal.erl @@ -648,6 +648,9 @@ obsolete_1(httpd_conf, is_file, 1) -> obsolete_1(httpd_conf, make_integer, 1) -> {deprecated, "deprecated; use erlang:list_to_integer/1 instead"}; +obsolete_1(overload, _, _) -> + {deprecated, "deprecated; will be removed in OTP 19"}; + obsolete_1(_, _, _) -> no. diff --git a/lib/stdlib/test/erl_eval_SUITE.erl b/lib/stdlib/test/erl_eval_SUITE.erl index 50fc62a00e..c21c4e61ee 100644 --- a/lib/stdlib/test/erl_eval_SUITE.erl +++ b/lib/stdlib/test/erl_eval_SUITE.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1998-2013. All Rights Reserved. +%% Copyright Ericsson AB 1998-2016. 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. @@ -39,6 +39,7 @@ otp_7550/1, otp_8133/1, otp_10622/1, + otp_13228/1, funs/1, try_catch/1, eval_expr_5/1, @@ -83,7 +84,8 @@ all() -> pattern_expr, match_bin, guard_3, guard_4, guard_5, lc, simple_cases, unary_plus, apply_atom, otp_5269, otp_6539, otp_6543, otp_6787, otp_6977, otp_7550, - otp_8133, otp_10622, funs, try_catch, eval_expr_5, zero_width, + otp_8133, otp_10622, otp_13228, + funs, try_catch, eval_expr_5, zero_width, eep37, eep43]. groups() -> @@ -1042,6 +1044,13 @@ otp_10622(Config) when is_list(Config) -> ok. +otp_13228(doc) -> + ["OTP-13228. ERL-32: non-local function handler bug."]; +otp_13228(_Config) -> + LFH = {value, fun(foo, [io_fwrite]) -> worked end}, + EFH = {value, fun({io, fwrite}, [atom]) -> io_fwrite end}, + {value, worked, []} = parse_and_run("foo(io:fwrite(atom)).", LFH, EFH). + funs(doc) -> ["Simple cases, just to cover some code."]; funs(suite) -> diff --git a/lib/stdlib/test/erl_lint_SUITE.erl b/lib/stdlib/test/erl_lint_SUITE.erl index 5347ccaf1f..375fb6bc93 100644 --- a/lib/stdlib/test/erl_lint_SUITE.erl +++ b/lib/stdlib/test/erl_lint_SUITE.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1999-2015. All Rights Reserved. +%% Copyright Ericsson AB 1999-2016. 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. @@ -65,7 +65,7 @@ too_many_arguments/1, basic_errors/1,bin_syntax_errors/1, predef/1, - maps/1,maps_type/1,otp_11851/1,otp_12195/1 + maps/1,maps_type/1,otp_11851/1,otp_12195/1, otp_13230/1 ]). % Default timetrap timeout (set in init_per_testcase). @@ -94,7 +94,7 @@ all() -> bif_clash, behaviour_basic, behaviour_multiple, otp_11861, otp_7550, otp_8051, format_warn, {group, on_load}, too_many_arguments, basic_errors, bin_syntax_errors, predef, - maps, maps_type, otp_11851, otp_12195]. + maps, maps_type, otp_11851, otp_12195, otp_13230]. groups() -> [{unused_vars_warn, [], @@ -3877,6 +3877,15 @@ otp_12195(Config) when is_list(Config) -> [] = run(Config, Ts), ok. +otp_13230(doc) -> + "OTP-13230: -deprecated without -module"; +otp_13230(Config) when is_list(Config) -> + Abstr = <<"-deprecated([{frutt,0,next_version}]).">>, + {errors,[{1,erl_lint,undefined_module}, + {1,erl_lint,{bad_deprecated,{frutt,0}}}], + []} = run_test2(Config, Abstr, []), + ok. + run(Config, Tests) -> F = fun({N,P,Ws,E}, BadL) -> case catch run_test(Config, P, Ws) of diff --git a/lib/tools/src/cover.erl b/lib/tools/src/cover.erl index 366d6bcbd9..0ae5c7978d 100644 --- a/lib/tools/src/cover.erl +++ b/lib/tools/src/cover.erl @@ -1474,7 +1474,7 @@ do_compile_beam(Module,BeamFile0,State) -> {ok,Module,BeamFile}; error -> {error, BeamFile}; - {error,Reason} -> % no abstract code + {error,Reason} -> % no abstract code or no 'file' attribute {error, {Reason, BeamFile}} end; {error,no_beam} -> @@ -1537,32 +1537,11 @@ do_compile_beam1(Module,Beam,UserOptions) -> {error,E}; {raw_abstract_v1,Code} -> Forms0 = epp:interpret_file_attribute(Code), - {Forms,Vars} = transform(Forms0, Module), - - %% We need to recover the source from the compilation - %% info otherwise the newly compiled module will have - %% source pointing to the current directory - SourceInfo = get_source_info(Module, Beam), - - %% Compile and load the result - %% It's necessary to check the result of loading since it may - %% fail, for example if Module resides in a sticky directory - {ok, Module, Binary} = compile:forms(Forms, SourceInfo ++ UserOptions), - case code:load_binary(Module, ?TAG, Binary) of - {module, Module} -> - - %% Store info about all function clauses in database - InitInfo = lists:reverse(Vars#vars.init_info), - ets:insert(?COVER_CLAUSE_TABLE, {Module, InitInfo}), - - %% Store binary code so it can be loaded on remote nodes - ets:insert(?BINARY_TABLE, {Module, Binary}), - - {ok, Module}; - - _Error -> - do_clear(Module), - error + case find_main_filename(Forms0) of + {ok,MainFile} -> + do_compile_beam2(Module,Beam,UserOptions,Forms0,MainFile); + Error -> + Error end; {_VSN,_Code} -> %% Wrong version of abstract code. Just report that there @@ -1579,6 +1558,35 @@ get_abstract_code(Module, Beam) -> Error -> Error end. +do_compile_beam2(Module,Beam,UserOptions,Forms0,MainFile) -> + {Forms,Vars} = transform(Forms0, Module, MainFile), + + %% We need to recover the source from the compilation + %% info otherwise the newly compiled module will have + %% source pointing to the current directory + SourceInfo = get_source_info(Module, Beam), + + %% Compile and load the result + %% It's necessary to check the result of loading since it may + %% fail, for example if Module resides in a sticky directory + {ok, Module, Binary} = compile:forms(Forms, SourceInfo ++ UserOptions), + case code:load_binary(Module, ?TAG, Binary) of + {module, Module} -> + + %% Store info about all function clauses in database + InitInfo = lists:reverse(Vars#vars.init_info), + ets:insert(?COVER_CLAUSE_TABLE, {Module, InitInfo}), + + %% Store binary code so it can be loaded on remote nodes + ets:insert(?BINARY_TABLE, {Module, Binary}), + + {ok, Module}; + + _Error -> + do_clear(Module), + error + end. + get_source_info(Module, Beam) -> Compile = get_compile_info(Module, Beam), case lists:keyfind(source, 1, Compile) of @@ -1601,8 +1609,7 @@ get_compile_info(Module, Beam) -> [] end. -transform(Code, Module) -> - MainFile=find_main_filename(Code), +transform(Code, Module, MainFile) -> Vars0 = #vars{module=Module}, {ok,MungedForms,Vars} = transform_2(Code,[],Vars0,MainFile,on), {MungedForms,Vars}. @@ -1610,9 +1617,12 @@ transform(Code, Module) -> %% Helpfunction which returns the first found file-attribute, which can %% be interpreted as the name of the main erlang source file. find_main_filename([{attribute,_,file,{MainFile,_}}|_]) -> - MainFile; + {ok,MainFile}; find_main_filename([_|Rest]) -> - find_main_filename(Rest). + find_main_filename(Rest); +find_main_filename([]) -> + {error, no_file_attribute}. + transform_2([Form0|Forms],MungedForms,Vars,MainFile,Switch) -> Form = expand(Form0), diff --git a/lib/tools/test/cover_SUITE.erl b/lib/tools/test/cover_SUITE.erl index 25c9317608..483ea9774e 100644 --- a/lib/tools/test/cover_SUITE.erl +++ b/lib/tools/test/cover_SUITE.erl @@ -19,43 +19,16 @@ %% -module(cover_SUITE). --export([all/0, init_per_testcase/2, end_per_testcase/2, - suite/0,groups/0,init_per_suite/1, end_per_suite/1, - init_per_group/2,end_per_group/2]). - --export([coverage/1, coverage_analysis/1, - start/1, compile/1, analyse/1, misc/1, stop/1, - distribution/1, reconnect/1, die_and_reconnect/1, - dont_reconnect_after_stop/1, stop_node_after_disconnect/1, - export_import/1, - otp_5031/1, eif/1, otp_5305/1, otp_5418/1, otp_6115/1, otp_7095/1, - otp_8188/1, otp_8270/1, otp_8273/1, otp_8340/1, - otp_10979_hanging_node/1, compile_beam_opts/1, eep37/1, - analyse_no_beam/1, line_0/1]). - --export([do_coverage/1]). - --export([distribution_performance/1]). +-compile(export_all). -include_lib("test_server/include/test_server.hrl"). -%%---------------------------------------------------------------------- -%% The following directory structure is assumed: -%% cwd __________________________________________ -%% | \ \ \ \ \ \ \ -%% a b cc d f d1 compile_beam_____ otp_6115 -%% | \ \ \ \ \ \ \ -%% e crypt v w x d f1 f2 -%% | -%% y -%%---------------------------------------------------------------------- - suite() -> [{ct_hooks,[ts_install_cth]}]. all() -> NoStartStop = [eif,otp_5305,otp_5418,otp_7095,otp_8273, otp_8340,otp_8188,compile_beam_opts,eep37, - analyse_no_beam, line_0], + analyse_no_beam, line_0, compile_beam_no_file], StartStop = [start, compile, analyse, misc, stop, distribution, reconnect, die_and_reconnect, dont_reconnect_after_stop, stop_node_after_disconnect, @@ -778,8 +751,8 @@ distribution_performance(Config) -> %% [{ok,_} = cover:compile_beam(Mod) || Mod <- Mods] %% end, CFun = fun() -> cover:compile_beam(Mods) end, - {CT,CA} = timer:tc(CFun), -% erlang:display(CA), + {CT,_CA} = timer:tc(CFun), +% erlang:display(_CA), erlang:display({compile,CT}), {SNT,_} = timer:tc(fun() -> {ok,[N1]} = cover:start(nodes()) end), @@ -799,7 +772,7 @@ distribution_performance(Config) -> % Fun = fun() -> cover:reset() end, - {AT,A} = timer:tc(Fun), + {AT,_A} = timer:tc(Fun), erlang:display({analyse,AT}), % erlang:display(lists:sort([X || X={_MFA,N} <- lists:append([L || {ok,L}<-A]), N=/=0])), @@ -1746,6 +1719,32 @@ line_0(Config) -> ok. +%% OTP-13200: Return error instead of crashing when trying to compile +%% a beam which has no 'file' attribute. +compile_beam_no_file(Config) -> + PrivDir = ?config(priv_dir,Config), + Dir = filename:join(PrivDir,"compile_beam_no_file"), + ok = filelib:ensure_dir(filename:join(Dir,"*")), + code:add_patha(Dir), + Str = lists:concat( + ["-module(nofile).\n" + "-compile(export_all).\n" + "foo() -> ok.\n"]), + TT = do_scan(Str), + Forms = [ begin {ok,Y} = erl_parse:parse_form(X),Y end || X <- TT ], + {ok,_,Bin} = compile:forms(Forms,[debug_info]), + BeamFile = filename:join(Dir,"nofile.beam"), + ok = file:write_file(BeamFile,Bin), + {error,{no_file_attribute,BeamFile}} = cover:compile_beam(nofile), + [{error,{no_file_attribute,BeamFile}}] = cover:compile_beam_directory(Dir), + ok. + +do_scan([]) -> + []; +do_scan(Str) -> + {done,{ok,T,_},C} = erl_scan:tokens([],Str,0), + [ T | do_scan(C) ]. + %%--Auxiliary------------------------------------------------------------ diff --git a/lib/tools/test/cover_SUITE_data/cc.erl b/lib/tools/test/cover_SUITE_data/cc.erl index 587bdbe493..7eb165ef8a 100644 --- a/lib/tools/test/cover_SUITE_data/cc.erl +++ b/lib/tools/test/cover_SUITE_data/cc.erl @@ -1,88 +1,17 @@ -module(cc). --export([epp/1, epp/2, dbg/1, dbg/2, cvr/1, cvr/2]). --export([p/2, pp/2]). +-compile(export_all). -%% epp(Module) - Creates Module.epp which contains all forms of Module -%% as obtained by using epp. -%% -%% dbg(Module) - Creates Module.dbg which contains all forms of Module -%% as obtained by using beam_lib:chunks/2. -%% -%% cvr(Module) - Creates Module.cvr which contains all forms of Module -%% as obtained by using cover:transform/3. -%% +%% This is a dummy module used only for cover compiling. The content +%% of this module has no meaning for the test. -epp(Module) -> - epp(Module, p). -epp(Module, P) -> - File = atom_to_list(Module)++".erl", - {ok,Cwd} = file:get_cwd(), - {ok, Fd1} = epp:open(File, [Cwd], []), - {ok, Fd2} = file:open(atom_to_list(Module)++".epp", write), +foo() -> + T = erlang:time(), + spawn(fun() -> bar(T) end). - epp(Fd1, Fd2, P), - - epp:close(Fd1), - file:close(Fd2), - ok. - -epp(Fd1, Fd2, P) -> - case epp:parse_erl_form(Fd1) of - {ok, {attribute,Line,Attr,Data}} -> - epp(Fd1, Fd2, P); - {ok, Form} when P==p -> - io:format(Fd2, "~p.~n", [Form]), - epp(Fd1, Fd2, P); - {ok, Form} when P==pp -> - io:format(Fd2, "~p.~n", [erl_pp:form(Form)]), - epp(Fd1, Fd2, P); - {eof, Line} -> - ok - end. - -cvr(Module) -> - cvr(Module, p). -cvr(Module, P) -> - case beam_lib:chunks(Module, [abstract_code]) of - {ok, {Module, [{abstract_code, no_abstract_code}]}} -> - {error, {no_debug_info,Module}}; - {ok, {Module, [{abstract_code, {Vsn, Forms}}]}} -> - Vars = {vars,Module,Vsn, [], - undefined, undefined, undefined, undefined, undefined, - undefined, - false}, - {ok, TForms, _Vars2} = cover:transform(Forms, [], Vars), - File = atom_to_list(Module)++".cvr", - apply(?MODULE, P, [File, TForms]); - Error -> - Error +bar(T) -> + receive + X -> + T1 = erlang:time(), + io:format("received ~p at ~p. Last time: ~p~n",[X,T1,T]), + bar(T1) end. - -dbg(Module) -> - dbg(Module, p). -dbg(Module, P) -> - case beam_lib:chunks(Module, [abstract_code]) of - {ok, {Module, [{abstract_code, no_abstract_code}]}} -> - {error, {no_debug_info,Module}}; - {ok, {Module, [{abstract_code, {Vsn, Forms}}]}} -> - File = atom_to_list(Module)++".dbg", - apply(?MODULE, P, [File, Forms]); - Error -> - Error - end. - -p(File, Forms) -> - {ok, Fd} = file:open(File, write), - lists:foreach(fun(Form) -> - io:format(Fd, "~p.~n", [Form]) - end, - Forms), - file:close(Fd). - -pp(File, Forms) -> - {ok, Fd} = file:open(File, write), - lists:foreach(fun(Form) -> - io:format(Fd, "~s", [erl_pp:form(Form)]) - end, - Forms), - file:close(Fd). |