diff options
Diffstat (limited to 'lib')
252 files changed, 6269 insertions, 3014 deletions
diff --git a/lib/asn1/test/asn1_SUITE.erl b/lib/asn1/test/asn1_SUITE.erl index b98a704e28..bfeffa969f 100644 --- a/lib/asn1/test/asn1_SUITE.erl +++ b/lib/asn1/test/asn1_SUITE.erl @@ -1355,8 +1355,8 @@ xref_export_all(_Config) -> [] -> ok; [_|_] -> - S = [io_lib:format("~p:~p/~p\n", [M,F,A]) || {M,F,A} <- Unused], - io:format("There are unused functions:\n\n~s\n", [S]), + Msg = [io_lib:format("~p:~p/~p\n", [M,F,A]) || {M,F,A} <- Unused], + io:format("There are unused functions:\n\n~s\n", [Msg]), ?t:fail(unused_functions) end. diff --git a/lib/common_test/src/ct.erl b/lib/common_test/src/ct.erl index 69e371a30f..fd7fa07b81 100644 --- a/lib/common_test/src/ct.erl +++ b/lib/common_test/src/ct.erl @@ -872,8 +872,8 @@ fail(Reason) -> try exit({test_case_failed,Reason}) catch - Class:R -> - case erlang:get_stacktrace() of + Class:R:S -> + case S of [{?MODULE,fail,1,_}|Stk] -> ok; Stk -> ok end, @@ -894,8 +894,8 @@ fail(Format, Args) -> try exit({test_case_failed,lists:flatten(Str)}) catch - Class:R -> - case erlang:get_stacktrace() of + Class:R:S -> + case S of [{?MODULE,fail,2,_}|Stk] -> ok; Stk -> ok end, diff --git a/lib/common_test/src/ct_hooks.erl b/lib/common_test/src/ct_hooks.erl index f0592a40be..bb33f0243b 100644 --- a/lib/common_test/src/ct_hooks.erl +++ b/lib/common_test/src/ct_hooks.erl @@ -233,8 +233,7 @@ call([{Hook, call_id, NextFun} | Rest], Config, Meta, Hooks) -> Rest ++ [{NewId, call_init}, {NewId,NextFun}]} end, call(resort(NewRest,NewHooks,Meta), Config, Meta, NewHooks) - catch Error:Reason -> - Trace = erlang:get_stacktrace(), + catch Error:Reason:Trace -> ct_logs:log("Suite Hook","Failed to start a CTH: ~tp:~tp", [Error,{Reason,Trace}]), call([], {fail,"Failed to start CTH" @@ -422,8 +421,7 @@ catch_apply(M,F,A, Default, Fallback) -> catch_apply(M,F,A) -> try erlang:apply(M,F,A) - catch _:Reason -> - Trace = erlang:get_stacktrace(), + catch _:Reason:Trace -> ct_logs:log("Suite Hook","Call to CTH failed: ~w:~tp", [error,{Reason,Trace}]), throw({error_in_cth_call, diff --git a/lib/common_test/src/ct_run.erl b/lib/common_test/src/ct_run.erl index 8c401cf3f5..afc5fee4f7 100644 --- a/lib/common_test/src/ct_run.erl +++ b/lib/common_test/src/ct_run.erl @@ -442,11 +442,9 @@ script_start2(Opts = #opts{vts = undefined, TestSpecData -> execute_all_specs(TestSpecData, Opts, Args, []) catch - throw:{error,Reason} -> - StackTrace = erlang:get_stacktrace(), + throw:{error,Reason}:StackTrace -> {error,{invalid_testspec,{Reason,StackTrace}}}; - _:Reason -> - StackTrace = erlang:get_stacktrace(), + _:Reason:StackTrace -> {error,{invalid_testspec,{Reason,StackTrace}}} end; [] -> @@ -1211,11 +1209,9 @@ run_spec_file(Relaxed, TestSpecData -> run_all_specs(TestSpecData, Opts, StartOpts, []) catch - throw:{error,CTReason} -> - StackTrace = erlang:get_stacktrace(), + throw:{error,CTReason}:StackTrace -> exit({error,{invalid_testspec,{CTReason,StackTrace}}}); - _:CTReason -> - StackTrace = erlang:get_stacktrace(), + _:CTReason:StackTrace -> exit({error,{invalid_testspec,{CTReason,StackTrace}}}) end. diff --git a/lib/common_test/src/ct_testspec.erl b/lib/common_test/src/ct_testspec.erl index bb445bb0d2..bd3755722f 100644 --- a/lib/common_test/src/ct_testspec.erl +++ b/lib/common_test/src/ct_testspec.erl @@ -1425,7 +1425,12 @@ skip_groups1(Suite,Groups,Cmt,Suites0) -> GrAndCases1 = GrAndCases0 ++ SkipGroups, insert_in_order({Suite,GrAndCases1},Suites0,replace); false -> - insert_in_order({Suite,SkipGroups},Suites0,replace) + case Suites0 of + [{all,_}=All|Skips]-> + [All|Skips++[{Suite,SkipGroups}]]; + _ -> + insert_in_order({Suite,SkipGroups},Suites0,replace) + end end. skip_cases(Node,Dir,Suite,Cases,Cmt,Tests,false) when is_list(Cases) -> diff --git a/lib/common_test/src/ct_util.erl b/lib/common_test/src/ct_util.erl index 10a06d5c88..e904bb1e7c 100644 --- a/lib/common_test/src/ct_util.erl +++ b/lib/common_test/src/ct_util.erl @@ -209,11 +209,10 @@ do_start(Parent, Mode, LogDir, Verbosity) -> self() ! {{stop,{self(),{user_error,CTHReason}}}, {Parent,make_ref()}} catch - _:CTHReason -> + _:CTHReason:StackTrace -> ErrorInfo = if is_atom(CTHReason) -> io_lib:format("{~tp,~tp}", - [CTHReason, - erlang:get_stacktrace()]); + [CTHReason, StackTrace]); true -> CTHReason end, diff --git a/lib/common_test/src/test_server.erl b/lib/common_test/src/test_server.erl index 7250041e13..9469619aa9 100644 --- a/lib/common_test/src/test_server.erl +++ b/lib/common_test/src/test_server.erl @@ -1340,13 +1340,12 @@ do_init_per_testcase(Mod, Args) -> {skip,Reason}; exit:{Skip,Reason} when Skip =:= skip; Skip =:= skipped -> {skip,Reason}; - throw:Other -> - set_loc(erlang:get_stacktrace()), + throw:Other:Stk -> + set_loc(Stk), Line = get_loc(), print_init_conf_result(Line,"thrown",Other), {skip,{failed,{Mod,init_per_testcase,Other}}}; - _:Reason0 -> - Stk = erlang:get_stacktrace(), + _:Reason0:Stk -> Reason = {Reason0,Stk}, set_loc(Stk), Line = get_loc(), @@ -1395,20 +1394,19 @@ do_end_per_testcase(Mod,EndFunc,Func,Conf) -> _ -> ok catch - throw:Other -> + throw:Other:Stk -> Comment0 = case read_comment() of "" -> ""; Cmt -> Cmt ++ test_server_ctrl:xhtml("<br>", "<br />") end, - set_loc(erlang:get_stacktrace()), + set_loc(Stk), comment(io_lib:format("~ts<font color=\"red\">" "WARNING: ~w thrown!" "</font>\n",[Comment0,EndFunc])), print_end_tc_warning(EndFunc,Other,"thrown",get_loc()), {failed,{Mod,end_per_testcase,Other}}; - Class:Reason -> - Stk = erlang:get_stacktrace(), + Class:Reason:Stk -> set_loc(Stk), Why = case Class of exit -> {'EXIT',Reason}; @@ -1550,8 +1548,7 @@ ts_tc(M, F, A) -> throw:{skipped, Reason} -> {skip, Reason}; exit:{skip, Reason} -> {skip, Reason}; exit:{skipped, Reason} -> {skip, Reason}; - Type:Reason -> - Stk = erlang:get_stacktrace(), + Type:Reason:Stk -> set_loc(Stk), case Type of throw -> @@ -1740,8 +1737,8 @@ fail(Reason) -> try exit({suite_failed,Reason}) catch - Class:R -> - case erlang:get_stacktrace() of + Class:R:Stacktrace -> + case Stacktrace of [{?MODULE,fail,1,_}|Stk] -> ok; Stk -> ok end, @@ -1763,8 +1760,8 @@ fail() -> try exit(suite_failed) catch - Class:R -> - case erlang:get_stacktrace() of + Class:R:Stacktrace -> + case Stacktrace of [{?MODULE,fail,0,_}|Stk] -> ok; Stk -> ok end, @@ -2043,15 +2040,15 @@ call_user_timetrap(Func, Sup) when is_function(Func) -> try Func() of Result -> Sup ! {self(),Result} - catch _:Error -> - exit({Error,erlang:get_stacktrace()}) + catch _:Error:Stk -> + exit({Error,Stk}) end; call_user_timetrap({M,F,A}, Sup) -> try apply(M,F,A) of Result -> Sup ! {self(),Result} - catch _:Error -> - exit({Error,erlang:get_stacktrace()}) + catch _:Error:Stk -> + exit({Error,Stk}) end. save_user_timetrap(TCPid, UserTTSup, StartTime) -> diff --git a/lib/common_test/src/test_server_sup.erl b/lib/common_test/src/test_server_sup.erl index 6ddbf1ad27..139621141d 100644 --- a/lib/common_test/src/test_server_sup.erl +++ b/lib/common_test/src/test_server_sup.erl @@ -781,8 +781,8 @@ framework_call(Callback,Func,Args,DefaultReturn) -> catch exit:Why -> EH(Why); - error:Why -> - EH({Why,erlang:get_stacktrace()}); + error:Why:Stacktrace -> + EH({Why,Stacktrace}); throw:Why -> EH(Why) end; diff --git a/lib/common_test/test/ct_netconfc_SUITE_data/ns.erl b/lib/common_test/test/ct_netconfc_SUITE_data/ns.erl index 63bf9be134..975f6cafcb 100644 --- a/lib/common_test/test/ct_netconfc_SUITE_data/ns.erl +++ b/lib/common_test/test/ct_netconfc_SUITE_data/ns.erl @@ -231,8 +231,7 @@ data_for_channel(CM, Ch, Data, State) -> {ok, NewState} end catch - Class:Reason -> - Stacktrace = erlang:get_stacktrace(), + Class:Reason:Stacktrace -> error_logger:error_report([{?MODULE, data_for_channel}, {request, Data}, {buffer, State#session.buffer}, diff --git a/lib/common_test/test/ct_unicode_SUITE_data/unicode_atoms_SUITE.erl b/lib/common_test/test/ct_unicode_SUITE_data/unicode_atoms_SUITE.erl index 993452500e..041c13cdbd 100644 --- a/lib/common_test/test/ct_unicode_SUITE_data/unicode_atoms_SUITE.erl +++ b/lib/common_test/test/ct_unicode_SUITE_data/unicode_atoms_SUITE.erl @@ -77,7 +77,7 @@ all() -> 'fail_αβ_4'(_Config) -> ct:log("This is test case ~tw",[?FUNCTION_NAME]), - S = try throw(ok) catch throw:ok -> erlang:get_stacktrace() end, + S = try throw(ok) catch throw:ok:Stacktrace -> Stacktrace end, erlang:raise(error,{error,testcase,?FUNCTION_NAME},S), ok. diff --git a/lib/common_test/test_server/ts_install_cth.erl b/lib/common_test/test_server/ts_install_cth.erl index 5d325b1115..35a5ec916c 100644 --- a/lib/common_test/test_server/ts_install_cth.erl +++ b/lib/common_test/test_server/ts_install_cth.erl @@ -108,8 +108,7 @@ pre_init_per_suite(_Suite,Config,State) -> {add_node_name(Config, State), State} catch error:{badmatch,{error,enoent}} -> {add_node_name(Config, State), State}; - Error:Reason -> - Stack = erlang:get_stacktrace(), + Error:Reason:Stack -> ct:pal("~p failed! ~p:{~p,~p}",[?MODULE,Error,Reason,Stack]), {{fail,{?MODULE,{Error,Reason, Stack}}},State} end. diff --git a/lib/compiler/src/beam_a.erl b/lib/compiler/src/beam_a.erl index 7df2edd714..91acb19971 100644 --- a/lib/compiler/src/beam_a.erl +++ b/lib/compiler/src/beam_a.erl @@ -61,6 +61,14 @@ rename_instrs([{'%live',_}|Is]) -> %% Ignore old type of live annotation. Only happens when compiling %% from very old .S files. rename_instrs(Is); +rename_instrs([{get_list,S,D1,D2}|Is]) -> + %% Only happens when compiling from old .S files. + if + D1 =:= S -> + [{get_tl,S,D2},{get_hd,S,D1}|rename_instrs(Is)]; + true -> + [{get_hd,S,D1},{get_tl,S,D2}|rename_instrs(Is)] + end; rename_instrs([I|Is]) -> [rename_instr(I)|rename_instrs(Is)]; rename_instrs([]) -> []. diff --git a/lib/compiler/src/beam_asm.erl b/lib/compiler/src/beam_asm.erl index 453e00fce3..fa919ca862 100644 --- a/lib/compiler/src/beam_asm.erl +++ b/lib/compiler/src/beam_asm.erl @@ -407,7 +407,17 @@ encode_arg({atom, Atom}, Dict0) when is_atom(Atom) -> {Index, Dict} = beam_dict:atom(Atom, Dict0), {encode(?tag_a, Index), Dict}; encode_arg({integer, N}, Dict) -> - {encode(?tag_i, N), Dict}; + %% Conservatily assume that all integers whose absolute + %% value is greater than 1 bsl 128 will be bignums in + %% the runtime system. + if + N >= 1 bsl 128 -> + encode_arg({literal, N}, Dict); + N =< -(1 bsl 128) -> + encode_arg({literal, N}, Dict); + true -> + {encode(?tag_i, N), Dict} + end; encode_arg(nil, Dict) -> {encode(?tag_a, 0), Dict}; encode_arg({f, W}, Dict) -> diff --git a/lib/compiler/src/beam_block.erl b/lib/compiler/src/beam_block.erl index 39ae8d5347..47a2be8ab5 100644 --- a/lib/compiler/src/beam_block.erl +++ b/lib/compiler/src/beam_block.erl @@ -36,19 +36,18 @@ module({Mod,Exp,Attr,Fs0,Lc}, Opts) -> function({function,Name,Arity,CLabel,Is0}, Blockify) -> try %% Collect basic blocks and optimize them. - Is2 = case Blockify of - true -> - Is1 = blockify(Is0), - embed_lines(Is1); - false -> - Is0 + Is1 = case Blockify of + false -> Is0; + true -> blockify(Is0) end, - Is3 = beam_utils:anno_defs(Is2), - Is4 = move_allocates(Is3), - Is5 = beam_utils:live_opt(Is4), - Is6 = opt_blocks(Is5), - Is7 = beam_utils:delete_annos(Is6), - Is = opt_allocs(Is7), + Is2 = embed_lines(Is1), + Is3 = local_cse(Is2), + Is4 = beam_utils:anno_defs(Is3), + Is5 = move_allocates(Is4), + Is6 = beam_utils:live_opt(Is5), + Is7 = opt_blocks(Is6), + Is8 = beam_utils:delete_annos(Is7), + Is = opt_allocs(Is8), %% Done. {function,Name,Arity,CLabel,Is} @@ -109,7 +108,8 @@ collect({put_tuple,A,D}) -> {set,[D],[],{put_tuple,A}}; collect({put,S}) -> {set,[],[S],put}; collect({get_tuple_element,S,I,D}) -> {set,[D],[S],{get_tuple_element,I}}; collect({set_tuple_element,S,D,I}) -> {set,[],[S,D],{set_tuple_element,I}}; -collect({get_list,S,D1,D2}) -> {set,[D1,D2],[S],get_list}; +collect({get_hd,S,D}) -> {set,[D],[S],get_hd}; +collect({get_tl,S,D}) -> {set,[D],[S],get_tl}; collect(remove_message) -> {set,[],[],remove_message}; collect({put_map,F,Op,S,D,R,{list,Puts}}) -> {set,[D],[S|Puts],{alloc,R,{put_map,Op,F}}}; @@ -137,6 +137,11 @@ embed_lines([{block,B2},{line,_}=Line,{block,B1}|T], Acc) -> embed_lines([{block,B1},{line,_}=Line|T], Acc) -> B = {block,[{set,[],[],Line}|B1]}, embed_lines([B|T], Acc); +embed_lines([{block,B2},{block,B1}|T], Acc) -> + %% This can only happen when beam_block is run for + %% the second time. + B = {block,B1++B2}, + embed_lines([B|T], Acc); embed_lines([I|Is], Acc) -> embed_lines(Is, [I|Acc]); embed_lines([], Acc) -> Acc. @@ -204,7 +209,7 @@ move_allocates([]) -> []. move_allocates_1([{'%anno',_}|Is], Acc) -> move_allocates_1(Is, Acc); -move_allocates_1([I|Is], [{set,[],[],{alloc,Live0,Info}}|Acc]=Acc0) -> +move_allocates_1([I|Is], [{set,[],[],{alloc,Live0,Info0}}|Acc]=Acc0) -> case alloc_may_pass(I) of false -> move_allocates_1(Is, [I|Acc0]); @@ -213,6 +218,7 @@ move_allocates_1([I|Is], [{set,[],[],{alloc,Live0,Info}}|Acc]=Acc0) -> not_possible -> move_allocates_1(Is, [I|Acc0]); Live when is_integer(Live) -> + Info = safe_info(Info0), A = {set,[],[],{alloc,Live,Info}}, move_allocates_1(Is, [A,I|Acc]) end @@ -221,17 +227,25 @@ move_allocates_1([I|Is], Acc) -> move_allocates_1(Is, [I|Acc]); move_allocates_1([], Acc) -> Acc. +alloc_may_pass({set,_,[{fr,_}],fmove}) -> false; alloc_may_pass({set,_,_,{alloc,_,_}}) -> false; alloc_may_pass({set,_,_,{set_tuple_element,_}}) -> false; alloc_may_pass({set,_,_,put_list}) -> false; alloc_may_pass({set,_,_,put}) -> false; alloc_may_pass({set,_,_,_}) -> true. +safe_info({nozero,Stack,Heap,_}) -> + %% nozero is not safe if the allocation instruction is moved + %% upwards past an instruction that may throw an exception + %% (such as element/2). + {zero,Stack,Heap,[]}; +safe_info(Info) -> Info. + %% opt([Instruction]) -> [Instruction] %% Optimize the instruction stream inside a basic block. opt([{set,[X],[X],move}|Is]) -> opt(Is); -opt([{set,[X],_,move},{set,[X],_,move}=I|Is]) -> +opt([{set,[Dst],_,move},{set,[Dst],[Src],move}=I|Is]) when Dst =/= Src -> opt([I|Is]); opt([{set,[{x,0}],[S1],move}=I1,{set,[D2],[{x,0}],move}|Is]) -> opt([I1,{set,[D2],[S1],move}|Is]); @@ -250,6 +264,16 @@ opt([{set,[D1],[{integer,Idx1},Reg],{bif,element,{f,L}}}=I1, {set,[D2],[{integer,Idx2},Reg],{bif,element,{f,L}}}=I2|Is]) when Idx1 < Idx2, D1 =/= D2, D1 =/= Reg, D2 =/= Reg -> opt([I2,I1|Is]); +opt([{set,Hd0,Cons,get_hd}=GetHd, + {set,Tl0,Cons,get_tl}=GetTl|Is0]) -> + case {opt_moves(Hd0, [GetTl|Is0]),opt_moves(Tl0, [GetHd|Is0])} of + {{Hd0,Is},{Tl0,_}} -> + [GetHd|opt(Is)]; + {{Hd,Is},{Tl0,_}} -> + [{set,Hd,Cons,get_hd}|opt(Is)]; + {{_,_},{Tl,Is}} -> + [{set,Tl,Cons,get_tl}|opt(Is)] + end; opt([{set,Ds0,Ss,Op}|Is0]) -> {Ds,Is} = opt_moves(Ds0, Is0), [{set,Ds,Ss,Op}|opt(Is)]; @@ -265,17 +289,6 @@ opt_moves([D0]=Ds, Is0) -> case opt_move(D0, Is0) of not_possible -> {Ds,Is0}; {D1,Is} -> {[D1],Is} - end; -opt_moves([X0,Y0], Is0) -> - {X,Is2} = case opt_move(X0, Is0) of - not_possible -> {X0,Is0}; - {Y0,_} -> {X0,Is0}; - {_X1,_Is1} = XIs1 -> XIs1 - end, - case opt_move(Y0, Is2) of - not_possible -> {[X,Y0],Is2}; - {X,_} -> {[X,Y0],Is2}; - {Y,Is} -> {[X,Y],Is} end. %% opt_move(Dest, [Instruction]) -> {UpdatedDest,[Instruction]} | not_possible @@ -289,7 +302,7 @@ opt_move(Dest, Is) -> opt_move_1(R, [{set,[D],[R],move}|Is0], Acc) -> %% Provided that the source register is killed by instructions %% that follow, the optimization is safe. - case eliminate_use_of_from_reg(Is0, R, D, []) of + case eliminate_use_of_from_reg(Is0, R, D) of {yes,Is} -> opt_move_rev(D, Acc, Is); no -> not_possible end; @@ -347,7 +360,7 @@ opt_tuple_element_1([{set,_,_,{alloc,_,_}}|_], _, _, _) -> opt_tuple_element_1([{set,_,_,{try_catch,_,_}}|_], _, _, _) -> no; opt_tuple_element_1([{set,[D],[S],move}|Is0], I0, {_,S}, Acc) -> - case eliminate_use_of_from_reg(Is0, S, D, []) of + case eliminate_use_of_from_reg(Is0, S, D) of no -> no; {yes,Is} -> @@ -389,6 +402,14 @@ is_killed_or_used(R, {set,Ss,Ds,_}) -> %% that FromRegister is still used and that the optimization is not %% possible. +eliminate_use_of_from_reg(Is, From, To) -> + try + eliminate_use_of_from_reg(Is, From, To, []) + catch + throw:not_possible -> + no + end. + eliminate_use_of_from_reg([{set,_,_,{alloc,Live,_}}|_]=Is0, {x,X}, _, Acc) -> if X < Live -> @@ -397,21 +418,32 @@ eliminate_use_of_from_reg([{set,_,_,{alloc,Live,_}}|_]=Is0, {x,X}, _, Acc) -> {yes,reverse(Acc, Is0)} end; eliminate_use_of_from_reg([{set,Ds,Ss0,Op}=I0|Is], From, To, Acc) -> + ensure_safe_tuple(I0, To), I = case member(From, Ss0) of - true -> - Ss = [case S of - From -> To; - _ -> S - end || S <- Ss0], - {set,Ds,Ss,Op}; - false -> - I0 - end, + true -> + Ss = [case S of + From -> To; + _ -> S + end || S <- Ss0], + {set,Ds,Ss,Op}; + false -> + I0 + end, case member(From, Ds) of - true -> - {yes,reverse(Acc, [I|Is])}; - false -> - eliminate_use_of_from_reg(Is, From, To, [I|Acc]) + true -> + {yes,reverse(Acc, [I|Is])}; + false -> + case member(To, Ds) of + true -> + case beam_utils:is_killed_block(From, Is) of + true -> + {yes,reverse(Acc, [I|Is])}; + false -> + no + end; + false -> + eliminate_use_of_from_reg(Is, From, To, [I|Acc]) + end end; eliminate_use_of_from_reg([I]=Is, From, _To, Acc) -> case beam_utils:is_killed_block(From, [I]) of @@ -421,6 +453,10 @@ eliminate_use_of_from_reg([I]=Is, From, _To, Acc) -> no end. +ensure_safe_tuple({set,[To],[],{put_tuple,_}}, To) -> + throw(not_possible); +ensure_safe_tuple(_, _) -> ok. + %% opt_allocs(Instructions) -> Instructions. Optimize allocate %% instructions inside blocks. If safe, replace an allocate_zero %% instruction with the slightly cheaper allocate instruction. @@ -541,3 +577,109 @@ defined_regs([{set,Ds,_,{alloc,Live,_}}|_], Regs) -> x_live(Ds, Regs bor ((1 bsl Live) - 1)); defined_regs([{set,Ds,_,_}|Is], Regs) -> defined_regs(Is, x_live(Ds, Regs)). + +%%% +%%% Do local common sub expression elimination (CSE) in each block. +%%% + +local_cse([{block,Bl0}|Is]) -> + Bl = cse_block(Bl0, orddict:new(), []), + [{block,Bl}|local_cse(Is)]; +local_cse([I|Is]) -> + [I|local_cse(Is)]; +local_cse([]) -> []. + +cse_block([I|Is], Es0, Acc0) -> + Es1 = cse_clear(I, Es0), + case cse_expr(I) of + none -> + %% Instruction is not suitable for CSE. + cse_block(Is, Es1, [I|Acc0]); + {ok,D,Expr} -> + %% Suitable instruction. First update the dictionary of + %% suitable expressions for the next iteration. + Es = cse_add(D, Expr, Es1), + + %% Search for a previous identical expression. + case cse_find(Expr, Es0) of + error -> + %% Nothing found + cse_block(Is, Es, [I|Acc0]); + Src -> + %% Use the previously calculated result. + %% Also eliminate any line instruction. + Move = {set,[D],[Src],move}, + case Acc0 of + [{set,_,_,{line,_}}|Acc] -> + cse_block(Is, Es, [Move|Acc]); + [_|_] -> + cse_block(Is, Es, [Move|Acc0]) + end + end + end; +cse_block([], _, Acc) -> + reverse(Acc). + +%% cse_find(Expr, Expressions) -> error | Register. +%% Find a previously evaluated expression whose result can be reused, +%% or return 'error' if no such expression is found. + +cse_find(Expr, Es) -> + case orddict:find(Expr, Es) of + {ok,{Src,_}} -> Src; + error -> error + end. + +cse_expr({set,[D],Ss,{bif,N,_}}) -> + case D of + {fr,_} -> + %% There are too many things that can go wrong. + none; + _ -> + {ok,D,{{bif,N},Ss}} + end; +cse_expr({set,[D],Ss,{alloc,_,{gc_bif,N,_}}}) -> + {ok,D,{{gc_bif,N},Ss}}; +cse_expr({set,[D],Ss,put_list}) -> + {ok,D,{put_list,Ss}}; +cse_expr(_) -> none. + +%% cse_clear(Instr, Expressions0) -> Expressions. +%% Remove all previous expressions that will become +%% invalid when this instruction is executed. Basically, +%% an expression is no longer safe to reuse when the +%% register it has been stored to has been modified, killed, +%% or if any of the source operands have changed. + +cse_clear({set,Ds,_,{alloc,Live,_}}, Es) -> + cse_clear_1(Es, Live, Ds); +cse_clear({set,Ds,_,_}, Es) -> + cse_clear_1(Es, all, Ds). + +cse_clear_1(Es, Live, Ds0) -> + Ds = ordsets:from_list(Ds0), + [E || E <- Es, cse_is_safe(E, Live, Ds)]. + +cse_is_safe({_,{Dst,Interfering}}, Live, Ds) -> + ordsets:is_disjoint(Interfering, Ds) andalso + case Dst of + {x,X} -> + X < Live; + _ -> + true + end. + +%% cse_add(Dest, Expr, Expressions0) -> Expressions. +%% Provided that it is safe, add a new expression to the dictionary +%% of already evaluated expressions. + +cse_add(D, {_,Ss}=Expr, Es) -> + case member(D, Ss) of + false -> + Interfering = ordsets:from_list([D|Ss]), + orddict:store(Expr, {D,Interfering}, Es); + true -> + %% Unsafe because the instruction overwrites one of + %% source operands. + Es + end. diff --git a/lib/compiler/src/beam_clean.erl b/lib/compiler/src/beam_clean.erl index e094c2c320..7ddf9fa2e2 100644 --- a/lib/compiler/src/beam_clean.erl +++ b/lib/compiler/src/beam_clean.erl @@ -24,7 +24,7 @@ -export([module/2]). -export([bs_clean_saves/1]). -export([clean_labels/1]). --import(lists, [foldl/3,reverse/1,filter/2]). +-import(lists, [foldl/3,reverse/1]). -spec module(beam_utils:module_code(), [compile:option()]) -> {'ok',beam_utils:module_code()}. @@ -303,8 +303,21 @@ maybe_remove_lines(Fs, Opts) -> end. remove_lines([{function,N,A,Lbl,Is0}|T]) -> - Is = filter(fun({line,_}) -> false; - (_) -> true - end, Is0), + Is = remove_lines_fun(Is0), [{function,N,A,Lbl,Is}|remove_lines(T)]; remove_lines([]) -> []. + +remove_lines_fun([{line,_}|Is]) -> + remove_lines_fun(Is); +remove_lines_fun([{block,Bl0}|Is]) -> + Bl = remove_lines_block(Bl0), + [{block,Bl}|remove_lines_fun(Is)]; +remove_lines_fun([I|Is]) -> + [I|remove_lines_fun(Is)]; +remove_lines_fun([]) -> []. + +remove_lines_block([{set,_,_,{line,_}}|Is]) -> + remove_lines_block(Is); +remove_lines_block([I|Is]) -> + [I|remove_lines_block(Is)]; +remove_lines_block([]) -> []. diff --git a/lib/compiler/src/beam_dead.erl b/lib/compiler/src/beam_dead.erl index da944f3ce6..dbbaae05eb 100644 --- a/lib/compiler/src/beam_dead.erl +++ b/lib/compiler/src/beam_dead.erl @@ -294,24 +294,25 @@ backward([{jump,{f,To}}=J|[{gc_bif,_,{f,To},_,_,_Dst}|Is]], D, Acc) -> %% register is initialized, and it is therefore no need to test %% for liveness of the destination register at label To. backward([J|Is], D, Acc); -backward([{test,bs_start_match2,F,Live,[R,_]=Args,Ctxt}|Is], D, - [{test,bs_match_string,F,[Ctxt,Bs]}, - {test,bs_test_tail2,F,[Ctxt,0]}|Acc0]=Acc) -> +backward([{test,bs_start_match2,F,Live,[Src,_]=Args,Ctxt}|Is], D, Acc0) -> {f,To0} = F, - case beam_utils:is_killed(Ctxt, Acc0, D) of - true -> - To = shortcut_bs_context_to_binary(To0, R, D), - Eq = {test,is_eq_exact,{f,To},[R,{literal,Bs}]}, - backward(Is, D, [Eq|Acc0]); - false -> - To = shortcut_bs_start_match(To0, R, D), - I = {test,bs_start_match2,{f,To},Live,Args,Ctxt}, - backward(Is, D, [I|Acc]) + case test_bs_literal(F, Ctxt, D, Acc0) of + {none,Acc} -> + %% Ctxt killed immediately after bs_start_match2. + To = shortcut_bs_context_to_binary(To0, Src, D), + I = {test,is_bitstr,{f,To},[Src]}, + backward(Is, D, [I|Acc]); + {Literal,Acc} -> + %% Ctxt killed after matching a literal. + To = shortcut_bs_context_to_binary(To0, Src, D), + Eq = {test,is_eq_exact,{f,To},[Src,{literal,Literal}]}, + backward(Is, D, [Eq|Acc]); + not_killed -> + %% Ctxt not killed. Not much to do. + To = shortcut_bs_start_match(To0, Src, D), + I = {test,bs_start_match2,{f,To},Live,Args,Ctxt}, + backward(Is, D, [I|Acc0]) end; -backward([{test,bs_start_match2,{f,To0},Live,[Src|_]=Info,Dst}|Is], D, Acc) -> - To = shortcut_bs_start_match(To0, Src, D), - I = {test,bs_start_match2,{f,To},Live,Info,Dst}, - backward(Is, D, [I|Acc]); backward([{test,Op,{f,To0},Ops0}|Is], D, Acc) -> To1 = shortcut_bs_test(To0, Is, D), To2 = shortcut_label(To1, D), @@ -511,6 +512,22 @@ remove_from_list(Lit, [Val,{f,_}=Fail|T]) -> [Val,Fail|remove_from_list(Lit, T)]; remove_from_list(_, []) -> []. + +test_bs_literal(F, Ctxt, D, + [{test,bs_match_string,F,[Ctxt,Bs]}, + {test,bs_test_tail2,F,[Ctxt,0]}|Acc]) -> + test_bs_literal_1(Ctxt, Acc, D, Bs); +test_bs_literal(F, Ctxt, D, [{test,bs_test_tail2,F,[Ctxt,0]}|Acc]) -> + test_bs_literal_1(Ctxt, Acc, D, <<>>); +test_bs_literal(_, Ctxt, D, Acc) -> + test_bs_literal_1(Ctxt, Acc, D, none). + +test_bs_literal_1(Ctxt, Is, D, Literal) -> + case beam_utils:is_killed(Ctxt, Is, D) of + true -> {Literal,Is}; + false -> not_killed + end. + %% shortcut_bs_test(TargetLabel, ReversedInstructions, D) -> TargetLabel' %% Try to shortcut the failure label for bit syntax matching. diff --git a/lib/compiler/src/beam_disasm.erl b/lib/compiler/src/beam_disasm.erl index 22ba86fa38..a68c4b5367 100644 --- a/lib/compiler/src/beam_disasm.erl +++ b/lib/compiler/src/beam_disasm.erl @@ -1088,6 +1088,12 @@ resolve_inst({get_map_elements,Args0},_,_,_) -> resolve_inst({build_stacktrace,[]},_,_,_) -> build_stacktrace; +resolve_inst({raw_raise,[]},_,_,_) -> + raw_raise; +resolve_inst({get_hd,[Src,Dst]},_,_,_) -> + {get_hd,Src,Dst}; +resolve_inst({get_tl,[Src,Dst]},_,_,_) -> + {get_tl,Src,Dst}; %% %% Catches instructions that are not yet handled. diff --git a/lib/compiler/src/beam_disasm.hrl b/lib/compiler/src/beam_disasm.hrl index 8cc0bcf99b..c3326c15a0 100644 --- a/lib/compiler/src/beam_disasm.hrl +++ b/lib/compiler/src/beam_disasm.hrl @@ -27,7 +27,7 @@ %% PROPER TYPES FOR THE SET OF BEAM INSTRUCTIONS. %% -type beam_instr() :: 'bs_init_writable' | 'build_stacktrace' - | 'fclearerror' | 'if_end' + | 'fclearerror' | 'if_end' | 'raw_raise' | 'remove_message' | 'return' | 'send' | 'timeout' | tuple(). %% XXX: Very underspecified - FIX THIS diff --git a/lib/compiler/src/beam_flatten.erl b/lib/compiler/src/beam_flatten.erl index a4d45a4ca6..c60211f516 100644 --- a/lib/compiler/src/beam_flatten.erl +++ b/lib/compiler/src/beam_flatten.erl @@ -50,6 +50,9 @@ norm_block([{set,[],[],{alloc,R,Alloc}}|Is], Acc0) -> Acc -> norm_block(Is, Acc) end; +norm_block([{set,[D1],[S],get_hd},{set,[D2],[S],get_tl}|Is], Acc) -> + I = {get_list,S,D1,D2}, + norm_block(Is, [I|Acc]); norm_block([I|Is], Acc) -> norm_block(Is, [norm(I)|Acc]); norm_block([], Acc) -> Acc. @@ -64,12 +67,14 @@ norm({set,[D],[],{put_tuple,A}}) -> {put_tuple,A,D}; norm({set,[],[S],put}) -> {put,S}; norm({set,[D],[S],{get_tuple_element,I}}) -> {get_tuple_element,S,I,D}; norm({set,[],[S,D],{set_tuple_element,I}}) -> {set_tuple_element,S,D,I}; -norm({set,[D1,D2],[S],get_list}) -> {get_list,S,D1,D2}; +norm({set,[D],[S],get_hd}) -> {get_hd,S,D}; +norm({set,[D],[S],get_tl}) -> {get_tl,S,D}; norm({set,[D],[S|Puts],{alloc,R,{put_map,Op,F}}}) -> {put_map,F,Op,S,D,R,{list,Puts}}; norm({set,[],[],remove_message}) -> remove_message; norm({set,[],[],fclearerror}) -> fclearerror; -norm({set,[],[],fcheckerror}) -> {fcheckerror,{f,0}}. +norm({set,[],[],fcheckerror}) -> {fcheckerror,{f,0}}; +norm({set,[],[],{line,_}=Line}) -> Line. norm_allocate({_Zero,nostack,Nh,[]}, Regs) -> [{test_heap,Nh,Regs}]; diff --git a/lib/compiler/src/beam_split.erl b/lib/compiler/src/beam_split.erl index d041f18806..52dd89b5bb 100644 --- a/lib/compiler/src/beam_split.erl +++ b/lib/compiler/src/beam_split.erl @@ -50,8 +50,9 @@ split_block([{set,[R],[_,_,_]=As,{bif,is_record,{f,Lbl}}}|Is], Bl, Acc) -> split_block(Is, [], [{bif,is_record,{f,Lbl},As,R}|make_block(Bl, Acc)]); split_block([{set,[R],As,{bif,N,{f,Lbl}=Fail}}|Is], Bl, Acc) when Lbl =/= 0 -> split_block(Is, [], [{bif,N,Fail,As,R}|make_block(Bl, Acc)]); -split_block([{set,[R],As,{bif,raise,{f,_}=Fail}}|Is], Bl, Acc) -> - split_block(Is, [], [{bif,raise,Fail,As,R}|make_block(Bl, Acc)]); +split_block([{set,[],[],{line,_}=Line}, + {set,[R],As,{bif,raise,{f,_}=Fail}}|Is], Bl, Acc) -> + split_block(Is, [], [{bif,raise,Fail,As,R},Line|make_block(Bl, Acc)]); split_block([{set,[R],As,{alloc,Live,{gc_bif,N,{f,Lbl}=Fail}}}|Is], Bl, Acc) when Lbl =/= 0 -> split_block(Is, [], [{gc_bif,N,Fail,Live,As,R}|make_block(Bl, Acc)]); @@ -61,8 +62,6 @@ split_block([{set,[D],[S|Puts],{alloc,R,{put_map,Op,{f,Lbl}=Fail}}}|Is], make_block(Bl, Acc)]); split_block([{set,[R],[],{try_catch,Op,L}}|Is], Bl, Acc) -> split_block(Is, [], [{Op,R,L}|make_block(Bl, Acc)]); -split_block([{set,[],[],{line,_}=Line}|Is], Bl, Acc) -> - split_block(Is, [], [Line|make_block(Bl, Acc)]); split_block([I|Is], Bl, Acc) -> split_block(Is, [I|Bl], Acc); split_block([], Bl, Acc) -> make_block(Bl, Acc). diff --git a/lib/compiler/src/beam_type.erl b/lib/compiler/src/beam_type.erl index 3b6bf49961..b83ed17b55 100644 --- a/lib/compiler/src/beam_type.erl +++ b/lib/compiler/src/beam_type.erl @@ -80,96 +80,99 @@ simplify(Is0, TypeDb0) -> %% Basic simplification, mostly tuples, no floating point optimizations. simplify_basic(Is, Ts) -> - simplify_basic_1(Is, Ts, []). - -simplify_basic_1([{set,[D],[{integer,Index},Reg],{bif,element,_}}=I0|Is], Ts0, Acc) -> - I = case max_tuple_size(Reg, Ts0) of - Sz when 0 < Index, Index =< Sz -> - {set,[D],[Reg],{get_tuple_element,Index-1}}; - _Other -> I0 - end, - Ts = update(I, Ts0), - simplify_basic_1(Is, Ts, [I|Acc]); -simplify_basic_1([{set,[D],[TupleReg],{get_tuple_element,0}}=I|Is0], Ts0, Acc) -> - case tdb_find(TupleReg, Ts0) of - {tuple,_,_,[Contents]} -> - simplify_basic_1([{set,[D],[Contents],move}|Is0], Ts0, Acc); - _ -> - Ts = update(I, Ts0), - simplify_basic_1(Is0, Ts, [I|Acc]) + simplify_basic(Is, Ts, []). + +simplify_basic([I0|Is], Ts0, Acc) -> + case simplify_instr(I0, Ts0) of + [] -> + simplify_basic(Is, Ts0, Acc); + [I] -> + Ts = update(I, Ts0), + simplify_basic(Is, Ts, [I|Acc]) + end; +simplify_basic([], Ts, Acc) -> + {reverse(Acc),Ts}. + +simplify_instr({set,[D],[{integer,Index},Reg],{bif,element,_}}=I, Ts) -> + case max_tuple_size(Reg, Ts) of + Sz when 0 < Index, Index =< Sz -> + [{set,[D],[Reg],{get_tuple_element,Index-1}}]; + _ -> [I] + end; +simplify_instr({test,is_atom,_,[R]}=I, Ts) -> + case tdb_find(R, Ts) of + boolean -> []; + _ -> [I] end; -simplify_basic_1([{set,_,_,{try_catch,_,_}}=I|Is], _Ts, Acc) -> - simplify_basic_1(Is, tdb_new(), [I|Acc]); -simplify_basic_1([{test,is_atom,_,[R]}=I|Is], Ts, Acc) -> +simplify_instr({test,is_integer,_,[R]}=I, Ts) -> + case tdb_find(R, Ts) of + integer -> []; + {integer,_} -> []; + _ -> [I] + end; +simplify_instr({set,[D],[TupleReg],{get_tuple_element,0}}=I, Ts) -> + case tdb_find(TupleReg, Ts) of + {tuple,_,_,[Contents]} -> + [{set,[D],[Contents],move}]; + _ -> + [I] + end; +simplify_instr({test,is_tuple,_,[R]}=I, Ts) -> case tdb_find(R, Ts) of - boolean -> simplify_basic_1(Is, Ts, Acc); - _ -> simplify_basic_1(Is, Ts, [I|Acc]) + {tuple,_,_,_} -> []; + _ -> [I] end; -simplify_basic_1([{test,is_integer,_,[R]}=I|Is], Ts, Acc) -> +simplify_instr({test,test_arity,_,[R,Arity]}=I, Ts) -> case tdb_find(R, Ts) of - integer -> simplify_basic_1(Is, Ts, Acc); - {integer,_} -> simplify_basic_1(Is, Ts, Acc); - _ -> simplify_basic_1(Is, Ts, [I|Acc]) + {tuple,exact_size,Arity,_} -> []; + _ -> [I] end; -simplify_basic_1([{test,is_tuple,_,[R]}=I|Is], Ts, Acc) -> +simplify_instr({test,is_map,_,[R]}=I, Ts) -> case tdb_find(R, Ts) of - {tuple,_,_,_} -> simplify_basic_1(Is, Ts, Acc); - _ -> simplify_basic_1(Is, Ts, [I|Acc]) + map -> []; + _ -> [I] end; -simplify_basic_1([{test,test_arity,_,[R,Arity]}=I|Is], Ts0, Acc) -> - case tdb_find(R, Ts0) of - {tuple,exact_size,Arity,_} -> - simplify_basic_1(Is, Ts0, Acc); - _Other -> - Ts = update(I, Ts0), - simplify_basic_1(Is, Ts, [I|Acc]) +simplify_instr({test,is_nonempty_list,_,[R]}=I, Ts) -> + case tdb_find(R, Ts) of + nonempty_list -> []; + _ -> [I] end; -simplify_basic_1([{test,is_map,_,[R]}=I|Is], Ts0, Acc) -> - case tdb_find(R, Ts0) of - map -> simplify_basic_1(Is, Ts0, Acc); - _Other -> - Ts = update(I, Ts0), - simplify_basic_1(Is, Ts, [I|Acc]) +simplify_instr({test,is_eq_exact,Fail,[R,{atom,_}=Atom]}=I, Ts) -> + case tdb_find(R, Ts) of + {atom,_}=Atom -> []; + {atom,_} -> [{jump,Fail}]; + _ -> [I] end; -simplify_basic_1([{test,is_nonempty_list,_,[R]}=I|Is], Ts0, Acc) -> - case tdb_find(R, Ts0) of - nonempty_list -> simplify_basic_1(Is, Ts0, Acc); - _Other -> - Ts = update(I, Ts0), - simplify_basic_1(Is, Ts, [I|Acc]) - end; -simplify_basic_1([{test,is_eq_exact,Fail,[R,{atom,_}=Atom]}=I|Is0], Ts0, Acc0) -> - Acc = case tdb_find(R, Ts0) of - {atom,_}=Atom -> Acc0; - {atom,_} -> [{jump,Fail}|Acc0]; - _ -> [I|Acc0] - end, - Ts = update(I, Ts0), - simplify_basic_1(Is0, Ts, Acc); -simplify_basic_1([{test,is_record,_,[R,{atom,_}=Tag,{integer,Arity}]}=I|Is], Ts0, Acc) -> - case tdb_find(R, Ts0) of - {tuple,exact_size,Arity,[Tag]} -> - simplify_basic_1(Is, Ts0, Acc); - _Other -> - Ts = update(I, Ts0), - simplify_basic_1(Is, Ts, [I|Acc]) - end; -simplify_basic_1([{select,select_val,Reg,_,_}=I0|Is], Ts, Acc) -> - I = case tdb_find(Reg, Ts) of - {integer,Range} -> - simplify_select_val_int(I0, Range); - boolean -> - simplify_select_val_bool(I0); - _ -> - I0 - end, - simplify_basic_1(Is, tdb_new(), [I|Acc]); -simplify_basic_1([I|Is], Ts0, Acc) -> - Ts = update(I, Ts0), - simplify_basic_1(Is, Ts, [I|Acc]); -simplify_basic_1([], Ts, Acc) -> - Is = reverse(Acc), - {Is,Ts}. +simplify_instr({test,is_record,_,[R,{atom,_}=Tag,{integer,Arity}]}=I, Ts) -> + case tdb_find(R, Ts) of + {tuple,exact_size,Arity,[Tag]} -> []; + _ -> [I] + end; +simplify_instr({select,select_val,Reg,_,_}=I, Ts) -> + [case tdb_find(Reg, Ts) of + {integer,Range} -> + simplify_select_val_int(I, Range); + boolean -> + simplify_select_val_bool(I); + _ -> + I + end]; +simplify_instr({test,bs_test_unit,_,[Src,Unit]}=I, Ts) -> + case tdb_find(Src, Ts) of + {binary,U} when U rem Unit =:= 0 -> []; + _ -> [I] + end; +simplify_instr({test,is_binary,_,[Src]}=I, Ts) -> + case tdb_find(Src, Ts) of + {binary,U} when U rem 8 =:= 0 -> []; + _ -> [I] + end; +simplify_instr({test,is_bitstr,_,[Src]}=I, Ts) -> + case tdb_find(Src, Ts) of + {binary,_} -> []; + _ -> [I] + end; +simplify_instr(I, _) -> [I]. simplify_select_val_int({select,select_val,R,_,L0}=I, {Min,Max}) -> Vs = sort([V || {integer,V} <- L0]), @@ -474,8 +477,6 @@ update({set,[D],[S1,S2],{alloc,_,{gc_bif,Op,{f,0}}}}, Ts0) -> update({set,[],_Src,_Op}, Ts0) -> Ts0; update({set,[D],_Src,_Op}, Ts0) -> tdb_update([{D,kill}], Ts0); -update({set,[D1,D2],_Src,_Op}, Ts0) -> - tdb_update([{D1,kill},{D2,kill}], Ts0); update({kill,D}, Ts) -> tdb_update([{D,kill}], Ts); @@ -504,8 +505,12 @@ update({test,is_eq_exact,_,[Reg,{atom,_}=Atom]}, Ts) -> update({test,is_record,_Fail,[Src,Tag,{integer,Arity}]}, Ts) -> tdb_update([{Src,{tuple,exact_size,Arity,[Tag]}}], Ts); -%% Binary matching +%% Binaries and binary matching. +update({test,is_binary,_Fail,[Src]}, Ts0) -> + tdb_update([{Src,{binary,8}}], Ts0); +update({test,is_bitstr,_Fail,[Src]}, Ts0) -> + tdb_update([{Src,{binary,1}}], Ts0); update({test,bs_get_integer2,_,_,Args,Dst}, Ts) -> tdb_update([{Dst,get_bs_integer_type(Args)}], Ts); update({test,bs_get_utf8,_,_,_,Dst}, Ts) -> @@ -514,8 +519,10 @@ update({test,bs_get_utf16,_,_,_,Dst}, Ts) -> tdb_update([{Dst,?UNICODE_INT}], Ts); update({test,bs_get_utf32,_,_,_,Dst}, Ts) -> tdb_update([{Dst,?UNICODE_INT}], Ts); +update({bs_init,_,{bs_init2,_,_},_,_,Dst}, Ts) -> + tdb_update([{Dst,{binary,8}}], Ts); update({bs_init,_,_,_,_,Dst}, Ts) -> - tdb_update([{Dst,kill}], Ts); + tdb_update([{Dst,{binary,1}}], Ts); update({bs_put,_,_,_}, Ts) -> Ts; update({bs_save2,_,_}, Ts) -> @@ -524,12 +531,19 @@ update({bs_restore2,_,_}, Ts) -> Ts; update({bs_context_to_binary,Dst}, Ts) -> tdb_update([{Dst,kill}], Ts); -update({test,bs_start_match2,_,_,_,Dst}, Ts) -> - tdb_update([{Dst,kill}], Ts); -update({test,bs_get_binary2,_,_,_,Dst}, Ts) -> - tdb_update([{Dst,kill}], Ts); +update({test,bs_start_match2,_,_,[Src,_],Dst}, Ts) -> + Type = case tdb_find(Src, Ts) of + {binary,_}=Type0 -> Type0; + _ -> {binary,1} + end, + tdb_update([{Dst,Type}], Ts); +update({test,bs_get_binary2,_,_,[_,_,Unit,_],Dst}, Ts) -> + true = is_integer(Unit), %Assertion. + tdb_update([{Dst,{binary,Unit}}], Ts); update({test,bs_get_float2,_,_,_,Dst}, Ts) -> tdb_update([{Dst,float}], Ts); +update({test,bs_test_unit,_,[Src,Unit]}, Ts) -> + tdb_update([{Src,{binary,Unit}}], Ts); update({test,_Test,_Fail,_Other}, Ts) -> Ts; @@ -566,6 +580,7 @@ update({call_fun, _}, Ts) -> tdb_kill_xregs(Ts); update({apply, _}, Ts) -> tdb_kill_xregs(Ts); update({line,_}, Ts) -> Ts; +update({'%',_}, Ts) -> Ts; %% The instruction is unknown. Kill all information. update(_I, _Ts) -> tdb_new(). @@ -804,6 +819,9 @@ checkerror_2(OrigIs) -> [{set,[],[],fcheckerror}|OrigIs]. %%% %%% 'integer' or {integer,{Min,Max}} that the register contains an %%% integer. +%%% +%%% {binary,Unit} means that the register contains a binary/bitstring aligned +%%% to unit Unit. %% tdb_new() -> EmptyDataBase %% Creates a new, empty type database. @@ -923,17 +941,20 @@ merge_type_info({tuple,SzKind1,Sz1,[]}, {tuple,_SzKind2,_Sz2,First}=Tuple2) -> merge_type_info({tuple,SzKind1,Sz1,First}, Tuple2); merge_type_info({tuple,_SzKind1,_Sz1,First}=Tuple1, {tuple,SzKind2,Sz2,_}) -> merge_type_info(Tuple1, {tuple,SzKind2,Sz2,First}); -merge_type_info(integer, {integer,_}=Int) -> - Int; -merge_type_info({integer,_}=Int, integer) -> - Int; +merge_type_info(integer, {integer,_}) -> + integer; +merge_type_info({integer,_}, integer) -> + integer; merge_type_info({integer,{Min1,Max1}}, {integer,{Min2,Max2}}) -> {integer,{max(Min1, Min2),min(Max1, Max2)}}; +merge_type_info({binary,U1}, {binary,U2}) -> + {binary,max(U1, U2)}; merge_type_info(NewType, _) -> verify_type(NewType), NewType. verify_type({atom,_}) -> ok; +verify_type({binary,U}) when is_integer(U) -> ok; verify_type(boolean) -> ok; verify_type(integer) -> ok; verify_type({integer,{Min,Max}}) diff --git a/lib/compiler/src/beam_utils.erl b/lib/compiler/src/beam_utils.erl index 901588ee3b..a57dbbbc2f 100644 --- a/lib/compiler/src/beam_utils.erl +++ b/lib/compiler/src/beam_utils.erl @@ -440,8 +440,11 @@ check_liveness(R, [{bs_init,_,_,Live,Ss,Dst}|Is], St) -> case member(R, Ss) of true -> {used,St}; false -> + %% If the exception is taken, the stack may + %% be scanned. Therefore the register is not + %% guaranteed to be killed. if - R =:= Dst -> {killed,St}; + R =:= Dst -> {not_used,St}; true -> not_used(check_liveness(R, Is, St)) end end @@ -602,8 +605,11 @@ check_liveness(R, [{test_heap,N,Live}|Is], St) -> check_liveness(R, [{allocate_zero,N,Live}|Is], St) -> I = {block,[{set,[],[],{alloc,Live,{zero,N,0,[]}}}]}, check_liveness(R, [I|Is], St); -check_liveness(R, [{get_list,S,D1,D2}|Is], St) -> - I = {block,[{set,[D1,D2],[S],get_list}]}, +check_liveness(R, [{get_hd,S,D}|Is], St) -> + I = {block,[{set,[D],[S],get_hd}]}, + check_liveness(R, [I|Is], St); +check_liveness(R, [{get_tl,S,D}|Is], St) -> + I = {block,[{set,[D],[S],get_tl}]}, check_liveness(R, [I|Is], St); check_liveness(R, [remove_message|Is], St) -> check_liveness(R, Is, St); @@ -732,8 +738,8 @@ check_liveness_block_1(R, Ss, Ds, Op, Is, St0) -> end end. -check_liveness_block_2(R, {gc_bif,_Op,{f,Lbl}}, _Ss, St) -> - check_liveness_block_3(R, Lbl, St); +check_liveness_block_2(R, {gc_bif,Op,{f,Lbl}}, Ss, St) -> + check_liveness_block_3(R, Lbl, {Op,length(Ss)}, St); check_liveness_block_2(R, {bif,Op,{f,Lbl}}, Ss, St) -> Arity = length(Ss), case erl_internal:comp_op(Op, Arity) orelse @@ -741,16 +747,23 @@ check_liveness_block_2(R, {bif,Op,{f,Lbl}}, Ss, St) -> true -> {killed,St}; false -> - check_liveness_block_3(R, Lbl, St) + check_liveness_block_3(R, Lbl, {Op,length(Ss)}, St) end; check_liveness_block_2(R, {put_map,_Op,{f,Lbl}}, _Ss, St) -> - check_liveness_block_3(R, Lbl, St); + check_liveness_block_3(R, Lbl, {unsafe,0}, St); check_liveness_block_2(_, _, _, St) -> {killed,St}. -check_liveness_block_3(_, 0, St) -> +check_liveness_block_3({x,_}, 0, _FA, St) -> {killed,St}; -check_liveness_block_3(R, Lbl, St0) -> +check_liveness_block_3({y,_}, 0, {F,A}, St) -> + %% If the exception is thrown, the stack may be scanned, + %% thus implicitly using the y register. + case erl_bifs:is_safe(erlang, F, A) of + true -> {killed,St}; + false -> {used,St} + end; +check_liveness_block_3(R, Lbl, _FA, St0) -> check_liveness_at(R, Lbl, St0). index_labels_1([{label,Lbl}|Is0], Acc) -> @@ -871,6 +884,8 @@ live_opt([{block,Bl0}|Is], Regs0, D, Acc) -> live_opt(Is, Regs, D, [{block,[Live|Bl]}|Acc]); live_opt([build_stacktrace=I|Is], _, D, Acc) -> live_opt(Is, live_call(1), D, [I|Acc]); +live_opt([raw_raise=I|Is], _, D, Acc) -> + live_opt(Is, live_call(3), D, [I|Acc]); live_opt([{label,L}=I|Is], Regs, D0, Acc) -> D = gb_trees:insert(L, Regs, D0), live_opt(Is, Regs, D, [I|Acc]); @@ -1142,6 +1157,8 @@ defs([{move,_,Dst}=I|Is], Regs0, D) -> defs([{put_map,{f,Fail},_,_,Dst,_,_}=I|Is], Regs0, D) -> Regs = def_regs([Dst], Regs0), [I|defs(Is, Regs, update_regs(Fail, Regs0, D))]; +defs([raw_raise=I|Is], _Regs, D) -> + [I|defs(Is, 1, D)]; defs([return=I|Is], _Regs, D) -> [I|defs_unreachable(Is, D)]; defs([{select,_,_Src,Fail,List}=I|Is], Regs, D0) -> diff --git a/lib/compiler/src/beam_validator.erl b/lib/compiler/src/beam_validator.erl index 4feb26c513..9de773542e 100644 --- a/lib/compiler/src/beam_validator.erl +++ b/lib/compiler/src/beam_validator.erl @@ -85,8 +85,6 @@ format_error(Error) -> %%% Things currently not checked. XXX %%% %%% - Heap allocation for binaries. -%%% - That put_tuple is followed by the correct number of -%%% put instructions. %%% %% validate(Module, [Function]) -> [] | [Error] @@ -148,7 +146,8 @@ validate_0(Module, [{function,Name,Ar,Entry,Code}|Fs], Ft) -> hf=0, %Available heap size for floats. fls=undefined, %Floating point state. ct=[], %List of hot catch/try labels - setelem=false %Previous instruction was setelement/3. + setelem=false, %Previous instruction was setelement/3. + puts_left=none %put/1 instructions left. }). -type label() :: integer(). @@ -340,11 +339,25 @@ valfun_1({put_list,A,B,Dst}, Vst0) -> Vst = eat_heap(2, Vst0), set_type_reg(cons, Dst, Vst); valfun_1({put_tuple,Sz,Dst}, Vst0) when is_integer(Sz) -> + Vst1 = eat_heap(1, Vst0), + Vst = set_type_reg(tuple_in_progress, Dst, Vst1), + #vst{current=St0} = Vst, + St = St0#st{puts_left={Sz,{Dst,{tuple,Sz}}}}, + Vst#vst{current=St}; +valfun_1({put,Src}, Vst0) -> + assert_term(Src, Vst0), Vst = eat_heap(1, Vst0), - set_type_reg({tuple,Sz}, Dst, Vst); -valfun_1({put,Src}, Vst) -> - assert_term(Src, Vst), - eat_heap(1, Vst); + #vst{current=St0} = Vst, + case St0 of + #st{puts_left=none} -> + error(not_building_a_tuple); + #st{puts_left={1,{Dst,Type}}} -> + St = St0#st{puts_left=none}, + set_type_reg(Type, Dst, Vst#vst{current=St}); + #st{puts_left={PutsLeft,Info}} when is_integer(PutsLeft) -> + St = St0#st{puts_left={PutsLeft-1,Info}}, + Vst#vst{current=St} + end; %% Instructions for optimization of selective receives. valfun_1({recv_mark,{f,Fail}}, Vst) when is_integer(Fail) -> Vst; @@ -524,6 +537,8 @@ valfun_4({bif,element,{f,Fail},[Pos,Tuple],Dst}, Vst0) -> valfun_4({bif,raise,{f,0},Src,_Dst}, Vst) -> validate_src(Src, Vst), kill_state(Vst); +valfun_4(raw_raise=I, Vst) -> + call(I, 3, Vst); valfun_4({bif,Op,{f,Fail},Src,Dst}, Vst0) -> validate_src(Src, Vst0), Vst = branch_state(Fail, Vst0), @@ -576,6 +591,12 @@ valfun_4({get_list,Src,D1,D2}, Vst0) -> assert_type(cons, Src, Vst0), Vst = set_type_reg(term, D1, Vst0), set_type_reg(term, D2, Vst); +valfun_4({get_hd,Src,Dst}, Vst) -> + assert_type(cons, Src, Vst), + set_type_reg(term, Dst, Vst); +valfun_4({get_tl,Src,Dst}, Vst) -> + assert_type(cons, Src, Vst), + set_type_reg(term, Dst, Vst); valfun_4({get_tuple_element,Src,I,Dst}, Vst) -> assert_type({tuple_element,I+1}, Src, Vst), set_type_reg(term, Dst, Vst); @@ -1272,6 +1293,7 @@ get_move_term_type(Src, Vst) -> initialized -> error({unassigned,Src}); {catchtag,_} -> error({catchtag,Src}); {trytag,_} -> error({trytag,Src}); + tuple_in_progress -> error({tuple_in_progress,Src}); Type -> Type end. @@ -1280,10 +1302,7 @@ get_move_term_type(Src, Vst) -> %% a standard Erlang type (no catch/try tags or match contexts). get_term_type(Src, Vst) -> - case get_term_type_1(Src, Vst) of - initialized -> error({unassigned,Src}); - {catchtag,_} -> error({catchtag,Src}); - {trytag,_} -> error({trytag,Src}); + case get_move_term_type(Src, Vst) of #ms{} -> error({match_context,Src}); Type -> Type end. @@ -1330,7 +1349,12 @@ branch_arities([Sz,{f,L}|T], Tuple, #vst{current=St}=Vst0) Vst = branch_state(L, Vst1), branch_arities(T, Tuple, Vst#vst{current=St}). -branch_state(0, #vst{}=Vst) -> Vst; +branch_state(0, #vst{}=Vst) -> + %% If the instruction fails, the stack may be scanned + %% looking for a catch tag. Therefore the Y registers + %% must be initialized at this point. + verify_y_init(Vst), + Vst; branch_state(L, #vst{current=St,branched=B}=Vst) -> Vst#vst{ branched=case gb_trees:is_defined(L, B) of diff --git a/lib/compiler/src/beam_z.erl b/lib/compiler/src/beam_z.erl index 1c56b95a9e..6c3a6995d7 100644 --- a/lib/compiler/src/beam_z.erl +++ b/lib/compiler/src/beam_z.erl @@ -24,18 +24,20 @@ -export([module/2]). --import(lists, [dropwhile/2]). +-import(lists, [dropwhile/2,map/2]). -spec module(beam_utils:module_code(), [compile:option()]) -> {'ok',beam_asm:module_code()}. -module({Mod,Exp,Attr,Fs0,Lc}, _Opt) -> - Fs = [function(F) || F <- Fs0], +module({Mod,Exp,Attr,Fs0,Lc}, Opts) -> + NoGetHdTl = proplists:get_bool(no_get_hd_tl, Opts), + Fs = [function(F, NoGetHdTl) || F <- Fs0], {ok,{Mod,Exp,Attr,Fs,Lc}}. -function({function,Name,Arity,CLabel,Is0}) -> +function({function,Name,Arity,CLabel,Is0}, NoGetHdTl) -> try - Is = undo_renames(Is0), + Is1 = undo_renames(Is0), + Is = maybe_eliminate_get_hd_tl(Is1, NoGetHdTl), {function,Name,Arity,CLabel,Is} catch Class:Error:Stack -> @@ -65,6 +67,10 @@ undo_renames([{bif,raise,_,_,_}=I|Is0]) -> (_) -> true end, Is0), [I|undo_renames(Is)]; +undo_renames([{get_hd,Src,Dst1},{get_tl,Src,Dst2}|Is]) -> + [{get_list,Src,Dst1,Dst2}|undo_renames(Is)]; +undo_renames([{get_tl,Src,Dst2},{get_hd,Src,Dst1}|Is]) -> + [{get_list,Src,Dst1,Dst2}|undo_renames(Is)]; undo_renames([I|Is]) -> [undo_rename(I)|undo_renames(Is)]; undo_renames([]) -> []. @@ -107,3 +113,17 @@ undo_rename({get_map_elements,Fail,Src,{list,List}}) -> undo_rename({select,I,Reg,Fail,List}) -> {I,Reg,Fail,{list,List}}; undo_rename(I) -> I. + +%%% +%%% Eliminate get_hd/get_tl instructions if requested by +%%% the no_get_hd_tl option. +%%% + +maybe_eliminate_get_hd_tl(Is, true) -> + map(fun({get_hd,Cons,Hd}) -> + {get_list,Cons,Hd,{x,1022}}; + ({get_tl,Cons,Tl}) -> + {get_list,Cons,{x,1022},Tl}; + (I) -> I + end, Is); +maybe_eliminate_get_hd_tl(Is, false) -> Is. diff --git a/lib/compiler/src/compile.erl b/lib/compiler/src/compile.erl index 1409c358c2..c6a0056a70 100644 --- a/lib/compiler/src/compile.erl +++ b/lib/compiler/src/compile.erl @@ -219,13 +219,15 @@ expand_opt(report, Os) -> expand_opt(return, Os) -> [return_errors,return_warnings|Os]; expand_opt(r16, Os) -> - [no_record_opt,no_utf8_atoms|Os]; + [no_get_hd_tl,no_record_opt,no_utf8_atoms|Os]; expand_opt(r17, Os) -> - [no_record_opt,no_utf8_atoms|Os]; + [no_get_hd_tl,no_record_opt,no_utf8_atoms|Os]; expand_opt(r18, Os) -> - [no_record_opt,no_utf8_atoms|Os]; + [no_get_hd_tl,no_record_opt,no_utf8_atoms|Os]; expand_opt(r19, Os) -> - [no_record_opt,no_utf8_atoms|Os]; + [no_get_hd_tl,no_record_opt,no_utf8_atoms|Os]; +expand_opt(r20, Os) -> + [no_get_hd_tl,no_record_opt,no_utf8_atoms|Os]; expand_opt({debug_info_key,_}=O, Os) -> [encrypt_debug_info,O|Os]; expand_opt(no_float_opt, Os) -> diff --git a/lib/compiler/src/genop.tab b/lib/compiler/src/genop.tab index 397e478e1e..a47d4e8cf7 100755 --- a/lib/compiler/src/genop.tab +++ b/lib/compiler/src/genop.tab @@ -554,3 +554,23 @@ BEAM_FORMAT_NUMBER=0 ## Do a garbage collection if necessary to allocate space on the heap ## for the result. 160: build_stacktrace/0 + +## @spec raw_raise +## @doc This instruction works like the erlang:raise/3 BIF, except that the +## stacktrace in x(2) must be a raw stacktrace. +## x(0) is the class of the exception (error, exit, or throw), +## x(1) is the exception term, and x(2) is the raw stackframe. +## If x(0) is not a valid class, the instruction will not throw an +## exception, but store the atom 'badarg' in x(0) and execute the +## next instruction. +161: raw_raise/0 + +## @spec get_hd Source Head +## @doc Get the head (or car) part of a list (a cons cell) from Source and +## put it into the register Head. +162: get_hd/2 + +## @spec get_tl Source Tail +## @doc Get the tail (or cdr) part of a list (a cons cell) from Source and +## put it into the register Tail. +163: get_tl/2 diff --git a/lib/compiler/src/sys_core_bsm.erl b/lib/compiler/src/sys_core_bsm.erl index 37e071fafa..65580f79e3 100644 --- a/lib/compiler/src/sys_core_bsm.erl +++ b/lib/compiler/src/sys_core_bsm.erl @@ -24,7 +24,7 @@ -export([module/2,format_error/1]). -include("core_parse.hrl"). --import(lists, [member/2,nth/2,reverse/1,usort/1]). +-import(lists, [member/2,reverse/1,usort/1]). -spec module(cerl:c_module(), [compile:option()]) -> {'ok', cerl:c_module()}. @@ -59,13 +59,6 @@ format_error(bin_opt_alias) -> format_error(bin_partition) -> "INFO: matching non-variables after a previous clause matching a variable " "will prevent delayed sub binary optimization"; -format_error(bin_left_var_used_in_guard) -> - "INFO: a variable to the left of the binary pattern is used in a guard; " - "will prevent delayed sub binary optimization"; -format_error(bin_argument_order) -> - "INFO: matching anything else but a plain variable to the left of " - "binary pattern will prevent delayed sub binary optimization; " - "SUGGEST changing argument order"; format_error(bin_var_used) -> "INFO: using a matched out sub binary will prevent " "delayed sub binary optimization"; @@ -96,46 +89,41 @@ bsm_an(#c_case{arg=#c_values{es=Es}}=Case) -> bsm_an(Other) -> {ok,Other}. -bsm_an_1(Vs, #c_case{clauses=Cs}=Case) -> - case bsm_leftmost(Cs) of - none -> {ok,Case}; - Pos -> bsm_an_2(Vs, Cs, Case, Pos) - end. - -bsm_an_2(Vs, Cs, Case, Pos) -> - case bsm_nonempty(Cs, Pos) of - true -> bsm_an_3(Vs, Cs, Case, Pos); - false -> {ok,Case} +bsm_an_1(Vs0, #c_case{clauses=Cs0}=Case) -> + case bsm_leftmost(Cs0) of + none -> + {ok,Case}; + 1 -> + bsm_an_2(Vs0, Cs0, Case); + Pos -> + Vs = move_from_col(Pos, Vs0), + Cs = [C#c_clause{pats=move_from_col(Pos, Ps)} || + #c_clause{pats=Ps}=C <- Cs0], + bsm_an_2(Vs, Cs, Case) end. -bsm_an_3(Vs, Cs, Case, Pos) -> +bsm_an_2(Vs, Cs, Case) -> try - bsm_ensure_no_partition(Cs, Pos), - {ok,bsm_do_an(Vs, Pos, Cs, Case)} + bsm_ensure_no_partition(Cs), + {ok,bsm_do_an(Vs, Cs, Case)} catch - throw:{problem,Where,What} -> - {ok,Case,{Where,What}} + throw:{problem,Where,What} -> + {ok,Case,{Where,What}} end. -bsm_do_an(Vs0, Pos, Cs0, Case) -> - case nth(Pos, Vs0) of - #c_var{name=Vname}=V0 -> - Cs = bsm_do_an_var(Vname, Pos, Cs0, []), - V = bsm_annotate_for_reuse(V0), - Bef = lists:sublist(Vs0, Pos-1), - Aft = lists:nthtail(Pos, Vs0), - case Bef ++ [V|Aft] of - [_] -> - Case#c_case{arg=V,clauses=Cs}; - Vs -> - Case#c_case{arg=#c_values{es=Vs},clauses=Cs} - end; - _ -> - Case - end. +move_from_col(Pos, L) -> + {First,[Col|Rest]} = lists:split(Pos - 1, L), + [Col|First] ++ Rest. -bsm_do_an_var(V, S, [#c_clause{pats=Ps,guard=G,body=B0}=C0|Cs], Acc) -> - case nth(S, Ps) of +bsm_do_an([#c_var{name=Vname}=V0|Vs0], Cs0, Case) -> + Cs = bsm_do_an_var(Vname, Cs0), + V = bsm_annotate_for_reuse(V0), + Vs = core_lib:make_values([V|Vs0]), + Case#c_case{arg=Vs,clauses=Cs}; +bsm_do_an(_Vs, _Cs, Case) -> Case. + +bsm_do_an_var(V, [#c_clause{pats=[P|_],guard=G,body=B0}=C0|Cs]) -> + case P of #c_var{name=VarName} -> case core_lib:is_var_used(V, G) of true -> bsm_problem(C0, orig_bin_var_used_in_guard); @@ -148,23 +136,23 @@ bsm_do_an_var(V, S, [#c_clause{pats=Ps,guard=G,body=B0}=C0|Cs], Acc) -> B1 = bsm_maybe_ctx_to_binary(VarName, B0), B = bsm_maybe_ctx_to_binary(V, B1), C = C0#c_clause{body=B}, - bsm_do_an_var(V, S, Cs, [C|Acc]); - #c_alias{}=P -> + [C|bsm_do_an_var(V, Cs)]; + #c_alias{} -> case bsm_could_match_binary(P) of false -> - bsm_do_an_var(V, S, Cs, [C0|Acc]); + [C0|bsm_do_an_var(V, Cs)]; true -> bsm_problem(C0, bin_opt_alias) end; - P -> + _ -> case bsm_could_match_binary(P) andalso bsm_is_var_used(V, G, B0) of false -> - bsm_do_an_var(V, S, Cs, [C0|Acc]); + [C0|bsm_do_an_var(V, Cs)]; true -> bsm_problem(C0, bin_var_used) end end; -bsm_do_an_var(_, _, [], Acc) -> reverse(Acc). +bsm_do_an_var(_, []) -> []. bsm_annotate_for_reuse(#c_var{anno=Anno}=Var) -> Var#c_var{anno=[reuse_for_context|Anno]}. @@ -192,131 +180,82 @@ previous_ctx_to_binary(V, Core) -> end. %% bsm_leftmost(Cs) -> none | ArgumentNumber -%% Find the leftmost argument that does binary matching. Return -%% the number of the argument (1-N). +%% Find the leftmost argument that matches a nonempty binary. +%% Return either 'none' or the argument number (1-N). bsm_leftmost(Cs) -> bsm_leftmost_1(Cs, none). +bsm_leftmost_1([_|_], 1) -> + 1; bsm_leftmost_1([#c_clause{pats=Ps}|Cs], Pos) -> bsm_leftmost_2(Ps, Cs, 1, Pos); bsm_leftmost_1([], Pos) -> Pos. bsm_leftmost_2(_, Cs, Pos, Pos) -> bsm_leftmost_1(Cs, Pos); -bsm_leftmost_2([#c_binary{}|_], Cs, N, _) -> +bsm_leftmost_2([#c_binary{segments=[_|_]}|_], Cs, N, _) -> bsm_leftmost_1(Cs, N); bsm_leftmost_2([_|Ps], Cs, N, Pos) -> bsm_leftmost_2(Ps, Cs, N+1, Pos); bsm_leftmost_2([], Cs, _, Pos) -> bsm_leftmost_1(Cs, Pos). -%% bsm_nonempty(Cs, Pos) -> true|false -%% Check if at least one of the clauses matches a non-empty -%% binary in the given argument position. +%% bsm_ensure_no_partition(Cs) -> ok (exception if problem) +%% There must only be a single bs_start_match2 instruction if we +%% are to reuse the binary variable for the match context. +%% +%% To make sure that there is only a single bs_start_match2 +%% instruction, we will check for partitions such as: %% -bsm_nonempty([#c_clause{pats=Ps}|Cs], Pos) -> - case nth(Pos, Ps) of - #c_binary{segments=[_|_]} -> - true; - _ -> - bsm_nonempty(Cs, Pos) - end; -bsm_nonempty([], _ ) -> false. - -%% bsm_ensure_no_partition(Cs, Pos) -> ok (exception if problem) -%% We must make sure that matching is not partitioned between -%% variables like this: %% foo(<<...>>) -> ... %% foo(<Variable>) when ... -> ... -%% foo(<Any non-variable pattern>) -> -%% If there is such partition, we are not allowed to reuse the binary variable -%% for the match context. +%% foo(<Non-variable pattern>) -> %% -%% Also, arguments to the left of the argument that is matched -%% against a binary, are only allowed to be simple variables, not -%% used in guards. The reason is that we must know that the binary is -%% only matched in one place (i.e. there must be only one bs_start_match2 -%% instruction emitted). +%% If there is such partition, we reject the optimization. -bsm_ensure_no_partition(Cs, Pos) -> - bsm_ensure_no_partition_1(Cs, Pos, before). +bsm_ensure_no_partition(Cs) -> + bsm_ensure_no_partition_1(Cs, before). %% Loop through each clause. -bsm_ensure_no_partition_1([#c_clause{pats=Ps,guard=G}|Cs], Pos, State0) -> - State = bsm_ensure_no_partition_2(Ps, Pos, G, simple_vars, State0), +bsm_ensure_no_partition_1([#c_clause{pats=Ps,guard=G}|Cs], State0) -> + State = bsm_ensure_no_partition_2(Ps, G, State0), case State of 'after' -> - bsm_ensure_no_partition_after(Cs, Pos); + bsm_ensure_no_partition_after(Cs); _ -> ok end, - bsm_ensure_no_partition_1(Cs, Pos, State); -bsm_ensure_no_partition_1([], _, _) -> ok. + bsm_ensure_no_partition_1(Cs, State); +bsm_ensure_no_partition_1([], _) -> ok. -%% Loop through each pattern for this clause. -bsm_ensure_no_partition_2([#c_binary{}=Where|_], 1, _, Vstate, State) -> - case State of - before when Vstate =:= simple_vars -> within; - before -> bsm_problem(Where, Vstate); - within when Vstate =:= simple_vars -> within; - within -> bsm_problem(Where, Vstate) - end; -bsm_ensure_no_partition_2([#c_alias{}=Alias|_], 1, N, Vstate, State) -> +bsm_ensure_no_partition_2([#c_binary{}|_], _, _State) -> + within; +bsm_ensure_no_partition_2([#c_alias{}=Alias|_], N, State) -> %% Retrieve the real pattern that the alias refers to and check that. P = bsm_real_pattern(Alias), - bsm_ensure_no_partition_2([P], 1, N, Vstate, State); -bsm_ensure_no_partition_2([_|_], 1, _, _Vstate, before=State) -> + bsm_ensure_no_partition_2([P], N, State); +bsm_ensure_no_partition_2([_|_], _, before=State) -> %% No binary matching yet - therefore no partition. State; -bsm_ensure_no_partition_2([P|_], 1, _, Vstate, State) -> +bsm_ensure_no_partition_2([P|_], _, State) -> case bsm_could_match_binary(P) of false -> - %% If clauses can be freely arranged (Vstate =:= simple_vars), - %% a clause that cannot match a binary will not partition the clause. - %% Example: - %% - %% a(Var, <<>>) -> ... - %% a(Var, []) -> ... - %% a(Var, <<B>>) -> ... - %% - %% But if the clauses can't be freely rearranged, as in - %% - %% b(Var, <<X>>) -> ... - %% b(1, 2) -> ... - %% - %% we do have a problem. - %% - case Vstate of - simple_vars -> State; - _ -> bsm_problem(P, Vstate) - end; + State; true -> %% The pattern P *may* match a binary, so we must update the state. %% (P must be a variable.) - case State of - within -> 'after'; - 'after' -> 'after' - end - end; -bsm_ensure_no_partition_2([#c_var{name=V}|Ps], N, G, Vstate, S) -> - case core_lib:is_var_used(V, G) of - false -> - bsm_ensure_no_partition_2(Ps, N-1, G, Vstate, S); - true -> - bsm_ensure_no_partition_2(Ps, N-1, G, bin_left_var_used_in_guard, S) - end; -bsm_ensure_no_partition_2([_|Ps], N, G, _, S) -> - bsm_ensure_no_partition_2(Ps, N-1, G, bin_argument_order, S). + 'after' + end. -bsm_ensure_no_partition_after([#c_clause{pats=Ps}=C|Cs], Pos) -> - case nth(Pos, Ps) of - #c_var{} -> - bsm_ensure_no_partition_after(Cs, Pos); - _ -> - bsm_problem(C, bin_partition) +bsm_ensure_no_partition_after([#c_clause{pats=Ps}=C|Cs]) -> + case Ps of + [#c_var{}|_] -> + bsm_ensure_no_partition_after(Cs); + _ -> + bsm_problem(C, bin_partition) end; -bsm_ensure_no_partition_after([], _) -> ok. +bsm_ensure_no_partition_after([]) -> ok. bsm_could_match_binary(#c_alias{pat=P}) -> bsm_could_match_binary(P); bsm_could_match_binary(#c_cons{}) -> false; diff --git a/lib/compiler/src/sys_core_fold.erl b/lib/compiler/src/sys_core_fold.erl index 46816fe24a..a9bd363ee1 100644 --- a/lib/compiler/src/sys_core_fold.erl +++ b/lib/compiler/src/sys_core_fold.erl @@ -2507,6 +2507,72 @@ are_all_failing_clauses(Cs) -> is_failing_clause(#c_clause{body=B}) -> will_fail(B). +%% opt_build_stacktrace(Let) -> Core. +%% If the stacktrace is *only* used in a call to erlang:raise/3, +%% there is no need to build a cooked stackframe using build_stacktrace/1. + +opt_build_stacktrace(#c_let{vars=[#c_var{name=Cooked}], + arg=#c_primop{name=#c_literal{val=build_stacktrace}, + args=[RawStk]}, + body=Body}=Let) -> + case Body of + #c_call{module=#c_literal{val=erlang}, + name=#c_literal{val=raise}, + args=[Class,Exp,#c_var{name=Cooked}]} -> + %% The stacktrace is only used in a call to erlang:raise/3. + %% There is no need to build the stacktrace. Replace the + %% call to erlang:raise/3 with the the raw_raise/3 instruction, + %% which will use a raw stacktrace. + #c_primop{name=#c_literal{val=raw_raise}, + args=[Class,Exp,RawStk]}; + #c_let{vars=[#c_var{name=V}],arg=Arg,body=B0} when V =/= Cooked -> + case core_lib:is_var_used(Cooked, Arg) of + false -> + %% The built stacktrace is not used in the argument, + %% so we can sink the building of the stacktrace into + %% the body of the let. + B = opt_build_stacktrace(Let#c_let{body=B0}), + Body#c_let{body=B}; + true -> + Let + end; + #c_seq{arg=Arg,body=B0} -> + case core_lib:is_var_used(Cooked, Arg) of + false -> + %% The built stacktrace is not used in the argument, + %% so we can sink the building of the stacktrace into + %% the body of the sequence. + B = opt_build_stacktrace(Let#c_let{body=B0}), + Body#c_seq{body=B}; + true -> + Let + end; + #c_case{arg=Arg,clauses=Cs0} -> + case core_lib:is_var_used(Cooked, Arg) orelse + is_used_in_any_guard(Cooked, Cs0) of + false -> + %% The built stacktrace is not used in the argument, + %% so we can sink the building of the stacktrace into + %% each arm of the case. + Cs = [begin + B = opt_build_stacktrace(Let#c_let{body=B0}), + C#c_clause{body=B} + end || #c_clause{body=B0}=C <- Cs0], + Body#c_case{clauses=Cs}; + true -> + Let + end; + _ -> + Let + end; +opt_build_stacktrace(Expr) -> + Expr. + +is_used_in_any_guard(V, Cs) -> + any(fun(#c_clause{guard=G}) -> + core_lib:is_var_used(V, G) + end, Cs). + %% opt_case_in_let(Let) -> Let' %% Try to avoid building tuples that are immediately matched. %% A common pattern is: @@ -2712,8 +2778,9 @@ opt_simple_let_2(Let0, Vs0, Arg0, Body, PrevBody, Sub) -> %% Note that the substitutions and scope in Sub have been cleared %% and should not be used. -post_opt_let(Let, Sub) -> - opt_bool_case_in_let(Let, Sub). +post_opt_let(Let0, Sub) -> + Let1 = opt_bool_case_in_let(Let0, Sub), + opt_build_stacktrace(Let1). %% remove_first_value(Core0, Sub) -> Core. diff --git a/lib/compiler/src/v3_codegen.erl b/lib/compiler/src/v3_codegen.erl index 8f3399d133..a8f4926e55 100644 --- a/lib/compiler/src/v3_codegen.erl +++ b/lib/compiler/src/v3_codegen.erl @@ -1495,28 +1495,34 @@ select_extract_map(Src, Vs, Fail, I, Vdb, Bef, St) -> {Code, Aft, St}. -select_extract_cons(Src, [#k_var{name=Hd}, #k_var{name=Tl}], I, Vdb, Bef, St) -> - {Es,Aft} = case {vdb_find(Hd, Vdb), vdb_find(Tl, Vdb)} of - {{_,_,Lhd}, {_,_,Ltl}} when Lhd =< I, Ltl =< I -> - %% Both head and tail are dead. No need to generate - %% any instruction. - {[], Bef}; - _ -> - %% At least one of head and tail will be used, - %% but we must always fetch both. We will call - %% clear_dead/2 to allow reuse of the register - %% in case only of them is used. - - Reg0 = put_reg(Tl, put_reg(Hd, Bef#sr.reg)), - Int0 = Bef#sr{reg=Reg0}, - Rsrc = fetch_var(Src, Int0), - Rhd = fetch_reg(Hd, Reg0), - Rtl = fetch_reg(Tl, Reg0), - Int1 = clear_dead(Int0, I, Vdb), - {[{get_list,Rsrc,Rhd,Rtl}], Int1} - end, - {Es,Aft,St}. - +select_extract_cons(Src, [#k_var{name=Hd},#k_var{name=Tl}], I, Vdb, Bef, St) -> + Rsrc = fetch_var(Src, Bef), + Int = clear_dead(Bef, I, Vdb), + {{_,_,Lhd},{_,_,Ltl}} = {vdb_find(Hd, Vdb),vdb_find(Tl, Vdb)}, + case {Lhd =< I, Ltl =< I} of + {true,true} -> + %% Both dead. + {[],Bef,St}; + {true,false} -> + %% Head dead. + Reg0 = put_reg(Tl, Bef#sr.reg), + Aft = Int#sr{reg=Reg0}, + Rtl = fetch_reg(Tl, Reg0), + {[{get_tl,Rsrc,Rtl}],Aft,St}; + {false,true} -> + %% Tail dead. + Reg0 = put_reg(Hd, Bef#sr.reg), + Aft = Int#sr{reg=Reg0}, + Rhd = fetch_reg(Hd, Reg0), + {[{get_hd,Rsrc,Rhd}],Aft,St}; + {false,false} -> + %% Both used. + Reg0 = put_reg(Tl, put_reg(Hd, Bef#sr.reg)), + Aft = Bef#sr{reg=Reg0}, + Rhd = fetch_reg(Hd, Reg0), + Rtl = fetch_reg(Tl, Reg0), + {[{get_hd,Rsrc,Rhd},{get_tl,Rsrc,Rtl}],Aft,St} + end. guard_clause_cg(#k_guard_clause{anno=#l{vdb=Vdb},guard=G,body=B}, Fail, Bef, St0) -> {Gis,Int,St1} = guard_cg(G, Fail, Vdb, Bef, St0), @@ -1855,7 +1861,12 @@ internal_cg(guard_error, [ExitCall], _Rs, Le, Vdb, Bef, St) -> {Ms,_} = cg_call_args(As, Bef, Le#l.i, Vdb), Call = {call_ext,Arity,{extfunc,Mod,Name,Arity}}, Is = Ms++[line(Le),Call], - {Is,Bef,St}. + {Is,Bef,St}; +internal_cg(raw_raise=I, As, Rs, Le, Vdb, Bef, St) -> + %% This behaves like a function call. + {Sis,Int} = cg_setup_call(As, Bef, Le#l.i, Vdb), + Reg = load_vars(Rs, clear_regs(Int#sr.reg)), + {Sis++[I],clear_dead(Int#sr{reg=Reg}, Le#l.i, Vdb),St}. %% bif_cg(Bif, [Arg], [Ret], Le, Vdb, StackReg, State) -> %% {[Ainstr],StackReg,State}. diff --git a/lib/compiler/test/beam_block_SUITE.erl b/lib/compiler/test/beam_block_SUITE.erl index 55d5f2dbe8..38ead96cc8 100644 --- a/lib/compiler/test/beam_block_SUITE.erl +++ b/lib/compiler/test/beam_block_SUITE.erl @@ -22,7 +22,7 @@ -export([all/0,suite/0,groups/0,init_per_suite/1,end_per_suite/1, init_per_group/2,end_per_group/2, get_map_elements/1,otp_7345/1,move_opt_across_gc_bif/1, - erl_202/1,repro/1]). + erl_202/1,repro/1,local_cse/1,second_block_pass/1]). %% The only test for the following functions is that %% the code compiles and is accepted by beam_validator. @@ -40,7 +40,9 @@ groups() -> otp_7345, move_opt_across_gc_bif, erl_202, - repro + repro, + local_cse, + second_block_pass ]}]. init_per_suite(Config) -> @@ -237,6 +239,72 @@ find_operands(Cfg,XsiGraph,ActiveList,Count) -> [Count+1, length(NewActiveList), length(digraph:vertices(XsiGraph))], find_operands(NewCfg,XsiGraph,NewActiveList,Count+1). +%% Some tests of local common subexpression elimination (CSE). + +local_cse(_Config) -> + {Self,{ok,Self}} = local_cse_1(), + + local_cse_2([]), + local_cse_2(lists:seq(1, 512)), + local_cse_2(?MODULE:module_info()), + + {[b],[a,b]} = local_cse_3(a, b), + + {2000,Self,{Self,write_cache}} = local_cse_4(), + + ok. + +local_cse_1() -> + %% Cover handling of unsafe tuple construction in + %% eliminate_use_of_from_reg/4. It became necessary to handle + %% unsafe tuples when local CSE was introduced. + + {self(),{ok,self()}}. + +local_cse_2(Term) -> + case cse_make_binary(Term) of + <<Size:8,BinTerm:Size/binary>> -> + Term = binary_to_term(BinTerm); + <<Size:8,SizeTerm:Size/binary,BinTerm/binary>> -> + {'$size',TermSize} = binary_to_term(SizeTerm), + TermSize = byte_size(BinTerm), + Term = binary_to_term(BinTerm) + end. + +%% Copy of observer_backend:ttb_make_binary/1. During development of +%% the local CSE optimization this function was incorrectly optimized. + +cse_make_binary(Term) -> + B = term_to_binary(Term), + SizeB = byte_size(B), + if SizeB > 255 -> + SB = term_to_binary({'$size',SizeB}), + <<(byte_size(SB)):8, SB/binary, B/binary>>; + true -> + <<SizeB:8, B/binary>> + end. + +local_cse_3(X, Y) -> + %% The following expression was incorrectly transformed to {[X,Y],[X,Y]} + %% during development of the local CSE optimization. + + {[Y],[X,Y]}. + +local_cse_4() -> + do_local_cse_4(2000, self(), {self(), write_cache}). + +do_local_cse_4(X, Y, Z) -> + {X,Y,Z}. + +%% Tests previously found bugs when running beam_block the second time. + +second_block_pass(_Config) -> + [#{dts:=5.0}] = second_1([#{dts => 10.0}], 2.0), + ok. + +second_1(Fs, TS) -> + [F#{dts=>DTS / TS} || #{dts:=DTS} = F <- Fs]. + %%% %%% Common functions. %%% diff --git a/lib/compiler/test/beam_type_SUITE.erl b/lib/compiler/test/beam_type_SUITE.erl index fe856b12b6..e33df809ff 100644 --- a/lib/compiler/test/beam_type_SUITE.erl +++ b/lib/compiler/test/beam_type_SUITE.erl @@ -23,7 +23,7 @@ init_per_group/2,end_per_group/2, integers/1,coverage/1,booleans/1,setelement/1,cons/1, tuple/1,record_float/1,binary_float/1,float_compare/1, - arity_checks/1]). + arity_checks/1,elixir_binaries/1]). suite() -> [{ct_hooks,[ts_install_cth]}]. @@ -42,7 +42,8 @@ groups() -> record_float, binary_float, float_compare, - arity_checks + arity_checks, + elixir_binaries ]}]. init_per_suite(Config) -> @@ -66,6 +67,15 @@ integers(_Config) -> college = do_integers_3(), + zero = do_integers_4(<<0:1>>, 0), + one = do_integers_4(<<1:1>>, 0), + other = do_integers_4(<<1:1>>, 2), + + zero = do_integers_5(0, 0), + one = do_integers_5(0, 1), + two = do_integers_5(0, 2), + three = do_integers_5(0, 3), + ok. do_integers_1(B0) -> @@ -88,6 +98,30 @@ do_integers_3() -> 1 -> 0 end. +do_integers_4(<<X:1,T/bits>>, C) -> + %% Binary matching gives the range 0-1 for X. + %% The range for `X bor C` is unknown. It must not be inherited + %% from X. (`X bor C` will reuse the register used for X.) + case X bor C of + 0 -> do_integers_4(T, C, zero); + 1 -> do_integers_4(T, C, one); + _ -> do_integers_4(T, C, other) + end. + +do_integers_4(_, _, Res) -> + Res. + +do_integers_5(X0, Y0) -> + %% X and Y will use the same register. + X = X0 band 1, + Y = Y0 band 3, + case Y of + 0 -> zero; + 1 -> one; + 2 -> two; + 3 -> three + end. + coverage(_Config) -> {'EXIT',{badarith,_}} = (catch id(1) bsl 0.5), {'EXIT',{badarith,_}} = (catch id(2.0) bsl 2), @@ -199,5 +233,42 @@ do_tuple_arity_check(RGB) when is_tuple(RGB), _ -> ok end. +elixir_binaries(_Config) -> + <<"foo blitzky baz">> = elixir_binary_1(<<"blitzky">>), + <<"foo * baz">> = elixir_binary_2($*), + <<7:4,755:10>> = elixir_bitstring_3(<<755:10>>), + ok. + +elixir_binary_1(Bar) when is_binary(Bar) -> + <<"foo ", + case Bar of + Rewrite when is_binary(Rewrite) -> + Rewrite; + Rewrite -> + list_to_binary(Rewrite) + end/binary, + " baz">>. + +elixir_binary_2(Arg) -> + Bin = <<Arg>>, + <<"foo ", + case Bin of + Rewrite when is_binary(Rewrite) -> + Rewrite; + Rewrite -> + list_to_binary:to_string(Rewrite) + end/binary, + " baz">>. + +elixir_bitstring_3(Bar) when is_bitstring(Bar) -> + <<7:4, + case Bar of + Rewrite when is_bitstring(Rewrite) -> + Rewrite; + Rewrite -> + list_to_bitstring(Rewrite) + end/bitstring>>. + + id(I) -> I. diff --git a/lib/compiler/test/beam_validator_SUITE.erl b/lib/compiler/test/beam_validator_SUITE.erl index 685eb2a72e..63a13281a8 100644 --- a/lib/compiler/test/beam_validator_SUITE.erl +++ b/lib/compiler/test/beam_validator_SUITE.erl @@ -33,8 +33,8 @@ state_after_fault_in_catch/1,no_exception_in_catch/1, undef_label/1,illegal_instruction/1,failing_gc_guard_bif/1, map_field_lists/1,cover_bin_opt/1, - val_dsetel/1]). - + val_dsetel/1,bad_tuples/1]). + -include_lib("common_test/include/ct.hrl"). init_per_testcase(Case, Config) when is_atom(Case), is_list(Config) -> @@ -61,7 +61,8 @@ groups() -> freg_state,bad_bin_match,bad_dsetel, state_after_fault_in_catch,no_exception_in_catch, undef_label,illegal_instruction,failing_gc_guard_bif, - map_field_lists,cover_bin_opt,val_dsetel]}]. + map_field_lists,cover_bin_opt,val_dsetel, + bad_tuples]}]. init_per_suite(Config) -> Config. @@ -509,6 +510,19 @@ destroy_reg({Tag,N}) -> {y,N+1} end. +bad_tuples(Config) -> + Errors = do_val(bad_tuples, Config), + [{{bad_tuples,heap_overflow,1}, + {{put,{x,0}},8,{heap_overflow,{left,0},{wanted,1}}}}, + {{bad_tuples,long,2}, + {{put,{atom,too_long}},8,not_building_a_tuple}}, + {{bad_tuples,self_referential,1}, + {{put,{x,1}},7,{tuple_in_progress,{x,1}}}}, + {{bad_tuples,short,1}, + {{move,{x,1},{x,0}},7,{tuple_in_progress,{x,1}}}}] = Errors, + + ok. + %%%------------------------------------------------------------------------- transform_remove(Remove, Module) -> diff --git a/lib/compiler/test/beam_validator_SUITE_data/bad_tuples.S b/lib/compiler/test/beam_validator_SUITE_data/bad_tuples.S new file mode 100644 index 0000000000..7980241c37 --- /dev/null +++ b/lib/compiler/test/beam_validator_SUITE_data/bad_tuples.S @@ -0,0 +1,88 @@ +{module, bad_tuples}. %% version = 0 + +{exports, [{heap_overflow,1}, + {long,2}, + {module_info,0}, + {module_info,1}, + {self_referential,1}, + {short,1}]}. + +{attributes, []}. + +{labels, 13}. + + +{function, short, 1, 2}. + {label,1}. + {line,[{location,"bad_tuples.erl",4}]}. + {func_info,{atom,bad_tuples},{atom,short},1}. + {label,2}. + {test_heap,3,1}. + {put_tuple,2,{x,1}}. + {put,{atom,ok}}. + {move,{x,1},{x,0}}. + return. + + +{function, long, 2, 4}. + {label,3}. + {line,[{location,"bad_tuples.erl",7}]}. + {func_info,{atom,bad_tuples},{atom,long},2}. + {label,4}. + {test_heap,6,2}. + {put_tuple,2,{x,2}}. + {put,{x,0}}. + {put,{x,1}}. + {put,{atom,too_long}}. + {put_tuple,2,{x,0}}. + {put,{atom,ok}}. + {put,{x,2}}. + return. + + +{function, heap_overflow, 1, 6}. + {label,5}. + {line,[{location,"bad_tuples.erl",10}]}. + {func_info,{atom,bad_tuples},{atom,heap_overflow},1}. + {label,6}. + {test_heap,3,1}. + {put_tuple,2,{x,1}}. + {put,{atom,ok}}. + {put,{x,0}}. + {put,{x,0}}. + {move,{x,1},{x,0}}. + return. + + +{function, self_referential, 1, 8}. + {label,7}. + {line,[{location,"bad_tuples.erl",13}]}. + {func_info,{atom,bad_tuples},{atom,self_referential},1}. + {label,8}. + {test_heap,3,1}. + {put_tuple,2,{x,1}}. + {put,{atom,ok}}. + {put,{x,1}}. + {move,{x,1},{x,0}}. + return. + + +{function, module_info, 0, 10}. + {label,9}. + {line,[]}. + {func_info,{atom,bad_tuples},{atom,module_info},0}. + {label,10}. + {move,{atom,bad_tuples},{x,0}}. + {line,[]}. + {call_ext_only,1,{extfunc,erlang,get_module_info,1}}. + + +{function, module_info, 1, 12}. + {label,11}. + {line,[]}. + {func_info,{atom,bad_tuples},{atom,module_info},1}. + {label,12}. + {move,{x,0},{x,1}}. + {move,{atom,bad_tuples},{x,0}}. + {line,[]}. + {call_ext_only,2,{extfunc,erlang,get_module_info,2}}. diff --git a/lib/compiler/test/bs_match_SUITE.erl b/lib/compiler/test/bs_match_SUITE.erl index 7557d6d57b..235956a714 100644 --- a/lib/compiler/test/bs_match_SUITE.erl +++ b/lib/compiler/test/bs_match_SUITE.erl @@ -40,7 +40,7 @@ map_and_binary/1,unsafe_branch_caching/1, bad_literals/1,good_literals/1,constant_propagation/1, parse_xml/1,get_payload/1,escape/1,num_slots_different/1, - beam_bsm/1,guard/1,is_ascii/1]). + beam_bsm/1,guard/1,is_ascii/1,non_opt_eq/1]). -export([coverage_id/1,coverage_external_ignore/2]). @@ -73,7 +73,7 @@ groups() -> map_and_binary,unsafe_branch_caching, bad_literals,good_literals,constant_propagation,parse_xml, get_payload,escape,num_slots_different, - beam_bsm,guard,is_ascii]}]. + beam_bsm,guard,is_ascii,non_opt_eq]}]. init_per_suite(Config) -> @@ -678,6 +678,10 @@ coverage(Config) when is_list(Config) -> <<>> = coverage_per_key(<<4:32>>), <<$a,$b,$c>> = coverage_per_key(<<7:32,"abc">>), + binary = coverage_bitstring(<<>>), + binary = coverage_bitstring(<<7>>), + bitstring = coverage_bitstring(<<7:4>>), + other = coverage_bitstring([a]), ok. coverage_fold(Fun, Acc, <<H,T/binary>>) -> @@ -768,6 +772,10 @@ coverage_per_key(<<BinSize:32,Bin/binary>> = B) -> true = (byte_size(B) =:= BinSize), Bin. +coverage_bitstring(Bin) when is_binary(Bin) -> binary; +coverage_bitstring(<<_/bitstring>>) -> bitstring; +coverage_bitstring(_) -> other. + multiple_uses(Config) when is_list(Config) -> {344,62879,345,<<245,159,1,89>>} = multiple_uses_1(<<1,88,245,159,1,89>>), true = multiple_uses_2(<<0,0,197,18>>), @@ -1654,6 +1662,21 @@ do_is_ascii(<<C,_/binary>>) when C >= 16#80 -> do_is_ascii(<<_, T/binary>>) -> do_is_ascii(T). +non_opt_eq(_Config) -> + true = non_opt_eq([], <<>>), + true = non_opt_eq([$a], <<$a>>), + false = non_opt_eq([$a], <<$b>>), + ok. + +%% An example from the Efficiency Guide. It used to be not optimized, +%% but now it can be optimized. + +non_opt_eq([H|T1], <<H,T2/binary>>) -> + non_opt_eq(T1, T2); +non_opt_eq([_|_], <<_,_/binary>>) -> + false; +non_opt_eq([], <<>>) -> + true. check(F, R) -> R = F(). diff --git a/lib/compiler/test/compile_SUITE.erl b/lib/compiler/test/compile_SUITE.erl index 35c11d894d..eee5bc733f 100644 --- a/lib/compiler/test/compile_SUITE.erl +++ b/lib/compiler/test/compile_SUITE.erl @@ -1455,19 +1455,21 @@ env_compiler_options(_Config) -> bc_options(Config) -> DataDir = proplists:get_value(data_dir, Config), - 101 = highest_opcode(DataDir, small_float, [no_line_info]), + 101 = highest_opcode(DataDir, small_float, [no_get_hd_tl,no_line_info]), 103 = highest_opcode(DataDir, big, - [no_record_opt,no_line_info,no_stack_trimming]), + [no_get_hd_tl,no_record_opt, + no_line_info,no_stack_trimming]), - 125 = highest_opcode(DataDir, small_float, [no_line_info,no_float_opt]), + 125 = highest_opcode(DataDir, small_float, + [no_get_hd_tl,no_line_info,no_float_opt]), 132 = highest_opcode(DataDir, small, - [no_record_opt,no_float_opt,no_line_info]), + [no_get_hd_tl,no_record_opt,no_float_opt,no_line_info]), - 136 = highest_opcode(DataDir, big, [no_record_opt,no_line_info]), + 136 = highest_opcode(DataDir, big, [no_get_hd_tl,no_record_opt,no_line_info]), - 153 = highest_opcode(DataDir, big, [no_record_opt]), + 153 = highest_opcode(DataDir, big, [no_get_hd_tl,no_record_opt]), 153 = highest_opcode(DataDir, big, [r16]), 153 = highest_opcode(DataDir, big, [r17]), 153 = highest_opcode(DataDir, big, [r18]), @@ -1478,9 +1480,10 @@ bc_options(Config) -> 158 = highest_opcode(DataDir, small_maps, [r17]), 158 = highest_opcode(DataDir, small_maps, [r18]), 158 = highest_opcode(DataDir, small_maps, [r19]), + 158 = highest_opcode(DataDir, small_maps, [r20]), 158 = highest_opcode(DataDir, small_maps, []), - 159 = highest_opcode(DataDir, big, []), + 163 = highest_opcode(DataDir, big, []), ok. diff --git a/lib/compiler/test/compile_SUITE_data/big.erl b/lib/compiler/test/compile_SUITE_data/big.erl index 2e54ee8660..1db07755a1 100644 --- a/lib/compiler/test/compile_SUITE_data/big.erl +++ b/lib/compiler/test/compile_SUITE_data/big.erl @@ -741,3 +741,7 @@ snmp_access(suite) -> debug_support(suite) -> [ info, schema, schema, kill, lkill ]. +%% Cover translation of get_hd/2 to get_list/3 when option no_get_hd_tl +%% is given. +cover_get_hd([Hd|_]) -> + Hd. diff --git a/lib/compiler/test/misc_SUITE.erl b/lib/compiler/test/misc_SUITE.erl index d93c5dda1e..4e39f4663e 100644 --- a/lib/compiler/test/misc_SUITE.erl +++ b/lib/compiler/test/misc_SUITE.erl @@ -359,9 +359,7 @@ integer_encoding_1(Config) -> io:put_chars(Src, "t(Last) ->[\n"), io:put_chars(Data, "[\n"), - do_integer_encoding(-(id(1) bsl 10000), Src, Data), - do_integer_encoding(id(1) bsl 10000, Src, Data), - do_integer_encoding(1024, 0, Src, Data), + do_integer_encoding(137, 0, Src, Data), _ = [begin B = 1 bsl I, do_integer_encoding(-B-1, Src, Data), @@ -370,7 +368,7 @@ integer_encoding_1(Config) -> do_integer_encoding(B-1, Src, Data), do_integer_encoding(B, Src, Data), do_integer_encoding(B+1, Src, Data) - end || I <- lists:seq(1, 128)], + end || I <- lists:seq(1, 130)], io:put_chars(Src, "Last].\n\n"), ok = file:close(Src), io:put_chars(Data, "0].\n\n"), @@ -384,8 +382,6 @@ integer_encoding_1(Config) -> %% Compare lists. List = Mod:t(0), {ok,[List]} = file:consult(DataFile), - OneBsl10000 = id(1) bsl 10000, - [-(1 bsl 10000),OneBsl10000|_] = List, %% Cleanup. file:delete(SrcFile), @@ -404,7 +400,3 @@ do_integer_encoding(I, Src, Data) -> Str = integer_to_list(I), io:put_chars(Src, [Str,",\n"]), io:put_chars(Data, [Str,",\n"]). - - -id(I) -> I. - diff --git a/lib/compiler/test/trycatch_SUITE.erl b/lib/compiler/test/trycatch_SUITE.erl index 8cf7928cc4..d5a1dc642f 100644 --- a/lib/compiler/test/trycatch_SUITE.erl +++ b/lib/compiler/test/trycatch_SUITE.erl @@ -27,7 +27,7 @@ nested_horrid/1,last_call_optimization/1,bool/1, plain_catch_coverage/1,andalso_orelse/1,get_in_try/1, hockey/1,handle_info/1,catch_in_catch/1,grab_bag/1, - stacktrace/1,nested_stacktrace/1]). + stacktrace/1,nested_stacktrace/1,raise/1]). -include_lib("common_test/include/ct.hrl"). @@ -44,7 +44,7 @@ groups() -> nested_after,nested_horrid,last_call_optimization, bool,plain_catch_coverage,andalso_orelse,get_in_try, hockey,handle_info,catch_in_catch,grab_bag, - stacktrace,nested_stacktrace]}]. + stacktrace,nested_stacktrace,raise]}]. init_per_suite(Config) -> @@ -117,6 +117,16 @@ basic(Conf) when is_list(Conf) -> catch nisse -> erro end, + %% Unmatchable clauses. + try + throw(thrown) + catch + {a,b}={a,b,c} -> %Intentionally no match. + ok; + thrown -> + ok + end, + ok. after_call() -> @@ -1159,5 +1169,99 @@ nested_stacktrace_1({X1,C1,V1}, {X2,C2,V2}) -> {caught1,S1,T2} end. +raise(_Config) -> + test_raise(fun() -> exit({exit,tuple}) end), + test_raise(fun() -> abs(id(x)) end), + test_raise(fun() -> throw({was,thrown}) end), + + badarg = bad_raise(fun() -> abs(id(x)) end), + + ok. + +bad_raise(Expr) -> + try + Expr() + catch + _:E:Stk -> + erlang:raise(bad_class, E, Stk) + end. + +test_raise(Expr) -> + test_raise_1(Expr), + test_raise_2(Expr), + test_raise_3(Expr). + +test_raise_1(Expr) -> + erase(exception), + try + do_test_raise_1(Expr) + catch + C:E:Stk -> + {C,E,Stk} = erase(exception) + end. + +do_test_raise_1(Expr) -> + try + Expr() + catch + C:E:Stk -> + %% Here the stacktrace must be built. + put(exception, {C,E,Stk}), + erlang:raise(C, E, Stk) + end. + +test_raise_2(Expr) -> + erase(exception), + try + do_test_raise_2(Expr) + catch + C:E:Stk -> + {C,E} = erase(exception), + try + Expr() + catch + _:_:S -> + [StkTop|_] = S, + [StkTop|_] = Stk + end + end. + +do_test_raise_2(Expr) -> + try + Expr() + catch + C:E:Stk -> + %% Here it is possible to replace erlang:raise/3 with + %% the raw_raise/3 instruction since the stacktrace is + %% not actually used. + put(exception, {C,E}), + erlang:raise(C, E, Stk) + end. + +test_raise_3(Expr) -> + try + do_test_raise_3(Expr) + catch + exit:{exception,C,E}:Stk -> + try + Expr() + catch + C:E:S -> + [StkTop|_] = S, + [StkTop|_] = Stk + end + end. + +do_test_raise_3(Expr) -> + try + Expr() + catch + C:E:Stk -> + %% Here it is possible to replace erlang:raise/3 with + %% the raw_raise/3 instruction since the stacktrace is + %% not actually used. + erlang:raise(exit, {exception,C,E}, Stk) + end. + id(I) -> I. diff --git a/lib/debugger/src/dbg_debugged.erl b/lib/debugger/src/dbg_debugged.erl index e142af4ae0..8b64a60a9c 100644 --- a/lib/debugger/src/dbg_debugged.erl +++ b/lib/debugger/src/dbg_debugged.erl @@ -31,32 +31,25 @@ %% Called via the error handler. %%-------------------------------------------------------------------- eval(Mod, Func, Args) -> - SaveStacktrace = erlang:get_stacktrace(), Meta = dbg_ieval:eval(Mod, Func, Args), Mref = erlang:monitor(process, Meta), - msg_loop(Meta, Mref, SaveStacktrace). + msg_loop(Meta, Mref). %%==================================================================== %% Internal functions %%==================================================================== -msg_loop(Meta, Mref, SaveStacktrace) -> +msg_loop(Meta, Mref) -> receive %% Evaluated function has returned a value {sys, Meta, {ready, Val}} -> erlang:demonitor(Mref, [flush]), - - %% Restore original stacktrace and return the value - try erlang:raise(throw, stack, SaveStacktrace) - catch - throw:stack -> - case Val of - {dbg_apply,M,F,A} -> - apply(M, F, A); - _ -> - Val - end + case Val of + {dbg_apply,M,F,A} -> + apply(M, F, A); + _ -> + Val end; %% Evaluated function raised an (uncaught) exception @@ -74,32 +67,25 @@ msg_loop(Meta, Mref, SaveStacktrace) -> Meta ! {self(), rec_acked}, ok end, - msg_loop(Meta, Mref, SaveStacktrace); + msg_loop(Meta, Mref); %% Meta needs something evaluated within context of real process {sys, Meta, {command,Command}} -> Reply = handle_command(Command), Meta ! {sys, self(), Reply}, - msg_loop(Meta, Mref, SaveStacktrace); + msg_loop(Meta, Mref); %% Meta has terminated %% Must be due to int:stop() (or -heaven forbid- a debugger bug) {'DOWN', Mref, _, _, Reason} -> - - %% Restore original stacktrace and return a dummy value - try erlang:raise(throw, stack, SaveStacktrace) - catch - throw:stack -> - {interpreter_terminated, Reason} - end + {interpreter_terminated, Reason} end. handle_command(Command) -> try reply(Command) - catch Class:Reason -> - Stacktrace = stacktrace_f(erlang:get_stacktrace()), - {exception,{Class,Reason,Stacktrace}} + catch Class:Reason:Stacktrace -> + {exception,{Class,Reason,stacktrace_f(Stacktrace)}} end. reply({apply,M,F,As}) -> diff --git a/lib/debugger/src/dbg_ieval.erl b/lib/debugger/src/dbg_ieval.erl index 8009d62629..b0db8228e5 100644 --- a/lib/debugger/src/dbg_ieval.erl +++ b/lib/debugger/src/dbg_ieval.erl @@ -924,8 +924,7 @@ expr({dbg,Line,raise,As0}, Bs0, #ieval{level=Le}=Ieval0) -> trace(return, {Le,Error}), {value,Error,Bs} catch - _:_ -> - Stk = erlang:get_stacktrace(), %Possibly truncated. + _:_:Stk -> %Possibly truncated. StkFun = fun(_) -> Stk end, do_exception(Class, Reason, StkFun, Bs, Ieval) end; diff --git a/lib/debugger/src/dbg_wx_mon.erl b/lib/debugger/src/dbg_wx_mon.erl index a32a6894b8..00aee62a87 100644 --- a/lib/debugger/src/dbg_wx_mon.erl +++ b/lib/debugger/src/dbg_wx_mon.erl @@ -119,9 +119,9 @@ init(CallingPid, Mode, SFile) -> init2(CallingPid, Mode, SFile, GS) catch exit:stop -> stop; - Error:Reason -> + Error:Reason:Stacktrace -> io:format("~p: Crashed {~p,~p} in~n ~p", - [?MODULE, Error, Reason, erlang:get_stacktrace()]) + [?MODULE, Error, Reason, Stacktrace]) end end. diff --git a/lib/debugger/src/dbg_wx_trace.erl b/lib/debugger/src/dbg_wx_trace.erl index b1e0e03b4c..505d53005f 100644 --- a/lib/debugger/src/dbg_wx_trace.erl +++ b/lib/debugger/src/dbg_wx_trace.erl @@ -95,9 +95,9 @@ start(Pid, Env, Parent, TraceWin, BackTrace, Strings) -> catch _:stop -> exit(stop); - E:R -> + E:R:S -> io:format("TraceWin Crashed ~p~n",[E]), - io:format(" ~p in ~p~n",[R, erlang:get_stacktrace()]), + io:format(" ~p in ~p~n",[R, S]), exit(R) end; error -> diff --git a/lib/dialyzer/src/dialyzer_cl_parse.erl b/lib/dialyzer/src/dialyzer_cl_parse.erl index 80c10183cf..f21eaed087 100644 --- a/lib/dialyzer/src/dialyzer_cl_parse.erl +++ b/lib/dialyzer/src/dialyzer_cl_parse.erl @@ -41,8 +41,8 @@ start() -> Ret catch throw:{dialyzer_cl_parse_error, Msg} -> {error, Msg}; - _:R -> - Msg = io_lib:format("~tp\n~tp\n", [R, erlang:get_stacktrace()]), + _:R:S -> + Msg = io_lib:format("~tp\n~tp\n", [R, S]), {error, lists:flatten(Msg)} end. diff --git a/lib/dialyzer/src/dialyzer_dataflow.erl b/lib/dialyzer/src/dialyzer_dataflow.erl index 93cfea3c5e..6bd3c2f9a6 100644 --- a/lib/dialyzer/src/dialyzer_dataflow.erl +++ b/lib/dialyzer/src/dialyzer_dataflow.erl @@ -299,7 +299,7 @@ traverse(Tree, Map, State) -> match_fail -> t_none(); raise -> t_none(); bs_init_writable -> t_from_term(<<>>); - build_stacktrace -> t_list(); + build_stacktrace -> erl_bif_types:type(erlang, build_stacktrace, 0); Other -> erlang:error({'Unsupported primop', Other}) end, {State, Map, Type}; @@ -1236,6 +1236,13 @@ handle_tuple(Tree, Map, State) -> State2 = state__add_warning(State1, ?WARN_OPAQUE, Tree, Msg), {State2, Map1, t_none()}; + {error, record, ErrorPat, ErrorType, _} -> + Msg = {record_match, + [format_patterns(ErrorPat), + format_type(ErrorType, State1)]}, + State2 = state__add_warning(State1, ?WARN_MATCHING, + Tree, Msg), + {State2, Map1, t_none()}; {Map2, ETypes} -> {State1, Map2, t_tuple(ETypes)} end @@ -3117,7 +3124,10 @@ state__add_warning(#state{warnings = Warnings, warning_mode = true} = State, state__remove_added_warnings(OldState, NewState) -> #state{warnings = OldWarnings} = OldState, #state{warnings = NewWarnings} = NewState, - {NewWarnings -- OldWarnings, NewState#state{warnings = OldWarnings}}. + case NewWarnings =:= OldWarnings of + true -> {[], NewState}; + false -> {NewWarnings -- OldWarnings, NewState#state{warnings = OldWarnings}} + end. state__add_warnings(Warns, #state{warnings = Warnings} = State) -> State#state{warnings = Warns ++ Warnings}. diff --git a/lib/dialyzer/src/dialyzer_typesig.erl b/lib/dialyzer/src/dialyzer_typesig.erl index b1f6a54503..dede475f98 100644 --- a/lib/dialyzer/src/dialyzer_typesig.erl +++ b/lib/dialyzer/src/dialyzer_typesig.erl @@ -418,7 +418,11 @@ traverse(Tree, DefinedVars, State) -> match_fail -> throw(error); raise -> throw(error); bs_init_writable -> {State, t_from_term(<<>>)}; - build_stacktrace -> {State, t_list()}; + build_stacktrace -> + V = mk_var(Tree), + Type = erl_bif_types:type(erlang, build_stacktrace, 0), + State1 = state__store_conj(V, sub, Type, State), + {State1, V}; Other -> erlang:error({'Unsupported primop', Other}) end; 'receive' -> @@ -1896,9 +1900,8 @@ solver(Solver, SolveFun) -> ?debug("Solver ~w returned unexpected result:\n ~P\n", [Solver, _R, 60]), throw(error) - catch E:R -> - io:format("Solver ~w failed: ~w:~p\n ~tp\n", - [Solver, E, R, erlang:get_stacktrace()]), + catch E:R:S -> + io:format("Solver ~w failed: ~w:~p\n ~tp\n", [Solver, E, R, S]), throw(error) end. diff --git a/lib/dialyzer/src/typer.erl b/lib/dialyzer/src/typer.erl index 16b9c8a94a..9d3d9ce438 100644 --- a/lib/dialyzer/src/typer.erl +++ b/lib/dialyzer/src/typer.erl @@ -164,9 +164,9 @@ get_type_info(#analysis{callgraph = CallGraph, CodeServer), Analysis#analysis{callgraph = StrippedCallGraph, trust_plt = NewPlt} catch - error:What -> + error:What:Stacktrace -> fatal_error(io_lib:format("Analysis failed with message: ~tp", - [{What, erlang:get_stacktrace()}])); + [{What, Stacktrace}])); throw:{dialyzer_succ_typing_error, Msg} -> fatal_error(io_lib:format("Analysis failed with message: ~ts", [Msg])) end. diff --git a/lib/dialyzer/test/behaviour_SUITE_data/src/proper/proper_typeserver.erl b/lib/dialyzer/test/behaviour_SUITE_data/src/proper/proper_typeserver.erl index b16075763f..12f6532c0c 100644 --- a/lib/dialyzer/test/behaviour_SUITE_data/src/proper/proper_typeserver.erl +++ b/lib/dialyzer/test/behaviour_SUITE_data/src/proper/proper_typeserver.erl @@ -539,7 +539,7 @@ apply_spec_test({Mod,Fun,_Arity}=MFA, {_Domain,Range}, SpecTimeout, FalsePositiv try apply(Mod, Fun, Args) of X -> {ok, X} catch - X:Y -> {X, Y} + X:Y:S -> {{X, Y}, S} end, case Result of {ok, Z} -> @@ -551,15 +551,15 @@ apply_spec_test({Mod,Fun,_Arity}=MFA, {_Domain,Range}, SpecTimeout, FalsePositiv false -> false end; - Exception when is_function(FalsePositiveMFAs) -> + {Exception, S2} when is_function(FalsePositiveMFAs) -> case FalsePositiveMFAs(MFA, Args, Exception) of true -> true; false -> - error(Exception, erlang:get_stacktrace()) + error(Exception, S2) end; - Exception -> - error(Exception, erlang:get_stacktrace()) + {Exception, S3} -> + error(Exception, S3) end end). diff --git a/lib/dialyzer/test/opaque_SUITE_data/src/proper/proper_typeserver.erl b/lib/dialyzer/test/opaque_SUITE_data/src/proper/proper_typeserver.erl index 1677b4efb8..529f9fba72 100644 --- a/lib/dialyzer/test/opaque_SUITE_data/src/proper/proper_typeserver.erl +++ b/lib/dialyzer/test/opaque_SUITE_data/src/proper/proper_typeserver.erl @@ -533,7 +533,7 @@ apply_spec_test({Mod,Fun,_Arity}=MFA, {_Domain,Range}, SpecTimeout, FalsePositiv try apply(Mod,Fun,Args) of X -> {ok, X} catch - X:Y -> {X, Y} + X:Y:S -> {{X, Y}, S} end, case Result of {ok, Z} -> @@ -545,15 +545,15 @@ apply_spec_test({Mod,Fun,_Arity}=MFA, {_Domain,Range}, SpecTimeout, FalsePositiv false -> false end; - Exception when is_function(FalsePositiveMFAs) -> + {Exception, S2} when is_function(FalsePositiveMFAs) -> case FalsePositiveMFAs(MFA, Args, Exception) of true -> true; false -> - error(Exception, erlang:get_stacktrace()) + error(Exception, S2) end; - Exception -> - error(Exception, erlang:get_stacktrace()) + {Exception, S3} -> + error(Exception, S3) end end). diff --git a/lib/dialyzer/test/options1_SUITE_data/src/compiler/beam_validator.erl b/lib/dialyzer/test/options1_SUITE_data/src/compiler/beam_validator.erl index 8fe43163f6..ea92613781 100644 --- a/lib/dialyzer/test/options1_SUITE_data/src/compiler/beam_validator.erl +++ b/lib/dialyzer/test/options1_SUITE_data/src/compiler/beam_validator.erl @@ -174,7 +174,7 @@ validate_error(Error, Name, Ar) -> -endif. validate_error_1(Error, Name, Ar) -> {{'_',Name,Ar}, - {internal_error,'_',{Error,erlang:get_stacktrace()}}}. + {internal_error,'_',{Error,[]}}}. -record(st, %Emulation state {x=init_regs(0, term), %x register info. diff --git a/lib/dialyzer/test/small_SUITE_data/results/record_match b/lib/dialyzer/test/small_SUITE_data/results/record_match new file mode 100644 index 0000000000..a0dd6f560a --- /dev/null +++ b/lib/dialyzer/test/small_SUITE_data/results/record_match @@ -0,0 +1,3 @@ + +record_match.erl:16: Function select/0 has no local return +record_match.erl:17: Matching of pattern {'b_literal', 'undefined'} tagged with a record name violates the declared type of #b_local{} | #b_remote{} diff --git a/lib/dialyzer/test/small_SUITE_data/results/stacktrace b/lib/dialyzer/test/small_SUITE_data/results/stacktrace new file mode 100644 index 0000000000..fd60881953 --- /dev/null +++ b/lib/dialyzer/test/small_SUITE_data/results/stacktrace @@ -0,0 +1,5 @@ + +stacktrace.erl:11: The pattern {'a', 'b'} can never match the type [{atom(),atom(),[any()] | byte(),[{'file',string()} | {'line',pos_integer()}]}] +stacktrace.erl:19: The pattern ['a', 'b'] can never match the type [{atom(),atom(),[any()] | byte(),[{'file',string()} | {'line',pos_integer()}]}] +stacktrace.erl:44: The pattern {'a', 'b'} can never match the type [{atom(),atom(),[any()] | byte(),[{'file',string()} | {'line',pos_integer()}]}] +stacktrace.erl:53: The pattern ['a', 'b'] can never match the type [{atom(),atom(),[any()] | byte(),[{'file',string()} | {'line',pos_integer()}]}] diff --git a/lib/dialyzer/test/small_SUITE_data/src/bsL.erl b/lib/dialyzer/test/small_SUITE_data/src/bsL.erl new file mode 100644 index 0000000000..b2fdc16324 --- /dev/null +++ b/lib/dialyzer/test/small_SUITE_data/src/bsL.erl @@ -0,0 +1,13 @@ +-module(bsL). + +-export([t/0]). + +%% Found in lib/observer/test/crashdump_helper.erl. + +t() -> + Size = 60, + <<H:16/unit:8>> = erlang:md5(<<Size:32>>), + true = H < 20, + true = H > 2, + Data = ((H bsl (8*150)) div (H+7919)), + <<Data:Size/unit:8>>. diff --git a/lib/dialyzer/test/small_SUITE_data/src/record_match.erl b/lib/dialyzer/test/small_SUITE_data/src/record_match.erl new file mode 100644 index 0000000000..8e9b91937f --- /dev/null +++ b/lib/dialyzer/test/small_SUITE_data/src/record_match.erl @@ -0,0 +1,17 @@ +-module(record_match). + +-export([select/0]). + +-record(b_literal, {val}). +-record(b_remote, {mod,name,arity}). +-record(b_local, {name,arity}). + +-type b_remote() :: #b_remote{}. +-type b_local() :: #b_local{}. + +-type argument() :: b_remote() | b_local(). + +-record(b_set, {args=[] :: [argument()]}). + +select() -> + #b_set{args=[#b_remote{},#b_literal{}]}. diff --git a/lib/dialyzer/test/small_SUITE_data/src/stacktrace.erl b/lib/dialyzer/test/small_SUITE_data/src/stacktrace.erl new file mode 100644 index 0000000000..de79e710e9 --- /dev/null +++ b/lib/dialyzer/test/small_SUITE_data/src/stacktrace.erl @@ -0,0 +1,73 @@ +-module(stacktrace). + +%% Check the stacktrace variable introduced in Erlang/OTP 21.0 + +-export([t1/0, t2/0, t3/0, t4/0, s1/0, s2/0, s3/0, s4/0]). + +t1() -> + try foo:bar() + catch + E:P:S -> + {a,b} = S, % can never match + {E, P} + end. + +t2() -> + try foo:bar() + catch + E:P:S -> + [a,b] = S, % can never match + {E, P} + end. + +t3() -> + try foo:bar() + catch + E:P:S -> + [{m,f,[],[]}] = S, + {E, P} + end. + +t4() -> + try foo:bar() + catch + E:P:S -> + [{m,f,1,[{file,"tjo"},{line,95}]}] = S, + {E, P} + end. + +s1() -> + try foo:bar() + catch + E:P -> + S = erlang:get_stacktrace(), + {a,b} = S, % can never match + {E, P} + end. + +s2() -> + try foo:bar() + catch + E:P -> + S = erlang:get_stacktrace(), + [a,b] = S, % can never match + {E, P} + end. + +s3() -> + try foo:bar() + catch + E:P -> + S = erlang:get_stacktrace(), + [{m,f,[],[]}] = S, + {E, P} + end. + +s4() -> + try foo:bar() + catch + E:P -> + S = erlang:get_stacktrace(), + [{m,f,1,[{file,"tjo"},{line,95}]}] = S, + {E, P} + end. diff --git a/lib/et/src/et_wx_contents_viewer.erl b/lib/et/src/et_wx_contents_viewer.erl index bca517317e..7ca41da3e8 100644 --- a/lib/et/src/et_wx_contents_viewer.erl +++ b/lib/et/src/et_wx_contents_viewer.erl @@ -93,8 +93,8 @@ start_link(Options) -> end, {ok, Pid} catch - error:Reason -> - {error, {'EXIT', Reason, erlang:get_stacktrace()}} + error:Reason:Stacktrace -> + {error, {'EXIT', Reason, Stacktrace}} end; {error, Reason} -> {error, Reason} diff --git a/lib/eunit/src/eunit_lib.erl b/lib/eunit/src/eunit_lib.erl index d1bd160ea1..771541354c 100644 --- a/lib/eunit/src/eunit_lib.erl +++ b/lib/eunit/src/eunit_lib.erl @@ -202,13 +202,13 @@ format_exception_test_() -> "\nymmud:rorre"++_, lists:reverse(lists:flatten( format_exception(try erlang:error(dummy) - catch C:R -> {C, R, erlang:get_stacktrace()} + catch C:R:S -> {C, R, S} end)))), ?_assertMatch( "\nymmud:rorre"++_, lists:reverse(lists:flatten( format_exception(try erlang:error(dummy, [a]) - catch C:R -> {C, R, erlang:get_stacktrace()} + catch C:R:S -> {C, R, S} end))))]. -endif. diff --git a/lib/eunit/src/eunit_listener.erl b/lib/eunit/src/eunit_listener.erl index e652c5b2f6..75aa05c543 100644 --- a/lib/eunit/src/eunit_listener.erl +++ b/lib/eunit/src/eunit_listener.erl @@ -137,8 +137,7 @@ call(F, As, St) when is_atom(F) -> try apply(St#state.callback, F, As) of Substate -> St#state{state = Substate} catch - Class:Term -> - Trace = erlang:get_stacktrace(), + Class:Term:Trace -> if F =/= terminate -> call(terminate, [{error, {Class, Term, Trace}}, St#state.state], St); diff --git a/lib/eunit/src/eunit_proc.erl b/lib/eunit/src/eunit_proc.erl index e075005238..96bdcf88b6 100644 --- a/lib/eunit/src/eunit_proc.erl +++ b/lib/eunit/src/eunit_proc.erl @@ -628,7 +628,7 @@ io_request({put_chars, M, F, As}, Buf) -> try apply(M, F, As) of Chars -> {ok, [Chars | Buf]} catch - C:T -> {{error, {C,T,erlang:get_stacktrace()}}, Buf} + C:T:S -> {{error, {C,T,S}}, Buf} end; io_request({put_chars, _Enc, Chars}, Buf) -> io_request({put_chars, Chars}, Buf); diff --git a/lib/eunit/src/eunit_test.erl b/lib/eunit/src/eunit_test.erl index 6036537178..6fe85ae70a 100644 --- a/lib/eunit/src/eunit_test.erl +++ b/lib/eunit/src/eunit_test.erl @@ -39,11 +39,11 @@ %% somewhat, but you can't have everything.) Note that we assume that %% this particular module is the boundary between eunit and user code. -get_stacktrace() -> - get_stacktrace([]). +get_stacktrace(Trace) -> + get_stacktrace(Trace, []). -get_stacktrace(Ts) -> - eunit_lib:uniq(prune_trace(erlang:get_stacktrace(), Ts)). +get_stacktrace(Trace, Ts) -> + eunit_lib:uniq(prune_trace(Trace, Ts)). -dialyzer({no_match, prune_trace/2}). prune_trace([{eunit_data, _, _} | Rest], Tail) -> @@ -75,8 +75,8 @@ run_testfun(F) -> {eunit_internal, Term} -> %% Internally generated: re-throw Term (lose the trace) throw(Term); - Class:Reason -> - {error, {Class, Reason, get_stacktrace()}} + Class:Reason:Trace -> + {error, {Class, Reason, Trace}} end. @@ -272,7 +272,7 @@ mf_wrapper(M, F) -> fun () -> try M:F() catch - error:undef -> + error:undef:Trace -> %% Check if it was M:F/0 that was undefined case erlang:module_loaded(M) of false -> @@ -282,14 +282,14 @@ mf_wrapper(M, F) -> false -> fail({no_such_function, {M,F,0}}); true -> - rethrow(error, undef, [{M,F,0}]) + rethrow(error, undef, Trace, [{M,F,0}]) end end end end. -rethrow(Class, Reason, Trace) -> - erlang:raise(Class, Reason, get_stacktrace(Trace)). +rethrow(Class, Reason, Trace, Ts) -> + erlang:raise(Class, Reason, get_stacktrace(Trace, Ts)). fail(Term) -> throw({eunit_internal, Term}). @@ -332,12 +332,14 @@ enter_context(Setup, Cleanup, Instantiate, Callback) -> T -> case eunit_lib:is_not_test(T) of true -> - catch throw(error), % generate a stack trace + {_, Stacktrace} = + erlang:process_info(self(), + current_stacktrace), {module,M} = erlang:fun_info(Instantiate, module), {name,N} = erlang:fun_info(Instantiate, name), {arity,A} = erlang:fun_info(Instantiate, arity), context_error({bad_instantiator, {{M,N,A},T}}, - error, badarg); + error, Stacktrace, badarg); false -> ok end, @@ -346,21 +348,22 @@ enter_context(Setup, Cleanup, Instantiate, Callback) -> %% Always run cleanup; client may be an idiot try Cleanup(R) catch - Class:Term -> - context_error(cleanup_failed, Class, Term) + Class:Term:Trace -> + context_error(cleanup_failed, + Class, Trace, Term) end end catch - Class:Term -> - context_error(instantiation_failed, Class, Term) + Class:Term:Trace -> + context_error(instantiation_failed, Class, Trace, Term) end catch - Class:Term -> - context_error(setup_failed, Class, Term) + Class:Term:Trace -> + context_error(setup_failed, Class, Trace, Term) end. -context_error(Type, Class, Term) -> - throw({context_error, Type, {Class, Term, get_stacktrace()}}). +context_error(Type, Class, Trace, Term) -> + throw({context_error, Type, {Class, Term, get_stacktrace(Trace)}}). %% This generates single setup/cleanup functions from a list of tuples %% on the form {Tag, Setup, Cleanup}, where the setup function always @@ -378,8 +381,8 @@ multi_setup([{Tag, S, C} | Es], CleanupPrev) -> try C(R) of _ -> CleanupPrev(Rs) catch - Class:Term -> - throw({Tag, {Class, Term, get_stacktrace()}}) + Class:Term:Trace -> + throw({Tag, {Class, Term, Trace}}) end end, {SetupRest, CleanupAll} = multi_setup(Es, Cleanup), @@ -388,9 +391,9 @@ multi_setup([{Tag, S, C} | Es], CleanupPrev) -> R -> SetupRest([R|Rs]) catch - Class:Term -> + Class:Term:Trace -> CleanupPrev(Rs), - throw({Tag, {Class, Term, get_stacktrace()}}) + throw({Tag, {Class, Term, Trace}}) end end, CleanupAll}; diff --git a/lib/hipe/cerl/erl_bif_types.erl b/lib/hipe/cerl/erl_bif_types.erl index fc6a844e22..bfffb8db41 100644 --- a/lib/hipe/cerl/erl_bif_types.erl +++ b/lib/hipe/cerl/erl_bif_types.erl @@ -585,6 +585,13 @@ type(erlang, float, 1, Xs, Opaques) -> %% Guard bif, needs to be here. type(erlang, floor, 1, Xs, Opaques) -> strict(erlang, floor, 1, Xs, fun (_) -> t_integer() end, Opaques); +%% Primop, needs to be somewhere. +type(erlang, build_stacktrace, 0, _, _Opaques) -> + t_list(t_tuple([t_module(), + t_atom(), + t_sup([t_arity(),t_list()]), + t_list(t_sup([t_tuple([t_atom('file'),t_string()]), + t_tuple([t_atom('line'),t_pos_integer()])]))])); %% Guard bif, needs to be here. type(erlang, hd, 1, Xs, Opaques) -> strict(erlang, hd, 1, Xs, fun ([X]) -> t_cons_hd(X) end, Opaques); @@ -1885,7 +1892,8 @@ infinity_div(Number1, Number2) when is_integer(Number1), is_integer(Number2) -> infinity_bsl(pos_inf, _) -> pos_inf; infinity_bsl(neg_inf, _) -> neg_inf; -infinity_bsl(Number, pos_inf) when is_integer(Number), Number >= 0 -> pos_inf; +infinity_bsl(0, pos_inf) -> 0; +infinity_bsl(Number, pos_inf) when is_integer(Number), Number > 0 -> pos_inf; infinity_bsl(Number, pos_inf) when is_integer(Number) -> neg_inf; infinity_bsl(Number, neg_inf) when is_integer(Number), Number >= 0 -> 0; infinity_bsl(Number, neg_inf) when is_integer(Number) -> -1; @@ -2335,6 +2343,9 @@ arg_types(erlang, float, 1) -> %% Guard bif, needs to be here. arg_types(erlang, floor, 1) -> [t_number()]; +%% Primop, needs to be somewhere. +arg_types(erlang, build_stacktrace, 0) -> + []; %% Guard bif, needs to be here. arg_types(erlang, hd, 1) -> [t_cons()]; diff --git a/lib/hipe/cerl/erl_types.erl b/lib/hipe/cerl/erl_types.erl index 77a2a7401c..8a609ef911 100644 --- a/lib/hipe/cerl/erl_types.erl +++ b/lib/hipe/cerl/erl_types.erl @@ -2351,6 +2351,8 @@ t_from_range(X, Y) -> -else. +t_from_range(pos_inf, pos_inf) -> ?integer_pos; +t_from_range(neg_inf, neg_inf) -> ?integer_neg; t_from_range(neg_inf, pos_inf) -> t_integer(); t_from_range(neg_inf, Y) when is_integer(Y), Y < 0 -> ?integer_neg; t_from_range(neg_inf, Y) when is_integer(Y), Y >= 0 -> t_integer(); @@ -2383,6 +2385,8 @@ t_from_range(pos_inf, neg_inf) -> t_none(). -spec t_from_range_unsafe(rng_elem(), rng_elem()) -> erl_type(). +t_from_range_unsafe(pos_inf, pos_inf) -> ?integer_pos; +t_from_range_unsafe(neg_inf, neg_inf) -> ?integer_neg; t_from_range_unsafe(neg_inf, pos_inf) -> t_integer(); t_from_range_unsafe(neg_inf, Y) -> ?int_range(neg_inf, Y); t_from_range_unsafe(X, pos_inf) -> ?int_range(X, pos_inf); diff --git a/lib/hipe/icode/hipe_beam_to_icode.erl b/lib/hipe/icode/hipe_beam_to_icode.erl index 7ff9fd83eb..f429d40272 100644 --- a/lib/hipe/icode/hipe_beam_to_icode.erl +++ b/lib/hipe/icode/hipe_beam_to_icode.erl @@ -605,6 +605,16 @@ trans_fun([{get_list,List,Head,Tail}|Instructions], Env) -> ?error_msg("hd and tl regs identical in get_list~n",[]), erlang:error(not_handled) end; +%%--- get_hd --- +trans_fun([{get_hd,List,Head}|Instructions], Env) -> + TransList = [trans_arg(List)], + I = hipe_icode:mk_primop([mk_var(Head)],unsafe_hd,TransList), + [I | trans_fun(Instructions,Env)]; +%%--- get_tl --- +trans_fun([{get_tl,List,Tail}|Instructions], Env) -> + TransList = [trans_arg(List)], + I = hipe_icode:mk_primop([mk_var(Tail)],unsafe_tl,TransList), + [I | trans_fun(Instructions,Env)]; %%--- get_tuple_element --- trans_fun([{get_tuple_element,Xreg,Index,Dst}|Instructions], Env) -> I = hipe_icode:mk_primop([mk_var(Dst)], @@ -1164,6 +1174,12 @@ trans_fun([build_stacktrace|Instructions], Env) -> Vars = [mk_var({x,0})], %{x,0} is implict arg and dst [hipe_icode:mk_primop(Vars,build_stacktrace,Vars), trans_fun(Instructions, Env)]; +%%--- raw_raise --- +trans_fun([raw_raise|Instructions], Env) -> + Vars = [mk_var({x,0}),mk_var({x,1}),mk_var({x,2})], + Dst = [mk_var({x,0})], + [hipe_icode:mk_primop(Dst,raw_raise,Vars) | + trans_fun(Instructions, Env)]; %%-------------------------------------------------------------------- %%--- ERROR HANDLING --- %%-------------------------------------------------------------------- diff --git a/lib/hipe/icode/hipe_icode_primops.erl b/lib/hipe/icode/hipe_icode_primops.erl index 941516e8b1..a1f1128124 100644 --- a/lib/hipe/icode/hipe_icode_primops.erl +++ b/lib/hipe/icode/hipe_icode_primops.erl @@ -236,6 +236,7 @@ fails({hipe_bs_primop, {bs_append, _, _, _, _}}) -> true; fails({hipe_bs_primop, {bs_private_append, _, _}}) -> true; fails({hipe_bs_primop, bs_init_writable}) -> true; fails(build_stacktrace) -> false; +fails(raw_raise) -> true; fails(#mkfun{}) -> false; fails(#unsafe_element{}) -> false; fails(#unsafe_update_element{}) -> false; @@ -735,6 +736,8 @@ type(Primop, Args) -> erl_types:t_any(); build_stacktrace -> erl_types:t_list(); + raw_raise -> + erl_types:t_atom(); {M, F, A} -> erl_bif_types:type(M, F, A, Args) end. @@ -909,6 +912,8 @@ type(Primop) -> %%% Other build_stacktrace -> erl_types:t_any(); + raw_raise -> + erl_types:t_any(); #closure_element{} -> erl_types:t_any(); redtest -> diff --git a/lib/hipe/icode/hipe_icode_range.erl b/lib/hipe/icode/hipe_icode_range.erl index cf74c1eb5b..34b18acccd 100644 --- a/lib/hipe/icode/hipe_icode_range.erl +++ b/lib/hipe/icode/hipe_icode_range.erl @@ -1187,7 +1187,8 @@ basic_type(unsafe_tl) -> not_int; basic_type(#element{}) -> not_analysed; basic_type(#unsafe_element{}) -> not_analysed; basic_type(#unsafe_update_element{}) -> not_analysed; -basic_type(build_stacktrace) -> not_int. +basic_type(build_stacktrace) -> not_int; +basic_type(raw_raise) -> not_int. -spec analyse_bs_get_integer(integer(), integer(), boolean()) -> range_tuple(). diff --git a/lib/hipe/llvm/hipe_llvm.erl b/lib/hipe/llvm/hipe_llvm.erl index ccd40162cb..343ca94cb1 100644 --- a/lib/hipe/llvm/hipe_llvm.erl +++ b/lib/hipe/llvm/hipe_llvm.erl @@ -934,7 +934,7 @@ pp_ins(Dev, Ver, I) -> end, case call_is_tail(I) of true -> write(Dev, "tail "); - false -> ok + false -> write(Dev, "notail ") end, write(Dev, ["call ", call_cconv(I), " "]), pp_options(Dev, call_ret_attrs(I)), diff --git a/lib/hipe/main/hipe_main.erl b/lib/hipe/main/hipe_main.erl index 4b5eb4c63e..6e48f0cffd 100644 --- a/lib/hipe/main/hipe_main.erl +++ b/lib/hipe/main/hipe_main.erl @@ -410,9 +410,9 @@ icode_to_rtl(MFA, Icode, Options, Servers) -> hipe_llvm_liveness:analyze(RtlCfg4) end, pp(RtlCfg5, MFA, rtl, pp_rtl, Options, Servers), - case proplists:get_bool(verify_gcsafe, Options) of - false -> ok; - true -> + case proplists:get_bool(no_verify_gcsafe, Options) of + true -> ok; + false -> ok = hipe_rtl_verify_gcsafe:check(RtlCfg5) end, LinearRTL1 = hipe_rtl_cfg:linearize(RtlCfg5), diff --git a/lib/hipe/rtl/hipe_rtl_primops.erl b/lib/hipe/rtl/hipe_rtl_primops.erl index d646b78a3d..ce5433379e 100644 --- a/lib/hipe/rtl/hipe_rtl_primops.erl +++ b/lib/hipe/rtl/hipe_rtl_primops.erl @@ -396,6 +396,8 @@ gen_primop({Op,Dst,Args,Cont,Fail}, IsGuard, ConstTab) -> [hipe_rtl:mk_call(Dst, Op, Args, Cont, Fail, not_remote)]; build_stacktrace -> [hipe_rtl:mk_call(Dst, Op, Args, Cont, Fail, not_remote)]; + raw_raise -> + [hipe_rtl:mk_call(Dst, Op, Args, Cont, Fail, not_remote)]; %% Only names listed above are accepted! MFA:s are not primops! _ -> diff --git a/lib/hipe/rtl/hipe_rtl_verify_gcsafe.erl b/lib/hipe/rtl/hipe_rtl_verify_gcsafe.erl index c3f20bfec1..01d7e89ccd 100644 --- a/lib/hipe/rtl/hipe_rtl_verify_gcsafe.erl +++ b/lib/hipe/rtl/hipe_rtl_verify_gcsafe.erl @@ -76,6 +76,7 @@ safe_primop(bs_allocate) -> true; safe_primop(bs_reallocate) -> true; safe_primop(bs_utf8_size) -> true; safe_primop(bs_get_utf8) -> true; +safe_primop(bs_put_utf8) -> true; safe_primop(bs_utf16_size) -> true; safe_primop(bs_get_utf16) -> true; safe_primop(bs_validate_unicode_retract) -> true; diff --git a/lib/hipe/test/basic_SUITE_data/basic_exceptions.erl b/lib/hipe/test/basic_SUITE_data/basic_exceptions.erl index d71b924d22..ba9c03d4ba 100644 --- a/lib/hipe/test/basic_SUITE_data/basic_exceptions.erl +++ b/lib/hipe/test/basic_SUITE_data/basic_exceptions.erl @@ -24,6 +24,7 @@ test() -> ok = test_bad_fun_call(), ok = test_guard_bif(), ok = test_eclectic(), + ok = test_raise(), ok. %%-------------------------------------------------------------------- @@ -579,3 +580,99 @@ my_add(A, B) -> my_abs(X) -> abs(X). + +test_raise() -> + test_raise(fun() -> exit({exit,tuple}) end), + test_raise(fun() -> abs(id(x)) end), + test_raise(fun() -> throw({was,thrown}) end), + + badarg = bad_raise(fun() -> abs(id(x)) end), + + ok. + +bad_raise(Expr) -> + try + Expr() + catch + _:E:Stk -> + erlang:raise(bad_class, E, Stk) + end. + +test_raise(Expr) -> + test_raise_1(Expr), + test_raise_2(Expr), + test_raise_3(Expr). + +test_raise_1(Expr) -> + erase(exception), + try + do_test_raise_1(Expr) + catch + C:E:Stk -> + {C,E,Stk} = erase(exception) + end. + +do_test_raise_1(Expr) -> + try + Expr() + catch + C:E:Stk -> + %% Here the stacktrace must be built. + put(exception, {C,E,Stk}), + erlang:raise(C, E, Stk) + end. + +test_raise_2(Expr) -> + erase(exception), + try + do_test_raise_2(Expr) + catch + C:E:Stk -> + {C,E} = erase(exception), + try + Expr() + catch + _:_:S -> + [StkTop|_] = S, + [StkTop|_] = Stk + end + end. + +do_test_raise_2(Expr) -> + try + Expr() + catch + C:E:Stk -> + %% Here it is possible to replace erlang:raise/3 with + %% the raw_raise/3 instruction since the stacktrace is + %% not actually used. + put(exception, {C,E}), + erlang:raise(C, E, Stk) + end. + +test_raise_3(Expr) -> + try + do_test_raise_3(Expr) + catch + exit:{exception,C,E}:Stk -> + try + Expr() + catch + C:E:S -> + [StkTop|_] = S, + [StkTop|_] = Stk + end + end. + +do_test_raise_3(Expr) -> + try + Expr() + catch + C:E:Stk -> + %% Here it is possible to replace erlang:raise/3 with + %% the raw_raise/3 instruction since the stacktrace is + %% not actually used. + erlang:raise(exit, {exception,C,E}, Stk) + end. + +id(I) -> I. diff --git a/lib/hipe/x86/hipe_rtl_to_x86.erl b/lib/hipe/x86/hipe_rtl_to_x86.erl index 31e4f6e4ac..22947da148 100644 --- a/lib/hipe/x86/hipe_rtl_to_x86.erl +++ b/lib/hipe/x86/hipe_rtl_to_x86.erl @@ -646,7 +646,7 @@ conv_imm(Opnd, Map) -> is_imm64(Value) when is_integer(Value) -> (Value < -(1 bsl (32 - 1))) or (Value > (1 bsl (32 - 1)) - 1); is_imm64({_,atom}) -> false; % Atoms are 32 bits. -is_imm64({_,c_const}) -> false; % c_consts are 32 bits. +is_imm64({_,c_const}) -> true; % c_consts are 64 bits. is_imm64({_,_}) -> true . % Other relocs are 64 bits. -else. conv_imm(Opnd, Map) -> @@ -777,6 +777,18 @@ conv_fconv(Dst, Src) -> %%% Finalise the conversion of a 2-address FP operation. +-ifdef(HIPE_AMD64). +conv_fp_unary(Dst, Src, 'fchs') -> + Tmp = new_untagged_temp(), + case same_opnd(Dst, Src) of + true -> + []; + _ -> + [hipe_x86:mk_fmove(Src, Dst)] + end ++ + mk_load_address(c_const, hipe_x86:mk_imm({sse2_fnegate_mask, c_const}), Tmp) ++ + [hipe_x86:mk_fp_binop('xorpd', hipe_x86:mk_mem(Tmp, hipe_x86:mk_imm(0), double), Dst)]. +-else. conv_fp_unary(Dst, Src, FpUnOp) -> case same_opnd(Dst, Src) of true -> @@ -785,6 +797,7 @@ conv_fp_unary(Dst, Src, FpUnOp) -> [hipe_x86:mk_fmove(Src, Dst), hipe_x86:mk_fp_unop(FpUnOp, Dst)] end. +-endif. conv_fp_unop(RtlFpUnOp) -> case RtlFpUnOp of @@ -854,13 +867,8 @@ mk_jmp_switch(Index, JTabLab, Labels) -> %%% Finalise the translation of a load_address instruction. -ifdef(HIPE_AMD64). -mk_load_address(Type, Src, Dst) -> - case Type of - c_const -> % 32 bits - [hipe_x86:mk_move(Src, Dst)]; - _ -> - [hipe_x86:mk_move64(Src, Dst)] - end. +mk_load_address(_Type, Src, Dst) -> + [hipe_x86:mk_move64(Src, Dst)]. -else. mk_load_address(_Type, Src, Dst) -> [hipe_x86:mk_move(Src, Dst)]. diff --git a/lib/hipe/x86/hipe_x86_assemble.erl b/lib/hipe/x86/hipe_x86_assemble.erl index 50919bdf4e..9d2586a14d 100644 --- a/lib/hipe/x86/hipe_x86_assemble.erl +++ b/lib/hipe/x86/hipe_x86_assemble.erl @@ -735,6 +735,7 @@ resolve_sse2_op(Op) -> fdiv -> divsd; fmul -> mulsd; fsub -> subsd; + xorpd -> xorpd; _ -> exit({?MODULE, unknown_sse2_operator, Op}) end. diff --git a/lib/inets/src/http_client/httpc_handler.erl b/lib/inets/src/http_client/httpc_handler.erl index 1482f4f922..e398b4f0aa 100644 --- a/lib/inets/src/http_client/httpc_handler.erl +++ b/lib/inets/src/http_client/httpc_handler.erl @@ -711,9 +711,9 @@ do_handle_info({'EXIT', _, _}, State = #state{request = undefined}) -> %% can retry requests in the pipeline. do_handle_info({'EXIT', _, _}, State) -> {noreply, State#state{status = close}}. - + call(Msg, Pid) -> - try gen_server:call(Pid, Msg) + try gen_server:call(Pid, Msg, infinity) catch exit:{noproc, _} -> {error, closed}; @@ -1685,9 +1685,8 @@ update_session(ProfileName, #session{id = SessionId} = Session, Pos, Value) -> insert_session(Session2, ProfileName); error:badarg -> {stop, normal}; - T:E -> + T:E:Stacktrace -> %% Unexpected this must be an error! - Stacktrace = erlang:get_stacktrace(), error_logger:error_msg("Failed updating session: " "~n ProfileName: ~p" "~n SessionId: ~p" diff --git a/lib/inets/src/http_server/httpd_response.erl b/lib/inets/src/http_server/httpd_response.erl index 6b9053fda6..57ce162922 100644 --- a/lib/inets/src/http_server/httpd_response.erl +++ b/lib/inets/src/http_server/httpd_response.erl @@ -84,14 +84,14 @@ traverse_modules(ModData,[Module|Rest]) -> {proceed, NewData} -> traverse_modules(ModData#mod{data = NewData}, Rest) catch - T:E -> + T:E:Stacktrace -> String = lists:flatten( io_lib:format("module traverse failed: ~p:do => " "~n Error Type: ~p" "~n Error: ~p" "~n Stack trace: ~p", - [Module, T, E, ?STACK()])), + [Module, T, E, Stacktrace])), httpd_util:error_log(ModData#mod.config_db, String), send_status(ModData, 500, none), done diff --git a/lib/inets/src/inets_app/inets.appup.src b/lib/inets/src/inets_app/inets.appup.src index fdf4cc6e07..e24a4a8694 100644 --- a/lib/inets/src/inets_app/inets.appup.src +++ b/lib/inets/src/inets_app/inets.appup.src @@ -18,13 +18,13 @@ %% %CopyrightEnd% {"%VSN%", [ - {<<"6.4.3">>, [{load_module, httpd_esi, + {<<"6.4.5">>, [{load_module, httpc_handler, soft_purge, soft_purge, []}]}, {<<"6\\..*">>,[{restart_application, inets}]}, {<<"5\\..*">>,[{restart_application, inets}]} ], [ - {<<"6.4.3">>, [{load_module, httpd_esi, + {<<"6.4.5">>, [{load_module, httpc_handler, soft_purge, soft_purge, []}]}, {<<"6\\..*">>,[{restart_application, inets}]}, {<<"5\\..*">>,[{restart_application, inets}]} diff --git a/lib/inets/src/inets_app/inets_internal.hrl b/lib/inets/src/inets_app/inets_internal.hrl index 079b415b56..e0f59bba5f 100644 --- a/lib/inets/src/inets_app/inets_internal.hrl +++ b/lib/inets/src/inets_app/inets_internal.hrl @@ -22,8 +22,6 @@ -ifndef(inets_internal_hrl). -define(inets_internal_hrl, true). --define(STACK(), erlang:get_stacktrace()). - %% Various trace macros -define(report(Severity, Label, Service, Content), diff --git a/lib/inets/test/httpc_SUITE.erl b/lib/inets/test/httpc_SUITE.erl index 0533b9ab70..4bb449408f 100644 --- a/lib/inets/test/httpc_SUITE.erl +++ b/lib/inets/test/httpc_SUITE.erl @@ -50,6 +50,7 @@ all() -> [ {group, http}, {group, sim_http}, + {group, http_internal}, {group, https}, {group, sim_https}, {group, misc} @@ -62,6 +63,7 @@ groups() -> %% and it shall be the last test case in the suite otherwise cookie %% will fail. {sim_http, [], only_simulated() ++ [process_leak_on_keepalive]}, + {http_internal, [], real_requests_esi()}, {https, [], real_requests()}, {sim_https, [], only_simulated()}, {misc, [], misc()} @@ -97,6 +99,9 @@ real_requests()-> invalid_body ]. +real_requests_esi() -> + [slow_connection]. + only_simulated() -> [ cookie, @@ -1245,7 +1250,25 @@ stream_fun_server_close(Config) when is_list(Config) -> after 13000 -> ct:fail(did_not_receive_close) end. - + +%%-------------------------------------------------------------------- +slow_connection() -> + [{doc, "Test that a request on a slow keep-alive connection won't crash the httpc_manager"}]. +slow_connection(Config) when is_list(Config) -> + BodyFun = fun(0) -> eof; + (LenLeft) -> timer:sleep(1000), + {ok, lists:duplicate(10, "1"), LenLeft - 10} + end, + Request = {url(group_name(Config), "/httpc_SUITE:esi_post", Config), + [{"content-length", "100"}], + "text/plain", + {BodyFun, 100}}, + {ok, _} = httpc:request(post, Request, [], []), + %% Second request causes a crash if gen_server timeout is not set to infinity + %% in httpc_handler. + {ok, _} = httpc:request(post, Request, [], []). + + %%-------------------------------------------------------------------- %% Internal Functions ------------------------------------------------ %%-------------------------------------------------------------------- @@ -1339,6 +1362,8 @@ url(https, End, Config) -> ?TLS_URL_START ++ Host ++ ":" ++ integer_to_list(Port) ++ End; url(sim_http, End, Config) -> url(http, End, Config); +url(http_internal, End, Config) -> + url(http, End, Config); url(sim_https, End, Config) -> url(https, End, Config). url(http, UserInfo, End, Config) -> @@ -1385,7 +1410,17 @@ server_config(http, Config) -> {mime_type, "text/plain"}, {script_alias, {"/cgi-bin/", filename:join(ServerRoot, "cgi-bin") ++ "/"}} ]; - +server_config(http_internal, Config) -> + ServerRoot = proplists:get_value(server_root, Config), + [{port, 0}, + {server_name,"httpc_test"}, + {server_root, ServerRoot}, + {document_root, proplists:get_value(doc_root, Config)}, + {bind_address, any}, + {ipfamily, inet_version()}, + {mime_type, "text/plain"}, + {erl_script_alias, {"", [httpc_SUITE]}} + ]; server_config(https, Config) -> [{socket_type, {essl, ssl_config(Config)}} | server_config(http, Config)]; server_config(sim_https, Config) -> @@ -1393,6 +1428,9 @@ server_config(sim_https, Config) -> server_config(_, _) -> []. +esi_post(Sid, _Env, _Input) -> + mod_esi:deliver(Sid, ["OK"]). + start_apps(https) -> inets_test_lib:start_apps([crypto, public_key, ssl]); start_apps(sim_https) -> diff --git a/lib/inets/vsn.mk b/lib/inets/vsn.mk index 05cf4f6cc3..dccdbfa94a 100644 --- a/lib/inets/vsn.mk +++ b/lib/inets/vsn.mk @@ -19,6 +19,6 @@ # %CopyrightEnd% APPLICATION = inets -INETS_VSN = 6.4.5 +INETS_VSN = 6.4.6 PRE_VSN = APP_VSN = "$(APPLICATION)-$(INETS_VSN)$(PRE_VSN)" diff --git a/lib/kernel/doc/src/code.xml b/lib/kernel/doc/src/code.xml index c94f612c01..bd95819636 100644 --- a/lib/kernel/doc/src/code.xml +++ b/lib/kernel/doc/src/code.xml @@ -34,26 +34,28 @@ <p>This module contains the interface to the Erlang <em>code server</em>, which deals with the loading of compiled code into a running Erlang runtime system.</p> - <p>The runtime system can be started in <em>embedded</em> or - <em>interactive</em> mode. Which one is decided by command-line + <p>The runtime system can be started in <em>interactive</em> or + <em>embedded</em> mode. Which one is decided by the command-line flag <c>-mode</c>:</p> <pre> % <input>erl -mode interactive</input></pre> <p>The modes are as follows:</p> <list type="bulleted"> <item> - <p>In embedded mode, all code is loaded during system startup - according to the boot script. (Code can also be loaded later - by explicitly ordering the code server to do so).</p> - </item> - <item> <p>In interactive mode, which is default, only some code is loaded - during system startup, basically the modules needed by the runtime + during system startup, basically the modules needed by the runtime system. Other code is dynamically loaded when first referenced. When a call to a function in a certain module is made, and the module is not loaded, the code server searches for and tries to load the module.</p> </item> + <item> + <p>In embedded mode, modules are not auto loaded. Trying to use + a module that has not been loaded results in an error. This mode is + recommended when the boot script loads all modules, as it is + typically done in OTP releases. (Code can still be loaded later + by explicitly ordering the code server to do so).</p> + </item> </list> <p>To prevent accidentally reloading of modules affecting the Erlang runtime system, directories <c>kernel</c>, <c>stdlib</c>, diff --git a/lib/kernel/doc/src/notes.xml b/lib/kernel/doc/src/notes.xml index d7f224c38e..65fe9b9c07 100644 --- a/lib/kernel/doc/src/notes.xml +++ b/lib/kernel/doc/src/notes.xml @@ -31,6 +31,26 @@ </header> <p>This document describes the changes made to the Kernel application.</p> +<section><title>Kernel 5.4.2</title> + + <section><title>Fixed Bugs and Malfunctions</title> + <list> + <item> + <p> + Add <c>os:cmd/2</c> that takes an options map as the + second argument.</p> + <p> + Add <c>max_size</c> as an option to <c>os:cmd/2</c> that + control the maximum size of the result that + <c>os:cmd/2</c> will return.</p> + <p> + Own Id: OTP-14823</p> + </item> + </list> + </section> + +</section> + <section><title>Kernel 5.4.1</title> <section><title>Fixed Bugs and Malfunctions</title> diff --git a/lib/kernel/doc/src/os.xml b/lib/kernel/doc/src/os.xml index c27182ff0b..ef416ed233 100644 --- a/lib/kernel/doc/src/os.xml +++ b/lib/kernel/doc/src/os.xml @@ -103,7 +103,7 @@ </desc> </datatype> <datatype> - <name name="command_input"/> + <name name="os_command"/> <desc> <p>All characters needs to be valid characters on the specific OS using @@ -116,19 +116,31 @@ </p> </desc> </datatype> + <datatype> + <name name="os_command_opts"/> + <desc> + <p>Options for <seealso marker="#cmd/2"><c>os:cmd/2</c></seealso></p> + <taglist> + <tag><c>max_size</c></tag> + <item> + <p>The maximum size of the data returned by the <c>os:cmd</c> call. + See the <seealso marker="#cmd/2"><c>os:cmd/2</c></seealso> + documentation for more details.</p> + </item> + </taglist> + </desc> + </datatype> </datatypes> - + <funcs> <func> <name name="cmd" arity="1"/> + <name name="cmd" arity="2"/> <fsummary>Execute a command in a shell of the target OS.</fsummary> <desc> <p>Executes <c><anno>Command</anno></c> in a command shell of the - target OS, - captures the standard output of the command, and returns this - result as a string. This function is a replacement of - the previous function <c>unix:cmd/1</c>; they are equivalent on a - Unix platform.</p> + target OS, captures the standard output of the command, + and returns this result as a string.</p> <warning><p>Previous implementation used to allow all characters as long as they were integer values greater than or equal to zero. This sometimes lead to unwanted results since null characters @@ -142,6 +154,21 @@ DirOut = os:cmd("dir"), % on Win32 platform</code> called from another program (for example, <c>os:cmd/1</c>) can differ, compared with the standard output of the command when called directly from an OS command shell.</p> + <p><c>os:cmd/2</c> was added in kernel-5.5 (OTP-20.2.1). It makes it + possible to pass an options map as the second argument in order to + control the behaviour of <c>os:cmd</c>. The possible options are: + </p> + <taglist> + <tag><c>max_size</c></tag> + <item> + <p>The maximum size of the data returned by the <c>os:cmd</c> call. + This option is a safety feature that should be used when the command + executed can return a very large, possibly infinite, result.</p> + <code type="none"> +> os:cmd("cat /dev/zero", #{ max_size => 20 }). +[0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0]</code> + </item> + </taglist> </desc> </func> diff --git a/lib/kernel/src/code_server.erl b/lib/kernel/src/code_server.erl index 418b0c50e1..f5a890cb95 100644 --- a/lib/kernel/src/code_server.erl +++ b/lib/kernel/src/code_server.erl @@ -340,8 +340,7 @@ handle_call(all_loaded, _From, S) -> {reply,all_loaded(Db),S}; handle_call({get_object_code,Mod}, _From, St) when is_atom(Mod) -> - Path = St#state.path, - case mod_to_bin(Path, Mod) of + case get_object_code(St, Mod) of {_,Bin,FName} -> {reply,{Mod,Bin,FName},St}; Error -> {reply,Error,St} end; @@ -1182,19 +1181,28 @@ load_file(Mod, From, St0) -> end, handle_pending_on_load(Action, Mod, From, St0). -load_file_1(Mod, From, #state{path=Path}=St) -> - case mod_to_bin(Path, Mod) of +load_file_1(Mod, From, St) -> + case get_object_code(St, Mod) of error -> {reply,{error,nofile},St}; {Mod,Binary,File} -> try_load_module_1(File, Mod, Binary, From, St) end. -mod_to_bin([Dir|Tail], Mod) -> - File = filename:append(Dir, atom_to_list(Mod) ++ objfile_extension()), +get_object_code(#state{path=Path}, Mod) when is_atom(Mod) -> + ModStr = atom_to_list(Mod), + case erl_prim_loader:is_basename(ModStr) of + true -> + mod_to_bin(Path, Mod, ModStr ++ objfile_extension()); + false -> + error + end. + +mod_to_bin([Dir|Tail], Mod, ModFile) -> + File = filename:append(Dir, ModFile), case erl_prim_loader:get_file(File) of error -> - mod_to_bin(Tail, Mod); + mod_to_bin(Tail, Mod, ModFile); {ok,Bin,_} -> case filename:pathtype(File) of absolute -> @@ -1203,10 +1211,9 @@ mod_to_bin([Dir|Tail], Mod) -> {Mod,Bin,absname(File)} end end; -mod_to_bin([], Mod) -> +mod_to_bin([], Mod, ModFile) -> %% At last, try also erl_prim_loader's own method - File = to_list(Mod) ++ objfile_extension(), - case erl_prim_loader:get_file(File) of + case erl_prim_loader:get_file(ModFile) of error -> error; % No more alternatives ! {ok,Bin,FName} -> diff --git a/lib/kernel/src/disk_log.erl b/lib/kernel/src/disk_log.erl index 70cbf1c87c..99ea8dc384 100644 --- a/lib/kernel/src/disk_log.erl +++ b/lib/kernel/src/disk_log.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1997-2017. All Rights Reserved. +%% Copyright Ericsson AB 1997-2018. 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. @@ -266,7 +266,7 @@ inc_wrap_file(Log) -> Size :: dlog_size(), Reason :: no_such_log | nonode | {read_only_mode, Log} | {blocked_log, Log} - | {new_size_too_small, CurrentSize :: pos_integer()} + | {new_size_too_small, Log, CurrentSize :: pos_integer()} | {badarg, size} | {file_error, file:filename(), file_error()}. change_size(Log, NewSize) -> diff --git a/lib/kernel/src/dist_util.erl b/lib/kernel/src/dist_util.erl index fb9f7fd7eb..5ea0ca991f 100644 --- a/lib/kernel/src/dist_util.erl +++ b/lib/kernel/src/dist_util.erl @@ -539,8 +539,8 @@ do_setnode(#hs_data{other_node = Node, socket = Socket, "no table space left for node ~w ** ~n", [Node]), ?shutdown(Node); - error:Other -> - exit({Other, erlang:get_stacktrace()}) + error:Other:Stacktrace -> + exit({Other, Stacktrace}) end; _ -> error_msg("** Distribution connection error, " diff --git a/lib/kernel/src/erl_boot_server.erl b/lib/kernel/src/erl_boot_server.erl index 2a38266579..4ac945ce01 100644 --- a/lib/kernel/src/erl_boot_server.erl +++ b/lib/kernel/src/erl_boot_server.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1996-2017. All Rights Reserved. +%% Copyright Ericsson AB 1996-2018. 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. @@ -58,13 +58,11 @@ -define(single_addr_mask, {255, 255, 255, 255}). --type ip4_address() :: {0..255,0..255,0..255,0..255}. - --spec start(Slaves) -> {'ok', Pid} | {'error', What} when +-spec start(Slaves) -> {'ok', Pid} | {'error', Reason} when Slaves :: [Host], - Host :: atom(), + Host :: inet:ip_address() | inet:hostname(), Pid :: pid(), - What :: any(). + Reason :: {'badarg', Slaves}. start(Slaves) -> case check_arg(Slaves) of @@ -74,11 +72,11 @@ start(Slaves) -> {error, {badarg, Slaves}} end. --spec start_link(Slaves) -> {'ok', Pid} | {'error', What} when +-spec start_link(Slaves) -> {'ok', Pid} | {'error', Reason} when Slaves :: [Host], - Host :: atom(), + Host :: inet:ip_address() | inet:hostname(), Pid :: pid(), - What :: any(). + Reason :: {'badarg', Slaves}. start_link(Slaves) -> case check_arg(Slaves) of @@ -104,10 +102,10 @@ check_arg([], Result) -> check_arg(_, _Result) -> error. --spec add_slave(Slave) -> 'ok' | {'error', What} when +-spec add_slave(Slave) -> 'ok' | {'error', Reason} when Slave :: Host, - Host :: atom(), - What :: any(). + Host :: inet:ip_address() | inet:hostname(), + Reason :: {'badarg', Slave}. add_slave(Slave) -> case inet:getaddr(Slave, inet) of @@ -117,10 +115,10 @@ add_slave(Slave) -> {error, {badarg, Slave}} end. --spec delete_slave(Slave) -> 'ok' | {'error', What} when +-spec delete_slave(Slave) -> 'ok' | {'error', Reason} when Slave :: Host, - Host :: atom(), - What :: any(). + Host :: inet:ip_address() | inet:hostname(), + Reason :: {'badarg', Slave}. delete_slave(Slave) -> case inet:getaddr(Slave, inet) of @@ -130,7 +128,7 @@ delete_slave(Slave) -> {error, {badarg, Slave}} end. --spec add_subnet(Mask :: ip4_address(), Addr :: ip4_address()) -> +-spec add_subnet(Netmask :: inet:ip_address(), Addr :: inet:ip_address()) -> 'ok' | {'error', any()}. add_subnet(Mask, Addr) when is_tuple(Mask), is_tuple(Addr) -> @@ -141,14 +139,15 @@ add_subnet(Mask, Addr) when is_tuple(Mask), is_tuple(Addr) -> {error, empty_subnet} end. --spec delete_subnet(Mask :: ip4_address(), Addr :: ip4_address()) -> 'ok'. +-spec delete_subnet(Netmask :: inet:ip_address(), + Addr :: inet:ip_address()) -> 'ok'. delete_subnet(Mask, Addr) when is_tuple(Mask), is_tuple(Addr) -> gen_server:call(boot_server, {delete, {Mask, Addr}}). -spec which_slaves() -> Slaves when - Slaves :: [Host], - Host :: atom(). + Slaves :: [Slave], + Slave :: {Netmask :: inet:ip_address(), Address :: inet:ip_address()}. which_slaves() -> gen_server:call(boot_server, which). diff --git a/lib/kernel/src/error_handler.erl b/lib/kernel/src/error_handler.erl index 59ca8e690d..a9582c6225 100644 --- a/lib/kernel/src/error_handler.erl +++ b/lib/kernel/src/error_handler.erl @@ -106,8 +106,8 @@ crash(M, F, A) -> crash(Tuple) -> try erlang:error(undef) catch - error:undef -> - Stk = [Tuple|tl(erlang:get_stacktrace())], + error:undef:Stacktrace -> + Stk = [Tuple|tl(Stacktrace)], erlang:raise(error, undef, Stk) end. diff --git a/lib/kernel/src/file.erl b/lib/kernel/src/file.erl index d05199897f..c2df1ee288 100644 --- a/lib/kernel/src/file.erl +++ b/lib/kernel/src/file.erl @@ -1382,8 +1382,8 @@ eval_stream2({ok,Form,EndLine}, Fd, H, Last, E, Bs0) -> try erl_eval:exprs(Form, Bs0) of {value,V,Bs} -> eval_stream(Fd, H, EndLine, {V}, E, Bs) - catch Class:Reason -> - Error = {EndLine,?MODULE,{Class,Reason,erlang:get_stacktrace()}}, + catch Class:Reason:StackTrace -> + Error = {EndLine,?MODULE,{Class,Reason,StackTrace}}, eval_stream(Fd, H, EndLine, Last, [Error|E], Bs0) end; eval_stream2({error,What,EndLine}, Fd, H, Last, E, Bs) -> diff --git a/lib/kernel/src/group_history.erl b/lib/kernel/src/group_history.erl index 91f3663cc5..9745848992 100644 --- a/lib/kernel/src/group_history.erl +++ b/lib/kernel/src/group_history.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 2017. All Rights Reserved. +%% Copyright Ericsson AB 2017-2018. 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. @@ -260,7 +260,7 @@ resize_log(Name, _OldSize, NewSize) -> ok -> show('$#erlang-history-resize-result', "ok~n", []); - {error, {new_size_too_small, _}} -> + {error, {new_size_too_small, _, _}} -> show('$#erlang-history-resize-result', "failed (new size is too small)~n", []), disable_history(); diff --git a/lib/kernel/src/hipe_unified_loader.erl b/lib/kernel/src/hipe_unified_loader.erl index f4c7c277ed..fd06f0f7d8 100644 --- a/lib/kernel/src/hipe_unified_loader.erl +++ b/lib/kernel/src/hipe_unified_loader.erl @@ -236,9 +236,10 @@ load_common(Mod, Bin, Beam, Architecture) -> lists:foreach(fun({FE, DestAddress}) -> hipe_bifs:set_native_address_in_fe(FE, DestAddress) end, erase(closures_to_patch)), - ok = hipe_bifs:commit_patch_load(LoaderState), set_beam_call_traps(FunDefs), - ok; + export_funs(FunDefs), + ok = hipe_bifs:commit_patch_load(LoaderState), + ok; BeamBinary when is_binary(BeamBinary) -> %% Find all closures in the code. [] = erase(closures_to_patch), %Clean up, assertion. @@ -274,6 +275,7 @@ needs_trampolines(Architecture) -> arm -> true; powerpc -> true; ppc64 -> true; + amd64 -> true; _ -> false end. diff --git a/lib/kernel/src/os.erl b/lib/kernel/src/os.erl index fbc046c8f9..1e9db80058 100644 --- a/lib/kernel/src/os.erl +++ b/lib/kernel/src/os.erl @@ -21,11 +21,11 @@ %% Provides a common operating system interface. --export([type/0, version/0, cmd/1, find_executable/1, find_executable/2]). +-export([type/0, version/0, cmd/1, cmd/2, find_executable/1, find_executable/2]). -include("file.hrl"). --export_type([env_var_name/0, env_var_value/0, env_var_name_value/0, command_input/0]). +-export_type([env_var_name/0, env_var_value/0, env_var_name_value/0]). -export([getenv/0, getenv/1, getenv/2, putenv/2, unsetenv/1]). @@ -35,14 +35,17 @@ perf_counter/1, set_env_var/2, set_signal/2, system_time/0, system_time/1, timestamp/0, unset_env_var/1]). +-type os_command() :: atom() | io_lib:chars(). +-type os_command_opts() :: #{ max_size => non_neg_integer() | infinity }. + +-export_type([os_command/0, os_command_opts/0]). + -type env_var_name() :: nonempty_string(). -type env_var_value() :: string(). -type env_var_name_value() :: nonempty_string(). --type command_input() :: atom() | io_lib:chars(). - -spec list_env_vars() -> [{env_var_name(), env_var_value()}]. list_env_vars() -> erlang:nif_error(undef). @@ -260,14 +263,20 @@ extensions() -> %% Executes the given command in the default shell for the operating system. -spec cmd(Command) -> string() when - Command :: os:command_input(). + Command :: os_command(). cmd(Cmd) -> + cmd(Cmd, #{ }). + +-spec cmd(Command, Options) -> string() when + Command :: os_command(), + Options :: os_command_opts(). +cmd(Cmd, Opts) -> {SpawnCmd, SpawnOpts, SpawnInput, Eot} = mk_cmd(os:type(), validate(Cmd)), Port = open_port({spawn, SpawnCmd}, [binary, stderr_to_stdout, stream, in, hide | SpawnOpts]), MonRef = erlang:monitor(port, Port), true = port_command(Port, SpawnInput), - Bytes = get_data(Port, MonRef, Eot, []), + Bytes = get_data(Port, MonRef, Eot, [], 0, maps:get(max_size, Opts, infinity)), demonitor(MonRef, [flush]), String = unicode:characters_to_list(Bytes), if %% Convert to unicode list if possible otherwise return bytes @@ -332,12 +341,13 @@ validate2([List|Rest]) when is_list(List) -> validate2(List), validate2(Rest). -get_data(Port, MonRef, Eot, Sofar) -> +get_data(Port, MonRef, Eot, Sofar, Size, Max) -> receive {Port, {data, Bytes}} -> - case eot(Bytes, Eot) of + case eot(Bytes, Eot, Size, Max) of more -> - get_data(Port, MonRef, Eot, [Sofar,Bytes]); + get_data(Port, MonRef, Eot, [Sofar, Bytes], + Size + byte_size(Bytes), Max); Last -> catch port_close(Port), flush_until_down(Port, MonRef), @@ -348,13 +358,16 @@ get_data(Port, MonRef, Eot, Sofar) -> iolist_to_binary(Sofar) end. -eot(_Bs, <<>>) -> +eot(_Bs, <<>>, _Size, _Max) -> more; -eot(Bs, Eot) -> +eot(Bs, Eot, Size, Max) -> case binary:match(Bs, Eot) of - nomatch -> more; - {Pos, _} -> - binary:part(Bs,{0, Pos}) + nomatch when Size + byte_size(Bs) < Max -> + more; + {Pos, _} when Size + Pos < Max -> + binary:part(Bs,{0, Pos}); + _ -> + binary:part(Bs,{0, Max - Size}) end. %% When port_close returns we know that all the diff --git a/lib/kernel/test/code_SUITE.erl b/lib/kernel/test/code_SUITE.erl index 569753155f..902196def2 100644 --- a/lib/kernel/test/code_SUITE.erl +++ b/lib/kernel/test/code_SUITE.erl @@ -931,37 +931,34 @@ purge_stacktrace(Config) when is_list(Config) -> code:purge(code_b_test), try code_b_test:call(fun(b) -> ok end, a) catch - error:function_clause -> + error:function_clause:Stacktrace -> code:load_file(code_b_test), - case erlang:get_stacktrace() of + case Stacktrace of [{?MODULE,_,[a],_}, {code_b_test,call,2,_}, {?MODULE,purge_stacktrace,1,_}|_] -> - false = code:purge(code_b_test), - [] = erlang:get_stacktrace() + false = code:purge(code_b_test) end end, try code_b_test:call(nofun, 2) catch - error:function_clause -> + error:function_clause:Stacktrace2 -> code:load_file(code_b_test), - case erlang:get_stacktrace() of + case Stacktrace2 of [{code_b_test,call,[nofun,2],_}, {?MODULE,purge_stacktrace,1,_}|_] -> - false = code:purge(code_b_test), - [] = erlang:get_stacktrace() + false = code:purge(code_b_test) end end, Args = [erlang,error,[badarg]], try code_b_test:call(erlang, error, [badarg,Args]) catch - error:badarg -> + error:badarg:Stacktrace3 -> code:load_file(code_b_test), - case erlang:get_stacktrace() of + case Stacktrace3 of [{code_b_test,call,Args,_}, {?MODULE,purge_stacktrace,1,_}|_] -> - false = code:purge(code_b_test), - [] = erlang:get_stacktrace() + false = code:purge(code_b_test) end end, ok. diff --git a/lib/kernel/test/disk_log_SUITE.erl b/lib/kernel/test/disk_log_SUITE.erl index 7beaadb1d6..0709a6e766 100644 --- a/lib/kernel/test/disk_log_SUITE.erl +++ b/lib/kernel/test/disk_log_SUITE.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1997-2017. All Rights Reserved. +%% Copyright Ericsson AB 1997-2018. 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. diff --git a/lib/kernel/test/erl_distribution_SUITE.erl b/lib/kernel/test/erl_distribution_SUITE.erl index bbfaa9d147..073b391288 100644 --- a/lib/kernel/test/erl_distribution_SUITE.erl +++ b/lib/kernel/test/erl_distribution_SUITE.erl @@ -459,9 +459,9 @@ run_remote_test([FuncStr, TestNodeStr | Args]) -> 1 end catch - C:E -> + C:E:S -> io:format("Node ~p got EXCEPTION ~p:~p\nat ~p\n", - [node(), C, E, erlang:get_stacktrace()]), + [node(), C, E, S]), 2 end, io:format("Node ~p doing halt(~p).\n",[node(), Status]), diff --git a/lib/kernel/test/file_SUITE.erl b/lib/kernel/test/file_SUITE.erl index 0cb8087a76..9a77454432 100644 --- a/lib/kernel/test/file_SUITE.erl +++ b/lib/kernel/test/file_SUITE.erl @@ -399,11 +399,11 @@ read_write_0(Str, {Func, ReadFun}, Options) -> io:format("~p:~p: ~p ERROR: ~ts vs~n ~w~n - ~p~n", [?MODULE, Line, Func, Str, ReadBytes, Options]), exit({error, ?LINE}); - error:What -> + error:What:Stacktrace -> io:format("~p:??: ~p ERROR: ~p from~n ~w~n ~p~n", [?MODULE, Func, What, Str, Options]), - io:format("\t~p~n", [erlang:get_stacktrace()]), + io:format("\t~p~n", [Stacktrace]), exit({error, ?LINE}) end. diff --git a/lib/kernel/test/gen_sctp_SUITE.erl b/lib/kernel/test/gen_sctp_SUITE.erl index 620ab235a0..9dde00652c 100644 --- a/lib/kernel/test/gen_sctp_SUITE.erl +++ b/lib/kernel/test/gen_sctp_SUITE.erl @@ -1038,8 +1038,7 @@ do_from_other_process(Fun) -> Result -> Parent ! {Ref,Result} catch - Class:Reason -> - Stacktrace = erlang:get_stacktrace(), + Class:Reason:Stacktrace -> Parent ! {Ref,Class,Reason,Stacktrace} end end), @@ -1617,8 +1616,7 @@ s_start(Socket, Timeout, Parent) -> try s_loop(Socket, Timeout, Parent, Handler, gb_trees:empty()) catch - Class:Reason -> - Stacktrace = erlang:get_stacktrace(), + Class:Reason:Stacktrace -> io:format(?MODULE_STRING":socket exception ~w:~w at~n" "~p.~n", [Class,Reason,Stacktrace]), erlang:raise(Class, Reason, Stacktrace) diff --git a/lib/kernel/test/gen_tcp_api_SUITE.erl b/lib/kernel/test/gen_tcp_api_SUITE.erl index 12d22519ce..0fe44e8a88 100644 --- a/lib/kernel/test/gen_tcp_api_SUITE.erl +++ b/lib/kernel/test/gen_tcp_api_SUITE.erl @@ -605,9 +605,9 @@ ok({ok,V}) -> V; ok(NotOk) -> try throw(not_ok) catch - Thrown -> + throw:Thrown:Stacktrace -> erlang:raise( - error, {Thrown, NotOk}, tl(erlang:get_stacktrace())) + error, {Thrown, NotOk}, tl(Stacktrace)) end. get_localaddr() -> diff --git a/lib/kernel/test/gen_udp_SUITE.erl b/lib/kernel/test/gen_udp_SUITE.erl index 96e495505a..6a50239c2a 100644 --- a/lib/kernel/test/gen_udp_SUITE.erl +++ b/lib/kernel/test/gen_udp_SUITE.erl @@ -755,9 +755,9 @@ ok({ok,V}) -> V; ok(NotOk) -> try throw(not_ok) catch - Thrown -> + throw:Thrown:Stacktrace -> erlang:raise( - error, {Thrown, NotOk}, tl(erlang:get_stacktrace())) + error, {Thrown, NotOk}, tl(Stacktrace)) end. diff --git a/lib/kernel/test/global_SUITE.erl b/lib/kernel/test/global_SUITE.erl index 0a7f73c344..0e7b7adc47 100644 --- a/lib/kernel/test/global_SUITE.erl +++ b/lib/kernel/test/global_SUITE.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1997-2016. All Rights Reserved. +%% Copyright Ericsson AB 1997-2018. 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. @@ -3470,8 +3470,8 @@ start_procs(Parent, N1, N2, N3, Config) -> Pid6 = rpc:call(N3, ?MODULE, start_proc3, [test4]), assert_pid(Pid6), yes = global:register_name(test1, Pid3), - yes = global:register_name(test2, Pid4, {global, notify_all_name}), - yes = global:register_name(test3, Pid5, {global, random_notify_name}), + yes = global:register_name(test2, Pid4, fun global:notify_all_name/3), + yes = global:register_name(test3, Pid5, fun global:random_notify_name/3), Resolve = fun(Name, Pid1, Pid2) -> Parent ! {resolve_called, Name, node()}, {Min, Max} = minmax(Pid1, Pid2), @@ -3546,7 +3546,7 @@ start_proc_basic(Name) -> end. init_proc_basic(Parent, Name) -> - X = global:register_name(Name, self(), {?MODULE, fix_basic_name}), + X = global:register_name(Name, self(), fun ?MODULE:fix_basic_name/3), Parent ! {self(),X}, loop(). @@ -3791,15 +3791,6 @@ stop() -> test_server:stop_node(Node) end, nodes()). -dbg_logs(Name) -> dbg_logs(Name, ?NODES). - -dbg_logs(Name, Nodes) -> - lists:foreach(fun(N) -> - F = lists:concat([Name, ".log.", N, ".txt"]), - ok = sys:log_to_file({global_name_server, N}, F) - end, Nodes). - - %% Tests that locally loaded nodes do not loose contact with other nodes. global_lost_nodes(Config) when is_list(Config) -> Timeout = 60, diff --git a/lib/kernel/test/inet_res_SUITE.erl b/lib/kernel/test/inet_res_SUITE.erl index 6691ad9c06..2a5b8d0044 100644 --- a/lib/kernel/test/inet_res_SUITE.erl +++ b/lib/kernel/test/inet_res_SUITE.erl @@ -217,10 +217,10 @@ proxy_start(TC, {NS,P}) -> spawn_link( fun () -> try proxy_start(TC, NS, P, Parent, Tag) - catch C:X -> + catch C:X:Stacktrace -> io:format( "~w: ~w:~p ~p~n", - [self(),C,X,erlang:get_stacktrace()]) + [self(),C,X,Stacktrace]) end end), receive {started,Tag,Port} -> diff --git a/lib/kernel/test/os_SUITE.erl b/lib/kernel/test/os_SUITE.erl index 8056321448..4369b1b0f9 100644 --- a/lib/kernel/test/os_SUITE.erl +++ b/lib/kernel/test/os_SUITE.erl @@ -26,7 +26,8 @@ null_in_command/1, space_in_name/1, bad_command/1, find_executable/1, unix_comment_in_command/1, deep_list_command/1, large_output_command/1, background_command/0, background_command/1, - message_leak/1, close_stdin/0, close_stdin/1, perf_counter_api/1]). + message_leak/1, close_stdin/0, close_stdin/1, max_size_command/1, + perf_counter_api/1]). -include_lib("common_test/include/ct.hrl"). @@ -39,7 +40,7 @@ all() -> space_in_name, bad_command, find_executable, unix_comment_in_command, deep_list_command, large_output_command, background_command, message_leak, - close_stdin, perf_counter_api]. + close_stdin, max_size_command, perf_counter_api]. groups() -> []. @@ -322,6 +323,19 @@ close_stdin(Config) -> "-1" = os:cmd(Fds). +max_size_command(_Config) -> + + Res20 = os:cmd("cat /dev/zero", #{ max_size => 20 }), + 20 = length(Res20), + + Res0 = os:cmd("cat /dev/zero", #{ max_size => 0 }), + 0 = length(Res0), + + Res32768 = os:cmd("cat /dev/zero", #{ max_size => 32768 }), + 32768 = length(Res32768), + + ResHello = os:cmd("echo hello", #{ max_size => 20 }), + 6 = length(ResHello). %% Test that the os:perf_counter api works as expected perf_counter_api(_Config) -> diff --git a/lib/kernel/vsn.mk b/lib/kernel/vsn.mk index 106bda01ca..91261e1d55 100644 --- a/lib/kernel/vsn.mk +++ b/lib/kernel/vsn.mk @@ -1 +1 @@ -KERNEL_VSN = 5.4.1 +KERNEL_VSN = 5.4.2 diff --git a/lib/mnesia/src/mnesia.erl b/lib/mnesia/src/mnesia.erl index 95f7d4afc1..6d87544bd2 100644 --- a/lib/mnesia/src/mnesia.erl +++ b/lib/mnesia/src/mnesia.erl @@ -177,8 +177,8 @@ %% Local function in order to avoid external function call val(Var) -> - case ?catch_val(Var) of - {'EXIT', _} -> mnesia_lib:other_val(Var); + case ?catch_val_and_stack(Var) of + {'EXIT', Stacktrace} -> mnesia_lib:other_val(Var, Stacktrace); Value -> Value end. diff --git a/lib/mnesia/src/mnesia.hrl b/lib/mnesia/src/mnesia.hrl index da7e662288..e36222d098 100644 --- a/lib/mnesia/src/mnesia.hrl +++ b/lib/mnesia/src/mnesia.hrl @@ -47,6 +47,10 @@ -define(catch_val(Var), (try ?ets_lookup_element(mnesia_gvar, Var, 2) catch error:_ -> {'EXIT', {badarg, []}} end)). +-define(catch_val_and_stack(Var), + (try ?ets_lookup_element(mnesia_gvar, Var, 2) + catch error:_:_Stacktrace -> {'EXIT', _Stacktrace} end)). + %% It's important that counter is first, since we compare tid's -record(tid, diff --git a/lib/mnesia/src/mnesia_bup.erl b/lib/mnesia/src/mnesia_bup.erl index 34f16f178b..9dda340333 100644 --- a/lib/mnesia/src/mnesia_bup.erl +++ b/lib/mnesia/src/mnesia_bup.erl @@ -90,9 +90,9 @@ iterate(Mod, Fun, Opaque, Acc) -> catch throw:Err -> close_read(R2), Err; - _:Reason -> + _:Reason:Stacktrace -> close_read(R2), - {error, {Reason, erlang:get_stacktrace()}} + {error, {Reason, Stacktrace}} end catch throw:{error,_} = Err -> Err @@ -198,9 +198,9 @@ do_read_schema_section(R) -> try {R3, RawSchema} = safe_apply(R2, read, [R2#restore.bup_data]), do_read_schema_section(R3, verify_header(RawSchema), []) - catch T:E -> + catch T:E:S -> close_read(R2), - erlang:raise(T,E,erlang:get_stacktrace()) + erlang:raise(T,E,S) end. do_read_schema_section(R, {ok, B, C, []}, Acc) -> diff --git a/lib/mnesia/src/mnesia_checkpoint.erl b/lib/mnesia/src/mnesia_checkpoint.erl index 8112378ffd..8290237908 100644 --- a/lib/mnesia/src/mnesia_checkpoint.erl +++ b/lib/mnesia/src/mnesia_checkpoint.erl @@ -1269,9 +1269,9 @@ system_code_change(Cp, _Module, _OldVsn, _Extra) -> %%%%%%%%%%%%%%%%%%%%%%%%%% +%% Local function in order to avoid external function call val(Var) -> - case ?catch_val(Var) of - {'EXIT', _} -> mnesia_lib:other_val(Var); - _VaLuE_ -> _VaLuE_ + case ?catch_val_and_stack(Var) of + {'EXIT', Stacktrace} -> mnesia_lib:other_val(Var, Stacktrace); + Value -> Value end. - diff --git a/lib/mnesia/src/mnesia_controller.erl b/lib/mnesia/src/mnesia_controller.erl index 77013489b3..77e67a59db 100644 --- a/lib/mnesia/src/mnesia_controller.erl +++ b/lib/mnesia/src/mnesia_controller.erl @@ -185,9 +185,10 @@ max_loaders() -> worker_res }). +%% Local function in order to avoid external function call val(Var) -> - case ?catch_val(Var) of - {'EXIT', _} -> mnesia_lib:other_val(Var); + case ?catch_val_and_stack(Var) of + {'EXIT', Stacktrace} -> mnesia_lib:other_val(Var, Stacktrace); Value -> Value end. diff --git a/lib/mnesia/src/mnesia_dumper.erl b/lib/mnesia/src/mnesia_dumper.erl index f0ed7aef4a..31bcc1451f 100644 --- a/lib/mnesia/src/mnesia_dumper.erl +++ b/lib/mnesia/src/mnesia_dumper.erl @@ -191,8 +191,7 @@ do_perform_dump(Cont, InPlace, InitBy, Regulator, OldVersion) -> try insert_recs(Recs, InPlace, InitBy, Regulator, OldVersion) of Version -> do_perform_dump(C2, InPlace, InitBy, Regulator, Version) - catch _:R when R =/= fatal -> - ST = erlang:get_stacktrace(), + catch _:R:ST when R =/= fatal -> Reason = {"Transaction log dump error: ~tp~n", [{R, ST}]}, close_files(InPlace, {error, Reason}, InitBy), exit(Reason) @@ -325,8 +324,7 @@ perform_update(Tid, SchemaOps, _DumperMode, _UseDir) -> ?eval_debug_fun({?MODULE, post_dump}, [InitBy]), close_files(InPlace, ok, InitBy), ok - catch _:Reason when Reason =/= fatal -> - ST = erlang:get_stacktrace(), + catch _:Reason:ST when Reason =/= fatal -> Error = {error, {"Schema update error", {Reason, ST}}}, close_files(InPlace, Error, InitBy), fatal("Schema update error ~tp ~tp", [{Reason,ST}, SchemaOps]) @@ -1471,8 +1469,9 @@ regulate(RegulatorPid) -> {regulated, RegulatorPid} -> ok end. +%% Local function in order to avoid external function call val(Var) -> - case ?catch_val(Var) of - {'EXIT', _} -> mnesia_lib:other_val(Var); + case ?catch_val_and_stack(Var) of + {'EXIT', Stacktrace} -> mnesia_lib:other_val(Var, Stacktrace); Value -> Value end. diff --git a/lib/mnesia/src/mnesia_frag.erl b/lib/mnesia/src/mnesia_frag.erl index c39f30e140..63fb4981fe 100644 --- a/lib/mnesia/src/mnesia_frag.erl +++ b/lib/mnesia/src/mnesia_frag.erl @@ -1157,9 +1157,10 @@ remove_node(Node, Cs) -> %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %% Helpers +%% Local function in order to avoid external function call val(Var) -> - case ?catch_val(Var) of - {'EXIT', _} -> mnesia_lib:other_val(Var); + case ?catch_val_and_stack(Var) of + {'EXIT', Stacktrace} -> mnesia_lib:other_val(Var, Stacktrace); Value -> Value end. diff --git a/lib/mnesia/src/mnesia_lib.erl b/lib/mnesia/src/mnesia_lib.erl index 53fdd76de8..56f6926df0 100644 --- a/lib/mnesia/src/mnesia_lib.erl +++ b/lib/mnesia/src/mnesia_lib.erl @@ -116,7 +116,7 @@ lock_table/1, mkcore/1, not_active_here/1, - other_val/1, + other_val/2, overload_read/0, overload_read/1, overload_set/2, @@ -435,8 +435,8 @@ validate_record(Tab, Obj) -> %% val(Var) -> - case ?catch_val(Var) of - {'EXIT', _} -> other_val(Var); + case ?catch_val_and_stack(Var) of + {'EXIT', Stacktrace} -> other_val(Var, Stacktrace); _VaLuE_ -> _VaLuE_ end. @@ -446,9 +446,9 @@ set(Var, Val) -> unset(Var) -> ?ets_delete(mnesia_gvar, Var). -other_val(Var) -> +other_val(Var, Stacktrace) -> case other_val_1(Var) of - error -> pr_other(Var); + error -> pr_other(Var, Stacktrace); Val -> Val end. @@ -460,8 +460,8 @@ other_val_1(Var) -> _ -> error end. --spec pr_other(_) -> no_return(). -pr_other(Var) -> +-spec pr_other(_, _) -> no_return(). +pr_other(Var, Stacktrace) -> Why = case is_running() of no -> {node_not_running, node()}; @@ -469,7 +469,7 @@ pr_other(Var) -> end, verbose("~p (~tp) val(mnesia_gvar, ~tw) -> ~p ~tp ~n", [self(), process_info(self(), registered_name), - Var, Why, erlang:get_stacktrace()]), + Var, Why, Stacktrace]), mnesia:abort(Why). %% Some functions for list valued variables diff --git a/lib/mnesia/src/mnesia_loader.erl b/lib/mnesia/src/mnesia_loader.erl index 4c6336cb73..bbceb9ba66 100644 --- a/lib/mnesia/src/mnesia_loader.erl +++ b/lib/mnesia/src/mnesia_loader.erl @@ -34,9 +34,10 @@ -include("mnesia.hrl"). +%% Local function in order to avoid external function call val(Var) -> - case ?catch_val(Var) of - {'EXIT', _} -> mnesia_lib:other_val(Var); + case ?catch_val_and_stack(Var) of + {'EXIT', Stacktrace} -> mnesia_lib:other_val(Var, Stacktrace); Value -> Value end. @@ -535,7 +536,7 @@ init_table(Tab, _, Fun, _DetsInfo,_) -> try true = ets:init_table(Tab, Fun), ok - catch _:Else -> {Else, erlang:get_stacktrace()} + catch _:Else:Stacktrace -> {Else, Stacktrace} end. @@ -777,9 +778,9 @@ do_send_table(Pid, Tab, Storage, RemoteS) -> throw:receiver_died -> cleanup_tab_copier(Pid, Storage, Tab), ok; - error:Reason -> %% Prepare failed + error:Reason:Stacktrace -> %% Prepare failed cleanup_tab_copier(Pid, Storage, Tab), - {error, {tab_copier, Tab, {Reason, erlang:get_stacktrace()}}} + {error, {tab_copier, Tab, {Reason, Stacktrace}}} after unlink(whereis(mnesia_tm)) end. diff --git a/lib/mnesia/src/mnesia_locker.erl b/lib/mnesia/src/mnesia_locker.erl index 073b48abc0..710bf38cb5 100644 --- a/lib/mnesia/src/mnesia_locker.erl +++ b/lib/mnesia/src/mnesia_locker.erl @@ -97,10 +97,11 @@ init(Parent) -> end, loop(#state{supervisor = Parent}). +%% Local function in order to avoid external function call val(Var) -> - case ?catch_val(Var) of - {'EXIT', _} -> mnesia_lib:other_val(Var); - _VaLuE_ -> _VaLuE_ + case ?catch_val_and_stack(Var) of + {'EXIT', Stacktrace} -> mnesia_lib:other_val(Var, Stacktrace); + Value -> Value end. reply(From, R) -> diff --git a/lib/mnesia/src/mnesia_recover.erl b/lib/mnesia/src/mnesia_recover.erl index d792070332..475bf3c327 100644 --- a/lib/mnesia/src/mnesia_recover.erl +++ b/lib/mnesia/src/mnesia_recover.erl @@ -177,10 +177,10 @@ disconnect(Node) -> log_decision(D) -> cast({log_decision, D}). +%% Local function in order to avoid external function call val(Var) -> - case ?catch_val(Var) of - {'EXIT', _Reason} -> - mnesia_lib:other_val(Var); + case ?catch_val_and_stack(Var) of + {'EXIT', Stacktrace} -> mnesia_lib:other_val(Var, Stacktrace); Value -> Value end. diff --git a/lib/mnesia/src/mnesia_schema.erl b/lib/mnesia/src/mnesia_schema.erl index 71952af31c..de6c3fb4ee 100644 --- a/lib/mnesia/src/mnesia_schema.erl +++ b/lib/mnesia/src/mnesia_schema.erl @@ -181,9 +181,10 @@ exit_on_error({error, Reason}) -> exit_on_error(GoodRes) -> GoodRes. +%% Local function in order to avoid external function call val(Var) -> - case ?catch_val(Var) of - {'EXIT', _} -> mnesia_lib:other_val(Var); + case ?catch_val_and_stack(Var) of + {'EXIT', Stacktrace} -> mnesia_lib:other_val(Var, Stacktrace); Value -> Value end. @@ -2695,10 +2696,10 @@ prepare_op(_Tid, {op, transform, Fun, TabDef}, _WaitFor) -> Objs -> mnesia_lib:db_fixtable(Storage, Tab, false), {true, Objs, mandatory} - catch _:Reason -> + catch _:Reason:Stacktrace -> mnesia_lib:db_fixtable(Storage, Tab, false), mnesia_lib:important("Transform function failed: '~tp' in '~tp'", - [Reason, erlang:get_stacktrace()]), + [Reason, Stacktrace]), exit({"Bad transform function", Tab, Fun, node(), Reason}) end end; diff --git a/lib/mnesia/src/mnesia_tm.erl b/lib/mnesia/src/mnesia_tm.erl index ebf580d09e..eaebdf6d02 100644 --- a/lib/mnesia/src/mnesia_tm.erl +++ b/lib/mnesia/src/mnesia_tm.erl @@ -121,10 +121,11 @@ init(Parent) -> proc_lib:init_ack(Parent, {ok, self()}), doit_loop(#state{supervisor = Parent}). +%% Local function in order to avoid external function call val(Var) -> - case ?catch_val(Var) of - {'EXIT', _} -> mnesia_lib:other_val(Var); - _VaLuE_ -> _VaLuE_ + case ?catch_val_and_stack(Var) of + {'EXIT', Stacktrace} -> mnesia_lib:other_val(Var, Stacktrace); + Value -> Value end. reply({From,Ref}, R) -> @@ -597,9 +598,9 @@ recover_coordinator(Tid, Etabs) -> false -> %% When killed before store havn't been copied to ok %% to the new nested trans store. end - catch _:Reason -> + catch _:Reason:Stacktrace -> dbg_out("Recovery of coordinator ~p failed: ~tp~n", - [Tid, {Reason, erlang:get_stacktrace()}]), + [Tid, {Reason, Stacktrace}]), Protocol = asym_trans, tell_outcome(Tid, Protocol, node(), CheckNodes, TellNodes) end, @@ -825,8 +826,7 @@ execute_transaction(Fun, Args, Factor, Retries, Type) -> catch throw:Value -> %% User called throw Reason = {aborted, {throw, Value}}, return_abort(Fun, Args, Reason); - error:Reason -> - ST = erlang:get_stacktrace(), + error:Reason:ST -> check_exit(Fun, Args, Factor, Retries, {Reason,ST}, Type); _:Reason -> check_exit(Fun, Args, Factor, Retries, Reason, Type) @@ -1796,14 +1796,13 @@ do_update(Tid, Storage, [Op | Ops], OldRes) -> try do_update_op(Tid, Storage, Op) of ok -> do_update(Tid, Storage, Ops, OldRes); NewRes -> do_update(Tid, Storage, Ops, NewRes) - catch _:Reason -> + catch _:Reason:ST -> %% This may only happen when we recently have %% deleted our local replica, changed storage_type %% or transformed table %% BUGBUG: Updates may be lost if storage_type is changed. %% Determine actual storage type and try again. %% BUGBUG: Updates may be lost if table is transformed. - ST = erlang:get_stacktrace(), verbose("do_update in ~w failed: ~tp -> {'EXIT', ~tp}~n", [Tid, Op, {Reason, ST}]), do_update(Tid, Storage, Ops, OldRes) @@ -1914,11 +1913,10 @@ commit_clear([H|R], Tid, Storage, Tab, K, Obj) do_snmp(_, []) -> ok; do_snmp(Tid, [Head|Tail]) -> try mnesia_snmp_hook:update(Head) - catch _:Reason -> + catch _:Reason:ST -> %% This should only happen when we recently have %% deleted our local replica or recently deattached %% the snmp table - ST = erlang:get_stacktrace(), verbose("do_snmp in ~w failed: ~tp -> {'EXIT', ~tp}~n", [Tid, Head, {Reason, ST}]) end, diff --git a/lib/mnesia/test/mnesia_test_lib.erl b/lib/mnesia/test/mnesia_test_lib.erl index 78dbe7ffde..db0e7beac6 100644 --- a/lib/mnesia/test/mnesia_test_lib.erl +++ b/lib/mnesia/test/mnesia_test_lib.erl @@ -470,9 +470,9 @@ get_suite(Mod, {group, Suite}) -> {_, _, TCList} = lists:keyfind(Suite, 1, Groups), TCList catch - _:Reason -> + _:Reason:Stacktrace -> io:format("Not implemented ~p ~p (~p ~p)~n", - [Mod,Suite,Reason, erlang:get_stacktrace()]), + [Mod,Suite,Reason,Stacktrace]), 'NYI' end; get_suite(Mod, all) -> diff --git a/lib/mnesia/test/mnesia_test_lib.hrl b/lib/mnesia/test/mnesia_test_lib.hrl index ba7eb10ea2..90a3c686b0 100644 --- a/lib/mnesia/test/mnesia_test_lib.hrl +++ b/lib/mnesia/test/mnesia_test_lib.hrl @@ -55,25 +55,25 @@ ?error("Not Matching Actual result was:~n ~p~n",[_AR_0]), {fail,_AR_0} catch - exit:{aborted, _ER_1} when + exit:{aborted, _ER_1}:Stacktrace when element(1, _ER_1) =:= node_not_running; element(1, _ER_1) =:= bad_commit; element(1, _ER_1) =:= cyclic -> %% Need to re-raise these to restart transaction - erlang:raise(exit, {aborted, _ER_1}, erlang:get_stacktrace()); - exit:_AR_1 -> + erlang:raise(exit, {aborted, _ER_1}, Stacktrace); + exit:_AR_1:Stacktrace -> case fun(_AR_EXIT_) -> {'EXIT', _AR_EXIT_} end(_AR_1) of _AR_2 = ExpectedRes -> ?verbose("ok, ~n Result as expected:~p~n",[_AR_2]), {success,_AR_2}; _AR_2 -> ?error("Not Matching Actual result was:~n ~p~n ~p~n", - [_AR_2, erlang:get_stacktrace()]), + [_AR_2, Stacktrace]), {fail,_AR_2} end; - _T1_:_AR_1 -> + _T1_:_AR_1:Stacktrace -> ?error("Not Matching Actual result was:~n ~p~n ~p~n", - [{_T1_,_AR_1}, erlang:get_stacktrace()]), + [{_T1_,_AR_1}, Stacktrace]), {fail,{_T1_,_AR_1}} end end()). diff --git a/lib/observer/src/observer_alloc_wx.erl b/lib/observer/src/observer_alloc_wx.erl index 7f4b3dd484..e0f319b6cc 100644 --- a/lib/observer/src/observer_alloc_wx.erl +++ b/lib/observer/src/observer_alloc_wx.erl @@ -79,8 +79,8 @@ init([Notebook, Parent, Config]) -> max = #{} } } - catch _:Err -> - io:format("~p crashed ~tp: ~tp~n",[?MODULE, Err, erlang:get_stacktrace()]), + catch _:Err:Stacktrace -> + io:format("~p crashed ~tp: ~tp~n",[?MODULE, Err, Stacktrace]), {stop, Err} end. diff --git a/lib/observer/src/observer_perf_wx.erl b/lib/observer/src/observer_perf_wx.erl index 5adfadb16e..eddb9327f3 100644 --- a/lib/observer/src/observer_perf_wx.erl +++ b/lib/observer/src/observer_perf_wx.erl @@ -86,8 +86,8 @@ init([Notebook, Parent, Config]) -> secs=maps:get(secs, Config, ?DISP_SECONDS)} }, {Panel, State0} - catch _:Err -> - io:format("~p crashed ~tp: ~tp~n",[?MODULE, Err, erlang:get_stacktrace()]), + catch _:Err:Stacktrace -> + io:format("~p crashed ~tp: ~tp~n",[?MODULE, Err, Stacktrace]), {stop, Err} end. diff --git a/lib/observer/src/observer_pro_wx.erl b/lib/observer/src/observer_pro_wx.erl index d612e0a1c5..1c40afba46 100644 --- a/lib/observer/src/observer_pro_wx.erl +++ b/lib/observer/src/observer_pro_wx.erl @@ -572,7 +572,8 @@ change_accum(true, S0) -> S0#holder{accum=true}; change_accum(false, S0=#holder{info=Info}) -> self() ! refresh, - S0#holder{accum=lists:sort(array:to_list(Info))}. + Accum = [{Pid, Reds} || #etop_proc_info{pid=Pid, reds=Reds} <- array:to_list(Info)], + S0#holder{accum=lists:sort(Accum)}. handle_update_old(#etop_info{procinfo=ProcInfo0}, S0=#holder{parent=Parent, sort=Sort=#sort{sort_key=KeyField}}) -> diff --git a/lib/observer/src/observer_procinfo.erl b/lib/observer/src/observer_procinfo.erl index 4d3f306a0a..6b761cb2ff 100644 --- a/lib/observer/src/observer_procinfo.erl +++ b/lib/observer/src/observer_procinfo.erl @@ -257,8 +257,6 @@ init_stack_page(Parent, Pid) -> [Pid, current_stacktrace]) of {current_stacktrace,RawBt} -> - observer_wx:try_rpc(node(Pid), erlang, process_info, - [Pid, current_stacktrace]), wxListCtrl:deleteAllItems(LCtrl), wx:foldl(fun({M, F, A, Info}, Row) -> _Item = wxListCtrl:insertItem(LCtrl, Row, ""), diff --git a/lib/observer/src/observer_traceoptions_wx.erl b/lib/observer/src/observer_traceoptions_wx.erl index fbcf6d7fe9..ff8c40ce77 100644 --- a/lib/observer/src/observer_traceoptions_wx.erl +++ b/lib/observer/src/observer_traceoptions_wx.erl @@ -536,7 +536,7 @@ ms_from_string(Str) -> {error, List} -> throw([[Error, $\n] || {_, Error} <- List]) end catch error:_Reason -> - %% io:format("Bad term: ~ts~n ~tp in ~tp~n", [Str, _Reason, erlang:get_stacktrace()]), + %% io:format("Bad term: ~ts~n ~tp in ~tp~n", [Str, _Reason, Stacktrace]), throw("Invalid term") end. diff --git a/lib/observer/src/observer_tv_wx.erl b/lib/observer/src/observer_tv_wx.erl index e16f3cab6b..2e387f7e74 100644 --- a/lib/observer/src/observer_tv_wx.erl +++ b/lib/observer/src/observer_tv_wx.erl @@ -38,13 +38,13 @@ -define(ID_SYSTEM_TABLES, 406). -define(ID_TABLE_INFO, 407). -define(ID_SHOW_TABLE, 408). - --record(opt, {type=ets, - sys_hidden=true, - unread_hidden=true, - sort_key=2, - sort_incr=true - }). + +-record(opts, {type=ets, + sys_hidden=true, + unread_hidden=true}). + +-record(sort, {sort_incr=true, + sort_key=2}). -record(state, { @@ -52,9 +52,9 @@ grid, panel, node=node(), - opt=#opt{}, + opts=#opts{}, + holder, selected, - tabs, timer }). @@ -64,8 +64,18 @@ start_link(Notebook, Parent, Config) -> init([Notebook, Parent, Config]) -> Panel = wxPanel:new(Notebook), Sizer = wxBoxSizer:new(?wxVERTICAL), - Style = ?wxLC_REPORT bor ?wxLC_SINGLE_SEL bor ?wxLC_HRULES, - Grid = wxListCtrl:new(Panel, [{winid, ?GRID}, {style, Style}]), + + Opts=#opts{type=maps:get(type, Config, ets), + sys_hidden=maps:get(sys_hidden, Config, true), + unread_hidden=maps:get(unread_hidden, Config, true)}, + + Style = ?wxLC_REPORT bor ?wxLC_VIRTUAL bor ?wxLC_SINGLE_SEL bor ?wxLC_HRULES, + Self = self(), + Attrs = observer_lib:create_attrs(), + Holder = spawn_link(fun() -> init_table_holder(Self, Attrs) end), + CBs = [{onGetItemText, fun(_, Item,Col) -> get_row(Holder, Item, Col) end}, + {onGetItemAttr, fun(_, Item) -> get_attr(Holder, Item) end}], + Grid = wxListCtrl:new(Panel, [{winid, ?GRID}, {style, Style} | CBs]), wxSizer:add(Sizer, Grid, [{flag, ?wxEXPAND bor ?wxALL}, {proportion, 1}, {border, 5}]), wxWindow:setSizer(Panel, Sizer), @@ -95,38 +105,26 @@ init([Notebook, Parent, Config]) -> wxWindow:setFocus(Grid), {Panel, #state{grid=Grid, parent=Parent, panel=Panel, - timer=Config, - opt=#opt{type=maps:get(type, Config, ets), - sys_hidden=maps:get(sys_hidden, Config, true), - unread_hidden=maps:get(unread_hidden, Config, true)} - }}. + opts=Opts, timer=Config, holder=Holder}}. handle_event(#wx{id=?ID_REFRESH}, - State = #state{node=Node, grid=Grid, opt=Opt}) -> - Tables = get_tables(Node, Opt), - {Tabs,Sel} = update_grid(Grid, sel(State), Opt, Tables), - Sel =/= undefined andalso wxListCtrl:ensureVisible(Grid, Sel), - {noreply, State#state{tabs=Tabs, selected=Sel}}; + State = #state{holder=Holder, node=Node, opts=Opts}) -> + Tables = get_tables(Node, Opts), + Holder ! {refresh, Tables}, + {noreply, State}; handle_event(#wx{event=#wxList{type=command_list_col_click, col=Col}}, - State = #state{node=Node, grid=Grid, - opt=Opt0=#opt{sort_key=Key, sort_incr=Bool}}) -> - Opt = case col2key(Col) of - Key -> Opt0#opt{sort_incr=not Bool}; - NewKey -> Opt0#opt{sort_key=NewKey} - end, - Tables = get_tables(Node, Opt), - {Tabs,Sel} = update_grid(Grid, sel(State), Opt, Tables), - wxWindow:setFocus(Grid), - {noreply, State#state{opt=Opt, tabs=Tabs, selected=Sel}}; + State = #state{holder=Holder}) -> + Holder ! {sort, Col}, + {noreply, State}; -handle_event(#wx{id=Id}, State = #state{node=Node, grid=Grid, opt=Opt0}) +handle_event(#wx{id=Id}, State = #state{node=Node, holder=Holder, grid=Grid, opts=Opt0}) when Id >= ?ID_ETS, Id =< ?ID_SYSTEM_TABLES -> Opt = case Id of - ?ID_ETS -> Opt0#opt{type=ets}; - ?ID_MNESIA -> Opt0#opt{type=mnesia}; - ?ID_UNREADABLE -> Opt0#opt{unread_hidden= not Opt0#opt.unread_hidden}; - ?ID_SYSTEM_TABLES -> Opt0#opt{sys_hidden= not Opt0#opt.sys_hidden} + ?ID_ETS -> Opt0#opts{type=ets}; + ?ID_MNESIA -> Opt0#opts{type=mnesia}; + ?ID_UNREADABLE -> Opt0#opts{unread_hidden= not Opt0#opts.unread_hidden}; + ?ID_SYSTEM_TABLES -> Opt0#opts{sys_hidden= not Opt0#opts.sys_hidden} end, case get_tables2(Node, Opt) of Error = {error, _} -> @@ -135,9 +133,9 @@ handle_event(#wx{id=Id}, State = #state{node=Node, grid=Grid, opt=Opt0}) self() ! Error, {noreply, State}; Tables -> - {Tabs, Sel} = update_grid(Grid, sel(State), Opt, Tables), + Holder ! {refresh, Tables}, wxWindow:setFocus(Grid), - {noreply, State#state{opt=Opt, tabs=Tabs, selected=Sel}} + {noreply, State#state{opts=Opt}} end; handle_event(#wx{event=#wxSize{size={W,_}}}, State=#state{grid=Grid}) -> @@ -146,19 +144,18 @@ handle_event(#wx{event=#wxSize{size={W,_}}}, State=#state{grid=Grid}) -> handle_event(#wx{event=#wxList{type=command_list_item_activated, itemIndex=Index}}, - State=#state{grid=Grid, node=Node, opt=#opt{type=Type}, tabs=Tabs}) -> - Table = lists:nth(Index+1, Tabs), - case Table#tab.protection of - private -> - self() ! {error, "Table has 'private' protection and can not be read"}; - _ -> - observer_tv_table:start_link(Grid, [{node,Node}, {type,Type}, {table,Table}]) + State=#state{holder=Holder, node=Node, opts=#opts{type=Type}, grid=Grid}) -> + case get_table(Holder, Index) of + #tab{protection=private} -> + self() ! {error, "Table has 'private' protection and can not be read"}; + #tab{}=Table -> + observer_tv_table:start_link(Grid, [{node,Node}, {type,Type}, {table,Table}]); + _ -> ignore end, {noreply, State}; handle_event(#wx{event=#wxList{type=command_list_item_right_click}}, State=#state{panel=Panel}) -> - Menu = wxMenu:new(), wxMenu:append(Menu, ?ID_TABLE_INFO, "Table info"), wxMenu:append(Menu, ?ID_SHOW_TABLE, "Show Table Content"), @@ -167,32 +164,33 @@ handle_event(#wx{event=#wxList{type=command_list_item_right_click}}, {noreply, State}; handle_event(#wx{event=#wxList{type=command_list_item_selected, itemIndex=Index}}, - State) -> + State=#state{holder=Holder}) -> + Holder ! {selected, Index}, {noreply, State#state{selected=Index}}; handle_event(#wx{id=?ID_TABLE_INFO}, - State = #state{grid=Grid, node=Node, opt=#opt{type=Type}, tabs=Tabs, selected=Sel}) -> + State = #state{holder=Holder, grid=Grid, node=Node, opts=#opts{type=Type}, selected=Sel}) -> case Sel of undefined -> {noreply, State}; R when is_integer(R) -> - Table = lists:nth(Sel+1, Tabs), + Table = get_table(Holder, Sel), display_table_info(Grid, Node, Type, Table), {noreply, State} end; handle_event(#wx{id=?ID_SHOW_TABLE}, - State=#state{grid=Grid, node=Node, opt=#opt{type=Type}, tabs=Tabs, selected=Sel}) -> + State=#state{holder=Holder, grid=Grid, node=Node, opts=#opts{type=Type}, selected=Sel}) -> case Sel of undefined -> {noreply, State}; R when is_integer(R) -> - Table = lists:nth(Sel+1, Tabs), - case Table#tab.protection of - private -> + case get_table(Holder, R) of + #tab{protection=private} -> self() ! {error, "Table has 'private' protection and can not be read"}; - _ -> - observer_tv_table:start_link(Grid, [{node,Node}, {type,Type}, {table,Table}]) + #tab{}=Table -> + observer_tv_table:start_link(Grid, [{node,Node}, {type,Type}, {table,Table}]); + _ -> ignore end, {noreply, State} end; @@ -202,14 +200,14 @@ handle_event(#wx{id=?ID_REFRESH_INTERVAL}, Timer = observer_lib:interval_dialog(Grid, Timer0, 10, 5*60), {noreply, State#state{timer=Timer}}; -handle_event(Event, _State) -> - error({unhandled_event, Event}). +handle_event(_Event, State) -> + {noreply, State}. handle_sync_event(_Event, _Obj, _State) -> ok. -handle_call(get_config, _, #state{timer=Timer, opt=Opt}=State) -> - #opt{type=Type, sys_hidden=Sys, unread_hidden=Unread} = Opt, +handle_call(get_config, _, #state{timer=Timer, opts=Opt}=State) -> + #opts{type=Type, sys_hidden=Sys, unread_hidden=Unread} = Opt, Conf0 = observer_lib:timer_config(Timer), Conf = Conf0#{type=>Type, sys_hidden=>Sys, unread_hidden=>Unread}, {reply, Conf, State}; @@ -220,50 +218,68 @@ handle_call(Event, From, _State) -> handle_cast(Event, _State) -> error({unhandled_cast, Event}). -handle_info(refresh_interval, State = #state{node=Node, grid=Grid, opt=Opt, - tabs=OldTabs}) -> - case get_tables(Node, Opt) of - OldTabs -> - %% no change - {noreply, State}; - Tables -> - {Tabs, Sel} = update_grid(Grid, sel(State), Opt, Tables), - Sel =/= undefined andalso wxListCtrl:ensureVisible(Grid, Sel), - {noreply, State#state{tabs=Tabs, selected=Sel}} - end; +handle_info(refresh_interval, State = #state{holder=Holder, node=Node, opts=Opt}) -> + Tables = get_tables(Node, Opt), + Holder ! {refresh, Tables}, + {noreply, State}; -handle_info({active, Node}, State = #state{parent=Parent, grid=Grid, opt=Opt0, - timer=Timer0}) -> - {Tables, Opt} = case Opt0#opt.type =:= mnesia andalso get_tables2(Node, Opt0) of +handle_info({active, Node}, State = #state{parent=Parent, holder=Holder, grid=Grid, + opts=Opt0, timer=Timer0}) -> + {Tables, Opt} = case Opt0#opts.type =:= mnesia andalso get_tables2(Node, Opt0) of Ts when is_list(Ts) -> {Ts, Opt0}; _ -> % false or error getting mnesia tables - Opt1 = Opt0#opt{type=ets}, + Opt1 = Opt0#opts{type=ets}, {get_tables(Node, Opt1), Opt1} end, - {Tabs,Sel} = update_grid(Grid, sel(State), Opt, Tables), + Holder ! {refresh, Tables}, wxWindow:setFocus(Grid), create_menus(Parent, Opt), Timer = observer_lib:start_timer(Timer0, 10), - {noreply, State#state{node=Node, tabs=Tabs, timer=Timer, opt=Opt, selected=Sel}}; + {noreply, State#state{node=Node, timer=Timer, opts=Opt}}; handle_info(not_active, State = #state{timer = Timer0}) -> Timer = observer_lib:stop_timer(Timer0), {noreply, State#state{timer=Timer}}; -handle_info({error, Error}, #state{panel=Panel,opt=Opt}=State) -> +handle_info({error, Error}, #state{panel=Panel,opts=Opt}=State) -> Str = io_lib:format("ERROR: ~ts~n",[Error]), observer_lib:display_info_dialog(Panel,Str), - case Opt#opt.type of + case Opt#opts.type of mnesia -> wxMenuBar:check(observer_wx:get_menubar(), ?ID_ETS, true); _ -> ok end, - {noreply, State#state{opt=Opt#opt{type=ets}}}; + {noreply, State#state{opts=Opt#opts{type=ets}}}; + +handle_info({refresh, Min, Min}, State = #state{grid=Grid}) -> + wxListCtrl:setItemCount(Grid, Min+1), + wxListCtrl:refreshItem(Grid, Min), %% Avoid assert in wx below if Max is 0 + observer_wx:set_status(io_lib:format("Tables: ~w", [Min+1])), + {noreply, State}; +handle_info({refresh, Min, Max}, State = #state{grid=Grid}) -> + wxListCtrl:setItemCount(Grid, Max+1), + Max > 0 andalso wxListCtrl:refreshItems(Grid, Min, Max), + observer_wx:set_status(io_lib:format("Tables: ~w", [Max+1])), + {noreply, State}; + +handle_info({selected, New, Size}, #state{grid=Grid, selected=Old} = State) -> + if + is_integer(Old), Old < Size -> + wxListCtrl:setItemState(Grid, Old, 0, ?wxLIST_STATE_SELECTED); + true -> ignore + end, + if is_integer(New) -> + wxListCtrl:setItemState(Grid, New, 16#FFFF, ?wxLIST_STATE_SELECTED), + wxListCtrl:ensureVisible(Grid, New); + true -> ignore + end, + {noreply, State#state{selected=New}}; handle_info(_Event, State) -> {noreply, State}. -terminate(_Event, _State) -> +terminate(_Event, #state{holder=Holder}) -> + Holder ! stop, ok. code_change(_, _, State) -> @@ -271,7 +287,7 @@ code_change(_, _, State) -> %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -create_menus(Parent, #opt{sys_hidden=Sys, unread_hidden=UnR, type=Type}) -> +create_menus(Parent, #opts{sys_hidden=Sys, unread_hidden=UnR, type=Type}) -> MenuEntries = [{"View", [#create_menu{id = ?ID_TABLE_INFO, text = "Table information\tCtrl-I"}, separator, @@ -298,7 +314,7 @@ get_tables(Node, Opts) -> Res -> Res end. -get_tables2(Node, #opt{type=Type, sys_hidden=Sys, unread_hidden=Unread}) -> +get_tables2(Node, #opts{type=Type, sys_hidden=Sys, unread_hidden=Unread}) -> Args = [Type, [{sys_hidden,Sys}, {unread_hidden,Unread}]], case rpc:call(Node, observer_backend, get_table_list, Args) of {badrpc, Error} -> @@ -386,49 +402,134 @@ list_to_strings([A]) -> integer_to_list(A); list_to_strings([A|B]) -> integer_to_list(A) ++ " ," ++ list_to_strings(B). -update_grid(Grid, Selected, Opt, Tables) -> - wx:batch(fun() -> update_grid2(Grid, Selected, Opt, Tables) end). - -update_grid2(Grid, {SelName,SelId}, #opt{sort_key=Sort,sort_incr=Dir}, Tables) -> - wxListCtrl:deleteAllItems(Grid), - Update = - fun(#tab{name = Name, id = Id, owner = Owner, size = Size, memory = Memory, - protection = Protection, reg_name = RegName}, - {Row, Sel}) -> - _Item = wxListCtrl:insertItem(Grid, Row, ""), - if (Row rem 2) =:= 0 -> - wxListCtrl:setItemBackgroundColour(Grid, Row, ?BG_EVEN); - true -> ignore - end, - if Protection == private -> - wxListCtrl:setItemTextColour(Grid, Row, {200,130,50}); - true -> ignore - end, - - lists:foreach(fun({_, ignore}) -> ignore; - ({Col, Val}) -> - wxListCtrl:setItem(Grid, Row, Col, observer_lib:to_str(Val)) - end, - [{0,Name}, {1,Size}, {2, Memory div 1024}, - {3,Owner}, {4,RegName}, {5,Id}]), - if SelName =:= Name, SelId =:= Id -> - wxListCtrl:setItemState(Grid, Row, 16#FFFF, ?wxLIST_STATE_SELECTED), - {Row+1, Row}; - true -> - wxListCtrl:setItemState(Grid, Row, 0, ?wxLIST_STATE_SELECTED), - {Row+1, Sel} - end - end, - ProcInfo = case Dir of - false -> lists:reverse(lists:keysort(Sort, Tables)); - true -> lists:keysort(Sort, Tables) - end, - {_, Sel} = lists:foldl(Update, {0, undefined}, ProcInfo), - {ProcInfo, Sel}. - -sel(#state{selected=Sel, tabs=Tabs}) -> - try lists:nth(Sel+1, Tabs) of - #tab{name=Name, id=Id} -> {Name, Id} - catch _:_ -> - {undefined, undefined} +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Table holder needs to be in a separate process otherwise +%% the callback get_row/3 may deadlock if the process do +%% wx calls when callback is invoked. + +get_table(Table, Item) -> + get_row(Table, Item, all). + +get_row(Table, Item, Column) -> + Ref = erlang:monitor(process, Table), + Table ! {get_row, self(), Item, Column}, + receive + {'DOWN', Ref, _, _, _} -> ""; + {Table, Res} -> + erlang:demonitor(Ref), + Res end. + +get_attr(Table, Item) -> + Ref = erlang:monitor(process, Table), + Table ! {get_attr, self(), Item}, + receive + {'DOWN', Ref, _, _, _} -> wx:null(); + {Table, Res} -> + erlang:demonitor(Ref), + Res + end. + +-record(holder, {node, parent, pid, + tabs=array:new(), + sort=#sort{}, + attrs, + sel + }). + +init_table_holder(Parent, Attrs) -> + Parent ! refresh, + table_holder(#holder{node=node(), parent=Parent, attrs=Attrs}). + +table_holder(S0 = #holder{parent=Parent, tabs=Tabs0, sel=Sel0}) -> + receive + {get_attr, From, Row} -> + get_attr(From, Row, S0), + table_holder(S0); + {get_row, From, Row, Col} -> + get_row(From, Row, Col, Tabs0), + table_holder(S0); + {sort, Col} -> + STab = get_sel(Sel0, Tabs0), + Parent ! {refresh, 0, array:size(Tabs0)-1}, + S1 = sort(col2key(Col), S0), + Sel = sel_idx(STab, S1#holder.tabs), + Parent ! {selected, Sel, array:size(Tabs0)}, + table_holder(S1#holder{sel=Sel}); + {refresh, Tabs1} -> + STab = get_sel(Sel0, Tabs0), + Tabs = case S0#holder.sort of + #sort{sort_incr=false, sort_key=Col} -> + array:from_list(lists:reverse(lists:keysort(Col, Tabs1))); + #sort{sort_key=Col} -> + array:from_list(lists:keysort(Col, Tabs1)) + end, + Parent ! {refresh, 0, array:size(Tabs)-1}, + Sel = sel_idx(STab, Tabs), + Parent ! {selected, Sel,array:size(Tabs)}, + table_holder(S0#holder{tabs=Tabs, sel=Sel}); + {selected, Sel} -> + table_holder(S0#holder{sel=Sel}); + stop -> + ok; + What -> + io:format("Table holder got ~tp~n",[What]), + Parent ! {refresh, 0, array:size(Tabs0)-1}, + table_holder(S0) + end. + +get_sel(undefined, _Tabs) -> + undefined; +get_sel(Idx, Tabs) -> + array:get(Idx, Tabs). + +sel_idx(undefined, _Tabs) -> + undefined; +sel_idx(Tab, Tabs) -> + Find = fun(Idx, C, Acc) -> C =:= Tab andalso throw({found, Idx}), Acc end, + try array:foldl(Find, undefined, Tabs) + catch {found, Idx} -> Idx + end. + +sort(Col, #holder{sort=#sort{sort_key=Col, sort_incr=Incr}=S, tabs=Table0}=H) -> + Table = lists:reverse(array:to_list(Table0)), + H#holder{sort=S#sort{sort_incr=(not Incr)}, + tabs=array:from_list(Table)}; +sort(Col, #holder{sort=#sort{sort_incr=Incr}=S, tabs=Table0}=H) -> + Table = case Incr of + false -> lists:reverse(lists:keysort(Col, array:to_list(Table0))); + true -> lists:keysort(Col, array:to_list(Table0)) + end, + H#holder{sort=S#sort{sort_key=Col}, + tabs=array:from_list(Table)}. + +get_row(From, Row, Col, Table) -> + Object = array:get(Row, Table), + From ! {self(), get_col(Col, Object)}. + +get_col(all, Rec) -> + Rec; +get_col(2, #tab{}=Rec) -> %% Memory in kB + observer_lib:to_str(element(#tab.memory, Rec) div 1024); +get_col(Col, #tab{}=Rec) -> + case element(col2key(Col), Rec) of + ignore -> ""; + Val -> observer_lib:to_str(Val) + end; +get_col(_, _) -> + "". + +get_attr(From, Row, #holder{tabs=Tabs, attrs=Attrs}) -> + EvenOdd = case (Row rem 2) > 0 of + true -> Attrs#attrs.odd; + false -> Attrs#attrs.even + end, + What = try array:get(Row, Tabs) of + #tab{protection=private} -> + Attrs#attrs.deleted; + _ -> + EvenOdd + catch _ -> + EvenOdd + end, + From ! {self(), What}. diff --git a/lib/observer/test/observer_SUITE.erl b/lib/observer/test/observer_SUITE.erl index 0db2c1ea77..fd4f93f662 100644 --- a/lib/observer/test/observer_SUITE.erl +++ b/lib/observer/test/observer_SUITE.erl @@ -113,7 +113,12 @@ appup_file(Config) when is_list(Config) -> basic(suite) -> []; basic(doc) -> [""]; basic(Config) when is_list(Config) -> - timer:send_after(100, "foobar"), %% Otherwise the timer server gets added to procs + %% Start these before + wx:new(), + wx:destroy(), + timer:send_after(100, "foobar"), + {foo, node@machine} ! dummy_msg, %% start distribution stuff + %% Otherwise ever lasting servers gets added to procs ProcsBefore = processes(), ProcInfoBefore = [{P,process_info(P)} || P <- ProcsBefore], NumProcsBefore = length(ProcsBefore), diff --git a/lib/parsetools/include/yeccpre.hrl b/lib/parsetools/include/yeccpre.hrl index 91d6cd49a6..53e8124aaa 100644 --- a/lib/parsetools/include/yeccpre.hrl +++ b/lib/parsetools/include/yeccpre.hrl @@ -56,8 +56,7 @@ return_error(Line, Message) -> yeccpars0(Tokens, Tzr, State, States, Vstack) -> try yeccpars1(Tokens, Tzr, State, States, Vstack) catch - error: Error -> - Stacktrace = erlang:get_stacktrace(), + error: Error: Stacktrace -> try yecc_error_type(Error, Stacktrace) of Desc -> erlang:raise(error, {yecc_bug, ?CODE_VERSION, Desc}, diff --git a/lib/parsetools/src/yeccparser.erl b/lib/parsetools/src/yeccparser.erl index 6f6f66d56c..45d91a83a3 100644 --- a/lib/parsetools/src/yeccparser.erl +++ b/lib/parsetools/src/yeccparser.erl @@ -72,8 +72,7 @@ return_error(Line, Message) -> yeccpars0(Tokens, Tzr, State, States, Vstack) -> try yeccpars1(Tokens, Tzr, State, States, Vstack) catch - error: Error -> - Stacktrace = erlang:get_stacktrace(), + error: Error: Stacktrace -> try yecc_error_type(Error, Stacktrace) of Desc -> erlang:raise(error, {yecc_bug, ?CODE_VERSION, Desc}, @@ -167,21 +166,20 @@ yecctoken_location(Token) -> end. -compile({nowarn_unused_function, yecctoken2string/1}). -yecctoken2string({atom, _, A}) -> io_lib:write(A); +yecctoken2string({atom, _, A}) -> io_lib:write_atom(A); yecctoken2string({integer,_,N}) -> io_lib:write(N); yecctoken2string({float,_,F}) -> io_lib:write(F); yecctoken2string({char,_,C}) -> io_lib:write_char(C); yecctoken2string({var,_,V}) -> io_lib:format("~s", [V]); yecctoken2string({string,_,S}) -> io_lib:write_string(S); yecctoken2string({reserved_symbol, _, A}) -> io_lib:write(A); -yecctoken2string({_Cat, _, Val}) -> io_lib:format("~p",[Val]); +yecctoken2string({_Cat, _, Val}) -> io_lib:format("~tp", [Val]); yecctoken2string({dot, _}) -> "'.'"; -yecctoken2string({'$end', _}) -> - []; +yecctoken2string({'$end', _}) -> []; yecctoken2string({Other, _}) when is_atom(Other) -> - io_lib:write(Other); + io_lib:write_atom(Other); yecctoken2string(Other) -> - io_lib:write(Other). + io_lib:format("~tp", [Other]). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% diff --git a/lib/parsetools/test/yecc_SUITE.erl b/lib/parsetools/test/yecc_SUITE.erl index a7166b91ed..2d3b15326b 100644 --- a/lib/parsetools/test/yecc_SUITE.erl +++ b/lib/parsetools/test/yecc_SUITE.erl @@ -1674,8 +1674,7 @@ format_error(Message) -> yeccpars0(Tokens, MFA) -> try yeccpars1(Tokens, MFA, 0, [], []) catch - error: Error -> - Stacktrace = erlang:get_stacktrace(), + error: Error : Stacktrace -> try yecc_error_type(Error, Stacktrace) of {syntax_error, Token} -> yeccerror(Token); diff --git a/lib/public_key/asn1/PKCS-7.asn1 b/lib/public_key/asn1/PKCS-7.asn1 index e76f928acb..e9c188be39 100644 --- a/lib/public_key/asn1/PKCS-7.asn1 +++ b/lib/public_key/asn1/PKCS-7.asn1 @@ -124,7 +124,7 @@ SignerInfoAuthenticatedAttributes ::= CHOICE { -- Also defined in X.509 -- Redeclared here as a parameterized type -AlgorithmIdentifierPKSC-7 {ALGORITHM:IOSet} ::= SEQUENCE { +AlgorithmIdentifierPKCS-7 {ALGORITHM:IOSet} ::= SEQUENCE { algorithm ALGORITHM.&id({IOSet}), parameters ALGORITHM.&Type({IOSet}{@algorithm}) OPTIONAL } @@ -146,21 +146,21 @@ CRLSequence ::= SEQUENCE OF CertificateList ContentEncryptionAlgorithmIdentifier ::= - AlgorithmIdentifierPKSC-7 {{ContentEncryptionAlgorithms}} + AlgorithmIdentifierPKCS-7 {{ContentEncryptionAlgorithms}} ContentEncryptionAlgorithms ALGORITHM ::= { ... -- add any application-specific algorithms here } DigestAlgorithmIdentifier ::= - AlgorithmIdentifierPKSC-7 {{DigestAlgorithms}} + AlgorithmIdentifierPKCS-7 {{DigestAlgorithms}} DigestAlgorithms ALGORITHM ::= { ... -- add any application-specific algorithms here } DigestEncryptionAlgorithmIdentifier ::= - AlgorithmIdentifierPKSC-7 {{DigestEncryptionAlgorithms}} + AlgorithmIdentifierPKCS-7 {{DigestEncryptionAlgorithms}} DigestEncryptionAlgorithms ALGORITHM ::= { ... -- add any application-specific algorithms here @@ -182,7 +182,7 @@ IssuerAndSerialNumber ::= SEQUENCE { } KeyEncryptionAlgorithmIdentifier ::= - AlgorithmIdentifierPKSC-7 {{KeyEncryptionAlgorithms}} + AlgorithmIdentifierPKCS-7 {{KeyEncryptionAlgorithms}} KeyEncryptionAlgorithms ALGORITHM ::= { ... -- add any application-specific algorithms here diff --git a/lib/reltool/src/reltool_app_win.erl b/lib/reltool/src/reltool_app_win.erl index 663144861f..335b40fa74 100644 --- a/lib/reltool/src/reltool_app_win.erl +++ b/lib/reltool/src/reltool_app_win.erl @@ -102,8 +102,8 @@ init(Parent, WxEnv, Xref, C, AppName) -> try do_init(Parent, WxEnv, Xref, C, AppName) catch - error:Reason -> - exit({Reason, erlang:get_stacktrace()}) + error:Reason:Stacktrace -> + exit({Reason, Stacktrace}) end. do_init(Parent, WxEnv, Xref, C, AppName) -> diff --git a/lib/reltool/src/reltool_mod_win.erl b/lib/reltool/src/reltool_mod_win.erl index dcd802a5de..8272d864c2 100644 --- a/lib/reltool/src/reltool_mod_win.erl +++ b/lib/reltool/src/reltool_mod_win.erl @@ -107,8 +107,8 @@ init(Parent, WxEnv, Xref, RelPid, C, ModName) -> try do_init(Parent, WxEnv, Xref, RelPid, C, ModName) catch - error:Reason -> - exit({Reason, erlang:get_stacktrace()}) + error:Reason:Stacktrace -> + exit({Reason, Stacktrace}) end. do_init(Parent, WxEnv, Xref, RelPid, C, ModName) -> diff --git a/lib/reltool/src/reltool_server.erl b/lib/reltool/src/reltool_server.erl index 853191c696..66ee1a3742 100644 --- a/lib/reltool/src/reltool_server.erl +++ b/lib/reltool/src/reltool_server.erl @@ -135,8 +135,8 @@ init([{parent,Parent}|_] = Options) -> catch throw:{error,Reason} -> proc_lib:init_ack(Parent,{error,Reason}); - error:Reason -> - exit({Reason, erlang:get_stacktrace()}) + error:Reason:Stacktrace -> + exit({Reason, Stacktrace}) end. do_init(Options) -> diff --git a/lib/reltool/src/reltool_sys_win.erl b/lib/reltool/src/reltool_sys_win.erl index 92df270752..d87b1dc91f 100644 --- a/lib/reltool/src/reltool_sys_win.erl +++ b/lib/reltool/src/reltool_sys_win.erl @@ -135,9 +135,9 @@ init(Options) -> try do_init(Options) catch - error:Reason -> - io:format("~tp: ~tp~n",[Reason, erlang:get_stacktrace()]), - exit({Reason, erlang:get_stacktrace()}) + error:Reason:Stacktrace -> + io:format("~tp: ~tp~n",[Reason, Stacktrace]), + exit({Reason, Stacktrace}) end. do_init([{safe_config, Safe}, {parent, Parent} | Options]) -> diff --git a/lib/runtime_tools/doc/src/Makefile b/lib/runtime_tools/doc/src/Makefile index ec19a4ce59..a9b0056a93 100644 --- a/lib/runtime_tools/doc/src/Makefile +++ b/lib/runtime_tools/doc/src/Makefile @@ -41,7 +41,13 @@ RELSYSDIR = $(RELEASE_PATH)/lib/$(APPLICATION)-$(VSN) # Target Specs # ---------------------------------------------------- XML_APPLICATION_FILES = ref_man.xml -XML_REF3_FILES = dbg.xml dyntrace.xml erts_alloc_config.xml system_information.xml msacc.xml +XML_REF3_FILES = \ + dbg.xml \ + dyntrace.xml \ + erts_alloc_config.xml \ + system_information.xml \ + msacc.xml \ + scheduler.xml XML_REF6_FILES = runtime_tools_app.xml XML_PART_FILES = part.xml diff --git a/lib/runtime_tools/doc/src/notes.xml b/lib/runtime_tools/doc/src/notes.xml index 93e3e26fda..74300ba3fc 100644 --- a/lib/runtime_tools/doc/src/notes.xml +++ b/lib/runtime_tools/doc/src/notes.xml @@ -32,6 +32,23 @@ <p>This document describes the changes made to the Runtime_Tools application.</p> +<section><title>Runtime_Tools 1.12.4</title> + + <section><title>Improvements and New Features</title> + <list> + <item> + <p> + New family of <c>erts_alloc</c> strategies: Age Order + First Fit. Similar to "address order", but instead the + oldest possible carrier is always chosen for allocation.</p> + <p> + Own Id: OTP-14917 Aux Id: ERIERL-88 </p> + </item> + </list> + </section> + +</section> + <section><title>Runtime_Tools 1.12.3</title> <section><title>Fixed Bugs and Malfunctions</title> diff --git a/lib/runtime_tools/doc/src/ref_man.xml b/lib/runtime_tools/doc/src/ref_man.xml index d2fb7a29af..eb3a6f0f5c 100644 --- a/lib/runtime_tools/doc/src/ref_man.xml +++ b/lib/runtime_tools/doc/src/ref_man.xml @@ -37,6 +37,7 @@ <xi:include href="dyntrace.xml"/> <xi:include href="erts_alloc_config.xml"/> <xi:include href="msacc.xml"/> + <xi:include href="scheduler.xml"/> <xi:include href="system_information.xml"/> </application> diff --git a/lib/runtime_tools/doc/src/scheduler.xml b/lib/runtime_tools/doc/src/scheduler.xml new file mode 100644 index 0000000000..dd8bf73bae --- /dev/null +++ b/lib/runtime_tools/doc/src/scheduler.xml @@ -0,0 +1,135 @@ +<?xml version="1.0" encoding="utf-8" ?> +<!DOCTYPE erlref SYSTEM "erlref.dtd"> + +<erlref> + <header> + <copyright> + <year>2018</year> + <holder>Ericsson AB. All Rights Reserved.</holder> + </copyright> + <legalnotice> + 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. + + </legalnotice> + + <title></title> + <prepared></prepared> + <responsible></responsible> + <docno>1</docno> + <approved></approved> + <checked></checked> + <date></date> + <rev></rev> + <file>scheduler.xml</file> + </header> + <module>scheduler</module> + <modulesummary>Measure scheduler utilization</modulesummary> + <description> + <p>This module contains utility functions for easier measurement and + calculation of scheduler utilization, otherwise obtained from calling the + more primitive <seealso marker="erts:erlang#statistics_scheduler_wall_time"> + <c>statistics(scheduler_wall_time)</c></seealso>.</p> + <p>The simplest usage is to call <seealso marker="#utilization-1"> + <c>scheduler:utilization(Seconds)</c></seealso>.</p> + </description> + + <datatypes> + <datatype> + <name name="sched_sample"/> + </datatype> + <datatype> + <name name="sched_type"/> + </datatype> + <datatype> + <name name="sched_id"/> + </datatype> + <datatype> + <name name="sched_util_result"/> + <desc> + <p>A list of tuples containing results for individual schedulers + as well as aggregated averages. <c>Util</c> is the scheduler utilization + as a floating point value between 0.0 and 1.0. <c>Percent</c> is the + same utilization as a more human readable string expressed in percent.</p> + <taglist> + <tag><c>{normal, SchedulerId, Util, Percent}</c></tag> + <item>Scheduler utilization of a normal scheduler with number + <c>SchedulerId</c>.</item> + <tag><c>{cpu, SchedulerId, Util, Percent}</c></tag> + <item>Scheduler utilization of a dirty-cpu scheduler with number + <c>SchedulerId</c>.</item> + <tag><c>{io, SchedulerId, Util, Percent}</c></tag> + <item>Scheduler utilization of a dirty-io scheduler with number + <c>SchedulerId</c>. This tuple will only exist if both samples were + taken with <seealso marker="#sample_all-0"><c>sample_all/0</c></seealso>.</item> + <tag><c>{total, Util, Percent}</c></tag> + <item>Total utilization of all normal and dirty-cpu schedulers.</item> + <tag><c>{weighted, Util, Percent}</c></tag> + <item>Total utilization of all normal and dirty-cpu schedulers, + weighted against maximum amount of available CPU time.</item> + </taglist> + </desc> + </datatype> + </datatypes> + + <funcs> + + <func> + <name name="sample" arity="0"/> + <fsummary>Get scheduler utilization sample.</fsummary> + <desc> + <p>Return a scheduler utilization sample for normal and dirty-cpu + schedulers.</p> + </desc> + </func> + + <func> + <name name="sample_all" arity="0"/> + <fsummary>Get scheduler utilization sample.</fsummary> + <desc> + <p>Return a scheduler utilization sample for all schedulers, + including dirty-io schedulers.</p> + </desc> + </func> + + <func> + <name name="utilization" arity="1" clause_i="1"/> + <fsummary>Measure scheduler utilizations during a period of time.</fsummary> + <desc> + <p>Measure utilization for normal and dirty-cpu schedulers during + <c><anno>Seconds</anno></c> seconds, and then return the result.</p> + </desc> + </func> + + <func> + <name name="utilization" arity="1" clause_i="2"/> + <fsummary>Measure scheduler utilizations since sample.</fsummary> + <desc> + <p>Calculate scheduler utilizations for the time interval from when + <c><anno>Sample</anno></c> was taken and "now". The same as calling + <c>scheduler:utilization(Sample, scheduler:sample_all())</c>.</p> + </desc> + </func> + + <func> + <name name="utilization" arity="2"/> + <fsummary>Measure scheduler utilizations between two samples.</fsummary> + <desc> + <p>Calculates scheduler utilizations for the time interval between + the two samples obtained from calling + <seealso marker="#sample-0"><c>sample/0</c></seealso> or + <seealso marker="#sample_all-0"><c>sample_all/0</c></seealso>.</p> + </desc> + </func> + + </funcs> + </erlref> diff --git a/lib/runtime_tools/doc/src/specs.xml b/lib/runtime_tools/doc/src/specs.xml index 978bd39e55..33fe7fa370 100644 --- a/lib/runtime_tools/doc/src/specs.xml +++ b/lib/runtime_tools/doc/src/specs.xml @@ -2,4 +2,5 @@ <specs xmlns:xi="http://www.w3.org/2001/XInclude"> <xi:include href="../specs/specs_system_information.xml"/> <xi:include href="../specs/specs_msacc.xml"/> + <xi:include href="../specs/specs_scheduler.xml"/> </specs> diff --git a/lib/runtime_tools/src/Makefile b/lib/runtime_tools/src/Makefile index 5a99c6e240..6faa9c2e35 100644 --- a/lib/runtime_tools/src/Makefile +++ b/lib/runtime_tools/src/Makefile @@ -45,6 +45,7 @@ MODULES= \ system_information \ observer_backend \ ttb_autostart\ + scheduler\ msacc HRL_FILES= ../include/observer_backend.hrl diff --git a/lib/runtime_tools/src/erts_alloc_config.erl b/lib/runtime_tools/src/erts_alloc_config.erl index 342363d08d..6c1a945484 100644 --- a/lib/runtime_tools/src/erts_alloc_config.erl +++ b/lib/runtime_tools/src/erts_alloc_config.erl @@ -265,7 +265,13 @@ strategy_str(aoff) -> strategy_str(aoffcbf) -> "Address order first fit carrier best fit"; strategy_str(aoffcaobf) -> - "Address order first fit carrier adress order best fit". + "Address order first fit carrier adress order best fit"; +strategy_str(ageffcaoff) -> + "Age order first fit carrier address order first fit"; +strategy_str(ageffcbf) -> + "Age order first fit carrier best fit"; +strategy_str(ageffcaobf) -> + "Age order first fit carrier adress order best fit". default_acul(A, S) -> case carrier_migration_support(S) of diff --git a/lib/runtime_tools/src/observer_backend.erl b/lib/runtime_tools/src/observer_backend.erl index a1edde8516..7ec3b38930 100644 --- a/lib/runtime_tools/src/observer_backend.erl +++ b/lib/runtime_tools/src/observer_backend.erl @@ -279,7 +279,7 @@ get_table_list(mnesia, Opts) -> end, [Tab|Acc] catch _:_What -> - %% io:format("Skipped ~p: ~p ~p ~n",[Id, _What, erlang:get_stacktrace()]), + %% io:format("Skipped ~p: ~p ~p ~n",[Id, _What, Stacktrace]), Acc end end, diff --git a/lib/runtime_tools/src/runtime_tools.app.src b/lib/runtime_tools/src/runtime_tools.app.src index 449532e5c4..09a9b447c2 100644 --- a/lib/runtime_tools/src/runtime_tools.app.src +++ b/lib/runtime_tools/src/runtime_tools.app.src @@ -23,6 +23,7 @@ {modules, [appmon_info, dbg,observer_backend,runtime_tools, runtime_tools_sup,erts_alloc_config, ttb_autostart,dyntrace,system_information, + scheduler, msacc]}, {registered, [runtime_tools_sup]}, {applications, [kernel, stdlib]}, diff --git a/lib/runtime_tools/src/scheduler.erl b/lib/runtime_tools/src/scheduler.erl new file mode 100644 index 0000000000..c896b671ac --- /dev/null +++ b/lib/runtime_tools/src/scheduler.erl @@ -0,0 +1,152 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2018. 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% +%% + +%% @doc Utility functions for easier measurement of scheduler utilization +%% using erlang:statistics(scheduler_wall_time). + +-module(scheduler). + +-export([sample/0, + sample_all/0, + utilization/1, + utilization/2]). + +-export_type([sched_sample/0]). + + +-opaque sched_sample() :: + {scheduler_wall_time | scheduler_wall_time_all, + [{sched_type(), sched_id(), ActiveTime::integer(), TotalTime::integer()}]}. + +-type sched_type() :: normal | cpu | io. + +-type sched_id() :: integer(). + +-spec sample() -> sched_sample(). +sample() -> + sample(scheduler_wall_time). + +-spec sample_all() -> sched_sample(). +sample_all() -> + sample(scheduler_wall_time_all). + +sample(Stats) -> + case erlang:statistics(Stats) of + undefined -> + erlang:system_flag(scheduler_wall_time, true), + sample(Stats); + + List -> + Sorted = lists:sort(List), + Tagged = lists:map(fun({I, A, T}) -> {sched_tag(I), I, A, T} end, + Sorted), + {Stats, Tagged} + end. + +-type sched_util_result() :: + [{sched_type(), sched_id(), float(), string()} | + {total, float(), string()} | + {weighted, float(), string()}]. + +-spec utilization(Seconds) -> sched_util_result() when + Seconds :: pos_integer(); + (Sample) -> sched_util_result() when + Sample :: sched_sample(). +utilization(Seconds) when is_integer(Seconds), Seconds > 0 -> + OldFlag = erlang:system_flag(scheduler_wall_time, true), + T0 = sample(), + receive after Seconds*1000 -> ok end, + T1 = sample(), + case OldFlag of + false -> + erlang:system_flag(scheduler_wall_time, OldFlag); + true -> + ok + end, + utilization(T0,T1); + +utilization({Stats, _}=T0) when Stats =:= scheduler_wall_time; + Stats =:= scheduler_wall_time_all -> + utilization(T0, sample(Stats)). + +-spec utilization(Sample1, Sample2) -> sched_util_result() when + Sample1 :: sched_sample(), + Sample2 :: sched_sample(). +utilization({Stats, Ts0}, {Stats, Ts1}) -> + Diffs = lists:map(fun({{Tag, I, A0, T0}, {Tag, I, A1, T1}}) -> + {Tag, I, (A1 - A0), (T1 - T0)} + end, + lists:zip(Ts0,Ts1)), + + {Lst0, {A, T, N}} = lists:foldl(fun({Tag, I, Adiff, Tdiff}, {Lst, Acc}) -> + R = safe_div(Adiff, Tdiff), + {[{Tag, I, R, percent(R)} | Lst], + acc(Tag, Adiff, Tdiff, Acc)} + end, + {[], {0, 0, 0}}, + Diffs), + + Total = safe_div(A, T), + Lst1 = lists:reverse(Lst0), + Lst2 = case erlang:system_info(logical_processors_available) of + unknown -> Lst1; + LPA -> + Weighted = Total * (N / LPA), + [{weighted, Weighted, percent(Weighted)} | Lst1] + end, + [{total, Total, percent(Total)} | Lst2]; + +utilization({scheduler_wall_time, _}=T0, + {scheduler_wall_time_all, Ts1}) -> + utilization(T0, {scheduler_wall_time, remove_io(Ts1)}); + +utilization({scheduler_wall_time_all, Ts0}, + {scheduler_wall_time, _}=T1) -> + utilization({scheduler_wall_time, remove_io(Ts0)}, T1). + +%% Do not include dirty-io in totals +acc(io, _, _, Acc) -> + Acc; +acc(Tag, Adiff, Tdiff, {Asum, Tsum, N}) when Tag =:= normal; Tag =:= cpu -> + {Adiff+Asum, Tdiff+Tsum, N+1}. + + +remove_io(Ts) -> + lists:filter(fun({io,_,_,_}) -> false; + (_) -> true end, + Ts). + +safe_div(A, B) -> + if B == 0.0 -> 0.0; + true -> A / B + end. + +sched_tag(Nr) -> + Normal = erlang:system_info(schedulers), + Cpu = Normal + erlang:system_info(dirty_cpu_schedulers), + case Nr of + _ when Nr =< Normal -> normal; + _ when Nr =< Cpu -> cpu; + _ -> io + end. + + +percent(F) -> + float_to_list(F*100, [{decimals,1}]) ++ [$%]. diff --git a/lib/runtime_tools/src/system_information.erl b/lib/runtime_tools/src/system_information.erl index 119d7cc3d4..136ee55b54 100644 --- a/lib/runtime_tools/src/system_information.erl +++ b/lib/runtime_tools/src/system_information.erl @@ -488,10 +488,10 @@ to_fd(Fd) -> ok = file:write(Fd, io_lib:format(Format, Args)) end, - EmitChunk("{system_information_version, ~p}.~n" + EmitChunk("{system_information_version, ~w}.~n" "{system_information,[" - "{init_arguments,~p}," - "{code_paths,~p},", + "{init_arguments,~w}," + "{code_paths,~w},", [?REPORT_FILE_VSN, init:get_arguments(), code:get_path()]), @@ -499,12 +499,12 @@ to_fd(Fd) -> emit_code_info(EmitChunk), EmitChunk( "," %% Note the leading comma! - "{system_info,~p}," - "{erts_compile_info,~p}," - "{beam_dynamic_libraries,~p}," - "{environment_erts,~p}," - "{environment,~p}," - "{sanity_check,~p}" + "{system_info,~w}," + "{erts_compile_info,~w}," + "{beam_dynamic_libraries,~w}," + "{environment_erts,~w}," + "{environment,~w}," + "{sanity_check,~w}" "]}.~n", [erlang_system_info(), erlang:system_info(compile_info), @@ -533,11 +533,11 @@ emit_application_info(EmitChunk, Path) -> Description = proplists:get_value(description, Info, []), Version = proplists:get_value(vsn, Info, []), - EmitChunk("{application, {~p,[" - "{description,~p}," - "{vsn,~p}," - "{path,~p}," - "{runtime_dependencies,~p},", + EmitChunk("{application, {~w,[" + "{description,~w}," + "{vsn,~w}," + "{path,~w}," + "{runtime_dependencies,~w},", [App, Description, Version, Path, RtDeps]), emit_module_info_from_path(EmitChunk, Path), EmitChunk("]}}", []) @@ -545,7 +545,7 @@ emit_application_info(EmitChunk, Path) -> emit_code_path_info(EmitChunk, Path) -> EmitChunk("{code, [" - "{path, ~p},", [Path]), + "{path, ~w},", [Path]), emit_module_info_from_path(EmitChunk, Path), EmitChunk("]}", []). @@ -573,11 +573,11 @@ emit_module_info(EmitChunk, Beam) -> _ -> true end, - EmitChunk("{~p,[" - "{loaded,~p}," - "{native,~p}," - "{compiler,~p}," - "{md5,~p}" + EmitChunk("{~w,[" + "{loaded,~w}," + "{native,~w}," + "{compiler,~w}," + "{md5,~w}" "]}", [Mod, Loaded, Native, CompilerVersion, hexstring(Md5)]). diff --git a/lib/runtime_tools/test/Makefile b/lib/runtime_tools/test/Makefile index 61377ea09e..de37b2570d 100644 --- a/lib/runtime_tools/test/Makefile +++ b/lib/runtime_tools/test/Makefile @@ -9,6 +9,7 @@ MODULES = \ system_information_SUITE \ dbg_SUITE \ erts_alloc_config_SUITE \ + scheduler_SUITE \ msacc_SUITE ERL_FILES= $(MODULES:%=%.erl) diff --git a/lib/runtime_tools/test/scheduler_SUITE.erl b/lib/runtime_tools/test/scheduler_SUITE.erl new file mode 100644 index 0000000000..1c80253371 --- /dev/null +++ b/lib/runtime_tools/test/scheduler_SUITE.erl @@ -0,0 +1,104 @@ +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2018. All Rights Reserved. +%% +%% Licensed under the Apache License, Version 2.0 (the "License"); +%% you may not use this file except in compliance with the License. +%% You may obtain a copy of the License at +%% +%% http://www.apache.org/licenses/LICENSE-2.0 +%% +%% Unless required by applicable law or agreed to in writing, software +%% distributed under the License is distributed on an "AS IS" BASIS, +%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +%% See the License for the specific language governing permissions and +%% limitations under the License. +%% +%% %CopyrightEnd% +%% +%% + +-module(scheduler_SUITE). + +-export([suite/0, all/0]). + +%% Test cases +-export([basic/1]). + +all() -> [basic]. + + +suite() -> [{ct_hooks,[ts_install_cth]}]. + + +basic(_Config) -> + S1 = scheduler:sample(), + S2 = scheduler:sample_all(), + + check(scheduler:utilization(1)), + + check(scheduler:utilization(S1)), + check(scheduler:utilization(S2)), + check(scheduler:utilization(S1, scheduler:sample())), + check(scheduler:utilization(S2, scheduler:sample())), + + S3 = scheduler:sample_all(), + U13 = scheduler:utilization(S1, S3), + U13 = scheduler:utilization(S1, remove_io(S3)), + check(U13), + + U23all = scheduler:utilization(S2, S3), + check(U23all), + U23 = scheduler:utilization(S2, remove_io(S3)), + U23 = scheduler:utilization(remove_io(S2), S3), + U23 = remove_io(U23all), + check(U23), + + ok. + + +check([{total, Tf, Ts} | List]=U) -> + io:format("\nU = ~p\n", [U]), + check_values(Tf, Ts, true), + + SchdList = case hd(List) of + {weighted, Wf, Ws} -> + check_values(Wf, Ws, false), + tl(List); + _ -> + unknown = erlang:system_info(logical_processors_available), + List + end, + + lists:foreach(fun({Type, Id, F, S}) when ((Type =:= normal) or (Type =:= cpu) or (Type =:= io)), + is_integer(Id) -> + check_values(F, S, true) + end, + SchdList), + ok. + +check_values(F, S, Max100) -> + true = is_float(F), + true = F >= 0.0, + + $% = lists:last(S), + Sf = list_to_float(lists:droplast(S)), + true = Sf >= 0.0, + true = case Max100 of + true -> + true = F =< 1.0, + true = Sf =< 100.0; + false -> + true + end, + MaxDiff = 0.055555555555555555, %% change to 0.05 when float_to_list/2 is fixed + true = abs(F*100 - Sf) =< MaxDiff, + ok. + + +remove_io({scheduler_wall_time_all,Lst}) -> + {scheduler_wall_time, remove_io(Lst)}; +remove_io(Lst) -> + lists:filter(fun({io,_,_,_}) -> false; + (_) -> true end, + Lst). diff --git a/lib/runtime_tools/vsn.mk b/lib/runtime_tools/vsn.mk index 872bd5db1d..0dc6a48570 100644 --- a/lib/runtime_tools/vsn.mk +++ b/lib/runtime_tools/vsn.mk @@ -1 +1 @@ -RUNTIME_TOOLS_VSN = 1.12.3 +RUNTIME_TOOLS_VSN = 1.12.4 diff --git a/lib/sasl/test/release_handler_SUITE.erl b/lib/sasl/test/release_handler_SUITE.erl index 824820c214..edd2efdf05 100644 --- a/lib/sasl/test/release_handler_SUITE.erl +++ b/lib/sasl/test/release_handler_SUITE.erl @@ -2580,15 +2580,15 @@ check_gg_info(Node,OtherAlive,OtherDead,Synced,N) -> GGI = rpc:call(Node, global_group, info, []), GI = rpc:call(Node, global, info,[]), try do_check_gg_info(OtherAlive,OtherDead,Synced,GGI,GI) - catch _:E when N==0 -> + catch _:E:Stacktrace when N==0 -> ?t:format("~nERROR: check_gg_info failed for ~p:~n~p~n" "when GGI was: ~p~nand GI was: ~p~n", - [Node,{E,erlang:get_stacktrace()},GGI,GI]), + [Node,{E,Stacktrace},GGI,GI]), ?t:fail("check_gg_info failed"); - _:E -> + _:E:Stacktrace -> ?t:format("~nWARNING: check_gg_info failed for ~p:~n~p~n" "when GGI was: ~p~nand GI was: ~p~n", - [Node,{E,erlang:get_stacktrace()},GGI,GI]), + [Node,{E,Stacktrace},GGI,GI]), timer:sleep(1000), check_gg_info(Node,OtherAlive,OtherDead,Synced,N-1) end. diff --git a/lib/ssh/doc/src/notes.xml b/lib/ssh/doc/src/notes.xml index 3a2f55a487..c559da911b 100644 --- a/lib/ssh/doc/src/notes.xml +++ b/lib/ssh/doc/src/notes.xml @@ -30,6 +30,42 @@ <file>notes.xml</file> </header> +<section><title>Ssh 4.6.5</title> + + <section><title>Fixed Bugs and Malfunctions</title> + <list> + <item> + <p> + Adjusted supervisor timeouts</p> + <p> + Own Id: OTP-14907</p> + </item> + <item> + <p> + Remove ERROR messages for slow process exits</p> + <p> + Own Id: OTP-14930</p> + </item> + </list> + </section> + + + <section><title>Improvements and New Features</title> + <list> + <item> + <p> + Add option <c>save_accepted_host</c> to + <c>ssh:connection</c>. This option, if set to false, + inhibits saving host keys to e.g the file + <c>known_hosts</c>.</p> + <p> + Own Id: OTP-14935</p> + </item> + </list> + </section> + +</section> + <section><title>Ssh 4.6.4</title> <section><title>Fixed Bugs and Malfunctions</title> diff --git a/lib/ssh/doc/src/ssh.xml b/lib/ssh/doc/src/ssh.xml index 337f4094cc..acf94ff6af 100644 --- a/lib/ssh/doc/src/ssh.xml +++ b/lib/ssh/doc/src/ssh.xml @@ -227,6 +227,18 @@ </item> </list> </item> + + <tag><c><![CDATA[{save_accepted_host, boolean()}]]></c></tag> + <item> + <p>If <c>true</c>, the client saves an accepted host key to avoid the + accept question the next time the same host is connected. If the option + <c>key_cb</c> is not present, the key is saved in the file "known_hosts". + </p> + <p>If <c>false</c>, the key is not saved and the key will still be unknown + at the next access of the same host. + </p> + </item> + <tag><c><![CDATA[{user_interaction, boolean()}]]></c></tag> <item> <p>If <c>false</c>, disables the client to connect to the server diff --git a/lib/ssh/src/ssh_acceptor_sup.erl b/lib/ssh/src/ssh_acceptor_sup.erl index a24664793b..fc564a359b 100644 --- a/lib/ssh/src/ssh_acceptor_sup.erl +++ b/lib/ssh/src/ssh_acceptor_sup.erl @@ -86,10 +86,7 @@ child_spec(Address, Port, Profile, Options) -> Timeout = ?GET_INTERNAL_OPT(timeout, Options, ?DEFAULT_TIMEOUT), #{id => id(Address, Port, Profile), start => {ssh_acceptor, start_link, [Port, Address, Options, Timeout]}, - restart => transient, - shutdown => 5500, %brutal_kill, - type => worker, - modules => [ssh_acceptor] + restart => transient % because a crashed listener could be replaced by a new one }. id(Address, Port, Profile) -> diff --git a/lib/ssh/src/ssh_channel_sup.erl b/lib/ssh/src/ssh_channel_sup.erl index 6b01dc334d..8444533fd1 100644 --- a/lib/ssh/src/ssh_channel_sup.erl +++ b/lib/ssh/src/ssh_channel_sup.erl @@ -26,7 +26,7 @@ -behaviour(supervisor). --export([start_link/1, start_child/2]). +-export([start_link/1, start_child/5]). %% Supervisor callback -export([init/1]). @@ -37,7 +37,14 @@ start_link(Args) -> supervisor:start_link(?MODULE, [Args]). -start_child(Sup, ChildSpec) -> +start_child(Sup, Callback, Id, Args, Exec) -> + ChildSpec = + #{id => make_ref(), + start => {ssh_channel, start_link, [self(), Id, Callback, Args, Exec]}, + restart => temporary, + type => worker, + modules => [ssh_channel] + }, supervisor:start_child(Sup, ChildSpec). %%%========================================================================= diff --git a/lib/ssh/src/ssh_connection.erl b/lib/ssh/src/ssh_connection.erl index 7e9ee78fd2..946ae2967b 100644 --- a/lib/ssh/src/ssh_connection.erl +++ b/lib/ssh/src/ssh_connection.erl @@ -812,22 +812,20 @@ start_channel(Cb, Id, Args, SubSysSup, Opts) -> start_channel(Cb, Id, Args, SubSysSup, undefined, Opts). start_channel(Cb, Id, Args, SubSysSup, Exec, Opts) -> - ChildSpec = child_spec(Cb, Id, Args, Exec), ChannelSup = ssh_subsystem_sup:channel_supervisor(SubSysSup), - assert_limit_num_channels_not_exceeded(ChannelSup, Opts), - ssh_channel_sup:start_child(ChannelSup, ChildSpec). + case max_num_channels_not_exceeded(ChannelSup, Opts) of + true -> + ssh_channel_sup:start_child(ChannelSup, Cb, Id, Args, Exec); + false -> + throw(max_num_channels_exceeded) + end. -assert_limit_num_channels_not_exceeded(ChannelSup, Opts) -> +max_num_channels_not_exceeded(ChannelSup, Opts) -> MaxNumChannels = ?GET_OPT(max_channels, Opts), NumChannels = length([x || {_,_,worker,[ssh_channel]} <- supervisor:which_children(ChannelSup)]), - if - %% Note that NumChannels is BEFORE starting a new one - NumChannels < MaxNumChannels -> - ok; - true -> - throw(max_num_channels_exceeded) - end. + %% Note that NumChannels is BEFORE starting a new one + NumChannels < MaxNumChannels. %%-------------------------------------------------------------------- %%% Internal functions @@ -874,14 +872,6 @@ check_subsystem(SsName, Options) -> Value end. -child_spec(Callback, Id, Args, Exec) -> - Name = make_ref(), - StartFunc = {ssh_channel, start_link, [self(), Id, Callback, Args, Exec]}, - Restart = temporary, - Shutdown = 3600, - Type = worker, - {Name, StartFunc, Restart, Shutdown, Type, [ssh_channel]}. - start_cli(#connection{cli_spec = no_cli}, _) -> {error, cli_disabled}; start_cli(#connection{options = Options, diff --git a/lib/ssh/src/ssh_connection_handler.erl b/lib/ssh/src/ssh_connection_handler.erl index 0ca960ef96..c8ac3a9c04 100644 --- a/lib/ssh/src/ssh_connection_handler.erl +++ b/lib/ssh/src/ssh_connection_handler.erl @@ -1460,13 +1460,12 @@ terminate(shutdown, StateName, State0) -> State0), finalize_termination(StateName, State); -%% terminate({shutdown,Msg}, StateName, State0) when is_record(Msg,ssh_msg_disconnect)-> -%% State = send_msg(Msg, State0), -%% finalize_termination(StateName, Msg, State); - terminate({shutdown,_R}, StateName, State) -> finalize_termination(StateName, State); +terminate(kill, StateName, State) -> + finalize_termination(StateName, State); + terminate(Reason, StateName, State0) -> %% Others, e.g undef, {badmatch,_} log_error(Reason), diff --git a/lib/ssh/src/ssh_connection_sup.erl b/lib/ssh/src/ssh_connection_sup.erl index 60ee8b7c73..2e8450090a 100644 --- a/lib/ssh/src/ssh_connection_sup.erl +++ b/lib/ssh/src/ssh_connection_sup.erl @@ -52,10 +52,7 @@ init(_) -> }, ChildSpecs = [#{id => undefined, % As simple_one_for_one is used. start => {ssh_connection_handler, start_link, []}, - restart => temporary, - shutdown => 4000, - type => worker, - modules => [ssh_connection_handler] + restart => temporary % because there is no way to restart a crashed connection } ], {ok, {SupFlags,ChildSpecs}}. diff --git a/lib/ssh/src/ssh_options.erl b/lib/ssh/src/ssh_options.erl index 68c99743ee..cf1534bd78 100644 --- a/lib/ssh/src/ssh_options.erl +++ b/lib/ssh/src/ssh_options.erl @@ -439,6 +439,12 @@ default(client) -> class => user_options }, + {save_accepted_host, def} => + #{default => true, + chk => fun erlang:is_boolean/1, + class => user_options + }, + {pref_public_key_algs, def} => #{default => ssh_transport:default_algorithms(public_key), chk => fun check_pref_public_key_algs/1, diff --git a/lib/ssh/src/ssh_subsystem_sup.erl b/lib/ssh/src/ssh_subsystem_sup.erl index 8db051095c..77da240a66 100644 --- a/lib/ssh/src/ssh_subsystem_sup.erl +++ b/lib/ssh/src/ssh_subsystem_sup.erl @@ -74,18 +74,14 @@ ssh_connection_child_spec(Role, Address, Port, _Profile, Options) -> #{id => id(Role, ssh_connection_sup, Address, Port), start => {ssh_connection_sup, start_link, [Options]}, restart => temporary, - shutdown => 5000, - type => supervisor, - modules => [ssh_connection_sup] + type => supervisor }. ssh_channel_child_spec(Role, Address, Port, _Profile, Options) -> #{id => id(Role, ssh_channel_sup, Address, Port), start => {ssh_channel_sup, start_link, [Options]}, restart => temporary, - shutdown => infinity, - type => supervisor, - modules => [ssh_channel_sup] + type => supervisor }. id(Role, Sup, Address, Port) -> diff --git a/lib/ssh/src/ssh_sup.erl b/lib/ssh/src/ssh_sup.erl index eaec7a54e4..8183016ba5 100644 --- a/lib/ssh/src/ssh_sup.erl +++ b/lib/ssh/src/ssh_sup.erl @@ -36,15 +36,14 @@ init(_) -> intensity => 10, period => 3600 }, - ChildSpecs = [#{id => Module, - start => {Module, start_link, []}, - restart => permanent, - shutdown => 4000, %brutal_kill, - type => supervisor, - modules => [Module] + ChildSpecs = [#{id => sshd_sup, + start => {sshd_sup, start_link, []}, + type => supervisor + }, + #{id => sshc_sup, + start => {sshc_sup, start_link, []}, + type => supervisor } - || Module <- [sshd_sup, - sshc_sup] ], {ok, {SupFlags,ChildSpecs}}. diff --git a/lib/ssh/src/ssh_system_sup.erl b/lib/ssh/src/ssh_system_sup.erl index e70abf59c2..17f990c5d8 100644 --- a/lib/ssh/src/ssh_system_sup.erl +++ b/lib/ssh/src/ssh_system_sup.erl @@ -63,9 +63,7 @@ init([Address, Port, Profile, Options]) -> [#{id => id(ssh_acceptor_sup, Address, Port, Profile), start => {ssh_acceptor_sup, start_link, [Address, Port, Profile, Options]}, restart => transient, - shutdown => infinity, - type => supervisor, - modules => [ssh_acceptor_sup] + type => supervisor }]; _ -> [] @@ -124,9 +122,8 @@ start_subsystem(SystemSup, Role, Address, Port, Profile, Options) -> #{id => make_ref(), start => {ssh_subsystem_sup, start_link, [Role, Address, Port, Profile, Options]}, restart => temporary, - shutdown => infinity, - type => supervisor, - modules => [ssh_subsystem_sup]}, + type => supervisor + }, supervisor:start_child(SystemSup, SubsystemSpec). stop_subsystem(SystemSup, SubSys) -> diff --git a/lib/ssh/src/ssh_transport.erl b/lib/ssh/src/ssh_transport.erl index ad9efc4755..975053d301 100644 --- a/lib/ssh/src/ssh_transport.erl +++ b/lib/ssh/src/ssh_transport.erl @@ -889,10 +889,13 @@ known_host_key(#ssh{opts = Opts, key_cb = {KeyCb,KeyCbOpts}, peer = {PeerName,_} {_,true} -> ok; {_,false} -> + DoAdd = ?GET_OPT(save_accepted_host, Opts), case accepted_host(Ssh, PeerName, Public, Opts) of - true -> + true when DoAdd == true -> {_,R} = add_host_key(KeyCb, PeerName, Public, [{key_cb_private,KeyCbOpts}|UserOpts]), R; + true when DoAdd == false -> + ok; false -> {error, rejected_by_user}; {error,E} -> diff --git a/lib/ssh/src/sshc_sup.erl b/lib/ssh/src/sshc_sup.erl index 133b2c6450..fd4d8a3c07 100644 --- a/lib/ssh/src/sshc_sup.erl +++ b/lib/ssh/src/sshc_sup.erl @@ -60,10 +60,7 @@ init(_) -> }, ChildSpecs = [#{id => undefined, % As simple_one_for_one is used. start => {ssh_connection_handler, start_link, []}, - restart => temporary, - shutdown => 4000, - type => worker, - modules => [ssh_connection_handler] + restart => temporary % because there is no way to restart a crashed connection } ], {ok, {SupFlags,ChildSpecs}}. diff --git a/lib/ssh/src/sshd_sup.erl b/lib/ssh/src/sshd_sup.erl index c23e65d955..779a861a54 100644 --- a/lib/ssh/src/sshd_sup.erl +++ b/lib/ssh/src/sshd_sup.erl @@ -90,10 +90,8 @@ init(_) -> child_spec(Address, Port, Profile, Options) -> #{id => id(Address, Port, Profile), start => {ssh_system_sup, start_link, [Address, Port, Profile, Options]}, - restart => temporary, - shutdown => infinity, - type => supervisor, - modules => [ssh_system_sup] + restart => temporary, + type => supervisor }. id(Address, Port, Profile) -> diff --git a/lib/ssh/test/ssh_compat_SUITE.erl b/lib/ssh/test/ssh_compat_SUITE.erl index 74ab5aca3a..82b83dd83d 100644 --- a/lib/ssh/test/ssh_compat_SUITE.erl +++ b/lib/ssh/test/ssh_compat_SUITE.erl @@ -32,7 +32,8 @@ -compile(export_all). -define(USER,"sshtester"). --define(PWD, "foobar"). +-define(PASSWD, "foobar"). +-define(BAD_PASSWD, "NOT-"?PASSWD). -define(DOCKER_PFX, "ssh_compat_suite-ssh"). %%-------------------------------------------------------------------- @@ -44,25 +45,22 @@ suite() -> {timetrap,{seconds,40}}]. all() -> - [{group,G} || G <- vers()]. +%% [check_docker_present] ++ + [{group,G} || G <- ssh_image_versions()]. groups() -> - [{G, [], tests()} || G <- vers()]. - -tests() -> - [login_with_password_otp_is_client, - login_with_password_otp_is_server, - login_with_keyboard_interactive_otp_is_client, - login_with_keyboard_interactive_otp_is_server, - login_with_all_public_keys_otp_is_client, - login_with_all_public_keys_otp_is_server, - all_algorithms_otp_is_client, - all_algorithms_otp_is_server + [{otp_client, [], [login_otp_is_client, + all_algorithms_sftp_exec_reneg_otp_is_client, + send_recv_big_with_renegotiate_otp_is_client + ]}, + {otp_server, [], [login_otp_is_server, + all_algorithms_sftp_exec_reneg_otp_is_server + ]} | + [{G, [], [{group,otp_client}, {group,otp_server}]} || G <- ssh_image_versions()] ]. - -vers() -> +ssh_image_versions() -> try %% Find all useful containers in such a way that undefined command, too low %% priviliges, no containers and containers found give meaningful result: @@ -97,25 +95,56 @@ end_per_suite(Config) -> Config. +init_per_group(otp_server, Config) -> + case proplists:get_value(common_remote_client_algs, Config) of + undefined -> + SSHver = proplists:get_value(ssh_version, Config, ""), + {skip,"No "++SSHver++ " client found in docker"}; + _ -> + Config + end; + +init_per_group(otp_client, Config) -> + Config; -init_per_group(G, Config) -> - case lists:member(G, vers()) of +init_per_group(G, Config0) -> + case lists:member(G, ssh_image_versions()) of true -> + %% This group is for one of the images + Vssh = atom_to_list(G), + Cmnt = io_lib:format("+++ ~s +++",[Vssh]), + ct:comment("~s",[Cmnt]), try start_docker(G) of {ok,ID} -> - ct:log("==> ~p",[G]), - [Vssh|VsslRest] = string:tokens(atom_to_list(G), "-"), - Vssl = lists:flatten(lists:join($-,VsslRest)), - ct:comment("+++ ~s + ~s +++",[Vssh,Vssl]), + ct:log("==> ~p started",[G]), %% Find the algorithms that both client and server supports: {IP,Port} = ip_port([{id,ID}]), - try common_algs([{id,ID}|Config], IP, Port) of - {ok, RemoteServerCommon, RemoteClientCommon} -> - [{ssh_version,Vssh},{ssl_version,Vssl}, - {id,ID}, - {common_server_algs,RemoteServerCommon}, - {common_client_algs,RemoteClientCommon} - |Config]; + ct:log("Try contact ~p:~p",[IP,Port]), + Config1 = [{id,ID}, + {ssh_version,Vssh} + | Config0], + try common_algs(Config1, IP, Port) of + {ok, ServerHello, RemoteServerCommon, ClientHello, RemoteClientCommon} -> + case chk_hellos([ServerHello,ClientHello], Cmnt) of + Cmnt -> + ok; + NewCmnt -> + ct:comment("~s",[NewCmnt]) + end, + AuthMethods = + %% This should be obtained by quering the peer, but that + %% is a bit hard. It is possible with ssh_protocol_SUITE + %% techniques, but it can wait. + case Vssh of + "dropbear" ++ _ -> + [password, publickey]; + _ -> + [password, 'keyboard-interactive', publickey] + end, + [{common_remote_server_algs,RemoteServerCommon}, + {common_remote_client_algs,RemoteClientCommon}, + {common_authmethods,AuthMethods} + |Config1]; Other -> ct:log("Error in init_per_group: ~p",[Other]), stop_docker(ID), @@ -138,188 +167,301 @@ init_per_group(G, Config) -> end; false -> - Config + Config0 end. -end_per_group(_, Config) -> - catch stop_docker(proplists:get_value(id,Config)), - Config. +end_per_group(G, Config) -> + case lists:member(G, ssh_image_versions()) of + true -> + catch stop_docker(proplists:get_value(id,Config)); + false -> + ok + end. %%-------------------------------------------------------------------- %% Test Cases -------------------------------------------------------- %%-------------------------------------------------------------------- -login_with_password_otp_is_client(Config) -> - {IP,Port} = ip_port(Config), - {ok,C} = ssh:connect(IP, Port, [{auth_methods,"password"}, - {user,?USER}, - {password,?PWD}, - {user_dir, new_dir(Config)}, - {silently_accept_hosts,true}, - {user_interaction,false} - ]), - ssh:close(C). - -%%-------------------------------------------------------------------- -login_with_password_otp_is_server(Config) -> - {Server, Host, HostPort} = - ssh_test_lib:daemon(0, - [{auth_methods,"password"}, - {system_dir, setup_local_hostdir('ssh-rsa',Config)}, - {user_dir, new_dir(Config)}, - {user_passwords, [{?USER,?PWD}]}, - {failfun, fun ssh_test_lib:failfun/2} - ]), - R = exec_from_docker(Config, Host, HostPort, - "'lists:concat([\"Answer=\",1+2]).\r\n'", - [<<"Answer=3">>], - ""), - ssh:stop_daemon(Server), - R. - -%%-------------------------------------------------------------------- -login_with_keyboard_interactive_otp_is_client(Config) -> - {DockerIP,DockerPort} = ip_port(Config), - {ok,C} = ssh:connect(DockerIP, DockerPort, - [{auth_methods,"keyboard-interactive"}, - {user,?USER}, - {password,?PWD}, - {user_dir, new_dir(Config)}, - {silently_accept_hosts,true}, - {user_interaction,false} - ]), - ssh:close(C). - -%%-------------------------------------------------------------------- -login_with_keyboard_interactive_otp_is_server(Config) -> - {Server, Host, HostPort} = - ssh_test_lib:daemon(0, - [{auth_methods,"keyboard-interactive"}, - {system_dir, setup_local_hostdir('ssh-rsa',Config)}, - {user_dir, new_dir(Config)}, - {user_passwords, [{?USER,?PWD}]}, - {failfun, fun ssh_test_lib:failfun/2} - ]), - R = exec_from_docker(Config, Host, HostPort, - "'lists:concat([\"Answer=\",1+3]).\r\n'", - [<<"Answer=4">>], - ""), - ssh:stop_daemon(Server), - R. +check_docker_present(_Config) -> + ct:log("This testcase is just to show in Monitor that we have a test host with docker installed",[]), + {fail, "Test is OK: just showing docker is available"}. %%-------------------------------------------------------------------- -login_with_all_public_keys_otp_is_client(Config) -> - CommonAlgs = [{public_key_from_host,A} - || {public_key,A} <- proplists:get_value(common_server_algs, Config)], - {DockerIP,DockerPort} = ip_port(Config), - chk_all_algos(CommonAlgs, Config, - fun(_Tag,Alg) -> - ssh:connect(DockerIP, DockerPort, - [{auth_methods, "publickey"}, - {user, ?USER}, - {user_dir, setup_remote_auth_keys_and_local_priv(Alg, Config)}, - {silently_accept_hosts,true}, - {user_interaction,false} - ]) +login_otp_is_client(Config) -> + {IP,Port} = ip_port(Config), + PublicKeyAlgs = [A || {public_key,A} <- proplists:get_value(common_remote_server_algs, Config)], + CommonAuths = + [{AuthMethod,Alg} || AuthMethod <- proplists:get_value(common_authmethods, Config), + Alg <- case AuthMethod of + publickey -> + PublicKeyAlgs; + _ -> + [' '] + end + ], + + chk_all_algos(?FUNCTION_NAME, CommonAuths, Config, + fun(AuthMethod,Alg) -> + {Opts,Dir} = + case AuthMethod of + publickey -> + {[], setup_remote_auth_keys_and_local_priv(Alg, Config)}; + _ -> + {[{password,?PASSWD}], new_dir(Config)} + end, + ssh:connect(IP, Port, [{auth_methods, atom_to_list(AuthMethod)}, + {user,?USER}, + {user_dir, Dir}, + {silently_accept_hosts,true}, + {user_interaction,false} + | Opts + ]) end). + %%-------------------------------------------------------------------- -login_with_all_public_keys_otp_is_server(Config) -> - CommonAlgs = [{public_key_to_host,A} - || {public_key,A} <- proplists:get_value(common_client_algs, Config)], - UserDir = new_dir(Config), - {Server, Host, HostPort} = - ssh_test_lib:daemon(0, - [{auth_methods, "publickey"}, - {system_dir, setup_local_hostdir('ssh-rsa',Config)}, - {user_dir, UserDir}, - {user_passwords, [{?USER,?PWD}]}, - {failfun, fun ssh_test_lib:failfun/2} - ]), - - R = chk_all_algos(CommonAlgs, Config, - fun(_Tag,Alg) -> - setup_remote_priv_and_local_auth_keys(Alg, clear_dir(UserDir), Config), - exec_from_docker(Config, Host, HostPort, - "'lists:concat([\"Answer=\",1+4]).\r\n'", - [<<"Answer=5">>], - "") - end), - ssh:stop_daemon(Server), - R. +login_otp_is_server(Config) -> + PublicKeyAlgs = [A || {public_key,A} <- proplists:get_value(common_remote_client_algs, Config)], + CommonAuths = + [{AuthMethod,Alg} || AuthMethod <- proplists:get_value(common_authmethods, Config), + Alg <- case AuthMethod of + publickey -> + PublicKeyAlgs; + _ -> + [' '] + end + ], + SysDir = setup_local_hostdir(hd(PublicKeyAlgs), Config), + chk_all_algos(?FUNCTION_NAME, CommonAuths, Config, + fun(AuthMethod,Alg) -> + {Opts,UsrDir} = + case AuthMethod of + publickey -> + {[{user_passwords, [{?USER,?BAD_PASSWD}]}], + setup_remote_priv_and_local_auth_keys(Alg, Config) + }; + _ -> + {[{user_passwords, [{?USER,?PASSWD}]}], + new_dir(Config) + } + end, + {Server, Host, HostPort} = + ssh_test_lib:daemon(0, + [{auth_methods, atom_to_list(AuthMethod)}, + {system_dir, SysDir}, + {user_dir, UsrDir}, + {failfun, fun ssh_test_lib:failfun/2} + | Opts + ]), + R = exec_from_docker(Config, Host, HostPort, + "'lists:concat([\"Answer=\",1+3]).\r\n'", + [<<"Answer=4">>], + ""), + ssh:stop_daemon(Server), + R + end). %%-------------------------------------------------------------------- -all_algorithms_otp_is_client(Config) -> - CommonAlgs = proplists:get_value(common_server_algs, Config), +all_algorithms_sftp_exec_reneg_otp_is_client(Config) -> + CommonAlgs = proplists:get_value(common_remote_server_algs, Config), {IP,Port} = ip_port(Config), - chk_all_algos(CommonAlgs, Config, + chk_all_algos(?FUNCTION_NAME, CommonAlgs, Config, fun(Tag, Alg) -> - ssh:connect(IP, Port, [{user,?USER}, - {password,?PWD}, - {auth_methods, "password"}, - {user_dir, new_dir(Config)}, - {preferred_algorithms, [{Tag,[Alg]}]}, - {silently_accept_hosts,true}, - {user_interaction,false} + ConnRes = + ssh:connect(IP, Port, + [{user,?USER}, + {password,?PASSWD}, + {auth_methods, "password"}, + {user_dir, new_dir(Config)}, + {preferred_algorithms, [{Tag,[Alg]}]}, + {silently_accept_hosts,true}, + {user_interaction,false} + ]) , + test_erl_client_reneg(ConnRes, % Seems that max 10 channels may be open in sshd + [{exec,1}, + {sftp,5}, + {no_subsyst,1}, + {setenv, 1}, + {sftp_async,1} ]) end). %%-------------------------------------------------------------------- -all_algorithms_otp_is_server(Config) -> - CommonAlgs = proplists:get_value(common_client_algs, Config), +all_algorithms_sftp_exec_reneg_otp_is_server(Config) -> + CommonAlgs = proplists:get_value(common_remote_client_algs, Config), UserDir = setup_remote_priv_and_local_auth_keys('ssh-rsa', Config), - chk_all_algos(CommonAlgs, Config, + chk_all_algos(?FUNCTION_NAME, CommonAlgs, Config, fun(Tag,Alg) -> HostKeyAlg = case Tag of public_key -> Alg; _ -> 'ssh-rsa' end, + SftpRootDir = new_dir(Config), + %% ct:log("Rootdir = ~p",[SftpRootDir]), {Server, Host, HostPort} = ssh_test_lib:daemon(0, [{preferred_algorithms, [{Tag,[Alg]}]}, {system_dir, setup_local_hostdir(HostKeyAlg, Config)}, {user_dir, UserDir}, - {user_passwords, [{?USER,?PWD}]}, - {failfun, fun ssh_test_lib:failfun/2} + {user_passwords, [{?USER,?PASSWD}]}, + {failfun, fun ssh_test_lib:failfun/2}, + {subsystems, + [ssh_sftpd:subsystem_spec([{cwd,SftpRootDir}, + {root,SftpRootDir}]), + {"echo_10",{ssh_echo_server,[10,[{dbg,true}]]}} + ]} ]), - R = exec_from_docker(Config, Host, HostPort, - "hi_there.\r\n", - [<<"hi_there">>], - ""), + R = do([fun() -> + exec_from_docker(Config, Host, HostPort, + "hi_there.\r\n", + [<<"hi_there">>], + "") + end, + fun() -> + sftp_tests_erl_server(Config, Host, HostPort, SftpRootDir, UserDir) + end + ]), ssh:stop_daemon(Server), R end). %%-------------------------------------------------------------------- +send_recv_big_with_renegotiate_otp_is_client(Config) -> + %% Connect to the remote openssh server: + {IP,Port} = ip_port(Config), + {ok,C} = ssh:connect(IP, Port, [{user,?USER}, + {password,?PASSWD}, + {user_dir, setup_remote_auth_keys_and_local_priv('ssh-rsa', Config)}, + {silently_accept_hosts,true}, + {user_interaction,false} + ]), + + %% Open a channel and exec the Linux 'cat' command at the openssh side. + %% This 'cat' will read stdin and write to stdout until an eof is read from stdin. + {ok, Ch1} = ssh_connection:session_channel(C, infinity), + success = ssh_connection:exec(C, Ch1, "cat", infinity), + + %% Build big binary + HalfSizeBytes = 100*1000*1000, + Data = << <<X:32>> || X <- lists:seq(1, HalfSizeBytes div 4)>>, + + %% Send the data. Must spawn a process to avoid deadlock. The client will block + %% until all is sent through the send window. But the server will stop receiveing + %% when the servers send-window towards the client is full. + %% Since the client can't receive before the server has received all but 655k from the client + %% ssh_connection:send/4 is blocking... + spawn_link( + fun() -> + ct:comment("Sending ~p Mbytes with renegotiation in the middle",[2*byte_size(Data)/1000000]), + %% ct:log("sending first ~p bytes",[byte_size(Data)]), + ok = ssh_connection:send(C, Ch1, Data, 10000), + %% ct:log("Init renegotiation test",[]), + Kex1 = renegotiate_test(init, C), + %% ct:log("sending next ~p bytes",[byte_size(Data)]), + ok = ssh_connection:send(C, Ch1, Data, 10000), + %% ct:log("Finnish renegotiation test",[]), + renegotiate_test(Kex1, C), + %% ct:log("sending eof",[]), + ok = ssh_connection:send_eof(C, Ch1) + %%, ct:log("READY, sent ~p bytes",[2*byte_size(Data)]) + end), + + {eof,ReceivedData} = + loop_until(fun({eof,_}) -> true; + (_ ) -> false + end, + fun(Acc) -> + %%ct:log("Get more ~p",[ ExpectedSize-byte_size(Acc) ]), + receive + {ssh_cm, C, {eof,Ch}} when Ch==Ch1 -> + %% ct:log("eof received",[]), + {eof,Acc}; + + {ssh_cm, C, {data,Ch,0,B}} when Ch==Ch1, + is_binary(B) -> + %% ct:log("(1) Received ~p bytes (total ~p), missing ~p bytes", + %% [byte_size(B), + %% byte_size(B)+byte_size(Acc), + %% 2*byte_size(Data)-(byte_size(B)+byte_size(Acc))]), + ssh_connection:adjust_window(C, Ch1, byte_size(B)), + <<Acc/binary, B/binary>> + end + end, + <<>>), + + ExpectedData = <<Data/binary, Data/binary>>, + case ReceivedData of + ExpectedData -> + %% ct:log("Correct data returned",[]), + %% receive close messages + loop_until(fun(Left) -> %% ct:log("Expect: ~p",[Left]), + Left == [] + end, + fun([Next|Rest]) -> + receive + {ssh_cm,C,Next} -> Rest + end + end, + [%% Already received: {eof, Ch1}, + {exit_status,Ch1,0}, + {closed,Ch1}] + ), + ok; + _ when is_binary(ReceivedData) -> + ct:fail("~p bytes echoed but ~p expected", [byte_size(ReceivedData), 2*byte_size(Data)]) + end. + +%%-------------------------------------------------------------------- %% Utilities --------------------------------------------------------- %%-------------------------------------------------------------------- -exec_from_docker(WhatEver, {0,0,0,0}, HostPort, Command, Expects, ExtraSshArg) -> - exec_from_docker(WhatEver, host_ip(), HostPort, Command, Expects, ExtraSshArg); +%%-------------------------------------------------------------------- +%% +%% A practical meta function +%% +loop_until(CondFun, DoFun, Acc) -> + case CondFun(Acc) of + true -> + Acc; + false -> + loop_until(CondFun, DoFun, DoFun(Acc)) + end. + +%%-------------------------------------------------------------------- +%% +%% Exec the Command in the docker. Add the arguments ExtraSshArg in the +%% ssh command. +%% +%% If Expects is returned, then return 'ok', else return {fail,Msg}. +%% exec_from_docker(Config, HostIP, HostPort, Command, Expects, ExtraSshArg) when is_binary(hd(Expects)), is_list(Config) -> {DockerIP,DockerPort} = ip_port(Config), {ok,C} = ssh:connect(DockerIP, DockerPort, [{user,?USER}, - {password,?PWD}, + {password,?PASSWD}, {user_dir, new_dir(Config)}, {silently_accept_hosts,true}, {user_interaction,false} ]), - R = exec_from_docker(C, HostIP, HostPort, Command, Expects, ExtraSshArg), + R = exec_from_docker(C, HostIP, HostPort, Command, Expects, ExtraSshArg, Config), ssh:close(C), - R; - -exec_from_docker(C, HostIP, HostPort, Command, Expects, ExtraSshArg) when is_binary(hd(Expects)) -> - SSH_from_docker = - lists:concat(["sshpass -p ",?PWD," ", - "/buildroot/ssh/bin/ssh -p ",HostPort," -o 'CheckHostIP=no' -o 'StrictHostKeyChecking=no' ", - ExtraSshArg," ", - inet_parse:ntoa(HostIP)," " - ]), - ExecCommand = SSH_from_docker ++ Command, - R = exec(C, ExecCommand), - case R of - {ok,{ExitStatus,Result}} when ExitStatus == 0 -> + R. + +exec_from_docker(C, DestIP, DestPort, Command, Expects, ExtraSshArg, Config) when is_binary(hd(Expects)) -> + ExecCommand = + lists:concat( + ["sshpass -p ",?PASSWD," " + | case proplists:get_value(ssh_version,Config) of + "dropbear" ++ _ -> + ["dbclient -y -y -p ",DestPort," ",ExtraSshArg," ",iptoa(DestIP)," "]; + + _ -> %% OpenSSH or compatible + ["/buildroot/ssh/bin/ssh -o 'CheckHostIP=no' -o 'StrictHostKeyChecking=no' ", + ExtraSshArg," -p ",DestPort," ",iptoa(DestIP)," "] + end]) ++ Command, + + case exec(C, ExecCommand) of + {ok,{ExitStatus,Result}} = R when ExitStatus == 0 -> case binary:match(Result, Expects) of nomatch -> ct:log("Result of~n ~s~nis~n ~p",[ExecCommand,R]), @@ -327,28 +469,26 @@ exec_from_docker(C, HostIP, HostPort, Command, Expects, ExtraSshArg) when is_bin _ -> ok end; - {ok,_} -> + {ok,_} = R -> ct:log("Result of~n ~s~nis~n ~p",[ExecCommand,R]), {fail, "Exit status =/= 0"}; - _ -> + R -> ct:log("Result of~n ~s~nis~n ~p",[ExecCommand,R]), {fail, "Couldn't login to host"} end. - - exec(C, Cmd) -> - ct:log("~s",[Cmd]), + %% ct:log("~s",[Cmd]), {ok,Ch} = ssh_connection:session_channel(C, 10000), success = ssh_connection:exec(C, Ch, Cmd, 10000), - exec_result(C, Ch). + result_of_exec(C, Ch). -exec_result(C, Ch) -> - exec_result(C, Ch, undefined, <<>>). +result_of_exec(C, Ch) -> + result_of_exec(C, Ch, undefined, <<>>). -exec_result(C, Ch, ExitStatus, Acc) -> +result_of_exec(C, Ch, ExitStatus, Acc) -> receive {ssh_cm,C,{closed,Ch}} -> %%ct:log("CHAN ~p got *closed*",[Ch]), @@ -356,29 +496,37 @@ exec_result(C, Ch, ExitStatus, Acc) -> {ssh_cm,C,{exit_status,Ch,ExStat}} when ExitStatus == undefined -> %%ct:log("CHAN ~p got *exit status ~p*",[Ch,ExStat]), - exec_result(C, Ch, ExStat, Acc); + result_of_exec(C, Ch, ExStat, Acc); {ssh_cm,C,{data,Ch,_,Data}=_X} when ExitStatus == undefined -> %%ct:log("CHAN ~p got ~p",[Ch,_X]), - exec_result(C, Ch, ExitStatus, <<Acc/binary, Data/binary>>); + result_of_exec(C, Ch, ExitStatus, <<Acc/binary, Data/binary>>); _Other -> %%ct:log("OTHER: ~p",[_Other]), - exec_result(C, Ch, ExitStatus, Acc) + result_of_exec(C, Ch, ExitStatus, Acc) after 5000 -> - %%ct:log("NO MORE, received so far:~n~s",[Acc]), + ct:log("NO MORE, received so far:~n~s",[Acc]), {error, timeout} end. -chk_all_algos(CommonAlgs, Config, DoTestFun) when is_function(DoTestFun,2) -> +%%-------------------------------------------------------------------- +%% +%% Loop through all {Tag,Alg} pairs in CommonAlgs, call DoTestFun(Tag,Alg) which +%% returns one of {ok,C}, ok, or Other. +%% +%% The chk_all_algos returns 'ok' or {fail,FaledAlgosList} +%% + +chk_all_algos(FunctionName, CommonAlgs, Config, DoTestFun) when is_function(DoTestFun,2) -> ct:comment("~p algorithms",[length(CommonAlgs)]), %% Check each algorithm Failed = lists:foldl( fun({Tag,Alg}, FailedAlgos) -> - ct:log("Try ~p",[Alg]), + %% ct:log("Try ~p",[Alg]), case DoTestFun(Tag,Alg) of {ok,C} -> ssh:close(C), @@ -387,10 +535,10 @@ chk_all_algos(CommonAlgs, Config, DoTestFun) when is_function(DoTestFun,2) -> FailedAlgos; Other -> ct:log("FAILED! ~p ~p: ~p",[Tag,Alg,Other]), - [Alg|FailedAlgos] + [{Alg,Other}|FailedAlgos] end end, [], CommonAlgs), - ct:pal("~s", [format_result_table_use_all_algos(Config, CommonAlgs, Failed)]), + ct:pal("~s", [format_result_table_use_all_algos(FunctionName, Config, CommonAlgs, Failed)]), case Failed of [] -> ok; @@ -398,6 +546,41 @@ chk_all_algos(CommonAlgs, Config, DoTestFun) when is_function(DoTestFun,2) -> {fail, Failed} end. + + +%%%---------------------------------------------------------------- +%%% +%%% Call all Funs as Fun() which returns 'ok', {ok,C} or Other. +%%% do/1 returns 'ok' or the first encountered value that is not +%%% successful. +%%% + +do(Funs) -> + do(Funs, 1). + +do([Fun|Funs], N) -> + case Fun() of + ok -> + %% ct:log("Fun ~p ok",[N]), + do(Funs, N-1); + {ok,C} -> + %% ct:log("Fun ~p {ok,C}",[N]), + ssh:close(C), + do(Funs, N-1); + Other -> + ct:log("Fun ~p FAILED:~n~p",[N, Other]), + Other + end; + +do([], _) -> + %% ct:log("All Funs ok",[]), + ok. + +%%-------------------------------------------------------------------- +%% +%% Functions to set up local and remote host's and user's keys and directories +%% + setup_local_hostdir(KeyAlg, Config) -> setup_local_hostdir(KeyAlg, new_dir(Config), Config). setup_local_hostdir(KeyAlg, HostDir, Config) -> @@ -428,7 +611,7 @@ setup_remote_auth_keys_and_local_priv(KeyAlg, IP, Port, UserDir, Config) -> ok = file:write_file(DstFile++".pub", Publ), %% Remote auth_methods with public key {ok,Ch,Cc} = ssh_sftp:start_channel(IP, Port, [{user, ?USER }, - {password, ?PWD }, + {password, ?PASSWD }, {auth_methods, "password"}, {silently_accept_hosts,true}, {user_interaction,false} @@ -460,7 +643,7 @@ setup_remote_priv_and_local_auth_keys(KeyAlg, IP, Port, UserDir, Config) -> ok = file:write_file(AuthKeyFile, Publ), %% Remote private and public key {ok,Ch,Cc} = ssh_sftp:start_channel(IP, Port, [{user, ?USER }, - {password, ?PWD }, + {password, ?PASSWD }, {auth_methods, "password"}, {silently_accept_hosts,true}, {user_interaction,false} @@ -485,6 +668,7 @@ priv_pub_keys(KeySubDir, Type, Config, KeyAlg) -> {ok, {Priv,Publ}}. +%%%---------------- The default filenames src_filename(user, 'ssh-rsa' ) -> "id_rsa"; src_filename(user, 'rsa-sha2-256' ) -> "id_rsa"; src_filename(user, 'rsa-sha2-512' ) -> "id_rsa"; @@ -516,7 +700,11 @@ dst_filename(host, 'ecdsa-sha2-nistp384') -> "ssh_host_ecdsa_key"; dst_filename(host, 'ecdsa-sha2-nistp521') -> "ssh_host_ecdsa_key". -format_result_table_use_all_algos(Config, CommonAlgs, Failed) -> +%%-------------------------------------------------------------------- +%% +%% Format the result table for chk_all_algos/4 +%% +format_result_table_use_all_algos(FunctionName, Config, CommonAlgs, Failed) -> %% Write a nice table with the result AlgHead = 'Algorithm', AlgWidth = lists:max([length(atom_to_list(A)) || {_,A} <- CommonAlgs]), @@ -529,23 +717,25 @@ format_result_table_use_all_algos(Config, CommonAlgs, Failed) -> end, {io_lib:format('~s ~*s ~s~n', [Tag, -AlgWidth, A, - case lists:member(A,Failed) of - true -> "<<<< FAIL <<<<"; - false-> "(ok)" + case proplists:get_value(A,Failed) of + undefined -> "(ok)"; + Err -> io_lib:format("<<<< FAIL <<<< ~p",[Err]) end]), T} end, undefined, CommonAlgs), Vssh = proplists:get_value(ssh_version,Config,""), - Vssl = proplists:get_value(ssl_version,Config,""), - io_lib:format("~nResults, Peer versions: ~s and ~s~n" + io_lib:format("~nResults of ~p, Peer version: ~s~n~n" "Tag ~*s Result~n" "=====~*..=s=======~n~s" - ,[Vssh,Vssl, - -AlgWidth,AlgHead, + ,[FunctionName, Vssh, + -AlgWidth, AlgHead, AlgWidth, "", ResultTable]). - +%%-------------------------------------------------------------------- +%% +%% Docker handling: start_docker/1 and stop_docker/1 +%% start_docker(Ver) -> Cmnd = lists:concat(["docker run -itd --rm -p 1234 ",?DOCKER_PFX,":",Ver]), Id0 = os:cmd(Cmnd), @@ -572,6 +762,10 @@ is_docker_sha(L) -> (_) -> false end, L). +%%-------------------------------------------------------------------- +%% +%% Misc docker info functions + ip_port(Config) -> {_Ver,{IP,Port},_} = proplists:get_value(id,Config), {IP,Port}. @@ -590,6 +784,23 @@ ip(Id) -> {ok,IP} = inet:parse_address(IPstr), IP. +%%-------------------------------------------------------------------- +%% +%% Normalize the host returned from ssh_test_lib + +iptoa({0,0,0,0}) -> inet_parse:ntoa(host_ip()); +iptoa(IP) -> inet_parse:ntoa(IP). + +host_ip() -> + {ok,Name} = inet:gethostname(), + {ok,#hostent{h_addr_list = [IP|_]}} = inet_res:gethostbyname(Name), + IP. + +%%-------------------------------------------------------------------- +%% +%% Create a new fresh directory or clear an existing one +%% + new_dir(Config) -> PrivDir = proplists:get_value(priv_dir, Config), SubDirName = integer_to_list(erlang:system_time()), @@ -626,20 +837,34 @@ delete_all_contents(Dir) -> end end, Fs). +%%-------------------------------------------------------------------- +%% +%% Find the intersection of algoritms for otp ssh and the docker ssh. +%% Returns {ok, ServerHello, Server, ClientHello, Client} where Server are the algorithms common +%% with the docker server and analogous for Client. +%% +%% Client may be undefined if no usable client is found. +%% +%% Both Server and Client are lists of {Tag,AlgName}. +%% + common_algs(Config, IP, Port) -> case remote_server_algs(IP, Port) of - {ok, {RemoteHelloBin, RemoteServerKexInit}} -> + {ok, {ServerHello, RemoteServerKexInit}} -> + RemoteServerAlgs = kexint_msg2default_algorithms(RemoteServerKexInit), + Server = find_common_algs(RemoteServerAlgs, + use_algorithms(ServerHello)), + ct:log("Remote server:~n~p~n~p",[ServerHello, RemoteServerAlgs]), case remote_client_algs(Config) of - {ok,{_Hello,RemoteClientKexInit}} -> - RemoteServerAlgs = kexint_msg2default_algorithms(RemoteServerKexInit), - Server = find_common_algs(RemoteServerAlgs, - use_algorithms(RemoteHelloBin)), + {ok,{ClientHello,RemoteClientKexInit}} -> RemoteClientAlgs = kexint_msg2default_algorithms(RemoteClientKexInit), Client = find_common_algs(RemoteClientAlgs, - use_algorithms(RemoteHelloBin)), - ct:log("Docker server algorithms:~n ~p~n~nDocker client algorithms:~n ~p", - [RemoteServerAlgs,RemoteClientAlgs]), - {ok, Server, Client}; + use_algorithms(ClientHello)), + ct:log("Remote client:~n~p~n~p",[ClientHello, RemoteClientAlgs]), + {ok, ServerHello, Server, ClientHello, Client}; + {error,_} =TO -> + ct:log("Remote client algs can't be found: ~p",[TO]), + {ok, ServerHello, Server, undefined, undefined}; Other -> Other end; @@ -648,6 +873,24 @@ common_algs(Config, IP, Port) -> end. +chk_hellos(Hs, Str) -> + lists:foldl( + fun(H, Acc) -> + try binary:split(H, <<"-">>, [global]) + of + %% [<<"SSH">>,<<"2.0">>|_] -> + %% Acc; + [<<"SSH">>,OldVer = <<"1.",_/binary>>|_] -> + io_lib:format("~s, Old SSH ver ~s",[Acc,OldVer]); + _ -> + Acc + catch + _:_ -> + Acc + end + end, Str, Hs). + + find_common_algs(Remote, Local) -> [{T,V} || {T,Vs} <- ssh_test_lib:extract_algos( ssh_test_lib:intersection(Remote, @@ -685,12 +928,18 @@ kexint_msg2default_algorithms(#ssh_msg_kexinit{kex_algorithms = Kex, {server2client,ssh_test_lib:to_atoms(CompS2C)}]}]. - +%%-------------------------------------------------------------------- +%% +%% Find the algorithms supported by the remote server +%% +%% Connect with tcp to the server, send a hello and read the returned +%% server hello and kexinit message. +%% remote_server_algs(IP, Port) -> case try_gen_tcp_connect(IP, Port, 5) of {ok,S} -> ok = gen_tcp:send(S, "SSH-2.0-CheckAlgs\r\n"), - receive_hello(S, <<>>); + receive_hello(S); {error,Error} -> {error,Error} end. @@ -709,6 +958,13 @@ try_gen_tcp_connect(_, _, _) -> {error, "No contact"}. +%%-------------------------------------------------------------------- +%% +%% Find the algorithms supported by the remote client +%% +%% Set up a fake ssh server and make the remote client connect to it. Use +%% hello message and the kexinit message. +%% remote_client_algs(Config) -> Parent = self(), Ref = make_ref(), @@ -719,7 +975,7 @@ remote_client_algs(Config) -> Parent ! {addr,Ref,IP,Port}, {ok,S} = gen_tcp:accept(Sl), ok = gen_tcp:send(S, "SSH-2.0-CheckAlgs\r\n"), - Parent ! {Ref,receive_hello(S, <<>>)} + Parent ! {Ref,receive_hello(S)} end), receive {addr,Ref,IP,Port} -> @@ -732,14 +988,28 @@ remote_client_algs(Config) -> receive {Ref, Result} -> Result - after 15000 -> - {error, timeout2} + after 5000 -> + {error, {timeout,2}} end - after 15000 -> - {error, timeout1} + after 5000 -> + {error, {timeout,1}} end. +%%% Receive a few packets from the remote server or client and find what is supported: + +receive_hello(S) -> + try + receive_hello(S, <<>>) + of + Result -> + Result + catch + Class:Error -> + ST = erlang:get_stacktrace(), + {error, {Class,Error,ST}} + end. + receive_hello(S, Ack) -> %% The Ack is to collect bytes until the full message is received @@ -747,20 +1017,19 @@ receive_hello(S, Ack) -> {tcp, S, Bin0} when is_binary(Bin0) -> case binary:split(<<Ack/binary, Bin0/binary>>, [<<"\r\n">>,<<"\r">>,<<"\n">>]) of [Hello = <<"SSH-2.0-",_/binary>>, NextPacket] -> - ct:log("Got 2.0 hello (~p), ~p bytes to next msg",[Hello,size(NextPacket)]), + %% ct:log("Got 2.0 hello (~p), ~p bytes to next msg",[Hello,size(NextPacket)]), {ok, {Hello, receive_kexinit(S, NextPacket)}}; [Hello = <<"SSH-1.99-",_/binary>>, NextPacket] -> - ct:comment("Old SSH ~s",["1.99"]), - ct:log("Got 1.99 hello (~p), ~p bytes to next msg",[Hello,size(NextPacket)]), + %% ct:log("Got 1.99 hello (~p), ~p bytes to next msg",[Hello,size(NextPacket)]), {ok, {Hello, receive_kexinit(S, NextPacket)}}; [Bin] when size(Bin) < 256 -> - ct:log("Got part of hello (~p chars):~n~s~n~s",[size(Bin),Bin, - [io_lib:format('~2.16.0b ',[C]) - || C <- binary_to_list(Bin0) - ] - ]), + %% ct:log("Got part of hello (~p chars):~n~s~n~s",[size(Bin),Bin, + %% [io_lib:format('~2.16.0b ',[C]) + %% || C <- binary_to_list(Bin0) + %% ] + %% ]), receive_hello(S, Bin0); _ -> @@ -804,11 +1073,326 @@ receive_kexinit(S, Ack) -> throw(timeout) end. +%%%---------------------------------------------------------------- +%%% Test of sftp from the OpenSSH client side +%%% +sftp_tests_erl_server(Config, ServerIP, ServerPort, ServerRootDir, UserDir) -> + try + Cmnds = prepare_local_directory(ServerRootDir), + call_sftp_in_docker(Config, ServerIP, ServerPort, Cmnds, UserDir), + check_local_directory(ServerRootDir) + catch + Class:Error -> + ST = erlang:get_stacktrace(), + {error, {Class,Error,ST}} + end. -host_ip() -> - {ok,Name} = inet:gethostname(), - {ok,#hostent{h_addr_list = [IP|_]}} = inet_res:gethostbyname(Name), - IP. +prepare_local_directory(ServerRootDir) -> + file:write_file(filename:join(ServerRootDir,"tst1"), + <<"Some test text">> + ), + ["get tst1", + "put tst1 tst2", + "put tst1 tst3", + "rename tst1 ex_tst1", + "rm tst3", + "mkdir mydir", + "cd mydir", + "put tst1 file_1", + "put tst1 unreadable_file", + "chmod 222 unreadable_file", + "exit"]. + +check_local_directory(ServerRootDir) -> + case lists:sort(ok(file:list_dir(ServerRootDir)) -- [".",".."]) of + ["ex_tst1","mydir","tst2"] -> + {ok,Expect} = file:read_file(filename:join(ServerRootDir,"ex_tst1")), + case file:read_file(filename:join(ServerRootDir,"tst2")) of + {ok,Expect} -> + case lists:sort(ok(file:list_dir(filename:join(ServerRootDir,"mydir"))) -- [".",".."]) of + ["file_1","unreadable_file"] -> + case file:read_file(filename:join([ServerRootDir,"mydir","file_1"])) of + {ok,Expect} -> + case file:read_file(filename:join([ServerRootDir,"mydir","unreadable_file"])) of + {error,_} -> + ok; + {ok,_} -> + {error, {could_read_unreadable,"mydir/unreadable_file"}} + end; + {ok,Other} -> + ct:log("file_1:~n~s~nExpected:~n~s",[Other,Expect]), + {error, {bad_contents_in_file,"mydir/file_1"}} + end; + Other -> + ct:log("Directory ~s~n~p",[filename:join(ServerRootDir,"mydir"),Other]), + {error,{bad_dir_contents,"mydir"}} + end; + {ok,Other} -> + ct:log("tst2:~n~s~nExpected:~n~s",[Other,Expect]), + {error, {bad_contents_in_file,"tst2"}} + end; + ["tst1"] -> + {error,{missing_file,"tst2"}}; + Other -> + ct:log("Directory ~s~n~p",[ServerRootDir,Other]), + {error,{bad_dir_contents,"/"}} + end. + +call_sftp_in_docker(Config, ServerIP, ServerPort, Cmnds, UserDir) -> + {DockerIP,DockerPort} = ip_port(Config), + {ok,C} = ssh:connect(DockerIP, DockerPort, + [{user,?USER}, + {password,?PASSWD}, + {user_dir, UserDir}, + {silently_accept_hosts,true}, + {user_interaction,false} + ]), + + %% Make commands for "expect" in the docker: + PreExpectCmnds = ["spawn /buildroot/ssh/bin/sftp -oPort="++integer_to_list(ServerPort)++ + " -oCheckHostIP=no -oStrictHostKeyChecking=no " ++ + iptoa(ServerIP)++"\n" + ], + PostExpectCmnds= [], + ExpectCmnds = + PreExpectCmnds ++ + ["expect \"sftp>\" {send \""++Cmnd++"\n\"}\n" || Cmnd <- Cmnds] ++ + PostExpectCmnds, + + %% Make an commands file in the docker + {ok,Ch} = ssh_sftp:start_channel(C, [{timeout,10000}]), + ok = ssh_sftp:write_file(Ch, "commands", erlang:iolist_to_binary(ExpectCmnds)), + ok = ssh_sftp:stop_channel(Ch), + + %% Call expect in the docker + {ok, Ch1} = ssh_connection:session_channel(C, infinity), + Kex1 = renegotiate_test(init, C), + success = ssh_connection:exec(C, Ch1, "expect commands", infinity), + + renegotiate_test(Kex1, C), + recv_log_msgs(C, Ch1), + + %% Done. + ssh:close(C). + +recv_log_msgs(C, Ch) -> + receive + {ssh_cm,C,{closed,Ch}} -> + %% ct:log("Channel closed ~p",[{closed,1}]), + ok; + {ssh_cm,C,{data,Ch,1,Msg}} -> + ct:log("*** ERROR from docker:~n~s",[Msg]), + recv_log_msgs(C, Ch); + {ssh_cm,C,_Msg} -> + %% ct:log("Got ~p",[_Msg]), + recv_log_msgs(C, Ch) + end. +%%%---------------------------------------------------------------- +%%%---------------------------------------------------------------- +%%% +%%% Tests from the Erlang client side +%%% +%%%---------------------------------------------------------------- +%%%---------------------------------------------------------------- +test_erl_client_reneg({ok,C}, Spec) -> + %% Start the test processes on the connection C: + Parent = self(), + Pids = [spawn( + fun() -> + Parent ! {self(), TestType, Id, one_test_erl_client(TestType,Id,C)} + end + ) + || {TestType,N} <- Spec, + Id <- lists:seq(1,N)], + + Kex1 = renegotiate_test(init, C), + + %% Collect the results: + case lists:filter( + fun(R) -> R=/=ok end, + [receive + {Pid,_TestType,_Id,ok} -> + %% ct:log("Test ~p:~p passed!", [_TestType,_Id]), + ok; + {Pid,TestType,Id,OtherResult} -> + ct:log("~p:~p ~p ~p~n~p",[?MODULE,?LINE,TestType,Id,OtherResult]), + {error,TestType,Id} + end || Pid <- Pids]) + of + [] -> + renegotiate_test(Kex1, C), + {ok,C}; + Other -> + renegotiate_test(Kex1, C), + Other + end; + +test_erl_client_reneg(Error, _) -> + Error. + + +one_test_erl_client(exec, Id, C) -> + {ok, Ch} = ssh_connection:session_channel(C, infinity), + success = ssh_connection:exec(C, Ch, "echo Hi there", 5000), + case loop_until(fun({eof,_}) -> true; + (_ ) -> false + end, + fun(Acc) -> + receive + {ssh_cm, C, {eof,Ch}} -> + {eof,Acc}; + {ssh_cm, C, {data,Ch,0,B}} when is_binary(B) -> + <<Acc/binary, B/binary>> + end + end, + <<>>) of + {eof,<<"Hi there\n">>} -> + ok; + Other -> + ct:pal("exec Got other ~p", [Other]), + {error, {exec,Id,bad_msg,Other,undefined}} + end; + +one_test_erl_client(no_subsyst, Id, C) -> + {ok, Ch} = ssh_connection:session_channel(C, infinity), + case ssh_connection:subsystem(C, Ch, "foo", infinity) of + failure -> + ok; + Other -> + ct:pal("no_subsyst Got other ~p", [Other]), + {error, {no_subsyst,Id,bad_ret,Other,undefined}} + end; + +one_test_erl_client(setenv, Id, C) -> + {ok, Ch} = ssh_connection:session_channel(C, infinity), + Var = "ENV_TEST", + Value = lists:concat(["env_test_",Id,"_",erlang:system_time()]), + Env = case ssh_connection:setenv(C, Ch, Var, Value, infinity) of + success -> binary_to_list(Value++"\n"); + failure -> <<"\n">> + end, + success = ssh_connection:exec(C, Ch, "echo $"++Var, 5000), + case loop_until(fun({eof,_}) -> true; + (_ ) -> false + end, + fun(Acc) -> + receive + {ssh_cm, C, {eof,Ch}} -> + {eof,Acc}; + {ssh_cm, C, {data,Ch,0,B}} when is_binary(B) -> + <<Acc/binary, B/binary>> + end + end, + <<>>) of + {eof,Env} -> + ok; + Other -> + ct:pal("setenv Got other ~p", [Other]), + {error, {setenv,Id,bad_msg,Other,undefined}} + end; + +one_test_erl_client(SFTP, Id, C) when SFTP==sftp ; SFTP==sftp_async -> + try + {ok,Ch} = ssh_sftp:start_channel(C, [{timeout,10000}]), + %% A new fresh name of a new file tree: + RootDir = lists:concat(["r_",Id,"_",erlang:system_time()]), + %% Check that it does not exist: + false = lists:member(RootDir, ok(ssh_sftp:list_dir(Ch, "."))), + %% Create it: + ok = ssh_sftp:make_dir(Ch, RootDir), + {ok, #file_info{type=directory, access=read_write}} = ssh_sftp:read_file_info(Ch, RootDir), + R = do_sftp_tests_erl_client(SFTP, C, Ch, Id, RootDir), + catch ssh_sftp:stop_channel(Ch), + R + catch + Class:Error -> + ST = erlang:get_stacktrace(), + {error, {SFTP,Id,Class,Error,ST}} + end. + + + +do_sftp_tests_erl_client(sftp_async, _C, Ch, _Id, RootDir) -> + FileName1 = "boring_name", + F1 = filename:join(RootDir, FileName1), + %% Open a new handle and start writing: + {ok,Handle1} = ssh_sftp:open(Ch, F1, [write,binary]), + {async,Aref1} = ssh_sftp:awrite(Ch, Handle1, <<0:250000/unsigned-unit:8>>), + wait_for_async_result(Aref1); + +do_sftp_tests_erl_client(sftp, _C, Ch, _Id, RootDir) -> + FileName0 = "f0", + F0 = filename:join(RootDir, FileName0), + + %% Create and write a file: + ok = ssh_sftp:write_file(Ch, + F0 = filename:join(RootDir, FileName0), + Data0 = mkbin(1234,240)), + {ok,Data0} = ssh_sftp:read_file(Ch, F0), + {ok, #file_info{type=regular, access=read_write, size=1234}} = ssh_sftp:read_file_info(Ch, F0), + + %% Re-write: + {ok,Handle0} = ssh_sftp:open(Ch, F0, [write,read,binary]), + ok = ssh_sftp:pwrite(Ch, Handle0, 16, Data0_1=mkbin(10,255)), + + <<B1:16/binary, _:10/binary, B2:(1234-26)/binary>> = Data0, + FileContents = <<B1:16/binary, Data0_1:10/binary, B2:(1234-26)/binary>>, + + <<_:1/binary, Part:25/binary, _/binary>> = FileContents, + {ok, Part} = ssh_sftp:pread(Ch, Handle0, 1, 25), + + %% Check: + {ok, FileContents} = ssh_sftp:pread(Ch, Handle0, 0, 1234), + ok = ssh_sftp:close(Ch, Handle0), + + %% Check in another way: + {ok, FileContents} = ssh_sftp:read_file(Ch, F0), + + %% Remove write access rights and check that it can't be written: + ok = ssh_sftp:write_file_info(Ch, F0, #file_info{mode=8#400}), %read}), + {ok, #file_info{type=regular, access=read}} = ssh_sftp:read_file_info(Ch, F0), + {error,permission_denied} = ssh_sftp:write_file(Ch, F0, mkbin(10,14)), + + %% Test deletion of file and dir: + [FileName0] = ok(ssh_sftp:list_dir(Ch, RootDir)) -- [".", ".."], + ok = ssh_sftp:delete(Ch, F0), + [] = ok(ssh_sftp:list_dir(Ch, RootDir)) -- [".", ".."], + ok = ssh_sftp:del_dir(Ch, RootDir), + false = lists:member(RootDir, ok(ssh_sftp:list_dir(Ch, "."))), + ok. + + +wait_for_async_result(Aref) -> + receive + {async_reply, Aref, Result} -> + Result + after + 60000 -> + timeout + end. + + +mkbin(Size, Byte) -> + list_to_binary(lists:duplicate(Size,Byte)). + +ok({ok,X}) -> X. + +%%%---------------------------------------------------------------- +renegotiate_test(init, ConnectionRef) -> + Kex1 = ssh_test_lib:get_kex_init(ConnectionRef), + ssh_connection_handler:renegotiate(ConnectionRef), + %%ct:log("Renegotiate test initiated!",[]), + Kex1; + +renegotiate_test(Kex1, ConnectionRef) -> + case ssh_test_lib:get_kex_init(ConnectionRef) of + Kex1 -> + ct:log("Renegotiate test failed, Kex1 == Kex2!",[]), + error(renegotiate_failed); + _ -> + %% ct:log("Renegotiate test passed!",[]), + ok + end. diff --git a/lib/ssh/test/ssh_compat_SUITE_data/build_scripts/create-dropbear-ssh b/lib/ssh/test/ssh_compat_SUITE_data/build_scripts/create-dropbear-ssh new file mode 100755 index 0000000000..85973081d0 --- /dev/null +++ b/lib/ssh/test/ssh_compat_SUITE_data/build_scripts/create-dropbear-ssh @@ -0,0 +1,28 @@ +#!/bin/sh + +# ./create-dropbear-ssh + +# This way of fetching the tar-file separate from the docker commands makes +# http-proxy handling way easier. The wget command handles the $https_proxy +# variable while the docker command must have /etc/docker/something changed +# and the docker server restarted. That is not possible without root access. + +# Make a Dockerfile. This method simplifies env variable handling considerably: +cat - > TempDockerFile <<EOF + + FROM ubuntubuildbase + + WORKDIR /buildroot + + RUN apt-get -y update + RUN apt-get -y upgrade + RUN apt-get -y install openssh-sftp-server +%% RUN echo 81 | apt-get -y install dropbear + +EOF + +# Build the image: +docker build -t ssh_compat_suite-ssh-dropbear -f ./TempDockerFile . + +# Cleaning +rm -fr ./TempDockerFile $TMP diff --git a/lib/ssh/test/ssh_compat_SUITE_data/build_scripts/create-dropbear-ssh-run b/lib/ssh/test/ssh_compat_SUITE_data/build_scripts/create-dropbear-ssh-run new file mode 100755 index 0000000000..d98c0cfaa3 --- /dev/null +++ b/lib/ssh/test/ssh_compat_SUITE_data/build_scripts/create-dropbear-ssh-run @@ -0,0 +1,27 @@ +#!/bin/sh + +# ./create-dropbear-ssh-run + +VER=v2016.72 + +# This way of fetching the tar-file separate from the docker commands makes +# http-proxy handling way easier. The wget command handles the $https_proxy +# variable while the docker command must have /etc/docker/something changed +# and the docker server restarted. That is not possible without root access. + +# Make a Dockerfile. This method simplifies env variable handling considerably: +cat - > TempDockerFile <<EOF + + FROM ssh_compat_suite-ssh-dropbear-installed:${VER} + + WORKDIR /buildroot + + CMD dropbear -F -p 1234 + +EOF + +# Build the image: +docker build -t ssh_compat_suite-ssh:dropbear${VER} -f ./TempDockerFile . + +# Cleaning +rm -fr ./TempDockerFile $TMP diff --git a/lib/ssh/test/ssh_compat_SUITE_data/build_scripts/create-ssh-image b/lib/ssh/test/ssh_compat_SUITE_data/build_scripts/create-ssh-image index 983c57b18b..2e08408841 100755 --- a/lib/ssh/test/ssh_compat_SUITE_data/build_scripts/create-ssh-image +++ b/lib/ssh/test/ssh_compat_SUITE_data/build_scripts/create-ssh-image @@ -47,7 +47,8 @@ cat - > TempDockerFile <<EOF RUN ./configure --without-pie \ --prefix=/buildroot/ssh \ --with-ssl-dir=/buildroot/ssl \ - --with-pam + --with-pam \ + LDFLAGS=-Wl,-R/buildroot/ssl/lib RUN make RUN make install RUN echo UsePAM yes >> /buildroot/ssh/etc/sshd_config diff --git a/lib/ssh/test/ssh_compat_SUITE_data/build_scripts/create-ssl-image b/lib/ssh/test/ssh_compat_SUITE_data/build_scripts/create-ssl-image index 66f8358b8a..4ab2a8bddc 100755 --- a/lib/ssh/test/ssh_compat_SUITE_data/build_scripts/create-ssl-image +++ b/lib/ssh/test/ssh_compat_SUITE_data/build_scripts/create-ssl-image @@ -23,6 +23,16 @@ case "$1" in ;; esac +case $1$2 in + openssl0.9.8[a-l]) + CONFIG_FLAGS=no-asm + ;; + *) + CONFIG_FLAGS= + ;; +esac + + # This way of fetching the tar-file separate from the docker commands makes # http-proxy handling way easier. The wget command handles the $https_proxy # variable while the docker command must have /etc/docker/something changed @@ -42,10 +52,10 @@ cat - > TempDockerFile <<EOF WORKDIR ${FAM}-${VER} - RUN ./config --prefix=/buildroot/ssl + RUN ./config --prefix=/buildroot/ssl ${CONFIG_FLAGS} RUN make - RUN make install + RUN make install_sw RUN echo Built ${FAM}-${VER} EOF diff --git a/lib/ssh/test/ssh_compat_SUITE_data/build_scripts/create_all b/lib/ssh/test/ssh_compat_SUITE_data/build_scripts/create_all index 16b9c21d9f..0dcf8cb570 100755 --- a/lib/ssh/test/ssh_compat_SUITE_data/build_scripts/create_all +++ b/lib/ssh/test/ssh_compat_SUITE_data/build_scripts/create_all @@ -3,19 +3,21 @@ UBUNTU_VERSION=16.04 SSH_SSL_VERSIONS=(\ - openssh 4.4p1 openssl 0.9.8zh \ - openssh 4.5p1 openssl 0.9.8zh \ - openssh 5.0p1 openssl 0.9.8zh \ - openssh 6.2p2 openssl 0.9.8zh \ - openssh 6.3p1 openssl 0.9.8zh \ - \ - openssh 7.1p1 openssl 1.0.0t \ - \ - openssh 7.1p1 openssl 1.0.1p \ - \ - openssh 6.6p1 openssl 1.0.2n \ - openssh 7.1p1 openssl 1.0.2n \ - openssh 7.6p1 openssl 1.0.2n \ + openssh 4.4p1 openssl 0.9.8c \ + openssh 4.5p1 openssl 0.9.8m \ + openssh 5.0p1 openssl 0.9.8za \ + openssh 6.2p2 openssl 0.9.8c \ + openssh 6.3p1 openssl 0.9.8zh \ + \ + openssh 7.1p1 openssl 1.0.0a \ + \ + openssh 7.1p1 openssl 1.0.1p \ + \ + openssh 6.6p1 openssl 1.0.2n \ + openssh 7.1p1 openssl 1.0.2n \ + openssh 7.6p1 openssl 1.0.2n \ + \ + openssh 7.6p1 libressl 2.6.4 \ ) if [ "x$1" == "x-b" ] diff --git a/lib/ssh/test/ssh_engine_SUITE.erl b/lib/ssh/test/ssh_engine_SUITE.erl index daf93891e9..c131a70973 100644 --- a/lib/ssh/test/ssh_engine_SUITE.erl +++ b/lib/ssh/test/ssh_engine_SUITE.erl @@ -55,16 +55,22 @@ basic_tests() -> init_per_suite(Config) -> ssh:start(), ?CHECK_CRYPTO( - case load_engine() of - {ok,E} -> - [{engine,E}|Config]; - {error, notsup} -> - {skip, "Engine not supported on this OpenSSL version"}; - {error, bad_engine_id} -> - {skip, "Dynamic Engine not supported"}; - Other -> - ct:log("Engine load failed: ~p",[Other]), - {fail, "Engine load failed"} + case crypto:info_lib() of + [{_,_, <<"OpenSSL 1.0.1s-freebsd 1 Mar 2016">>}] -> + {skip, "Strange Engine stuff"}; + + _ -> + case load_engine() of + {ok,E} -> + [{engine,E}|Config]; + {error, notsup} -> + {skip, "Engine not supported on this OpenSSL version"}; + {error, bad_engine_id} -> + {skip, "Dynamic Engine not supported"}; + Other -> + ct:log("Engine load failed: ~p",[Other]), + {fail, "Engine load failed"} + end end ). diff --git a/lib/ssh/test/ssh_options_SUITE.erl b/lib/ssh/test/ssh_options_SUITE.erl index 144ec7f8fd..bb09ca4c8b 100644 --- a/lib/ssh/test/ssh_options_SUITE.erl +++ b/lib/ssh/test/ssh_options_SUITE.erl @@ -70,7 +70,8 @@ hostkey_fingerprint_check_sha256/1, hostkey_fingerprint_check_sha384/1, hostkey_fingerprint_check_sha512/1, - hostkey_fingerprint_check_list/1 + hostkey_fingerprint_check_list/1, + save_accepted_host_option/1 ]). %%% Common test callbacks @@ -124,6 +125,7 @@ all() -> id_string_own_string_server, id_string_own_string_server_trail_space, id_string_random_server, + save_accepted_host_option, {group, hardening_tests} ]. @@ -211,7 +213,8 @@ init_per_testcase(_TestCase, Config) -> end_per_testcase(TestCase, Config) when TestCase == server_password_option; TestCase == server_userpassword_option; TestCase == server_pwdfun_option; - TestCase == server_pwdfun_4_option -> + TestCase == server_pwdfun_4_option ; + TestCase == save_accepted_host_option -> UserDir = filename:join(proplists:get_value(priv_dir, Config), nopubkey), ssh_test_lib:del_dirs(UserDir), end_per_testcase(Config); @@ -219,7 +222,9 @@ end_per_testcase(_TestCase, Config) -> end_per_testcase(Config). end_per_testcase(_Config) -> + ct:log("~p: Before ssh:stop()",[?FUNCTION_NAME]), ssh:stop(), + ct:log("~p: After ssh:stop()",[?FUNCTION_NAME]), ok. %%-------------------------------------------------------------------- @@ -1314,6 +1319,36 @@ try_to_connect(Connect, Host, Port, Pid, Tref, N) -> end. %%-------------------------------------------------------------------- +save_accepted_host_option(Config) -> + PrivDir = proplists:get_value(priv_dir, Config), + UserDir = filename:join(PrivDir, nopubkey), % to make sure we don't use public-key-auth + KnownHosts = filename:join(UserDir, "known_hosts"), + file:make_dir(UserDir), + file:delete(KnownHosts), + SysDir = proplists:get_value(data_dir, Config), + {Pid, Host, Port} = ssh_test_lib:daemon([{system_dir, SysDir}, + {user_dir, UserDir}, + {user_passwords, [{"vego", "morot"}]} + ]), + {error,enoent} = file:read_file(KnownHosts), + + {ok,_C1} = ssh:connect(Host, Port, [{silently_accept_hosts, true}, + {user, "vego"}, + {password, "morot"}, + {user_interaction, false}, + {save_accepted_host, false}, + {user_dir, UserDir}]), + {error,enoent} = file:read_file(KnownHosts), + + {ok,_C2} = ssh:connect(Host, Port, [{silently_accept_hosts, true}, + {user, "vego"}, + {password, "morot"}, + {user_interaction, false}, + {user_dir, UserDir}]), + {ok,_} = file:read_file(KnownHosts), + ssh:stop_daemon(Pid). + +%%-------------------------------------------------------------------- %% Internal functions ------------------------------------------------ %%-------------------------------------------------------------------- diff --git a/lib/ssh/test/ssh_sup_SUITE.erl b/lib/ssh/test/ssh_sup_SUITE.erl index 3920a1c592..d453a2e143 100644 --- a/lib/ssh/test/ssh_sup_SUITE.erl +++ b/lib/ssh/test/ssh_sup_SUITE.erl @@ -42,7 +42,9 @@ suite() -> all() -> [default_tree, sshc_subtree, sshd_subtree, sshd_subtree_profile, - killed_acceptor_restarts]. + killed_acceptor_restarts, + shell_channel_tree + ]. groups() -> []. @@ -246,6 +248,98 @@ killed_acceptor_restarts(Config) -> {error,closed} = ssh:connection_info(C2,[client_version]). %%------------------------------------------------------------------------- +shell_channel_tree(Config) -> + PrivDir = proplists:get_value(priv_dir, Config), + UserDir = filename:join(PrivDir, nopubkey), % to make sure we don't use public-key-auth + file:make_dir(UserDir), + SysDir = proplists:get_value(data_dir, Config), + TimeoutShell = + fun() -> + io:format("TimeoutShell started!~n",[]), + timer:sleep(5000), + ct:pal("~p TIMEOUT!",[self()]) + end, + {Daemon, Host, Port} = ssh_test_lib:daemon([{system_dir, SysDir}, + {user_dir, UserDir}, + {password, "morot"}, + {shell, fun(_User) -> + spawn(TimeoutShell) + end + } + ]), + ConnectionRef = ssh_test_lib:connect(Host, Port, [{silently_accept_hosts, true}, + {user, "foo"}, + {password, "morot"}, + {user_interaction, true}, + {user_dir, UserDir}]), + + [ChannelSup|_] = Sups0 = chk_empty_con_daemon(Daemon), + + {ok, ChannelId0} = ssh_connection:session_channel(ConnectionRef, infinity), + ok = ssh_connection:shell(ConnectionRef,ChannelId0), + + ?wait_match([{_, GroupPid,worker,[ssh_channel]}], + supervisor:which_children(ChannelSup), + [GroupPid]), + {links,GroupLinks} = erlang:process_info(GroupPid, links), + [ShellPid] = GroupLinks--[ChannelSup], + ct:pal("GroupPid = ~p, ShellPid = ~p",[GroupPid,ShellPid]), + + receive + {ssh_cm,ConnectionRef, {data, ChannelId0, 0, <<"TimeoutShell started!\r\n">>}} -> + receive + %%---- wait for the subsystem to terminate + {ssh_cm,ConnectionRef,{closed,ChannelId0}} -> + ct:pal("Subsystem terminated",[]), + case {chk_empty_con_daemon(Daemon), + process_info(GroupPid), + process_info(ShellPid)} of + {Sups0, undefined, undefined} -> + %% SUCCESS + ssh:stop_daemon(Daemon); + {Sups0, _, undefined} -> + ssh:stop_daemon(Daemon), + ct:fail("Group proc lives!"); + {Sups0, undefined, _} -> + ssh:stop_daemon(Daemon), + ct:fail("Shell proc lives!"); + _ -> + ssh:stop_daemon(Daemon), + ct:fail("Sup tree changed!") + end + after 10000 -> + ssh:close(ConnectionRef), + ssh:stop_daemon(Daemon), + ct:fail("CLI Timeout") + end + after 10000 -> + ssh:close(ConnectionRef), + ssh:stop_daemon(Daemon), + ct:fail("CLI Timeout") + end. + + +chk_empty_con_daemon(Daemon) -> + ?wait_match([{_,SubSysSup, supervisor,[ssh_subsystem_sup]}, + {{ssh_acceptor_sup,_,_,_}, AccSup, supervisor,[ssh_acceptor_sup]}], + supervisor:which_children(Daemon), + [SubSysSup,AccSup]), + ?wait_match([{{server,ssh_connection_sup, _,_}, + ConnectionSup, supervisor, + [ssh_connection_sup]}, + {{server,ssh_channel_sup,_ ,_}, + ChannelSup,supervisor, + [ssh_channel_sup]}], + supervisor:which_children(SubSysSup), + [ConnectionSup,ChannelSup]), + ?wait_match([{{ssh_acceptor_sup,_,_,_},_,worker,[ssh_acceptor]}], + supervisor:which_children(AccSup)), + ?wait_match([{_, _, worker,[ssh_connection_handler]}], + supervisor:which_children(ConnectionSup)), + ?wait_match([], supervisor:which_children(ChannelSup)), + [ChannelSup, ConnectionSup, SubSysSup, AccSup]. + +%%------------------------------------------------------------------------- %% Help functions %%------------------------------------------------------------------------- check_sshd_system_tree(Daemon, Config) -> diff --git a/lib/ssh/test/ssh_test_lib.erl b/lib/ssh/test/ssh_test_lib.erl index 2d7bf75847..f97c3b1352 100644 --- a/lib/ssh/test/ssh_test_lib.erl +++ b/lib/ssh/test/ssh_test_lib.erl @@ -53,7 +53,7 @@ daemon(Host, Options) -> daemon(Host, Port, Options) -> - ct:log("~p:~p Calling ssh:daemon(~p, ~p, ~p)",[?MODULE,?LINE,Host,Port,Options]), + %% ct:log("~p:~p Calling ssh:daemon(~p, ~p, ~p)",[?MODULE,?LINE,Host,Port,Options]), case ssh:daemon(Host, Port, Options) of {ok, Pid} -> {ok,L} = ssh:daemon_info(Pid), @@ -199,15 +199,17 @@ init_io_server(TestCase) -> loop_io_server(TestCase, Buff0) -> receive - {input, TestCase, Line} -> + {input, TestCase, Line} = _INP -> + %%ct:log("io_server ~p:~p ~p got ~p",[?MODULE,?LINE,self(),_INP]), loop_io_server(TestCase, Buff0 ++ [Line]); - {io_request, From, ReplyAs, Request} -> + {io_request, From, ReplyAs, Request} = _REQ-> + %%ct:log("io_server ~p:~p ~p got ~p",[?MODULE,?LINE,self(),_REQ]), {ok, Reply, Buff} = io_request(Request, TestCase, From, ReplyAs, Buff0), io_reply(From, ReplyAs, Reply), loop_io_server(TestCase, Buff); {'EXIT',_, _} = _Exit -> -%% ct:log("ssh_test_lib:loop_io_server/2 got ~p",[_Exit]), + ct:log("ssh_test_lib:loop_io_server/2 got ~p",[_Exit]), ok after 30000 -> ct:fail("timeout ~p:~p",[?MODULE,?LINE]) diff --git a/lib/ssh/test/ssh_to_openssh_SUITE.erl b/lib/ssh/test/ssh_to_openssh_SUITE.erl index b20764ce47..9df404d7ed 100644 --- a/lib/ssh/test/ssh_to_openssh_SUITE.erl +++ b/lib/ssh/test/ssh_to_openssh_SUITE.erl @@ -48,19 +48,9 @@ all() -> end. groups() -> - [{erlang_client, [], [erlang_shell_client_openssh_server, - erlang_client_openssh_server_exec_compressed, - erlang_client_openssh_server_setenv, - erlang_client_openssh_server_publickey_dsa, - erlang_client_openssh_server_publickey_rsa, - erlang_client_openssh_server_password, - erlang_client_openssh_server_kexs, - erlang_client_openssh_server_nonexistent_subsystem, - erlang_client_openssh_server_renegotiate + [{erlang_client, [], [erlang_shell_client_openssh_server ]}, - {erlang_server, [], [erlang_server_openssh_client_public_key_dsa, - erlang_server_openssh_client_public_key_rsa, - erlang_server_openssh_client_renegotiate + {erlang_server, [], [erlang_server_openssh_client_renegotiate ]} ]. @@ -100,15 +90,6 @@ end_per_group(_, Config) -> Config. -init_per_testcase(erlang_server_openssh_client_public_key_dsa, Config) -> - chk_key(sshc, 'ssh-dss', ".ssh/id_dsa", Config); -init_per_testcase(erlang_server_openssh_client_public_key_rsa, Config) -> - chk_key(sshc, 'ssh-rsa', ".ssh/id_rsa", Config); -init_per_testcase(erlang_client_openssh_server_publickey_dsa, Config) -> - chk_key(sshd, 'ssh-dss', ".ssh/id_dsa", Config); -init_per_testcase(erlang_client_openssh_server_publickey_rsa, Config) -> - chk_key(sshd, 'ssh-rsa', ".ssh/id_rsa", Config); - init_per_testcase(erlang_server_openssh_client_renegotiate, Config) -> case os:type() of {unix,_} -> ssh:start(), Config; @@ -122,27 +103,6 @@ end_per_testcase(_TestCase, _Config) -> ssh:stop(), ok. - -chk_key(Pgm, Name, File, Config) -> - case ssh_test_lib:openssh_supports(Pgm, public_key, Name) of - false -> - {skip,lists:concat(["openssh client does not support ",Name])}; - true -> - {ok,[[Home]]} = init:get_argument(home), - KeyFile = filename:join(Home, File), - case file:read_file(KeyFile) of - {ok, Pem} -> - case public_key:pem_decode(Pem) of - [{_,_, not_encrypted}] -> - init_per_testcase('__default__',Config); - _ -> - {skip, {error, "Has pass phrase can not be used by automated test case"}} - end; - _ -> - {skip, lists:concat(["no ~/",File])} - end - end. - %%-------------------------------------------------------------------- %% Test Cases -------------------------------------------------------- %%-------------------------------------------------------------------- @@ -160,219 +120,6 @@ erlang_shell_client_openssh_server(Config) when is_list(Config) -> receive_logout(), receive_normal_exit(Shell). -%-------------------------------------------------------------------- -erlang_client_openssh_server_exec() -> - [{doc, "Test api function ssh_connection:exec"}]. - -erlang_client_openssh_server_exec(Config) when is_list(Config) -> - ConnectionRef = ssh_test_lib:connect(?SSH_DEFAULT_PORT, [{silently_accept_hosts, true}, - {user_interaction, false}]), - {ok, ChannelId0} = ssh_connection:session_channel(ConnectionRef, infinity), - success = ssh_connection:exec(ConnectionRef, ChannelId0, - "echo testing", infinity), - Data0 = {ssh_cm, ConnectionRef, {data, ChannelId0, 0, <<"testing\n">>}}, - case ssh_test_lib:receive_exec_result(Data0) of - expected -> - ssh_test_lib:receive_exec_end(ConnectionRef, ChannelId0); - {unexpected_msg,{ssh_cm, ConnectionRef, {exit_status, ChannelId0, 0}} - = ExitStatus0} -> - ct:log("0: Collected data ~p", [ExitStatus0]), - ssh_test_lib:receive_exec_result(Data0, - ConnectionRef, ChannelId0); - Other0 -> - ct:fail(Other0) - end, - - {ok, ChannelId1} = ssh_connection:session_channel(ConnectionRef, infinity), - success = ssh_connection:exec(ConnectionRef, ChannelId1, - "echo testing1", infinity), - Data1 = {ssh_cm, ConnectionRef, {data, ChannelId1, 0, <<"testing1\n">>}}, - case ssh_test_lib:receive_exec_result(Data1) of - expected -> - ssh_test_lib:receive_exec_end(ConnectionRef, ChannelId1); - {unexpected_msg,{ssh_cm, ConnectionRef, {exit_status, ChannelId1, 0}} - = ExitStatus1} -> - ct:log("0: Collected data ~p", [ExitStatus1]), - ssh_test_lib:receive_exec_result(Data1, - ConnectionRef, ChannelId1); - Other1 -> - ct:fail(Other1) - end. - -%%-------------------------------------------------------------------- -erlang_client_openssh_server_exec_compressed() -> - [{doc, "Test that compression option works"}]. - -erlang_client_openssh_server_exec_compressed(Config) when is_list(Config) -> - CompressAlgs = [zlib, '[email protected]',none], - case ssh_test_lib:ssh_supports(CompressAlgs, compression) of - {false,L} -> - {skip, io_lib:format("~p compression is not supported",[L])}; - - true -> - ConnectionRef = ssh_test_lib:connect(?SSH_DEFAULT_PORT, [{silently_accept_hosts, true}, - {user_interaction, false}, - {preferred_algorithms, - [{compression,CompressAlgs}]}]), - {ok, ChannelId} = ssh_connection:session_channel(ConnectionRef, infinity), - success = ssh_connection:exec(ConnectionRef, ChannelId, - "echo testing", infinity), - Data = {ssh_cm, ConnectionRef, {data, ChannelId, 0, <<"testing\n">>}}, - case ssh_test_lib:receive_exec_result(Data) of - expected -> - ssh_test_lib:receive_exec_end(ConnectionRef, ChannelId); - {unexpected_msg,{ssh_cm, ConnectionRef, - {exit_status, ChannelId, 0}} = ExitStatus} -> - ct:log("0: Collected data ~p", [ExitStatus]), - ssh_test_lib:receive_exec_result(Data, ConnectionRef, ChannelId); - Other -> - ct:fail(Other) - end - end. - -%%-------------------------------------------------------------------- -erlang_client_openssh_server_kexs() -> - [{doc, "Test that we can connect with different KEXs."}]. - -erlang_client_openssh_server_kexs(Config) when is_list(Config) -> - KexAlgos = try proplists:get_value(kex, proplists:get_value(common_algs,Config)) - catch _:_ -> [] - end, - comment(KexAlgos), - case KexAlgos of - [] -> {skip, "No common kex algorithms"}; - _ -> - Success = - lists:foldl( - fun(Kex, Acc) -> - ConnectionRef = - ssh_test_lib:connect(?SSH_DEFAULT_PORT, [{silently_accept_hosts, true}, - {user_interaction, false}, - {preferred_algorithms, - [{kex,[Kex]}]}]), - - {ok, ChannelId} = - ssh_connection:session_channel(ConnectionRef, infinity), - success = - ssh_connection:exec(ConnectionRef, ChannelId, - "echo testing", infinity), - - ExpectedData = {ssh_cm, ConnectionRef, {data, ChannelId, 0, <<"testing\n">>}}, - case ssh_test_lib:receive_exec_result(ExpectedData) of - expected -> - ssh_test_lib:receive_exec_end(ConnectionRef, ChannelId), - Acc; - {unexpected_msg,{ssh_cm, ConnectionRef, - {exit_status, ChannelId, 0}} = ExitStatus} -> - ct:log("0: Collected data ~p", [ExitStatus]), - ssh_test_lib:receive_exec_result(ExpectedData, ConnectionRef, ChannelId), - Acc; - Other -> - ct:log("~p failed: ~p",[Kex,Other]), - false - end - end, true, KexAlgos), - case Success of - true -> - ok; - false -> - {fail, "Kex failed for one or more algos"} - end - end. - -%%-------------------------------------------------------------------- -erlang_client_openssh_server_setenv() -> - [{doc, "Test api function ssh_connection:setenv"}]. - -erlang_client_openssh_server_setenv(Config) when is_list(Config) -> - ConnectionRef = - ssh_test_lib:connect(?SSH_DEFAULT_PORT, [{silently_accept_hosts, true}, - {user_interaction, false}]), - {ok, ChannelId} = - ssh_connection:session_channel(ConnectionRef, infinity), - Env = case ssh_connection:setenv(ConnectionRef, ChannelId, - "ENV_TEST", "testing_setenv", - infinity) of - success -> - <<"tesing_setenv\n">>; - failure -> - <<"\n">> - end, - success = ssh_connection:exec(ConnectionRef, ChannelId, - "echo $ENV_TEST", infinity), - Data = {ssh_cm, ConnectionRef, {data, ChannelId, 0, Env}}, - case ssh_test_lib:receive_exec_result(Data) of - expected -> - ssh_test_lib:receive_exec_end(ConnectionRef, ChannelId); - {unexpected_msg,{ssh_cm, ConnectionRef, - {data,0,1, UnxpectedData}}} -> - %% Some os may return things as - %% ENV_TEST: Undefined variable.\n" - ct:log("UnxpectedData: ~p", [UnxpectedData]), - ssh_test_lib:receive_exec_end(ConnectionRef, ChannelId); - {unexpected_msg,{ssh_cm, ConnectionRef, {exit_status, ChannelId, 0}} - = ExitStatus} -> - ct:log("0: Collected data ~p", [ExitStatus]), - ssh_test_lib:receive_exec_result(Data, - ConnectionRef, ChannelId); - Other -> - ct:fail(Other) - end. - -%%-------------------------------------------------------------------- - -%% setenv not meaningfull on erlang ssh daemon! - -%%-------------------------------------------------------------------- -erlang_client_openssh_server_publickey_rsa(Config) -> - erlang_client_openssh_server_publickey_X(Config, 'ssh-rsa'). - -erlang_client_openssh_server_publickey_dsa(Config) -> - erlang_client_openssh_server_publickey_X(Config, 'ssh-dss'). - - -erlang_client_openssh_server_publickey_X(_Config, Alg) -> - ConnectionRef = - ssh_test_lib:connect(?SSH_DEFAULT_PORT, - [{pref_public_key_algs, [Alg]}, - {user_interaction, false}, - {auth_methods, "publickey"}, - silently_accept_hosts]), - {ok, Channel} = - ssh_connection:session_channel(ConnectionRef, infinity), - ok = ssh_connection:close(ConnectionRef, Channel), - ok = ssh:close(ConnectionRef). - -%%-------------------------------------------------------------------- -erlang_server_openssh_client_public_key_dsa() -> - [{timetrap, {seconds,(?TIMEOUT div 1000)+10}}]. -erlang_server_openssh_client_public_key_dsa(Config) when is_list(Config) -> - erlang_server_openssh_client_public_key_X(Config, 'ssh-dss'). - -erlang_server_openssh_client_public_key_rsa() -> - [{timetrap, {seconds,(?TIMEOUT div 1000)+10}}]. -erlang_server_openssh_client_public_key_rsa(Config) when is_list(Config) -> - erlang_server_openssh_client_public_key_X(Config, 'ssh-rsa'). - - -erlang_server_openssh_client_public_key_X(Config, Alg) -> - SystemDir = proplists:get_value(data_dir, Config), - PrivDir = proplists:get_value(priv_dir, Config), - KnownHosts = filename:join(PrivDir, "known_hosts"), - {Pid, Host, Port} = ssh_test_lib:daemon([{system_dir, SystemDir}, - {preferred_algorithms,[{public_key, [Alg]}]}, - {auth_methods, "publickey"}, - {failfun, fun ssh_test_lib:failfun/2}]), - ct:sleep(500), - - Cmd = ssh_test_lib:open_sshc_cmd(Host, Port, - [" -o UserKnownHostsFile=", KnownHosts, - " -o StrictHostKeyChecking=no"], - "1+1."), - OpenSsh = ssh_test_lib:open_port({spawn, Cmd}), - ssh_test_lib:rcv_expected({data,<<"2\n">>}, OpenSsh, ?TIMEOUT), - ssh:stop_daemon(Pid). - %%-------------------------------------------------------------------- %% Test that the Erlang/OTP server can renegotiate with openSSH erlang_server_openssh_client_renegotiate(Config) -> @@ -430,108 +177,6 @@ erlang_server_openssh_client_renegotiate(Config) -> end. %%-------------------------------------------------------------------- -erlang_client_openssh_server_renegotiate(_Config) -> - process_flag(trap_exit, true), - IO = ssh_test_lib:start_io_server(), - Ref = make_ref(), - Parent = self(), - - Shell = - spawn_link( - fun() -> - Host = ssh_test_lib:hostname(), - Options = [{user_interaction, false}, - {silently_accept_hosts,true}], - group_leader(IO, self()), - {ok, ConnRef} = ssh:connect(Host, ?SSH_DEFAULT_PORT, Options), - ct:log("Parent = ~p, IO = ~p, Shell = ~p, ConnRef = ~p~n",[Parent, IO, self(), ConnRef]), - case ssh_connection:session_channel(ConnRef, infinity) of - {ok,ChannelId} -> - success = ssh_connection:ptty_alloc(ConnRef, ChannelId, []), - Args = [{channel_cb, ssh_shell}, - {init_args,[ConnRef, ChannelId]}, - {cm, ConnRef}, {channel_id, ChannelId}], - {ok, State} = ssh_channel:init([Args]), - Parent ! {ok, Ref, ConnRef}, - ssh_channel:enter_loop(State); - Error -> - Parent ! {error, Ref, Error} - end, - receive - nothing -> ok - end - end), - - receive - {error, Ref, Error} -> - ct:fail("Error=~p",[Error]); - {ok, Ref, ConnectionRef} -> - IO ! {input, self(), "echo Hej1\n"}, - receive_data("Hej1", ConnectionRef), - Kex1 = ssh_test_lib:get_kex_init(ConnectionRef), - ssh_connection_handler:renegotiate(ConnectionRef), - IO ! {input, self(), "echo Hej2\n"}, - receive_data("Hej2", ConnectionRef), - Kex2 = ssh_test_lib:get_kex_init(ConnectionRef), - IO ! {input, self(), "exit\n"}, - receive_logout(), - receive_normal_exit(Shell), - true = (Kex1 =/= Kex2) - end. - -%%-------------------------------------------------------------------- -erlang_client_openssh_server_password() -> - [{doc, "Test client password option"}]. -erlang_client_openssh_server_password(Config) when is_list(Config) -> - %% to make sure we don't public-key-auth - UserDir = proplists:get_value(data_dir, Config), - {error, Reason0} = - ssh:connect(any, ?SSH_DEFAULT_PORT, [{silently_accept_hosts, true}, - {user, "foo"}, - {password, "morot"}, - {user_interaction, false}, - {user_dir, UserDir}]), - - ct:log("Test of user foo that does not exist. " - "Error msg: ~p~n", [Reason0]), - - User = string:strip(os:cmd("whoami"), right, $\n), - - case length(string:tokens(User, " ")) of - 1 -> - {error, Reason1} = - ssh:connect(any, ?SSH_DEFAULT_PORT, - [{silently_accept_hosts, true}, - {user, User}, - {password, "foo"}, - {user_interaction, false}, - {user_dir, UserDir}]), - ct:log("Test of wrong Pasword. " - "Error msg: ~p~n", [Reason1]); - _ -> - ct:log("Whoami failed reason: ~n", []) - end. - -%%-------------------------------------------------------------------- - -erlang_client_openssh_server_nonexistent_subsystem() -> - [{doc, "Test client password option"}]. -erlang_client_openssh_server_nonexistent_subsystem(Config) when is_list(Config) -> - - ConnectionRef = ssh_test_lib:connect(?SSH_DEFAULT_PORT, - [{user_interaction, false}, - silently_accept_hosts]), - - {ok, ChannelId} = ssh_connection:session_channel(ConnectionRef, infinity), - - failure = ssh_connection:subsystem(ConnectionRef, ChannelId, "foo", infinity). - -%%-------------------------------------------------------------------- -% -%% Not possible to send password with openssh without user interaction -%% -%%-------------------------------------------------------------------- -%%-------------------------------------------------------------------- %%% Internal functions ----------------------------------------------- %%-------------------------------------------------------------------- receive_data(Data, Conn) -> diff --git a/lib/ssh/vsn.mk b/lib/ssh/vsn.mk index 004db6e3a2..6aaa22a6b4 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.6.4 +SSH_VSN = 4.6.5 APP_VSN = "ssh-$(SSH_VSN)" diff --git a/lib/ssl/doc/src/ssl.xml b/lib/ssl/doc/src/ssl.xml index 8fcda78ed5..4f72114ae9 100644 --- a/lib/ssl/doc/src/ssl.xml +++ b/lib/ssl/doc/src/ssl.xml @@ -32,7 +32,7 @@ <modulesummary>Interface Functions for Secure Socket Layer</modulesummary> <description> <p> - This module contains interface functions for the SSL/TLS protocol. + This module contains interface functions for the SSL/TLS/DTLS protocol. For detailed information about the supported standards see <seealso marker="ssl_app">ssl(6)</seealso>. </p> @@ -40,7 +40,7 @@ <section> <title>DATA TYPES</title> - <p>The following data types are used in the functions for SSL:</p> + <p>The following data types are used in the functions for SSL/TLS/DTLS:</p> <taglist> @@ -56,9 +56,11 @@ <p>The default socket options are <c>[{mode,list},{packet, 0},{header, 0},{active, true}]</c>.</p> <p>For valid options, see the - <seealso marker="kernel:inet">inet(3)</seealso> and - <seealso marker="kernel:gen_tcp">gen_tcp(3)</seealso> manual pages - in Kernel.</p></item> + <seealso marker="kernel:inet">inet(3)</seealso>, + <seealso marker="kernel:gen_tcp">gen_tcp(3)</seealso> and + <seealso marker="kernel:gen_tcp">gen_udp(3)</seealso> + manual pages + in Kernel. Note that stream oriented options such as packet are only relevant for SSL/TLS and not DTLS</p></item> <tag><marker id="type-ssloption"/><c>ssl_option() =</c></tag> <item> @@ -95,13 +97,14 @@ <item><p><c>{cb_info, {CallbackModule::atom(), DataTag::atom(), ClosedTag::atom(), ErrTag:atom()}}</c></p> - <p>Defaults to <c>{gen_tcp, tcp, tcp_closed, tcp_error}</c>. Can be used - to customize the transport layer. The callback module must implement a + <p>Defaults to <c>{gen_tcp, tcp, tcp_closed, tcp_error}</c> for TLS + and <c>{gen_udp, udp, udp_closed, udp_error}</c> for DTLS. Can be used + to customize the transport layer. For TLS the callback module must implement a reliable transport protocol, behave as <c>gen_tcp</c>, and have functions corresponding to <c>inet:setopts/2</c>, <c>inet:getopts/2</c>, <c>inet:peername/1</c>, <c>inet:sockname/1</c>, and <c>inet:port/1</c>. The callback <c>gen_tcp</c> is treated specially and calls <c>inet</c> - directly.</p> + directly. For DTLS this feature must be considered exprimental.</p> <taglist> <tag><c>CallbackModule =</c></tag> <item><p><c>atom()</c></p></item> @@ -137,18 +140,26 @@ <tag><c>sslsocket() =</c></tag> <item><p>opaque()</p></item> - - <tag><marker id="type-protocol"/><c>protocol() =</c></tag> + + <tag><marker id="type-protocol"/><c> protocol_version() =</c></tag> + <item><p><c> ssl_tls_protocol() | dtls_protocol() </c></p></item> + <item><p><c>sslv3 | tlsv1 | 'tlsv1.1' | 'tlsv1.2'</c></p></item> + <tag><marker id="type-protocol"/><c> dtls_protocol() =</c></tag> + <item><p><c>'dtlsv1' | 'dtlsv1.2'</c></p></item> + <tag><c>ciphers() =</c></tag> - <item><p><c>= [ciphersuite()] | string()</c></p> - <p>According to old API.</p></item> + <item><p><c>= [ciphersuite()]</c></p> + <p>Tuples and string formats accepted by versions + before ssl-8.2.4 will be converted for backwards compatibility</p></item> <tag><c>ciphersuite() =</c></tag> - - <item><p><c>{key_exchange(), cipher(), MAC::hash()} | - {key_exchange(), cipher(), MAC::hash(), PRF::hash()}</c></p></item> + <item><p><c> + #{key_exchange := key_exchange(), + cipher := cipher(), + mac := MAC::hash() | aead, + prf := PRF::hash() | default_prf} </c></p></item> <tag><c>key_exchange()=</c></tag> <item><p><c>rsa | dhe_dss | dhe_rsa | dh_anon | psk | dhe_psk @@ -165,6 +176,12 @@ <tag><c>prf_random() =</c></tag> <item><p><c>client_random | server_random</c></p></item> + <tag><c>cipher_filters() =</c></tag> + <item><p><c> [{key_exchange | cipher | mac | prf, algo_filter()}])</c></p></item> + + <tag><c>algo_filter() =</c></tag> + <item><p>fun(key_exchange() | cipher() | hash() | aead | default_prf) -> true | false </p></item> + <tag><c>srp_param_type() =</c></tag> <item><p><c>srp_1024 | srp_1536 | srp_2048 | srp_3072 | srp_4096 | srp_6144 | srp_8192</c></p></item> @@ -184,7 +201,7 @@ </section> <section> - <title>SSL OPTION DESCRIPTIONS - COMMON for SERVER and CLIENT</title> + <title>TLS/DTLS OPTION DESCRIPTIONS - COMMON for SERVER and CLIENT</title> <p>The following options have the same meaning in the client and the server:</p> @@ -289,11 +306,11 @@ atom()}} | <list type="bulleted"> <item><p>If the verify callback fun returns <c>{fail, Reason}</c>, the verification process is immediately stopped, an alert is - sent to the peer, and the TLS/SSL handshake terminates.</p></item> + sent to the peer, and the TLS/DTLS handshake terminates.</p></item> <item><p>If the verify callback fun returns <c>{valid, UserState}</c>, the verification process continues.</p></item> <item><p>If the verify callback fun always returns - <c>{valid, UserState}</c>, the TLS/SSL handshake does not + <c>{valid, UserState}</c>, the TLS/DTLS handshake does not terminate regarding verification failures and the connection is established.</p></item> <item><p>If called with an extension unknown to the user application, @@ -456,15 +473,16 @@ marker="public_key:public_key#pkix_path_validation-3">public_key:pkix_path_valid marker="public_key:public_key#pkix_path_validation-3">public_key:pkix_path_validation/3</seealso> with the selected CA as trusted anchor and the rest of the chain.</p></item> - <tag><c>{versions, [protocol()]}</c></tag> + <tag><c>{versions, [protocol_version()]}</c></tag> + <item><p>TLS protocol versions supported by started clients and servers. This option overrides the application environment option - <c>protocol_version</c>. If the environment option is not set, it defaults + <c>protocol_version</c> and <c>dtls_protocol_version</c>. If the environment option is not set, it defaults to all versions, except SSL-3.0, supported by the SSL application. See also <seealso marker="ssl:ssl_app">ssl(6).</seealso></p></item> <tag><c>{hibernate_after, integer()|undefined}</c></tag> - <item><p>When an integer-value is specified, <c>ssl_connection</c> + <item><p>When an integer-value is specified, <c>TLS/DTLS-connection</c> goes into hibernation after the specified number of milliseconds of inactivity, thus reducing its memory footprint. When <c>undefined</c> is specified (this is the default), the process @@ -524,7 +542,7 @@ fun(srp, Username :: string(), UserState :: term()) -> </section> <section> - <title>SSL OPTION DESCRIPTIONS - CLIENT SIDE</title> + <title>TLS/DTLS OPTION DESCRIPTIONS - CLIENT SIDE</title> <p>The following options are client-specific or have a slightly different meaning in the client than in the server:</p> @@ -664,7 +682,7 @@ fun(srp, Username :: string(), UserState :: term()) -> </section> <section> - <title>SSL OPTION DESCRIPTIONS - SERVER SIDE</title> + <title>TLS/DTLS OPTION DESCRIPTIONS - SERVER SIDE</title> <p>The following options are server-specific or have a slightly different meaning in the server than in the client:</p> @@ -702,7 +720,7 @@ fun(srp, Username :: string(), UserState :: term()) -> </p></item> <tag><c>{fail_if_no_peer_cert, boolean()}</c></tag> - <item><p>Used together with <c>{verify, verify_peer}</c> by an SSL server. + <item><p>Used together with <c>{verify, verify_peer}</c> by an TLS/DTLS server. If set to <c>true</c>, the server fails if the client does not have a certificate to send, that is, sends an empty certificate. If set to <c>false</c>, it fails only if the client sends an invalid @@ -716,7 +734,7 @@ fun(srp, Username :: string(), UserState :: term()) -> <tag><c>{reuse_session, fun(SuggestedSessionId, PeerCert, Compression, CipherSuite) -> boolean()}</c></tag> - <item><p>Enables the SSL server to have a local policy + <item><p>Enables the TLS/DTLS server to have a local policy for deciding if a session is to be reused or not. Meaningful only if <c>reuse_sessions</c> is set to <c>true</c>. <c>SuggestedSessionId</c> is a <c>binary()</c>, <c>PeerCert</c> is @@ -814,7 +832,7 @@ fun(srp, Username :: string(), UserState :: term()) -> <section> <title>General</title> - <p>When an SSL socket is in active mode (the default), data from the + <p>When an TLS/DTLS socket is in active mode (the default), data from the socket is delivered to the owner of the socket in the form of messages:</p> @@ -829,14 +847,34 @@ fun(srp, Username :: string(), UserState :: term()) -> </section> <funcs> + + <func> + <name>append_cipher_suites(Deferred, Suites) -> ciphers() </name> + <fsummary></fsummary> + <type> + <v>Deferred = ciphers() | cipher_filters() </v> + <v>Suites = ciphers() </v> + </type> + <desc><p>Make <c>Deferred</c> suites become the least preferred + suites, that is put them at the end of the cipher suite list + <c>Suites</c> after removing them from <c>Suites</c> if + present. <c>Deferred</c> may be a list of cipher suits or a + list of filters in which case the filters are use on <c>Suites</c> to + extract the Deferred cipher list.</p> + </desc> + </func> + <func> <name>cipher_suites() -></name> - <name>cipher_suites(Type) -> ciphers()</name> + <name>cipher_suites(Type) -> old_ciphers()</name> <fsummary>Returns a list of supported cipher suites.</fsummary> <type> <v>Type = erlang | openssl | all</v> </type> - <desc><p>Returns a list of supported cipher suites. + <desc> + <p>Returns a list of supported cipher suites. + This function will become deprecated in OTP 21, and replaced + by <seealso marker="#cipher_suites-2">ssl:cipher-suites/2</seealso> <c>cipher_suites()</c> is equivalent to <c>cipher_suites(erlang).</c> Type <c>openssl</c> is provided for backwards compatibility with the old SSL, which used OpenSSL. <c>cipher_suites(all)</c> returns @@ -844,12 +882,26 @@ fun(srp, Username :: string(), UserState :: term()) -> in <c>cipher_suites(erlang)</c> but included in <c>cipher_suites(all)</c> are not used unless explicitly configured by the user.</p> + </desc> + </func> + + <func> + <name>cipher_suites(Supported, Version) -> ciphers()</name> + <fsummary>Returns a list of all default or + all supported cipher suites.</fsummary> + <type> + <v> Supported = default | all | anonymous </v> + <v> Version = protocol_version() </v> + </type> + <desc><p>Returns all default or all supported (except anonymous), + or all anonymous cipher suites for a + TLS version</p> </desc> </func> <func> <name>eccs() -></name> - <name>eccs(protocol()) -> [named_curve()]</name> + <name>eccs(protocol_version()) -> [named_curve()]</name> <fsummary>Returns a list of supported ECCs.</fsummary> <desc><p>Returns a list of supported ECCs. <c>eccs()</c> @@ -857,7 +909,7 @@ fun(srp, Username :: string(), UserState :: term()) -> supported protocols and then deduplicating the output.</p> </desc> </func> - + <func> <name>clear_pem_cache() -> ok </name> <fsummary> Clears the pem cache</fsummary> @@ -872,20 +924,20 @@ fun(srp, Username :: string(), UserState :: term()) -> <func> <name>connect(Socket, SslOptions) -> </name> - <name>connect(Socket, SslOptions, Timeout) -> {ok, SslSocket} + <name>connect(Socket, SslOptions, Timeout) -> {ok, TLSSocket} | {error, Reason}</name> <fsummary>Upgrades a <c>gen_tcp</c>, or - equivalent, connected socket to an SSL socket.</fsummary> + equivalent, connected socket to an TLS socket.</fsummary> <type> <v>Socket = socket()</v> <v>SslOptions = [ssl_option()]</v> <v>Timeout = integer() | infinity</v> - <v>SslSocket = sslsocket()</v> + <v>TLSSocket = sslsocket()</v> <v>Reason = term()</v> </type> <desc><p>Upgrades a <c>gen_tcp</c>, or equivalent, - connected socket to an SSL socket, that is, performs the - client-side ssl handshake.</p> + connected socket to an TLS socket, that is, performs the + client-side TLS handshake.</p> <note><p>If the option <c>verify</c> is set to <c>verify_peer</c> the option <c>server_name_indication</c> shall also be specified, @@ -899,7 +951,7 @@ fun(srp, Username :: string(), UserState :: term()) -> <name>connect(Host, Port, Options) -></name> <name>connect(Host, Port, Options, Timeout) -> {ok, SslSocket} | {error, Reason}</name> - <fsummary>Opens an SSL connection to <c>Host</c>, <c>Port</c>.</fsummary> + <fsummary>Opens an TLS/DTLS connection to <c>Host</c>, <c>Port</c>.</fsummary> <type> <v>Host = host()</v> <v>Port = integer()</v> @@ -908,13 +960,13 @@ fun(srp, Username :: string(), UserState :: term()) -> <v>SslSocket = sslsocket()</v> <v>Reason = term()</v> </type> - <desc><p>Opens an SSL connection to <c>Host</c>, <c>Port</c>.</p> + <desc><p>Opens an TLS/DTLS connection to <c>Host</c>, <c>Port</c>.</p> <p> When the option <c>verify</c> is set to <c>verify_peer</c> the check <seealso marker="public_key:public_key#pkix_verify_hostname-2">public_key:pkix_verify_hostname/2</seealso> will be performed in addition to the usual x509-path validation checks. If the check fails the error {bad_cert, hostname_check_failed} will be propagated to the path validation fun <seealso marker="#verify_fun">verify_fun</seealso>, where it is possible to do customized - checks by using the full possibilitis of the <seealso marker="public_key:public_key#pkix_verify_hostname-2">public_key:pkix_verify_hostname/2</seealso> API. + checks by using the full possibilities of the <seealso marker="public_key:public_key#pkix_verify_hostname-3">public_key:pkix_verify_hostname/3</seealso> API. When the option <c>server_name_indication</c> is provided, its value (the DNS name) will be used as <c>ReferenceID</c> to <seealso marker="public_key:public_key#pkix_verify_hostname-2">public_key:pkix_verify_hostname/2</seealso>. @@ -930,24 +982,24 @@ fun(srp, Username :: string(), UserState :: term()) -> <func> <name>close(SslSocket) -> ok | {error, Reason}</name> - <fsummary>Closes an SSL connection.</fsummary> + <fsummary>Closes an TLS/DTLS connection.</fsummary> <type> <v>SslSocket = sslsocket()</v> <v>Reason = term()</v> </type> - <desc><p>Closes an SSL connection.</p> + <desc><p>Closes an TLS/DTLS connection.</p> </desc> </func> <func> <name>close(SslSocket, How) -> ok | {ok, port()} | {error, Reason}</name> - <fsummary>Closes an SSL connection.</fsummary> + <fsummary>Closes an TLS connection.</fsummary> <type> <v>SslSocket = sslsocket()</v> <v>How = timeout() | {NewController::pid(), timeout()} </v> <v>Reason = term()</v> </type> - <desc><p>Closes or downgrades an SSL connection. In the latter case the transport + <desc><p>Closes or downgrades an TLS connection. In the latter case the transport connection will be handed over to the <c>NewController</c> process after receiving the TLS close alert from the peer. The returned transport socket will have the following options set: <c>[{active, false}, {packet, 0}, {mode, binary}]</c></p> @@ -958,7 +1010,7 @@ fun(srp, Username :: string(), UserState :: term()) -> <name>controlling_process(SslSocket, NewOwner) -> ok | {error, Reason}</name> <fsummary>Assigns a new controlling process to the - SSL socket.</fsummary> + TLS/DTLS socket.</fsummary> <type> <v>SslSocket = sslsocket()</v> <v>NewOwner = pid()</v> @@ -1008,6 +1060,21 @@ fun(srp, Username :: string(), UserState :: term()) -> </desc> </func> + <func> + <name>filter_cipher_suites(Suites, Filters) -> ciphers()</name> + <fsummary></fsummary> + <type> + <v> Suites = ciphers()</v> + <v> Filters = cipher_filters()</v> + </type> + <desc><p>Removes cipher suites if any of the filter functions + returns false for any part of the cipher suite. This function + also calls default filter functions to make sure the cipher + suites are supported by crypto. If no filter function is supplied for some + part the default behaviour is fun(Algorithm) -> true.</p> + </desc> + </func> + <func> <name>format_error(Reason) -> string()</name> <fsummary>Returns an error string.</fsummary> @@ -1105,6 +1172,22 @@ fun(srp, Username :: string(), UserState :: term()) -> <p>Returns the address and port number of the peer.</p> </desc> </func> + + <func> + <name>prepend_cipher_suites(Preferred, Suites) -> ciphers()</name> + <fsummary></fsummary> + <type> + <v>Preferred = ciphers() | cipher_filters() </v> + <v>Suites = ciphers() </v> + </type> + <desc><p>Make <c>Preferred</c> suites become the most preferred + suites that is put them at the head of the cipher suite list + <c>Suites</c> after removing them from <c>Suites</c> if + present. <c>Preferred</c> may be a list of cipher suits or a + list of filters in which case the filters are use on <c>Suites</c> to + extract the preferred cipher list. </p> + </desc> + </func> <func> <name>prf(Socket, Secret, Label, Seed, WantedLength) -> {ok, binary()} | {error, reason()}</name> @@ -1121,7 +1204,7 @@ fun(srp, Username :: string(), UserState :: term()) -> extra key material. It either takes user-generated values for <c>Secret</c> and <c>Seed</c> or atoms directing it to use a specific value from the session security parameters.</p> - <p>Can only be used with TLS connections; <c>{error, undefined}</c> + <p>Can only be used with TLS/DTLS connections; <c>{error, undefined}</c> is returned for SSLv3 connections.</p> </desc> </func> @@ -1221,7 +1304,7 @@ fun(srp, Username :: string(), UserState :: term()) -> <v>Reason = term()</v> </type> <desc> - <p>Performs the SSL/TLS server-side handshake.</p> + <p>Performs the SSL/TLS/DTLS server-side handshake.</p> <p><c>Socket</c> is a socket as returned by <seealso marker="#transport_accept-2">ssl:transport_accept/[1,2]</seealso> </p> @@ -1231,7 +1314,7 @@ fun(srp, Username :: string(), UserState :: term()) -> <func> <name>ssl_accept(Socket, SslOptions) -> </name> <name>ssl_accept(Socket, SslOptions, Timeout) -> {ok, Socket} | ok | {error, Reason}</name> - <fsummary>Performs server-side SSL/TLS handshake.</fsummary> + <fsummary>Performs server-side SSL/TLS/DTLS handshake.</fsummary> <type> <v>Socket = socket() | sslsocket() </v> <v>SslOptions = [ssl_option()]</v> @@ -1248,10 +1331,10 @@ fun(srp, Username :: string(), UserState :: term()) -> by calling this function, else the upgrade succeeds or does not succeed depending on timing.</p></warning> - <p>If <c>Socket</c> is an <c>sslsocket()</c>: provides extra SSL/TLS + <p>If <c>Socket</c> is an <c>sslsocket()</c>: provides extra SSL/TLS/DTLS options to those specified in <seealso marker="#listen-2">ssl:listen/2 </seealso> and then performs - the SSL/TLS handshake. + the SSL/TLS/DTLS handshake. </p> </desc> </func> @@ -1310,7 +1393,7 @@ fun(srp, Username :: string(), UserState :: term()) -> The socket returned is to be passed to <seealso marker="#ssl_accept-2"> ssl:ssl_accept[2,3]</seealso> to complete handshaking, that is, - establishing the SSL/TLS connection.</p> + establishing the SSL/TLS/DTLS connection.</p> <warning> <p>The socket returned can only be used with <seealso marker="#ssl_accept-2"> ssl:ssl_accept[2,3]</seealso>. @@ -1332,7 +1415,8 @@ fun(srp, Username :: string(), UserState :: term()) -> <fsummary>Returns version information relevant for the SSL application.</fsummary> <type> - <v>versions_info() = {app_vsn, string()} | {supported | available, [protocol()] </v> + <v>versions_info() = {app_vsn, string()} | {supported | available, [ssl_tls_protocol()]} | + {supported_dtls | available_dtls, [dtls_protocol()]} </v> </type> <desc> <p>Returns version information relevant for the SSL @@ -1342,19 +1426,35 @@ fun(srp, Username :: string(), UserState :: term()) -> <item>The application version of the SSL application.</item> <tag><c>supported</c></tag> - <item>TLS/SSL versions supported by default. + <item>SSL/TLS versions supported by default. Overridden by a version option on <seealso marker="#connect-2"> connect/[2,3,4]</seealso>, <seealso marker="#listen-2"> listen/2</seealso>, and <seealso marker="#ssl_accept-2">ssl_accept/[1,2,3]</seealso>. - For the negotiated TLS/SSL version, see <seealso + For the negotiated SSL/TLS version, see <seealso marker="#connection_information-1">ssl:connection_information/1 </seealso>.</item> - + + <tag><c>supported_dtls</c></tag> + <item>DTLS versions supported by default. + Overridden by a version option on + <seealso marker="#connect-2"> connect/[2,3,4]</seealso>, + <seealso marker="#listen-2"> listen/2</seealso>, and <seealso + marker="#ssl_accept-2">ssl_accept/[1,2,3]</seealso>. + For the negotiated DTLS version, see <seealso + marker="#connection_information-1">ssl:connection_information/1 + </seealso>.</item> + <tag><c>available</c></tag> - <item>All TLS/SSL versions supported by the SSL application. + <item>All SSL/TLS versions supported by the SSL application. TLS 1.2 requires sufficient support from the Crypto application.</item> + + <tag><c>available_dtls</c></tag> + <item>All DTLS versions supported by the SSL application. + DTLS 1.2 requires sufficient support from the Crypto + application.</item> + </taglist> </desc> </func> @@ -1365,6 +1465,7 @@ fun(srp, Username :: string(), UserState :: term()) -> <title>SEE ALSO</title> <p><seealso marker="kernel:inet">inet(3)</seealso> and <seealso marker="kernel:gen_tcp">gen_tcp(3)</seealso> + <seealso marker="kernel:gen_udp">gen_udp(3)</seealso> </p> </section> diff --git a/lib/ssl/doc/src/ssl_app.xml b/lib/ssl/doc/src/ssl_app.xml index e4109dd080..51070bb083 100644 --- a/lib/ssl/doc/src/ssl_app.xml +++ b/lib/ssl/doc/src/ssl_app.xml @@ -35,11 +35,11 @@ <description> <p> - The ssl application is an implementation of the SSL/TLS protocol in Erlang. + The ssl application is an implementation of the SSL/TLS/DTLS protocol in Erlang. </p> <list type="bulleted"> - <item>Supported SSL/TLS-versions are SSL-3.0, TLS-1.0, - TLS-1.1, and TLS-1.2.</item> + <item>Supported SSL/TLS/DTLS-versions are SSL-3.0, TLS-1.0, + TLS-1.1, TLS-1.2, DTLS-1.0 (based on TLS-1.1), DTLS-1.2 (based on TLS-1.2)</item> <item>For security reasons SSL-2.0 is not supported.</item> <item>For security reasons SSL-3.0 is no longer supported by default, but can be configured. (OTP 19) </item> @@ -47,6 +47,8 @@ but can be configured. (OTP 21) </item> <item>For security reasons DES cipher suites are no longer supported by default, but can be configured. (OTP 20) </item> + <item>For security reasons 3DES cipher suites are no longer supported by default, + but can be configured. (OTP 21) </item> <item> Renegotiation Indication Extension <url href="http://www.ietf.org/rfc/rfc5746.txt">RFC 5746</url> is supported </item> <item>Ephemeral Diffie-Hellman cipher suites are supported, @@ -74,7 +76,7 @@ <section> <title>DEPENDENCIES</title> - <p>The SSL application uses the <c>public_key</c> and + <p>The SSL application uses the <c>public_key</c>, <c>asn1</c> and Crypto application to handle public keys and encryption, hence these applications must be loaded for the SSL application to work. In an embedded environment this means they must be started with @@ -96,13 +98,20 @@ <p><c>erl -ssl protocol_version "['tlsv1.2', 'tlsv1.1']"</c></p> <taglist> - <tag><c>protocol_version = </c><seealso marker="ssl#type-protocol">ssl:protocol()</seealso><c><![CDATA[<optional>]]></c></tag> + <tag><c>protocol_version = </c><seealso marker="ssl#type-protocol">ssl:ssl_tls_protocol()</seealso><c><![CDATA[<optional>]]></c></tag> <item><p>Protocol supported by started clients and servers. If this option is not set, it defaults to all - protocols currently supported by the SSL application. + TLS protocols currently supported by the SSL application. This option can be overridden by the version option to <c>ssl:connect/[2,3]</c> and <c>ssl:listen/2</c>.</p></item> + <tag><c>dtls_protocol_version = </c><seealso marker="ssl#type-protocol">ssl:dtls_protocol()</seealso><c><![CDATA[<optional>]]></c></tag> + <item><p>Protocol supported by started clients and + servers. If this option is not set, it defaults to all + DTLS protocols currently supported by the SSL application. + This option can be overridden by the version option + to <c>ssl:connect/[2,3]</c> and <c>ssl:listen/2</c>.</p></item> + <tag><c><![CDATA[session_lifetime = integer() <optional>]]></c></tag> <item><p>Maximum lifetime of the session data in seconds. Defaults to 24 hours which is the maximum recommended lifetime by <url href="http://www.ietf.org/rfc/5246rfc.txt">RFC 5246</url>. However @@ -125,14 +134,14 @@ new client connections. If the maximum number of sessions is reached, the current cache entries will be invalidated regardless of their remaining lifetime. Defaults to - 1000.</p></item> + 1000. Recommended ssl-8.2.1 or later for this option to work as intended.</p></item> <tag> <c><![CDATA[session_cache_server_max = integer() <optional>]]></c></tag> <item><p>Limits the growth of the servers session cache, that is how many client sessions are cached by the server. If the maximum number of sessions is reached, the current cache entries will be invalidated regardless of their remaining - lifetime. Defaults to 1000.</p></item> + lifetime. Defaults to 1000. Recommended ssl-8.2.1 or later for this option to work as intended.</p></item> <tag><c><![CDATA[ssl_pem_cache_clean = integer() <optional>]]></c></tag> <item> @@ -147,9 +156,8 @@ <tag><c><![CDATA[bypass_pem_cache = boolean() <optional>]]></c></tag> <item> <p>Introduced in ssl-8.0.2. Disables the PEM-cache. - The PEM cache has proven to be a bottleneck, until the - implementation has been improved this can be used as - a workaround. Defaults to false. + Can be used as a workaround for the PEM-cache bottleneck + before ssl-8.1.1. Defaults to false. </p> </item> @@ -169,7 +177,7 @@ <title>ERROR LOGGER AND EVENT HANDLERS</title> <p>The SSL application uses the default <seealso marker="kernel:error_logger">OTP error logger</seealso> to log - unexpected errors and TLS alerts. The logging of TLS alerts may be + unexpected errors and TLS/DTLS alerts. The logging of TLS/DTLS alerts may be turned off with the <c>log_alert</c> option. </p> </section> diff --git a/lib/ssl/doc/src/ssl_distribution.xml b/lib/ssl/doc/src/ssl_distribution.xml index 7f8a08f704..e14f3f90dc 100644 --- a/lib/ssl/doc/src/ssl_distribution.xml +++ b/lib/ssl/doc/src/ssl_distribution.xml @@ -22,7 +22,7 @@ </legalnotice> - <title>Using SSL for Erlang Distribution</title> + <title>Using TLS for Erlang Distribution</title> <prepared>P Nyblom</prepared> <responsible></responsible> <docno></docno> @@ -33,7 +33,7 @@ <file>ssl_distribution.xml</file> </header> <p>This section describes how the Erlang distribution can use - SSL to get extra verification and security.</p> + TLS to get extra verification and security.</p> <p>The Erlang distribution can in theory use almost any connection-based protocol as bearer. However, a module that @@ -45,16 +45,16 @@ <p>In the SSL application, an extra distribution module, <c>inet_tls_dist</c>, can be used as an - alternative. All distribution connections will use SSL and + alternative. All distribution connections will use TLS and all participating Erlang nodes in a distributed system must use this distribution module.</p> <p>The security level depends on the parameters provided to the - SSL connection setup. Erlang node cookies are however always + TLS connection setup. Erlang node cookies are however always used, as they can be used to differentiate between two different Erlang networks.</p> - <p>To set up Erlang distribution over SSL:</p> + <p>To set up Erlang distribution over TLS:</p> <list type="bulleted"> <item><em>Step 1:</em> Build boot scripts including the @@ -63,13 +63,13 @@ <c>net_kernel</c>.</item> <item><em>Step 3:</em> Specify the security options and other SSL options.</item> - <item><em>Step 4:</em> Set up the environment to always use SSL.</item> + <item><em>Step 4:</em> Set up the environment to always use TLS.</item> </list> <p>The following sections describe these steps.</p> <section> - <title>Building Boot Scripts Including the ssl Application</title> + <title>Building Boot Scripts Including the SSL Application</title> <p>Boot scripts are built using the <c>systools</c> utility in the SASL application. For more information on <c>systools</c>, see the SASL documentation. This is only an example of @@ -90,7 +90,7 @@ STDLIB application.</p></item> </list> - <p>The following shows an example <c>.rel</c> file with SSL + <p>The following shows an example <c>.rel</c> file with TLS added:</p> <code type="none"> {release, {"OTP APN 181 01","R15A"}, {erts, "5.9"}, @@ -154,7 +154,7 @@ Eshell V5.0 (abort with ^G) <section> <title>Specifying Distribution Module for net_kernel</title> - <p>The distribution module for SSL is named <c>inet_tls_dist</c> + <p>The distribution module for SSL/TLS is named <c>inet_tls_dist</c> and is specified on the command line with option <c>-proto_dist</c>. The argument to <c>-proto_dist</c> is to be the module name without suffix <c>_dist</c>. So, this distribution @@ -174,21 +174,21 @@ Eshell V5.0 (abort with ^G) (ssl_test@myhost)1> </code> <p>However, a node started in this way refuses to talk - to other nodes, as no SSL parameters are supplied + to other nodes, as no TLS parameters are supplied (see the next section).</p> </section> <section> - <title>Specifying SSL Options</title> + <title>Specifying SSL/TLS Options</title> <p> - The SSL distribution options can be written into a file + The SSL/TLS distribution options can be written into a file that is consulted when the node is started. This file name is then specified with the command line argument <c>-ssl_dist_optfile</c>. </p> <p> - Any available SSL option can be specified in an options file, + Any available SSL/TLS option can be specified in an options file, but note that options that take a <c>fun()</c> has to use the syntax <c>fun Mod:Func/Arity</c> since a function body can not be compiled when consulting a file. @@ -202,7 +202,7 @@ Eshell V5.0 (abort with ^G) interfere severely, so beware! </p> <p> - For SSL to work, at least a public key and a certificate + For SSL/TLS to work, at least a public key and a certificate must be specified for the server side. In the following example, the PEM file <c>"/home/me/ssl/erlserver.pem"</c> contains both @@ -257,13 +257,13 @@ $ erl -boot /home/me/ssl/start_ssl -proto_dist inet_tls still be accepted if it does not present any certificate. </p> <p> - A node started in this way is fully functional, using SSL + A node started in this way is fully functional, using TLS as the distribution protocol. </p> </section> <section> - <title>Specifying SSL Options (Legacy)</title> + <title>Specifying SSL/TLS Options (Legacy)</title> <p> As in the previous section the PEM file @@ -272,9 +272,9 @@ $ erl -boot /home/me/ssl/start_ssl -proto_dist inet_tls </p> <p>On the <c>erl</c> command line you can specify options that the - SSL distribution adds when creating a socket.</p> + SSL/TLS distribution adds when creating a socket.</p> - <p>The simplest SSL options in the following list can be specified + <p>The simplest SSL/TLS options in the following list can be specified by adding the prefix <c>server_</c> or <c>client_</c> to the option name:</p> <list type="bulleted"> @@ -294,7 +294,7 @@ $ erl -boot /home/me/ssl/start_ssl -proto_dist inet_tls </list> <p>Note that <c>verify_fun</c> needs to be written in a different - form than the corresponding SSL option, since funs are not + form than the corresponding SSL/TLS option, since funs are not accepted on the command line.</p> <p>The server can also take the options <c>dhfile</c> and @@ -307,7 +307,7 @@ $ erl -boot /home/me/ssl/start_ssl -proto_dist inet_tls <p>Raw socket options, such as <c>packet</c> and <c>size</c> must not be specified on the command line.</p> - <p>The command-line argument for specifying the SSL options is named + <p>The command-line argument for specifying the SSL/TLS options is named <c>-ssl_dist_opt</c> and is to be followed by pairs of SSL options and their values. Argument <c>-ssl_dist_opt</c> can be repeated any number of times.</p> @@ -331,10 +331,10 @@ Eshell V5.0 (abort with ^G) </section> <section> - <title>Setting up Environment to Always Use SSL (Legacy)</title> + <title>Setting up Environment to Always Use SSL/TLS (Legacy)</title> <p>A convenient way to specify arguments to Erlang is to use environment variable <c>ERL_FLAGS</c>. All the flags needed to - use the SSL distribution can be specified in that variable and are + use the SSL/TLS distribution can be specified in that variable and are then interpreted as command-line arguments for all subsequent invocations of Erlang.</p> @@ -365,8 +365,8 @@ Eshell V5.0 (abort with ^G) </section> <section> - <title>Using SSL distribution over IPv6</title> - <p>It is possible to use SSL distribution over IPv6 instead of + <title>Using SSL/TLS distribution over IPv6</title> + <p>It is possible to use SSL/TLS distribution over IPv6 instead of IPv4. To do this, pass the option <c>-proto_dist inet6_tls</c> instead of <c>-proto_dist inet_tls</c> when starting Erlang, either on the command line or in the <c>ERL_FLAGS</c> environment @@ -380,6 +380,6 @@ $ erl -boot /home/me/ssl/start_ssl -proto_dist inet6_tls </code> <p>A node started in this way will only be able to communicate with - other nodes using SSL distribution over IPv6.</p> + other nodes using SSL/TLS distribution over IPv6.</p> </section> </chapter> diff --git a/lib/ssl/doc/src/ssl_introduction.xml b/lib/ssl/doc/src/ssl_introduction.xml index 25b05a769d..a416924eb1 100644 --- a/lib/ssl/doc/src/ssl_introduction.xml +++ b/lib/ssl/doc/src/ssl_introduction.xml @@ -5,7 +5,7 @@ <header> <copyright> <year>2015</year> - <year>2015</year> + <year>2017</year> <holder>Ericsson AB, All Rights Reserved</holder> </copyright> <legalnotice> @@ -41,14 +41,15 @@ authenticate the counterpart with whom they communicate, and to exchange a symmetric key for payload encryption. The protocol provides data/message confidentiality (encryption), integrity (through message authentication code checks) - and host verification (through certificate path validation).</p> + and host verification (through certificate path validation). DTLS (Datagram Transport Layer Security) that + is based on TLS but datagram oriented instead of stream oriented.</p> </section> <section> <title>Prerequisites</title> <p>It is assumed that the reader is familiar with the Erlang programming language, the concepts of OTP, and has a basic - understanding of SSL/TLS.</p> + understanding of SSL/TLS/DTLS.</p> </section> </chapter> diff --git a/lib/ssl/doc/src/ssl_protocol.xml b/lib/ssl/doc/src/ssl_protocol.xml index 31a22db58b..0b12dc7dc5 100644 --- a/lib/ssl/doc/src/ssl_protocol.xml +++ b/lib/ssl/doc/src/ssl_protocol.xml @@ -22,7 +22,7 @@ </legalnotice> - <title>TLS and its Predecessor, SSL</title> + <title>TLS/DTLS and TLS Predecessor, SSL</title> <prepared></prepared> <responsible></responsible> <docno></docno> @@ -33,7 +33,7 @@ <file>ssl_protocol.xml</file> </header> - <p>The Erlang SSL application implements the SSL/TLS protocol + <p>The Erlang SSL application implements the SSL/TLS/DTLS protocol for the currently supported versions, see the <seealso marker="ssl">ssl(3)</seealso> manual page. </p> @@ -41,20 +41,22 @@ <p>By default SSL/TLS is run over the TCP/IP protocol even though you can plug in any other reliable transport protocol with the same Application Programming Interface (API) as the - <c>gen_tcp</c> module in Kernel.</p> + <c>gen_tcp</c> module in Kernel. DTLS is by default run over UDP/IP, + which means that application data has no delivery guarentees. Other + transports, such as SCTP, may be supported in future releases.</p> <p>If a client and a server wants to use an upgrade mechanism, such as - defined by RFC 2817, to upgrade a regular TCP/IP connection to an SSL + defined by RFC 2817, to upgrade a regular TCP/IP connection to an TLS connection, this is supported by the Erlang SSL application API. This can be useful for, for example, supporting HTTP and HTTPS on the same port and - implementing virtual hosting. + implementing virtual hosting. Note this is a TLS feature only. </p> <section> <title>Security Overview</title> <p>To achieve authentication and privacy, the client and server - perform a TLS handshake procedure before transmitting or receiving + perform a TLS/DTLS handshake procedure before transmitting or receiving any data. During the handshake, they agree on a protocol version and cryptographic algorithms, generate shared secrets using public key cryptographies, and optionally authenticate each other with @@ -73,10 +75,10 @@ <p>The keys for the symmetric encryption are generated uniquely for each connection and are based on a secret negotiated - in the TLS handshake.</p> + in the TLS/DTLS handshake.</p> - <p>The TLS handshake protocol and data transfer is run on top of - the TLS Record Protocol, which uses a keyed-hash Message + <p>The TLS/DTLS handshake protocol and data transfer is run on top of + the TLS/DTLS Record Protocol, which uses a keyed-hash Message Authenticity Code (MAC), or a Hash-based MAC (HMAC), to protect the message data integrity. From the TLS RFC: "A Message Authentication Code is a @@ -152,8 +154,8 @@ from it was saved, for security reasons. The amount of time the session data is to be saved can be configured.</p> - <p>By default the SSL clients try to reuse an available session and - by default the SSL servers agree to reuse sessions when clients + <p>By default the TLS/DTLS clients try to reuse an available session and + by default the TLS/DTLS servers agree to reuse sessions when clients ask for it.</p> </section> diff --git a/lib/ssl/doc/src/using_ssl.xml b/lib/ssl/doc/src/using_ssl.xml index 61918a346d..3ef33df719 100644 --- a/lib/ssl/doc/src/using_ssl.xml +++ b/lib/ssl/doc/src/using_ssl.xml @@ -22,7 +22,7 @@ </legalnotice> - <title>Using SSL API</title> + <title>Using SSL application API</title> <prepared></prepared> <responsible></responsible> <docno></docno> @@ -51,7 +51,7 @@ <section> <title>Minimal Example</title> - <note><p> The minimal setup is not the most secure setup of SSL.</p> + <note><p> The minimal setup is not the most secure setup of SSL/TLS/DTLS.</p> </note> <p>To set up client/server connections:</p> @@ -60,27 +60,27 @@ <code type="erl">1 server> ssl:start(). ok</code> - <p><em>Step 2:</em> Create an SSL listen socket:</p> + <p><em>Step 2:</em> Create an TLS listen socket: (To run DTLS add the option {protocol, dtls})</p> <code type="erl">2 server> {ok, ListenSocket} = ssl:listen(9999, [{certfile, "cert.pem"}, {keyfile, "key.pem"},{reuseaddr, true}]). {ok,{sslsocket, [...]}}</code> - <p><em>Step 3:</em> Do a transport accept on the SSL listen socket:</p> + <p><em>Step 3:</em> Do a transport accept on the TLS listen socket:</p> <code type="erl">3 server> {ok, Socket} = ssl:transport_accept(ListenSocket). {ok,{sslsocket, [...]}}</code> - <p><em>Step 4:</em> Start the client side:</p> + <p><em>Step 4:</em> Start the client side: </p> <code type="erl">1 client> ssl:start(). ok</code> - + <p> To run DTLS add the option {protocol, dtls} to third argument.</p> <code type="erl">2 client> {ok, Socket} = ssl:connect("localhost", 9999, [], infinity). {ok,{sslsocket, [...]}}</code> - <p><em>Step 5:</em> Do the SSL handshake:</p> + <p><em>Step 5:</em> Do the TLS handshake:</p> <code type="erl">4 server> ok = ssl:ssl_accept(Socket). ok</code> - <p><em>Step 6:</em> Send a message over SSL:</p> + <p><em>Step 6:</em> Send a message over TLS:</p> <code type="erl">5 server> ssl:send(Socket, "foo"). ok</code> @@ -92,7 +92,7 @@ ok</code> </section> <section> - <title>Upgrade Example</title> + <title>Upgrade Example - TLS only </title> <note><p>To upgrade a TCP/IP connection to an SSL connection, the client and server must agree to do so. The agreement @@ -125,24 +125,24 @@ ok</code> <code type="erl">4 server> inet:setopts(Socket, [{active, false}]). ok</code> - <p><em>Step 6:</em> Do the SSL handshake:</p> - <code type="erl">5 server> {ok, SSLSocket} = ssl:ssl_accept(Socket, [{cacertfile, "cacerts.pem"}, + <p><em>Step 6:</em> Do the TLS handshake:</p> + <code type="erl">5 server> {ok, TLSSocket} = ssl:ssl_accept(Socket, [{cacertfile, "cacerts.pem"}, {certfile, "cert.pem"}, {keyfile, "key.pem"}]). {ok,{sslsocket,[...]}}</code> - <p><em>Step 7:</em> Upgrade to an SSL connection. The client and server + <p><em>Step 7:</em> Upgrade to an TLS connection. The client and server must agree upon the upgrade. The server must call <c>ssl:accept/2</c> before the client calls <c>ssl:connect/3.</c></p> - <code type="erl">3 client>{ok, SSLSocket} = ssl:connect(Socket, [{cacertfile, "cacerts.pem"}, + <code type="erl">3 client>{ok, TLSSocket} = ssl:connect(Socket, [{cacertfile, "cacerts.pem"}, {certfile, "cert.pem"}, {keyfile, "key.pem"}], infinity). {ok,{sslsocket,[...]}}</code> - <p><em>Step 8:</em> Send a message over SSL:</p> - <code type="erl">4 client> ssl:send(SSLSocket, "foo"). + <p><em>Step 8:</em> Send a message over TLS:</p> + <code type="erl">4 client> ssl:send(TLSSocket, "foo"). ok</code> - <p><em>Step 9:</em> Set <c>active true</c> on the SSL socket:</p> - <code type="erl">4 server> ssl:setopts(SSLSocket, [{active, true}]). + <p><em>Step 9:</em> Set <c>active true</c> on the TLS socket:</p> + <code type="erl">4 server> ssl:setopts(TLSSocket, [{active, true}]). ok</code> <p><em>Step 10:</em> Flush the shell message queue to see that the message @@ -153,7 +153,51 @@ ok</code> </section> </section> - <section> + <section> + <title>Customizing cipher suits</title> + + <p>Fetch default cipher suite list for an TLS/DTLS version. Change default + to all to get all possible cipher suites.</p> + <code type="erl">1> Default = ssl:cipher_suites(default, 'tlsv1.2'). + [#{cipher => aes_256_gcm,key_exchange => ecdhe_ecdsa, + mac => aead,prf => sha384}, ....] +</code> + + <p>In OTP 20 it is desirable to remove all cipher suites + that uses rsa kexchange (removed from default in 21) </p> + <code type="erl">2> NoRSA = + ssl:filter_cipher_suites(Default, + [{key_exchange, fun(rsa) -> false; + (_) -> true end}]). + [...] + </code> + + <p> Pick just a few suites </p> + <code type="erl"> 3> Suites = + ssl:filter_cipher_suites(Default, + [{key_exchange, fun(ecdh_ecdsa) -> true; + (_) -> false end}, + {cipher, fun(aes_128_cbc) ->true; + (_) ->false end}]). + [#{cipher => aes_128_cbc,key_exchange => ecdh_ecdsa, + mac => sha256,prf => sha256}, + #{cipher => aes_128_cbc,key_exchange => ecdh_ecdsa,mac => sha, + prf => default_prf}] + </code> + + <p> Make some particular suites the most preferred, or least + preferred by changing prepend to append.</p> + <code type="erl"> 4>ssl:prepend_cipher_suites(Suites, Default). + [#{cipher => aes_128_cbc,key_exchange => ecdh_ecdsa, + mac => sha256,prf => sha256}, + #{cipher => aes_128_cbc,key_exchange => ecdh_ecdsa,mac => sha, + prf => default_prf}, + #{cipher => aes_256_cbc,key_exchange => ecdhe_ecdsa, + mac => sha384,prf => sha384}, ...] + </code> + </section> + + <section> <title>Using an Engine Stored Key</title> <p>Erlang ssl application is able to use private keys provided diff --git a/lib/ssl/src/dtls_connection.erl b/lib/ssl/src/dtls_connection.erl index 3b5a548f72..fb12a729b1 100644 --- a/lib/ssl/src/dtls_connection.erl +++ b/lib/ssl/src/dtls_connection.erl @@ -759,10 +759,12 @@ initial_state(Role, Host, Port, Socket, {SSLOptions, SocketOptions, _}, User, flight_state = {retransmit, ?INITIAL_RETRANSMIT_TIMEOUT} }. -next_dtls_record(Data, #state{protocol_buffers = #protocol_buffers{ +next_dtls_record(Data, StateName, #state{protocol_buffers = #protocol_buffers{ dtls_record_buffer = Buf0, dtls_cipher_texts = CT0} = Buffers} = State0) -> - case dtls_record:get_dtls_records(Data, Buf0) of + case dtls_record:get_dtls_records(Data, + acceptable_record_versions(StateName, State0), + Buf0) of {Records, Buf1} -> CT1 = CT0 ++ Records, next_record(State0#state{protocol_buffers = @@ -772,6 +774,11 @@ next_dtls_record(Data, #state{protocol_buffers = #protocol_buffers{ Alert end. +acceptable_record_versions(hello, _) -> + [dtls_record:protocol_version(Vsn) || Vsn <- ?ALL_DATAGRAM_SUPPORTED_VERSIONS]; +acceptable_record_versions(_, #state{negotiated_version = Version}) -> + [Version]. + dtls_handshake_events(Packets) -> lists:map(fun(Packet) -> {next_event, internal, {handshake, Packet}} @@ -829,7 +836,7 @@ handle_client_hello(#client_hello{client_version = ClientVersion} = Hello, %% raw data from socket, unpack records handle_info({Protocol, _, _, _, Data}, StateName, #state{data_tag = Protocol} = State0) -> - case next_dtls_record(Data, State0) of + case next_dtls_record(Data, StateName, State0) of {Record, State} -> next_event(StateName, Record, State); #alert{} = Alert -> diff --git a/lib/ssl/src/dtls_record.erl b/lib/ssl/src/dtls_record.erl index 2dcc6efc91..316de05532 100644 --- a/lib/ssl/src/dtls_record.erl +++ b/lib/ssl/src/dtls_record.erl @@ -30,7 +30,7 @@ -include("ssl_cipher.hrl"). %% Handling of incoming data --export([get_dtls_records/2, init_connection_states/2, empty_connection_state/1]). +-export([get_dtls_records/3, init_connection_states/2, empty_connection_state/1]). -export([save_current_connection_state/2, next_epoch/2, get_connection_state_by_epoch/3, replay_detect/2, init_connection_state_seq/2, current_connection_state_epoch/2]). @@ -163,17 +163,25 @@ current_connection_state_epoch(#{current_write := #{epoch := Epoch}}, Epoch. %%-------------------------------------------------------------------- --spec get_dtls_records(binary(), binary()) -> {[binary()], binary()} | #alert{}. +-spec get_dtls_records(binary(), [dtls_version()], binary()) -> {[binary()], binary()} | #alert{}. %% %% Description: Given old buffer and new data from UDP/SCTP, packs up a records %% and returns it as a list of tls_compressed binaries also returns leftover %% data %%-------------------------------------------------------------------- -get_dtls_records(Data, <<>>) -> - get_dtls_records_aux(Data, []); -get_dtls_records(Data, Buffer) -> - get_dtls_records_aux(list_to_binary([Buffer, Data]), []). - +get_dtls_records(Data, Versions, Buffer) -> + BinData = list_to_binary([Buffer, Data]), + case erlang:byte_size(BinData) of + N when N >= 3 -> + case assert_version(BinData, Versions) of + true -> + get_dtls_records_aux(BinData, []); + false -> + ?ALERT_REC(?FATAL, ?BAD_RECORD_MAC) + end; + _ -> + get_dtls_records_aux(BinData, []) + end. %%==================================================================== %% Encoding DTLS records @@ -397,6 +405,8 @@ initial_connection_state(ConnectionEnd, BeastMitigation) -> client_verify_data => undefined, server_verify_data => undefined }. +assert_version(<<?BYTE(_), ?BYTE(MajVer), ?BYTE(MinVer), _/binary>>, Versions) -> + is_acceptable_version({MajVer, MinVer}, Versions). get_dtls_records_aux(<<?BYTE(?APPLICATION_DATA),?BYTE(MajVer),?BYTE(MinVer), ?UINT16(Epoch), ?UINT48(SequenceNumber), @@ -431,15 +441,11 @@ get_dtls_records_aux(<<?BYTE(?CHANGE_CIPHER_SPEC),?BYTE(MajVer),?BYTE(MinVer), epoch = Epoch, sequence_number = SequenceNumber, fragment = Data} | Acc]); -get_dtls_records_aux(<<0:1, _CT:7, ?BYTE(_MajVer), ?BYTE(_MinVer), +get_dtls_records_aux(<<?BYTE(_), ?BYTE(_MajVer), ?BYTE(_MinVer), ?UINT16(Length), _/binary>>, _Acc) when Length > ?MAX_CIPHER_TEXT_LENGTH -> ?ALERT_REC(?FATAL, ?RECORD_OVERFLOW); -get_dtls_records_aux(<<1:1, Length0:15, _/binary>>,_Acc) - when Length0 > ?MAX_CIPHER_TEXT_LENGTH -> - ?ALERT_REC(?FATAL, ?RECORD_OVERFLOW); - get_dtls_records_aux(Data, Acc) -> case size(Data) =< ?MAX_CIPHER_TEXT_LENGTH + ?INITIAL_BYTES of true -> diff --git a/lib/ssl/src/dtls_v1.erl b/lib/ssl/src/dtls_v1.erl index 51ee8ec047..0f6344b6f7 100644 --- a/lib/ssl/src/dtls_v1.erl +++ b/lib/ssl/src/dtls_v1.erl @@ -21,7 +21,7 @@ -include("ssl_cipher.hrl"). --export([suites/1, all_suites/1, hmac_hash/3, ecc_curves/1, +-export([suites/1, all_suites/1, anonymous_suites/1,hmac_hash/3, ecc_curves/1, corresponding_tls_version/1, corresponding_dtls_version/1, cookie_secret/0, cookie_timeout/0]). @@ -40,6 +40,12 @@ all_suites(Version) -> end, ssl_cipher:all_suites(corresponding_tls_version(Version))). +anonymous_suites(Version) -> + lists:filter(fun(Cipher) -> + is_acceptable_cipher(ssl_cipher:suite_definition(Cipher)) + end, + ssl_cipher:anonymous_suites(corresponding_tls_version(Version))). + hmac_hash(MacAlg, MacSecret, Value) -> tls_v1:hmac_hash(MacAlg, MacSecret, Value). diff --git a/lib/ssl/src/ssl.erl b/lib/ssl/src/ssl.erl index 656ed94ea5..0b035d31be 100644 --- a/lib/ssl/src/ssl.erl +++ b/lib/ssl/src/ssl.erl @@ -39,7 +39,9 @@ ]). %% SSL/TLS protocol handling --export([cipher_suites/0, cipher_suites/1, eccs/0, eccs/1, versions/0, +-export([cipher_suites/0, cipher_suites/1, cipher_suites/2, filter_cipher_suites/2, + prepend_cipher_suites/2, append_cipher_suites/2, + eccs/0, eccs/1, versions/0, format_error/1, renegotiate/1, prf/5, negotiated_protocol/1, connection_information/1, connection_information/2]). %% Misc @@ -379,19 +381,93 @@ negotiated_protocol(#sslsocket{pid = Pid}) -> cipher_suites() -> cipher_suites(erlang). %%-------------------------------------------------------------------- --spec cipher_suites(erlang | openssl | all) -> [ssl_cipher:old_erl_cipher_suite() | string()]. +-spec cipher_suites(erlang | openssl | all) -> + [ssl_cipher:old_erl_cipher_suite() | string()]. %% Description: Returns all supported cipher suites. %%-------------------------------------------------------------------- cipher_suites(erlang) -> [ssl_cipher:erl_suite_definition(Suite) || Suite <- available_suites(default)]; cipher_suites(openssl) -> - [ssl_cipher:openssl_suite_name(Suite) || Suite <- available_suites(default)]; + [ssl_cipher:openssl_suite_name(Suite) || + Suite <- available_suites(default)]; cipher_suites(all) -> [ssl_cipher:erl_suite_definition(Suite) || Suite <- available_suites(all)]. %%-------------------------------------------------------------------- +-spec cipher_suites(default | all | anonymous, tls_record:tls_version() | dtls_record:dtls_version() | + tls_record:tls_atom_version() | dtls_record:dtls_atom_version()) -> + [ssl_cipher:erl_cipher_suite()]. +%% Description: Returns all default and all supported cipher suites for a +%% TLS/DTLS version +%%-------------------------------------------------------------------- +cipher_suites(Base, Version) when Version == 'tlsv1.2'; + Version == 'tlsv1.1'; + Version == tlsv1; + Version == sslv3 -> + cipher_suites(Base, tls_record:protocol_version(Version)); +cipher_suites(Base, Version) when Version == 'dtlsv1.2'; + Version == 'dtlsv1'-> + cipher_suites(Base, dtls_record:protocol_version(Version)); +cipher_suites(Base, Version) -> + [ssl_cipher:suite_definition(Suite) || Suite <- supported_suites(Base, Version)]. + +%%-------------------------------------------------------------------- +-spec filter_cipher_suites([ssl_cipher:erl_cipher_suite()], + [{key_exchange | cipher | mac | prf, fun()}] | []) -> + [ssl_cipher:erl_cipher_suite()]. +%% Description: Removes cipher suites if any of the filter functions returns false +%% for any part of the cipher suite. This function also calls default filter functions +%% to make sure the cipher suite are supported by crypto. +%%-------------------------------------------------------------------- +filter_cipher_suites(Suites, Filters0) -> + #{key_exchange_filters := KexF, + cipher_filters := CipherF, + mac_filters := MacF, + prf_filters := PrfF} + = ssl_cipher:crypto_support_filters(), + Filters = #{key_exchange_filters => add_filter(proplists:get_value(key_exchange, Filters0), KexF), + cipher_filters => add_filter(proplists:get_value(cipher, Filters0), CipherF), + mac_filters => add_filter(proplists:get_value(mac, Filters0), MacF), + prf_filters => add_filter(proplists:get_value(prf, Filters0), PrfF)}, + ssl_cipher:filter_suites(Suites, Filters). +%%-------------------------------------------------------------------- +-spec prepend_cipher_suites([ssl_cipher:erl_cipher_suite()] | + [{key_exchange | cipher | mac | prf, fun()}], + [ssl_cipher:erl_cipher_suite()]) -> + [ssl_cipher:erl_cipher_suite()]. +%% Description: Make <Preferred> suites become the most prefered +%% suites that is put them at the head of the cipher suite list +%% and remove them from <Suites> if present. <Preferred> may be a +%% list of cipher suits or a list of filters in which case the +%% filters are use on Suites to extract the the preferred +%% cipher list. +%% -------------------------------------------------------------------- +prepend_cipher_suites([First | _] = Preferred, Suites0) when is_map(First) -> + Suites = Preferred ++ (Suites0 -- Preferred), + Suites; +prepend_cipher_suites(Filters, Suites) -> + Preferred = filter_cipher_suites(Suites, Filters), + Preferred ++ (Suites -- Preferred). +%%-------------------------------------------------------------------- +-spec append_cipher_suites(Deferred :: [ssl_cipher:erl_cipher_suite()] | + [{key_exchange | cipher | mac | prf, fun()}], + [ssl_cipher:erl_cipher_suite()]) -> + [ssl_cipher:erl_cipher_suite()]. +%% Description: Make <Deferred> suites suites become the +%% least prefered suites that is put them at the end of the cipher suite list +%% and removed them from <Suites> if present. +%% +%%-------------------------------------------------------------------- +append_cipher_suites([First | _] = Deferred, Suites0) when is_map(First)-> + Suites = (Suites0 -- Deferred) ++ Deferred, + Suites; +append_cipher_suites(Filters, Suites) -> + Deferred = filter_cipher_suites(Suites, Filters), + (Suites -- Deferred) ++ Deferred. + +%%-------------------------------------------------------------------- -spec eccs() -> tls_v1:curves(). %% Description: returns all supported curves across all versions %%-------------------------------------------------------------------- @@ -410,6 +486,11 @@ eccs({3,0}) -> eccs({3,_}) -> Curves = tls_v1:ecc_curves(all), eccs_filter_supported(Curves); +eccs({_,_} = DTLSVersion) -> + eccs(dtls_v1:corresponding_tls_version(DTLSVersion)); +eccs(DTLSAtomVersion) when DTLSAtomVersion == 'dtlsv1'; + DTLSAtomVersion == 'dtlsv2' -> + eccs(dtls_record:protocol_version(DTLSAtomVersion)); eccs(AtomVersion) when is_atom(AtomVersion) -> eccs(tls_record:protocol_version(AtomVersion)). @@ -542,16 +623,23 @@ sockname(#sslsocket{pid = Pid, fd = {Transport, Socket, _, _}}) when is_pid(Pid) %%--------------------------------------------------------------- -spec versions() -> [{ssl_app, string()} | {supported, [tls_record:tls_atom_version()]} | - {available, [tls_record:tls_atom_version()]}]. + {supported_dtls, [dtls_record:dtls_atom_version()]} | + {available, [tls_record:tls_atom_version()]} | + {available_dtls, [dtls_record:dtls_atom_version()]}]. %% %% Description: Returns a list of relevant versions. %%-------------------------------------------------------------------- versions() -> - Vsns = tls_record:supported_protocol_versions(), - SupportedVsns = [tls_record:protocol_version(Vsn) || Vsn <- Vsns], - AvailableVsns = ?ALL_AVAILABLE_VERSIONS, - %% TODO Add DTLS versions when supported - [{ssl_app, ?VSN}, {supported, SupportedVsns}, {available, AvailableVsns}]. + TLSVsns = tls_record:supported_protocol_versions(), + DTLSVsns = dtls_record:supported_protocol_versions(), + SupportedTLSVsns = [tls_record:protocol_version(Vsn) || Vsn <- TLSVsns], + SupportedDTLSVsns = [dtls_record:protocol_version(Vsn) || Vsn <- DTLSVsns], + AvailableTLSVsns = ?ALL_AVAILABLE_VERSIONS, + AvailableDTLSVsns = ?ALL_AVAILABLE_DATAGRAM_VERSIONS, + [{ssl_app, ?VSN}, {supported, SupportedTLSVsns}, + {supported_dtls, SupportedDTLSVsns}, + {available, AvailableTLSVsns}, + {available_dtls, AvailableDTLSVsns}]. %%--------------------------------------------------------------- @@ -631,16 +719,21 @@ tls_version({254, _} = Version) -> %%%-------------------------------------------------------------- %%% Internal functions %%%-------------------------------------------------------------------- - %% Possible filters out suites not supported by crypto available_suites(default) -> Version = tls_record:highest_protocol_version([]), ssl_cipher:filter_suites(ssl_cipher:suites(Version)); - available_suites(all) -> Version = tls_record:highest_protocol_version([]), ssl_cipher:filter_suites(ssl_cipher:all_suites(Version)). +supported_suites(default, Version) -> + ssl_cipher:suites(Version); +supported_suites(all, Version) -> + ssl_cipher:all_suites(Version); +supported_suites(anonymous, Version) -> + ssl_cipher:anonymous_suites(Version). + do_listen(Port, #config{transport_info = {Transport, _, _, _}} = Config, tls_connection) -> tls_socket:listen(Transport, Port, Config); @@ -1150,17 +1243,21 @@ handle_cipher_option(Value, Version) when is_list(Value) -> binary_cipher_suites(Version, []) -> %% Defaults to all supported suites that does %% not require explicit configuration - ssl_cipher:filter_suites(ssl_cipher:suites(tls_version(Version))); + default_binary_suites(Version); +binary_cipher_suites(Version, [Map|_] = Ciphers0) when is_map(Map) -> + Ciphers = [ssl_cipher:suite(C) || C <- Ciphers0], + binary_cipher_suites(Version, Ciphers); binary_cipher_suites(Version, [Tuple|_] = Ciphers0) when is_tuple(Tuple) -> Ciphers = [ssl_cipher:suite(tuple_to_map(C)) || C <- Ciphers0], binary_cipher_suites(Version, Ciphers); binary_cipher_suites(Version, [Cipher0 | _] = Ciphers0) when is_binary(Cipher0) -> - All = ssl_cipher:all_suites(tls_version(Version)), + All = ssl_cipher:all_suites(Version) ++ + ssl_cipher:anonymous_suites(Version), case [Cipher || Cipher <- Ciphers0, lists:member(Cipher, All)] of [] -> %% Defaults to all supported suites that does %% not require explicit configuration - ssl_cipher:filter_suites(ssl_cipher:suites(tls_version(Version))); + default_binary_suites(Version); Ciphers -> Ciphers end; @@ -1173,6 +1270,9 @@ binary_cipher_suites(Version, Ciphers0) -> Ciphers = [ssl_cipher:openssl_suite(C) || C <- string:lexemes(Ciphers0, ":")], binary_cipher_suites(Version, Ciphers). +default_binary_suites(Version) -> + ssl_cipher:filter_suites(ssl_cipher:suites(Version)). + tuple_to_map({Kex, Cipher, Mac}) -> #{key_exchange => Kex, cipher => Cipher, @@ -1181,9 +1281,19 @@ tuple_to_map({Kex, Cipher, Mac}) -> tuple_to_map({Kex, Cipher, Mac, Prf}) -> #{key_exchange => Kex, cipher => Cipher, - mac => Mac, + mac => tuple_to_map_mac(Cipher, Mac), prf => Prf}. +%% Backwards compatible +tuple_to_map_mac(aes_128_gcm, _) -> + aead; +tuple_to_map_mac(aes_256_gcm, _) -> + aead; +tuple_to_map_mac(chacha20_poly1305, _) -> + aead; +tuple_to_map_mac(_, MAC) -> + MAC. + handle_eccs_option(Value, Version) when is_list(Value) -> {_Major, Minor} = tls_version(Version), try tls_v1:ecc_curves(Minor, Value) of @@ -1462,3 +1572,8 @@ reject_alpn_next_prot_options([Opt| AlpnNextOpts], Opts) -> false -> reject_alpn_next_prot_options(AlpnNextOpts, Opts) end. + +add_filter(undefined, Filters) -> + Filters; +add_filter(Filter, Filters) -> + [Filter | Filters]. diff --git a/lib/ssl/src/ssl_cipher.erl b/lib/ssl/src/ssl_cipher.erl index dba8e5a311..1d645e5782 100644 --- a/lib/ssl/src/ssl_cipher.erl +++ b/lib/ssl/src/ssl_cipher.erl @@ -36,9 +36,11 @@ -export([security_parameters/2, security_parameters/3, suite_definition/1, erl_suite_definition/1, cipher_init/3, decipher/6, cipher/5, decipher_aead/6, cipher_aead/6, - suite/1, suites/1, all_suites/1, - ec_keyed_suites/0, anonymous_suites/1, psk_suites/1, srp_suites/0, - rc4_suites/1, des_suites/1, rsa_suites/1, openssl_suite/1, openssl_suite_name/1, filter/2, filter_suites/1, + suite/1, suites/1, all_suites/1, crypto_support_filters/0, + ec_keyed_suites/0, chacha_suites/1, anonymous_suites/1, psk_suites/1, psk_suites_anon/1, + srp_suites/0, srp_suites_anon/0, + rc4_suites/1, des_suites/1, rsa_suites/1, openssl_suite/1, openssl_suite_name/1, + filter/2, filter_suites/1, filter_suites/2, hash_algorithm/1, sign_algorithm/1, is_acceptable_hash/2, is_fallback/1, random_bytes/1, calc_mac_hash/4, is_stream_ciphersuite/1]). @@ -53,7 +55,7 @@ -type key_algo() :: null | rsa | dhe_rsa | dhe_dss | ecdhe_ecdsa| ecdh_ecdsa | ecdh_rsa| srp_rsa| srp_dss | psk | dhe_psk | rsa_psk | dh_anon | ecdh_anon | srp_anon. -type erl_cipher_suite() :: #{key_exchange := key_algo(), cipher := cipher(), - mac := hash(), + mac := hash() | aead, prf := hash() | default_prf %% Old cipher suites, version dependent }. -type old_erl_cipher_suite() :: {key_algo(), cipher(), hash()} % Pre TLS 1.2 @@ -320,14 +322,28 @@ suites({_, Minor}) -> all_suites({3, _} = Version) -> suites(Version) - ++ anonymous_suites(Version) + ++ chacha_suites(Version) ++ psk_suites(Version) ++ srp_suites() ++ rc4_suites(Version) ++ des_suites(Version) ++ rsa_suites(Version); + all_suites(Version) -> dtls_v1:all_suites(Version). +%%-------------------------------------------------------------------- +-spec chacha_suites(ssl_record:ssl_version() | integer()) -> [cipher_suite()]. +%% +%% Description: Returns list of the chacha cipher suites, only supported +%% if explicitly set by user for now due to interop problems, proably need +%% to be fixed in crypto. +%%-------------------------------------------------------------------- +chacha_suites({3, _}) -> + [?TLS_ECDHE_ECDSA_WITH_CHACHA20_POLY1305_SHA256, + ?TLS_ECDHE_RSA_WITH_CHACHA20_POLY1305_SHA256, + ?TLS_DHE_RSA_WITH_CHACHA20_POLY1305_SHA256]; +chacha_suites(_) -> + []. %%-------------------------------------------------------------------- -spec anonymous_suites(ssl_record:ssl_version() | integer()) -> [cipher_suite()]. @@ -335,14 +351,13 @@ all_suites(Version) -> %% Description: Returns a list of the anonymous cipher suites, only supported %% if explicitly set by user. Intended only for testing. %%-------------------------------------------------------------------- - anonymous_suites({3, N}) -> - anonymous_suites(N); + srp_suites_anon() ++ anonymous_suites(N); anonymous_suites({254, _} = Version) -> - anonymous_suites(dtls_v1:corresponding_tls_version(Version)) - -- [?TLS_DH_anon_WITH_RC4_128_MD5]; + dtls_v1:anonymous_suites(Version); anonymous_suites(N) when N >= 3 -> + psk_suites_anon(N) ++ [?TLS_DH_anon_WITH_AES_128_GCM_SHA256, ?TLS_DH_anon_WITH_AES_256_GCM_SHA384, ?TLS_DH_anon_WITH_AES_128_CBC_SHA256, @@ -351,20 +366,20 @@ anonymous_suites(N) ?TLS_ECDH_anon_WITH_AES_256_CBC_SHA, ?TLS_ECDH_anon_WITH_3DES_EDE_CBC_SHA, ?TLS_DH_anon_WITH_RC4_128_MD5]; - -anonymous_suites(2) -> +anonymous_suites(2 = N) -> + psk_suites_anon(N) ++ [?TLS_ECDH_anon_WITH_AES_128_CBC_SHA, ?TLS_ECDH_anon_WITH_AES_256_CBC_SHA, ?TLS_ECDH_anon_WITH_3DES_EDE_CBC_SHA, ?TLS_DH_anon_WITH_DES_CBC_SHA, ?TLS_DH_anon_WITH_RC4_128_MD5]; - anonymous_suites(N) when N == 0; N == 1 -> - [?TLS_DH_anon_WITH_RC4_128_MD5, - ?TLS_DH_anon_WITH_3DES_EDE_CBC_SHA, - ?TLS_DH_anon_WITH_DES_CBC_SHA - ]. + psk_suites_anon(N) ++ + [?TLS_DH_anon_WITH_RC4_128_MD5, + ?TLS_DH_anon_WITH_3DES_EDE_CBC_SHA, + ?TLS_DH_anon_WITH_DES_CBC_SHA + ]. %%-------------------------------------------------------------------- -spec psk_suites(ssl_record:ssl_version() | integer()) -> [cipher_suite()]. @@ -377,41 +392,52 @@ psk_suites({3, N}) -> psk_suites(N) when N >= 3 -> [ - ?TLS_ECDHE_PSK_WITH_AES_256_GCM_SHA384, - ?TLS_DHE_PSK_WITH_AES_256_GCM_SHA384, ?TLS_RSA_PSK_WITH_AES_256_GCM_SHA384, + ?TLS_RSA_PSK_WITH_AES_256_CBC_SHA384, + ?TLS_RSA_PSK_WITH_AES_128_GCM_SHA256, + ?TLS_RSA_PSK_WITH_AES_128_CBC_SHA256 + ] ++ psk_suites(0); +psk_suites(_) -> + [?TLS_RSA_PSK_WITH_AES_256_CBC_SHA, + ?TLS_RSA_PSK_WITH_AES_128_CBC_SHA, + ?TLS_RSA_PSK_WITH_3DES_EDE_CBC_SHA, + ?TLS_RSA_PSK_WITH_RC4_128_SHA]. + +%%-------------------------------------------------------------------- +-spec psk_suites_anon(ssl_record:ssl_version() | integer()) -> [cipher_suite()]. +%% +%% Description: Returns a list of the anonymous PSK cipher suites, only supported +%% if explicitly set by user. +%%-------------------------------------------------------------------- +psk_suites_anon({3, N}) -> + psk_suites_anon(N); +psk_suites_anon(N) + when N >= 3 -> + [ + ?TLS_DHE_PSK_WITH_AES_256_GCM_SHA384, ?TLS_PSK_WITH_AES_256_GCM_SHA384, ?TLS_ECDHE_PSK_WITH_AES_256_CBC_SHA384, ?TLS_DHE_PSK_WITH_AES_256_CBC_SHA384, - ?TLS_RSA_PSK_WITH_AES_256_CBC_SHA384, ?TLS_PSK_WITH_AES_256_CBC_SHA384, ?TLS_ECDHE_PSK_WITH_AES_128_GCM_SHA256, ?TLS_DHE_PSK_WITH_AES_128_GCM_SHA256, - ?TLS_RSA_PSK_WITH_AES_128_GCM_SHA256, ?TLS_PSK_WITH_AES_128_GCM_SHA256, ?TLS_ECDHE_PSK_WITH_AES_128_CBC_SHA256, ?TLS_DHE_PSK_WITH_AES_128_CBC_SHA256, - ?TLS_RSA_PSK_WITH_AES_128_CBC_SHA256, ?TLS_PSK_WITH_AES_128_CBC_SHA256 - ] ++ psk_suites(0); -psk_suites(_) -> - [?TLS_ECDHE_PSK_WITH_AES_256_CBC_SHA, - ?TLS_DHE_PSK_WITH_AES_256_CBC_SHA, - ?TLS_RSA_PSK_WITH_AES_256_CBC_SHA, + ] ++ psk_suites_anon(0); +psk_suites_anon(_) -> + [?TLS_DHE_PSK_WITH_AES_256_CBC_SHA, ?TLS_PSK_WITH_AES_256_CBC_SHA, ?TLS_ECDHE_PSK_WITH_AES_128_CBC_SHA, ?TLS_DHE_PSK_WITH_AES_128_CBC_SHA, - ?TLS_RSA_PSK_WITH_AES_128_CBC_SHA, ?TLS_PSK_WITH_AES_128_CBC_SHA, ?TLS_ECDHE_PSK_WITH_3DES_EDE_CBC_SHA, ?TLS_DHE_PSK_WITH_3DES_EDE_CBC_SHA, - ?TLS_RSA_PSK_WITH_3DES_EDE_CBC_SHA, ?TLS_PSK_WITH_3DES_EDE_CBC_SHA, ?TLS_ECDHE_PSK_WITH_RC4_128_SHA, ?TLS_DHE_PSK_WITH_RC4_128_SHA, - ?TLS_RSA_PSK_WITH_RC4_128_SHA, ?TLS_PSK_WITH_RC4_128_SHA]. - %%-------------------------------------------------------------------- -spec srp_suites() -> [cipher_suite()]. %% @@ -419,15 +445,24 @@ psk_suites(_) -> %% if explicitly set by user. %%-------------------------------------------------------------------- srp_suites() -> - [?TLS_SRP_SHA_WITH_3DES_EDE_CBC_SHA, - ?TLS_SRP_SHA_RSA_WITH_3DES_EDE_CBC_SHA, + [?TLS_SRP_SHA_RSA_WITH_3DES_EDE_CBC_SHA, ?TLS_SRP_SHA_DSS_WITH_3DES_EDE_CBC_SHA, - ?TLS_SRP_SHA_WITH_AES_128_CBC_SHA, ?TLS_SRP_SHA_RSA_WITH_AES_128_CBC_SHA, ?TLS_SRP_SHA_DSS_WITH_AES_128_CBC_SHA, - ?TLS_SRP_SHA_WITH_AES_256_CBC_SHA, ?TLS_SRP_SHA_RSA_WITH_AES_256_CBC_SHA, ?TLS_SRP_SHA_DSS_WITH_AES_256_CBC_SHA]. + +%%-------------------------------------------------------------------- +-spec srp_suites_anon() -> [cipher_suite()]. +%% +%% Description: Returns a list of the SRP anonymous cipher suites, only supported +%% if explicitly set by user. +%%-------------------------------------------------------------------- +srp_suites_anon() -> + [?TLS_SRP_SHA_WITH_3DES_EDE_CBC_SHA, + ?TLS_SRP_SHA_WITH_AES_128_CBC_SHA, + ?TLS_SRP_SHA_WITH_AES_256_CBC_SHA]. + %%-------------------------------------------------------------------- -spec rc4_suites(Version::ssl_record:ssl_version() | integer()) -> [cipher_suite()]. %% @@ -457,7 +492,14 @@ rc4_suites(N) when N =< 3 -> %%-------------------------------------------------------------------- des_suites(_)-> [?TLS_DHE_RSA_WITH_DES_CBC_SHA, - ?TLS_RSA_WITH_DES_CBC_SHA]. + ?TLS_RSA_WITH_DES_CBC_SHA, + ?TLS_ECDHE_ECDSA_WITH_3DES_EDE_CBC_SHA, + ?TLS_ECDHE_RSA_WITH_3DES_EDE_CBC_SHA, + ?TLS_DHE_RSA_WITH_3DES_EDE_CBC_SHA, + ?TLS_DHE_DSS_WITH_3DES_EDE_CBC_SHA, + ?TLS_ECDH_ECDSA_WITH_3DES_EDE_CBC_SHA, + ?TLS_ECDH_RSA_WITH_3DES_EDE_CBC_SHA + ]. %%-------------------------------------------------------------------- -spec rsa_suites(Version::ssl_record:ssl_version() | integer()) -> [cipher_suite()]. @@ -730,32 +772,32 @@ suite_definition(?TLS_RSA_PSK_WITH_NULL_SHA) -> suite_definition(?TLS_PSK_WITH_AES_128_GCM_SHA256) -> #{key_exchange => psk, cipher => aes_128_gcm, - mac => null, + mac => aead, prf => sha256}; suite_definition(?TLS_PSK_WITH_AES_256_GCM_SHA384) -> #{key_exchange => psk, cipher => aes_256_gcm, - mac => null, + mac => aead, prf => sha384}; suite_definition(?TLS_DHE_PSK_WITH_AES_128_GCM_SHA256) -> #{key_exchange => dhe_psk, cipher => aes_128_gcm, - mac => null, + mac => aead, prf => sha256}; suite_definition(?TLS_DHE_PSK_WITH_AES_256_GCM_SHA384) -> #{key_exchange => dhe_psk, cipher => aes_256_gcm, - mac => null, + mac => aead, prf => sha384}; suite_definition(?TLS_RSA_PSK_WITH_AES_128_GCM_SHA256) -> #{key_exchange => rsa_psk, cipher => aes_128_gcm, - mac => null, + mac => aead, prf => sha256}; suite_definition(?TLS_RSA_PSK_WITH_AES_256_GCM_SHA384) -> #{key_exchange => rsa_psk, cipher => aes_256_gcm, - mac => null, + mac => aead, prf => sha384}; suite_definition(?TLS_PSK_WITH_AES_128_CBC_SHA256) -> #{key_exchange => psk, @@ -1095,42 +1137,42 @@ suite_definition(?TLS_ECDH_RSA_WITH_AES_256_CBC_SHA384) -> suite_definition(?TLS_RSA_WITH_AES_128_GCM_SHA256) -> #{key_exchange => rsa, cipher => aes_128_gcm, - mac => null, + mac => aead, prf => sha256}; suite_definition(?TLS_RSA_WITH_AES_256_GCM_SHA384) -> #{key_exchange => rsa, cipher => aes_256_gcm, - mac => null, + mac => aead, prf => sha384}; suite_definition(?TLS_DHE_RSA_WITH_AES_128_GCM_SHA256) -> #{key_exchange => dhe_rsa, cipher => aes_128_gcm, - mac => null, + mac => aead, prf => sha256}; suite_definition(?TLS_DHE_RSA_WITH_AES_256_GCM_SHA384) -> #{key_exchange => dhe_rsa, cipher => aes_256_gcm, - mac => null, + mac => aead, prf => sha384}; suite_definition(?TLS_DH_RSA_WITH_AES_128_GCM_SHA256) -> #{key_exchange => dh_rsa, cipher => aes_128_gcm, - mac => null, + mac => aead, prf => sha256}; suite_definition(?TLS_DH_RSA_WITH_AES_256_GCM_SHA384) -> #{key_exchange => dh_rsa, cipher => aes_256_gcm, - mac => null, + mac => aead, prf => sha384}; suite_definition(?TLS_DHE_DSS_WITH_AES_128_GCM_SHA256) -> #{key_exchange => dhe_dss, cipher => aes_128_gcm, - mac => null, + mac => aead, prf => sha256}; suite_definition(?TLS_DHE_DSS_WITH_AES_256_GCM_SHA384) -> #{key_exchange => dhe_dss, cipher => aes_256_gcm, - mac => null, + mac => aead, prf => sha384}; suite_definition(?TLS_DH_DSS_WITH_AES_128_GCM_SHA256) -> #{key_exchange => dh_dss, @@ -1140,74 +1182,74 @@ suite_definition(?TLS_DH_DSS_WITH_AES_128_GCM_SHA256) -> suite_definition(?TLS_DH_DSS_WITH_AES_256_GCM_SHA384) -> #{key_exchange => dh_dss, cipher => aes_256_gcm, - mac => null, + mac => aead, prf => sha384}; suite_definition(?TLS_DH_anon_WITH_AES_128_GCM_SHA256) -> #{key_exchange => dh_anon, cipher => aes_128_gcm, - mac => null, + mac => aead, prf => sha256}; suite_definition(?TLS_DH_anon_WITH_AES_256_GCM_SHA384) -> #{key_exchange => dh_anon, cipher => aes_256_gcm, - mac => null, + mac => aead, prf => sha384}; %% RFC 5289 ECC AES-GCM Cipher Suites suite_definition(?TLS_ECDHE_ECDSA_WITH_AES_128_GCM_SHA256) -> #{key_exchange => ecdhe_ecdsa, cipher => aes_128_gcm, - mac => null, + mac => aead, prf => sha256}; suite_definition(?TLS_ECDHE_ECDSA_WITH_AES_256_GCM_SHA384) -> #{key_exchange => ecdhe_ecdsa, cipher => aes_256_gcm, - mac => null, + mac => aead, prf => sha384}; suite_definition(?TLS_ECDH_ECDSA_WITH_AES_128_GCM_SHA256) -> #{key_exchange => ecdh_ecdsa, cipher => aes_128_gcm, - mac => null, + mac => aead, prf => sha256}; suite_definition(?TLS_ECDH_ECDSA_WITH_AES_256_GCM_SHA384) -> #{key_exchange => ecdh_ecdsa, cipher => aes_256_gcm, - mac => null, + mac => aead, prf => sha384}; suite_definition(?TLS_ECDHE_RSA_WITH_AES_128_GCM_SHA256) -> #{key_exchange => ecdhe_rsa, cipher => aes_128_gcm, - mac => null, + mac => aead, prf => sha256}; suite_definition(?TLS_ECDHE_RSA_WITH_AES_256_GCM_SHA384) -> #{key_exchange => ecdhe_rsa, cipher => aes_256_gcm, - mac => null, + mac => aead, prf => sha384}; suite_definition(?TLS_ECDH_RSA_WITH_AES_128_GCM_SHA256) -> #{key_exchange => ecdh_rsa, cipher => aes_128_gcm, - mac => null, + mac => aead, prf => sha256}; suite_definition(?TLS_ECDH_RSA_WITH_AES_256_GCM_SHA384) -> #{key_exchange => ecdh_rsa, cipher => aes_256_gcm, - mac => null, + mac => aead, prf => sha384}; %% draft-agl-tls-chacha20poly1305-04 Chacha20/Poly1305 Suites suite_definition(?TLS_ECDHE_RSA_WITH_CHACHA20_POLY1305_SHA256) -> #{key_exchange => ecdhe_rsa, cipher => chacha20_poly1305, - mac => null, + mac => aead, prf => sha256}; suite_definition(?TLS_ECDHE_ECDSA_WITH_CHACHA20_POLY1305_SHA256) -> #{key_exchange => ecdhe_ecdsa, cipher => chacha20_poly1305, - mac => null, + mac => aead, prf => sha256}; suite_definition(?TLS_DHE_RSA_WITH_CHACHA20_POLY1305_SHA256) -> #{key_exchange => dhe_rsa, cipher => chacha20_poly1305, - mac => null, + mac => aead, prf => sha256}. %%-------------------------------------------------------------------- @@ -1408,32 +1450,32 @@ suite(#{key_exchange := rsa_psk, %%% TLS 1.2 PSK Cipher Suites RFC 5487 suite(#{key_exchange := psk, cipher := aes_128_gcm, - mac := null, + mac := aead, prf := sha256}) -> ?TLS_PSK_WITH_AES_128_GCM_SHA256; suite(#{key_exchange := psk, cipher := aes_256_gcm, - mac := null, + mac := aead, prf := sha384}) -> ?TLS_PSK_WITH_AES_256_GCM_SHA384; suite(#{key_exchange := dhe_psk, cipher := aes_128_gcm, - mac := null, + mac := aead, prf := sha256}) -> ?TLS_DHE_PSK_WITH_AES_128_GCM_SHA256; suite(#{key_exchange := dhe_psk, cipher := aes_256_gcm, - mac := null, + mac := aead, prf := sha384}) -> ?TLS_DHE_PSK_WITH_AES_256_GCM_SHA384; suite(#{key_exchange := rsa_psk, cipher := aes_128_gcm, - mac := null, + mac := aead, prf := sha256}) -> ?TLS_RSA_PSK_WITH_AES_128_GCM_SHA256; suite(#{key_exchange := rsa_psk, cipher := aes_256_gcm, - mac := null, + mac := aead, prf := sha384}) -> ?TLS_RSA_PSK_WITH_AES_256_GCM_SHA384; suite(#{key_exchange := psk, @@ -1719,119 +1761,119 @@ suite(#{key_exchange := ecdh_rsa, %% RFC 5288 AES-GCM Cipher Suites suite(#{key_exchange := rsa, cipher := aes_128_gcm, - mac := null, + mac := aead, prf := sha256}) -> ?TLS_RSA_WITH_AES_128_GCM_SHA256; suite(#{key_exchange := rsa, cipher := aes_256_gcm, - mac := null, + mac := aead, prf := sha384}) -> ?TLS_RSA_WITH_AES_256_GCM_SHA384; suite(#{key_exchange := dhe_rsa, cipher := aes_128_gcm, - mac := null, + mac := aead, prf := sha256}) -> ?TLS_DHE_RSA_WITH_AES_128_GCM_SHA256; suite(#{key_exchange := dhe_rsa, cipher := aes_256_gcm, - mac := null, + mac := aead, prf := sha384}) -> ?TLS_DHE_RSA_WITH_AES_256_GCM_SHA384; suite(#{key_exchange := dh_rsa, cipher := aes_128_gcm, - mac := null, + mac := aead, prf := sha256}) -> ?TLS_DH_RSA_WITH_AES_128_GCM_SHA256; suite(#{key_exchange := dh_rsa, cipher := aes_256_gcm, - mac := null, + mac := aead, prf := sha384}) -> ?TLS_DH_RSA_WITH_AES_256_GCM_SHA384; suite(#{key_exchange := dhe_dss, cipher := aes_128_gcm, - mac := null, + mac := aead, prf := sha256}) -> ?TLS_DHE_DSS_WITH_AES_128_GCM_SHA256; suite(#{key_exchange := dhe_dss, cipher := aes_256_gcm, - mac := null, + mac := aead, prf := sha384}) -> ?TLS_DHE_DSS_WITH_AES_256_GCM_SHA384; suite(#{key_exchange := dh_dss, cipher := aes_128_gcm, - mac := null, + mac := aead, prf := sha256}) -> ?TLS_DH_DSS_WITH_AES_128_GCM_SHA256; suite(#{key_exchange := dh_dss, cipher := aes_256_gcm, - mac := null, + mac := aead, prf := sha384}) -> ?TLS_DH_DSS_WITH_AES_256_GCM_SHA384; suite(#{key_exchange := dh_anon, cipher := aes_128_gcm, - mac := null, + mac := aead, prf := sha256}) -> ?TLS_DH_anon_WITH_AES_128_GCM_SHA256; suite(#{key_exchange := dh_anon, cipher := aes_256_gcm, - mac := null, + mac := aead, prf := sha384}) -> ?TLS_DH_anon_WITH_AES_256_GCM_SHA384; %% RFC 5289 ECC AES-GCM Cipher Suites suite(#{key_exchange := ecdhe_ecdsa, cipher := aes_128_gcm, - mac := null, + mac := aead, prf := sha256}) -> ?TLS_ECDHE_ECDSA_WITH_AES_128_GCM_SHA256; suite(#{key_exchange := ecdhe_ecdsa, cipher := aes_256_gcm, - mac := null, + mac := aead, prf := sha384}) -> ?TLS_ECDHE_ECDSA_WITH_AES_256_GCM_SHA384; suite(#{key_exchange := ecdh_ecdsa, cipher := aes_128_gcm, - mac := null, + mac := aead, prf := sha256}) -> ?TLS_ECDH_ECDSA_WITH_AES_128_GCM_SHA256; suite(#{key_exchange := ecdh_ecdsa, cipher := aes_256_gcm, - mac := null, + mac := aead, prf := sha384}) -> ?TLS_ECDH_ECDSA_WITH_AES_256_GCM_SHA384; suite(#{key_exchange := ecdhe_rsa, cipher := aes_128_gcm, - mac := null, + mac := aead, prf := sha256}) -> ?TLS_ECDHE_RSA_WITH_AES_128_GCM_SHA256; suite(#{key_exchange := ecdhe_rsa, cipher := aes_256_gcm, - mac := null, + mac := aead, prf := sha384}) -> ?TLS_ECDHE_RSA_WITH_AES_256_GCM_SHA384; suite(#{key_exchange := ecdh_rsa, cipher := aes_128_gcm, - mac := null, + mac := aead, prf := sha256}) -> ?TLS_ECDH_RSA_WITH_AES_128_GCM_SHA256; suite(#{key_exchange := ecdh_rsa, cipher := aes_256_gcm, - mac := null, + mac := aead, prf := sha384}) -> ?TLS_ECDH_RSA_WITH_AES_256_GCM_SHA384; %% draft-agl-tls-chacha20poly1305-04 Chacha20/Poly1305 Suites suite(#{key_exchange := ecdhe_rsa, cipher := chacha20_poly1305, - mac := null, + mac := aead, prf := sha256}) -> ?TLS_ECDHE_RSA_WITH_CHACHA20_POLY1305_SHA256; suite(#{key_exchange := ecdhe_ecdsa, cipher := chacha20_poly1305, - mac := null, + mac := aead, prf := sha256}) -> ?TLS_ECDHE_ECDSA_WITH_CHACHA20_POLY1305_SHA256; suite(#{key_exchange := dhe_rsa, cipher := chacha20_poly1305, - mac := null, + mac := aead, prf := sha256}) -> ?TLS_DHE_RSA_WITH_CHACHA20_POLY1305_SHA256. @@ -1991,9 +2033,9 @@ openssl_suite("ECDH-RSA-AES256-GCM-SHA384") -> ?TLS_ECDH_RSA_WITH_AES_256_GCM_SHA384. %%-------------------------------------------------------------------- --spec openssl_suite_name(cipher_suite()) -> openssl_cipher_suite(). +-spec openssl_suite_name(cipher_suite()) -> openssl_cipher_suite() | erl_cipher_suite(). %% -%% Description: Return openssl cipher suite name. +%% Description: Return openssl cipher suite name if possible %%------------------------------------------------------------------- openssl_suite_name(?TLS_DHE_RSA_WITH_AES_256_CBC_SHA) -> "DHE-RSA-AES256-SHA"; @@ -2203,38 +2245,74 @@ filter(DerCert, Ciphers) -> {_, ecdsa} -> Ciphers1 -- rsa_signed_suites() end. - %%-------------------------------------------------------------------- --spec filter_suites([cipher_suite()]) -> [cipher_suite()]. +-spec filter_suites([erl_cipher_suite()] | [cipher_suite()], map()) -> + [erl_cipher_suite()] | [cipher_suite()]. +%% +%% Description: Filter suites using supplied filter funs +%%------------------------------------------------------------------- +filter_suites(Suites, Filters) -> + ApplyFilters = fun(Suite) -> + filter_suite(Suite, Filters) + end, + lists:filter(ApplyFilters, Suites). + +filter_suite(#{key_exchange := KeyExchange, + cipher := Cipher, + mac := Hash, + prf := Prf}, + #{key_exchange_filters := KeyFilters, + cipher_filters := CipherFilters, + mac_filters := HashFilters, + prf_filters := PrfFilters}) -> + all_filters(KeyExchange, KeyFilters) andalso + all_filters(Cipher, CipherFilters) andalso + all_filters(Hash, HashFilters) andalso + all_filters(Prf, PrfFilters); +filter_suite(Suite, Filters) -> + filter_suite(suite_definition(Suite), Filters). + +%%-------------------------------------------------------------------- +-spec filter_suites([erl_cipher_suite()] | [cipher_suite()]) -> + [erl_cipher_suite()] | [cipher_suite()]. %% %% Description: Filter suites for algorithms supported by crypto. %%------------------------------------------------------------------- -filter_suites(Suites = [Value|_]) when is_map(Value) -> - Algos = crypto:supports(), - Hashs = proplists:get_value(hashs, Algos), - lists:filter(fun(#{key_exchange := KeyExchange, - cipher := Cipher, - mac := Hash, - prf := Prf}) -> - is_acceptable_keyexchange(KeyExchange, proplists:get_value(public_keys, Algos)) andalso - is_acceptable_cipher(Cipher, proplists:get_value(ciphers, Algos)) andalso - is_acceptable_hash(Hash, Hashs) andalso - is_acceptable_prf(Prf, Hashs) - end, Suites); - filter_suites(Suites) -> + Filters = crypto_support_filters(), + filter_suites(Suites, Filters). + +all_filters(_, []) -> + true; +all_filters(Value, [Filter| Rest]) -> + case Filter(Value) of + true -> + all_filters(Value, Rest); + false -> + false + end. +crypto_support_filters() -> Algos = crypto:supports(), Hashs = proplists:get_value(hashs, Algos), - lists:filter(fun(Suite) -> - #{key_exchange := KeyExchange, - cipher := Cipher, - mac := Hash, - prf := Prf} = suite_definition(Suite), - is_acceptable_keyexchange(KeyExchange, proplists:get_value(public_keys, Algos)) andalso - is_acceptable_cipher(Cipher, proplists:get_value(ciphers, Algos)) andalso - is_acceptable_hash(Hash, Hashs) andalso - is_acceptable_prf(Prf, Hashs) - end, Suites). + #{key_exchange_filters => + [fun(KeyExchange) -> + is_acceptable_keyexchange(KeyExchange, + proplists:get_value(public_keys, Algos)) + end], + cipher_filters => + [fun(Cipher) -> + is_acceptable_cipher(Cipher, + proplists:get_value(ciphers, Algos)) + end], + mac_filters => + [fun(Hash) -> + is_acceptable_hash(Hash, Hashs) + end], + prf_filters => + [fun(Prf) -> + is_acceptable_prf(Prf, + proplists:get_value(hashs, Algos)) + end]}. is_acceptable_keyexchange(KeyExchange, _Algos) when KeyExchange == psk; KeyExchange == null -> diff --git a/lib/ssl/src/ssl_connection.erl b/lib/ssl/src/ssl_connection.erl index d046145dff..2031735a71 100644 --- a/lib/ssl/src/ssl_connection.erl +++ b/lib/ssl/src/ssl_connection.erl @@ -1148,8 +1148,8 @@ handle_common_event(internal, #change_cipher_spec{type = <<1>>}, StateName, StateName, State); handle_common_event(_Type, Msg, StateName, #state{negotiated_version = Version} = State, _) -> - Alert = ?ALERT_REC(?FATAL,?UNEXPECTED_MESSAGE), - handle_own_alert(Alert, Version, {StateName, Msg}, State). + Alert = ?ALERT_REC(?FATAL,?UNEXPECTED_MESSAGE, {unexpected_msg, Msg}), + handle_own_alert(Alert, Version, StateName, State). handle_call({application_data, _Data}, _, _, _, _) -> %% In renegotiation priorities handshake, send data when handshake is finished diff --git a/lib/ssl/src/ssl_internal.hrl b/lib/ssl/src/ssl_internal.hrl index 9bb1cbaeb0..bbe1374fec 100644 --- a/lib/ssl/src/ssl_internal.hrl +++ b/lib/ssl/src/ssl_internal.hrl @@ -73,6 +73,7 @@ %% sslv3 is considered insecure due to lack of padding check (Poodle attack) %% Keep as interop with legacy software but do not support as default -define(ALL_AVAILABLE_VERSIONS, ['tlsv1.2', 'tlsv1.1', tlsv1, sslv3]). +-define(ALL_AVAILABLE_DATAGRAM_VERSIONS, ['dtlsv1.2', dtlsv1]). -define(ALL_SUPPORTED_VERSIONS, ['tlsv1.2', 'tlsv1.1', tlsv1]). -define(MIN_SUPPORTED_VERSIONS, ['tlsv1.1', tlsv1]). -define(ALL_DATAGRAM_SUPPORTED_VERSIONS, ['dtlsv1.2', dtlsv1]). diff --git a/lib/ssl/src/tls_connection.erl b/lib/ssl/src/tls_connection.erl index cf2f3a2b62..2872ca9fe5 100644 --- a/lib/ssl/src/tls_connection.erl +++ b/lib/ssl/src/tls_connection.erl @@ -640,18 +640,34 @@ initial_state(Role, Host, Port, Socket, {SSLOptions, SocketOptions, Tracker}, Us flight_buffer = [] }. -next_tls_record(Data, #state{protocol_buffers = #protocol_buffers{tls_record_buffer = Buf0, - tls_cipher_texts = CT0} = Buffers} = State0) -> - case tls_record:get_tls_records(Data, Buf0) of +next_tls_record(Data, StateName, #state{protocol_buffers = + #protocol_buffers{tls_record_buffer = Buf0, + tls_cipher_texts = CT0} = Buffers} + = State0) -> + case tls_record:get_tls_records(Data, + acceptable_record_versions(StateName, State0), + Buf0) of {Records, Buf1} -> CT1 = CT0 ++ Records, next_record(State0#state{protocol_buffers = Buffers#protocol_buffers{tls_record_buffer = Buf1, tls_cipher_texts = CT1}}); #alert{} = Alert -> - Alert + handle_record_alert(Alert, State0) end. +acceptable_record_versions(hello, #state{ssl_options = #ssl_options{v2_hello_compatible = true}}) -> + [tls_record:protocol_version(Vsn) || Vsn <- ?ALL_AVAILABLE_VERSIONS ++ ['sslv2']]; +acceptable_record_versions(hello, _) -> + [tls_record:protocol_version(Vsn) || Vsn <- ?ALL_AVAILABLE_VERSIONS]; +acceptable_record_versions(_, #state{negotiated_version = Version}) -> + [Version]. +handle_record_alert(#alert{description = ?BAD_RECORD_MAC}, + #state{ssl_options = #ssl_options{v2_hello_compatible = true}}) -> + ?ALERT_REC(?FATAL, ?PROTOCOL_VERSION); +handle_record_alert(Alert, _) -> + Alert. + tls_handshake_events(Packets) -> lists:map(fun(Packet) -> {next_event, internal, {handshake, Packet}} @@ -660,7 +676,7 @@ tls_handshake_events(Packets) -> %% raw data from socket, upack records handle_info({Protocol, _, Data}, StateName, #state{data_tag = Protocol} = State0) -> - case next_tls_record(Data, State0) of + case next_tls_record(Data, StateName, State0) of {Record, State} -> next_event(StateName, Record, State); #alert{} = Alert -> diff --git a/lib/ssl/src/tls_record.erl b/lib/ssl/src/tls_record.erl index ab179c1bf0..188ec6809d 100644 --- a/lib/ssl/src/tls_record.erl +++ b/lib/ssl/src/tls_record.erl @@ -32,7 +32,7 @@ -include("ssl_cipher.hrl"). %% Handling of incoming data --export([get_tls_records/2, init_connection_states/2]). +-export([get_tls_records/3, init_connection_states/2]). %% Encoding TLS records -export([encode_handshake/3, encode_alert_record/3, @@ -75,16 +75,25 @@ init_connection_states(Role, BeastMitigation) -> pending_write => Pending}. %%-------------------------------------------------------------------- --spec get_tls_records(binary(), binary()) -> {[binary()], binary()} | #alert{}. +-spec get_tls_records(binary(), [tls_version()], binary()) -> {[binary()], binary()} | #alert{}. %% %% and returns it as a list of tls_compressed binaries also returns leftover %% Description: Given old buffer and new data from TCP, packs up a records %% data %%-------------------------------------------------------------------- -get_tls_records(Data, <<>>) -> - get_tls_records_aux(Data, []); -get_tls_records(Data, Buffer) -> - get_tls_records_aux(list_to_binary([Buffer, Data]), []). +get_tls_records(Data, Versions, Buffer) -> + BinData = list_to_binary([Buffer, Data]), + case erlang:byte_size(BinData) of + N when N >= 3 -> + case assert_version(BinData, Versions) of + true -> + get_tls_records_aux(BinData, []); + false -> + ?ALERT_REC(?FATAL, ?BAD_RECORD_MAC) + end; + _ -> + get_tls_records_aux(BinData, []) + end. %%==================================================================== %% Encoding @@ -385,6 +394,19 @@ initial_connection_state(ConnectionEnd, BeastMitigation) -> server_verify_data => undefined }. +assert_version(<<1:1, Length0:15, Data0:Length0/binary, _/binary>>, Versions) -> + case Data0 of + <<?BYTE(?CLIENT_HELLO), ?BYTE(Major), ?BYTE(Minor), _/binary>> -> + %% First check v2_hello_compatible mode is active + lists:member({2,0}, Versions) andalso + %% andalso we want to negotiate higher version + lists:member({Major, Minor}, Versions -- [{2,0}]); + _ -> + false + end; +assert_version(<<?BYTE(_), ?BYTE(MajVer), ?BYTE(MinVer), _/binary>>, Versions) -> + is_acceptable_version({MajVer, MinVer}, Versions). + get_tls_records_aux(<<?BYTE(?APPLICATION_DATA),?BYTE(MajVer),?BYTE(MinVer), ?UINT16(Length), Data:Length/binary, Rest/binary>>, Acc) -> @@ -428,10 +450,9 @@ get_tls_records_aux(<<1:1, Length0:15, Data0:Length0/binary, Rest/binary>>, end; get_tls_records_aux(<<0:1, _CT:7, ?BYTE(_MajVer), ?BYTE(_MinVer), - ?UINT16(Length), _/binary>>, + ?UINT16(Length), _/binary>>, _Acc) when Length > ?MAX_CIPHER_TEXT_LENGTH -> ?ALERT_REC(?FATAL, ?RECORD_OVERFLOW); - get_tls_records_aux(<<1:1, Length0:15, _/binary>>,_Acc) when Length0 > ?MAX_CIPHER_TEXT_LENGTH -> ?ALERT_REC(?FATAL, ?RECORD_OVERFLOW); diff --git a/lib/ssl/src/tls_v1.erl b/lib/ssl/src/tls_v1.erl index af3f037477..a31ab8d044 100644 --- a/lib/ssl/src/tls_v1.erl +++ b/lib/ssl/src/tls_v1.erl @@ -208,14 +208,7 @@ suites(Minor) when Minor == 1; Minor == 2 -> ?TLS_DHE_RSA_WITH_AES_128_CBC_SHA, ?TLS_DHE_DSS_WITH_AES_128_CBC_SHA, ?TLS_ECDH_ECDSA_WITH_AES_128_CBC_SHA, - ?TLS_ECDH_RSA_WITH_AES_128_CBC_SHA, - - ?TLS_ECDHE_ECDSA_WITH_3DES_EDE_CBC_SHA, - ?TLS_ECDHE_RSA_WITH_3DES_EDE_CBC_SHA, - ?TLS_DHE_RSA_WITH_3DES_EDE_CBC_SHA, - ?TLS_DHE_DSS_WITH_3DES_EDE_CBC_SHA, - ?TLS_ECDH_ECDSA_WITH_3DES_EDE_CBC_SHA, - ?TLS_ECDH_RSA_WITH_3DES_EDE_CBC_SHA + ?TLS_ECDH_RSA_WITH_AES_128_CBC_SHA ]; suites(3) -> [?TLS_ECDHE_ECDSA_WITH_AES_256_GCM_SHA384, @@ -227,10 +220,6 @@ suites(3) -> ?TLS_ECDH_ECDSA_WITH_AES_256_CBC_SHA384, ?TLS_ECDH_RSA_WITH_AES_256_CBC_SHA384, - ?TLS_ECDHE_ECDSA_WITH_CHACHA20_POLY1305_SHA256, - ?TLS_ECDHE_RSA_WITH_CHACHA20_POLY1305_SHA256, - ?TLS_DHE_RSA_WITH_CHACHA20_POLY1305_SHA256, - ?TLS_DHE_RSA_WITH_AES_256_GCM_SHA384, ?TLS_DHE_DSS_WITH_AES_256_GCM_SHA384, ?TLS_DHE_RSA_WITH_AES_256_CBC_SHA256, diff --git a/lib/ssl/test/ssl_basic_SUITE.erl b/lib/ssl/test/ssl_basic_SUITE.erl index dc602910a1..2781203557 100644 --- a/lib/ssl/test/ssl_basic_SUITE.erl +++ b/lib/ssl/test/ssl_basic_SUITE.erl @@ -163,7 +163,8 @@ api_tests() -> server_name_indication_option, accept_pool, prf, - socket_options + socket_options, + cipher_suites ]. api_tests_tls() -> @@ -207,12 +208,14 @@ tls_cipher_tests() -> rc4_ecdsa_cipher_suites]. cipher_tests() -> - [cipher_suites, + [old_cipher_suites, cipher_suites_mix, ciphers_rsa_signed_certs, ciphers_rsa_signed_certs_openssl_names, ciphers_dsa_signed_certs, ciphers_dsa_signed_certs_openssl_names, + chacha_rsa_cipher_suites, + chacha_ecdsa_cipher_suites, anonymous_cipher_suites, psk_cipher_suites, psk_with_hint_cipher_suites, @@ -702,8 +705,6 @@ secret_connection_info(Config) when is_list(Config) -> ct:log("Testcase ~p, Client ~p Server ~p ~n", [self(), Client, Server]), - - Version = ssl_test_lib:protocol_version(Config), ssl_test_lib:check_result(Server, true, Client, true), @@ -1128,11 +1129,16 @@ fallback(Config) when is_list(Config) -> %%-------------------------------------------------------------------- cipher_format() -> - [{doc, "Test that cipher conversion from tuples to binarys works"}]. + [{doc, "Test that cipher conversion from maps | tuples | stings to binarys works"}]. cipher_format(Config) when is_list(Config) -> - {ok, Socket} = ssl:listen(0, [{ciphers, ssl:cipher_suites()}]), - ssl:close(Socket). - + {ok, Socket0} = ssl:listen(0, [{ciphers, ssl:cipher_suites(default, 'tlsv1.2')}]), + ssl:close(Socket0), + %% Legacy + {ok, Socket1} = ssl:listen(0, [{ciphers, ssl:cipher_suites()}]), + ssl:close(Socket1), + {ok, Socket2} = ssl:listen(0, [{ciphers, ssl:cipher_suites(openssl)}]), + ssl:close(Socket2). + %%-------------------------------------------------------------------- peername() -> @@ -1283,20 +1289,76 @@ sockname_result(S) -> ssl:sockname(S). %%-------------------------------------------------------------------- + cipher_suites() -> - [{doc,"Test API function cipher_suites/0"}]. + [{doc,"Test API function cipher_suites/2, filter_cipher_suites/2" + " and prepend|append_cipher_suites/2"}]. cipher_suites(Config) when is_list(Config) -> - MandatoryCipherSuiteTLS1_0TLS1_1 = {rsa,'3des_ede_cbc',sha}, - MandatoryCipherSuiteTLS1_0TLS1_2 = {rsa,'aes_128_cbc',sha} , - [_|_] = Suites = ssl:cipher_suites(), - AllSuites = ssl:cipher_suites(all), - %% The mandantory suites will no longer be supported by default - %% due to security reasons - true = lists:member(MandatoryCipherSuiteTLS1_0TLS1_1, AllSuites), - true = lists:member(MandatoryCipherSuiteTLS1_0TLS1_2, AllSuites), + MandatoryCipherSuiteTLS1_0TLS1_1 = #{key_exchange => rsa, + cipher => '3des_ede_cbc', + mac => sha, + prf => default_prf}, + MandatoryCipherSuiteTLS1_0TLS1_2 = #{key_exchange =>rsa, + cipher => 'aes_128_cbc', + mac => sha, + prf => default_prf}, + Version = ssl_test_lib:protocol_version(Config), + All = [_|_] = ssl:cipher_suites(all, Version), + Default = [_|_] = ssl:cipher_suites(default, Version), + Anonymous = [_|_] = ssl:cipher_suites(anonymous, Version), + true = length(Default) < length(All), + Filters = [{key_exchange, + fun(dhe_rsa) -> + true; + (_) -> + false + end + }, + {cipher, + fun(aes_256_cbc) -> + true; + (_) -> + false + end + }, + {mac, + fun(sha) -> + true; + (_) -> + false + end + } + ], + Cipher = #{cipher => aes_256_cbc, + key_exchange => dhe_rsa, + mac => sha, + prf => default_prf}, + [Cipher] = ssl:filter_cipher_suites(All, Filters), + [Cipher | Rest0] = ssl:prepend_cipher_suites([Cipher], Default), + [Cipher | Rest0] = ssl:prepend_cipher_suites(Filters, Default), + true = lists:member(Cipher, Default), + false = lists:member(Cipher, Rest0), + [Cipher | Rest1] = lists:reverse(ssl:append_cipher_suites([Cipher], Default)), + [Cipher | Rest1] = lists:reverse(ssl:append_cipher_suites(Filters, Default)), + true = lists:member(Cipher, Default), + false = lists:member(Cipher, Rest1), + [] = lists:dropwhile(fun(X) -> not lists:member(X, Default) end, Anonymous), + [] = lists:dropwhile(fun(X) -> not lists:member(X, All) end, Anonymous), + true = lists:member(MandatoryCipherSuiteTLS1_0TLS1_1, All), + true = lists:member(MandatoryCipherSuiteTLS1_0TLS1_2, All). + +%%-------------------------------------------------------------------- + +old_cipher_suites() -> + [{doc,"Test API function cipher_suites/0"}]. + +old_cipher_suites(Config) when is_list(Config) -> + MandatoryCipherSuite = {rsa, '3des_ede_cbc', sha}, + [_|_] = Suites = ssl:cipher_suites(), Suites = ssl:cipher_suites(erlang), - [_|_] =ssl:cipher_suites(openssl). + [_|_] = ssl:cipher_suites(openssl), + true = lists:member(MandatoryCipherSuite, ssl:cipher_suites(all)). %%-------------------------------------------------------------------- cipher_suites_mix() -> @@ -2371,7 +2433,24 @@ ciphers_dsa_signed_certs_openssl_names() -> ciphers_dsa_signed_certs_openssl_names(Config) when is_list(Config) -> Ciphers = ssl_test_lib:openssl_dsa_suites(), run_suites(Ciphers, Config, dsa). + %%------------------------------------------------------------------- +chacha_rsa_cipher_suites()-> + [{doc,"Test the cacha with ECDSA signed certs ciphersuites"}]. +chacha_rsa_cipher_suites(Config) when is_list(Config) -> + NVersion = ssl_test_lib:protocol_version(Config, tuple), + Ciphers = [S || {KeyEx,_,_} = S <- ssl_test_lib:chacha_suites(NVersion), + KeyEx == ecdhe_rsa, KeyEx == dhe_rsa], + run_suites(Ciphers, Config, chacha_ecdsa). + +%%------------------------------------------------------------------- +chacha_ecdsa_cipher_suites()-> + [{doc,"Test the cacha with ECDSA signed certs ciphersuites"}]. +chacha_ecdsa_cipher_suites(Config) when is_list(Config) -> + NVersion = ssl_test_lib:protocol_version(Config, tuple), + Ciphers = [S || {ecdhe_ecdsa,_,_} = S <- ssl_test_lib:chacha_suites(NVersion)], + run_suites(Ciphers, Config, chacha_rsa). +%%----------------------------------------------------------------- anonymous_cipher_suites()-> [{doc,"Test the anonymous ciphersuites"}]. anonymous_cipher_suites(Config) when is_list(Config) -> @@ -2451,14 +2530,15 @@ rc4_ecdsa_cipher_suites(Config) when is_list(Config) -> des_rsa_cipher_suites()-> [{doc, "Test the des_rsa ciphersuites"}]. des_rsa_cipher_suites(Config) when is_list(Config) -> - Ciphers = ssl_test_lib:des_suites(Config), + NVersion = tls_record:highest_protocol_version([]), + Ciphers = [S || {rsa,_,_} = S <- ssl_test_lib:des_suites(NVersion)], run_suites(Ciphers, Config, des_rsa). %------------------------------------------------------------------- des_ecdh_rsa_cipher_suites()-> [{doc, "Test ECDH rsa signed ciphersuites"}]. des_ecdh_rsa_cipher_suites(Config) when is_list(Config) -> NVersion = ssl_test_lib:protocol_version(Config, tuple), - Ciphers = ssl_test_lib:des_suites(NVersion), + Ciphers = [S || {dhe_rsa,_,_} = S <- ssl_test_lib:des_suites(NVersion)], run_suites(Ciphers, Config, des_dhe_rsa). %%-------------------------------------------------------------------- @@ -3151,18 +3231,25 @@ no_reuses_session_server_restart_new_cert_file(Config) when is_list(Config) -> %%-------------------------------------------------------------------- defaults(Config) when is_list(Config)-> - [_, - {supported, Supported}, - {available, Available}] - = ssl:versions(), - true = lists:member(sslv3, Available), - false = lists:member(sslv3, Supported), + Versions = ssl:versions(), + true = lists:member(sslv3, proplists:get_value(available, Versions)), + false = lists:member(sslv3, proplists:get_value(supported, Versions)), + true = lists:member('tlsv1', proplists:get_value(available, Versions)), + true = lists:member('tlsv1', proplists:get_value(supported, Versions)), + true = lists:member('tlsv1.1', proplists:get_value(available, Versions)), + true = lists:member('tlsv1.1', proplists:get_value(supported, Versions)), + true = lists:member('tlsv1.2', proplists:get_value(available, Versions)), + true = lists:member('tlsv1.2', proplists:get_value(supported, Versions)), false = lists:member({rsa,rc4_128,sha}, ssl:cipher_suites()), true = lists:member({rsa,rc4_128,sha}, ssl:cipher_suites(all)), false = lists:member({rsa,des_cbc,sha}, ssl:cipher_suites()), true = lists:member({rsa,des_cbc,sha}, ssl:cipher_suites(all)), false = lists:member({dhe_rsa,des_cbc,sha}, ssl:cipher_suites()), - true = lists:member({dhe_rsa,des_cbc,sha}, ssl:cipher_suites(all)). + true = lists:member({dhe_rsa,des_cbc,sha}, ssl:cipher_suites(all)), + true = lists:member('dtlsv1.2', proplists:get_value(available_dtls, Versions)), + true = lists:member('dtlsv1', proplists:get_value(available_dtls, Versions)), + true = lists:member('dtlsv1.2', proplists:get_value(supported_dtls, Versions)), + true = lists:member('dtlsv1', proplists:get_value(supported_dtls, Versions)). %%-------------------------------------------------------------------- reuseaddr() -> @@ -3773,9 +3860,23 @@ rizzo() -> vunrable to Rizzo/Dungon attack"}]. rizzo(Config) when is_list(Config) -> - Ciphers = [X || X ={_,Y,_} <- ssl:cipher_suites(), Y =/= rc4_128], Prop = proplists:get_value(tc_group_properties, Config), Version = proplists:get_value(name, Prop), + NVersion = ssl_test_lib:protocol_version(Config, tuple), + Ciphers = ssl:filter_cipher_suites(ssl:cipher_suites(all, NVersion), + [{key_exchange, + fun(Alg) when Alg == ecdh_rsa; Alg == ecdhe_rsa-> + true; + (_) -> + false + end}, + {cipher, + fun(rc4_128) -> + false; + (_) -> + true + end}]), + run_send_recv_rizzo(Ciphers, Config, Version, {?MODULE, send_recv_result_active_rizzo, []}). %%-------------------------------------------------------------------- @@ -3787,8 +3888,13 @@ no_rizzo_rc4(Config) when is_list(Config) -> Version = proplists:get_value(name, Prop), NVersion = ssl_test_lib:protocol_version(Config, tuple), %% Test uses RSA certs - Ciphers = ssl_test_lib:rc4_suites(NVersion) -- [{ecdhe_ecdsa,rc4_128,sha}, - {ecdh_ecdsa,rc4_128,sha}], + Ciphers = ssl:filter_cipher_suites(ssl_test_lib:rc4_suites(NVersion), + [{key_exchange, + fun(Alg) when Alg == ecdh_rsa; Alg == ecdhe_rsa-> + true; + (_) -> + false + end}]), run_send_recv_rizzo(Ciphers, Config, Version, {?MODULE, send_recv_result_active_no_rizzo, []}). @@ -3799,10 +3905,21 @@ rizzo_one_n_minus_one(Config) when is_list(Config) -> Prop = proplists:get_value(tc_group_properties, Config), Version = proplists:get_value(name, Prop), NVersion = ssl_test_lib:protocol_version(Config, tuple), - AllSuites = ssl_test_lib:available_suites(NVersion), - Ciphers = [X || X ={_,Y,_} <- AllSuites, Y =/= rc4_128], + Ciphers = ssl:filter_cipher_suites(ssl:cipher_suites(all, NVersion), + [{key_exchange, + fun(Alg) when Alg == ecdh_rsa; Alg == ecdhe_rsa-> + true; + (_) -> + false + end}, + {cipher, + fun(rc4_128) -> + false; + (_) -> + true + end}]), run_send_recv_rizzo(Ciphers, Config, Version, - {?MODULE, send_recv_result_active_rizzo, []}). + {?MODULE, send_recv_result_active_rizzo, []}). rizzo_zero_n() -> [{doc,"Test that the 0/n-split mitigation of Rizzo/Dungon attack can be explicitly selected"}]. @@ -3811,8 +3928,13 @@ rizzo_zero_n(Config) when is_list(Config) -> Prop = proplists:get_value(tc_group_properties, Config), Version = proplists:get_value(name, Prop), NVersion = ssl_test_lib:protocol_version(Config, tuple), - AllSuites = ssl_test_lib:available_suites(NVersion), - Ciphers = [X || X ={_,Y,_} <- AllSuites, Y =/= rc4_128], + Ciphers = ssl:filter_cipher_suites(ssl:cipher_suites(default, NVersion), + [{cipher, + fun(rc4_128) -> + false; + (_) -> + true + end}]), run_send_recv_rizzo(Ciphers, Config, Version, {?MODULE, send_recv_result_active_no_rizzo, []}). @@ -3820,9 +3942,16 @@ rizzo_disabled() -> [{doc,"Test that the mitigation of Rizzo/Dungon attack can be explicitly disabled"}]. rizzo_disabled(Config) when is_list(Config) -> - Ciphers = [X || X ={_,Y,_} <- ssl:cipher_suites(), Y =/= rc4_128], Prop = proplists:get_value(tc_group_properties, Config), Version = proplists:get_value(name, Prop), + NVersion = ssl_test_lib:protocol_version(Config, tuple), + Ciphers = ssl:filter_cipher_suites(ssl:cipher_suites(default, NVersion), + [{cipher, + fun(rc4_128) -> + false; + (_) -> + true + end}]), run_send_recv_rizzo(Ciphers, Config, Version, {?MODULE, send_recv_result_active_no_rizzo, []}). @@ -4597,19 +4726,21 @@ rizzo_test(Cipher, Config, Version, Mfa) -> [{Cipher, Error}] end. -client_server_opts({KeyAlgo,_,_}, Config) +client_server_opts(#{key_exchange := KeyAlgo}, Config) when KeyAlgo == rsa orelse KeyAlgo == dhe_rsa orelse - KeyAlgo == ecdhe_rsa -> + KeyAlgo == ecdhe_rsa orelse + KeyAlgo == rsa_psk orelse + KeyAlgo == srp_rsa -> {ssl_test_lib:ssl_options(client_opts, Config), ssl_test_lib:ssl_options(server_opts, Config)}; -client_server_opts({KeyAlgo,_,_}, Config) when KeyAlgo == dss orelse KeyAlgo == dhe_dss -> +client_server_opts(#{key_exchange := KeyAlgo}, Config) when KeyAlgo == dss orelse KeyAlgo == dhe_dss -> {ssl_test_lib:ssl_options(client_dsa_opts, Config), ssl_test_lib:ssl_options(server_dsa_opts, Config)}; -client_server_opts({KeyAlgo,_,_}, Config) when KeyAlgo == ecdh_ecdsa orelse KeyAlgo == ecdhe_ecdsa -> +client_server_opts(#{key_exchange := KeyAlgo}, Config) when KeyAlgo == ecdh_ecdsa orelse KeyAlgo == ecdhe_ecdsa -> {ssl_test_lib:ssl_options(client_opts, Config), ssl_test_lib:ssl_options(server_ecdsa_opts, Config)}; -client_server_opts({KeyAlgo,_,_}, Config) when KeyAlgo == ecdh_rsa -> +client_server_opts(#{key_exchange := KeyAlgo}, Config) when KeyAlgo == ecdh_rsa -> {ssl_test_lib:ssl_options(client_opts, Config), ssl_test_lib:ssl_options(server_ecdh_rsa_opts, Config)}. @@ -4683,7 +4814,15 @@ run_suites(Ciphers, Config, Type) -> des_rsa -> {ssl_test_lib:ssl_options(client_verification_opts, Config), [{ciphers, Ciphers} | - ssl_test_lib:ssl_options(server_verification_opts, Config)]} + ssl_test_lib:ssl_options(server_verification_opts, Config)]}; + chacha_rsa -> + {ssl_test_lib:ssl_options(client_verification_opts, Config), + [{ciphers, Ciphers} | + ssl_test_lib:ssl_options(server_verification_opts, Config)]}; + chacha_ecdsa -> + {ssl_test_lib:ssl_options(client_verification_opts, Config), + [{ciphers, Ciphers} | + ssl_test_lib:ssl_options(server_ecdsa_opts, Config)]} end, Result = lists:map(fun(Cipher) -> cipher(Cipher, Version, Config, ClientOpts, ServerOpts) end, diff --git a/lib/ssl/test/ssl_test_lib.erl b/lib/ssl/test/ssl_test_lib.erl index e74529b455..26ef311615 100644 --- a/lib/ssl/test/ssl_test_lib.erl +++ b/lib/ssl/test/ssl_test_lib.erl @@ -1024,55 +1024,50 @@ string_regex_filter(Str, Search) when is_list(Str) -> string_regex_filter(_Str, _Search) -> false. -anonymous_suites({3,_ } = Version) -> - [ssl_cipher:erl_suite_definition(S) || S <- ssl_cipher:filter_suites(ssl_cipher:anonymous_suites(Version))]; -anonymous_suites(DTLSVersion) -> - Version = dtls_v1:corresponding_tls_version(DTLSVersion), - [ssl_cipher:erl_suite_definition(S) || S <- ssl_cipher:filter_suites(ssl_cipher:anonymous_suites(Version)), - not ssl_cipher:is_stream_ciphersuite(tuple_to_map(ssl_cipher:erl_suite_definition(S)))]. - -psk_suites({3,_ } = Version) -> - [ssl_cipher:erl_suite_definition(S) || S <- ssl_cipher:filter_suites(ssl_cipher:psk_suites(Version))]; -psk_suites(DTLSVersion) -> - Version = dtls_v1:corresponding_tls_version(DTLSVersion), - [ssl_cipher:erl_suite_definition(S) || S <- ssl_cipher:filter_suites(ssl_cipher:psk_suites(Version)), - not ssl_cipher:is_stream_ciphersuite(tuple_to_map(ssl_cipher:erl_suite_definition(S)))]. - -psk_anon_suites({3,_ } = Version) -> - [Suite || Suite <- psk_suites(Version), is_psk_anon_suite(Suite)]; -psk_anon_suites(DTLSVersion) -> - Version = dtls_v1:corresponding_tls_version(DTLSVersion), - [Suite || Suite <- psk_suites(Version), is_psk_anon_suite(Suite), - not ssl_cipher:is_stream_ciphersuite(tuple_to_map(Suite))]. +anonymous_suites(Version) -> + ssl:filter_cipher_suites([ssl_cipher:suite_definition(S) || S <- ssl_cipher:anonymous_suites(Version)],[]). +psk_suites(Version) -> + ssl:filter_cipher_suites([ssl_cipher:suite_definition(S) || S <- ssl_cipher:psk_suites(Version)], []). + +psk_anon_suites(Version) -> + ssl:filter_cipher_suites([ssl_cipher:suite_definition(S) || S <- ssl_cipher:psk_suites_anon(Version)], + [{key_exchange, + fun(psk) -> + true; + (psk_dhe) -> + true; + (_) -> + false + end}]). + srp_suites() -> - [ssl_cipher:erl_suite_definition(Suite) || - Suite <- - ssl_cipher:filter_suites([tuple_to_map(S) || - S <- [{srp_anon,'3des_ede_cbc', sha}, - {srp_rsa, '3des_ede_cbc', sha}, - {srp_anon, aes_128_cbc, sha}, - {srp_rsa, aes_128_cbc, sha}, - {srp_anon, aes_256_cbc, sha}, - {srp_rsa, aes_256_cbc, sha}]])]. + ssl:filter_cipher_suites([ssl_cipher:suite_definition(S) || S <- ssl_cipher:srp_suites()], + [{key_exchange, + fun(srp_rsa) -> + true; + (_) -> + false + end}]). srp_anon_suites() -> - [ssl_cipher:erl_suite_definition(Suite) || - Suite <- - ssl_cipher:filter_suites([tuple_to_map(S) || - S <-[{srp_anon, '3des_ede_cbc', sha}, - {srp_anon, aes_128_cbc, sha}, - {srp_anon, aes_256_cbc, sha}]])]. + ssl:filter_cipher_suites([ssl_cipher:suite_definition(S) || S <- ssl_cipher:srp_suites_anon()], + []). srp_dss_suites() -> - [ssl_cipher:erl_suite_definition(Suite) || - Suite <- - ssl_cipher:filter_suites([tuple_to_map(S) || - S <- [{srp_dss, '3des_ede_cbc', sha}, - {srp_dss, aes_128_cbc, sha}, - {srp_dss, aes_256_cbc, sha}]])]. + ssl:filter_cipher_suites([ssl_cipher:suite_definition(S) || S <- ssl_cipher:srp_suites()], + [{key_exchange, + fun(srp_dss) -> + true; + (_) -> + false + end}]). +chacha_suites(Version) -> + [ssl_cipher:erl_suite_definition(S) || S <- ssl_cipher:filter_suites(ssl_cipher:chacha_suites(Version))]. + + rc4_suites(Version) -> - [ssl_cipher:erl_suite_definition(S) || S <- ssl_cipher:filter_suites(ssl_cipher:rc4_suites(Version))]. + ssl:filter_cipher_suites([ssl_cipher:suite_definition(S) || S <-ssl_cipher:rc4_suites(Version)], []). des_suites(Version) -> - [ssl_cipher:erl_suite_definition(S) || S <- ssl_cipher:filter_suites(ssl_cipher:des_suites(Version))]. + ssl:filter_cipher_suites([ssl_cipher:suite_definition(S) || S <-ssl_cipher:des_suites(Version)], []). tuple_to_map({Kex, Cipher, Mac}) -> #{key_exchange => Kex, @@ -1309,6 +1304,32 @@ cipher_restriction(Config0) -> Config0 end. +openssl_dsa_support() -> + case os:cmd("openssl version") of + "LibreSSL 2.6.1" ++ _ -> + true; + "LibreSSL 2.6.2" ++ _ -> + true; + "LibreSSL 2.6" ++ _ -> + false; + "LibreSSL 2.4" ++ _ -> + true; + "LibreSSL 2.3" ++ _ -> + true; + "LibreSSL 2.2" ++ _ -> + true; + "LibreSSL 2.1" ++ _ -> + true; + "LibreSSL 2.0" ++ _ -> + true; + "LibreSSL" ++ _ -> + false; + "OpenSSL 1.0.1" ++ Rest -> + hd(Rest) >= s; + _ -> + true + end. + check_sane_openssl_version(Version) -> case supports_ssl_tls_version(Version) of true -> @@ -1387,7 +1408,9 @@ filter_suites(Ciphers0, AtomVersion) -> Supported0 = ssl_cipher:suites(Version) ++ ssl_cipher:anonymous_suites(Version) ++ ssl_cipher:psk_suites(Version) + ++ ssl_cipher:psk_suites_anon(Version) ++ ssl_cipher:srp_suites() + ++ ssl_cipher:srp_suites_anon() ++ ssl_cipher:rc4_suites(Version), Supported1 = ssl_cipher:filter_suites(Supported0), Supported2 = [ssl_cipher:erl_suite_definition(S) || S <- Supported1], diff --git a/lib/ssl/test/ssl_to_openssl_SUITE.erl b/lib/ssl/test/ssl_to_openssl_SUITE.erl index bbb925e742..f091c8786e 100644 --- a/lib/ssl/test/ssl_to_openssl_SUITE.erl +++ b/lib/ssl/test/ssl_to_openssl_SUITE.erl @@ -143,10 +143,15 @@ init_per_suite(Config0) -> try crypto:start() of ok -> ssl_test_lib:clean_start(), - - Config1 = ssl_test_lib:make_rsa_cert(Config0), - Config2 = ssl_test_lib:make_dsa_cert(Config1), - ssl_test_lib:cipher_restriction(Config2) + Config = + case ssl_test_lib:openssl_dsa_support() of + true -> + Config1 = ssl_test_lib:make_rsa_cert(Config0), + ssl_test_lib:make_dsa_cert(Config1); + false -> + ssl_test_lib:make_rsa_cert(Config0) + end, + ssl_test_lib:cipher_restriction(Config) catch _:_ -> {skip, "Crypto did not start"} end @@ -199,15 +204,27 @@ init_per_testcase(expired_session, Config) -> ssl:start(), Config; -init_per_testcase(TestCase, Config) when TestCase == ciphers_rsa_signed_certs; - TestCase == ciphers_dsa_signed_certs -> - ct:timetrap({seconds, 90}), - special_init(TestCase, Config); - +init_per_testcase(TestCase, Config) when + TestCase == ciphers_dsa_signed_certs; + TestCase == erlang_client_openssl_server_dsa_cert; + TestCase == erlang_server_openssl_client_dsa_cert; + TestCase == erlang_client_openssl_server_dsa_cert; + TestCase == erlang_server_openssl_client_dsa_cert -> + case ssl_test_lib:openssl_dsa_support() of + true -> + special_init(TestCase, Config); + false -> + {skip, "DSA not supported by OpenSSL"} + end; init_per_testcase(TestCase, Config) -> ct:timetrap({seconds, 35}), special_init(TestCase, Config). +special_init(TestCase, Config) when + TestCase == ciphers_rsa_signed_certs; + TestCase == ciphers_dsa_signed_certs-> + ct:timetrap({seconds, 90}), + Config; special_init(TestCase, Config) when TestCase == erlang_client_openssl_server_renegotiate; TestCase == erlang_client_openssl_server_nowrap_seqnum; @@ -1016,7 +1033,7 @@ ssl2_erlang_server_openssl_client(Config) when is_list(Config) -> ct:log("Ports ~p~n", [[erlang:port_info(P) || P <- erlang:ports()]]), consume_port_exit(OpenSslPort), - ssl_test_lib:check_result(Server, {error, {tls_alert, "handshake failure"}}), + ssl_test_lib:check_result(Server, {error, {tls_alert, "bad record mac"}}), process_flag(trap_exit, false). %%-------------------------------------------------------------------- ssl2_erlang_server_openssl_client_comp() -> diff --git a/lib/stdlib/doc/src/assert_hrl.xml b/lib/stdlib/doc/src/assert_hrl.xml index ea23cca2ee..33f29f38da 100644 --- a/lib/stdlib/doc/src/assert_hrl.xml +++ b/lib/stdlib/doc/src/assert_hrl.xml @@ -93,7 +93,7 @@ erlc -DNOASSERT=true *.erl</code> <taglist> <tag><c>assert(BoolExpr)</c></tag> <item></item> - <tag><c>URKAassert(BoolExpr, Comment)</c></tag> + <tag><c>assert(BoolExpr, Comment)</c></tag> <item> <p>Tests that <c>BoolExpr</c> completes normally returning <c>true</c>.</p> diff --git a/lib/stdlib/doc/src/erl_tar.xml b/lib/stdlib/doc/src/erl_tar.xml index 337028568a..caf8f4a96d 100644 --- a/lib/stdlib/doc/src/erl_tar.xml +++ b/lib/stdlib/doc/src/erl_tar.xml @@ -4,7 +4,7 @@ <erlref> <header> <copyright> - <year>2003</year><year>2017</year> + <year>2003</year><year>2018</year> <holder>Ericsson AB. All Rights Reserved.</holder> </copyright> <legalnotice> @@ -136,6 +136,9 @@ <v>Filename = filename()|{NameInArchive,FilenameOrBin}</v> <v>Options = [Option]</v> <v>Option = dereference|verbose|{chunks,ChunkSize}</v> + <v>|{atime,non_neg_integer()}|{mtime,non_neg_integer()}</v> + <v>|{ctime,non_neg_integer()}|{uid,non_neg_integer()}</v> + <v>|{gid,non_neg_integer()}</v> <v>ChunkSize = positive_integer()</v> <v>RetValue = ok|{error,{Filename,Reason}}</v> <v>Reason = term()</v> @@ -167,6 +170,42 @@ <seealso marker="ssh:ssh_sftp#open_tar/3"> <c>ssh_sftp:open_tar/3</c></seealso>.</p> </item> + <tag><c>{atime,non_neg_integer()}</c></tag> + <item> + <p>Sets the last time, as + <seealso marker="erts:time_correction#POSIX_Time"> + POSIX time</seealso>, when the file was read. See also + <seealso marker="kernel:file#read_file_info/1"> + <c>file:read_file_info/1</c></seealso>.</p> + </item> + <tag><c>{mtime,non_neg_integer()}</c></tag> + <item> + <p>Sets the last time, as + <seealso marker="erts:time_correction#POSIX_Time"> + POSIX time</seealso>, when the file was written. See also + <seealso marker="kernel:file#read_file_info/1"> + <c>file:read_file_info/1</c></seealso>.</p> + </item> + <tag><c>{ctime,non_neg_integer()}</c></tag> + <item> + <p>Sets the time, as + <seealso marker="erts:time_correction#POSIX_Time"> + POSIX time</seealso>, when the file was created. See also + <seealso marker="kernel:file#read_file_info/1"> + <c>file:read_file_info/1</c></seealso>.</p> + </item> + <tag><c>{uid,non_neg_integer()}</c></tag> + <item> + <p>Sets the file owner. + <seealso marker="kernel:file#read_file_info/1"> + <c>file:read_file_info/1</c></seealso>.</p> + </item> + <tag><c>{gid,non_neg_integer()}</c></tag> + <item> + <p>Sets the group that the file owner belongs to. + <seealso marker="kernel:file#read_file_info/1"> + <c>file:read_file_info/1</c></seealso>.</p> + </item> </taglist> </desc> </func> diff --git a/lib/stdlib/doc/src/ets.xml b/lib/stdlib/doc/src/ets.xml index a0ec22c515..1b31a1ec9d 100644 --- a/lib/stdlib/doc/src/ets.xml +++ b/lib/stdlib/doc/src/ets.xml @@ -963,11 +963,11 @@ ets:is_compiled_ms(Broken).</code> <func> <name name="match_spec_run" arity="2"/> <fsummary>Perform matching, using a compiled match specification on a - list of tuples.</fsummary> + list of terms.</fsummary> <desc> <p>Executes the matching specified in a compiled <seealso marker="#match_spec">match specification</seealso> on a list - of tuples. Term <c><anno>CompiledMatchSpec</anno></c> is to be + of terms. Term <c><anno>CompiledMatchSpec</anno></c> is to be the result of a call to <seealso marker="#match_spec_compile/1"> <c>match_spec_compile/1</c></seealso> and is hence the internal representation of the match specification one wants to use.</p> @@ -985,7 +985,7 @@ Table = ets:new... MatchSpec = ... % The following call... ets:match_spec_run(ets:tab2list(Table), -ets:match_spec_compile(MatchSpec)), + ets:match_spec_compile(MatchSpec)), % ...gives the same result as the more common (and more efficient) ets:select(Table, MatchSpec),</code> <note> diff --git a/lib/stdlib/doc/src/gen_statem.xml b/lib/stdlib/doc/src/gen_statem.xml index 4a824f073e..be0d64feba 100644 --- a/lib/stdlib/doc/src/gen_statem.xml +++ b/lib/stdlib/doc/src/gen_statem.xml @@ -4,7 +4,7 @@ <erlref> <header> <copyright> - <year>2016</year><year>2017</year> + <year>2016</year><year>2018</year> <holder>Ericsson AB. All Rights Reserved.</holder> </copyright> <legalnotice> @@ -543,7 +543,23 @@ handle_event(_, _, State, Data) -> <name name="event_type"/> <desc> <p> - External events are of three types: + There are 3 categories of events: + <seealso marker="#type-external_event_type">external</seealso>, + <seealso marker="#type-timeout_event_type">timeout</seealso>, + and <c>internal</c>. + </p> + <p> + <c>internal</c> events can only be generated by the + state machine itself through the state transition action + <seealso marker="#type-action"><c>next_event</c></seealso>. + </p> + </desc> + </datatype> + <datatype> + <name name="external_event_type"/> + <desc> + <p> + External events are of 3 types: <c>{call,<anno>From</anno>}</c>, <c>cast</c>, or <c>info</c>. <seealso marker="#call/2">Calls</seealso> (synchronous) and @@ -551,12 +567,17 @@ handle_event(_, _, State, Data) -> originate from the corresponding API functions. For calls, the event contains whom to reply to. Type <c>info</c> originates from regular process messages sent - to the <c>gen_statem</c>. The state machine - implementation can, in addition to the above, - generate - <seealso marker="#type-event_type"><c>events of types</c></seealso> - <c>timeout</c>, <c>{timeout,<anno>Name</anno>}</c>, - <c>state_timeout</c>, and <c>internal</c> to itself. + to the <c>gen_statem</c>. + </p> + </desc> + </datatype> + <datatype> + <name name="timeout_event_type"/> + <desc> + <p> + There are 3 types of timeout events that the state machine + can generate for itself with the corresponding + <seealso marker="#type-timeout_action">timeout_action()</seealso>s. </p> </desc> </datatype> @@ -1026,6 +1047,25 @@ handle_event(_, _, State, Data) -> for this state transition. </p> </item> + </taglist> + </desc> + </datatype> + <datatype> + <name name="timeout_action"/> + <desc> + <p> + These state transition actions can be invoked by + returning them from the + <seealso marker="#state callback">state callback</seealso>, from + <seealso marker="#Module:init/1"><c>Module:init/1</c></seealso> + or by giving them to + <seealso marker="#enter_loop/5"><c>enter_loop/5,6</c></seealso>. + </p> + <p> + These timeout actions sets timeout + <seealso marker="#type-transition_option">transition options</seealso>. + </p> + <taglist> <tag><c>Timeout</c></tag> <item> <p> diff --git a/lib/stdlib/include/assert.hrl b/lib/stdlib/include/assert.hrl index 2fbaeba0b2..2ec89e7d8a 100644 --- a/lib/stdlib/include/assert.hrl +++ b/lib/stdlib/include/assert.hrl @@ -309,7 +309,7 @@ {unexpected_success, __V}]}) catch Class:Term -> ok; - __C:__T -> + __C:__T:__S -> erlang:error({assertException, [{module, ?MODULE}, {line, ?LINE}, @@ -318,8 +318,7 @@ "{ "++(??Class)++" , "++(??Term) ++" , [...] }"}, {unexpected_exception, - {__C, __T, - erlang:get_stacktrace()}}]}) + {__C, __T, __S}}]}) end end)()) end). @@ -338,7 +337,7 @@ {unexpected_success, __V}]}) catch Class:Term -> ok; - __C:__T -> + __C:__T:__S -> erlang:error({assertException, [{module, ?MODULE}, {line, ?LINE}, @@ -348,8 +347,7 @@ "{ "++(??Class)++" , "++(??Term) ++" , [...] }"}, {unexpected_exception, - {__C, __T, - erlang:get_stacktrace()}}]}) + {__C, __T, __S}}]}) end end)()) end). @@ -378,7 +376,7 @@ try (Expr) of _ -> ok catch - __C:__T -> + __C:__T:__S -> case __C of Class -> case __T of @@ -391,9 +389,7 @@ "{ "++(??Class)++" , " ++(??Term)++" , [...] }"}, {unexpected_exception, - {__C, __T, - erlang:get_stacktrace() - }}]}); + {__C, __T, __S}}]}); _ -> ok end; _ -> ok @@ -407,7 +403,7 @@ try (Expr) of _ -> ok catch - __C:__T -> + __C:__T:__S -> case __C of Class -> case __T of @@ -421,9 +417,7 @@ "{ "++(??Class)++" , " ++(??Term)++" , [...] }"}, {unexpected_exception, - {__C, __T, - erlang:get_stacktrace() - }}]}); + {__C, __T, __S}}]}); _ -> ok end; _ -> ok diff --git a/lib/stdlib/src/c.erl b/lib/stdlib/src/c.erl index 9a447af5b7..3597e61c26 100644 --- a/lib/stdlib/src/c.erl +++ b/lib/stdlib/src/c.erl @@ -1034,8 +1034,8 @@ appcall(App, M, F, Args) -> try apply(M, F, Args) catch - error:undef -> - case erlang:get_stacktrace() of + error:undef:S -> + case S of [{M,F,Args,_}|_] -> Arity = length(Args), io:format("Call to ~w:~w/~w in application ~w failed.\n", diff --git a/lib/stdlib/src/dets.erl b/lib/stdlib/src/dets.erl index 4e3fe0e5c1..e1a36abc70 100644 --- a/lib/stdlib/src/dets.erl +++ b/lib/stdlib/src/dets.erl @@ -1288,8 +1288,8 @@ init(Parent, Server) -> catch exit:normal -> exit(normal); - _:Bad -> - bug_found(no_name, Op, Bad, From), + _:Bad:Stacktrace -> + bug_found(no_name, Op, Bad, Stacktrace, From), exit(Bad) % give up end end. @@ -1371,8 +1371,8 @@ do_apply_op(Op, From, Head, N) -> catch exit:normal -> exit(normal); - _:Bad -> - bug_found(Head#head.name, Op, Bad, From), + _:Bad:Stacktrace -> + bug_found(Head#head.name, Op, Bad, Stacktrace, From), open_file_loop(Head, N) end. @@ -1581,7 +1581,7 @@ apply_op(Op, From, Head, N) -> ok end. -bug_found(Name, Op, Bad, From) -> +bug_found(Name, Op, Bad, Stacktrace, From) -> case dets_utils:debug_mode() of true -> %% If stream_op/5 found more requests, this is not @@ -1590,7 +1590,7 @@ bug_found(Name, Op, Bad, From) -> ("** dets: Bug was found when accessing table ~tw,~n" "** dets: operation was ~tp and reply was ~tw.~n" "** dets: Stacktrace: ~tw~n", - [Name, Op, Bad, erlang:get_stacktrace()]); + [Name, Op, Bad, Stacktrace]); false -> error_logger:format ("** dets: Bug was found when accessing table ~tw~n", diff --git a/lib/stdlib/src/dets_utils.erl b/lib/stdlib/src/dets_utils.erl index 17f55ebdc2..4c8ea9e82b 100644 --- a/lib/stdlib/src/dets_utils.erl +++ b/lib/stdlib/src/dets_utils.erl @@ -377,7 +377,8 @@ corrupt_reason(Head, Reason0) -> no_disk_map -> Reason0; DM -> - ST = erlang:get_stacktrace(), + {current_stacktrace, ST} = + erlang:process_info(self(), current_stacktrace), PD = get(), {Reason0, ST, PD, DM} end, diff --git a/lib/stdlib/src/erl_tar.erl b/lib/stdlib/src/erl_tar.erl index 5ee584d612..d8b8f466b1 100644 --- a/lib/stdlib/src/erl_tar.erl +++ b/lib/stdlib/src/erl_tar.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1997-2017. All Rights Reserved. +%% Copyright Ericsson AB 1997-2018. 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. @@ -457,26 +457,61 @@ add(Reader, NameOrBin, NameInArchive, Options) do_add(#reader{access=write}=Reader, Name, NameInArchive, Options) when is_list(NameInArchive), is_list(Options) -> - RF = fun(F) -> file:read_link_info(F, [{time, posix}]) end, + RF = apply_file_info_opts_fun(Options, read_link_info), Opts = #add_opts{read_info=RF}, - add1(Reader, Name, NameInArchive, add_opts(Options, Opts)); + add1(Reader, Name, NameInArchive, add_opts(Options, Options, Opts)); do_add(#reader{access=read},_,_,_) -> {error, eacces}; do_add(Reader,_,_,_) -> {error, {badarg, Reader}}. -add_opts([dereference|T], Opts) -> - RF = fun(F) -> file:read_file_info(F, [{time, posix}]) end, - add_opts(T, Opts#add_opts{read_info=RF}); -add_opts([verbose|T], Opts) -> - add_opts(T, Opts#add_opts{verbose=true}); -add_opts([{chunks,N}|T], Opts) -> - add_opts(T, Opts#add_opts{chunk_size=N}); -add_opts([_|T], Opts) -> - add_opts(T, Opts); -add_opts([], Opts) -> +add_opts([dereference|T], AllOptions, Opts) -> + RF = apply_file_info_opts_fun(AllOptions, read_file_info), + add_opts(T, AllOptions, Opts#add_opts{read_info=RF}); +add_opts([verbose|T], AllOptions, Opts) -> + add_opts(T, AllOptions, Opts#add_opts{verbose=true}); +add_opts([{chunks,N}|T], AllOptions, Opts) -> + add_opts(T, AllOptions, Opts#add_opts{chunk_size=N}); +add_opts([{atime,Value}|T], AllOptions, Opts) -> + add_opts(T, AllOptions, Opts#add_opts{atime=Value}); +add_opts([{mtime,Value}|T], AllOptions, Opts) -> + add_opts(T, AllOptions, Opts#add_opts{mtime=Value}); +add_opts([{ctime,Value}|T], AllOptions, Opts) -> + add_opts(T, AllOptions, Opts#add_opts{ctime=Value}); +add_opts([{uid,Value}|T], AllOptions, Opts) -> + add_opts(T, AllOptions, Opts#add_opts{uid=Value}); +add_opts([{gid,Value}|T], AllOptions, Opts) -> + add_opts(T, AllOptions, Opts#add_opts{gid=Value}); +add_opts([_|T], AllOptions, Opts) -> + add_opts(T, AllOptions, Opts); +add_opts([], _AllOptions, Opts) -> Opts. +apply_file_info_opts(Opts, {ok, FileInfo}) -> + {ok, do_apply_file_info_opts(Opts, FileInfo)}; +apply_file_info_opts(_Opts, Other) -> + Other. + +do_apply_file_info_opts([{atime,Value}|T], FileInfo) -> + do_apply_file_info_opts(T, FileInfo#file_info{atime=Value}); +do_apply_file_info_opts([{mtime,Value}|T], FileInfo) -> + do_apply_file_info_opts(T, FileInfo#file_info{mtime=Value}); +do_apply_file_info_opts([{ctime,Value}|T], FileInfo) -> + do_apply_file_info_opts(T, FileInfo#file_info{ctime=Value}); +do_apply_file_info_opts([{uid,Value}|T], FileInfo) -> + do_apply_file_info_opts(T, FileInfo#file_info{uid=Value}); +do_apply_file_info_opts([{gid,Value}|T], FileInfo) -> + do_apply_file_info_opts(T, FileInfo#file_info{gid=Value}); +do_apply_file_info_opts([_|T], FileInfo) -> + do_apply_file_info_opts(T, FileInfo); +do_apply_file_info_opts([], FileInfo) -> + FileInfo. + +apply_file_info_opts_fun(Options, InfoFunction) -> + fun(F) -> + apply_file_info_opts(Options, file:InfoFunction(F, [{time, posix}])) + end. + add1(#reader{}=Reader, Name, NameInArchive, #add_opts{read_info=ReadInfo}=Opts) when is_list(Name) -> Res = case ReadInfo(Name) of @@ -515,9 +550,11 @@ add1(Reader, Bin, NameInArchive, Opts) when is_binary(Bin) -> name = NameInArchive, size = byte_size(Bin), typeflag = ?TYPE_REGULAR, - atime = Now, - mtime = Now, - ctime = Now, + atime = add_opts_time(Opts#add_opts.atime, Now), + mtime = add_opts_time(Opts#add_opts.mtime, Now), + ctime = add_opts_time(Opts#add_opts.ctime, Now), + uid = Opts#add_opts.uid, + gid = Opts#add_opts.gid, mode = 8#100644}, {ok, Reader2} = add_header(Reader, Header, Opts), Padding = skip_padding(byte_size(Bin)), @@ -527,6 +564,9 @@ add1(Reader, Bin, NameInArchive, Opts) when is_binary(Bin) -> {error, Reason} -> {error, {NameInArchive, Reason}} end. +add_opts_time(undefined, Now) -> Now; +add_opts_time(Time, _Now) -> Time. + add_directory(Reader, DirName, NameInArchive, Info, Opts) -> case file:list_dir(DirName) of {ok, []} -> @@ -1650,8 +1690,12 @@ write_file(Name, Bin) -> case file:write_file(Name, Bin) of ok -> ok; {error,enoent} -> - ok = make_dirs(Name, file), - write_file(Name, Bin); + case make_dirs(Name, file) of + ok -> + write_file(Name, Bin); + {error,Reason} -> + throw({error, Reason}) + end; {error,Reason} -> throw({error, Reason}) end. diff --git a/lib/stdlib/src/erl_tar.hrl b/lib/stdlib/src/erl_tar.hrl index cff0c2f500..5d6cecbb66 100644 --- a/lib/stdlib/src/erl_tar.hrl +++ b/lib/stdlib/src/erl_tar.hrl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 2017. All Rights Reserved. +%% Copyright Ericsson AB 1997-2018. 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. @@ -21,7 +21,12 @@ -record(add_opts, { read_info, %% Fun to use for read file/link info. chunk_size = 0, %% For file reading when sending to sftp. 0=do not chunk - verbose = false}). %% Verbose on/off. + verbose = false, %% Verbose on/off. + atime = undefined, + mtime = undefined, + ctime = undefined, + uid = 0, + gid = 0}). -type add_opts() :: #add_opts{}. %% Options used when reading a tar archive. @@ -36,7 +41,12 @@ -type add_opt() :: dereference | verbose | - {chunks, pos_integer()}. + {chunks, pos_integer()} | + {atime, non_neg_integer()} | + {mtime, non_neg_integer()} | + {ctime, non_neg_integer()} | + {uid, non_neg_integer()} | + {gid, non_neg_integer()}. -type extract_opt() :: {cwd, string()} | {files, [string()]} | diff --git a/lib/stdlib/src/escript.erl b/lib/stdlib/src/escript.erl index 132f8efbbe..beea9927d2 100644 --- a/lib/stdlib/src/escript.erl +++ b/lib/stdlib/src/escript.erl @@ -283,8 +283,7 @@ start(EscriptOptions) -> throw:Str -> io:format("escript: ~ts\n", [Str]), my_halt(127); - _:Reason -> - Stk = erlang:get_stacktrace(), + _:Reason:Stk -> io:format("escript: Internal error: ~tp\n", [Reason]), io:format("~tp\n", [Stk]), my_halt(127) @@ -759,8 +758,8 @@ run(Module, Args) -> Module:main(Args), my_halt(0) catch - Class:Reason -> - fatal(format_exception(Class, Reason)) + Class:Reason:StackTrace -> + fatal(format_exception(Class, Reason, StackTrace)) end. -spec interpret(_, _, _, _) -> no_return(). @@ -793,8 +792,8 @@ interpret(Forms, HasRecs, File, Args) -> end}), my_halt(0) catch - Class:Reason -> - fatal(format_exception(Class, Reason)) + Class:Reason:StackTrace -> + fatal(format_exception(Class, Reason, StackTrace)) end. report_errors(Errors) -> @@ -873,7 +872,7 @@ eval_exprs([E|Es], Bs0, Lf, Ef, RBs) -> {value,_V,Bs} = erl_eval:expr(E, Bs0, Lf, Ef, RBs1), eval_exprs(Es, Bs, Lf, Ef, RBs). -format_exception(Class, Reason) -> +format_exception(Class, Reason, StackTrace) -> Enc = encoding(), P = case Enc of latin1 -> "P"; @@ -882,7 +881,6 @@ format_exception(Class, Reason) -> PF = fun(Term, I) -> io_lib:format("~." ++ integer_to_list(I) ++ P, [Term, 50]) end, - StackTrace = erlang:get_stacktrace(), StackFun = fun(M, _F, _A) -> (M =:= erl_eval) or (M =:= ?MODULE) end, lib:format_exception(1, Class, Reason, StackTrace, StackFun, PF, Enc). @@ -916,8 +914,8 @@ hidden_apply(App, M, F, Args) -> try apply(fun() -> M end(), F, Args) catch - error:undef -> - case erlang:get_stacktrace() of + error:undef:StackTrace -> + case StackTrace of [{M,F,Args,_} | _] -> Arity = length(Args), Text = io_lib:format("Call to ~w:~w/~w in application ~w failed.\n", diff --git a/lib/stdlib/src/ets.erl b/lib/stdlib/src/ets.erl index b6548626f3..039ab45868 100644 --- a/lib/stdlib/src/ets.erl +++ b/lib/stdlib/src/ets.erl @@ -277,7 +277,7 @@ match_spec_compile(_) -> erlang:nif_error(undef). -spec match_spec_run_r(List, CompiledMatchSpec, list()) -> list() when - List :: [tuple()], + List :: [term()], CompiledMatchSpec :: comp_match_spec(). match_spec_run_r(_, _, _) -> @@ -517,7 +517,7 @@ update_element(_, _, _) -> -opaque comp_match_spec() :: reference(). -spec match_spec_run(List, CompiledMatchSpec) -> list() when - List :: [tuple()], + List :: [term()], CompiledMatchSpec :: comp_match_spec(). match_spec_run(List, CompiledMS) -> @@ -882,10 +882,10 @@ tab2file(Tab, File, Options) -> _ = disk_log:close(Name), _ = file:delete(File), exit(ExReason); - error:ErReason -> + error:ErReason:StackTrace -> _ = disk_log:close(Name), _ = file:delete(File), - erlang:raise(error,ErReason,erlang:get_stacktrace()) + erlang:raise(error,ErReason,StackTrace) end catch throw:TReason2 -> @@ -1060,9 +1060,9 @@ file2tab(File, Opts) -> exit:ExReason -> ets:delete(Tab), exit(ExReason); - error:ErReason -> + error:ErReason:StackTrace -> ets:delete(Tab), - erlang:raise(error,ErReason,erlang:get_stacktrace()) + erlang:raise(error,ErReason,StackTrace) end after _ = disk_log:close(Name) diff --git a/lib/stdlib/src/file_sorter.erl b/lib/stdlib/src/file_sorter.erl index 3aeaff8dc4..7f74e71136 100644 --- a/lib/stdlib/src/file_sorter.erl +++ b/lib/stdlib/src/file_sorter.erl @@ -1314,9 +1314,9 @@ infun(W) -> {cont, W#w{in = NFun}, Objs}; Error -> error(Error, W1) - catch Class:Reason -> + catch Class:Reason:Stacktrace -> cleanup(W1), - erlang:raise(Class, Reason, erlang:get_stacktrace()) + erlang:raise(Class, Reason, Stacktrace) end. outfun(A, #w{inout_value = Val} = W) when Val =/= no_value -> @@ -1336,9 +1336,9 @@ outfun(A, W) -> W#w{out = NF}; Error -> error(Error, W1) - catch Class:Reason -> + catch Class:Reason:Stacktrace -> cleanup(W1), - erlang:raise(Class, Reason, erlang:get_stacktrace()) + erlang:raise(Class, Reason, Stacktrace) end. is_keypos(Keypos) when is_integer(Keypos), Keypos > 0 -> diff --git a/lib/stdlib/src/gen_event.erl b/lib/stdlib/src/gen_event.erl index a9b98911e2..73e4457bd0 100644 --- a/lib/stdlib/src/gen_event.erl +++ b/lib/stdlib/src/gen_event.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1996-2017. All Rights Reserved. +%% Copyright Ericsson AB 1996-2018. 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. @@ -125,7 +125,8 @@ | {'logfile', string()}. -type option() :: {'timeout', timeout()} | {'debug', [debug_flag()]} - | {'spawn_opt', [proc_lib:spawn_option()]}. + | {'spawn_opt', [proc_lib:spawn_option()]} + | {'hibernate_after', timeout()}. -type emgr_ref() :: atom() | {atom(), atom()} | {'global', atom()} | {'via', atom(), term()} | pid(). -type start_ret() :: {'ok', pid()} | {'error', term()}. diff --git a/lib/stdlib/src/gen_fsm.erl b/lib/stdlib/src/gen_fsm.erl index 96a53426e2..8c7db65563 100644 --- a/lib/stdlib/src/gen_fsm.erl +++ b/lib/stdlib/src/gen_fsm.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1996-2017. All Rights Reserved. +%% Copyright Ericsson AB 1996-2018. 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. @@ -198,7 +198,7 @@ %%% start(Name, Mod, Args, Options) %%% start_link(Mod, Args, Options) %%% start_link(Name, Mod, Args, Options) where: -%%% Name ::= {local, atom()} | {global, atom()} | {via, atom(), term()} +%%% Name ::= {local, atom()} | {global, term()} | {via, atom(), term()} %%% Mod ::= atom(), callback module implementing the 'real' fsm %%% Args ::= term(), init arguments (to Mod:init/1) %%% Options ::= [{debug, [Flag]}] diff --git a/lib/stdlib/src/gen_server.erl b/lib/stdlib/src/gen_server.erl index ac172325b5..77a46419f6 100644 --- a/lib/stdlib/src/gen_server.erl +++ b/lib/stdlib/src/gen_server.erl @@ -109,7 +109,7 @@ -define( STACKTRACE(), - try throw(ok) catch _ -> erlang:get_stacktrace() end). + element(2, erlang:process_info(self(), current_stacktrace))). %%%========================================================================= %%% API @@ -369,7 +369,7 @@ init_it(Mod, Args) -> {ok, Mod:init(Args)} catch throw:R -> {ok, R}; - Class:R -> {'EXIT', Class, R, erlang:get_stacktrace()} + Class:R:S -> {'EXIT', Class, R, S} end. %%%======================================================================== @@ -634,7 +634,7 @@ try_dispatch(Mod, Func, Msg, State) -> catch throw:R -> {ok, R}; - error:undef = R when Func == handle_info -> + error:undef = R:Stacktrace when Func == handle_info -> case erlang:function_exported(Mod, handle_info, 2) of false -> error_logger:warning_msg("** Undefined handle_info in ~p~n" @@ -642,10 +642,10 @@ try_dispatch(Mod, Func, Msg, State) -> [Mod, Msg]), {ok, {noreply, State}}; true -> - {'EXIT', error, R, erlang:get_stacktrace()} + {'EXIT', error, R, Stacktrace} end; - Class:R -> - {'EXIT', Class, R, erlang:get_stacktrace()} + Class:R:Stacktrace -> + {'EXIT', Class, R, Stacktrace} end. try_handle_call(Mod, Msg, From, State) -> @@ -654,8 +654,8 @@ try_handle_call(Mod, Msg, From, State) -> catch throw:R -> {ok, R}; - Class:R -> - {'EXIT', Class, R, erlang:get_stacktrace()} + Class:R:Stacktrace -> + {'EXIT', Class, R, Stacktrace} end. try_terminate(Mod, Reason, State) -> @@ -666,8 +666,8 @@ try_terminate(Mod, Reason, State) -> catch throw:R -> {ok, R}; - Class:R -> - {'EXIT', Class, R, erlang:get_stacktrace()} + Class:R:Stacktrace -> + {'EXIT', Class, R, Stacktrace} end; false -> {ok, ok} diff --git a/lib/stdlib/src/gen_statem.erl b/lib/stdlib/src/gen_statem.erl index cd6312855d..f95b2ea9cd 100644 --- a/lib/stdlib/src/gen_statem.erl +++ b/lib/stdlib/src/gen_statem.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 2016-2017. All Rights Reserved. +%% Copyright Ericsson AB 2016-2018. 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. @@ -78,9 +78,11 @@ -type data() :: term(). -type event_type() :: - {'call',From :: from()} | 'cast' | 'info' | - 'timeout' | {'timeout', Name :: term()} | 'state_timeout' | - 'internal'. + external_event_type() | timeout_event_type() | 'internal'. +-type external_event_type() :: + {'call',From :: from()} | 'cast' | 'info'. +-type timeout_event_type() :: + 'timeout' | {'timeout', Name :: term()} | 'state_timeout'. -type callback_mode_result() :: callback_mode() | [callback_mode() | state_enter()]. @@ -138,7 +140,9 @@ -type enter_action() :: 'hibernate' | % Set the hibernate option {'hibernate', Hibernate :: hibernate()} | - %% + timeout_action() | + reply_action(). +-type timeout_action() :: (Timeout :: event_timeout()) | % {timeout,Timeout} {'timeout', % Set the event_timeout option Time :: event_timeout(), EventContent :: term()} | @@ -159,9 +163,7 @@ {'state_timeout', % Set the state_timeout option Time :: state_timeout(), EventContent :: term(), - Options :: (timeout_option() | [timeout_option()])} | - %% - reply_action(). + Options :: (timeout_option() | [timeout_option()])}. -type reply_action() :: {'reply', % Reply to a caller From :: from(), Reply :: term()}. @@ -320,7 +322,13 @@ handle_event/4 % For callback_mode() =:= handle_event_function ]). + + %% Type validation functions +-compile( + {inline, + [callback_mode/1, state_enter/1, from/1, event_type/1]}). +%% callback_mode(CallbackMode) -> case CallbackMode of state_functions -> true; @@ -328,6 +336,14 @@ callback_mode(CallbackMode) -> _ -> false end. %% +state_enter(StateEnter) -> + case StateEnter of + state_enter -> + true; + _ -> + false + end. +%% from({Pid,_}) when is_pid(Pid) -> true; from(_) -> false. %% @@ -349,7 +365,49 @@ event_type(Type) -> -define( STACKTRACE(), - try throw(ok) catch _ -> erlang:get_stacktrace() end). + element(2, erlang:process_info(self(), current_stacktrace))). + +-define(not_sys_debug, []). +%% +%% This is a macro to only evaluate arguments if Debug =/= []. +%% Debug is evaluated multiple times. +-define( + sys_debug(Debug, NameState, Entry), + case begin Debug end of + ?not_sys_debug -> + begin Debug end; + _ -> + sys_debug(begin Debug end, begin NameState end, begin Entry end) + end). + +-record(state, + {callback_mode = undefined :: callback_mode() | undefined, + state_enter = false :: boolean(), + module :: atom(), + name :: atom(), + state :: term(), + data :: term(), + postponed = [] :: [{event_type(),term()}], + %% + timer_refs = #{} :: % timer ref => the timer's event type + #{reference() => timeout_event_type()}, + timer_types = #{} :: % timer's event type => timer ref + #{timeout_event_type() => reference()}, + cancel_timers = 0 :: non_neg_integer(), + %% We add a timer to both timer_refs and timer_types + %% when we start it. When we request an asynchronous + %% timer cancel we remove it from timer_types. When + %% the timer cancel message arrives we remove it from + %% timer_refs. + %% + hibernate = false :: boolean(), + hibernate_after = infinity :: timeout()}). + +-record(trans_opts, + {hibernate = false, + postpone = false, + timeouts_r = [], + next_events_r = []}). %%%========================================================================== %%% API @@ -422,6 +480,10 @@ stop(ServerRef, Reason, Timeout) -> %% Send an event to a state machine that arrives with type 'event' -spec cast(ServerRef :: server_ref(), Msg :: term()) -> ok. +cast(ServerRef, Msg) when is_pid(ServerRef) -> + send(ServerRef, wrap_cast(Msg)); +cast(ServerRef, Msg) when is_atom(ServerRef) -> + send(ServerRef, wrap_cast(Msg)); cast({global,Name}, Msg) -> try global:send(Name, wrap_cast(Msg)) of _ -> ok @@ -435,10 +497,6 @@ cast({via,RegMod,Name}, Msg) -> _:_ -> ok end; cast({Name,Node} = ServerRef, Msg) when is_atom(Name), is_atom(Node) -> - send(ServerRef, wrap_cast(Msg)); -cast(ServerRef, Msg) when is_atom(ServerRef) -> - send(ServerRef, wrap_cast(Msg)); -cast(ServerRef, Msg) when is_pid(ServerRef) -> send(ServerRef, wrap_cast(Msg)). %% Call a state machine (synchronous; a reply is expected) that @@ -455,73 +513,16 @@ call(ServerRef, Request) -> {'clean_timeout',T :: timeout()} | {'dirty_timeout',T :: timeout()}) -> Reply :: term(). +call(ServerRef, Request, infinity = T = Timeout) -> + call_dirty(ServerRef, Request, Timeout, T); +call(ServerRef, Request, {dirty_timeout, T} = Timeout) -> + call_dirty(ServerRef, Request, Timeout, T); +call(ServerRef, Request, {clean_timeout, T} = Timeout) -> + call_clean(ServerRef, Request, Timeout, T); +call(ServerRef, Request, {_, _} = Timeout) -> + erlang:error(badarg, [ServerRef,Request,Timeout]); call(ServerRef, Request, Timeout) -> - case parse_timeout(Timeout) of - {dirty_timeout,T} -> - try gen:call(ServerRef, '$gen_call', Request, T) of - {ok,Reply} -> - Reply - catch - Class:Reason -> - erlang:raise( - Class, - {Reason,{?MODULE,call,[ServerRef,Request,Timeout]}}, - erlang:get_stacktrace()) - end; - {clean_timeout,T} -> - %% Call server through proxy process to dodge any late reply - Ref = make_ref(), - Self = self(), - Pid = spawn( - fun () -> - Self ! - try gen:call( - ServerRef, '$gen_call', Request, T) of - Result -> - {Ref,Result} - catch Class:Reason -> - {Ref,Class,Reason, - erlang:get_stacktrace()} - end - end), - Mref = monitor(process, Pid), - receive - {Ref,Result} -> - demonitor(Mref, [flush]), - case Result of - {ok,Reply} -> - Reply - end; - {Ref,Class,Reason,Stacktrace} -> - demonitor(Mref, [flush]), - erlang:raise( - Class, - {Reason,{?MODULE,call,[ServerRef,Request,Timeout]}}, - Stacktrace); - {'DOWN',Mref,_,_,Reason} -> - %% There is a theoretical possibility that the - %% proxy process gets killed between try--of and ! - %% so this clause is in case of that - exit(Reason) - end; - Error when is_atom(Error) -> - erlang:error(Error, [ServerRef,Request,Timeout]) - end. - -parse_timeout(Timeout) -> - case Timeout of - {clean_timeout,_} -> - Timeout; - {dirty_timeout,_} -> - Timeout; - {_,_} -> - %% Be nice and throw a badarg for speling errors - badarg; - infinity -> - {dirty_timeout,infinity}; - T -> - {clean_timeout,T} - end. + call_clean(ServerRef, Request, Timeout, Timeout). %% Reply from a state machine callback to whom awaits in call/2 -spec reply([reply_action()] | reply_action()) -> ok. @@ -530,6 +531,7 @@ reply({reply,From,Reply}) -> reply(Replies) when is_list(Replies) -> replies(Replies). %% +-compile({inline, [reply/2]}). -spec reply(From :: from(), Reply :: term()) -> ok. reply({To,Tag}, Reply) when is_pid(To) -> Msg = {Tag,Reply}, @@ -579,9 +581,58 @@ enter_loop(Module, Opts, State, Data, Server, Actions) -> %%--------------------------------------------------------------------------- %% API helpers +-compile({inline, [wrap_cast/1]}). wrap_cast(Event) -> {'$gen_cast',Event}. +call_dirty(ServerRef, Request, Timeout, T) -> + try gen:call(ServerRef, '$gen_call', Request, T) of + {ok,Reply} -> + Reply + catch + Class:Reason:Stacktrace -> + erlang:raise( + Class, + {Reason,{?MODULE,call,[ServerRef,Request,Timeout]}}, + Stacktrace) + end. + +call_clean(ServerRef, Request, Timeout, T) -> + %% Call server through proxy process to dodge any late reply + Ref = make_ref(), + Self = self(), + Pid = spawn( + fun () -> + Self ! + try gen:call( + ServerRef, '$gen_call', Request, T) of + Result -> + {Ref,Result} + catch Class:Reason:Stacktrace -> + {Ref,Class,Reason,Stacktrace} + end + end), + Mref = monitor(process, Pid), + receive + {Ref,Result} -> + demonitor(Mref, [flush]), + case Result of + {ok,Reply} -> + Reply + end; + {Ref,Class,Reason,Stacktrace} -> + demonitor(Mref, [flush]), + erlang:raise( + Class, + {Reason,{?MODULE,call,[ServerRef,Request,Timeout]}}, + Stacktrace); + {'DOWN',Mref,_,_,Reason} -> + %% There is a theoretical possibility that the + %% proxy process gets killed between try--of and ! + %% so this clause is in case of that + exit(Reason) + end. + replies([{reply,From,Reply}|Replies]) -> reply(From, Reply), replies(Replies); @@ -606,60 +657,28 @@ enter(Module, Opts, State, Data, Server, Actions, Parent) -> %% The values should already have been type checked Name = gen:get_proc_name(Server), Debug = gen:debug_options(Name, Opts), - HibernateAfterTimeout = gen:hibernate_after(Opts), - Events = [], - P = [], + HibernateAfterTimeout = gen:hibernate_after(Opts), + Events = [], Event = {internal,init_state}, %% We enforce {postpone,false} to ensure that %% our fake Event gets discarded, thought it might get logged - NewActions = - if - is_list(Actions) -> - Actions ++ [{postpone,false}]; - true -> - [Actions,{postpone,false}] - end, - TimerRefs = #{}, - %% Key: timer ref - %% Value: the timer type i.e the timer's event type - %% - TimerTypes = #{}, - %% Key: timer type i.e the timer's event type - %% Value: timer ref - %% - %% We add a timer to both timer_refs and timer_types - %% when we start it. When we request an asynchronous - %% timer cancel we remove it from timer_types. When - %% the timer cancel message arrives we remove it from - %% timer_refs. - %% - Hibernate = false, - CancelTimers = 0, - S = #{ - callback_mode => undefined, - state_enter => false, - module => Module, - name => Name, - state => State, - data => Data, - postponed => P, - %% - %% The following fields are finally set from to the arguments to - %% loop_event_actions/9 when it finally loops back to loop/3 - %% in loop_event_result/11 - timer_refs => TimerRefs, - timer_types => TimerTypes, - hibernate => Hibernate, - hibernate_after => HibernateAfterTimeout, - cancel_timers => CancelTimers - }, - NewDebug = sys_debug(Debug, S, State, {enter,Event,State}), + NewActions = listify(Actions) ++ [{postpone,false}], + S = + #state{ + module = Module, + name = Name, + state = State, + data = Data, + hibernate_after = HibernateAfterTimeout}, + CallEnter = true, + NewDebug = ?sys_debug(Debug, {Name,State}, {enter,Event,State}), case call_callback_mode(S) of - {ok,NewS} -> + #state{} = NewS -> loop_event_actions( Parent, NewDebug, NewS, - Events, Event, State, Data, NewActions, true); - {Class,Reason,Stacktrace} -> + Events, Event, State, Data, #trans_opts{}, + NewActions, CallEnter); + [Class,Reason,Stacktrace] -> terminate( Class, Reason, Stacktrace, NewDebug, S, [Event|Events]) @@ -677,17 +696,14 @@ init_it(Starter, Parent, ServerRef, Module, Args, Opts) -> catch Result -> init_result(Starter, Parent, ServerRef, Module, Result, Opts); - Class:Reason -> - Stacktrace = erlang:get_stacktrace(), + Class:Reason:Stacktrace -> Name = gen:get_proc_name(ServerRef), gen:unregister_name(ServerRef), proc_lib:init_ack(Starter, {error,Reason}), error_info( Class, Reason, Stacktrace, - #{name => Name, - callback_mode => undefined, - state_enter => false}, - [], [], undefined), + #state{name = Name}, + [], undefined), erlang:raise(Class, Reason, Stacktrace) end. @@ -717,10 +733,8 @@ init_result(Starter, Parent, ServerRef, Module, Result, Opts) -> proc_lib:init_ack(Starter, {error,Error}), error_info( error, Error, ?STACKTRACE(), - #{name => Name, - callback_mode => undefined, - state_enter => false}, - [], [], undefined), + #state{name = Name}, + [], undefined), exit(Error) end. @@ -734,9 +748,10 @@ system_terminate(Reason, _Parent, Debug, S) -> terminate(exit, Reason, ?STACKTRACE(), Debug, S, []). system_code_change( - #{module := Module, - state := State, - data := Data} = S, + #state{ + module = Module, + state = State, + data = Data} = S, _Mod, OldVsn, Extra) -> case try Module:code_change(OldVsn, State, Data, Extra) @@ -746,29 +761,31 @@ system_code_change( of {ok,NewState,NewData} -> {ok, - S#{callback_mode := undefined, - state := NewState, - data := NewData}}; + S#state{ + callback_mode = undefined, + state = NewState, + data = NewData}}; {ok,_} = Error -> error({case_clause,Error}); Error -> Error end. -system_get_state(#{state := State, data := Data}) -> +system_get_state(#state{state = State, data = Data}) -> {ok,{State,Data}}. system_replace_state( StateFun, - #{state := State, - data := Data} = S) -> + #state{ + state = State, + data = Data} = S) -> {NewState,NewData} = Result = StateFun({State,Data}), - {ok,Result,S#{state := NewState, data := NewData}}. + {ok,Result,S#state{state = NewState, data = NewData}}. format_status( Opt, [PDict,SysState,Parent,Debug, - #{name := Name, postponed := P} = S]) -> + #state{name = Name, postponed = P} = S]) -> Header = gen:format_status_header("Status for state machine", Name), Log = sys:get_debug(log, Debug, []), [{header,Header}, @@ -787,6 +804,9 @@ format_status( %% them, not as the real erlang messages. Use trace for that. %%--------------------------------------------------------------------------- +sys_debug(Debug, NameState, Entry) -> + sys:handle_debug(Debug, fun print_event/3, NameState, Entry). + print_event(Dev, {in,Event}, {Name,State}) -> io:format( Dev, "*DBG* ~tp receive ~ts in state ~tp~n", @@ -819,15 +839,6 @@ event_string(Event) -> io_lib:format("~tw ~tp", [EventType,EventContent]) end. -sys_debug(Debug, #{name := Name}, State, Entry) -> - case Debug of - [] -> - Debug; - _ -> - sys:handle_debug( - Debug, fun print_event/3, {Name,State}, Entry) - end. - %%%========================================================================== %%% Internal callbacks @@ -842,14 +853,16 @@ wakeup_from_hibernate(Parent, Debug, S) -> %% and detours through sys:handle_system_message/7 and proc_lib:hibernate/3 %% Entry point for system_continue/3 -loop(Parent, Debug, #{hibernate := true, cancel_timers := 0} = S) -> +loop(Parent, Debug, #state{hibernate = true, cancel_timers = 0} = S) -> loop_hibernate(Parent, Debug, S); loop(Parent, Debug, S) -> loop_receive(Parent, Debug, S). loop_hibernate(Parent, Debug, S) -> + %% %% Does not return but restarts process at %% wakeup_from_hibernate/3 that jumps to loop_receive/3 + %% proc_lib:hibernate( ?MODULE, wakeup_from_hibernate, [Parent,Debug,S]), error( @@ -857,17 +870,18 @@ loop_hibernate(Parent, Debug, S) -> {wakeup_from_hibernate,3}}). %% Entry point for wakeup_from_hibernate/3 -loop_receive(Parent, Debug, #{hibernate_after := HibernateAfterTimeout} = S) -> +loop_receive( + Parent, Debug, #state{hibernate_after = HibernateAfterTimeout} = S) -> + %% receive Msg -> case Msg of {system,Pid,Req} -> - #{hibernate := Hibernate} = S, %% Does not return but tail recursively calls %% system_continue/3 that jumps to loop/3 sys:handle_system_msg( Req, Pid, Parent, ?MODULE, Debug, S, - Hibernate); + S#state.hibernate); {'EXIT',Parent,Reason} = EXIT -> %% EXIT is not a 2-tuple therefore %% not an event but this will stand out @@ -875,9 +889,9 @@ loop_receive(Parent, Debug, #{hibernate_after := HibernateAfterTimeout} = S) -> Q = [EXIT], terminate(exit, Reason, ?STACKTRACE(), Debug, S, Q); {timeout,TimerRef,TimerMsg} -> - #{timer_refs := TimerRefs, - timer_types := TimerTypes, - hibernate := Hibernate} = S, + #state{ + timer_refs = TimerRefs, + timer_types = TimerTypes} = S, case TimerRefs of #{TimerRef := TimerType} -> %% We know of this timer; is it a running @@ -887,7 +901,6 @@ loop_receive(Parent, Debug, #{hibernate_after := HibernateAfterTimeout} = S) -> #{TimerType := TimerRef} -> %% The timer type maps back to this %% timer ref, so it was a running timer - Event = {TimerType,TimerMsg}, %% Unregister the triggered timeout NewTimerRefs = maps:remove(TimerRef, TimerRefs), @@ -895,11 +908,10 @@ loop_receive(Parent, Debug, #{hibernate_after := HibernateAfterTimeout} = S) -> maps:remove(TimerType, TimerTypes), loop_receive_result( Parent, Debug, - S#{ - timer_refs := NewTimerRefs, - timer_types := NewTimerTypes}, - Hibernate, - Event); + S#state{ + timer_refs = NewTimerRefs, + timer_types = NewTimerTypes}, + TimerType, TimerMsg); _ -> %% This was a late timeout message %% from timer being cancelled, so @@ -909,14 +921,13 @@ loop_receive(Parent, Debug, #{hibernate_after := HibernateAfterTimeout} = S) -> end; _ -> %% Not our timer; present it as an event - Event = {info,Msg}, - loop_receive_result( - Parent, Debug, S, Hibernate, Event) + loop_receive_result(Parent, Debug, S, info, Msg) end; {cancel_timer,TimerRef,_} -> - #{timer_refs := TimerRefs, - cancel_timers := CancelTimers, - hibernate := Hibernate} = S, + #state{ + timer_refs = TimerRefs, + cancel_timers = CancelTimers, + hibernate = Hibernate} = S, case TimerRefs of #{TimerRef := _} -> %% We must have requested a cancel @@ -926,9 +937,9 @@ loop_receive(Parent, Debug, #{hibernate_after := HibernateAfterTimeout} = S) -> maps:remove(TimerRef, TimerRefs), NewCancelTimers = CancelTimers - 1, NewS = - S#{ - timer_refs := NewTimerRefs, - cancel_timers := NewCancelTimers}, + S#state{ + timer_refs = NewTimerRefs, + cancel_timers = NewCancelTimers}, if Hibernate =:= true, NewCancelTimers =:= 0 -> %% No more cancel_timer msgs to expect; @@ -940,297 +951,677 @@ loop_receive(Parent, Debug, #{hibernate_after := HibernateAfterTimeout} = S) -> _ -> %% Not our cancel_timer msg; %% present it as an event - Event = {info,Msg}, - loop_receive_result( - Parent, Debug, S, Hibernate, Event) + loop_receive_result(Parent, Debug, S, info, Msg) end; _ -> %% External msg - #{hibernate := Hibernate} = S, - Event = - case Msg of - {'$gen_call',From,Request} -> - {{call,From},Request}; - {'$gen_cast',E} -> - {cast,E}; - _ -> - {info,Msg} - end, - loop_receive_result( - Parent, Debug, S, Hibernate, Event) + case Msg of + {'$gen_call',From,Request} -> + loop_receive_result( + Parent, Debug, S, {call,From}, Request); + {'$gen_cast',Cast} -> + loop_receive_result(Parent, Debug, S, cast, Cast); + _ -> + loop_receive_result(Parent, Debug, S, info, Msg) + end end after HibernateAfterTimeout -> loop_hibernate(Parent, Debug, S) end. +loop_receive_result(Parent, ?not_sys_debug, S, Type, Content) -> + %% Here is the queue of not yet handled events created + Events = [], + loop_event(Parent, ?not_sys_debug, S, Events, Type, Content); loop_receive_result( - Parent, Debug, - #{state := State, - timer_types := TimerTypes, cancel_timers := CancelTimers} = S, - Hibernate, Event) -> - %% From now the 'hibernate' field in S is invalid - %% and will be restored when looping back - %% in loop_event_result/11 - NewDebug = sys_debug(Debug, S, State, {in,Event}), + Parent, Debug, #state{name = Name, state = State} = S, Type, Content) -> + NewDebug = sys_debug(Debug, {Name,State}, {in,{Type,Content}}), %% Here is the queue of not yet handled events created Events = [], - %% Cancel any running event timer - case - cancel_timer_by_type(timeout, TimerTypes, CancelTimers) - of - {_,CancelTimers} -> - %% No timer cancelled - loop_event(Parent, NewDebug, S, Events, Event, Hibernate); - {NewTimerTypes,NewCancelTimers} -> - %% The timer is removed from NewTimerTypes but - %% remains in TimerRefs until we get - %% the cancel_timer msg - NewS = - S#{ - timer_types := NewTimerTypes, - cancel_timers := NewCancelTimers}, - loop_event(Parent, NewDebug, NewS, Events, Event, Hibernate) - end. + loop_event(Parent, NewDebug, S, Events, Type, Content). %% Entry point for handling an event, received or enqueued loop_event( + Parent, Debug, #state{hibernate = Hibernate} = S, + Events, Type, Content) -> + %% + case Hibernate of + true -> + %% + %% If (this old) Hibernate is true here it can only be + %% because it was set from an event action + %% and we did not go into hibernation since there were + %% events in queue, so we do what the user + %% might rely on i.e collect garbage which + %% would have happened if we actually hibernated + %% and immediately was awakened. + %% + _ = garbage_collect(), + loop_event_state_function( + Parent, Debug, S, Events, Type, Content); + false -> + loop_event_state_function( + Parent, Debug, S, Events, Type, Content) + end. + +%% Call the state function +loop_event_state_function( Parent, Debug, - #{state := State, data := Data} = S, - Events, {Type,Content} = Event, Hibernate) -> + #state{state = State, data = Data} = S, + Events, Type, Content) -> + %% + %% The field 'hibernate' in S is now invalid and will be + %% restored when looping back to loop/3 or loop_event/6. %% - %% If (this old) Hibernate is true here it can only be - %% because it was set from an event action - %% and we did not go into hibernation since there were - %% events in queue, so we do what the user - %% might rely on i.e collect garbage which - %% would have happened if we actually hibernated - %% and immediately was awakened - Hibernate andalso garbage_collect(), + Event = {Type,Content}, + TransOpts = false, case call_state_function(S, Type, Content, State, Data) of - {ok,Result,NewS} -> - {NextState,NewData,Actions,EnterCall} = - parse_event_result( - true, Debug, NewS, - Events, Event, State, Data, Result), - loop_event_actions( - Parent, Debug, NewS, - Events, Event, NextState, NewData, Actions, EnterCall); - {Class,Reason,Stacktrace} -> + {Result, NewS} -> + loop_event_result( + Parent, Debug, NewS, + Events, Event, State, Data, TransOpts, Result); + [Class,Reason,Stacktrace] -> terminate( - Class, Reason, Stacktrace, Debug, S, - [Event|Events]) + Class, Reason, Stacktrace, Debug, S, [Event|Events]) end. -loop_event_actions( - Parent, Debug, - #{state := State, state_enter := StateEnter} = S, - Events, Event, NextState, NewData, - Actions, EnterCall) -> - %% Hibernate is reborn here as false being - %% the default value from parse_actions/4 - case parse_actions(Debug, S, State, Actions) of - {ok,NewDebug,Hibernate,TimeoutsR,Postpone,NextEventsR} -> - if - StateEnter, EnterCall -> - loop_event_enter( - Parent, NewDebug, S, - Events, Event, NextState, NewData, - Hibernate, TimeoutsR, Postpone, NextEventsR); - true -> - loop_event_result( - Parent, NewDebug, S, - Events, Event, NextState, NewData, - Hibernate, TimeoutsR, Postpone, NextEventsR) - end; - {Class,Reason,Stacktrace} -> +%% Make a state enter call to the state function +loop_event_state_enter( + Parent, Debug, #state{state = PrevState} = S, + Events, Event, NextState, NewData, TransOpts) -> + %% + case call_state_function(S, enter, PrevState, NextState, NewData) of + {Result, NewS} -> + loop_event_result( + Parent, Debug, NewS, + Events, Event, NextState, NewData, TransOpts, Result); + [Class,Reason,Stacktrace] -> terminate( - Class, Reason, Stacktrace, Debug, S, - [Event|Events]) + Class, Reason, Stacktrace, Debug, S, [Event|Events]) end. -loop_event_enter( - Parent, Debug, #{state := State} = S, - Events, Event, NextState, NewData, - Hibernate, TimeoutsR, Postpone, NextEventsR) -> - case call_state_function(S, enter, State, NextState, NewData) of - {ok,Result,NewS} -> - case parse_event_result( - false, Debug, NewS, - Events, Event, NextState, NewData, Result) of - {_,NewerData,Actions,EnterCall} -> - loop_event_enter_actions( - Parent, Debug, NewS, - Events, Event, NextState, NewerData, - Hibernate, TimeoutsR, Postpone, NextEventsR, - Actions, EnterCall) - end; - {Class,Reason,Stacktrace} -> - terminate( - Class, Reason, Stacktrace, Debug, - S#{ - state := NextState, - data := NewData, - hibernate := Hibernate}, - [Event|Events]) +%% Process the result from the state function. +%% When TransOpts =:= false it was a state function call, +%% otherwise it is an option tuple and it was a state enter call. +%% +loop_event_result( + Parent, Debug, S, + Events, Event, State, Data, TransOpts, Result) -> + %% + case Result of + {next_state,State,NewData} -> + loop_event_actions( + Parent, Debug, S, + Events, Event, State, NewData, TransOpts, + [], false); + {next_state,NextState,NewData} + when TransOpts =:= false -> + loop_event_actions( + Parent, Debug, S, + Events, Event, NextState, NewData, TransOpts, + [], true); + {next_state,State,NewData,Actions} -> + loop_event_actions( + Parent, Debug, S, + Events, Event, State, NewData, TransOpts, + Actions, false); + {next_state,NextState,NewData,Actions} + when TransOpts =:= false -> + loop_event_actions( + Parent, Debug, S, + Events, Event, NextState, NewData, TransOpts, + Actions, true); + %% + {keep_state,NewData} -> + loop_event_actions( + Parent, Debug, S, + Events, Event, State, NewData, TransOpts, + [], false); + {keep_state,NewData,Actions} -> + loop_event_actions( + Parent, Debug, S, + Events, Event, State, NewData, TransOpts, + Actions, false); + %% + keep_state_and_data -> + loop_event_actions( + Parent, Debug, S, + Events, Event, State, Data, TransOpts, + [], false); + {keep_state_and_data,Actions} -> + loop_event_actions( + Parent, Debug, S, + Events, Event, State, Data, TransOpts, + Actions, false); + %% + {repeat_state,NewData} -> + loop_event_actions( + Parent, Debug, S, + Events, Event, State, NewData, TransOpts, + [], true); + {repeat_state,NewData,Actions} -> + loop_event_actions( + Parent, Debug, S, + Events, Event, State, NewData, TransOpts, + Actions, true); + %% + repeat_state_and_data -> + loop_event_actions( + Parent, Debug, S, + Events, Event, State, Data, TransOpts, + [], true); + {repeat_state_and_data,Actions} -> + loop_event_actions( + Parent, Debug, S, + Events, Event, State, Data, TransOpts, + Actions, true); + %% + stop -> + terminate( + exit, normal, ?STACKTRACE(), Debug, + S#state{ + state = State, data = Data, + hibernate = hibernate_in_trans_opts(TransOpts)}, + [Event|Events]); + {stop,Reason} -> + terminate( + exit, Reason, ?STACKTRACE(), Debug, + S#state{ + state = State, data = Data, + hibernate = hibernate_in_trans_opts(TransOpts)}, + [Event|Events]); + {stop,Reason,NewData} -> + terminate( + exit, Reason, ?STACKTRACE(), Debug, + S#state{ + state = State, data = NewData, + hibernate = hibernate_in_trans_opts(TransOpts)}, + [Event|Events]); + %% + {stop_and_reply,Reason,Replies} -> + reply_then_terminate( + exit, Reason, ?STACKTRACE(), Debug, + S#state{ + state = State, data = Data, + hibernate = hibernate_in_trans_opts(TransOpts)}, + [Event|Events], Replies); + {stop_and_reply,Reason,Replies,NewData} -> + reply_then_terminate( + exit, Reason, ?STACKTRACE(), Debug, + S#state{ + state = State, data = NewData, + hibernate = hibernate_in_trans_opts(TransOpts)}, + [Event|Events], Replies); + %% + _ -> + terminate( + error, + {bad_return_from_state_function,Result}, + ?STACKTRACE(), Debug, + S#state{ + state = State, data = Data, + hibernate = hibernate_in_trans_opts(TransOpts)}, + [Event|Events]) end. -loop_event_enter_actions( - Parent, Debug, #{state_enter := StateEnter} = S, - Events, Event, NextState, NewData, - Hibernate, TimeoutsR, Postpone, NextEventsR, - Actions, EnterCall) -> - case - parse_enter_actions( - Debug, S, NextState, Actions, Hibernate, TimeoutsR) - of - {ok,NewDebug,NewHibernate,NewTimeoutsR,_,_} -> - if - StateEnter, EnterCall -> - loop_event_enter( - Parent, NewDebug, S, - Events, Event, NextState, NewData, - NewHibernate, NewTimeoutsR, Postpone, NextEventsR); - true -> - loop_event_result( - Parent, NewDebug, S, - Events, Event, NextState, NewData, - NewHibernate, NewTimeoutsR, Postpone, NextEventsR) - end; - {Class,Reason,Stacktrace} -> - terminate( - Class, Reason, Stacktrace, Debug, - S#{ - state := NextState, - data := NewData, - hibernate := Hibernate}, - [Event|Events]) +-compile({inline, [hibernate_in_trans_opts/1]}). +hibernate_in_trans_opts(false) -> + (#trans_opts{})#trans_opts.hibernate; +hibernate_in_trans_opts(#trans_opts{hibernate = Hibernate}) -> + Hibernate. + +%% Ensure that Actions are a list +loop_event_actions( + Parent, Debug, S, + Events, Event, NextState, NewerData, TransOpts, + Actions, CallEnter) -> + loop_event_actions_list( + Parent, Debug, S, + Events, Event, NextState, NewerData, TransOpts, + listify(Actions), CallEnter). + +%% Process actions from the state function +loop_event_actions_list( + Parent, Debug, #state{state_enter = StateEnter} = S, + Events, Event, NextState, NewerData, TransOpts, + Actions, CallEnter) -> + %% + case parse_actions(TransOpts, Debug, S, Actions) of + {NewDebug,NewTransOpts} + when StateEnter, CallEnter -> + loop_event_state_enter( + Parent, NewDebug, S, + Events, Event, NextState, NewerData, NewTransOpts); + {NewDebug,NewTransOpts} -> + loop_event_done( + Parent, NewDebug, S, + Events, Event, NextState, NewerData, NewTransOpts); + [Class,Reason,Stacktrace,NewDebug] -> + terminate( + Class, Reason, Stacktrace, NewDebug, + S#state{ + state = NextState, + data = NewerData, + hibernate = TransOpts#trans_opts.hibernate}, + [Event|Events]) end. -loop_event_result( +parse_actions(false, Debug, S, Actions) -> + parse_actions(true, Debug, S, Actions, #trans_opts{}); +parse_actions(TransOpts, Debug, S, Actions) -> + parse_actions(false, Debug, S, Actions, TransOpts). +%% +parse_actions(_StateCall, Debug, _S, [], TransOpts) -> + {Debug,TransOpts}; +parse_actions(StateCall, Debug, S, [Action|Actions], TransOpts) -> + case Action of + %% Actual actions + {reply,From,Reply} -> + parse_actions_reply( + StateCall, Debug, S, Actions, TransOpts, From, Reply); + %% + %% Actions that set options + {hibernate,NewHibernate} when is_boolean(NewHibernate) -> + parse_actions( + StateCall, Debug, S, Actions, + TransOpts#trans_opts{hibernate = NewHibernate}); + hibernate -> + parse_actions( + StateCall, Debug, S, Actions, + TransOpts#trans_opts{hibernate = true}); + %% + {postpone,NewPostpone} when not NewPostpone orelse StateCall -> + parse_actions( + StateCall, Debug, S, Actions, + TransOpts#trans_opts{postpone = NewPostpone}); + postpone when StateCall -> + parse_actions( + StateCall, Debug, S, Actions, + TransOpts#trans_opts{postpone = true}); + %% + {next_event,Type,Content} -> + parse_actions_next_event( + StateCall, Debug, S, Actions, TransOpts, Type, Content); + %% + _ -> + parse_actions_timeout( + StateCall, Debug, S, Actions, TransOpts, Action) + end. + +parse_actions_reply( + StateCall, ?not_sys_debug, S, Actions, TransOpts, + From, Reply) -> + %% + case from(From) of + true -> + reply(From, Reply), + parse_actions(StateCall, ?not_sys_debug, S, Actions, TransOpts); + false -> + [error, + {bad_action_from_state_function,{reply,From,Reply}}, + ?STACKTRACE(), + ?not_sys_debug] + end; +parse_actions_reply( + StateCall, Debug, #state{name = Name, state = State} = S, + Actions, TransOpts, From, Reply) -> + %% + case from(From) of + true -> + reply(From, Reply), + NewDebug = sys_debug(Debug, {Name,State}, {out,Reply,From}), + parse_actions(StateCall, NewDebug, S, Actions, TransOpts); + false -> + [error, + {bad_action_from_state_function,{reply,From,Reply}}, + ?STACKTRACE(), + Debug] + end. + +parse_actions_next_event( + StateCall, ?not_sys_debug, S, + Actions, TransOpts, Type, Content) -> + case event_type(Type) of + true when StateCall -> + NextEventsR = TransOpts#trans_opts.next_events_r, + parse_actions( + StateCall, ?not_sys_debug, S, Actions, + TransOpts#trans_opts{ + next_events_r = [{Type,Content}|NextEventsR]}); + _ -> + [error, + {bad_action_from_state_function,{next_events,Type,Content}}, + ?STACKTRACE(), + ?not_sys_debug] + end; +parse_actions_next_event( + StateCall, Debug, #state{name = Name, state = State} = S, + Actions, TransOpts, Type, Content) -> + case event_type(Type) of + true when StateCall -> + NewDebug = sys_debug(Debug, {Name,State}, {in,{Type,Content}}), + NextEventsR = TransOpts#trans_opts.next_events_r, + parse_actions( + StateCall, NewDebug, S, Actions, + TransOpts#trans_opts{ + next_events_r = [{Type,Content}|NextEventsR]}); + _ -> + [error, + {bad_action_from_state_function,{next_events,Type,Content}}, + ?STACKTRACE(), + Debug] + end. + +parse_actions_timeout( + StateCall, Debug, S, Actions, TransOpts, + {TimerType,Time,TimerMsg,TimerOpts} = AbsoluteTimeout) -> + %% + case classify_timer(Time, listify(TimerOpts)) of + absolute -> + parse_actions_timeout_add( + StateCall, Debug, S, Actions, + TransOpts, AbsoluteTimeout); + relative -> + RelativeTimeout = {TimerType,Time,TimerMsg}, + parse_actions_timeout_add( + StateCall, Debug, S, Actions, + TransOpts, RelativeTimeout); + badarg -> + [error, + {bad_action_from_state_function,AbsoluteTimeout}, + ?STACKTRACE(), + Debug] + end; +parse_actions_timeout( + StateCall, Debug, S, Actions, TransOpts, + {_,Time,_} = RelativeTimeout) -> + case classify_timer(Time, []) of + relative -> + parse_actions_timeout_add( + StateCall, Debug, S, Actions, + TransOpts, RelativeTimeout); + badarg -> + [error, + {bad_action_from_state_function,RelativeTimeout}, + ?STACKTRACE(), + Debug] + end; +parse_actions_timeout( + StateCall, Debug, S, Actions, TransOpts, + Timeout) -> + case classify_timer(Timeout, []) of + relative -> + parse_actions_timeout_add( + StateCall, Debug, S, Actions, TransOpts, Timeout); + badarg -> + [error, + {bad_action_from_state_function,Timeout}, + ?STACKTRACE(), + Debug] + end. + +parse_actions_timeout_add( + StateCall, Debug, S, Actions, + #trans_opts{timeouts_r = TimeoutsR} = TransOpts, Timeout) -> + parse_actions( + StateCall, Debug, S, Actions, + TransOpts#trans_opts{timeouts_r = [Timeout|TimeoutsR]}). + +%% Do the state transition +loop_event_done( + Parent, ?not_sys_debug, + #state{postponed = P} = S, + Events, Event, NextState, NewData, + #trans_opts{ + postpone = Postpone, hibernate = Hibernate, + timeouts_r = [], next_events_r = []}) -> + %% + %% Optimize the simple cases + %% i.e no timer changes, no inserted events and no debug, + %% by duplicate stripped down code + %% + %% Fast path + %% + case Postpone of + true -> + loop_event_done_fast( + Parent, Hibernate, + S, + Events, [Event|P], NextState, NewData); + false -> + loop_event_done_fast( + Parent, Hibernate, + S, + Events, P, NextState, NewData) + end; +loop_event_done( Parent, Debug_0, - #{state := State, postponed := P_0, - timer_refs := TimerRefs_0, timer_types := TimerTypes_0, - cancel_timers := CancelTimers_0} = S_0, + #state{ + state = State, postponed = P_0, + timer_refs = TimerRefs_0, timer_types = TimerTypes_0, + cancel_timers = CancelTimers_0} = S, Events_0, Event_0, NextState, NewData, - Hibernate, TimeoutsR, Postpone, NextEventsR) -> + #trans_opts{ + hibernate = Hibernate, timeouts_r = TimeoutsR, + postpone = Postpone, next_events_r = NextEventsR}) -> %% %% All options have been collected and next_events are buffered. %% Do the actual state transition. %% - {Debug_1,P_1} = % Move current event to postponed if Postpone + %% Full feature path + %% + [Debug_1|P_1] = % Move current event to postponed if Postpone case Postpone of true -> - {sys_debug(Debug_0, S_0, State, {postpone,Event_0,State}), - [Event_0|P_0]}; + [?sys_debug( + Debug_0, + {S#state.name,State}, + {postpone,Event_0,State}), + Event_0|P_0]; false -> - {sys_debug(Debug_0, S_0, State, {consume,Event_0,State}), - P_0} + [?sys_debug( + Debug_0, + {S#state.name,State}, + {consume,Event_0,State})|P_0] end, - {Events_1,P_2,{TimerTypes_1,CancelTimers_1}} = - %% Move all postponed events to queue and cancel the - %% state timeout if the state changes + {Events_2,P_2,Timers_2} = + %% Move all postponed events to queue, + %% cancel the event timer, + %% and cancel the state timeout if the state changes if NextState =:= State -> - {Events_0,P_1,{TimerTypes_0,CancelTimers_0}}; + {Events_0,P_1, + cancel_timer_by_type( + timeout, {TimerTypes_0,CancelTimers_0})}; true -> {lists:reverse(P_1, Events_0), [], cancel_timer_by_type( - state_timeout, TimerTypes_0, CancelTimers_0)} - %% The state timer is removed from TimerTypes_1 - %% but remains in TimerRefs_0 until we get + state_timeout, + cancel_timer_by_type( + timeout, {TimerTypes_0,CancelTimers_0}))} + %% The state timer is removed from TimerTypes + %% but remains in TimerRefs until we get %% the cancel_timer msg end, - {TimerRefs_2,TimerTypes_2,CancelTimers_2,TimeoutEvents} = - %% Stop and start non-event timers - parse_timers(TimerRefs_0, TimerTypes_1, CancelTimers_1, TimeoutsR), + {TimerRefs_3,{TimerTypes_3,CancelTimers_3},TimeoutEvents} = + %% Stop and start timers + parse_timers(TimerRefs_0, Timers_2, TimeoutsR), %% Place next events last in reversed queue - Events_2R = lists:reverse(Events_1, NextEventsR), - %% Enqueue immediate timeout events and start event timer - Events_3R = prepend_timeout_events(TimeoutEvents, Events_2R), - S_1 = - S_0#{ - state := NextState, - data := NewData, - postponed := P_2, - timer_refs := TimerRefs_2, - timer_types := TimerTypes_2, - cancel_timers := CancelTimers_2, - hibernate := Hibernate}, - case lists:reverse(Events_3R) of - [] -> - %% Get a new event - loop(Parent, Debug_1, S_1); - [Event|Events] -> + Events_3R = lists:reverse(Events_2, NextEventsR), + %% Enqueue immediate timeout events + Events_4R = prepend_timeout_events(TimeoutEvents, Events_3R), + loop_event_done( + Parent, Debug_1, + S#state{ + state = NextState, + data = NewData, + postponed = P_2, + timer_refs = TimerRefs_3, + timer_types = TimerTypes_3, + cancel_timers = CancelTimers_3, + hibernate = Hibernate}, + lists:reverse(Events_4R)). + +%% Fast path +%% +loop_event_done_fast( + Parent, Hibernate, + #state{ + state = NextState, + timer_types = #{timeout := _} = TimerTypes, + cancel_timers = CancelTimers} = S, + Events, P, NextState, NewData) -> + %% + %% Same state, event timeout active + %% + loop_event_done_fast( + Parent, Hibernate, S, + Events, P, NextState, NewData, + cancel_timer_by_type( + timeout, {TimerTypes,CancelTimers})); +loop_event_done_fast( + Parent, Hibernate, + #state{state = NextState} = S, + Events, P, NextState, NewData) -> + %% + %% Same state + %% + loop_event_done( + Parent, ?not_sys_debug, + S#state{ + data = NewData, + postponed = P, + hibernate = Hibernate}, + Events); +loop_event_done_fast( + Parent, Hibernate, + #state{ + timer_types = #{timeout := _} = TimerTypes, + cancel_timers = CancelTimers} = S, + Events, P, NextState, NewData) -> + %% + %% State change, event timeout active + %% + loop_event_done_fast( + Parent, Hibernate, S, + lists:reverse(P, Events), [], NextState, NewData, + cancel_timer_by_type( + state_timeout, + cancel_timer_by_type( + timeout, {TimerTypes,CancelTimers}))); +loop_event_done_fast( + Parent, Hibernate, + #state{ + timer_types = #{state_timeout := _} = TimerTypes, + cancel_timers = CancelTimers} = S, + Events, P, NextState, NewData) -> + %% + %% State change, state timeout active + %% + loop_event_done_fast( + Parent, Hibernate, S, + lists:reverse(P, Events), [], NextState, NewData, + cancel_timer_by_type( + state_timeout, + cancel_timer_by_type( + timeout, {TimerTypes,CancelTimers}))); +loop_event_done_fast( + Parent, Hibernate, + #state{} = S, + Events, P, NextState, NewData) -> + %% + %% State change, no timeout to automatically cancel + %% + loop_event_done( + Parent, ?not_sys_debug, + S#state{ + state = NextState, + data = NewData, + postponed = [], + hibernate = Hibernate}, + lists:reverse(P, Events)). +%% +%% Fast path +%% +loop_event_done_fast( + Parent, Hibernate, S, + Events, P, NextState, NewData, + {TimerTypes,CancelTimers}) -> + %% + loop_event_done( + Parent, ?not_sys_debug, + S#state{ + state = NextState, + data = NewData, + postponed = P, + timer_types = TimerTypes, + cancel_timers = CancelTimers, + hibernate = Hibernate}, + Events). + +loop_event_done(Parent, Debug, S, Q) -> + case Q of + [] -> + %% Get a new event + loop(Parent, Debug, S); + [{Type,Content}|Events] -> %% Loop until out of enqueued events - loop_event(Parent, Debug_1, S_1, Events, Event, Hibernate) + loop_event(Parent, Debug, S, Events, Type, Content) end. %%--------------------------------------------------------------------------- %% Server loop helpers -call_callback_mode(#{module := Module} = S) -> +call_callback_mode(#state{module = Module} = S) -> try Module:callback_mode() of CallbackMode -> callback_mode_result(S, CallbackMode) catch CallbackMode -> callback_mode_result(S, CallbackMode); - Class:Reason -> - {Class,Reason,erlang:get_stacktrace()} + Class:Reason:Stacktrace -> + [Class,Reason,Stacktrace] end. callback_mode_result(S, CallbackMode) -> - case - parse_callback_mode( - if - is_atom(CallbackMode) -> - [CallbackMode]; - true -> - CallbackMode - end, undefined, false) - of - {undefined,_} -> - {error, - {bad_return_from_callback_mode,CallbackMode}, - ?STACKTRACE()}; - {CBMode,StateEnter} -> - {ok, - S#{ - callback_mode := CBMode, - state_enter := StateEnter}} - end. - -parse_callback_mode([], CBMode, StateEnter) -> - {CBMode,StateEnter}; -parse_callback_mode([H|T], CBMode, StateEnter) -> + callback_mode_result( + S, CallbackMode, listify(CallbackMode), undefined, false). +%% +callback_mode_result(_S, CallbackMode, [], undefined, _StateEnter) -> + [error, + {bad_return_from_callback_mode,CallbackMode}, + ?STACKTRACE()]; +callback_mode_result(S, _CallbackMode, [], CBMode, StateEnter) -> + S#state{callback_mode = CBMode, state_enter = StateEnter}; +callback_mode_result(S, CallbackMode, [H|T], CBMode, StateEnter) -> case callback_mode(H) of true -> - parse_callback_mode(T, H, StateEnter); + callback_mode_result(S, CallbackMode, T, H, StateEnter); false -> - case H of - state_enter -> - parse_callback_mode(T, CBMode, true); - _ -> - {undefined,StateEnter} + case state_enter(H) of + true -> + callback_mode_result(S, CallbackMode, T, CBMode, true); + false -> + [error, + {bad_return_from_callback_mode,CallbackMode}, + ?STACKTRACE()] end - end; -parse_callback_mode(_, _CBMode, StateEnter) -> - {undefined,StateEnter}. + end. call_state_function( - #{callback_mode := undefined} = S, Type, Content, State, Data) -> + #state{callback_mode = undefined} = S, Type, Content, State, Data) -> case call_callback_mode(S) of - {ok,NewS} -> + #state{} = NewS -> call_state_function(NewS, Type, Content, State, Data); Error -> Error end; call_state_function( - #{callback_mode := CallbackMode, module := Module} = S, + #state{callback_mode = CallbackMode, module = Module} = S, Type, Content, State, Data) -> try case CallbackMode of @@ -1241,333 +1632,108 @@ call_state_function( end of Result -> - {ok,Result,S} + {Result,S} catch Result -> - {ok,Result,S}; - Class:Reason -> - {Class,Reason,erlang:get_stacktrace()} - end. - - -%% Interpret all callback return variants -parse_event_result( - AllowStateChange, Debug, S, - Events, Event, State, Data, Result) -> - case Result of - stop -> - terminate( - exit, normal, ?STACKTRACE(), Debug, - S#{state := State, data := Data}, - [Event|Events]); - {stop,Reason} -> - terminate( - exit, Reason, ?STACKTRACE(), Debug, - S#{state := State, data := Data}, - [Event|Events]); - {stop,Reason,NewData} -> - terminate( - exit, Reason, ?STACKTRACE(), Debug, - S#{state := State, data := NewData}, - [Event|Events]); - %% - {stop_and_reply,Reason,Replies} -> - reply_then_terminate( - exit, Reason, ?STACKTRACE(), Debug, - S#{state := State, data := Data}, - [Event|Events], Replies); - {stop_and_reply,Reason,Replies,NewData} -> - reply_then_terminate( - exit, Reason, ?STACKTRACE(), Debug, - S#{state := State, data := NewData}, - [Event|Events], Replies); - %% - {next_state,State,NewData} -> - {State,NewData,[],false}; - {next_state,NextState,NewData} when AllowStateChange -> - {NextState,NewData,[],true}; - {next_state,State,NewData,Actions} -> - {State,NewData,Actions,false}; - {next_state,NextState,NewData,Actions} when AllowStateChange -> - {NextState,NewData,Actions,true}; - %% - {keep_state,NewData} -> - {State,NewData,[],false}; - {keep_state,NewData,Actions} -> - {State,NewData,Actions,false}; - keep_state_and_data -> - {State,Data,[],false}; - {keep_state_and_data,Actions} -> - {State,Data,Actions,false}; - %% - {repeat_state,NewData} -> - {State,NewData,[],true}; - {repeat_state,NewData,Actions} -> - {State,NewData,Actions,true}; - repeat_state_and_data -> - {State,Data,[],true}; - {repeat_state_and_data,Actions} -> - {State,Data,Actions,true}; - %% - _ -> - terminate( - error, - {bad_return_from_state_function,Result}, - ?STACKTRACE(), Debug, - S#{state := State, data := Data}, - [Event|Events]) - end. - - -parse_enter_actions(Debug, S, State, Actions, Hibernate, TimeoutsR) -> - Postpone = forbidden, - NextEventsR = forbidden, - parse_actions( - Debug, S, State, listify(Actions), - Hibernate, TimeoutsR, Postpone, NextEventsR). - -parse_actions(Debug, S, State, Actions) -> - Hibernate = false, - TimeoutsR = [infinity], %% Will cancel event timer - Postpone = false, - NextEventsR = [], - parse_actions( - Debug, S, State, listify(Actions), - Hibernate, TimeoutsR, Postpone, NextEventsR). -%% -parse_actions( - Debug, _S, _State, [], - Hibernate, TimeoutsR, Postpone, NextEventsR) -> - {ok,Debug,Hibernate,TimeoutsR,Postpone,NextEventsR}; -parse_actions( - Debug, S, State, [Action|Actions], - Hibernate, TimeoutsR, Postpone, NextEventsR) -> - case Action of - %% Actual actions - {reply,From,Reply} -> - case from(From) of - true -> - NewDebug = do_reply(Debug, S, State, From, Reply), - parse_actions( - NewDebug, S, State, Actions, - Hibernate, TimeoutsR, Postpone, NextEventsR); - false -> - {error, - {bad_action_from_state_function,Action}, - ?STACKTRACE()} - end; - %% - %% Actions that set options - {hibernate,NewHibernate} when is_boolean(NewHibernate) -> - parse_actions( - Debug, S, State, Actions, - NewHibernate, TimeoutsR, Postpone, NextEventsR); - hibernate -> - NewHibernate = true, - parse_actions( - Debug, S, State, Actions, - NewHibernate, TimeoutsR, Postpone, NextEventsR); - %% - {postpone,NewPostpone} - when is_boolean(NewPostpone), Postpone =/= forbidden -> - parse_actions( - Debug, S, State, Actions, - Hibernate, TimeoutsR, NewPostpone, NextEventsR); - postpone when Postpone =/= forbidden -> - NewPostpone = true, - parse_actions( - Debug, S, State, Actions, - Hibernate, TimeoutsR, NewPostpone, NextEventsR); - %% - {next_event,Type,Content} -> - case event_type(Type) of - true when NextEventsR =/= forbidden -> - NewDebug = - sys_debug(Debug, S, State, {in,{Type,Content}}), - parse_actions( - NewDebug, S, State, Actions, - Hibernate, TimeoutsR, Postpone, - [{Type,Content}|NextEventsR]); - _ -> - {error, - {bad_action_from_state_function,Action}, - ?STACKTRACE()} - end; - %% - {{timeout,_},_,_} = Timeout -> - parse_actions_timeout( - Debug, S, State, Actions, - Hibernate, TimeoutsR, Postpone, NextEventsR, Timeout); - {{timeout,_},_,_,_} = Timeout -> - parse_actions_timeout( - Debug, S, State, Actions, - Hibernate, TimeoutsR, Postpone, NextEventsR, Timeout); - {timeout,_,_} = Timeout -> - parse_actions_timeout( - Debug, S, State, Actions, - Hibernate, TimeoutsR, Postpone, NextEventsR, Timeout); - {timeout,_,_,_} = Timeout -> - parse_actions_timeout( - Debug, S, State, Actions, - Hibernate, TimeoutsR, Postpone, NextEventsR, Timeout); - {state_timeout,_,_} = Timeout -> - parse_actions_timeout( - Debug, S, State, Actions, - Hibernate, TimeoutsR, Postpone, NextEventsR, Timeout); - {state_timeout,_,_,_} = Timeout -> - parse_actions_timeout( - Debug, S, State, Actions, - Hibernate, TimeoutsR, Postpone, NextEventsR, Timeout); - Time -> - parse_actions_timeout( - Debug, S, State, Actions, - Hibernate, TimeoutsR, Postpone, NextEventsR, Time) + {Result,S}; + Class:Reason:Stacktrace -> + [Class,Reason,Stacktrace] end. -parse_actions_timeout( - Debug, S, State, Actions, - Hibernate, TimeoutsR, Postpone, NextEventsR, Timeout) -> - case Timeout of - {TimerType,Time,TimerMsg,TimerOpts} -> - case validate_timer_args(Time, listify(TimerOpts)) of - true -> - parse_actions( - Debug, S, State, Actions, - Hibernate, [Timeout|TimeoutsR], - Postpone, NextEventsR); - false -> - NewTimeout = {TimerType,Time,TimerMsg}, - parse_actions( - Debug, S, State, Actions, - Hibernate, [NewTimeout|TimeoutsR], - Postpone, NextEventsR); - error -> - {error, - {bad_action_from_state_function,Timeout}, - ?STACKTRACE()} - end; - {_,Time,_} -> - case validate_timer_args(Time, []) of - false -> - parse_actions( - Debug, S, State, Actions, - Hibernate, [Timeout|TimeoutsR], - Postpone, NextEventsR); - error -> - {error, - {bad_action_from_state_function,Timeout}, - ?STACKTRACE()} - end; - Time -> - case validate_timer_args(Time, []) of - false -> - parse_actions( - Debug, S, State, Actions, - Hibernate, [Timeout|TimeoutsR], - Postpone, NextEventsR); - error -> - {error, - {bad_action_from_state_function,Timeout}, - ?STACKTRACE()} - end - end. -validate_timer_args(Time, Opts) -> - validate_timer_args(Time, Opts, false). +%% -> absolute | relative | badarg +classify_timer(Time, Opts) -> + classify_timer(Time, Opts, false). %% -validate_timer_args(Time, [], true) when is_integer(Time) -> - true; -validate_timer_args(Time, [], false) when is_integer(Time), Time >= 0 -> - false; -validate_timer_args(infinity, [], Abs) -> - Abs; -validate_timer_args(Time, [{abs,Abs}|Opts], _) when is_boolean(Abs) -> - validate_timer_args(Time, Opts, Abs); -validate_timer_args(_, [_|_], _) -> - error. +classify_timer(Time, [], Abs) -> + case Abs of + true when + is_integer(Time); + Time =:= infinity -> + absolute; + false when + is_integer(Time), 0 =< Time; + Time =:= infinity -> + relative; + _ -> + badarg + end; +classify_timer(Time, [{abs,Abs}|Opts], _) when is_boolean(Abs) -> + classify_timer(Time, Opts, Abs); +classify_timer(_, Opts, _) when is_list(Opts) -> + badarg. %% Stop and start timers as well as create timeout zero events %% and pending event timer %% %% Stop and start timers non-event timers -parse_timers(TimerRefs, TimerTypes, CancelTimers, TimeoutsR) -> - parse_timers(TimerRefs, TimerTypes, CancelTimers, TimeoutsR, #{}, []). +parse_timers(TimerRefs, Timers, TimeoutsR) -> + parse_timers(TimerRefs, Timers, TimeoutsR, #{}, []). %% parse_timers( - TimerRefs, TimerTypes, CancelTimers, [], _Seen, TimeoutEvents) -> - {TimerRefs,TimerTypes,CancelTimers,TimeoutEvents}; + TimerRefs, Timers, [], _Seen, TimeoutEvents) -> + %% + {TimerRefs,Timers,TimeoutEvents}; parse_timers( - TimerRefs, TimerTypes, CancelTimers, [Timeout|TimeoutsR], - Seen, TimeoutEvents) -> + TimerRefs, Timers, [Timeout|TimeoutsR], Seen, TimeoutEvents) -> + %% case Timeout of {TimerType,Time,TimerMsg,TimerOpts} -> %% Absolute timer parse_timers( - TimerRefs, TimerTypes, CancelTimers, TimeoutsR, - Seen, TimeoutEvents, + TimerRefs, Timers, TimeoutsR, Seen, TimeoutEvents, TimerType, Time, TimerMsg, listify(TimerOpts)); %% Relative timers below {TimerType,0,TimerMsg} -> parse_timers( - TimerRefs, TimerTypes, CancelTimers, TimeoutsR, - Seen, TimeoutEvents, + TimerRefs, Timers, TimeoutsR, Seen, TimeoutEvents, TimerType, zero, TimerMsg, []); {TimerType,Time,TimerMsg} -> parse_timers( - TimerRefs, TimerTypes, CancelTimers, TimeoutsR, - Seen, TimeoutEvents, + TimerRefs, Timers, TimeoutsR, Seen, TimeoutEvents, TimerType, Time, TimerMsg, []); 0 -> parse_timers( - TimerRefs, TimerTypes, CancelTimers, TimeoutsR, - Seen, TimeoutEvents, + TimerRefs, Timers, TimeoutsR, Seen, TimeoutEvents, timeout, zero, 0, []); Time -> parse_timers( - TimerRefs, TimerTypes, CancelTimers, TimeoutsR, - Seen, TimeoutEvents, + TimerRefs, Timers, TimeoutsR, Seen, TimeoutEvents, timeout, Time, Time, []) end. parse_timers( - TimerRefs, TimerTypes, CancelTimers, TimeoutsR, - Seen, TimeoutEvents, + TimerRefs, Timers, TimeoutsR, Seen, TimeoutEvents, TimerType, Time, TimerMsg, TimerOpts) -> case Seen of #{TimerType := _} -> %% Type seen before - ignore parse_timers( - TimerRefs, TimerTypes, CancelTimers, TimeoutsR, - Seen, TimeoutEvents); + TimerRefs, Timers, TimeoutsR, Seen, TimeoutEvents); #{} -> %% Unseen type - handle NewSeen = Seen#{TimerType => true}, case Time of infinity -> %% Cancel any running timer - {NewTimerTypes,NewCancelTimers} = - cancel_timer_by_type( - TimerType, TimerTypes, CancelTimers), parse_timers( - TimerRefs, NewTimerTypes, NewCancelTimers, TimeoutsR, - NewSeen, TimeoutEvents); + TimerRefs, cancel_timer_by_type(TimerType, Timers), + TimeoutsR, NewSeen, TimeoutEvents); zero -> %% Cancel any running timer - {NewTimerTypes,NewCancelTimers} = - cancel_timer_by_type( - TimerType, TimerTypes, CancelTimers), %% Handle zero time timeouts later - TimeoutEvent = {TimerType,TimerMsg}, parse_timers( - TimerRefs, NewTimerTypes, NewCancelTimers, TimeoutsR, - NewSeen, [TimeoutEvent|TimeoutEvents]); + TimerRefs, cancel_timer_by_type(TimerType, Timers), + TimeoutsR, NewSeen, + [{TimerType,TimerMsg}|TimeoutEvents]); _ -> %% (Re)start the timer TimerRef = erlang:start_timer( Time, self(), TimerMsg, TimerOpts), - case TimerTypes of - #{TimerType := OldTimerRef} -> + case Timers of + {#{TimerType := OldTimerRef} = TimerTypes, + CancelTimers} -> %% Cancel the running timer cancel_timer(OldTimerRef), NewCancelTimers = CancelTimers + 1, @@ -1575,17 +1741,17 @@ parse_timers( %% both TimerRefs and TimerTypes parse_timers( TimerRefs#{TimerRef => TimerType}, - TimerTypes#{TimerType => TimerRef}, - NewCancelTimers, TimeoutsR, - NewSeen, TimeoutEvents); - #{} -> + {TimerTypes#{TimerType => TimerRef}, + NewCancelTimers}, + TimeoutsR, NewSeen, TimeoutEvents); + {#{} = TimerTypes,CancelTimers} -> %% Insert the new timer into %% both TimerRefs and TimerTypes parse_timers( TimerRefs#{TimerRef => TimerType}, - TimerTypes#{TimerType => TimerRef}, - CancelTimers, TimeoutsR, - NewSeen, TimeoutEvents) + {TimerTypes#{TimerType => TimerRef}, + CancelTimers}, + TimeoutsR, NewSeen, TimeoutEvents) end end end. @@ -1607,6 +1773,8 @@ prepend_timeout_events([], EventsR) -> prepend_timeout_events([{timeout,_} = TimeoutEvent|TimeoutEvents], []) -> prepend_timeout_events(TimeoutEvents, [TimeoutEvent]); prepend_timeout_events([{timeout,_}|TimeoutEvents], EventsR) -> + %% Ignore since there are other events in queue + %% so they have cancelled the event timeout 0. prepend_timeout_events(TimeoutEvents, EventsR); prepend_timeout_events([TimeoutEvent|TimeoutEvents], EventsR) -> %% Just prepend all others @@ -1617,23 +1785,28 @@ prepend_timeout_events([TimeoutEvent|TimeoutEvents], EventsR) -> %%--------------------------------------------------------------------------- %% Server helpers -reply_then_terminate( - Class, Reason, Stacktrace, Debug, - #{state := State} = S, Q, Replies) -> +reply_then_terminate(Class, Reason, Stacktrace, Debug, S, Q, Replies) -> do_reply_then_terminate( - Class, Reason, Stacktrace, Debug, - S, Q, listify(Replies), State). + Class, Reason, Stacktrace, Debug, S, Q, listify(Replies)). %% do_reply_then_terminate( - Class, Reason, Stacktrace, Debug, S, Q, [], _State) -> + Class, Reason, Stacktrace, Debug, S, Q, []) -> terminate(Class, Reason, Stacktrace, Debug, S, Q); do_reply_then_terminate( - Class, Reason, Stacktrace, Debug, S, Q, [R|Rs], State) -> + Class, Reason, Stacktrace, Debug, S, Q, [R|Rs]) -> case R of {reply,{_To,_Tag}=From,Reply} -> - NewDebug = do_reply(Debug, S, State, From, Reply), + reply(From, Reply), + NewDebug = + ?sys_debug( + Debug, + begin + #state{name = Name, state = State} = S, + {Name,State} + end, + {out,Reply,From}), do_reply_then_terminate( - Class, Reason, Stacktrace, NewDebug, S, Q, Rs, State); + Class, Reason, Stacktrace, NewDebug, S, Q, Rs); _ -> terminate( error, @@ -1642,14 +1815,9 @@ do_reply_then_terminate( Debug, S, Q) end. -do_reply(Debug, S, State, From, Reply) -> - reply(From, Reply), - sys_debug(Debug, S, State, {out,Reply,From}). - - terminate( Class, Reason, Stacktrace, Debug, - #{module := Module, state := State, data := Data, postponed := P} = S, + #state{module = Module, state = State, data = Data} = S, Q) -> case erlang:function_exported(Module, terminate, 3) of true -> @@ -1657,10 +1825,9 @@ terminate( _ -> ok catch _ -> ok; - C:R -> - ST = erlang:get_stacktrace(), + C:R:ST -> error_info( - C, R, ST, S, Q, P, + C, R, ST, S, Q, format_status(terminate, get(), S)), sys:print_log(Debug), erlang:raise(C, R, ST) @@ -1671,14 +1838,14 @@ terminate( _ = case Reason of normal -> - sys_debug(Debug, S, State, {terminate,Reason}); + terminate_sys_debug(Debug, S, State, Reason); shutdown -> - sys_debug(Debug, S, State, {terminate,Reason}); + terminate_sys_debug(Debug, S, State, Reason); {shutdown,_} -> - sys_debug(Debug, S, State, {terminate,Reason}); + terminate_sys_debug(Debug, S, State, Reason); _ -> error_info( - Class, Reason, Stacktrace, S, Q, P, + Class, Reason, Stacktrace, S, Q, format_status(terminate, get(), S)), sys:print_log(Debug) end, @@ -1689,12 +1856,18 @@ terminate( erlang:raise(Class, Reason, Stacktrace) end. +terminate_sys_debug(Debug, S, State, Reason) -> + ?sys_debug(Debug, {S#state.name,State}, {terminate,Reason}). + + error_info( Class, Reason, Stacktrace, - #{name := Name, - callback_mode := CallbackMode, - state_enter := StateEnter}, - Q, P, FmtData) -> + #state{ + name = Name, + callback_mode = CallbackMode, + state_enter = StateEnter, + postponed = P}, + Q, FmtData) -> {FixedReason,FixedStacktrace} = case Stacktrace of [{M,F,Args,_}|ST] @@ -1775,7 +1948,7 @@ error_info( %% Call Module:format_status/2 or return a default value format_status( Opt, PDict, - #{module := Module, state := State, data := Data}) -> + #state{module = Module, state = State, data = Data}) -> case erlang:function_exported(Module, format_status, 2) of true -> try Module:format_status(Opt, [PDict,State,Data]) @@ -1800,6 +1973,7 @@ format_status_default(Opt, State, Data) -> [{data,[{"State",StateData}]}] end. +-compile({inline, [listify/1]}). listify(Item) when is_list(Item) -> Item; listify(Item) -> @@ -1813,14 +1987,16 @@ listify(Item) -> %% %% Remove the timer from TimerTypes. %% When we get the cancel_timer msg we remove it from TimerRefs. -cancel_timer_by_type(TimerType, TimerTypes, CancelTimers) -> +-compile({inline, [cancel_timer_by_type/2]}). +cancel_timer_by_type(TimerType, {TimerTypes,CancelTimers} = TT_CT) -> case TimerTypes of #{TimerType := TimerRef} -> - cancel_timer(TimerRef), + ok = erlang:cancel_timer(TimerRef, [{async,true}]), {maps:remove(TimerType, TimerTypes),CancelTimers + 1}; #{} -> - {TimerTypes,CancelTimers} + TT_CT end. +-compile({inline, [cancel_timer/1]}). cancel_timer(TimerRef) -> ok = erlang:cancel_timer(TimerRef, [{async,true}]). diff --git a/lib/stdlib/src/io_lib.erl b/lib/stdlib/src/io_lib.erl index 3c8430b820..cacd9f2524 100644 --- a/lib/stdlib/src/io_lib.erl +++ b/lib/stdlib/src/io_lib.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1996-2017. All Rights Reserved. +%% Copyright Ericsson AB 1996-2018. 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. @@ -149,7 +149,7 @@ fread(Chars, Format) -> -spec fread(Continuation, CharSpec, Format) -> Return when Continuation :: continuation() | [], - CharSpec :: string() | eof, + CharSpec :: string() | 'eof', Format :: string(), Return :: {'more', Continuation1 :: continuation()} | {'done', Result, LeftOverChars :: string()}, diff --git a/lib/stdlib/src/io_lib_fread.erl b/lib/stdlib/src/io_lib_fread.erl index 983e8d4566..319bff484e 100644 --- a/lib/stdlib/src/io_lib_fread.erl +++ b/lib/stdlib/src/io_lib_fread.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1996-2017. All Rights Reserved. +%% Copyright Ericsson AB 1996-2018. 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. @@ -38,7 +38,7 @@ -spec fread(Continuation, String, Format) -> Return when Continuation :: io_lib:continuation() | [], - String :: string(), + String :: string() | 'eof', Format :: string(), Return :: {'more', Continuation1 :: io_lib:continuation()} | {'done', Result, LeftOverChars :: string()}, diff --git a/lib/stdlib/src/proc_lib.erl b/lib/stdlib/src/proc_lib.erl index 8e10cbe93b..1991585c13 100644 --- a/lib/stdlib/src/proc_lib.erl +++ b/lib/stdlib/src/proc_lib.erl @@ -231,8 +231,8 @@ init_p(Parent, Ancestors, Fun) when is_function(Fun) -> try Fun() catch - Class:Reason -> - exit_p(Class, Reason, erlang:get_stacktrace()) + Class:Reason:Stacktrace -> + exit_p(Class, Reason, Stacktrace) end. -spec init_p(pid(), [pid()], atom(), atom(), [term()]) -> term(). @@ -246,8 +246,8 @@ init_p_do_apply(M, F, A) -> try apply(M, F, A) catch - Class:Reason -> - exit_p(Class, Reason, erlang:get_stacktrace()) + Class:Reason:Stacktrace -> + exit_p(Class, Reason, Stacktrace) end. -spec wake_up(atom(), atom(), [term()]) -> term(). @@ -256,8 +256,8 @@ wake_up(M, F, A) when is_atom(M), is_atom(F), is_list(A) -> try apply(M, F, A) catch - Class:Reason -> - exit_p(Class, Reason, erlang:get_stacktrace()) + Class:Reason:Stacktrace -> + exit_p(Class, Reason, Stacktrace) end. exit_p(Class, Reason, Stacktrace) -> diff --git a/lib/stdlib/src/qlc.erl b/lib/stdlib/src/qlc.erl index f11f9d0a0b..3a66f6930b 100644 --- a/lib/stdlib/src/qlc.erl +++ b/lib/stdlib/src/qlc.erl @@ -301,11 +301,11 @@ eval(QH, Options) -> post_funs(Post) end end - catch Term -> - case erlang:get_stacktrace() of + catch throw:Term:Stacktrace -> + case Stacktrace of [?THROWN_ERROR | _] -> Term; - Stacktrace -> + _ -> erlang:raise(throw, Term, Stacktrace) end end @@ -359,11 +359,11 @@ fold(Fun, Acc0, QH, Options) -> post_funs(Post) end end - catch Term -> - case erlang:get_stacktrace() of + catch throw:Term:Stacktrace -> + case Stacktrace of [?THROWN_ERROR | _] -> Term; - Stacktrace -> + _ -> erlang:raise(throw, Term, Stacktrace) end end @@ -457,11 +457,11 @@ info(QH, Options) -> debug -> % Not documented. Intended for testing only. Info end - catch Term -> - case erlang:get_stacktrace() of + catch throw:Term:Stacktrace -> + case Stacktrace of [?THROWN_ERROR | _] -> Term; - Stacktrace -> + _ -> erlang:raise(throw, Term, Stacktrace) end end @@ -1056,9 +1056,9 @@ cursor_process(H, GUnique, GCache, TmpDir, SpawnOptions, MaxList, TmpUsage) -> Prep = prepare_qlc(H, not_a_list, GUnique, GCache, TmpDir, MaxList, TmpUsage), setup_qlc(Prep, Setup) - catch Class:Reason -> - Parent ! {self(), {caught, Class, Reason, - erlang:get_stacktrace()}}, + catch Class:Reason:Stacktrace -> + Parent ! {self(), + {caught, Class, Reason, Stacktrace}}, exit(normal) end, Parent ! {self(), ok}, @@ -1075,8 +1075,8 @@ parent_fun(Pid, Parent) -> {TPid, {parent_fun, Fun}} -> V = try {value, Fun()} - catch Class:Reason -> - {parent_fun_caught, Class, Reason, erlang:get_stacktrace()} + catch Class:Reason:Stacktrace -> + {parent_fun_caught, Class, Reason, Stacktrace} end, TPid ! {Parent, V}, parent_fun(Pid, Parent); @@ -1101,9 +1101,9 @@ reply(Parent, MonRef, Post, Cont) -> throw_error(Cont) end catch - Class:Reason -> + Class:Reason:Stacktrace -> post_funs(Post), - Message = {caught, Class, Reason, erlang:get_stacktrace()}, + Message = {caught, Class, Reason, Stacktrace}, Parent ! {self(), Message}, exit(normal) end, @@ -1392,9 +1392,8 @@ next_loop(Pid, L, N) when N =/= 0 -> {caught, throw, Error, [?THROWN_ERROR | _]} -> Error; {caught, Class, Reason, Stacktrace} -> - CurrentStacktrace = try erlang:error(foo) - catch error:_ -> erlang:get_stacktrace() - end, + {current_stacktrace, CurrentStacktrace} = + erlang:process_info(self(), current_stacktrace), erlang:raise(Class, Reason, Stacktrace ++ CurrentStacktrace); error -> erlang:error({qlc_cursor_pid_no_longer_exists, Pid}) @@ -2627,9 +2626,9 @@ table_handle(#qlc_table{trav_fun = TraverseFun, trav_MS = TravMS, Parent =:= self() -> try ParentFun() - catch Class:Reason -> + catch Class:Reason:Stacktrace -> post_funs(Post), - erlang:raise(Class, Reason, erlang:get_stacktrace()) + erlang:raise(Class, Reason, Stacktrace) end; true -> case monitor_request(Parent, {parent_fun, ParentFun}) of @@ -3033,9 +3032,9 @@ file_sort_handle(H, Kp, SortOptions, TmpDir, Compressed, Post, LocalPost) -> {terms, BTerms} -> try {[binary_to_term(B) || B <- BTerms], Post, LocalPost} - catch Class:Reason -> + catch Class:Reason:Stacktrace -> post_funs(Post), - erlang:raise(Class, Reason, erlang:get_stacktrace()) + erlang:raise(Class, Reason, Stacktrace) end end. @@ -3045,9 +3044,9 @@ do_sort(In, Out, Sort, SortOptions, Post) -> {error, Reason} -> throw_reason(Reason); Reply -> Reply end - catch Class:Term -> + catch Class:Term:Stacktrace -> post_funs(Post), - erlang:raise(Class, Term, erlang:get_stacktrace()) + erlang:raise(Class, Term, Stacktrace) end. do_sort(In, Out, sort, SortOptions) -> @@ -3797,9 +3796,9 @@ call(undefined, _Arg, Default, _Post) -> call(Fun, Arg, _Default, Post) -> try Fun(Arg) - catch Class:Reason -> + catch Class:Reason:Stacktrace -> post_funs(Post), - erlang:raise(Class, Reason, erlang:get_stacktrace()) + erlang:raise(Class, Reason, Stacktrace) end. grd(undefined, _Arg) -> diff --git a/lib/stdlib/src/shell.erl b/lib/stdlib/src/shell.erl index 212b143b1d..e4153e7899 100644 --- a/lib/stdlib/src/shell.erl +++ b/lib/stdlib/src/shell.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1996-2017. All Rights Reserved. +%% Copyright Ericsson AB 1996-2018. 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. @@ -645,8 +645,7 @@ eval_exprs(Es, Shell, Bs0, RT, Lf, Ef, W) -> catch exit:normal -> exit(normal); - Class:Reason -> - Stacktrace = erlang:get_stacktrace(), + Class:Reason:Stacktrace -> M = {self(),Class,{Reason,Stacktrace}}, case do_catch(Class, Reason) of true -> @@ -701,7 +700,9 @@ exprs([E0|Es], Bs1, RT, Lf, Ef, Bs0, W) -> {W,V0}; true -> case result_will_be_saved() of true -> V0; - false -> ignored + false -> + erlang:garbage_collect(), + ignored end end, {{value,V,Bs,get()},Bs}; @@ -805,8 +806,8 @@ restrict_handlers(RShMod, Shell, RT) -> -define(BAD_RETURN(M, F, V), try erlang:error(reason) - catch _:_ -> erlang:raise(exit, {restricted_shell_bad_return,V}, - [{M,F,3} | erlang:get_stacktrace()]) + catch _:_:S -> erlang:raise(exit, {restricted_shell_bad_return,V}, + [{M,F,3} | S]) end). local_allowed(F, As, RShMod, Bs, Shell, RT) when is_atom(F) -> diff --git a/lib/stdlib/src/sys.erl b/lib/stdlib/src/sys.erl index 1f966411c5..0c578acf21 100644 --- a/lib/stdlib/src/sys.erl +++ b/lib/stdlib/src/sys.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1996-2017. All Rights Reserved. +%% Copyright Ericsson AB 1996-2018. 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. @@ -38,7 +38,9 @@ -export_type([dbg_opt/0]). --type name() :: pid() | atom() | {'global', atom()}. +-type name() :: pid() | atom() + | {'global', term()} + | {'via', module(), term()}. -type system_event() :: {'in', Msg :: _} | {'in', Msg :: _, From :: _} | {'out', Msg :: _, To :: _} diff --git a/lib/stdlib/src/zip.erl b/lib/stdlib/src/zip.erl index 81f927f399..39be2abff6 100644 --- a/lib/stdlib/src/zip.erl +++ b/lib/stdlib/src/zip.erl @@ -457,8 +457,7 @@ do_zip(F, Files, Options) -> Out3 = Output({close, F}, Out2), {ok, Out3} catch - C:R -> - Stk = erlang:get_stacktrace(), + C:R:Stk -> zlib:close(Z), Output({close, F}, Out0), erlang:raise(C, R, Stk) diff --git a/lib/stdlib/test/array_SUITE.erl b/lib/stdlib/test/array_SUITE.erl index 5836f275ba..956582c4fd 100644 --- a/lib/stdlib/test/array_SUITE.erl +++ b/lib/stdlib/test/array_SUITE.erl @@ -141,10 +141,10 @@ t(What) -> io:format("Test ~p ~n",[T]), try ?MODULE:T([]) - catch _E:_R -> + catch _E:_R:_S -> Line = get(test_server_loc), io:format("Failed ~p:~p ~p ~p~n ~p~n", - [T,Line,_E,_R, erlang:get_stacktrace()]) + [T,Line,_E,_R,_S]) end end, What). @@ -161,8 +161,8 @@ extract_tests() -> end, [Call(Test) || Test <- Tests], io:format("Tests ~p~n", [Tests]) - catch _:Err -> - io:format("Error: ~p ~p~n", [Err, erlang:get_stacktrace()]) + catch _:Err:Stacktrace -> + io:format("Error: ~p ~p~n", [Err, Stacktrace]) end, file:close(In), file:close(Out). diff --git a/lib/stdlib/test/epp_SUITE.erl b/lib/stdlib/test/epp_SUITE.erl index 915f478dfa..9123bf2f28 100644 --- a/lib/stdlib/test/epp_SUITE.erl +++ b/lib/stdlib/test/epp_SUITE.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1998-2017. All Rights Reserved. +%% Copyright Ericsson AB 1998-2018. 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. @@ -551,8 +551,8 @@ otp_8130(Config) when is_list(Config) -> "t() -> " " L = \"{ 34 , \\\"1\\\\x{AAA}\\\" , \\\"34\\\" , X . a , $\\\\x{AAA} }\", " " R = ?M({34,\"1\\x{aaa}\",\"34\",X.a,$\\x{aaa}})," - " Lt = erl_scan:string(L, 1, [unicode])," - " Rt = erl_scan:string(R, 1, [unicode])," + " Lt = erl_scan:string(L, 1)," + " Rt = erl_scan:string(R, 1)," " Lt = Rt, ok. ">>, ok}, diff --git a/lib/stdlib/test/erl_lint_SUITE.erl b/lib/stdlib/test/erl_lint_SUITE.erl index 5efffc6a5c..e40f5e9a5d 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-2017. All Rights Reserved. +%% Copyright Ericsson AB 1999-2018. 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. @@ -3982,8 +3982,9 @@ non_latin1_module(Config) -> do_non_latin1_module(Mod) -> File = atom_to_list(Mod) ++ ".erl", - Forms = [{attribute,1,file,{File,1}}, - {attribute,1,module,Mod}, + L1 = erl_anno:new(1), + Forms = [{attribute,L1,file,{File,1}}, + {attribute,L1,module,Mod}, {eof,2}], error = compile:forms(Forms), {error,_,[]} = compile:forms(Forms, [return]), diff --git a/lib/stdlib/test/erl_pp_SUITE.erl b/lib/stdlib/test/erl_pp_SUITE.erl index 808ba9b4c1..dda8d0a12e 100644 --- a/lib/stdlib/test/erl_pp_SUITE.erl +++ b/lib/stdlib/test/erl_pp_SUITE.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 2006-2017. All Rights Reserved. +%% Copyright Ericsson AB 2006-2018. 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. @@ -1262,7 +1262,7 @@ parse_forms(Chars) -> parse_forms2([], _Cont, _Line, Forms) -> lists:reverse(Forms); parse_forms2(String, Cont0, Line, Forms) -> - case erl_scan:tokens(Cont0, String, Line, [unicode]) of + case erl_scan:tokens(Cont0, String, Line) of {done, {ok, Tokens, EndLine}, Chars} -> {ok, Form} = erl_parse:parse_form(Tokens), parse_forms2(Chars, [], EndLine, [Form | Forms]); @@ -1303,7 +1303,7 @@ parse_and_pp_expr(String, Indent, Options) -> erl_pp:expr(parse_expr(StringDot), Indent, Options). parse_expr(Chars) -> - {ok, Tokens, _} = erl_scan:string(Chars, 1, [unicode]), + {ok, Tokens, _} = erl_scan:string(Chars, 1), {ok, [Expr]} = erl_parse:parse_exprs(Tokens), Expr. diff --git a/lib/stdlib/test/error_logger_h_SUITE.erl b/lib/stdlib/test/error_logger_h_SUITE.erl index 1f2a9fda0b..9dc04f27a1 100644 --- a/lib/stdlib/test/error_logger_h_SUITE.erl +++ b/lib/stdlib/test/error_logger_h_SUITE.erl @@ -257,8 +257,7 @@ match_output([Item|T], Lines0, AtNode, Depth) -> Lines -> match_output(T, Lines, AtNode, Depth) catch - C:E -> - Stk = erlang:get_stacktrace(), + C:E:Stk -> io:format("ITEM: ~p", [Item]), io:format("LINES: ~p", [Lines0]), erlang:raise(C, E, Stk) diff --git a/lib/stdlib/test/escript_SUITE_data/unicode1 b/lib/stdlib/test/escript_SUITE_data/unicode1 index 351bb785e5..8dc9d450b8 100755 --- a/lib/stdlib/test/escript_SUITE_data/unicode1 +++ b/lib/stdlib/test/escript_SUITE_data/unicode1 @@ -8,7 +8,7 @@ main(_) -> _D = erlang:system_flag(backtrace_depth, 0), A = <<"\x{aaa}"/utf8>>, S = lists:flatten(io_lib:format("~p/~p.", [A, A])), - {ok, Ts, _} = erl_scan:string(S, 1, [unicode]), + {ok, Ts, _} = erl_scan:string(S, 1), {ok, Es} = erl_parse:parse_exprs(Ts), B = erl_eval:new_bindings(), erl_eval:exprs(Es, B). diff --git a/lib/stdlib/test/escript_SUITE_data/unicode2 b/lib/stdlib/test/escript_SUITE_data/unicode2 index 495188f6f0..d0195b036c 100755 --- a/lib/stdlib/test/escript_SUITE_data/unicode2 +++ b/lib/stdlib/test/escript_SUITE_data/unicode2 @@ -8,7 +8,7 @@ main(_) -> _D = erlang:system_flag(backtrace_depth, 0), A = <<"\x{aa}">>, S = lists:flatten(io_lib:format("~p/~p.", [A, A])), - {ok, Ts, _} = erl_scan:string(S, 1, [unicode]), + {ok, Ts, _} = erl_scan:string(S, 1), {ok, Es} = erl_parse:parse_exprs(Ts), B = erl_eval:new_bindings(), erl_eval:exprs(Es, B). diff --git a/lib/stdlib/test/ets_SUITE.erl b/lib/stdlib/test/ets_SUITE.erl index 07c8b60cbd..0cfb1b5516 100644 --- a/lib/stdlib/test/ets_SUITE.erl +++ b/lib/stdlib/test/ets_SUITE.erl @@ -6023,17 +6023,23 @@ etsmem() -> end}, {Mem,AllTabs}. -verify_etsmem({MemInfo,AllTabs}) -> + +verify_etsmem(MI) -> wait_for_test_procs(), + verify_etsmem(MI, 1). + +verify_etsmem({MemInfo,AllTabs}, Try) -> case etsmem() of {MemInfo,_} -> io:format("Ets mem info: ~p", [MemInfo]), - case MemInfo of - {ErlMem,EtsAlloc} when ErlMem == notsup; EtsAlloc == undefined -> + case {MemInfo, Try} of + {{ErlMem,EtsAlloc},_} when ErlMem == notsup; EtsAlloc == undefined -> %% Use 'erl +Mea max' to do more complete memory leak testing. {comment,"Incomplete or no mem leak testing"}; - _ -> - ok + {_, 1} -> + ok; + _ -> + {comment, "Transient memory discrepancy"} end; {MemInfo2, AllTabs2} -> @@ -6041,7 +6047,15 @@ verify_etsmem({MemInfo,AllTabs}) -> io:format("Actual: ~p", [MemInfo2]), io:format("Changed tables before: ~p\n",[AllTabs -- AllTabs2]), io:format("Changed tables after: ~p\n", [AllTabs2 -- AllTabs]), - ct:fail("Failed memory check") + case Try < 2 of + true -> + io:format("\nThis discrepancy could be caused by an " + "inconsistent memory \"snapshot\"" + "\nTry again...\n", []), + verify_etsmem({MemInfo, AllTabs}, Try+1); + false -> + ct:fail("Failed memory check") + end end. diff --git a/lib/stdlib/test/gen_fsm_SUITE.erl b/lib/stdlib/test/gen_fsm_SUITE.erl index 86cf58566b..41ee3246f5 100644 --- a/lib/stdlib/test/gen_fsm_SUITE.erl +++ b/lib/stdlib/test/gen_fsm_SUITE.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1996-2017. All Rights Reserved. +%% Copyright Ericsson AB 1996-2018. 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. @@ -389,7 +389,7 @@ stop10(_Config) -> Dir = filename:dirname(code:which(?MODULE)), rpc:call(Node,code,add_path,[Dir]), {ok, Pid} = rpc:call(Node,gen_fsm,start,[{global,to_stop},?MODULE,[],[]]), - global:sync(), + ok = global:sync(), ok = gen_fsm:stop({global,to_stop}), false = rpc:call(Node,erlang,is_process_alive,[Pid]), {'EXIT',noproc} = (catch gen_fsm:stop({global,to_stop})), @@ -1005,7 +1005,7 @@ undef_in_terminate(Config) when is_list(Config) -> State = {undef_in_terminate, {?MODULE, terminate}}, {ok, FSM} = gen_fsm:start(?MODULE, {state_data, State}, []), try - gen_fsm:stop(FSM), + ok = gen_fsm:stop(FSM), ct:fail(failed) catch exit:{undef, [{?MODULE, terminate, _, _}|_]} -> @@ -1201,7 +1201,7 @@ timeout({timeout,Ref,{timeout,Time}}, {From,Ref}) -> Cref = gen_fsm:start_timer(Time, cancel), Time4 = Time*4, receive after Time4 -> ok end, - gen_fsm:cancel_timer(Cref), + _= gen_fsm:cancel_timer(Cref), {next_state, timeout, {From,Ref2}}; timeout({timeout,Ref2,ok},{From,Ref2}) -> gen_fsm:reply(From, ok), diff --git a/lib/stdlib/test/gen_server_SUITE.erl b/lib/stdlib/test/gen_server_SUITE.erl index 2bc220fef2..e29195e895 100644 --- a/lib/stdlib/test/gen_server_SUITE.erl +++ b/lib/stdlib/test/gen_server_SUITE.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1996-2017. All Rights Reserved. +%% Copyright Ericsson AB 1996-2018. 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. @@ -347,7 +347,7 @@ stop10(_Config) -> Dir = filename:dirname(code:which(?MODULE)), rpc:call(Node,code,add_path,[Dir]), {ok, Pid} = rpc:call(Node,gen_server,start,[{global,to_stop},?MODULE,[],[]]), - global:sync(), + ok = global:sync(), ok = gen_server:stop({global,to_stop}), false = rpc:call(Node,erlang,is_process_alive,[Pid]), {'EXIT',noproc} = (catch gen_server:stop({global,to_stop})), @@ -509,7 +509,7 @@ start_node(Name) -> %% After starting a slave, it takes a little while until global knows %% about it, even if nodes() includes it, so we make sure that global %% knows about it before registering something on all nodes. - global:sync(), + ok = global:sync(), N. call_remote1(Config) when is_list(Config) -> @@ -647,7 +647,7 @@ cast_fast(Config) when is_list(Config) -> cast_fast_messup() -> %% Register a false node: hopp@hostname unregister(erl_epmd), - erl_epmd:start_link(), + {ok, _} = erl_epmd:start_link(), {ok,S} = gen_tcp:listen(0, []), {ok,P} = inet:port(S), {ok,_Creation} = erl_epmd:register_node(hopp, P), @@ -1351,7 +1351,7 @@ do_call_with_huge_message_queue() -> {Time,ok} = tc(fun() -> calls(10000, Pid) end), - [self() ! {msg,N} || N <- lists:seq(1, 500000)], + _ = [self() ! {msg,N} || N <- lists:seq(1, 500000)], erlang:garbage_collect(), {NewTime,ok} = tc(fun() -> calls(10000, Pid) end), io:format("Time for empty message queue: ~p", [Time]), @@ -1476,7 +1476,7 @@ undef_in_terminate(Config) when is_list(Config) -> State = {undef_in_terminate, {oc_server, terminate}}, {ok, Server} = gen_server:start(?MODULE, {state, State}, []), try - gen_server:stop(Server), + ok = gen_server:stop(Server), ct:fail(failed) catch exit:{undef, [{oc_server, terminate, [], _}|_]} -> @@ -1674,7 +1674,7 @@ handle_cast({From,delayed_cast,T}, _State) -> handle_cast(hibernate_now, _State) -> {noreply, [], hibernate}; handle_cast(hibernate_later, _State) -> - timer:send_after(1000,self(),hibernate_now), + {ok, _} = timer:send_after(1000,self(),hibernate_now), {noreply, []}; handle_cast({call_undef_fun, Mod, Fun}, State) -> Mod:Fun(), diff --git a/lib/stdlib/test/gen_statem_SUITE.erl b/lib/stdlib/test/gen_statem_SUITE.erl index 5b9daecfd3..7c8a386116 100644 --- a/lib/stdlib/test/gen_statem_SUITE.erl +++ b/lib/stdlib/test/gen_statem_SUITE.erl @@ -21,7 +21,7 @@ -include_lib("common_test/include/ct.hrl"). --compile(export_all). +-compile([export_all, nowarn_export_all]). -behaviour(gen_statem). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% @@ -2040,9 +2040,9 @@ handle_event(Type, Event, State, Data) -> Result -> wrap_result(Result) catch - throw:Result -> + throw:Result:Stacktrace -> erlang:raise( - throw, wrap_result(Result), erlang:get_stacktrace()) + throw, wrap_result(Result), Stacktrace) end. unwrap_state([State]) -> diff --git a/lib/stdlib/test/io_SUITE.erl b/lib/stdlib/test/io_SUITE.erl index 13929bdbb6..45363c0592 100644 --- a/lib/stdlib/test/io_SUITE.erl +++ b/lib/stdlib/test/io_SUITE.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 1999-2017. All Rights Reserved. +%% Copyright Ericsson AB 1999-2018. 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. @@ -714,7 +714,7 @@ p(Term, D) -> rp(Term, 1, 80, D). p(Term, Col, Ll, D) -> - rp(Term, Col, Ll, D, no_fun). + rp(Term, Col, Ll, D, none). rp(Term, Col, Ll, D) -> rp(Term, Col, Ll, D, fun rfd/2). @@ -724,6 +724,8 @@ rp(Term, Col, Ll, D) -> rp(Term, Col, Ll, D, RF) -> rp(Term, Col, Ll, D, ?MAXCS, RF). +rp(Term, Col, Ll, D, M, none) -> + rp(Term, Col, Ll, D, M, fun(_, _) -> no end); rp(Term, Col, Ll, D, M, RF) -> %% io:format("~n~n*** Col = ~p Ll = ~p D = ~p~n~p~n-->~n", %% [Col, Ll, D, Term]), diff --git a/lib/stdlib/test/proc_lib_SUITE.erl b/lib/stdlib/test/proc_lib_SUITE.erl index 7686889360..fbdcb518b2 100644 --- a/lib/stdlib/test/proc_lib_SUITE.erl +++ b/lib/stdlib/test/proc_lib_SUITE.erl @@ -446,8 +446,8 @@ init_dont_hang(Config) when is_list(Config) -> StartLinkRes = proc_lib:start(?MODULE, init_dont_hang_init, [self()], 1000), StartLinkRes = proc_lib:start(?MODULE, init_dont_hang_init, [self()], 1000, []), ok - catch _:Error -> - io:format("Error ~p /= ~p ~n",[erlang:get_stacktrace(), StartLinkRes]), + catch _:Error:Stacktrace -> + io:format("Error ~p /= ~p ~n",[Stacktrace, StartLinkRes]), exit(Error) end. diff --git a/lib/stdlib/test/rand_SUITE.erl b/lib/stdlib/test/rand_SUITE.erl index 55cff22d47..d753d929f5 100644 --- a/lib/stdlib/test/rand_SUITE.erl +++ b/lib/stdlib/test/rand_SUITE.erl @@ -88,9 +88,9 @@ test() -> try ok = ?MODULE:Test([]), io:format("~p: ok~n", [Test]) - catch _:Reason -> + catch _:Reason:Stacktrace -> io:format("Failed: ~p: ~p ~p~n", - [Test, Reason, erlang:get_stacktrace()]) + [Test, Reason, Stacktrace]) end end, Tests). @@ -104,8 +104,8 @@ seed(Config) when is_list(Config) -> Algs = algs(), Test = fun(Alg) -> try seed_1(Alg) - catch _:Reason -> - ct:fail({Alg, Reason, erlang:get_stacktrace()}) + catch _:Reason:Stacktrace -> + ct:fail({Alg, Reason, Stacktrace}) end end, [Test(Alg) || Alg <- Algs], @@ -742,12 +742,12 @@ uniform_real_conv_check(M, E, Gen) -> [["16#",integer_to_list(G,16),$\s]||G<-Gen]]), ct:fail({neq, FF, F}) catch - Error:Reason -> + Error:Reason:Stacktrace -> ct:pal( "~w:~p ~s: ~s~n", [Error, Reason, rand:float2str(F), [["16#",integer_to_list(G,16),$\s]||G<-Gen]]), - ct:fail({Error, Reason, F, erlang:get_stacktrace()}) + ct:fail({Error, Reason, F, Stacktrace}) end. diff --git a/lib/stdlib/test/shell_SUITE.erl b/lib/stdlib/test/shell_SUITE.erl index 217e8cc252..ca85314775 100644 --- a/lib/stdlib/test/shell_SUITE.erl +++ b/lib/stdlib/test/shell_SUITE.erl @@ -1,7 +1,7 @@ %% %% %CopyrightBegin% %% -%% Copyright Ericsson AB 2004-2017. All Rights Reserved. +%% Copyright Ericsson AB 2004-2018. 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. @@ -561,9 +561,10 @@ otp_5226(Config) when is_list(Config) -> otp_5327(Config) when is_list(Config) -> "exception error: bad argument" = comm_err(<<"<<\"hej\":default>>.">>), + L1 = erl_anno:new(1), <<"abc">> = - erl_parse:normalise({bin,1,[{bin_element,1,{string,1,"abc"}, - default,default}]}), + erl_parse:normalise({bin,L1,[{bin_element,L1,{string,L1,"abc"}, + default,default}]}), [<<"abc">>] = scan(<<"<<(<<\"abc\">>):3/binary>>.">>), [<<"abc">>] = scan(<<"<<(<<\"abc\">>)/binary>>.">>), "exception error: bad argument" = @@ -576,9 +577,9 @@ otp_5327(Config) when is_list(Config) -> comm_err(<<"<<10:default>>.">>), [<<98,1:1>>] = scan(<<"<<3:3,5:6>>.">>), {'EXIT',{badarg,_}} = - (catch erl_parse:normalise({bin,1,[{bin_element,1,{integer,1,17}, - {atom,1,all}, - default}]})), + (catch erl_parse:normalise({bin,L1,[{bin_element,L1,{integer,L1,17}, + {atom,L1,all}, + default}]})), [<<-20/signed>>] = scan(<<"<<-20/signed>> = <<-20>>.">>), [<<-300:16/signed>>] = scan(<<"<<-300:16/signed>> = <<-300:16>>.">>), @@ -2784,7 +2785,7 @@ otp_10302(Config) when is_list(Config) -> <<"begin A = <<\"\\xaa\">>, S = lists:flatten(io_lib:format(\"~p/~p.\", [A, A])), - {ok, Ts, _} = erl_scan:string(S, 1, [unicode]), + {ok, Ts, _} = erl_scan:string(S, 1), {ok, Es} = erl_parse:parse_exprs(Ts), B = erl_eval:new_bindings(), erl_eval:exprs(Es, B) @@ -2797,7 +2798,7 @@ otp_10302(Config) when is_list(Config) -> <<"io:setopts([{encoding,utf8}]). A = <<\"\\xaa\">>, S = lists:flatten(io_lib:format(\"~p/~p.\", [A, A])), - {ok, Ts, _} = erl_scan:string(S, 1, [unicode]), + {ok, Ts, _} = erl_scan:string(S, 1), {ok, Es} = erl_parse:parse_exprs(Ts), B = erl_eval:new_bindings(), erl_eval:exprs(Es, B).">>, @@ -2809,7 +2810,7 @@ otp_10302(Config) when is_list(Config) -> <<"begin A = [1089], S = lists:flatten(io_lib:format(\"~tp/~tp.\", [A, A])), - {ok, Ts, _} = erl_scan:string(S, 1, [unicode]), + {ok, Ts, _} = erl_scan:string(S, 1), {ok, Es} = erl_parse:parse_exprs(Ts), B = erl_eval:new_bindings(), erl_eval:exprs(Es, B) @@ -2821,7 +2822,7 @@ otp_10302(Config) when is_list(Config) -> <<"io:setopts([{encoding,utf8}]). A = [1089], S = lists:flatten(io_lib:format(\"~tp/~tp.\", [A, A])), - {ok, Ts, _} = erl_scan:string(S, 1, [unicode]), + {ok, Ts, _} = erl_scan:string(S, 1), {ok, Es} = erl_parse:parse_exprs(Ts), B = erl_eval:new_bindings(), erl_eval:exprs(Es, B).">>, @@ -2940,7 +2941,7 @@ otp_14296(Config) when is_list(Config) -> end(), fun() -> - Port = open_port({spawn, "ls"}, [line]), + Port = open_port({spawn, "ls"}, [{line,1}]), KnownPort = erlang:port_to_list(Port), S = KnownPort ++ ".", R = KnownPort ++ ".\n", @@ -3012,7 +3013,7 @@ scan(B) -> scan(t(B), F). scan(S0, F) -> - case erl_scan:tokens([], S0, 1, [unicode]) of + case erl_scan:tokens([], S0, 1) of {done,{ok,Ts,_},S} -> [F(Ts) | scan(S, F)]; _Else -> diff --git a/lib/stdlib/test/stdlib.spec b/lib/stdlib/test/stdlib.spec index 1adec67ac9..9c625091a8 100644 --- a/lib/stdlib/test/stdlib.spec +++ b/lib/stdlib/test/stdlib.spec @@ -1,3 +1,4 @@ {suites,"../stdlib_test",all}. -{skip_groups,"../stdlib_test",stdlib_bench_SUITE,[base64,gen_server,unicode], +{skip_groups,"../stdlib_test",stdlib_bench_SUITE, + [base64,gen_server,gen_statem,unicode], "Benchmark only"}. diff --git a/lib/stdlib/test/stdlib_bench.spec b/lib/stdlib/test/stdlib_bench.spec index f82f1ab9b3..7a0da811a0 100644 --- a/lib/stdlib/test/stdlib_bench.spec +++ b/lib/stdlib/test/stdlib_bench.spec @@ -5,5 +5,6 @@ {skip_suites,"../stdlib_test",string_SUITE, "bench only"}. {suites,"../stdlib_test",[stdlib_bench_SUITE]}. -{skip_groups,"../stdlib_test",stdlib_bench_SUITE,[gen_server_comparison], +{skip_groups,"../stdlib_test",stdlib_bench_SUITE, + [gen_server_comparison,gen_statem_comparison], "Not a benchmark"}. diff --git a/lib/stdlib/test/stdlib_bench_SUITE.erl b/lib/stdlib/test/stdlib_bench_SUITE.erl index 9ad4bae2f5..294898a932 100644 --- a/lib/stdlib/test/stdlib_bench_SUITE.erl +++ b/lib/stdlib/test/stdlib_bench_SUITE.erl @@ -30,7 +30,8 @@ suite() -> [{ct_hooks,[{ts_install_cth,[{nodenames,2}]}]}]. all() -> [{group,unicode},{group,base64}, - {group,gen_server},{group,gen_server_comparison}]. + {group,gen_server},{group,gen_statem}, + {group,gen_server_comparison},{group,gen_statem_comparison}]. groups() -> [{unicode,[{repeat,5}], @@ -44,20 +45,39 @@ groups() -> encode_list, encode_list_to_string, mime_binary_decode, mime_binary_decode_to_string, mime_list_decode, mime_list_decode_to_string]}, - {gen_server, [{repeat,5}], - [simple, simple_timer, simple_mon, simple_timer_mon, - generic, generic_timer]}, + {gen_server, [{repeat,5}], cases(gen_server)}, + {gen_statem, [{repeat,3}], cases(gen_statem)}, {gen_server_comparison, [], [single_small, single_medium, single_big, sched_small, sched_medium, sched_big, - multi_small, multi_medium, multi_big]}]. + multi_small, multi_medium, multi_big]}, + {gen_statem_comparison, [], + [single_small, single_big, + sched_small, sched_big, + multi_small, multi_big]}]. -init_per_group(GroupName, Config) when GroupName =:= gen_server; - GroupName =:= gen_server_comparison -> - DataDir = ?config(data_dir, Config), - Files = filelib:wildcard(filename:join(DataDir, "{simple,generic}*.erl")), - _ = [{ok, _} = compile:file(File) || File <- Files], - Config; +cases(gen_server) -> + [simple, simple_timer, simple_mon, simple_timer_mon, + generic, generic_timer]; +cases(gen_statem) -> + [generic, generic_fsm, generic_fsm_transit, + generic_statem, generic_statem_transit, + generic_statem_complex]. + +init_per_group(gen_server, Config) -> + compile_servers(Config), + [{benchmark_suite,"stdlib_gen_server"}|Config]; +init_per_group(gen_statem, Config) -> + compile_servers(Config), + [{benchmark_suite,"stdlib_gen_statem"}|Config]; +init_per_group(gen_server_comparison, Config) -> + compile_servers(Config), + [{cases,cases(gen_server)}, + {benchmark_suite,"stdlib_gen_server"}|Config]; +init_per_group(gen_statem_comparison, Config) -> + compile_servers(Config), + [{cases,cases(gen_statem)}, + {benchmark_suite,"stdlib_gen_statem"}|Config]; init_per_group(_GroupName, Config) -> Config. @@ -77,23 +97,33 @@ end_per_testcase(_Func, _Conf) -> ok. +compile_servers(Config) -> + DataDir = ?config(data_dir, Config), + Files = filelib:wildcard(filename:join(DataDir, "{simple,generic}*.erl")), + _ = [{ok, _} = compile:file(File) || File <- Files], + ok. + +comment(Value) -> + C = lists:flatten(io_lib:format("~p", [Value])), + {comment, C}. + %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -define(REPEAT_NORM, 5). norm_nfc_list(Config) -> Bin = norm_data(Config), {_N, Mean, _Stddev, Res} = unicode_util_SUITE:time_count(nfc, list, Bin, ?REPEAT_NORM), - report(1000.0*Res / Mean). + comment(report(1000.0*Res / Mean)). norm_nfc_deep_l(Config) -> Bin = norm_data(Config), {_N, Mean, _Stddev, Res} = unicode_util_SUITE:time_count(nfc, deep_l, Bin, ?REPEAT_NORM), - report(1000.0*Res / Mean). + comment(report(1000.0*Res / Mean)). norm_nfc_binary(Config) -> Bin = norm_data(Config), {_N, Mean, _Stddev, Res} = unicode_util_SUITE:time_count(nfc, binary, Bin, ?REPEAT_NORM), - report(1000.0*Res / Mean). + comment(report(1000.0*Res / Mean)). string_lexemes_list(Config) -> @@ -102,7 +132,7 @@ string_lexemes_list(Config) -> Bin = norm_data(Config), Fun = fun(Str) -> string:nth_lexeme(Str, 200000, [$;,$\n,$\r]), 200000 end, {_N, Mean, _Stddev, Res} = string_SUITE:time_func(Fun, list, Bin, 15), - report(1000.0*Res / Mean). + comment(report(1000.0*Res / Mean)). string_lexemes_binary(Config) -> %% Use nth_lexeme instead of lexemes to avoid building a result of @@ -110,7 +140,7 @@ string_lexemes_binary(Config) -> Bin = norm_data(Config), Fun = fun(Str) -> string:nth_lexeme(Str, 200000, [$;,$\n,$\r]), 200000 end, {_N, Mean, _Stddev, Res} = string_SUITE:time_func(Fun, binary, Bin, ?REPEAT_NORM), - report(1000.0*Res / Mean). + comment(report(1000.0*Res / Mean)). %%% report(Tps) -> @@ -128,40 +158,40 @@ norm_data(Config) -> %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% decode_binary(_Config) -> - test(decode, encoded_binary()). + comment(test(decode, encoded_binary())). decode_binary_to_string(_Config) -> - test(decode_to_string, encoded_binary()). + comment(test(decode_to_string, encoded_binary())). decode_list(_Config) -> - test(decode, encoded_list()). + comment(test(decode, encoded_list())). decode_list_to_string(_Config) -> - test(decode_to_string, encoded_list()). + comment(test(decode_to_string, encoded_list())). encode_binary(_Config) -> - test(encode, binary()). + comment(test(encode, binary())). encode_binary_to_string(_Config) -> - test(encode_to_string, binary()). + comment(test(encode_to_string, binary())). encode_list(_Config) -> - test(encode, list()). + comment(test(encode, list())). encode_list_to_string(_Config) -> - test(encode_to_string, list()). + comment(test(encode_to_string, list())). mime_binary_decode(_Config) -> - test(mime_decode, encoded_binary()). + comment(test(mime_decode, encoded_binary())). mime_binary_decode_to_string(_Config) -> - test(mime_decode_to_string, encoded_binary()). + comment(test(mime_decode_to_string, encoded_binary())). mime_list_decode(_Config) -> - test(mime_decode, encoded_list()). + comment(test(mime_decode, encoded_list())). mime_list_decode_to_string(_Config) -> - test(mime_decode_to_string, encoded_list()). + comment(test(mime_decode_to_string, encoded_list())). -define(SIZE, 10000). -define(N, 1000). @@ -223,94 +253,106 @@ mbb(N, Acc) -> lists:reverse(Acc, B). simple(Config) when is_list(Config) -> - do_tests(simple, single_small). + comment(do_tests(simple, single_small, Config)). simple_timer(Config) when is_list(Config) -> - do_tests(simple_timer, single_small). + comment(do_tests(simple_timer, single_small, Config)). simple_mon(Config) when is_list(Config) -> - do_tests(simple_mon, single_small). + comment(do_tests(simple_mon, single_small, Config)). simple_timer_mon(Config) when is_list(Config) -> - do_tests(simple_timer_mon, single_small). + comment(do_tests(simple_timer_mon, single_small, Config)). generic(Config) when is_list(Config) -> - do_tests(generic, single_small). + comment(do_tests(generic, single_small, Config)). generic_timer(Config) when is_list(Config) -> - do_tests(generic_timer, single_small). + comment(do_tests(generic_timer, single_small, Config)). + +generic_statem(Config) when is_list(Config) -> + comment(do_tests(generic_statem, single_small, Config)). + +generic_statem_transit(Config) when is_list(Config) -> + comment(do_tests(generic_statem_transit, single_small, Config)). + +generic_statem_complex(Config) when is_list(Config) -> + comment(do_tests(generic_statem_complex, single_small, Config)). + +generic_fsm(Config) when is_list(Config) -> + comment(do_tests(generic_fsm, single_small, Config)). + +generic_fsm_transit(Config) when is_list(Config) -> + comment(do_tests(generic_fsm_transit, single_small, Config)). single_small(Config) when is_list(Config) -> - comparison(single_small). + comparison(?config(cases, Config), single_small, Config). single_medium(Config) when is_list(Config) -> - comparison(single_medium). + comparison(?config(cases, Config), single_medium, Config). single_big(Config) when is_list(Config) -> - comparison(single_big). + comparison(?config(cases, Config), single_big, Config). sched_small(Config) when is_list(Config) -> - comparison(sched_small). + comparison(?config(cases, Config), sched_small, Config). sched_medium(Config) when is_list(Config) -> - comparison(sched_medium). + comparison(?config(cases, Config), sched_medium, Config). sched_big(Config) when is_list(Config) -> - comparison(sched_big). + comparison(?config(cases, Config), sched_big, Config). multi_small(Config) when is_list(Config) -> - comparison(multi_small). + comparison(?config(cases, Config), multi_small, Config). multi_medium(Config) when is_list(Config) -> - comparison(multi_medium). + comparison(?config(cases, Config), multi_medium, Config). multi_big(Config) when is_list(Config) -> - comparison(multi_big). - -comparison(Kind) -> - Simple0 = do_tests(simple, Kind), - SimpleTimer0 = do_tests(simple_timer, Kind), - SimpleMon0 = do_tests(simple_mon, Kind), - SimpleTimerMon0 = do_tests(simple_timer_mon, Kind), - Generic0 = do_tests(generic, Kind), - GenericTimer0 = do_tests(generic_timer, Kind), - %% Normalize - Simple = norm(Simple0, Simple0), - SimpleTimer = norm(SimpleTimer0, Simple0), - SimpleMon = norm(SimpleMon0, Simple0), - SimpleTimerMon = norm(SimpleTimerMon0, Simple0), - Generic = norm(Generic0, Simple0), - GenericTimer = norm(GenericTimer0, Simple0), + comparison(?config(cases, Config), multi_big, Config). + +comparison(Cases, Kind, Config) -> + Cases = ?config(cases, Config), + [RefResult|_] = Results = + [do_tests(Case, Kind, Config) || Case <- Cases], + Normalized = [norm(Result, RefResult) || Result <- Results], {Parallelism, Message} = bench_params(Kind), Wordsize = erlang:system_info(wordsize), MSize = Wordsize * erts_debug:flat_size(Message), What = io_lib:format("#parallel gen_server instances: ~.4w, " "message flat size: ~.5w bytes", [Parallelism, MSize]), - C = io_lib:format("~s: " - "Simple: ~s Simple+Timer: ~s " - "Simple+Monitor: ~s Simple+Timer+Monitor: ~s " - "Generic: ~s Generic+Timer: ~s", - [What, Simple, SimpleTimer, SimpleMon, SimpleTimerMon, - Generic, GenericTimer]), + Format = + lists:flatten( + ["~s: "] ++ + [[atom_to_list(Case),": ~s "] || Case <- Cases]), + C = lists:flatten(io_lib:format(Format, [What] ++ Normalized)), {comment, C}. norm(T, Ref) -> - io_lib:format("~.2f", [Ref/T]). + try Ref / T of + Norm -> + io_lib:format("~.2f", [Norm]) + catch error:badarith -> + "---" + end. -define(MAX_TIME_SECS, 3). % s -define(MAX_TIME, 1000 * ?MAX_TIME_SECS). % ms -define(CALLS_PER_LOOP, 5). -do_tests(Test, ParamSet) -> +do_tests(Test, ParamSet, Config) -> + BenchmarkSuite = ?config(benchmark_suite, Config), {Client, ServerMod} = bench(Test), {Parallelism, Message} = bench_params(ParamSet), Fun = create_clients(Message, ServerMod, Client, Parallelism), {TotalLoops, AllPidTime} = run_test(Fun), PerSecond = ?CALLS_PER_LOOP * round((1000 * TotalLoops) / AllPidTime), - ct_event:notify(#event{name = benchmark_data, - data = [{suite,"stdlib_gen_server"}, - {value,PerSecond}]}), + ct_event:notify( + #event{ + name = benchmark_data, + data = [{suite,BenchmarkSuite},{value,PerSecond}]}), PerSecond. -define(COUNTER, n). @@ -369,6 +411,51 @@ generic_timer_client(N, M, P) -> _ = generic_server_timer:reply(P, M), generic_timer_client(N+1, M, P). +generic_statem_client(N, M, P) -> + put(?COUNTER, N), + _ = generic_statem:reply(P, M), + _ = generic_statem:reply(P, M), + _ = generic_statem:reply(P, M), + _ = generic_statem:reply(P, M), + _ = generic_statem:reply(P, M), + generic_statem_client(N+1, M, P). + +generic_statem_transit_client(N, M, P) -> + put(?COUNTER, N), + _ = generic_statem:transit(P, M), + _ = generic_statem:transit(P, M), + _ = generic_statem:transit(P, M), + _ = generic_statem:transit(P, M), + _ = generic_statem:transit(P, M), + generic_statem_transit_client(N+1, M, P). + +generic_statem_complex_client(N, M, P) -> + put(?COUNTER, N), + _ = generic_statem:reply(P, M), + _ = generic_statem:reply(P, M), + _ = generic_statem:reply(P, M), + _ = generic_statem:reply(P, M), + _ = generic_statem:reply(P, M), + generic_statem_complex_client(N+1, M, P). + +generic_fsm_client(N, M, P) -> + put(?COUNTER, N), + _ = generic_fsm:reply(P, M), + _ = generic_fsm:reply(P, M), + _ = generic_fsm:reply(P, M), + _ = generic_fsm:reply(P, M), + _ = generic_fsm:reply(P, M), + generic_fsm_client(N+1, M, P). + +generic_fsm_transit_client(N, M, P) -> + put(?COUNTER, N), + _ = generic_fsm:transit(P, M), + _ = generic_fsm:transit(P, M), + _ = generic_fsm:transit(P, M), + _ = generic_fsm:transit(P, M), + _ = generic_fsm:transit(P, M), + generic_fsm_transit_client(N+1, M, P). + bench(simple) -> {fun simple_client/3, simple_server}; bench(simple_timer) -> @@ -380,7 +467,17 @@ bench(simple_timer_mon) -> bench(generic) -> {fun generic_client/3, generic_server}; bench(generic_timer) -> - {fun generic_timer_client/3, generic_server_timer}. + {fun generic_timer_client/3, generic_server_timer}; +bench(generic_statem) -> + {fun generic_statem_client/3, generic_statem}; +bench(generic_statem_transit) -> + {fun generic_statem_transit_client/3, generic_statem}; +bench(generic_statem_complex) -> + {fun generic_statem_complex_client/3, generic_statem_complex}; +bench(generic_fsm) -> + {fun generic_fsm_client/3, generic_fsm}; +bench(generic_fsm_transit) -> + {fun generic_fsm_transit_client/3, generic_fsm}. %% -> {Parallelism, MessageTerm} bench_params(single_small) -> {1, small()}; diff --git a/lib/stdlib/test/stdlib_bench_SUITE_data/generic_fsm.erl b/lib/stdlib/test/stdlib_bench_SUITE_data/generic_fsm.erl new file mode 100644 index 0000000000..50f7df7a2a --- /dev/null +++ b/lib/stdlib/test/stdlib_bench_SUITE_data/generic_fsm.erl @@ -0,0 +1,59 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2017-2018. All Rights Reserved. +%% +%% Licensed under the Apache License, Version 2.0 (the "License"); +%% you may not use this file except in compliance with the License. +%% You may obtain a copy of the License at +%% +%% http://www.apache.org/licenses/LICENSE-2.0 +%% +%% Unless required by applicable law or agreed to in writing, software +%% distributed under the License is distributed on an "AS IS" BASIS, +%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +%% See the License for the specific language governing permissions and +%% limitations under the License. +%% +%% %CopyrightEnd% +%% +-module(generic_fsm). + +-export([start/1, reply/2, transit/2, stop/1]). + +-export([init/1, terminate/3]). +-export([state1/3, state2/3]). + +-behaivour(gen_fsm). + + +%% API + +start(Data) -> + {ok, Pid} = gen_fsm:start(?MODULE, Data, []), + Pid. + +stop(P) -> + ok = gen_fsm:stop(P). + +reply(S, M) -> + gen_fsm:sync_send_event(S, {reply, M}, infinity). + +transit(S, M) -> + gen_fsm:sync_send_event(S, {transit, M}, infinity). + +%% Implementation + +init(Data) -> + {ok, state1, Data}. + +terminate(_Reason, _State, _Data) -> + ok. + +state1({reply, M}, _From, Data) -> + {reply, M, ?FUNCTION_NAME, Data}; +state1({transit, M}, _From, Data) -> + {reply, M, state2, Data}. + +state2({transit, M}, _From, Data) -> + {reply, M, state1, Data}. diff --git a/lib/stdlib/test/stdlib_bench_SUITE_data/generic_statem.erl b/lib/stdlib/test/stdlib_bench_SUITE_data/generic_statem.erl new file mode 100644 index 0000000000..2e0491f060 --- /dev/null +++ b/lib/stdlib/test/stdlib_bench_SUITE_data/generic_statem.erl @@ -0,0 +1,58 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2017-2018. All Rights Reserved. +%% +%% Licensed under the Apache License, Version 2.0 (the "License"); +%% you may not use this file except in compliance with the License. +%% You may obtain a copy of the License at +%% +%% http://www.apache.org/licenses/LICENSE-2.0 +%% +%% Unless required by applicable law or agreed to in writing, software +%% distributed under the License is distributed on an "AS IS" BASIS, +%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +%% See the License for the specific language governing permissions and +%% limitations under the License. +%% +%% %CopyrightEnd% +%% +-module(generic_statem). + +-export([start/1, reply/2, transit/2, stop/1]). + +-export([callback_mode/0, init/1]). +-export([state1/3, state2/3]). + +-behaviour(gen_statem). + +%% API + +start(Data) -> + {ok, Pid} = gen_statem:start(?MODULE, Data, []), + Pid. + +stop(P) -> + ok = gen_statem:stop(P). + +reply(S, M) -> + gen_statem:call(S, {reply, M}, infinity). + +transit(S, M) -> + gen_statem:call(S, {transit, M}, infinity). + +%% Implementation + +callback_mode() -> + state_functions. + +init(Data) -> + {ok, state1, Data}. + +state1({call, From}, {reply, M}, Data) -> + {keep_state, Data, {reply, From, M}}; +state1({call, From}, {transit, M}, Data) -> + {next_state, state2, Data, {reply, From, M}}. + +state2({call, From}, {transit, M}, Data) -> + {next_state, state1, Data, {reply, From, M}}. diff --git a/lib/stdlib/test/stdlib_bench_SUITE_data/generic_statem_complex.erl b/lib/stdlib/test/stdlib_bench_SUITE_data/generic_statem_complex.erl new file mode 100644 index 0000000000..983227d281 --- /dev/null +++ b/lib/stdlib/test/stdlib_bench_SUITE_data/generic_statem_complex.erl @@ -0,0 +1,66 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2017-2018. All Rights Reserved. +%% +%% Licensed under the Apache License, Version 2.0 (the "License"); +%% you may not use this file except in compliance with the License. +%% You may obtain a copy of the License at +%% +%% http://www.apache.org/licenses/LICENSE-2.0 +%% +%% Unless required by applicable law or agreed to in writing, software +%% distributed under the License is distributed on an "AS IS" BASIS, +%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +%% See the License for the specific language governing permissions and +%% limitations under the License. +%% +%% %CopyrightEnd% +%% +-module(generic_statem_complex). + +-export([start/1, reply/2, stop/1]). + +-export([callback_mode/0, init/1]). +-export([state1/3, state2/3, state3/3]). + +-behaviour(gen_statem). + +%% API + +start(Data) -> + {ok, Pid} = gen_statem:start(?MODULE, Data, []), + Pid. + +stop(P) -> + ok = gen_statem:stop(P). + +reply(S, M) -> + gen_statem:call(S, {reply, M}, infinity). + +%% Implementation + +callback_mode() -> + [state_functions,state_enter]. + +init(Data) -> + {ok, state1, Data}. + +state1(enter, _, Data) -> + {keep_state, Data, + {state_timeout, 5000, t1}}; +state1({call, _From}, {reply, _M}, Data) -> + {next_state, state2, Data, + [postpone,{next_event,internal,e}]}. + +state2(enter, _, _Data) -> + keep_state_and_data; +state2(internal, e, Data) -> + {next_state, state3, Data}. + +state3(enter, _, Data) -> + {keep_state, Data, + {state_timeout, 5000, t3}}; +state3({call, From}, {reply, M}, Data) -> + {next_state, state1, Data, + {reply, From, M}}. diff --git a/lib/stdlib/test/string_SUITE.erl b/lib/stdlib/test/string_SUITE.erl index d02a6eac0a..c4a469c251 100644 --- a/lib/stdlib/test/string_SUITE.erl +++ b/lib/stdlib/test/string_SUITE.erl @@ -877,9 +877,9 @@ test_1(Line, Func, Str, Args, Exp) -> catch error:Exp -> ok; - error:Reason -> + error:Reason:Stacktrace -> io:format("~p:~p: Crash ~p ~p~n", - [?MODULE,Line, Reason, erlang:get_stacktrace()]), + [?MODULE,Line, Reason, Stacktrace]), exit({error, Func}) end. @@ -944,10 +944,10 @@ check_types(Line, Func, [Str|_], Res) -> io:format("Failed: ~p ~p: ~p ~p~n",[Line, Func, T1, T2]), io:format(" ~p => ~p~n", [Str, Res]), error; - _:Reason -> - io:format("Crash: ~p in~n ~p~n",[Reason, erlang:get_stacktrace()]), + _:Reason:Stacktrace -> + io:format("Crash: ~p in~n ~p~n",[Reason, Stacktrace]), io:format("Failed: ~p ~p: ~p => ~p~n", [Line, Func, Str, Res]), - exit({Reason, erlang:get_stacktrace()}) + exit({Reason, Stacktrace}) end. check_types_1(T, T) -> diff --git a/lib/stdlib/test/tar_SUITE.erl b/lib/stdlib/test/tar_SUITE.erl index 4061008812..32a33283d1 100644 --- a/lib/stdlib/test/tar_SUITE.erl +++ b/lib/stdlib/test/tar_SUITE.erl @@ -28,7 +28,7 @@ extract_from_open_file/1, symlinks/1, open_add_close/1, cooked_compressed/1, memory/1,unicode/1,read_other_implementations/1, sparse/1, init/1, leading_slash/1, dotdot/1, - roundtrip_metadata/1]). + roundtrip_metadata/1, apply_file_info_opts/1]). -include_lib("common_test/include/ct.hrl"). -include_lib("kernel/include/file.hrl"). @@ -42,7 +42,8 @@ all() -> extract_filtered, symlinks, open_add_close, cooked_compressed, memory, unicode, read_other_implementations, - sparse,init,leading_slash,dotdot,roundtrip_metadata]. + sparse,init,leading_slash,dotdot,roundtrip_metadata, + apply_file_info_opts]. groups() -> []. @@ -989,6 +990,31 @@ do_roundtrip_metadata(Dir, File) -> ok end. +apply_file_info_opts(Config) when is_list(Config) -> + ok = file:set_cwd(proplists:get_value(priv_dir, Config)), + + ok = file:make_dir("empty_directory"), + ok = file:write_file("file", "contents"), + + Opts = [{atime, 0}, {mtime, 0}, {ctime, 0}, {uid, 0}, {gid, 0}], + TarFile = "reproducible.tar", + {ok, Tar} = erl_tar:open(TarFile, [write]), + ok = erl_tar:add(Tar, "file", Opts), + ok = erl_tar:add(Tar, "empty_directory", Opts), + ok = erl_tar:add(Tar, <<"contents">>, "memory_file", Opts), + erl_tar:close(Tar), + + ok = file:make_dir("extracted"), + erl_tar:extract(TarFile, [{cwd, "extracted"}]), + + {ok, #file_info{mtime=0}} = + file:read_file_info("extracted/empty_directory", [{time, posix}]), + {ok, #file_info{mtime=0}} = + file:read_file_info("extracted/file", [{time, posix}]), + {ok, #file_info{mtime=0}} = + file:read_file_info("extracted/memory_file", [{time, posix}]), + + ok. %% Delete the given list of files. delete_files([]) -> ok; diff --git a/lib/stdlib/test/unicode_util_SUITE.erl b/lib/stdlib/test/unicode_util_SUITE.erl index 632d9ae6e6..40b1c260a5 100644 --- a/lib/stdlib/test/unicode_util_SUITE.erl +++ b/lib/stdlib/test/unicode_util_SUITE.erl @@ -136,10 +136,10 @@ verify_gc(Line0, N, Acc) -> io:format("Expected: ~p~n", [Res]), io:format("Got: ~w~n", [Other]), Acc+1; - Cl:R -> + Cl:R:Stacktrace -> io:format("~p: ~ts => |~tp|~n",[N, Line, Str]), io:format("Expected: ~p~n", [Res]), - erlang:raise(Cl,R,erlang:get_stacktrace()) + erlang:raise(Cl,R,Stacktrace) end. gc_test_data([[247]|Rest], Str, [First|GCs]) -> @@ -175,29 +175,29 @@ verify_nfd(Data0, LineNo, _Acc) -> C3GC = fetch(C1, fun unicode_util:nfd/1), C3GC = fetch(C2, fun unicode_util:nfd/1), C3GC = fetch(C3, fun unicode_util:nfd/1) - catch _Cl:{badmatch, Other} = _R-> + catch _Cl:{badmatch, Other} = _R: Stacktrace -> io:format("Failed: ~p~nInput: ~ts~n\t=> ~w |~ts|~n",[LineNo, Data1, C1, C1]), io:format("Expected: ~ts ~w~n", [C3GC, C3GC]), io:format("Got: ~ts ~w~n", [Other, Other]), - erlang:raise(_Cl,_R,erlang:get_stacktrace()); - Cl:R -> + erlang:raise(_Cl,_R,Stacktrace); + Cl:R:Stacktrace -> io:format("~p: ~ts => |~tp|~n",[LineNo, Data1, C1]), io:format("Expected: ~p~n", [C3]), - erlang:raise(Cl,R,erlang:get_stacktrace()) + erlang:raise(Cl,R,Stacktrace) end, C5GC = fetch(C5, fun unicode_util:gc/1), try C5GC = fetch(C4, fun unicode_util:nfd/1), C5GC = fetch(C5, fun unicode_util:nfd/1) - catch _Cl2:{badmatch, Other2} = _R2-> + catch _Cl2:{badmatch, Other2} = _R2:Stacktrace2 -> io:format("Failed: ~p~nInput: ~ts~n\t=> ~w |~ts|~n",[LineNo, Data1, C1, C1]), io:format("Expected: ~ts ~w~n", [C5GC, C5GC]), io:format("Got: ~ts ~w~n", [Other2, Other2]), - erlang:raise(_Cl2,_R2,erlang:get_stacktrace()); - Cl2:R2 -> + erlang:raise(_Cl2,_R2,Stacktrace2); + Cl2:R2:Stacktrace2 -> io:format("~p: ~ts => |~tp|~n",[LineNo, Data1, C1]), io:format("Expected: ~p~n", [C5]), - erlang:raise(Cl2,R2,erlang:get_stacktrace()) + erlang:raise(Cl2,R2,Stacktrace2) end, ok. @@ -218,29 +218,29 @@ verify_nfc(Data0, LineNo, _Acc) -> C2GC = fetch(C1, fun unicode_util:nfc/1), C2GC = fetch(C2, fun unicode_util:nfc/1), C2GC = fetch(C3, fun unicode_util:nfc/1) - catch _Cl:{badmatch, Other} = _R-> + catch _Cl:{badmatch, Other} = _R:Stacktrace -> io:format("Failed: ~p~nInput: ~ts~n\t=> ~w |~ts|~n",[LineNo, Data1, C1, C1]), io:format("Expected: ~ts ~w~n", [C2GC, C2GC]), io:format("Got: ~ts ~w~n", [Other, Other]), - erlang:raise(_Cl,_R,erlang:get_stacktrace()); - Cl:R -> + erlang:raise(_Cl,_R,Stacktrace); + Cl:R:Stacktrace -> io:format("~p: ~ts => |~tp|~n",[LineNo, Data1, C1]), io:format("Expected: ~p~n", [C3]), - erlang:raise(Cl,R,erlang:get_stacktrace()) + erlang:raise(Cl,R,Stacktrace) end, C4GC = fetch(C4, fun unicode_util:gc/1), try C4GC = fetch(C4, fun unicode_util:nfc/1), C4GC = fetch(C5, fun unicode_util:nfc/1) - catch _Cl2:{badmatch, Other2} = _R2-> + catch _Cl2:{badmatch, Other2} = _R2:Stacktrace2 -> io:format("Failed: ~p~nInput: ~ts~n\t=> ~w |~ts|~n",[LineNo, Data1, C1, C1]), io:format("Expected: ~ts ~w~n", [C4GC, C4GC]), io:format("Got: ~ts ~w~n", [Other2, Other2]), - erlang:raise(_Cl2,_R2,erlang:get_stacktrace()); - Cl2:R2 -> + erlang:raise(_Cl2,_R2,Stacktrace2); + Cl2:R2:Stacktrace2 -> io:format("~p: ~ts => |~tp|~n",[LineNo, Data1, C1]), io:format("Expected: ~p~n", [C5]), - erlang:raise(Cl2,R2,erlang:get_stacktrace()) + erlang:raise(Cl2,R2,Stacktrace2) end, ok. @@ -263,15 +263,15 @@ verify_nfkd(Data0, LineNo, _Acc) -> C5GC = lists:flatten(fetch(C3, fun unicode_util:nfkd/1)), C5GC = lists:flatten(fetch(C4, fun unicode_util:nfkd/1)), C5GC = lists:flatten(fetch(C5, fun unicode_util:nfkd/1)) - catch _Cl:{badmatch, Other} = _R-> + catch _Cl:{badmatch, Other} = _R:Stacktrace -> io:format("Failed: ~p~nInput: ~ts~n\t=> ~w |~ts|~n",[LineNo, Data1, C5, C5]), io:format("Expected: ~ts ~w~n", [C5GC, C5GC]), io:format("Got: ~ts ~w~n", [Other, Other]), - erlang:raise(_Cl,_R,erlang:get_stacktrace()); - Cl:R -> + erlang:raise(_Cl,_R,Stacktrace); + Cl:R:Stacktrace -> io:format("~p: ~ts => |~tp|~n",[LineNo, Data1, C1]), io:format("Expected: ~p~n", [C3]), - erlang:raise(Cl,R,erlang:get_stacktrace()) + erlang:raise(Cl,R,Stacktrace) end, ok. @@ -296,15 +296,15 @@ verify_nfkc(Data0, LineNo, _Acc) -> C4GC = lists:flatten(fetch(C4, fun unicode_util:nfkc/1)), C4GC = lists:flatten(fetch(C5, fun unicode_util:nfkc/1)) - catch _Cl:{badmatch, Other} = _R-> + catch _Cl:{badmatch, Other} = _R:Stacktrace -> io:format("Failed: ~p~nInput: ~ts~n\t=> ~w |~ts|~n",[LineNo, Data1, C4, C4]), io:format("Expected: ~ts ~w~n", [C4GC, C4GC]), io:format("Got: ~ts ~w~n", [Other, Other]), - erlang:raise(_Cl,_R,erlang:get_stacktrace()); - Cl:R -> + erlang:raise(_Cl,_R,Stacktrace); + Cl:R:Stacktrace -> io:format("~p: ~ts => |~tp|~n",[LineNo, Data1, C1]), io:format("Expected: ~p~n", [C3]), - erlang:raise(Cl,R,erlang:get_stacktrace()) + erlang:raise(Cl,R,Stacktrace) end, ok. diff --git a/lib/stdlib/test/zip_SUITE.erl b/lib/stdlib/test/zip_SUITE.erl index 1dfcda4ed0..e5ba629c55 100644 --- a/lib/stdlib/test/zip_SUITE.erl +++ b/lib/stdlib/test/zip_SUITE.erl @@ -909,8 +909,7 @@ do_fd_leak(Bad, N) -> ok -> do_fd_leak(Bad, N + 1) catch - C:R -> - Stk = erlang:get_stacktrace(), + C:R:Stk -> io:format("Bad error after ~p attempts\n", [N]), erlang:raise(C, R, Stk) end. diff --git a/lib/tools/doc/src/lcnt.xml b/lib/tools/doc/src/lcnt.xml index 5bdfc60448..0c24375b91 100644 --- a/lib/tools/doc/src/lcnt.xml +++ b/lib/tools/doc/src/lcnt.xml @@ -371,7 +371,7 @@ <v>Serial = integer()</v> </type> <desc> - <p>Creates a process id with creation 0. Example:</p> + <p>Creates a process id with creation 0.</p> </desc> </func> diff --git a/lib/tools/src/fprof.erl b/lib/tools/src/fprof.erl index fb657c2928..a3b4bfdddf 100644 --- a/lib/tools/src/fprof.erl +++ b/lib/tools/src/fprof.erl @@ -1242,8 +1242,7 @@ spawn_3step(Spawn, FunPrelude, FunAck, FunBody) catch Child ! {Parent, Ref, Go}, Result catch - Class:Reason -> - Stacktrace = erlang:get_stacktrace(), + Class:Reason:Stacktrace -> catch exit(Child, kill), erlang:raise(Class, Reason, Stacktrace) end; diff --git a/lib/tools/src/lcnt.erl b/lib/tools/src/lcnt.erl index 139b3d8a4a..d0152a4915 100644 --- a/lib/tools/src/lcnt.erl +++ b/lib/tools/src/lcnt.erl @@ -218,9 +218,11 @@ raw() -> call(raw). set(Option, Value) -> call({set, Option, Value}). set({Option, Value}) -> call({set, Option, Value}). save(Filename) -> call({save, Filename}). -load(Filename) -> ok = start_internal(), call({load, Filename}). +load(Filename) -> call({load, Filename}). -call(Msg) -> gen_server:call(?MODULE, Msg, infinity). +call(Msg) -> + ok = start_internal(), + gen_server:call(?MODULE, Msg, infinity). %% -------------------------------------------------------------------- %% %% @@ -237,7 +239,6 @@ apply(Fun) when is_function(Fun) -> lcnt:apply(Fun, []). apply(Fun, As) when is_function(Fun) -> - ok = start_internal(), Opt = lcnt:rt_opt({copy_save, true}), lcnt:clear(), Res = erlang:apply(Fun, As), @@ -943,7 +944,7 @@ print_state_information(#state{locks = Locks} = State) -> print(kv("#tries", s(Stats#stats.tries))), print(kv("#colls", s(Stats#stats.colls))), print(kv("wait time", s(Stats#stats.time) ++ " us" ++ " ( " ++ s(Stats#stats.time/1000000) ++ " s)")), - print(kv("percent of duration", s(Stats#stats.time/State#state.duration*100) ++ " %")), + print(kv("percent of duration", s(percent(Stats#stats.time, State#state.duration)) ++ " %")), ok. diff --git a/lib/tools/test/lcnt_SUITE.erl b/lib/tools/test/lcnt_SUITE.erl index 146c915087..a79572a742 100644 --- a/lib/tools/test/lcnt_SUITE.erl +++ b/lib/tools/test/lcnt_SUITE.erl @@ -30,6 +30,8 @@ t_conflicts/1, t_locations/1, t_swap_keys/1, + t_implicit_start/1, + t_crash_before_collect/1, smoke_lcnt/1]). init_per_testcase(_Case, Config) -> @@ -44,8 +46,8 @@ suite() -> {timetrap,{minutes,4}}]. all() -> - [t_load, t_conflicts, t_locations, t_swap_keys, - smoke_lcnt]. + [t_load, t_conflicts, t_locations, t_swap_keys, t_implicit_start, + t_crash_before_collect, smoke_lcnt]. %%---------------------------------------------------------------------- %% Tests @@ -149,6 +151,15 @@ t_swap_keys_file([File|Files]) -> ok = lcnt:stop(), t_swap_keys_file(Files). +%% Prior to OTP-14913 this would crash with 'noproc' as the lcnt server hadn't +%% been started yet. +t_implicit_start(Config) when is_list(Config) -> + ok = lcnt:conflicts(). + +t_crash_before_collect(Config) when is_list(Config) -> + {ok, _} = lcnt:start(), + ok = lcnt:information(). + %% Simple smoke test of actual lock-counting, if running on %% a run-time with lock-counting enabled. smoke_lcnt(Config) -> diff --git a/lib/wx/api_gen/gen_util.erl b/lib/wx/api_gen/gen_util.erl index 5e2f405498..3068a2f4ea 100644 --- a/lib/wx/api_gen/gen_util.erl +++ b/lib/wx/api_gen/gen_util.erl @@ -106,8 +106,8 @@ check_diff(Diff) -> throw:_ -> diff; error:{badmatch,_} -> diff; - _:What -> - io:format("~p:~p: ~p ~p~n", [?MODULE,?LINE, What, erlang:get_stacktrace()]), + _:What:Stacktrace -> + io:format("~p:~p: ~p ~p~n", [?MODULE,?LINE, What, Stacktrace]), diff end. diff --git a/lib/wx/api_gen/gl_gen.erl b/lib/wx/api_gen/gl_gen.erl index 7e3766a43b..6f68517c16 100644 --- a/lib/wx/api_gen/gl_gen.erl +++ b/lib/wx/api_gen/gl_gen.erl @@ -47,9 +47,9 @@ safe(What, QuitOnErr) -> What(), io:format("Completed successfully~n~n", []), QuitOnErr andalso gen_util:halt(0) - catch Err:Reason -> + catch Err:Reason:Stacktrace -> io:format("Error ~p: ~p:~p~n ~p~n", - [get(current_func),Err,Reason,erlang:get_stacktrace()]), + [get(current_func),Err,Reason,Stacktrace]), (catch gen_util:close()), timer:sleep(1999), QuitOnErr andalso gen_util:halt(1) diff --git a/lib/wx/api_gen/gl_gen_erl.erl b/lib/wx/api_gen/gl_gen_erl.erl index 45f5fd8f4c..7e673c2987 100644 --- a/lib/wx/api_gen/gl_gen_erl.erl +++ b/lib/wx/api_gen/gl_gen_erl.erl @@ -246,8 +246,8 @@ gen_types(Where) -> gen_export(F) -> try gen_export_1(F) - catch E:R -> - io:format("Crash ~p:~p in ~p ~n",[E,R, erlang:get_stacktrace()]), + catch E:R:S -> + io:format("Crash ~p:~p in ~p ~n",[E,R,S]), io:format("Func = ~p~n ~p", [F, get(F)]) end. @@ -489,8 +489,8 @@ doc_return_types2(T, Ps) -> doc_arg_type(#arg{name=Name,type=T}) -> try erl_arg_name(Name) ++ " :: " ++ doc_arg_type2(T) - catch _:Error -> - io:format("Error spec: ~p ~p~n~p~n",[Name, Error, erlang:get_stacktrace()]), + catch _:Error:Stacktrace -> + io:format("Error spec: ~p ~p~n~p~n",[Name, Error, Stacktrace]), exit(error) end. diff --git a/lib/wx/api_gen/wx_gen.erl b/lib/wx/api_gen/wx_gen.erl index aadfe4b111..ab70a588ab 100644 --- a/lib/wx/api_gen/wx_gen.erl +++ b/lib/wx/api_gen/wx_gen.erl @@ -47,9 +47,9 @@ safe(What, QuitOnErr) -> What(), io:format("Completed successfully~n~n", []), QuitOnErr andalso gen_util:halt(0) - catch Err:Reason -> + catch Err:Reason:Stacktrace -> io:format("Error in ~p ~p~n", [get(current_class),get(current_func)]), - erlang:display({Err,Reason, erlang:get_stacktrace()}), + erlang:display({Err,Reason,Stacktrace}), catch gen_util:close(), QuitOnErr andalso gen_util:halt(1) end. diff --git a/lib/wx/c_src/wxe_ps_init.c b/lib/wx/c_src/wxe_ps_init.c index e6b677d469..277f3ac25f 100644 --- a/lib/wx/c_src/wxe_ps_init.c +++ b/lib/wx/c_src/wxe_ps_init.c @@ -61,13 +61,20 @@ int is_packaged_app() { void * wxe_ps_init2() { NSAutoreleasePool *pool; ProcessSerialNumber psn; - + size_t app_len = 127; + char app_title_buf[128]; + char * app_title; // Setup and enable gui pool = [[NSAutoreleasePool alloc] init]; - + if( !is_packaged_app() ) { // Undocumented function (but no documented way of doing this exists) - char *app_title = getenv("WX_APP_TITLE"); + int res = erl_drv_getenv("WX_APP_TITLE", app_title_buf, &app_len); + if (res >= 0) { + app_title = app_title_buf; + } else { + app_title = NULL; + } if(!GetCurrentProcess(&psn)) { CPSSetProcessName(&psn, app_title?app_title:"Erlang"); } diff --git a/lib/wx/examples/demo/ex_aui.erl b/lib/wx/examples/demo/ex_aui.erl index d8fc0021f1..97805621ed 100644 --- a/lib/wx/examples/demo/ex_aui.erl +++ b/lib/wx/examples/demo/ex_aui.erl @@ -87,8 +87,7 @@ do_init(Config) -> wxAuiManager:update(Manager), process_flag(trap_exit, true), {Panel, #state{parent=Panel, config=Config, aui=Manager}} - catch Class:Reason -> - ST = erlang:get_stacktrace(), + catch Class:Reason:ST -> io:format("AUI Crashed ~p ~p~n",[Reason, ST]), wxAuiManager:unInit(Manager), wxAuiManager:destroy(Manager), diff --git a/lib/wx/src/wx.erl b/lib/wx/src/wx.erl index 34bf06cf46..6dd3c148db 100644 --- a/lib/wx/src/wx.erl +++ b/lib/wx/src/wx.erl @@ -183,7 +183,7 @@ batch(Fun) -> ok = wxe_util:cast(?BATCH_BEGIN, <<>>), try Fun() catch - error:W -> erlang:exit({W, erlang:get_stacktrace()}); + error:W:S -> erlang:exit({W, S}); throw:W -> erlang:throw(W); exit:W -> erlang:exit(W) after @@ -196,7 +196,7 @@ foreach(Fun, List) -> ok = wxe_util:cast(?BATCH_BEGIN, <<>>), try lists:foreach(Fun, List) catch - error:W -> erlang:exit({W, erlang:get_stacktrace()}); + error:W:S -> erlang:exit({W, S}); throw:W -> erlang:throw(W); exit:W -> erlang:exit(W) after @@ -209,7 +209,7 @@ map(Fun, List) -> ok = wxe_util:cast(?BATCH_BEGIN, <<>>), try lists:map(Fun, List) catch - error:W -> erlang:exit({W, erlang:get_stacktrace()}); + error:W:S -> erlang:exit({W, S}); throw:W -> erlang:throw(W); exit:W -> erlang:exit(W) after @@ -222,7 +222,7 @@ foldl(Fun, Acc, List) -> ok = wxe_util:cast(?BATCH_BEGIN, <<>>), try lists:foldl(Fun, Acc, List) catch - error:W -> erlang:exit({W, erlang:get_stacktrace()}); + error:W:S -> erlang:exit({W, S}); throw:W -> erlang:throw(W); exit:W -> erlang:exit(W) after @@ -235,7 +235,7 @@ foldr(Fun, Acc, List) -> ok = wxe_util:cast(?BATCH_BEGIN, <<>>), try lists:foldr(Fun, Acc, List) catch - error:W -> erlang:exit({W, erlang:get_stacktrace()}); + error:W:S -> erlang:exit({W, S}); throw:W -> erlang:throw(W); exit:W -> erlang:exit(W) after diff --git a/lib/wx/src/wxe_master.erl b/lib/wx/src/wxe_master.erl index ce859b3eb3..a55917f0aa 100644 --- a/lib/wx/src/wxe_master.erl +++ b/lib/wx/src/wxe_master.erl @@ -122,16 +122,9 @@ init([SilentStart]) -> erlang:error(not_smp) end, - case os:type() of - {win32,_} -> %% Needed for mingwm10.dll - Path = os:getenv("PATH"), - os:putenv("PATH", PrivDir ++ ";" ++ Path); - _ -> ok - end, - case erl_ddll:load_driver(PrivDir,DriverName) of ok -> ok; - {error, What} -> + {error, What} -> wxe_util:opt_error_log(SilentStart, "WX Failed loading ~p@~p ~n", [DriverName,PrivDir]), @@ -139,8 +132,8 @@ init([SilentStart]) -> erlang:error({load_driver,Str}) end, process_flag(trap_exit, true), - DriverWithArgs = DriverName ++ " " ++ code:priv_dir(wx) ++ [0], - + DriverWithArgs = DriverName ++ " " ++ code:priv_dir(wx), + try Port = open_port({spawn, DriverWithArgs},[binary]), wx_debug_info = ets:new(wx_debug_info, [named_table]), diff --git a/lib/wx/src/wxe_server.erl b/lib/wx/src/wxe_server.erl index 58fcaf8f23..d6d9dbd629 100644 --- a/lib/wx/src/wxe_server.erl +++ b/lib/wx/src/wxe_server.erl @@ -283,10 +283,10 @@ invoke_callback(Pid, Ev, Ref) -> Return -> exit({bad_return, Return}) end end - catch _:Reason -> + catch _:Reason:Stacktrace -> wxEvent:skip(Ref), ?log("Callback fun crashed with {'EXIT, ~p, ~p}~n", - [Reason, erlang:get_stacktrace()]) + [Reason, Stacktrace]) end, wxe_util:cast(?WXE_CB_RETURN, <<>>) end, @@ -299,9 +299,9 @@ invoke_callback_fun(Fun) -> Return = Fun(), true = is_binary(Return), Return - catch _:Reason -> + catch _:Reason:Stacktrace -> ?log("Callback fun crashed with {'EXIT, ~p, ~p}~n", - [Reason, erlang:get_stacktrace()]), + [Reason, Stacktrace]), <<>> end, wxe_util:cast(?WXE_CB_RETURN, Res). |