diff options
Diffstat (limited to 'lib')
145 files changed, 4859 insertions, 1800 deletions
diff --git a/lib/asn1/c_src/asn1_erl_nif.c b/lib/asn1/c_src/asn1_erl_nif.c index b29c9a7ed3..7b7e11b02d 100644 --- a/lib/asn1/c_src/asn1_erl_nif.c +++ b/lib/asn1/c_src/asn1_erl_nif.c @@ -901,31 +901,35 @@ static int ber_decode_tag(ErlNifEnv* env, ERL_NIF_TERM *tag, unsigned char *in_b /* then get the tag number */ if ((tmp_tag = (int) INVMASK(in_buf[*ib_index],ASN1_CLASSFORM)) < 31) { - *tag = enif_make_uint(env, tag_no + tmp_tag); + *tag = enif_make_uint(env, tag_no | tmp_tag); (*ib_index)++; } else { - int n = 0; /* n is used to check that the 64K limit is not - exceeded*/ - /* should check that at least three bytes are left in in-buffer,at least two tag byte and at least one length byte */ if ((*ib_index + 3) > in_buf_len) return ASN1_VALUE_ERROR; (*ib_index)++; - /* The tag is in the following bytes in in_buf as - 1ttttttt 1ttttttt ... 0ttttttt, where the t-bits - is the tag number*/ - /* In practice is the tag size limited to 64K, i.e. 16 bits. If - the tag is greater then 64K return an error */ - while (((tmp_tag = (int) in_buf[*ib_index]) >= 128) && n < 2) { - /* m.s.b. = 1 */ - tag_no = tag_no + (MASK(tmp_tag,ASN1_LONG_TAG) << 7); + /* + * The tag is in the following bytes in in_buf as: + * + * 1ttttttt 0ttttttt + * + * or + * + * 0ttttttt + * + * where the t-bits is the tag number. If the tag does not + * fit in two tag bytes (16K), return an error. + */ + if ((tmp_tag = (int) in_buf[*ib_index]) >= 128) { + tag_no = tag_no | (MASK(tmp_tag,ASN1_LONG_TAG) << 7); (*ib_index)++; - n++; - }; - if ((n == 2) && in_buf[*ib_index] > 3) - return ASN1_TAG_ERROR; /* tag number > 64K */ - tag_no = tag_no + in_buf[*ib_index]; + } + tmp_tag = (int) in_buf[*ib_index]; + if (tmp_tag >= 128) { + return ASN1_TAG_ERROR; /* tag number > 16K */ + } + tag_no = tag_no | tmp_tag; (*ib_index)++; *tag = enif_make_uint(env, tag_no); } diff --git a/lib/asn1/src/asn1ct.erl b/lib/asn1/src/asn1ct.erl index 9f77a557e5..58cbc89db5 100644 --- a/lib/asn1/src/asn1ct.erl +++ b/lib/asn1/src/asn1ct.erl @@ -23,10 +23,10 @@ %% Compile Time functions for ASN.1 (e.g ASN.1 compiler). -%%-compile(export_all). %% Public exports -export([compile/1, compile/2]). -export([test/1, test/2, test/3, value/2, value/3]). + %% Application internal exports -export([compile_asn/3,compile_asn1/3,compile_py/3,compile/3, vsn/0, @@ -75,12 +75,9 @@ -define(ALTERNATIVE,alt). -define(ALTERNATIVE_UNDECODED,alt_undec). -define(ALTERNATIVE_PARTS,alt_parts). -%-define(BINARY,bin). %% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %% This is the interface to the compiler -%% -%% compile(File) -> compile(File,[]). @@ -751,7 +748,6 @@ remove_import_doubles([]) -> remove_import_doubles(ImportList) -> MergedImportList = merge_symbols_from_module(ImportList,[]), -%% io:format("MergedImportList: ~p~n",[MergedImportList]), delete_double_of_symbol(MergedImportList,[]). merge_symbols_from_module([Imp|Imps],Acc) -> @@ -769,7 +765,6 @@ merge_symbols_from_module([Imp|Imps],Acc) -> end, Imps), NewImps = lists:subtract(Imps,IfromModName), -%% io:format("Imp: ~p~nIfromModName: ~p~n",[Imp,IfromModName]), NewImp = Imp#'SymbolsFromModule'{ symbols = lists:append( @@ -835,7 +830,6 @@ generate({M,CodeTuple}, OutFile, EncodingRule, Options) -> Code = #abst{name=M#module.name, types=Types,values=Values,ptypes=Ptypes, classes=Classes,objects=Objects,objsets=ObjectSets}, - debug_on(Options), setup_bit_string_format(Options), setup_legacy_erlang_types(Options), asn1ct_table:new(check_functions), @@ -855,7 +849,6 @@ generate({M,CodeTuple}, OutFile, EncodingRule, Options) -> end, asn1ct_gen:pgen(OutFile, Gen, Code), - debug_off(Options), cleanup_bit_string_format(), erase(tlv_format), % used in ber erase(class_default_type),% used in ber @@ -990,12 +983,8 @@ get_input_file(Module,[]) -> get_input_file(Module,[I|Includes]) -> case (catch input_file_type(filename:join([I,Module]))) of {single_file,FileName} -> -%% case file:read_file_info(FileName) of -%% {ok,_} -> {file,FileName}; -%% _ -> get_input_file(Module,Includes) -%% end; - _ -> + _ -> get_input_file(Module,Includes) end. @@ -1151,20 +1140,8 @@ is_asn1_flag(verbose) -> true; %% 'warnings_as_errors' is intentionally passed through to the compiler. is_asn1_flag(_) -> false. -debug_on(Options) -> - case lists:member(debug,Options) of - true -> - put(asndebug,true); - _ -> - true - end. - -debug_off(_Options) -> - erase(asndebug). - outfile(Base, Ext, Opts) -> -% io:format("Opts. ~p~n",[Opts]), Obase = case lists:keysearch(outdir, 1, Opts) of {value, {outdir, Odir}} -> filename:join(Odir, Base); _NotFound -> Base % Not found or bad format @@ -1215,9 +1192,6 @@ compile_py(File,OutFile,Options) -> compile(File, _OutFile, Options) -> case compile(File, make_erl_options(Options)) of {error,_Reason} -> - %% case occurs due to error in asn1ct_parser2,asn1ct_check -%% io:format("~p~n",[_Reason]), -%% io:format("~p~n~s~n",[_Reason,"error"]), error; ok -> ok; @@ -1512,7 +1486,8 @@ create_pdec_inc_command(_ModName,_,[],Acc) -> create_pdec_inc_command(ModName,{Comps1,Comps2},TNL,Acc) when is_list(Comps1),is_list(Comps2) -> create_pdec_inc_command(ModName,Comps1 ++ Comps2,TNL,Acc); -%% The following two functionclauses matches on the type after the top type. This one if the top type had no tag, i.e. a CHOICE +%% The following two clauses match on the type after the top +%% type. This one if the top type had no tag, i.e. a CHOICE. create_pdec_inc_command(ModN,Clist,[CL|_Rest],[[]]) when is_list(CL) -> create_pdec_inc_command(ModN,Clist,CL,[]); create_pdec_inc_command(ModN,Clist,[CL|_Rest],Acc) when is_list(CL) -> @@ -1523,17 +1498,14 @@ create_pdec_inc_command(ModName, prop=Prop}|Comps], TNL=[C1|Cs],Acc) -> case C1 of -% Name -> -% %% In this case C1 is an atom -% TagCommand = get_tag_command(TS,?MANDATORY,Prop), -% create_pdec_inc_command(ModName,get_components(TS#type.def),Cs,[TagCommand|Acc]); {Name,undecoded} -> TagCommand = get_tag_command(TS,?UNDECODED,Prop), create_pdec_inc_command(ModName,Comps,Cs,concat_sequential(TagCommand,Acc)); {Name,parts} -> TagCommand = get_tag_command(TS,?PARTS,Prop), create_pdec_inc_command(ModName,Comps,Cs,concat_sequential(TagCommand,Acc)); - L when is_list(L) -> % I guess this never happens due to previous function clause + L when is_list(L) -> + %% I guess this never happens due to previous clause. %% This case is only possible as the first element after %% the top type element, when top type is SEGUENCE or SET. %% Follow each element in L. Must note every tag on the @@ -1555,8 +1527,6 @@ create_pdec_inc_command(ModName, RestPartsList,[]), create_pdec_inc_command(ModName,Comps,Cs, [[?MANDATORY,InnerDirectives]|Acc]); -% create_pdec_inc_command(ModName,Comps,Cs, -% [InnerDirectives,?MANDATORY|Acc]); [Opt,EncTag] -> InnerDirectives = create_pdec_inc_command(ModName,TS#type.def, @@ -1564,9 +1534,8 @@ create_pdec_inc_command(ModName, create_pdec_inc_command(ModName,Comps,Cs, [[Opt,EncTag,InnerDirectives]|Acc]) end; -% create_pdec_inc_command(ModName,CList,RestPartsList,Acc); -%% create_pdec_inc_command(ModName,TS#type.def,RestPartsList,Acc); - _ -> %% this component may not be in the config list + _ -> + %% this component may not be in the config list TagCommand = get_tag_command(TS,?MANDATORY,Prop), create_pdec_inc_command(ModName,Comps,TNL,concat_sequential(TagCommand,Acc)) end; @@ -1577,7 +1546,6 @@ create_pdec_inc_command(ModName, [{C1,Directive}|Rest],Acc) -> case Directive of List when is_list(List) -> -% [Command,Tag] = get_tag_command(TS,?ALTERNATIVE,Prop), TagCommand = get_tag_command(TS,?ALTERNATIVE,Prop), CompAcc = create_pdec_inc_command(ModName, @@ -1586,9 +1554,6 @@ create_pdec_inc_command(ModName, [Command,Tag] when is_atom(Command) -> [[Command,Tag,CompAcc]|Acc]; [L1,_L2|Rest] when is_list(L1) -> -% [LastComm|Comms] = lists:reverse(TagCommand), -% [concat_sequential(lists:reverse(Comms), -% [LastComm,CompAcc])|Acc] case lists:reverse(TagCommand) of [Atom|Comms] when is_atom(Atom) -> [concat_sequential(lists:reverse(Comms), @@ -1597,12 +1562,8 @@ create_pdec_inc_command(ModName, [concat_sequential(lists:reverse(Comms), [[Command2,Tag2,CompAcc]])|Acc] end -% [concat_sequential(lists:reverse(Comms), -% InnerCommand)|Acc] - end, create_pdec_inc_command(ModName,{'CHOICE',Comps},Rest, -% [[Command,Tag,CompAcc]|Acc]); NewAcc); undecoded -> TagCommand = get_tag_command(TS,?ALTERNATIVE_UNDECODED,Prop), @@ -1658,7 +1619,6 @@ create_partial_decode_gen_info(_M1,{M2,_}) -> throw({error,{"wrong module name in asn1 config file", M2}}). -%create_partial_decode_gen_info1(ModName,{ModName,TypeList}) -> create_partial_decode_gen_info1(ModName,{FuncName,TypeList}) -> case TypeList of [TopType|Rest] -> @@ -1678,11 +1638,6 @@ create_partial_decode_gen_info1(ModName,{FuncName,TypeList}) -> end; create_partial_decode_gen_info1(_,_) -> ok. -% create_partial_decode_gen_info1(_,[]) -> -% []; -% create_partial_decode_gen_info1(_M1,{M2,_}) -> -% throw({error,{"wrong module name in asn1 config file", -% M2}}). %% create_pdec_command/4 for each name (type or component) in the %% third argument, TypeNameList, a command is created. The command has @@ -1698,7 +1653,6 @@ create_pdec_command(_ModName,_,[],Acc) -> Fun(L,[H|Res],Fun) end, Remove_empty_lists(Acc,[],Remove_empty_lists); -% lists:reverse(Acc); create_pdec_command(ModName,[#'ComponentType'{name=C1,typespec=TS}|_Comps], [C1|Cs],Acc) -> %% this component is a constructed type or the last in the @@ -1747,9 +1701,7 @@ create_pdec_command(ModName,TS=#type{def=Def},[C1|Cs],Acc) -> create_pdec_command(_,_,TNL,_) -> throw({error,{"unexpected error when creating partial " "decode command",TNL}}). - -% get_components({'CHOICE',Components}) -> -% Components; + get_components(#'SEQUENCE'{components={C1,C2}}) when is_list(C1),is_list(C2) -> C1++C2; get_components(#'SEQUENCE'{components=Components}) -> @@ -1820,8 +1772,6 @@ get_tag_command(#type{tag=[Tag]},Command) -> [Command,encode_tag_val(decode_class(Tag#tag.class),Tag#tag.form, Tag#tag.number)]; get_tag_command(T=#type{tag=[Tag|Tags]},Command) -> -% [get_tag_command(T#type{tag=[Tag]},Command)| -% [get_tag_command(T#type{tag=Tags},Command)]]. TC = get_tag_command(T#type{tag=[Tag]},Command), TCs = get_tag_command(T#type{tag=Tags},Command), case many_tags(TCs) of @@ -1849,7 +1799,6 @@ get_tag_command(#type{tag=Tag},Command,Prop) when is_record(Tag,tag) -> get_tag_command(#type{tag=[Tag]},Command,Prop); get_tag_command(T=#type{tag=[Tag|Tags]},Command,Prop) -> [get_tag_command(T#type{tag=[Tag]},Command,Prop)|[ -% get_tag_command(T#type{tag=Tags},?MANDATORY,Prop)]]. get_tag_command(T#type{tag=Tags},Command,Prop)]]. anonymous_dec_command(?UNDECODED,'OPTIONAL') -> @@ -1964,8 +1913,8 @@ read_config_data(Key) -> true -> case asn1ct_table:lookup(asn1_general,{asn1_config,Key}) of [{_,Data}] -> Data; - Err -> % Err is [] when nothing was saved in the ets table -%% io:format("strange data from config file ~w~n",[Err]), + Err -> + %% Err is [] when nothing was saved in the ets table Err end end. @@ -1978,7 +1927,6 @@ read_config_data(Key) -> %% saves input data in a new gen_state record save_gen_state(exclusive_decode,{_,ConfList},PartIncTlvTagList) -> - %ConfList=[{FunctionName,PatternList}|Rest] State = case get_gen_state() of S when is_record(S,gen_state) -> S; @@ -1988,14 +1936,12 @@ save_gen_state(exclusive_decode,{_,ConfList},PartIncTlvTagList) -> inc_type_pattern=ConfList}, save_config(gen_state,StateRec); save_gen_state(_,_,_) -> -%% ok. case get_gen_state() of S when is_record(S,gen_state) -> ok; _ -> save_config(gen_state,#gen_state{}) end. save_gen_state(selective_decode,{_,Type_component_name_list}) -> -%% io:format("Selective_decode: ~p~n",[Type_component_name_list]), State = case get_gen_state() of S when is_record(S,gen_state) -> S; @@ -2077,11 +2023,6 @@ update_gen_state(type_pattern,State,Data) -> update_gen_state(func_name,State,Data) -> save_gen_state(State#gen_state{func_name=Data}); update_gen_state(namelist,State,Data) -> -% SData = -% case Data of -% [D] when is_list(D) -> D; -% _ -> Data -% end, save_gen_state(State#gen_state{namelist=Data}); update_gen_state(tobe_refed_funcs,State,Data) -> save_gen_state(State#gen_state{tobe_refed_funcs=Data}); @@ -2136,7 +2077,6 @@ get_tobe_refed_func(Name) -> %% tuple. Do not save if it exists in generated_functions, because %% then it will be or already is generated. add_tobe_refed_func(Data) -> - %% {Name,SI,Pattern} = fun({N,Si,P,_}) -> {N,Si,P}; (D) -> D end (Data), @@ -2144,8 +2084,6 @@ add_tobe_refed_func(Data) -> case SI of I when is_integer(I) -> fun(D) -> D end(Data); -% fun({N,Ix,P}) -> {N,Ix+1,P}; -% ({N,Ix,P,T}) -> {N,Ix+1,P,T} end (Data); _ -> fun({N,_,P}) -> {N,0,P}; ({N,_,P,T}) -> {N,0,P,T} end (Data) @@ -2153,12 +2091,13 @@ add_tobe_refed_func(Data) -> L = get_gen_state_field(generated_functions), case generated_functions_member(get(currmod),Name,L,Pattern) of - true -> % it exists in generated_functions, it has already - % been generated or saved in tobe_refed_func + true -> + %% it exists in generated_functions, it has already + %% been generated or saved in tobe_refed_func ok; _ -> add_once_tobe_refed_func(NewData), - %%only to get it saved in generated_functions + %% only to get it saved in generated_functions maybe_rename_function(tobe_refed,Name,Pattern) end. @@ -2173,16 +2112,13 @@ add_once_tobe_refed_func(Data) -> ({N,I,_,_}) when N==Name,I==Index -> true; (_) -> false end,TRFL) of [] -> -%% case lists:keysearch(element(1,Data),1,TRFL) of -%% false -> update_gen_state(tobe_refed_funcs,[Data|TRFL]); _ -> ok end. - -%% moves Name from the to be list to the generated list. +%% Moves Name from the to be list to the generated list. generated_refed_func(Name) -> L = get_gen_state_field(tobe_refed_funcs), NewL = lists:keydelete(Name,1,L), @@ -2190,7 +2126,7 @@ generated_refed_func(Name) -> L2 = get_gen_state_field(gen_refed_funcs), update_gen_state(gen_refed_funcs,[Name|L2]). -%% adds Data to gen_refed_funcs field in gen_state. +%% Adds Data to gen_refed_funcs field in gen_state. add_generated_refed_func(Data) -> case is_function_generated(Data) of true -> @@ -2212,7 +2148,7 @@ next_refed_func() -> reset_gen_state() -> save_gen_state(#gen_state{}). -%% adds Data to generated_functions field in gen_state. +%% Adds Data to generated_functions field in gen_state. add_generated_function(Data) -> L = get_gen_state_field(generated_functions), update_gen_state(generated_functions,[Data|L]). @@ -2231,16 +2167,18 @@ maybe_rename_function(Mode,Name,Pattern) -> {_,true} -> L2 = generated_functions_filter(get(currmod),Name,L), case lists:keysearch(Pattern,3,L2) of - false -> %name existed, but not pattern + false -> + %% name existed, but not pattern NextIndex = length(L2), - %%rename function + %% rename function Suffix = lists:concat(["_",NextIndex]), NewName = maybe_rename_function2(type_check(Name),Name, Suffix), add_generated_function({Name,NextIndex,Pattern}), NewName; - Value -> % name and pattern existed + Value -> + %% name and pattern existed %% do not save any new index Suffix = make_suffix(Value), Name2 = @@ -2250,9 +2188,9 @@ maybe_rename_function(Mode,Name,Pattern) -> end, lists:concat([Name2,Suffix]) end; - {inc_disp,_} -> %% this is when - %% decode_partial_inc_disp/2 is - %% generated + {inc_disp,_} -> + %% this is when decode_partial_inc_disp/2 is + %% generated add_generated_function({Name,0,Pattern}), Name; _ -> % this if call from add_tobe_refed_func @@ -2298,23 +2236,12 @@ generated_functions_member(M,Name,[_|T]) -> generated_functions_member(_,_,[]) -> false. -% generated_functions_member(M,Name,L) -> -% case lists:keymember(Name,1,L) of -% true -> -% true; -% _ -> -% generated_functions_member1(M,Name,L) -% end. -% generated_functions_member1(M,#'Externaltypereference'{module=M,type=Name},L) -> -% lists:keymember(Name,1,L); -% generated_functions_member1(_,_,_) -> false. - generated_functions_filter(_,Name,L) when is_atom(Name);is_list(Name) -> lists:filter(fun({N,_,_}) when N==Name -> true; (_) -> false end, L); generated_functions_filter(M,#'Externaltypereference'{module=M,type=Name},L)-> - % remove toptypename from patterns + %% remove top typename from patterns RemoveTType = fun({N,I,[N,P]}) when N == Name -> {N,I,P}; @@ -2351,8 +2278,6 @@ set_current_sindex(Index) -> type_check(A) when is_atom(A) -> atom; -%% type_check(I) when is_integer(I) -> -%% integer; type_check(L) when is_list(L) -> Pred = fun(X) when X=<255 -> false; diff --git a/lib/asn1/src/asn1ct_check.erl b/lib/asn1/src/asn1ct_check.erl index 4f04b78241..e867b9606a 100644 --- a/lib/asn1/src/asn1ct_check.erl +++ b/lib/asn1/src/asn1ct_check.erl @@ -23,10 +23,9 @@ %% Main Module for ASN.1 compile time functions -%-compile(export_all). -export([check/2,storeindb/2,format_error/1]). -%-define(debug,1). -include("asn1_records.hrl"). + %%% The tag-number for universal types -define(N_BOOLEAN, 1). -define(N_INTEGER, 2). @@ -63,7 +62,8 @@ -define(TAG_CONSTRUCTED(Num), #tag{class='UNIVERSAL',number=Num,type='IMPLICIT',form=32}). --record(newt,{type=unchanged,tag=unchanged,constraint=unchanged,inlined=no}). % used in check_type to update type and tag +%% used in check_type to update type and tag +-record(newt,{type=unchanged,tag=unchanged,constraint=unchanged,inlined=no}). check(S,{Types,Values,ParameterizedTypes,Classes,Objects,ObjectSets}) -> %%Predicates used to filter errors @@ -561,7 +561,6 @@ check_class_fields(S,[F|Fields],Acc) -> D; {undefined,user} -> %% neither of {primitive,bif} or {constructed,bif} - {_,D} = get_referenced_type(S,#'Externaltypereference'{module=S#state.mname,type=Type#type.def}), D; _ -> @@ -623,7 +622,6 @@ if_current_checked_type(S,#type{def=Def}) -> CurrentModule = S#state.mname, CurrentCheckedName = S#state.tname, MergedModules = S#state.inputmodules, - % CurrentCheckedModule = S#state.mname, case Def of #'Externaltypereference'{module=CurrentModule, type=CurrentCheckedName} -> @@ -656,7 +654,6 @@ check_pobjectset(S,PObjSet) -> ClassName = #'Externaltypereference'{module=Mod, type=get_datastr_name(Def)}, {valueset,Set} = ValueSet, -% ObjectSet = #'ObjectSet'{class={objectclassname,ClassName}, ObjectSet = #'ObjectSet'{class=ClassName, set=Set}, #pobjectsetdef{pos=Pos,name=Name,args=Args,class=Type#type.def, @@ -1696,7 +1693,7 @@ check_value(OldS,V) when is_record(V,typedef) -> %% reference to class check_value(OldS,V#typedef{typespec=TS#'ObjectSet'{class=Eref}}); #typedef{typespec=HostType} -> - % an ordinary value set with a type in #typedef.typespec + %% an ordinary value set with a type in #typedef.typespec ValueSet0 = TS#'ObjectSet'.set, Constr = check_constraints(OldS, HostType, [ValueSet0]), Type = check_type(OldS,TSDef,TSDef#typedef.typespec), @@ -2381,15 +2378,6 @@ normalize_s_of(SorS,S,Value,Type,NameList) %% normalize_restrictedstring handles all format of restricted strings. -%% tuple case -% normalize_restrictedstring(_S,[Int1,Int2],_) when is_integer(Int1),is_integer(Int2) -> -% {Int1,Int2}; -% %% quadruple case -% normalize_restrictedstring(_S,[Int1,Int2,Int3,Int4],_) when is_integer(Int1), -% is_integer(Int2), -% is_integer(Int3), -% is_integer(Int4) -> -% {Int1,Int2,Int3,Int4}; %% character string list case normalize_restrictedstring(S,[H|T],CType) when is_list(H);is_tuple(H) -> [normalize_restrictedstring(S,H,CType)|normalize_restrictedstring(S,T,CType)]; @@ -2491,7 +2479,7 @@ check_ptype(S,Type,Ts) when is_record(Ts,type) -> Ts#type{def=TDef} end, Ts2; -%parameterized class +%% parameterized class check_ptype(_S,_PTDef,Ts) when is_record(Ts,objectclass) -> throw({asn1_param_class,Ts}). @@ -2506,8 +2494,6 @@ check_formal_parameter(_, #'Externaltypereference'{}) -> check_formal_parameter(S, #'Externalvaluereference'{value=Name}) -> asn1_error(S, {illegal_typereference,Name}). -% check_type(S,Type,ObjSpec={{objectclassname,_},_}) -> - % check_class(S,ObjSpec); check_type(_S,Type,Ts) when is_record(Type,typedef), (Type#typedef.checked==true) -> Ts; @@ -2606,7 +2592,6 @@ check_type(S=#state{recordtopname=TopName},Type,Ts) when is_record(Ts,type) -> constraint = NewC}; _ -> %% Here we only expand the tags and keep the ext ref. - NewExt = ExtRef#'Externaltypereference'{module=merged_mod(S,RefMod,Ext)}, TempNewDef#newt{ type = check_externaltypereference(S,NewExt), @@ -2749,7 +2734,6 @@ check_type(S=#state{recordtopname=TopName},Type,Ts) when is_record(Ts,type) -> case TopName of [] -> [get_datastr_name(Type)]; -% [Type#typedef.name]; _ -> TopName end, @@ -2773,7 +2757,6 @@ check_type(S=#state{recordtopname=TopName},Type,Ts) when is_record(Ts,type) -> case TopName of [] -> [get_datastr_name(Type)]; -% [Type#typedef.name]; _ -> TopName end, @@ -2898,8 +2881,6 @@ tablecinf_choose(#'SEQUENCE'{tablecinf=TCI}) -> get_innertag(_S,#'ObjectClassFieldType'{type=Type}) -> case Type of -% #type{tag=Tag} -> Tag; -% {fixedtypevaluefield,_,#type{tag=[]}=T} -> get_taglist(S,T); {fixedtypevaluefield,_,#type{tag=Tag}} -> Tag; {TypeFieldName,_} when is_atom(TypeFieldName) -> []; _ -> [] @@ -3754,14 +3735,8 @@ check_reference(S,#'Externaltypereference'{pos=Pos,module=Emod,type=Name}) -> {ok,Imodule} -> check_imported(S,Imodule,Name), #'Externaltypereference'{module=Imodule,type=Name}; -%% case check_imported(S,Imodule,Name) of -%% ok -> -%% #'Externaltypereference'{module=Imodule,type=Name}; -%% Err -> -%% Err -%% end; _ -> - %may be a renamed type in multi file compiling! + %% may be a renamed type in multi file compiling! {M,T}=get_renamed_reference(S,Name,Emod), NewName = asn1ct:get_name_of_def(T), NewPos = asn1ct:get_pos_of_def(T), @@ -4170,7 +4145,6 @@ iof_associated_type(S,[]) -> def=AssociateSeq}}, asn1_db:dbput(S#state.mname,'INSTANCE OF',TypeDef), instance_of_decl(S#state.mname); -%% put(instance_of,{generate,S#state.mname}); _ -> instance_of_decl(S#state.mname), ok @@ -4199,14 +4173,12 @@ iof_associated_type1(S,C) -> ObjectIdentifier = #'ObjectClassFieldType'{classname=TypeIdentifierRef, class=[], -%% fieldname=[{valuefieldreference,id}], fieldname={id,[]}, type={fixedtypevaluefield,id, #type{def='OBJECT IDENTIFIER'}}}, Typefield = #'ObjectClassFieldType'{classname=TypeIdentifierRef, class=[], -%% fieldname=[{typefieldreference,'Type'}], fieldname={'Type',[]}, type=Typefield_type}, IOFComponents0 = @@ -4360,11 +4332,11 @@ check_boolean(_S,_Constr) -> check_octetstring(_S,_Constr) -> ok. -% check all aspects of a SEQUENCE -% - that all component names are unique -% - that all TAGS are ok (when TAG default is applied) -% - that each component is of a valid type -% - that the extension marks are valid +%% check all aspects of a SEQUENCE +%% - that all component names are unique +%% - that all TAGS are ok (when TAG default is applied) +%% - that each component is of a valid type +%% - that the extension marks are valid check_sequence(S,Type,Comps) -> Components = expand_components(S,Comps), @@ -4705,11 +4677,11 @@ check_objectidentifier(_S,_Constr) -> check_relative_oid(_S,_Constr) -> ok. -% check all aspects of a CHOICE -% - that all alternative names are unique -% - that all TAGS are ok (when TAG default is applied) -% - that each alternative is of a valid type -% - that the extension marks are valid +%% check all aspects of a CHOICE +%% - that all alternative names are unique +%% - that all TAGS are ok (when TAG default is applied) +%% - that each alternative is of a valid type +%% - that the extension marks are valid check_choice(S,Type,Components) when is_list(Components) -> Components1 = [C||C = #'ComponentType'{} <- Components], case check_unique(Components1,#'ComponentType'.name) of @@ -5063,12 +5035,12 @@ remove_doubles1(El,L) -> %% referred to in the ObjectClassFieldType, and the name of the unique %% field of the class of the ObjectClassFieldType. %% -% %% The level information outermost/innermost must be kept. There are -% %% at least two possibilities to cover here for an outermost case: 1) -% %% Both the simple table and the component relation have a common path -% %% at least one step below the outermost level, i.e. the leading -% %% information shall be on a sub level. 2) They don't have any common -% %% path. +%% The level information outermost/innermost must be kept. There are +%% at least two possibilities to cover here for an outermost case: 1) +%% Both the simple table and the component relation have a common path +%% at least one step below the outermost level, i.e. the leading +%% information shall be on a sub level. 2) They don't have any common +%% path. get_simple_table_info(S, Cs, AtLists) -> [get_simple_table_info1(S, Cs, AtList, []) || AtList <- AtLists]. @@ -5109,10 +5081,10 @@ simple_table_info(S,#'ObjectClassFieldType'{classname=ClRef, {_FirstFieldName,FieldNames} -> lists:last(FieldNames) end, - %%ObjectClassFieldName is the last element in the dotted - %%list of the ObjectClassFieldType. The last element may - %%be of another class, that is referenced from the class - %%of the ObjectClassFieldType + %% ObjectClassFieldName is the last element in the dotted list of + %% the ObjectClassFieldType. The last element may be of another + %% class, that is referenced from the class of the + %% ObjectClassFieldType ClassDef = case ObjectClass of [] -> @@ -5128,7 +5100,7 @@ simple_table_info(S,#'ObjectClassFieldType'{classname=ClRef, %% the "name path" in the at-list to the component relation constraint %% that must refer to a simple table constraint. The list is empty if %% no component relation constraints were found. -%% +%% %% NamePath has the names of all components that are followed from the %% beginning of the search. CNames holds the names of all components %% of the start level, this info is used if an outermost at-notation @@ -5141,6 +5113,7 @@ any_component_relation(S,[#'ComponentType'{name=CName,typespec=Type}|Cs],CNames, %% whether this constraint is relevant for the level %% where the search started AtNot = extract_at_notation(AtNotation), + %% evaluate_atpath returns the relative path to the %% simple table constraint from where the component %% relation is found. @@ -5246,12 +5219,10 @@ get_components(_,#'SET'{components=Cs}) -> tuple2complist(Cs); get_components(_,{'CHOICE',Cs}) -> tuple2complist(Cs); -%do not step in inlined structures +%%do not step in inlined structures get_components(any,{'SEQUENCE OF',T = #type{def=_Def,inlined=no}}) -> -% get_components(any,Def); T; get_components(any,{'SET OF',T = #type{def=_Def,inlined=no}}) -> -% get_components(any,Def); T; get_components(_,_) -> []. @@ -5281,15 +5252,12 @@ extract_at_notation([{Level,ValueRefs}]) -> componentrelation1(S,C = #type{def=Def,constraint=Constraint,tablecinf=TCI}, Path) -> Ret = -% case Constraint of -% [{componentrelation,{_,_,ObjectSet},AtList}|_Rest] -> case lists:keyfind(componentrelation, 1, Constraint) of {_,{_,_,ObjectSet},AtList} -> [{_,AL=[#'Externalvaluereference'{}|_R1]}|_R2] = AtList, %% Note: if Path is longer than one,i.e. it is within %% an inner type of the actual level, then the only %% relevant at-list is of "outermost" type. -%% #'ObjectClassFieldType'{class=ClassDef} = Def, ClassDef = get_ObjectClassFieldType_classdef(S,Def), AtPath = lists:map(fun(#'Externalvaluereference'{value=V})->V end, @@ -5375,7 +5343,6 @@ innertype_comprel1(S,T = #type{def=Def,constraint=Cons,tablecinf=TCI},Path) -> %% relevent here. [{_,AL=[#'Externalvaluereference'{value=_Attr}|_R1]}|_R2] = AtList, -%% #'ObjectClassFieldType'{class=ClassDef} = Def, ClassDef = get_ObjectClassFieldType_classdef(S,Def), AtPath = lists:map(fun(#'Externalvaluereference'{value=V})->V end, @@ -5444,7 +5411,7 @@ leading_attr_index1(S,[C|Cs],Arg={ObjectSet,_,CDef,P}, value_match(S,C,Name,SubAttr) -> value_match(S,C,Name,SubAttr,[]). % C has name Name value_match(_S,#'ComponentType'{},_Name,[],Acc) -> - Acc;% do not reverse, indexes in reverse order + Acc; % do not reverse, indexes in reverse order value_match(S,#'ComponentType'{typespec=Type},Name,[At|Ats],Acc) -> InnerType = asn1ct_gen:get_inner(Type#type.def), Components = @@ -5514,8 +5481,6 @@ get_tableconstraint_info(S,Type,[C=#'ComponentType'{typespec=CheckedTs}|Cs],Acc) CheckedTs#type{ def=NewOCFT }}; -% constraint=[{tableconstraint_info, -% FieldRef}]}}; {'SEQUENCE OF',SOType} when is_record(SOType,type), (element(1,SOType#type.def)=='CHOICE') -> CTypeList = element(2,SOType#type.def), @@ -5618,51 +5583,6 @@ get_taglist1(S,[_H|Rest]) -> % skip EXTENSIONMARK get_taglist1(_S,[]) -> []. -%% def_to_tag(S,Def) -> -%% case asn1ct_gen:def_to_tag(Def) of -%% {'UNIVERSAL',T} -> -%% case asn1ct_gen:prim_bif(T) of -%% true -> -%% ?TAG_PRIMITIVE(tag_number(T)); -%% _ -> -%% ?TAG_CONSTRUCTED(tag_number(T)) -%% end; -%% _ -> [] -%% end. -%% tag_number('BOOLEAN') -> 1; -%% tag_number('INTEGER') -> 2; -%% tag_number('BIT STRING') -> 3; -%% tag_number('OCTET STRING') -> 4; -%% tag_number('NULL') -> 5; -%% tag_number('OBJECT IDENTIFIER') -> 6; -%% tag_number('ObjectDescriptor') -> 7; -%% tag_number('EXTERNAL') -> 8; -%% tag_number('INSTANCE OF') -> 8; -%% tag_number('REAL') -> 9; -%% tag_number('ENUMERATED') -> 10; -%% tag_number('EMBEDDED PDV') -> 11; -%% tag_number('UTF8String') -> 12; -%% %%tag_number('RELATIVE-OID') -> 13; -%% tag_number('SEQUENCE') -> 16; -%% tag_number('SEQUENCE OF') -> 16; -%% tag_number('SET') -> 17; -%% tag_number('SET OF') -> 17; -%% tag_number('NumericString') -> 18; -%% tag_number('PrintableString') -> 19; -%% tag_number('TeletexString') -> 20; -%% %%tag_number('T61String') -> 20; -%% tag_number('VideotexString') -> 21; -%% tag_number('IA5String') -> 22; -%% tag_number('UTCTime') -> 23; -%% tag_number('GeneralizedTime') -> 24; -%% tag_number('GraphicString') -> 25; -%% tag_number('VisibleString') -> 26; -%% %%tag_number('ISO646String') -> 26; -%% tag_number('GeneralString') -> 27; -%% tag_number('UniversalString') -> 28; -%% tag_number('CHARACTER STRING') -> 29; -%% tag_number('BMPString') -> 30. - merge_tags(T1, T2) when is_list(T2) -> merge_tags2(T1 ++ T2, []); merge_tags(T1, T2) -> diff --git a/lib/asn1/src/asn1ct_constructed_ber_bin_v2.erl b/lib/asn1/src/asn1ct_constructed_ber_bin_v2.erl index 16af09bca9..bfb69a09b3 100644 --- a/lib/asn1/src/asn1ct_constructed_ber_bin_v2.erl +++ b/lib/asn1/src/asn1ct_constructed_ber_bin_v2.erl @@ -32,17 +32,17 @@ -include("asn1_records.hrl"). --import(asn1ct_gen, [emit/1,demit/1,get_record_name_prefix/1]). +-import(asn1ct_gen, [emit/1,get_record_name_prefix/1]). -define(ASN1CT_GEN_BER,asn1ct_gen_ber_bin_v2). -% the encoding of class of tag bits 8 and 7 +%% the encoding of class of tag bits 8 and 7 -define(UNIVERSAL, 0). -define(APPLICATION, 16#40). -define(CONTEXT, 16#80). -define(PRIVATE, 16#C0). -% primitive or constructed encoding % bit 6 +%% primitive or constructed encoding % bit 6 -define(PRIMITIVE, 0). -define(CONSTRUCTED, 2#00100000). @@ -103,7 +103,6 @@ gen_encode_sequence(Gen, Typename, #type{}=D) -> uniqueclassfield=Unique} when Used /= Unique -> false; %% ObjectSet, name of the object set in constraints - %% #simpletableattributes{objectsetname=ObjectSetRef, c_name=AttrN, c_index=N, @@ -230,7 +229,6 @@ gen_decode_sequence(Gen, Typename, #type{}=D) -> usedclassfield=UniqueFieldName, uniqueclassfield=UniqueFieldName, valueindex=ValIndex} -> -% {ObjectSetRef,AttrN,_N,UniqueFieldName} ->%% N is index of attribute that determines constraint F = fun(#'ComponentType'{typespec=CT})-> case {asn1ct_gen:get_constraint(CT#type.constraint,componentrelation),CT#type.tablecinf} of {no,[{objfun,_}|_]} -> true; @@ -279,12 +277,12 @@ gen_decode_sequence(Gen, Typename, #type{}=D) -> ValueMatch,"),",nl]), gen_dec_postponed_decs(DecObj,PostponedDecArgs) end, - demit(["Result = "]), %dbg %% return value as record case Ext of {ext,_,_} -> emit(["case ",{prev,tlv}," of [] -> true; _ -> true end, % ... extra fields skipped",nl]); - _ -> % noext | extensible + _ -> + %% noext | extensible emit(["case ",{prev,tlv}," of",nl, "[] -> true;", "_ -> exit({error,{asn1, {unexpected,",{prev,tlv}, @@ -431,7 +429,6 @@ gen_decode_set(Gen, Typename, #type{}=D) -> {DecObjInf,ValueIndex} = case TableConsInfo of -%% {ObjectSetRef,AttrN,_N,UniqueFieldName} ->%% N is index of attribute that determines constraint #simpletableattributes{objectsetname=ObjectSetRef, c_name=AttrN, usedclassfield=UniqueFieldName, @@ -446,7 +443,8 @@ gen_decode_set(Gen, Typename, #type{}=D) -> end end, case lists:any(F,CompList) of - true -> % when component relation constraint establish + true -> + %% when component relation constraint establish %% relation from a component to another components %% subtype component {{AttrN,{deep,ObjectSetRef,UniqueFieldName,ValIndex}}, @@ -503,7 +501,6 @@ gen_decode_set(Gen, Typename, #type{}=D) -> ValueMatch,"),",nl]), gen_dec_postponed_decs(DecObj,PostponedDecArgs) end, - demit(["Result = "]), %dbg %% return value as record case Ext of Extnsn when Extnsn =/= noext -> @@ -722,7 +719,7 @@ gen_dec_sequence_call2(Erules,TopType,{Root1,EList,Root2},_Ext,DecObjInf) -> length(Root1)+length(EList),noext, DecObjInf,LA,ArgsAcc). -%% returns a list of tags of the elements in the component (second +%% Returns a list of tags of the elements in the component (second %% root) list up to and including the first mandatory tag. See 24.6 in %% X.680 (7/2002) get_root2_taglist([],Acc) -> @@ -811,8 +808,6 @@ gen_dec_set_cases(Erules,TopType,[Comp|RestComps],Pos) -> [FirstTag|_] -> [(?ASN1CT_GEN_BER:decode_class(FirstTag#tag.class) bsl 10) + FirstTag#tag.number] end, -% emit([indent(6),"%Tags: ",Tags,nl]), -% emit([indent(6),"%Type#type.tag: ",Type#type.tag,nl]), CaseFun = fun(TagList=[H|T],Fun,N) -> Semicolon = case TagList of [_Tag1,_|_] -> [";",nl]; @@ -827,7 +822,6 @@ gen_dec_set_cases(Erules,TopType,[Comp|RestComps],Pos) -> emit([";",nl]) end, CaseFun(Tags,CaseFun,0), -%% emit([";",nl]), gen_dec_set_cases(Erules,TopType,RestComps,Pos+1). @@ -1007,14 +1001,6 @@ gen_enc_line(Erules,TopType,Cname, ["{",{curr,encBytes},",",{curr,encLen},"} = "], EncObj) end; -% gen_enc_line(Erules,TopType,Cname, -% Type=#type{constraint=[{componentrelation,_,_}], -% def=#'ObjectClassFieldType'{type={typefield,_}}}, -% Element,Indent,OptOrMand=mandatory,EncObj) -% when is_list(Element) -> -% asn1ct_name:new(tmpBytes), -% gen_enc_line(Erules,TopType,Cname,Type,Element,Indent,OptOrMand, -% ["{",{curr,tmpBytes},",_} = "],EncObj); gen_enc_line(Erules,TopType,Cname,Type,Element,Indent,OptOrMand,EncObj) when is_list(Element) -> gen_enc_line(Erules,TopType,Cname,Type,Element,Indent,OptOrMand, @@ -1035,37 +1021,30 @@ gen_enc_line(Erules,TopType,Cname,Type,Element,Indent,OptOrMand,Assign,EncObj) gen_optormand_case(OptOrMand, Erules, TopType, Cname, Type, Element), case {Type,asn1ct_gen:get_constraint(Type#type.constraint, componentrelation)} of -% #type{constraint=[{tableconstraint_info,RefedFieldName}], -% def={typefield,_}} -> {#type{def=#'ObjectClassFieldType'{type={typefield,_}, fieldname=RefedFieldName}}, {componentrelation,_,_}} -> {_LeadingAttrName,Fun} = EncObj, - case RefedFieldName of - {Name,RestFieldNames} when is_atom(Name) -> - case OptOrMand of - mandatory -> ok; - _ -> -% emit(["{",{curr,tmpBytes},",",{curr,tmpLen}, - emit(["{",{curr,tmpBytes},",_ } = "]) -% "} = "]) - end, - emit([Fun,"(",{asis,Name},", ",Element,", ", - {asis,RestFieldNames},"),",nl]), - emit(IndDeep), - case OptOrMand of - mandatory -> - emit(["{",{curr,encBytes},",",{curr,encLen}, - "} = ", - {call,ber,encode_open_type, - [{curr,tmpBytes},{asis,Tag}]},nl]); - _ -> - emit([{call,ber,encode_open_type, - [{curr,tmpBytes},{asis,Tag}]}]) - end; - Err -> - throw({asn1,{'internal error',Err}}) - end; + {Name,RestFieldNames} = RefedFieldName, + true = is_atom(Name), %Assertion. + case OptOrMand of + mandatory -> ok; + _ -> + emit(["{",{curr,tmpBytes},",_ } = "]) + end, + emit([Fun,"(",{asis,Name},", ",Element,", ", + {asis,RestFieldNames},"),",nl]), + emit(IndDeep), + case OptOrMand of + mandatory -> + emit(["{",{curr,encBytes},",",{curr,encLen}, + "} = ", + {call,ber,encode_open_type, + [{curr,tmpBytes},{asis,Tag}]},nl]); + _ -> + emit([{call,ber,encode_open_type, + [{curr,tmpBytes},{asis,Tag}]}]) + end; _ -> case WhatKind of {primitive,bif} -> @@ -1166,7 +1145,9 @@ gen_dec_line(Erules,TopType,Cname,CTags,Type,OptOrMand,DecObjInf) -> gen_dec_call(InnerType,Erules,TopType,Cname,Type, BytesVar,Tag, mandatory,", mandatory, ",DecObjInf,OptOrMand); - _ -> %optional or default or a mandatory component after an extensionmark + _ -> + %% optional or default, or a mandatory component after + %% an extension marker {FirstTag,RestTag} = case Tag of [] -> @@ -1241,9 +1222,9 @@ gen_dec_line(Erules,TopType,Cname,CTags,Type,OptOrMand,DecObjInf) -> PostponedDec end, case DecObjInf of - {Cname,ObjSet} -> % this must be the component were an object is - %% choosen from the object set according to the table - %% constraint. + {Cname,ObjSet} -> + %% This must be the component were an object is chosen + %% from the object set according to the table constraint. ObjSetName = case ObjSet of {deep,OSName,_,_} -> OSName; @@ -1280,10 +1261,7 @@ gen_dec_call({typefield,_},_,_,_Cname,Type,BytesVar,Tag,_,_,false,_) -> []; gen_dec_call({typefield,_},_,_,Cname,Type,BytesVar,Tag,_,_,_DecObjInf,OptOrMandComp) -> call(decode_open_type, [BytesVar,{asis,Tag}]), - RefedFieldName = -% asn1ct_gen:get_constraint(Type#type.constraint, -% tableconstraint_info), - (Type#type.def)#'ObjectClassFieldType'.fieldname, + RefedFieldName = (Type#type.def)#'ObjectClassFieldType'.fieldname, [{Cname,RefedFieldName,asn1ct_gen:mk_var(asn1ct_name:curr(term)), asn1ct_gen:mk_var(asn1ct_name:curr(tmpterm)),Tag,OptOrMandComp}]; gen_dec_call(InnerType, Gen, TopType, Cname, Type, BytesVar, @@ -1339,8 +1317,6 @@ gen_dec_call1(WhatKind, _, TopType, Cname, Type, BytesVar, Tag) -> emit(["{'",asn1ct_gen:list2name([Cname|TopType]),"',", BytesVar,"}"]); _ -> -% {DecFunName, _DecMod, _DecFun} = -% case {asn1ct:get_gen_state_field(namelist),WhatKind} of EmitDecFunCall = fun(FuncName) -> case {WhatKind,Type#type.tablecinf} of @@ -1356,14 +1332,11 @@ gen_dec_call1(WhatKind, _, TopType, Cname, Type, BytesVar, Tag) -> Sindex = case WhatKind of #'Externaltypereference'{} -> -% asn1ct:maybe_rename_function(WhatKind,List), SI = asn1ct:maybe_saved_sindex(WhatKind,List), Saves = {WhatKind,SI,List}, asn1ct:add_tobe_refed_func(Saves), SI; _ -> -% asn1ct:maybe_rename_function([Cname|TopType], -% List), SI = asn1ct:maybe_saved_sindex([Cname|TopType],List), Saves = {[Cname|TopType],SI,List,Type}, asn1ct:add_tobe_refed_func(Saves), @@ -1371,8 +1344,6 @@ gen_dec_call1(WhatKind, _, TopType, Cname, Type, BytesVar, Tag) -> end, asn1ct:update_gen_state(namelist,Rest), Prefix=asn1ct:get_gen_state_field(prefix), -% Suffix = -% lists:concat(["_",asn1ct:latest_sindex()]), Suffix = case Sindex of I when is_integer(I),I>0 -> lists:concat(["_",I]); @@ -1380,8 +1351,6 @@ gen_dec_call1(WhatKind, _, TopType, Cname, Type, BytesVar, Tag) -> end, {DecFunName,_,_}= mkfuncname(TopType,Cname,WhatKind,Prefix,Suffix), -% SuffixedName = -% lists:concat([DecFunName,asn1ct:latest_sindex()]), EmitDecFunCall(DecFunName); [{Cname,parts}|Rest] -> asn1ct:update_gen_state(namelist,Rest), @@ -1401,13 +1370,6 @@ gen_dec_call1(WhatKind, _, TopType, Cname, Type, BytesVar, Tag) -> mkfuncname(TopType,Cname,WhatKind,"dec_",""), EmitDecFunCall(DecFunName) end -% case {WhatKind,Type#type.tablecinf} of -% {{constructed,bif},[{objfun,_}|_Rest]} -> -% emit([DecFunName,"(",BytesVar,", ",{asis,Tag}, -% ", ObjFun)"]); -% _ -> -% emit([DecFunName,"(",BytesVar,", ",{asis,Tag},")"]) -% end end. @@ -1464,6 +1426,9 @@ print_attribute_comment(InnerType,Pos,Cname,Prop) -> case InnerType of #'Externaltypereference'{module=XModule,type=Name} -> emit([nl,"%% attribute ",Cname,"(",Pos,") External ",XModule,":",Name]); + _ when is_tuple(InnerType) -> + emit([nl,"%% attribute ",Cname,"(",Pos,") with type "| + tuple_to_list(InnerType)]); _ -> emit([nl,"%% attribute ",Cname,"(",Pos,") with type ",InnerType]) end, diff --git a/lib/asn1/src/asn1ct_constructed_per.erl b/lib/asn1/src/asn1ct_constructed_per.erl index 9cd9864b80..986d88b677 100644 --- a/lib/asn1/src/asn1ct_constructed_per.erl +++ b/lib/asn1/src/asn1ct_constructed_per.erl @@ -30,9 +30,8 @@ -export([gen_decode_choice/3]). -include("asn1_records.hrl"). -%-compile(export_all). --import(asn1ct_gen, [emit/1,demit/1,get_record_name_prefix/1]). +-import(asn1ct_gen, [emit/1,get_record_name_prefix/1]). -type type_name() :: any(). @@ -357,7 +356,6 @@ gen_dec_constructed_imm(Erule, Typename, #type{}=D) -> #'SEQUENCE'{tablecinf=TCI,components=CL} -> {add_textual_order(CL),TCI}; #'SET'{tablecinf=TCI,components=CL} -> -%% {add_textual_order(CL),TCI} {CL,TCI} % the textual order is already taken care of end, Ext = extensible_dec(CompList), @@ -375,13 +373,11 @@ gen_dec_constructed_imm(Erule, Typename, #type{}=D) -> end, ObjSetInfo = case TableConsInfo of -%% {ObjectSet,AttrN,N,UniqueFieldName} ->%% N is index of attribute that determines constraint #simpletableattributes{objectsetname=ObjectSet, c_name=AttrN, usedclassfield=UniqueFieldName, uniqueclassfield=UniqueFieldName, valueindex=ValIndex} -> -%% {AttrN,ObjectSet}; F = fun(#'ComponentType'{typespec=CT})-> case {asn1ct_gen:get_constraint(CT#type.constraint,componentrelation),CT#type.tablecinf} of {no,[{objfun,_}|_R]} -> true; @@ -686,10 +682,10 @@ gen_decode_choice(Erules,Typename,D) when is_record(D,type) -> {'CHOICE',CompList} = D#type.def, Ext = extensible_enc(CompList), gen_dec_choice(Erules,Typename,CompList,Ext), - emit({".",nl}). + emit([".",nl]). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -% Encode generator for SEQUENCE OF type +%% Encode generator for SEQUENCE OF type gen_encode_sof(Erule, Typename, SeqOrSetOf, D) -> asn1ct_name:start(), @@ -781,20 +777,20 @@ gen_decode_sof_components(Erule, Name, Typename, SeqOrSetOf, Cont) -> case asn1ct_gen:type(Conttype) of {primitive,bif} -> asn1ct_gen_per:gen_dec_prim(Erule, Cont, "Bytes"), - emit({com,nl}); + emit([com,nl]); {constructed,bif} -> NewTypename = [Constructed_Suffix|Typename], - emit({"'dec_",asn1ct_gen:list2name(NewTypename), - "'(Bytes",ObjFun,"),",nl}); + emit([{asis,dec_func(asn1ct_gen:list2name(NewTypename))}, + "(Bytes",ObjFun,"),",nl]); #'Externaltypereference'{}=Etype -> asn1ct_gen_per:gen_dec_external(Etype, "Bytes"), emit([com,nl]); 'ASN1_OPEN_TYPE' -> asn1ct_gen_per:gen_dec_prim(Erule, #type{def='ASN1_OPEN_TYPE'}, "Bytes"), - emit({com,nl}); + emit([com,nl]); _ -> - emit({"'dec_",Conttype,"'(Bytes),",nl}) + emit([{asis,dec_func(Conttype)},"(Bytes),",nl]) end, emit([{asis,Name},"(Num-1, Remain",ObjFun,", [Term|Acc]).",nl]). @@ -934,9 +930,7 @@ add_textual_order({R1,Ext,R2}) -> {NewExt,Num2} = add_textual_order1(Ext,Num1), {NewR2,_} = add_textual_order1(R2,Num2), {NewR1,NewExt,NewR2}. -%%add_textual_order1(Cs=[#'ComponentType'{textual_order=Int}|_],I) -%% when is_integer(Int) -> -%% {Cs,I}; + add_textual_order1(Cs,NumIn) -> lists:mapfoldl(fun(C=#'ComponentType'{},Num) -> {C#'ComponentType'{textual_order=Num}, @@ -1494,9 +1488,9 @@ gen_dec_component_no_val(_, Type, {'DEFAULT',DefVal0}) -> DefVal = asn1ct_gen:conform_value(Type, DefVal0), emit([{asis,DefVal}]); gen_dec_component_no_val(_, _, 'OPTIONAL') -> - emit({"asn1_NOVALUE"}); + emit(["asn1_NOVALUE"]); gen_dec_component_no_val({ext,_,_}, _, mandatory) -> - emit({"asn1_NOVALUE"}). + emit(["asn1_NOVALUE"]). dec_map_extaddgroup_no_val(Ext, Type, Comp) -> L0 = [dec_map_extaddgroup_no_val_1(N, P, Ext, Type) || @@ -1693,16 +1687,15 @@ gen_dec_line_other(Erule, Atype, TopType, Comp) -> end; {constructed,bif} -> NewTypename = [Cname|TopType], + DecFunc = dec_func(asn1ct_gen:list2name(NewTypename)), case Type#type.tablecinf of [{objfun,_}|_R] -> fun(BytesVar) -> - emit({"'dec_",asn1ct_gen:list2name(NewTypename), - "'(",BytesVar,", ObjFun)"}) + emit([{asis,DecFunc},"(",BytesVar,", ObjFun)"]) end; _ -> fun(BytesVar) -> - emit({"'dec_",asn1ct_gen:list2name(NewTypename), - "'(",BytesVar,")"}) + emit([{asis,DecFunc},"(",BytesVar,")"]) end end end. @@ -1908,7 +1901,7 @@ emit_extaddgroupTerms(VarSeries,[_]) -> ok; emit_extaddgroupTerms(VarSeries,[_|Rest]) -> asn1ct_name:new(VarSeries), - emit({{curr,VarSeries},","}), + emit([{curr,VarSeries},","]), emit_extaddgroupTerms(VarSeries,Rest); emit_extaddgroupTerms(_,[]) -> ok. @@ -1990,3 +1983,6 @@ attribute_comment(InnerType, TextPos, Cname) -> end, Comment = ["attribute ",Cname,"(",TextPos,") with type ",DispType], lists:concat(Comment). + +dec_func(Tname) -> + list_to_atom(lists:concat(["dec_",Tname])). diff --git a/lib/asn1/src/asn1ct_func.erl b/lib/asn1/src/asn1ct_func.erl index 0cd72acf9d..016161fcaf 100644 --- a/lib/asn1/src/asn1ct_func.erl +++ b/lib/asn1/src/asn1ct_func.erl @@ -65,7 +65,7 @@ generate(Fd) -> Funcs = sofs:to_external(Funcs0), ok = file:write(Fd, Funcs). -is_used({_,_,_}=MFA) -> +is_used({M,F,A}=MFA) when is_atom(M), is_atom(F), is_integer(A) -> req({is_used,MFA}). diff --git a/lib/asn1/src/asn1ct_gen.erl b/lib/asn1/src/asn1ct_gen.erl index 9f628c7b04..fa312ed052 100644 --- a/lib/asn1/src/asn1ct_gen.erl +++ b/lib/asn1/src/asn1ct_gen.erl @@ -22,8 +22,7 @@ -include("asn1_records.hrl"). --export([demit/1, - emit/1, +-export([emit/1, open_output_file/1,close_output_file/0, get_inner/1,type/1,def_to_tag/1,prim_bif/1, list2name/1, @@ -191,13 +190,9 @@ pgen_partial_decode(_, _, _) -> ok. pgen_partial_inc_dec(Rtmod,Erules,Module) -> -% io:format("Start partial incomplete decode gen?~n"), case asn1ct:get_gen_state_field(inc_type_pattern) of undefined -> -% io:format("Partial incomplete decode gen not started: ~w~n",[asn1ct:get_gen_state_field(active)]), ok; -% [] -> -% ok; ConfList -> PatternLists=lists:map(fun({_,P}) -> P end,ConfList), pgen_partial_inc_dec1(Rtmod,Erules,Module,PatternLists), @@ -215,11 +210,9 @@ pgen_partial_inc_dec1(Rtmod,Erules,Module,[P|Ps]) -> asn1ct:update_gen_state(prefix,"dec-inc-"), case asn1ct:maybe_saved_sindex(TopTypeName,P) of I when is_integer(I),I > 0 -> -% io:format("Index:~p~n",[I]), asn1ct:set_current_sindex(I); _I -> asn1ct:set_current_sindex(0), -% io:format("Index=~p~n",[_I]), ok end, Rtmod:gen_decode(Erules,TypeDef), @@ -250,8 +243,8 @@ gen_partial_inc_dec_refed_funcs(Rtmod, #gen{erule=ber}=Gen) -> pgen_partial_dec(_Rtmod,Erules,_Module) -> Type_pattern = asn1ct:get_gen_state_field(type_pattern), -% io:format("Type_pattern: ~w~n",[Type_pattern]), - %% Get the typedef of the top type and follow into the choosen components until the last type/component. + %% Get the typedef of the top type and follow into the choosen + %% components until the last type/component. pgen_partial_types(Erules,Type_pattern), ok. @@ -266,7 +259,6 @@ pgen_partial_types(#gen{options=Options}=Gen, TypePattern) -> pgen_partial_types1(Erules,[{FuncName,[TopType|RestTypes]}|Rest]) -> -% emit([FuncName,"(Bytes) ->",nl]), CurrMod = get(currmod), TypeDef = asn1_db:dbget(CurrMod,TopType), traverse_type_structure(Erules,TypeDef,RestTypes,FuncName, @@ -291,8 +283,9 @@ traverse_type_structure(Erules,Type,[],FuncName,TopTypeName) -> end, Ctmod:gen_decode_selected(Erules,TypeDef,FuncName); % what if Type is #type{} traverse_type_structure(Erules,#type{def=Def},[[N]],FuncName,TopTypeName) - when is_integer(N) -> % this case a decode of one of the elements in - % the SEQUENCE OF is required. + when is_integer(N) -> + %% In this case a decode of one of the elements in the SEQUENCE OF is + %% required. InnerType = asn1ct_gen:get_inner(Def), case InnerType of 'SEQUENCE OF' -> @@ -368,8 +361,9 @@ traverse_type_structure(Erules,#typedef{typespec=Def},[T|Ts],FuncName, TypeDef = asn1_db:dbget(M,TName), traverse_type_structure(Erules,TypeDef,[T|Ts],FuncName, [TypeDef#typedef.name]); - _ -> %this may be a referenced type that shall be traversed or - %the selected type + _ -> + %% This may be a referenced type that shall be traversed + %% or the selected type traverse_type_structure(Erules,Def,Ts,FuncName,[T|TopTypeName]) end. @@ -384,9 +378,7 @@ get_component(Name,{C1,C2}) when is_list(C1),is_list(C2) -> get_component(Name,[C=#'ComponentType'{name=Name}|_Cs]) -> C; get_component(Name,[_C|Cs]) -> - get_component(Name,Cs); -get_component(Name,_) -> - throw({error,{asn1,{internal_error,Name}}}). + get_component(Name,Cs). %% generate code for all inner types that are called from the top type %% of the partial incomplete decode and are defined within the top @@ -451,7 +443,6 @@ pgen_partial_incomplete_decode1(#gen{erule=ber}) -> lists:foreach(fun emit_partial_incomplete_decode/1,Data) end, GeneratedFs= asn1ct:get_gen_state_field(gen_refed_funcs), -% io:format("GeneratedFs :~n~p~n",[GeneratedFs]), gen_part_decode_funcs(GeneratedFs,0); pgen_partial_incomplete_decode1(#gen{}) -> ok. @@ -604,9 +595,7 @@ gen_encode_constructed(Erules,Typename,InnerType,D) when is_record(D,type) -> Rtmod:gen_encode_sof(Erules,Typename,InnerType,D), {_,Type} = D#type.def, NameSuffix = asn1ct_gen:constructed_suffix(InnerType,Type#type.def), - gen_types(Erules, [NameSuffix|Typename], Type, gen_encode); - _ -> - exit({nyi,InnerType}) + gen_types(Erules, [NameSuffix|Typename], Type, gen_encode) end; gen_encode_constructed(Erules,Typename,InnerType,D) when is_record(D,typedef) -> @@ -879,7 +868,6 @@ gen_partial_inc_dispatcher(#gen{erule=ber}) -> {_,undefined} -> ok; {Data1,Data2} -> -% io:format("partial_incomplete_decode: ~p~ninc_type_pattern: ~p~n",[Data,Data2]), gen_partial_inc_dispatcher(Data1, Data2, "") end; gen_partial_inc_dispatcher(#gen{}) -> @@ -954,71 +942,39 @@ hrl_protector(OutFile) -> end || C <- P]. -%% EMIT functions ************************ -%% *************************************** - - % debug generation -demit(Term) -> - case get(asndebug) of - true -> emit(Term); - _ ->true - end. - - % always generation emit(Term) -> ok = file:write(get(gen_file_out), do_emit(Term)). -do_emit({external,_M,T}) -> - do_emit(T); - do_emit({prev,Variable}) when is_atom(Variable) -> do_emit({var,asn1ct_name:prev(Variable)}); - do_emit({next,Variable}) when is_atom(Variable) -> do_emit({var,asn1ct_name:next(Variable)}); - do_emit({curr,Variable}) when is_atom(Variable) -> do_emit({var,asn1ct_name:curr(Variable)}); - do_emit({var,Variable}) when is_atom(Variable) -> [Head|V] = atom_to_list(Variable), [Head-32|V]; - -do_emit({var,Variable}) -> - [Head|V] = Variable, - [Head-32|V]; - do_emit({asis,What}) -> io_lib:format("~w", [What]); - do_emit({call,M,F,A}) -> MFA = {M,F,length(A)}, asn1ct_func:need(MFA), [atom_to_list(F),"(",call_args(A, "")|")"]; - do_emit(nl) -> "\n"; - do_emit(com) -> ","; - -do_emit(tab) -> - " "; - +do_emit([C|_]=Str) when is_integer(C) -> + Str; +do_emit([_|_]=L) -> + [do_emit(E) || E <- L]; +do_emit([]) -> + []; do_emit(What) when is_integer(What) -> integer_to_list(What); - -do_emit(What) when is_list(What), is_integer(hd(What)) -> - What; - do_emit(What) when is_atom(What) -> - atom_to_list(What); + atom_to_list(What). -do_emit(What) when is_tuple(What) -> - [do_emit(E) || E <- tuple_to_list(What)]; - -do_emit(What) when is_list(What) -> - [do_emit(E) || E <- What]. call_args([A|As], Sep) -> [Sep,do_emit(A)|call_args(As, ", ")]; @@ -1124,8 +1080,6 @@ gen_record(Gen, TorPtype, Name, #type{}=Type, Num) -> case Seq#'SEQUENCE'.pname of false -> {record,Seq#'SEQUENCE'.components}; -%% _Pname when TorPtype == type -> -%% false; _ -> {record,Seq#'SEQUENCE'.components} end; @@ -1138,8 +1092,6 @@ gen_record(Gen, TorPtype, Name, #type{}=Type, Num) -> _ -> {record,to_textual_order(Set#'SET'.components)} end; -% {'SET',{_,_CompList}} -> -% {record,_CompList}; {'CHOICE',_CompList} -> {inner,Def}; {'SEQUENCE OF',_CompList} -> {['SEQOF'|Name],Def}; {'SET OF',_CompList} -> {['SETOF'|Name],Def}; @@ -1345,7 +1297,6 @@ get_inner({fixedtypevaluefield,_,Type}) -> get_inner({typefield,TypeName}) -> TypeName; get_inner(#'ObjectClassFieldType'{type=Type}) -> -% get_inner(Type); Type; get_inner(T) when is_tuple(T) -> case element(1,T) of @@ -1354,9 +1305,7 @@ get_inner(T) when is_tuple(T) -> {valuefieldreference,FieldName} -> get_fieldtype(element(2,Tuple),FieldName); {typefieldreference,FieldName} -> - get_fieldtype(element(2,Tuple),FieldName); - {'EXIT',Reason} -> - throw({asn1,{'internal error in get_inner/1',Reason}}) + get_fieldtype(element(2,Tuple),FieldName) end; _ -> element(1,T) end. diff --git a/lib/asn1/src/asn1ct_gen_ber_bin_v2.erl b/lib/asn1/src/asn1ct_gen_ber_bin_v2.erl index 6c6d4193f3..948566a6fc 100644 --- a/lib/asn1/src/asn1ct_gen_ber_bin_v2.erl +++ b/lib/asn1/src/asn1ct_gen_ber_bin_v2.erl @@ -35,21 +35,21 @@ -export([extaddgroup2sequence/1]). -export([dialyzer_suppressions/1]). --import(asn1ct_gen, [emit/1,demit/1]). +-import(asn1ct_gen, [emit/1]). - % the encoding of class of tag bits 8 and 7 +%% The encoding of class of tag bits 8 and 7 -define(UNIVERSAL, 0). -define(APPLICATION, 16#40). -define(CONTEXT, 16#80). -define(PRIVATE, 16#C0). - % primitive or constructed encoding % bit 6 +%% Primitive or constructed encoding % bit 6 -define(PRIMITIVE, 0). -define(CONSTRUCTED, 2#00100000). -define(T_ObjectDescriptor, ?UNIVERSAL bor ?PRIMITIVE bor 7). - % restricted character string types +%% Restricted character string types -define(T_NumericString, ?UNIVERSAL bor ?PRIMITIVE bor 18). %can be constructed -define(T_PrintableString, ?UNIVERSAL bor ?PRIMITIVE bor 19). %can be constructed -define(T_TeletexString, ?UNIVERSAL bor ?PRIMITIVE bor 20). %can be constructed @@ -107,20 +107,12 @@ gen_encode(Erules,Typename,Type) when is_record(Type,type) -> case asn1ct_gen:type(InnerType) of {constructed,bif} -> - emit([nl,nl,nl,"%%================================"]), - emit([nl,"%% ",asn1ct_gen:list2name(Typename)]), - emit([nl,"%%================================",nl]), - case length(Typename) of - 1 -> % top level type - emit(["'enc_",asn1ct_gen:list2name(Typename), - "'(Val",ObjFun,") ->",nl]), - emit([" 'enc_",asn1ct_gen:list2name(Typename), - "'(Val, ", {asis,lists:reverse(Type#type.tag)},ObjFun,").",nl,nl]); - _ -> % embedded type with constructed name - true - end, - emit(["'enc_",asn1ct_gen:list2name(Typename), - "'(Val, TagIn",ObjFun,") ->",nl," "]), + Func = {asis,enc_func(asn1ct_gen:list2name(Typename))}, + emit([nl,nl,nl,"%%================================",nl, + "%% ",asn1ct_gen:list2name(Typename),nl, + "%%================================",nl, + Func,"(Val, TagIn",ObjFun,") ->",nl, + " "]), asn1ct_gen:gen_encode_constructed(Erules,Typename,InnerType,Type); _ -> true @@ -146,7 +138,7 @@ gen_encode_user(Erules, #typedef{}=D, Wrapper) -> emit([nl,nl,"%%================================"]), emit([nl,"%% ",Typename]), emit([nl,"%%================================",nl]), - FuncName = "'enc_" ++ asn1ct_gen:list2name(Typename) ++ "'", + FuncName = {asis,enc_func(asn1ct_gen:list2name(Typename))}, case Wrapper of true -> %% This is a top-level type. Generate an 'enc_Type'/1 @@ -169,9 +161,10 @@ gen_encode_user(Erules, #typedef{}=D, Wrapper) -> gen_encode_prim(ber,Type,"TagIn","Val"), emit([".",nl]); #'Externaltypereference'{module=CurrentMod,type=Etype} -> - emit([" 'enc_",Etype,"'(Val, TagIn).",nl]); + emit([" ",{asis,enc_func(Etype)},"(Val, TagIn).",nl]); #'Externaltypereference'{module=Emod,type=Etype} -> - emit([" '",Emod,"':'enc_",Etype,"'(Val, TagIn).",nl]); + emit([" ",{asis,Emod},":",{asis,enc_func(Etype)}, + "(Val, TagIn).",nl]); 'ASN1_OPEN_TYPE' -> emit(["%% OPEN TYPE",nl]), gen_encode_prim(ber, @@ -326,40 +319,39 @@ gen_decode(Erules,Type) when is_record(Type,typedef) -> Tag = [(decode_class(X#tag.class) bsl 10) + X#tag.number || X <- InnerTag], - FunctionName = + FuncName0 = case {asn1ct:get_gen_state_field(active), asn1ct:get_gen_state_field(prefix)} of {true,Pref} -> %% prevent duplicated function definitions -% Pattern = asn1ct:get_gen_state_field(namelist), -% FuncName=asn1ct:maybe_rename_function(Type#typedef.name, -% Pattern), case asn1ct:current_sindex() of - I when is_integer(I),I>0 -> - lists:concat([Pref,Type#typedef.name,"_",I]); + I when is_integer(I), I > 0 -> + [Pref,Type#typedef.name,"_",I]; _-> - lists:concat([Pref,Type#typedef.name]) - end; % maybe the current_sindex must be reset - _ -> lists:concat(["dec_",Type#typedef.name]) + [Pref,Type#typedef.name] + end; + {_,_} -> + ["dec_",Type#typedef.name] end, - emit({nl,nl}), - emit(["'",FunctionName,"'(Tlv) ->",nl]), - emit([" '",FunctionName,"'(Tlv, ",{asis,Tag},").",nl,nl]), - emit(["'",FunctionName,"'(Tlv, TagIn) ->",nl]), - dbdec(Type#typedef.name,"Tlv"), + FuncName = {asis,list_to_atom(lists:concat(FuncName0))}, + emit([nl,nl, + FuncName,"(Tlv) ->",nl, + " ",FuncName,"(Tlv, ",{asis,Tag},").",nl,nl, + FuncName,"(Tlv, TagIn) ->",nl]), gen_decode_user(Erules,Type). gen_inc_decode(Erules,Type) when is_record(Type,typedef) -> Prefix = asn1ct:get_gen_state_field(prefix), Suffix = asn1ct_gen:index2suffix(asn1ct:current_sindex()), - emit({nl,nl}), - emit(["'",Prefix,Type#typedef.name,Suffix,"'(Tlv, TagIn) ->",nl]), + FuncName0 = [Prefix,Type#typedef.name,Suffix], + FuncName = {asis,list_to_atom(lists:concat(FuncName0))}, + emit([nl,nl, + FuncName,"(Tlv, TagIn) ->",nl]), gen_decode_user(Erules,Type). %% gen_decode_selected exported function for selected decode gen_decode_selected(Erules,Type,FuncName) -> emit([FuncName,"(Bin) ->",nl]), -% Pattern = asn1ct:get_gen_state_field(tag_pattern), Patterns = asn1ct:read_config_data(partial_decode), Pattern = case lists:keysearch(FuncName,1,Patterns) of @@ -398,12 +390,10 @@ gen_decode_selected_type(_Erules,TypeDef) -> asn1ct_gen:list2name(TopType),"'"]), emit([DecFunName,"(",BytesVar, ", ",{asis,Tag},")"]); -% emit([";",nl]); TheType -> DecFunName = mkfuncname(TheType,dec), emit([DecFunName,"(",BytesVar, ", ",{asis,Tag},")"]) -% emit([";",nl]) end. %%=============================================================================== @@ -418,7 +408,6 @@ gen_decode(Erules,Typename,Type) when is_record(Type,type) -> FunctionName = case asn1ct:get_gen_state_field(active) of true -> -% Suffix = asn1ct_gen:index2suffix(SIndex), Pattern = asn1ct:get_gen_state_field(namelist), Suffix = case asn1ct:maybe_saved_sindex(Typename,Pattern) of @@ -431,8 +420,6 @@ gen_decode(Erules,Typename,Type) when is_record(Type,type) -> _ -> lists:concat(["'dec_",asn1ct_gen:list2name(Typename)]) end, -% io:format("Typename: ~p,~n",[Typename]), -% io:format("FunctionName: ~p~n",[FunctionName]), case asn1ct_gen:type(InnerType) of {constructed,bif} -> ObjFun = @@ -442,9 +429,7 @@ gen_decode(Erules,Typename,Type) when is_record(Type,type) -> _ -> "" end, -% emit([Prefix,asn1ct_gen:list2name(Typename),"'(Tlv, TagIn",ObjFun,") ->",nl]), emit([FunctionName,"'(Tlv, TagIn",ObjFun,") ->",nl]), - dbdec(Typename,"Tlv"), asn1ct_gen:gen_decode_constructed(Erules,Typename,InnerType,Type); Rec when is_record(Rec,'Externaltypereference') -> case {Typename,asn1ct:get_gen_state_field(namelist)} of @@ -476,10 +461,10 @@ gen_decode(Erules,Typename,Type) when is_record(Type,type) -> gen_decode(Erules,Tname,#'ComponentType'{name=Cname,typespec=Type}) -> NewTname = [Cname|Tname], - %% The tag is set to [] to avoid that it is - %% taken into account twice, both as a component/alternative (passed as - %% argument to the encode decode function and within the encode decode - %% function it self. + %% The tag is set to [] to avoid that it is taken into account + %% twice, both as a component/alternative (passed as argument to + %% the encode/decode function), and within the encode decode + %% function itself. NewType = Type#type{tag=[]}, case {asn1ct:get_gen_state_field(active), asn1ct:get_tobe_refed_func(NewTname)} of @@ -504,7 +489,7 @@ gen_decode_user(Erules,D) when is_record(D,typedef) -> asn1ct_name:new(len), gen_dec_prim(Def#type{def='ASN1_OPEN_TYPE'}, BytesVar, {string,"TagIn"}), - emit({".",nl,nl}); + emit([".",nl,nl]); {primitive,bif} -> asn1ct_name:new(len), gen_dec_prim(Def, BytesVar, {string,"TagIn"}), @@ -515,8 +500,7 @@ gen_decode_user(Erules,D) when is_record(D,typedef) -> TheType -> DecFunName = mkfuncname(TheType,dec), emit([DecFunName,"(",BytesVar, - ", TagIn)"]), - emit([".",nl,nl]) + ", TagIn).",nl,nl]) end. @@ -746,9 +730,10 @@ gen_obj_code(Erules,_Module,Obj) when is_record(Obj,typedef) -> #'Externaltypereference'{module=M,type=ClName} = Def#'Object'.classname, Class = asn1_db:dbget(M,ClName), {object,_,Fields} = Def#'Object'.def, - emit({nl,nl,nl,"%%================================"}), - emit({nl,"%% ",ObjName}), - emit({nl,"%%================================",nl}), + emit([nl,nl,nl, + "%%================================",nl, + "%% ",ObjName,nl, + "%%================================",nl]), EncConstructed = gen_encode_objectfields(ClName,get_class_fields(Class), ObjName,Fields,[]), @@ -766,11 +751,9 @@ gen_encode_objectfields(ClassName,[{typefield,Name,OptOrMand}|Rest], ObjName,ObjectFields,ConstrAcc) -> EmitFuncClause = fun(Arg) -> - emit(["'enc_",ObjName,"'(",{asis,Name}, - ", ",Arg,", _RestPrimFieldName) ->",nl]) + emit([{asis,enc_func(ObjName)},"(",{asis,Name}, + ", ",Arg,", _RestPrimFieldName) ->",nl]) end, -% emit(["'enc_",ObjName,"'(",{asis,Name}, -% ", Val, RestPrimFieldName) ->",nl]), MaybeConstr= case {get_object_field(Name,ObjectFields),OptOrMand} of {false,'OPTIONAL'} -> @@ -799,11 +782,9 @@ gen_encode_objectfields(ClassName,[{objectfield,Name,_,_,OptOrMand}|Rest], CurrentMod = get(currmod), EmitFuncClause = fun(Args) -> - emit(["'enc_",ObjName,"'(",{asis,Name}, + emit([{asis,enc_func(ObjName)},"(",{asis,Name}, ", ",Args,") ->",nl]) end, -% emit(["'enc_",ObjName,"'(",{asis,Name}, -% ", Val,[H|T]) ->",nl]), case {get_object_field(Name,ObjectFields),OptOrMand} of {false,'OPTIONAL'} -> EmitFuncClause("_,_"), @@ -814,19 +795,14 @@ gen_encode_objectfields(ClassName,[{objectfield,Name,_,_,OptOrMand}|Rest], {{Name,#'Externalvaluereference'{module=CurrentMod, value=TypeName}},_} -> EmitFuncClause(" Val, [H|T]"), - emit({indent(3),"'enc_",TypeName,"'(H, Val, T)"}); + emit([indent(3),{asis,enc_func(TypeName)},"(H, Val, T)"]); {{Name,#'Externalvaluereference'{module=M,value=TypeName}},_} -> EmitFuncClause(" Val, [H|T]"), - emit({indent(3),"'",M,"':'enc_",TypeName,"'(H, Val, T)"}); - {{Name,TypeSpec},_} -> + emit([indent(3),{asis,M},":",{asis,enc_func(TypeName)}, + "(H, Val, T)"]); + {{Name,#typedef{name=TypeName}},_} when is_atom(TypeName) -> EmitFuncClause(" Val, [H|T]"), - case TypeSpec#typedef.name of - {ExtMod,TypeName} -> - emit({indent(3),"'",ExtMod,"':'enc_",TypeName, - "'(H, Val, T)"}); - TypeName -> - emit({indent(3),"'enc_",TypeName,"'(H, Val, T)"}) - end + emit([indent(3),{asis,enc_func(TypeName)},"(H, Val, T)"]) end, case more_genfields(Rest) of true -> @@ -862,10 +838,11 @@ gen_encode_field_call(_ObjName,_FieldName, X <- OTag], if M == CurrentMod -> - emit({" 'enc_",T,"'(Val, ",{asis,Tag},")"}), + emit([" ",{asis,enc_func(T)},"(Val, ",{asis,Tag},")"]), []; true -> - emit({" '",M,"':'enc_",T,"'(Val, ",{asis,Tag},")"}), + emit([" ",{asis,M},":",{asis,enc_func(T)}, + "(Val, ",{asis,Tag},")"]), [] end; gen_encode_field_call(ObjName,FieldName,Type) -> @@ -875,24 +852,21 @@ gen_encode_field_call(ObjName,FieldName,Type) -> X#tag.form,X#tag.number)|| X <- OTag], case Type#typedef.name of - {primitive,bif} -> %%tag should be the primitive tag -% OTag = Def#type.tag, -% Tag = [encode_tag_val(decode_class(X#tag.class), -% X#tag.form,X#tag.number)|| -% X <- OTag], + {primitive,bif} -> %tag should be the primitive tag gen_encode_prim(ber,Def,{asis,lists:reverse(Tag)}, "Val"), []; {constructed,bif} -> - emit({" 'enc_",ObjName,'_',FieldName, - "'(Val,",{asis,Tag},")"}), - [Type#typedef{name=list_to_atom(lists:concat([ObjName,'_',FieldName]))}]; + Name = lists:concat([ObjName,'_',FieldName]), + emit([" ",{asis,enc_func(Name)},"(Val,",{asis,Tag},")"]), + [Type#typedef{name=list_to_atom(Name)}]; {ExtMod,TypeName} -> - emit({" '",ExtMod,"':'enc_",TypeName, - "'(Val,",{asis,Tag},")"}), + emit([" ",{asis,ExtMod},":",{asis,enc_func(TypeName)}, + "(Val,",{asis,Tag},")"]), []; TypeName -> - emit({" 'enc_",TypeName,"'(Val,",{asis,Tag},")"}), + emit([" ",{asis,enc_func(TypeName)}, + "(Val,",{asis,Tag},")"]), [] end. @@ -903,10 +877,10 @@ gen_encode_default_call(ClassName,FieldName,Type) -> Tag = [encode_tag_val(decode_class(X#tag.class),X#tag.form,X#tag.number)|| X <- OTag], case asn1ct_gen:type(InnerType) of {constructed,bif} -> - emit([" 'enc_",ClassName,'_',FieldName,"'", + Name = lists:concat([ClassName,'_',FieldName]), + emit([" ",{asis,enc_func(Name)}, "(Val, ",{asis,Tag},")"]), - [#typedef{name=list_to_atom(lists:concat([ClassName,'_',FieldName])), - typespec=Type}]; + [#typedef{name=list_to_atom(Name),typespec=Type}]; {primitive,bif} -> gen_encode_prim(ber,Type,{asis,lists:reverse(Tag)},"Val"), []; @@ -916,12 +890,6 @@ gen_encode_default_call(ClassName,FieldName,Type) -> #'Externaltypereference'{module=Emod,type=Etype} -> emit([" '",Emod,"':'enc_",Etype,"'(Val, ",{asis,Tag},")",nl]), [] -% 'ASN1_OPEN_TYPE' -> -% emit(["%% OPEN TYPE",nl]), -% gen_encode_prim(ber, -% Type#type{def='ASN1_OPEN_TYPE'}, -% "TagIn","Val"), -% emit([".",nl]) end. %%%%%%%%%%%%%%%% @@ -930,11 +898,9 @@ gen_decode_objectfields(ClassName,[{typefield,Name,OptOrMand}|Rest], ObjName,ObjectFields,ConstrAcc) -> EmitFuncClause = fun(Arg) -> - emit(["'dec_",ObjName,"'(",{asis,Name}, + emit([{asis,dec_func(ObjName)},"(",{asis,Name}, ", ",Arg,",_) ->",nl]) end, -% emit(["'dec_",ObjName,"'(",{asis,Name}, -% ", Bytes, RestPrimFieldName) ->",nl]), MaybeConstr= case {get_object_field(Name,ObjectFields),OptOrMand} of {false,'OPTIONAL'} -> @@ -964,12 +930,9 @@ gen_decode_objectfields(ClassName,[{objectfield,Name,_,_,OptOrMand}|Rest], CurrentMod = get(currmod), EmitFuncClause = fun(Args) -> - emit(["'dec_",ObjName,"'(",{asis,Name}, + emit([{asis,dec_func(ObjName)},"(",{asis,Name}, ", ",Args,") ->",nl]) end, -% emit(["'dec_",ObjName,"'(",{asis,Name}, -% ", Bytes,[H|T]) ->",nl]), -% emit_tlv_format("Bytes"), case {get_object_field(Name,ObjectFields),OptOrMand} of {false,'OPTIONAL'} -> EmitFuncClause("_,_"), @@ -980,21 +943,14 @@ gen_decode_objectfields(ClassName,[{objectfield,Name,_,_,OptOrMand}|Rest], {{Name,#'Externalvaluereference'{module=CurrentMod, value=TypeName}},_} -> EmitFuncClause("Bytes,[H|T]"), - emit({indent(3),"'dec_",TypeName,"'(H, Bytes, T)"}); + emit([indent(3),{asis,dec_func(TypeName)},"(H, Bytes, T)"]); {{Name,#'Externalvaluereference'{module=M,value=TypeName}},_} -> EmitFuncClause("Bytes,[H|T]"), - emit({indent(3),"'",M,"':'dec_",TypeName, - "'(H, Bytes, T)"}); - {{Name,TypeSpec},_} -> - EmitFuncClause("Bytes,[H|T]"), -% emit_tlv_format("Bytes"), - case TypeSpec#typedef.name of - {ExtMod,TypeName} -> - emit({indent(3),"'",ExtMod,"':'dec_",TypeName, - "'(H, Bytes, T)"}); - TypeName -> - emit({indent(3),"'dec_",TypeName,"'(H, Bytes, T)"}) - end + emit([indent(3),{asis,M},":",{asis,dec_func(TypeName)}, + "(H, Bytes, T)"]); + {{Name,#typedef{name=TypeName}},_} when is_atom(TypeName) -> + EmitFuncClause("Bytes,[H|T]"), + emit([indent(3),{asis,dec_func(TypeName)},"(H, Bytes, T)"]) end, case more_genfields(Rest) of true -> @@ -1014,24 +970,20 @@ emit_tlv_format(Bytes) -> notice_tlv_format_gen() -> Module = get(currmod), -% io:format("Noticed: ~p~n",[Module]), case get(tlv_format) of {done,Module} -> ok; - _ -> % true or undefined + _ -> % true or undefined put(tlv_format,true) end. emit_tlv_format_function() -> Module = get(currmod), -% io:format("Tlv formated: ~p",[Module]), case get(tlv_format) of true -> -% io:format(" YES!~n"), emit_tlv_format_function1(), put(tlv_format,{done,Module}); _ -> -% io:format(" NO!~n"), ok end. emit_tlv_format_function1() -> @@ -1066,12 +1018,12 @@ gen_decode_field_call(_ObjName,_FieldName,Bytes, X <- OTag], if M == CurrentMod -> - emit({" 'dec_",T,"'(",Bytes, - ", ",{asis,Tag},")"}), + emit([" ",{asis,dec_func(T)},"(",Bytes, + ", ",{asis,Tag},")"]), []; true -> - emit({" '",M,"':'dec_",T, - "'(",Bytes,", ",{asis,Tag},")"}), + emit([" ",{asis,M},":",{asis,dec_func(T)}, + "(",Bytes,", ",{asis,Tag},")"]), [] end; gen_decode_field_call(ObjName,FieldName,Bytes,Type) -> @@ -1084,15 +1036,17 @@ gen_decode_field_call(ObjName,FieldName,Bytes,Type) -> gen_dec_prim(Def, Bytes, Tag), []; {constructed,bif} -> - emit({" 'dec_",ObjName,'_',FieldName, - "'(",Bytes,",",{asis,Tag},")"}), - [Type#typedef{name=list_to_atom(lists:concat([ObjName,'_',FieldName]))}]; + Name = lists:concat([ObjName,"_",FieldName]), + emit([" ",{asis,dec_func(Name)}, + "(",Bytes,",",{asis,Tag},")"]), + [Type#typedef{name=list_to_atom(Name)}]; {ExtMod,TypeName} -> - emit({" '",ExtMod,"':'dec_",TypeName, - "'(",Bytes,",",{asis,Tag},")"}), + emit([" ",{asis,ExtMod},":",{asis,dec_func(TypeName)}, + "(",Bytes,",",{asis,Tag},")"]), []; TypeName -> - emit({" 'dec_",TypeName,"'(",Bytes,",",{asis,Tag},")"}), + emit([" ",{asis,dec_func(TypeName)}, + "(",Bytes,",",{asis,Tag},")"]), [] end. @@ -1118,12 +1072,6 @@ gen_decode_default_call(ClassName,FieldName,Bytes,Type) -> emit([" '",Emod,"':'dec_",Etype,"'(",Bytes,", ", {asis,Tag},")",nl]), [] -% 'ASN1_OPEN_TYPE' -> -% emit(["%% OPEN TYPE",nl]), -% gen_encode_prim(ber, -% Type#type{def='ASN1_OPEN_TYPE'}, -% "TagIn","Val"), -% emit([".",nl]) end. %%%%%%%%%%% @@ -1162,15 +1110,15 @@ more_genfields([Field|Fields]) -> gen_objectset_code(Erules,ObjSet) -> ObjSetName = ObjSet#typedef.name, Def = ObjSet#typedef.typespec, -% {ClassName,ClassDef} = Def#'ObjectSet'.class, #'Externaltypereference'{module=ClassModule, type=ClassName} = Def#'ObjectSet'.class, ClassDef = asn1_db:dbget(ClassModule,ClassName), UniqueFName = Def#'ObjectSet'.uniquefname, Set = Def#'ObjectSet'.set, - emit({nl,nl,nl,"%%================================"}), - emit({nl,"%% ",ObjSetName}), - emit({nl,"%%================================",nl}), + emit([nl,nl,nl, + "%%================================",nl, + "%% ",ObjSetName,nl, + "%%================================",nl]), case ClassName of {_Module,ExtClassName} -> gen_objset_code(Erules,ObjSetName,UniqueFName,Set,ExtClassName,ClassDef); @@ -1200,19 +1148,20 @@ gen_objset_enc(Erules, ObjSetName, UniqueName, {no_mod,no_name} -> gen_inlined_enc_funs(Fields, ClFields, ObjSetName, Val, NthObj); {CurrMod,Name} -> - emit(["'getenc_",ObjSetName,"'(Id) when Id =:= ", - {asis,Val}," ->",nl, - " fun 'enc_",Name,"'/3;",nl]), + emit([asis_atom(["getenc_",ObjSetName]), + "(Id) when Id =:= ",{asis,Val}," ->",nl, + " fun ",asis_atom(["enc_",Name]),"/3;",nl]), {[],NthObj}; {ModuleName,Name} -> - emit(["'getenc_",ObjSetName,"'(Id) when Id =:= ", - {asis,Val}," ->",nl]), + emit([asis_atom(["getenc_",ObjSetName]), + "(Id) when Id =:= ",{asis,Val}," ->",nl]), emit_ext_fun(enc,ModuleName,Name), emit([";",nl]), {[],NthObj}; _ -> - emit(["'getenc_",ObjSetName,"'(",{asis,Val},") ->",nl, - " fun 'enc_",ObjName,"'/3;",nl]), + emit([asis_atom(["getenc_",ObjSetName]), + "(",{asis,Val},") ->",nl, + " fun ",asis_atom(["enc_",ObjName]),"/3;",nl]), {[],NthObj} end, gen_objset_enc(Erules, ObjSetName, UniqueName, T, ClName, ClFields, @@ -1220,7 +1169,7 @@ gen_objset_enc(Erules, ObjSetName, UniqueName, %% See X.681 Annex E for the following case gen_objset_enc(_,ObjSetName,_UniqueName,['EXTENSIONMARK'],_ClName, _ClFields,_NthObj,Acc) -> - emit(["'getenc_",ObjSetName,"'(_) ->",nl, + emit([asis_atom(["getenc_",ObjSetName]),"(_) ->",nl, indent(2),"fun(_, Val, _RestPrimFieldName) ->",nl]), emit_enc_open_type(4), emit([nl, @@ -1228,7 +1177,7 @@ gen_objset_enc(_,ObjSetName,_UniqueName,['EXTENSIONMARK'],_ClName, Acc; gen_objset_enc(_, ObjSetName, UniqueName, [], _, _, _, Acc) -> emit_default_getenc(ObjSetName, UniqueName), - emit({".",nl,nl}), + emit([".",nl,nl]), Acc. emit_ext_fun(EncDec,ModuleName,Name) -> @@ -1236,14 +1185,15 @@ emit_ext_fun(EncDec,ModuleName,Name) -> Name,"'(T,V,O) end"]). emit_default_getenc(ObjSetName,UniqueName) -> - emit(["'getenc_",ObjSetName,"'(ErrV) ->",nl]), - emit([indent(3),"fun(C,V,_) -> exit({'Type not compatible with table constraint',{component,C},{value,V}, {unique_name_and_value,",{asis,UniqueName},", ErrV}}) end"]). + emit([asis_atom(["getenc_",ObjSetName]),"(ErrV) ->",nl, + indent(3),"fun(C,V,_) ->",nl, + "exit({'Type not compatible with table constraint',{component,C},{value,V}, {unique_name_and_value,",{asis,UniqueName},", ErrV}}) end"]). %% gen_inlined_enc_funs for each object iterates over all fields of a %% class, and for each typefield it checks if the object has that %% field and emits the proper code. gen_inlined_enc_funs(Fields, [{typefield,_,_}|_]=T, ObjSetName, Val, NthObj) -> - emit(["'getenc_",ObjSetName,"'(",{asis,Val},") ->",nl, + emit([asis_atom(["getenc_",ObjSetName]),"(",{asis,Val},") ->",nl, indent(3),"fun(Type, Val, _RestPrimFieldName) ->",nl, indent(6),"case Type of",nl]), gen_inlined_enc_funs1(Fields, T, ObjSetName, [], NthObj, []); @@ -1283,8 +1233,8 @@ gen_inlined_enc_funs1(Fields, [{typefield,Name,_}|Rest], ObjSetName, end, {Acc0,0}; false -> - %% This field was not present in the object thus there - %% were no type in the table and we therefore generate + %% This field was not present in the object; thus, there + %% was no type in the table and we therefore generate %% code that returns the input for application %% treatment. emit([indent(9),{asis,Name}," ->",nl]), @@ -1322,7 +1272,6 @@ emit_inner_of_fun(TDef=#typedef{name={ExtMod,Name},typespec=Type}, InternalDefFunName) -> OTag = Type#type.tag, Tag = [encode_tag_val(decode_class(X#tag.class),X#tag.form,X#tag.number)|| X <- OTag], -% remove Tag = [X#tag{class=decode_class(X#tag.class)}|| X <- OTag], case {ExtMod,Name} of {primitive,bif} -> emit(indent(12)), @@ -1333,20 +1282,14 @@ emit_inner_of_fun(TDef=#typedef{name={ExtMod,Name},typespec=Type}, InternalDefFunName,"'(Val, ",{asis,Tag},")"]), {[TDef#typedef{name=InternalDefFunName}],1}; _ -> - emit({indent(12),"'",ExtMod,"':'enc_",Name,"'(Val",{asis,Tag},")"}), + emit([indent(12),"'",ExtMod,"':'enc_",Name,"'(Val",{asis,Tag},")"]), {[],0} end; emit_inner_of_fun(#typedef{name=Name},_) -> -% OTag = Type#type.tag, -% remove Tag = [X#tag{class=decode_class(X#tag.class)}|| X <- OTag], -% Tag = [encode_tag_val(decode_class(X#tag.class),X#tag.form,X#tag.number)|| X <- OTag], - emit({indent(12),"'enc_",Name,"'(Val)"}), + emit([indent(12),"'enc_",Name,"'(Val)"]), {[],0}; emit_inner_of_fun(Type,_) when is_record(Type,type) -> CurrMod = get(currmod), -% OTag = Type#type.tag, -% remove Tag = [X#tag{class=decode_class(X#tag.class)}|| X <- OTag], -% Tag = [encode_tag_val(decode_class(X#tag.class),X#tag.form,X#tag.number)|| X <- OTag], case Type#type.def of Def when is_atom(Def) -> OTag = Type#type.tag, @@ -1384,18 +1327,19 @@ gen_objset_dec(Erules, ObjSName, UniqueName, [{ObjName,Val,Fields}|T], {no_mod,no_name} -> gen_inlined_dec_funs(Fields,ClFields,ObjSName,Val,NthObj); {CurrMod,Name} -> - emit(["'getdec_",ObjSName,"'(Id) when Id =:= ", - {asis,Val}," ->",nl, + emit([asis_atom(["getdec_",ObjSName]), + "(Id) when Id =:= ",{asis,Val}," ->",nl, " fun 'dec_",Name,"'/3;", nl]), NthObj; {ModuleName,Name} -> - emit(["'getdec_",ObjSName,"'(Id) when Id =:= ", - {asis,Val}," ->",nl]), + emit([asis_atom(["getdec_",ObjSName]), + "(Id) when Id =:= ",{asis,Val}," ->",nl]), emit_ext_fun(dec,ModuleName,Name), emit([";",nl]), NthObj; _ -> - emit(["'getdec_",ObjSName,"'(",{asis,Val},") ->",nl, + emit([asis_atom(["getdec_",ObjSName]), + "(",{asis,Val},") ->",nl, " fun 'dec_",ObjName,"'/3;", nl]), NthObj end, @@ -1403,8 +1347,8 @@ gen_objset_dec(Erules, ObjSName, UniqueName, [{ObjName,Val,Fields}|T], ClFields, NewNthObj); gen_objset_dec(_,ObjSetName,_UniqueName,['EXTENSIONMARK'],_ClName, _ClFields,_NthObj) -> - emit(["'getdec_",ObjSetName,"'(_) ->",nl]), - emit([indent(2),"fun(_,Bytes, _RestPrimFieldName) ->",nl]), + emit([asis_atom(["getdec_",ObjSetName]),"(_) ->",nl, + indent(2),"fun(_,Bytes, _RestPrimFieldName) ->",nl]), emit_dec_open_type(4), emit([nl, indent(2),"end.",nl,nl]), @@ -1495,7 +1439,6 @@ emit_dec_open_type(I) -> emit_inner_of_decfun(#typedef{name={ExtName,Name},typespec=Type}, _Prop, InternalDefFunName) -> OTag = Type#type.tag, -%% Tag = [X#tag{class=decode_class(X#tag.class)}|| X <- OTag], Tag = [(decode_class(X#tag.class) bsl 10) + X#tag.number || X <- OTag], case {ExtName,Name} of {primitive,bif} -> @@ -1504,8 +1447,6 @@ emit_inner_of_decfun(#typedef{name={ExtName,Name},typespec=Type}, _Prop, 0; {constructed,bif} -> emit([indent(12),"'dec_", -% asn1ct_gen:list2name(InternalDefFunName),"'(Bytes, ",Prop, -% ", ",{asis,Tag},")"]), asn1ct_gen:list2name(InternalDefFunName),"'(Bytes, ", {asis,Tag},")"]), 1; @@ -1519,7 +1460,6 @@ emit_inner_of_decfun(#typedef{name=Name},_Prop,_) -> 0; emit_inner_of_decfun(#type{}=Type, _Prop, _) -> OTag = Type#type.tag, -%% Tag = [X#tag{class=decode_class(X#tag.class)}|| X <- OTag], Tag = [(decode_class(X#tag.class) bsl 10) + X#tag.number || X <- OTag], CurrMod = get(currmod), Def = Type#type.def, @@ -1531,11 +1471,9 @@ emit_inner_of_decfun(#type{}=Type, _Prop, _) -> gen_dec_prim(Type, "Bytes", Tag); #'Externaltypereference'{module=CurrMod,type=T} -> emit([indent(9),T," ->",nl,indent(12),"'dec_",T, -% "'(Bytes, ",Prop,")"]); "'(Bytes)"]); #'Externaltypereference'{module=ExtMod,type=T} -> emit([indent(9),T," ->",nl,indent(12),ExtMod,":'dec_", -% T,"'(Bytes, ",Prop,")"]) T,"'(Bytes, ",{asis,Tag},")"]) end, 0. @@ -1550,10 +1488,6 @@ gen_internal_funcs(Erules,[TypeDef|Rest]) -> gen_internal_funcs(Erules,Rest). -dbdec(Type,Arg) -> - demit({"io:format(\"decoding: ",{asis,Type},"~w~n\",[",Arg,"]),",nl}). - - decode_class('UNIVERSAL') -> ?UNIVERSAL; decode_class('APPLICATION') -> @@ -1605,7 +1539,7 @@ encode_tag_val(Class, Form, TagNo) -> %%%%%%%%%%% %% mk_object_val(Value) -> {OctetList, Len} -%% returns a Val as a list of octets, the 8 bit is allways set to one except +%% returns a Val as a list of octets, the 8 bit is always set to one except %% for the last octet, where its 0 %% @@ -1619,8 +1553,9 @@ mk_object_val(0, Ack, Len) -> mk_object_val(Val, Ack, Len) -> mk_object_val(Val bsr 7, [((Val band 127) bor 128) | Ack], Len + 1). -%% For BER the ExtensionAdditionGroup notation has no impact on the encoding/decoding -%% and therefore we only filter away the ExtensionAdditionGroup start and end markers +%% For BER the ExtensionAdditionGroup notation has no impact on the +%% encoding/decoding. Therefore we can filter away the +%% ExtensionAdditionGroup start and end markers. extaddgroup2sequence(ExtList) when is_list(ExtList) -> lists:filter(fun(#'ExtensionAdditionGroup'{}) -> false; @@ -1632,3 +1567,12 @@ extaddgroup2sequence(ExtList) when is_list(ExtList) -> call(F, Args) -> asn1ct_func:call(ber, F, Args). + +enc_func(Tname) -> + list_to_atom(lists:concat(["enc_",Tname])). + +dec_func(Tname) -> + list_to_atom(lists:concat(["dec_",Tname])). + +asis_atom(List) -> + {asis,list_to_atom(lists:concat(List))}. diff --git a/lib/asn1/src/asn1ct_gen_per.erl b/lib/asn1/src/asn1ct_gen_per.erl index 9671a566bf..22719bba74 100644 --- a/lib/asn1/src/asn1ct_gen_per.erl +++ b/lib/asn1/src/asn1ct_gen_per.erl @@ -24,7 +24,6 @@ %% all types in an ASN.1 module -include("asn1_records.hrl"). -%-compile(export_all). -export([gen_dec_imm/2]). -export([gen_dec_prim/3,gen_encode_prim_imm/3]). @@ -35,15 +34,20 @@ -export([extaddgroup2sequence/1]). -export([dialyzer_suppressions/1]). --import(asn1ct_gen, [emit/1,demit/1]). +-import(asn1ct_gen, [emit/1]). -import(asn1ct_func, [call/3]). -%% Generate ENCODING ****************************** -%%****************************************x +%%**************************************** +%% Generate ENCODING +%%**************************************** -dialyzer_suppressions(Erules) -> - case asn1ct_func:is_used({Erules,complete,1}) of +dialyzer_suppressions(#gen{erule=per,aligned=Aligned}) -> + Mod = case Aligned of + false -> uper; + true -> per + end, + case asn1ct_func:is_used({Mod,complete,1}) of false -> ok; true -> @@ -54,14 +58,6 @@ dialyzer_suppressions(Erules) -> gen_encode(Erules,Type) when is_record(Type,typedef) -> gen_encode_user(Erules,Type). -%% case Type#typedef.typespec of -%% Def when is_record(Def,type) -> -%% gen_encode_user(Erules,Type); -%% Def when is_tuple(Def),(element(1,Def) == 'Object') -> -%% gen_encode_object(Erules,Type); -%% Other -> -%% exit({error,{asn1,{unknown,Other}}}) -%% end. gen_encode(Erules,Typename,#'ComponentType'{name=Cname,typespec=Type}) -> NewTypename = [Cname|Typename], @@ -72,15 +68,14 @@ gen_encode(Erules,Typename,Type) when is_record(Type,type) -> ObjFun = case lists:keysearch(objfun,1,Type#type.tablecinf) of {value,{_,_Name}} -> -%% lists:concat([", ObjFun",Name]); ", ObjFun"; false -> "" end, case asn1ct_gen:type(InnerType) of {constructed,bif} -> - emit({"'enc_",asn1ct_gen:list2name(Typename),"'(Val",ObjFun, - ") ->",nl}), + Func = enc_func(asn1ct_gen:list2name(Typename)), + emit([{asis,Func},"(Val",ObjFun,") ->",nl]), asn1ct_gen:gen_encode_constructed(Erules,Typename,InnerType,Type); _ -> true @@ -92,20 +87,21 @@ gen_encode_user(Erules,D) when is_record(D,typedef) -> Typename = [D#typedef.name], Def = D#typedef.typespec, InnerType = asn1ct_gen:get_inner(Def#type.def), - emit({"'enc_",asn1ct_gen:list2name(Typename),"'(Val) ->",nl}), + Func = enc_func(asn1ct_gen:list2name(Typename)), + emit([{asis,Func},"(Val) ->",nl]), case asn1ct_gen:type(InnerType) of {primitive,bif} -> gen_encode_prim(Erules, Def), - emit({".",nl}); + emit([".",nl]); 'ASN1_OPEN_TYPE' -> gen_encode_prim(Erules, Def#type{def='ASN1_OPEN_TYPE'}), - emit({".",nl}); + emit([".",nl]); {constructed,bif} -> asn1ct_gen:gen_encode_constructed(Erules,Typename,InnerType,D); #'Externaltypereference'{module=CurrMod,type=Etype} -> - emit({"'enc_",Etype,"'(Val).",nl,nl}); + emit([{asis,enc_func(Etype)},"(Val).",nl]); #'Externaltypereference'{module=Emod,type=Etype} -> - emit({"'",Emod,"':'enc_",Etype,"'(Val).",nl,nl}) + emit([{asis,Emod},":",enc_func(Etype),"(Val).",nl]) end. @@ -220,7 +216,6 @@ gen_objectset_code(_Erules, _ObjSet) -> gen_decode(Erules, #typedef{}=Type) -> DecFunc = dec_func(Type#typedef.name), emit([nl,nl,{asis,DecFunc},"(Bytes) ->",nl]), - dbdec(Type#typedef.name), gen_decode_user(Erules, Type). gen_decode(Erules,Tname,#'ComponentType'{name=Cname,typespec=Type}) -> @@ -241,17 +236,11 @@ gen_decode(Erules,Typename,Type) when is_record(Type,type) -> emit([nl, {asis,dec_func(asn1ct_gen:list2name(Typename))}, "(Bytes",ObjFun,") ->",nl]), - dbdec(Typename), asn1ct_gen:gen_decode_constructed(Erules,Typename,InnerType,Type); _ -> true end. -dbdec(Type) when is_list(Type)-> - demit({"io:format(\"decoding: ",asn1ct_gen:list2name(Type),"~w~n\",[Bytes]),",nl}); -dbdec(Type) -> - demit({"io:format(\"decoding: ",{asis,Type},"~w~n\",[Bytes]),",nl}). - gen_decode_user(Erules,D) when is_record(D,typedef) -> Typename = [D#typedef.name], Def = D#typedef.typespec, @@ -259,17 +248,15 @@ gen_decode_user(Erules,D) when is_record(D,typedef) -> case asn1ct_gen:type(InnerType) of {primitive,bif} -> gen_dec_prim(Erules,Def,"Bytes"), - emit({".",nl,nl}); + emit([".",nl,nl]); 'ASN1_OPEN_TYPE' -> gen_dec_prim(Erules,Def#type{def='ASN1_OPEN_TYPE'},"Bytes"), - emit({".",nl,nl}); + emit([".",nl,nl]); {constructed,bif} -> asn1ct_gen:gen_decode_constructed(Erules,Typename,InnerType,D); #'Externaltypereference'{}=Etype -> gen_dec_external(Etype, "Bytes"), - emit([".",nl,nl]); - Other -> - exit({error,{asn1,{unknown,Other}}}) + emit([".",nl,nl]) end. gen_dec_external(Ext, BytesVar) -> @@ -398,10 +385,11 @@ gen_dec_prim(Erule, Type, BytesVar) -> asn1ct_imm:dec_code_gen(Imm, BytesVar). -%% For PER the ExtensionAdditionGroup notation has significance for the encoding and decoding -%% the components within the ExtensionAdditionGroup is treated in a similar way as if they -%% have been specified within a SEQUENCE, therefore we construct a fake sequence type here -%% so that we can generate code for it +%% For PER the ExtensionAdditionGroup notation has significance for +%% the encoding and decoding. The components within the +%% ExtensionAdditionGroup is treated in a similar way as if they have +%% been specified within a SEQUENCE. Therefore we construct a fake +%% sequence type here so that we can generate code for it. extaddgroup2sequence(ExtList) -> extaddgroup2sequence(ExtList,0,[]). diff --git a/lib/asn1/src/asn1ct_name.erl b/lib/asn1/src/asn1ct_name.erl index 72d541cbbc..06f6604a26 100644 --- a/lib/asn1/src/asn1ct_name.erl +++ b/lib/asn1/src/asn1ct_name.erl @@ -20,7 +20,6 @@ %% -module(asn1ct_name). -%%-compile(export_all). -export([start/0, curr/1, clear/0, @@ -44,7 +43,6 @@ start() -> end. name_server_loop({Ref, Parent} = Monitor,Vars) -> -%% io:format("name -- ~w~n",[Vars]), receive {_From,clear} -> name_server_loop(Monitor, []); diff --git a/lib/asn1/src/asn1ct_parser2.erl b/lib/asn1/src/asn1ct_parser2.erl index 2de9b0e2f0..3f1819b660 100644 --- a/lib/asn1/src/asn1ct_parser2.erl +++ b/lib/asn1/src/asn1ct_parser2.erl @@ -1496,7 +1496,7 @@ parse_ContentsConstraint([{'ENCODED',_},{'BY',_}|Rest]) -> parse_ContentsConstraint(Tokens) -> parse_error(Tokens). -% X.683 Parameterization of ASN.1 specifications +%% X.683 Parameterization of ASN.1 specifications parse_Governor(Tokens) -> Flist = [fun parse_Type/1, diff --git a/lib/asn1/src/asn1ct_value.erl b/lib/asn1/src/asn1ct_value.erl index 8bd99d995b..f7d986aa91 100644 --- a/lib/asn1/src/asn1ct_value.erl +++ b/lib/asn1/src/asn1ct_value.erl @@ -24,12 +24,12 @@ %% The value is randomized within it's constraints -include("asn1_records.hrl"). -%-compile(export_all). -export([from_type/2]). -%% Generate examples of values ****************************** -%%****************************************x +%%**************************************** +%% Generate examples of values +%%**************************************** from_type(M,Typename) -> @@ -92,9 +92,6 @@ get_inner(T) when is_tuple(T) -> Other -> Other end. -%%get_inner(T) when is_tuple(T) -> element(1,T). - - from_type_constructed(M,Typename,InnerType,D) when is_record(D,type) -> case InnerType of @@ -111,9 +108,7 @@ from_type_constructed(M,Typename,InnerType,D) when is_record(D,type) -> 'SET OF' -> {_,Type} = D#type.def, NameSuffix = asn1ct_gen:constructed_suffix(InnerType,Type#type.def), - get_sequence_of(M,Typename,D,NameSuffix); - _ -> - exit({nyi,InnerType}) + get_sequence_of(M,Typename,D,NameSuffix) end. get_sequence(M,Typename,Type) -> @@ -147,7 +142,8 @@ get_choice(M,Typename,Type) -> case TCompList of [] -> {asn1_EMPTY,asn1_EMPTY}; - {CompList,ExtList} -> % Should be enhanced to handle extensions too + {CompList,ExtList} -> + %% should be enhanced to handle extensions too. CList = CompList ++ ExtList, C = lists:nth(random(length(CList)),CList), {C#'ComponentType'.name,from_type(M,Typename,C)}; @@ -247,14 +243,6 @@ from_type_prim(M, D) -> _ -> {2#11111111,2,2} end; -%% Sign1 = random_sign(integer), -%% Sign2 = random_sign(integer), -%% {Sign1*random(10000),2,Sign2*random(1028)}; -%% 2 -> -%% %% base 10 tuple format -%% Sign1 = random_sign(integer), -%% Sign2 = random_sign(integer), -%% {Sign1*random(10000),10,Sign2*random(1028)}; _ -> %% base 10 string format, NR3 format case random(2) of @@ -302,9 +290,7 @@ from_type_prim(M, D) -> 16#ffff,16#ffee,16#10ffff,16#ffff,16#fff]), unicode:characters_to_binary(L); 'UniversalString' -> - adjust_list(size_random(C),c_string(C,"UniversalString")); - XX -> - exit({asn1_error,nyi,XX}) + adjust_list(size_random(C),c_string(C,"UniversalString")) end. c_string(C,Default) -> @@ -343,22 +329,6 @@ random_unnamed_bit_string(M, C) -> {PadLen,<<BitString/bitstring,0:PadLen>>} end. -%% FIXME: -%% random_sign(integer) -> -%% case random(2) of -%% 2 -> -%% -1; -%% _ -> -%% 1 -%% end; -%% random_sign(string) -> -%% case random(2) of -%% 2 -> -%% "-"; -%% _ -> -%% "" -%% end. - random(Upper) -> rand:uniform(Upper). @@ -409,13 +379,6 @@ c_random(VRange,Single) -> S; {_,S} when is_list(S) -> lists:nth(random(length(S)),S) -%% {S1,S2} -> -%% io:format("asn1ct_value: hejsan hoppsan~n"); -%% _ -> -%% io:format("asn1ct_value: hejsan hoppsan 2~n") -%% io:format("asn1ct_value: c_random/2: S1 = ~w~n" -%% "S2 = ~w,~n",[S1,S2]) -%% exit(self(),goodbye) end. adjust_list(Len,Orig) -> diff --git a/lib/asn1/src/asn1rtt_ber.erl b/lib/asn1/src/asn1rtt_ber.erl index fdb9b9061f..882a25c332 100644 --- a/lib/asn1/src/asn1rtt_ber.erl +++ b/lib/asn1/src/asn1rtt_ber.erl @@ -92,7 +92,7 @@ -define(N_BMPString, 30). -% the complete tag-word of built-in types +%% The complete tag-word of built-in types -define(T_BOOLEAN, ?UNIVERSAL bor ?PRIMITIVE bor 1). -define(T_INTEGER, ?UNIVERSAL bor ?PRIMITIVE bor 2). -define(T_BIT_STRING, ?UNIVERSAL bor ?PRIMITIVE bor 3). % can be CONSTRUCTED @@ -137,11 +137,11 @@ ber_decode_erlang(Tlv) -> decode_primitive(Bin) -> {Form,TagNo,V,Rest} = decode_tag_and_length(Bin), case Form of - 1 -> % constructed + 1 -> % constructed {{TagNo,decode_constructed(V)},Rest}; - 0 -> % primitive + 0 -> % primitive {{TagNo,V},Rest}; - 2 -> % constructed indefinite + 2 -> % constructed indefinite {Vlist,Rest2} = decode_constructed_indefinite(V,[]), {{TagNo,Vlist},Rest2} end. @@ -165,31 +165,30 @@ decode_primitive_incomplete([[default,TagNo]],Bin) -> %default {Form,TagNo,V,Rest} -> decode_incomplete2(Form,TagNo,V,[],Rest); _ -> - %{asn1_DEFAULT,Bin} asn1_NOVALUE end; -decode_primitive_incomplete([[default,TagNo,Directives]],Bin) -> %default, constructed type, Directives points into this type +decode_primitive_incomplete([[default,TagNo,Directives]],Bin) -> + %% default, constructed type, Directives points into this type case decode_tag_and_length(Bin) of {Form,TagNo,V,Rest} -> decode_incomplete2(Form,TagNo,V,Directives,Rest); _ -> - %{asn1_DEFAULT,Bin} asn1_NOVALUE end; -decode_primitive_incomplete([[opt,TagNo]],Bin) -> %optional +decode_primitive_incomplete([[opt,TagNo]],Bin) -> + %% optional case decode_tag_and_length(Bin) of {Form,TagNo,V,Rest} -> decode_incomplete2(Form,TagNo,V,[],Rest); _ -> - %{{TagNo,asn1_NOVALUE},Bin} asn1_NOVALUE end; -decode_primitive_incomplete([[opt,TagNo,Directives]],Bin) -> %optional +decode_primitive_incomplete([[opt,TagNo,Directives]],Bin) -> + %% optional case decode_tag_and_length(Bin) of {Form,TagNo,V,Rest} -> decode_incomplete2(Form,TagNo,V,Directives,Rest); _ -> - %{{TagNo,asn1_NOVALUE},Bin} asn1_NOVALUE end; %% An optional that shall be undecoded @@ -236,7 +235,8 @@ decode_primitive_incomplete([[alt_parts,TagNo]|RestAlts],Bin) -> _ -> decode_primitive_incomplete(RestAlts,Bin) end; -decode_primitive_incomplete([[undec,_TagNo]|_RestTag],Bin) -> %incomlete decode +decode_primitive_incomplete([[undec,_TagNo]|_RestTag],Bin) -> + %% incomlete decode decode_incomplete_bin(Bin); decode_primitive_incomplete([[parts,TagNo]|_RestTag],Bin) -> case decode_tag_and_length(Bin) of @@ -301,7 +301,8 @@ decode_constructed_incomplete(Directives=[[Alt,_]|_],Bin) {TagNo,Tlv}; {alt_parts,_} -> [{TagNo,decode_parts_incomplete(V)}]; - no_match -> %% if a choice alternative was encoded that + no_match -> + %% if a choice alternative was encoded that %% was not specified in the config file, %% thus decode component anonomous. {Tlv,_}=decode_primitive(Bin), @@ -546,7 +547,7 @@ decode_tag_and_length(<<Class:2, Form:1, 31:5, Buffer/binary>>) -> decode_tag(<<0:1,PartialTag:7, Buffer/binary>>, TagAck) -> TagNo = (TagAck bsl 7) bor PartialTag, {TagNo, Buffer}; -% more tags +%% more tags decode_tag(<<_:1,PartialTag:7, Buffer/binary>>, TagAck) -> TagAck1 = (TagAck bsl 7) bor PartialTag, decode_tag(Buffer, TagAck1). @@ -941,12 +942,12 @@ encode_bit_string_bits(C, BitListVal, _NamedBitList, TagIn) when is_list(BitList case length(BitListVal) of BitSize when BitSize == Size -> {Len, Unused, OctetList} = encode_bitstring(BitListVal), - %%add unused byte to the Len + %% add unused byte to the Len encode_tags(TagIn, [Unused | OctetList], Len+1); BitSize when BitSize < Size -> PaddedList = pad_bit_list(Size-BitSize,BitListVal), {Len, Unused, OctetList} = encode_bitstring(PaddedList), - %%add unused byte to the Len + %% add unused byte to the Len encode_tags(TagIn, [Unused | OctetList], Len+1); BitSize -> exit({error,{asn1, diff --git a/lib/asn1/test/asn1_SUITE.erl b/lib/asn1/test/asn1_SUITE.erl index 580c919b9d..d99190b6b0 100644 --- a/lib/asn1/test/asn1_SUITE.erl +++ b/lib/asn1/test/asn1_SUITE.erl @@ -1108,6 +1108,7 @@ test_modules() -> "From", "H235-SECURITY-MESSAGES", "H323-MESSAGES", + "HighTagNumbers", "Import", "Int", "MAP-commonDataTypes", diff --git a/lib/asn1/test/asn1_SUITE_data/HighTagNumbers.asn1 b/lib/asn1/test/asn1_SUITE_data/HighTagNumbers.asn1 new file mode 100644 index 0000000000..b681063965 --- /dev/null +++ b/lib/asn1/test/asn1_SUITE_data/HighTagNumbers.asn1 @@ -0,0 +1,17 @@ +HighTagNumbers DEFINITIONS ::= +BEGIN + +S ::= SEQUENCE { + a [127] INTEGER, + b [128] INTEGER, + c [150] INTEGER, + d [207] INTEGER, + e [255] INTEGER, + f [256] INTEGER, + g [7777] INTEGER, + h [9999] INTEGER, + i [16382] INTEGER, + j [16383] INTEGER +} + +END diff --git a/lib/compiler/src/Makefile b/lib/compiler/src/Makefile index cf60355a40..59b80ade5d 100644 --- a/lib/compiler/src/Makefile +++ b/lib/compiler/src/Makefile @@ -63,6 +63,7 @@ MODULES = \ beam_peep \ beam_receive \ beam_reorder \ + beam_record \ beam_split \ beam_trim \ beam_type \ diff --git a/lib/compiler/src/beam_disasm.erl b/lib/compiler/src/beam_disasm.erl index c699672db1..8fd0b36d05 100644 --- a/lib/compiler/src/beam_disasm.erl +++ b/lib/compiler/src/beam_disasm.erl @@ -815,6 +815,9 @@ resolve_inst({is_tuple=I,Args0},_,_,_) -> resolve_inst({test_arity=I,Args0},_,_,_) -> [L|Args] = resolve_args(Args0), {test,I,L,Args}; +resolve_inst({is_tagged_tuple=I,Args0},_,_,_) -> + [F|Args] = resolve_args(Args0), + {test,I,F,Args}; resolve_inst({select_val,Args},_,_,_) -> [Reg,FLbl,{{z,1},{u,_Len},List0}] = Args, List = resolve_args(List0), diff --git a/lib/compiler/src/beam_record.erl b/lib/compiler/src/beam_record.erl new file mode 100644 index 0000000000..419089b1bc --- /dev/null +++ b/lib/compiler/src/beam_record.erl @@ -0,0 +1,106 @@ +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2014-2017. All Rights Reserved. +%% +%% The contents of this file are subject to the Erlang Public License, +%% Version 1.1, (the "License"); you may not use this file except in +%% compliance with the License. You should have received a copy of the +%% Erlang Public License along with this software. If not, it can be +%% retrieved online at http://www.erlang.org/. +%% +%% Software distributed under the License is distributed on an "AS IS" +%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +%% the License for the specific language governing rights and limitations +%% under the License. +%% +%% %CopyrightEnd% +%% +%% File: beam_record.erl +%% Author: Björn-Egil Dahlberg +%% Created: 2014-09-03 +%% + +-module(beam_record). +-export([module/2]). + +%% Rewrite the instruction stream on tagged tuple tests. +%% Tagged tuples means a tuple of any arity with an atom as its first element. +%% Typically records, ok-tuples and error-tuples. +%% +%% from: +%% ... +%% {test,is_tuple,Fail,[Src]}. +%% {test,test_arity,Fail,[Src,Sz]}. +%% ... +%% {get_tuple_element,Src,0,Dst}. +%% ... +%% {test,is_eq_exact,Fail,[Dst,Atom]}. +%% ... +%% to: +%% ... +%% {test,is_tagged_tuple,Fail,[Src,Sz,Atom]}. +%% ... + + +-import(lists, [reverse/1]). + +-spec module(beam_utils:module_code(), [compile:option()]) -> + {'ok',beam_utils:module_code()}. + +module({Mod,Exp,Attr,Fs0,Lc}, _Opt) -> + Fs = [function(F) || F <- Fs0], + {ok,{Mod,Exp,Attr,Fs,Lc}}. + +function({function,Name,Arity,CLabel,Is}) -> + try + Idx = beam_utils:index_labels(Is), + {function,Name,Arity,CLabel,rewrite(Is,Idx)} + catch + Class:Error -> + Stack = erlang:get_stacktrace(), + io:fwrite("Function: ~w/~w\n", [Name,Arity]), + erlang:raise(Class, Error, Stack) + end. + +rewrite(Is,Idx) -> + rewrite(Is,Idx,[]). + +rewrite([{test,is_tuple,Fail,[Src]}=I1, + {test,test_arity,Fail,[Src,N]}=I2|Is],Idx,Acc) -> + case is_tagged_tuple(Is,Fail,Src,Idx) of + no -> + rewrite(Is,Idx,[I2,I1|Acc]); + {Atom,[{block,[]}|Is1]} -> + rewrite(Is1,Idx,[{test,is_tagged_tuple,Fail,[Src,N,Atom]}|Acc]); + {Atom,Is1} -> + rewrite(Is1,Idx,[{test,is_tagged_tuple,Fail,[Src,N,Atom]}|Acc]) + end; +rewrite([I|Is],Idx,Acc) -> + rewrite(Is,Idx,[I|Acc]); +rewrite([],_,Acc) -> reverse(Acc). + +is_tagged_tuple([{block,[{set,[Dst],[Src],{get_tuple_element,0}}=B|Bs]}, + {test,is_eq_exact,Fail,[Dst,{atom,_}=Atom]}|Is],Fail,Src,Idx) -> + + %% if Dst is killed in the instruction stream and at fail label, + %% we can safely remove get_tuple_element. + %% + %% if Dst is not killed in the stream, we cannot remove get_tuple_element + %% since it is referenced. + + case is_killed(Dst,Is,Fail,Idx) of + true -> {Atom,[{block,Bs}|Is]}; + false -> {Atom,[{block,[B|Bs]}|Is]} + end; +is_tagged_tuple([{block,[{set,_,_,_}=B|Bs]}, + {test,is_eq_exact,_,_}=I|Is],Fail,Src,Idx) -> + case is_tagged_tuple([{block,Bs},I|Is],Fail,Src,Idx) of + {Atom,[{block,Bsr}|Isr]} -> {Atom,[{block,[B|Bsr]}|Isr]}; + no -> no + end; +is_tagged_tuple(_Is,_Fail,_Src,_Idx) -> + no. + +is_killed(Dst,Is,{_,Lbl},Idx) -> + beam_utils:is_killed(Dst,Is,Idx) andalso + beam_utils:is_killed_at(Dst,Lbl,Idx). diff --git a/lib/compiler/src/beam_validator.erl b/lib/compiler/src/beam_validator.erl index bf33ae0aeb..c26e5719aa 100644 --- a/lib/compiler/src/beam_validator.erl +++ b/lib/compiler/src/beam_validator.erl @@ -653,6 +653,9 @@ valfun_4({test,is_nonempty_list,{f,Lbl},[Cons]}, Vst) -> valfun_4({test,test_arity,{f,Lbl},[Tuple,Sz]}, Vst) when is_integer(Sz) -> assert_type(tuple, Tuple, Vst), set_type_reg({tuple,Sz}, Tuple, branch_state(Lbl, Vst)); +valfun_4({test,is_tagged_tuple,{f,Lbl},[Src,Sz,_Atom]}, Vst) -> + validate_src([Src], Vst), + set_type_reg({tuple, Sz}, Src, branch_state(Lbl, Vst)); valfun_4({test,has_map_fields,{f,Lbl},Src,{list,List}}, Vst) -> assert_type(map, Src, Vst), assert_unique_map_keys(List), diff --git a/lib/compiler/src/compile.erl b/lib/compiler/src/compile.erl index c849306c0d..03b52932d1 100644 --- a/lib/compiler/src/compile.erl +++ b/lib/compiler/src/compile.erl @@ -216,19 +216,19 @@ expand_opt(return, Os) -> expand_opt(r12, Os) -> [no_recv_opt,no_line_info,no_utf8_atoms|Os]; expand_opt(r13, Os) -> - [no_recv_opt,no_line_info,no_utf8_atoms|Os]; + [no_record_opt,no_recv_opt,no_line_info,no_utf8_atoms|Os]; expand_opt(r14, Os) -> - [no_line_info,no_utf8_atoms|Os]; + [no_record_opt,no_line_info,no_utf8_atoms|Os]; expand_opt(r15, Os) -> - [no_utf8_atoms|Os]; + [no_record_opt,no_utf8_atoms|Os]; expand_opt(r16, Os) -> - [no_utf8_atoms|Os]; + [no_record_opt,no_utf8_atoms|Os]; expand_opt(r17, Os) -> - [no_utf8_atoms|Os]; + [no_record_opt,no_utf8_atoms|Os]; expand_opt(r18, Os) -> - [no_utf8_atoms|Os]; + [no_record_opt,no_utf8_atoms|Os]; expand_opt(r19, Os) -> - [no_utf8_atoms|Os]; + [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) -> @@ -755,6 +755,8 @@ asm_passes() -> {iff,dbsm,{listing,"bsm"}}, {unless,no_recv_opt,{pass,beam_receive}}, {iff,drecv,{listing,"recv"}}, + {unless,no_record_opt,{pass,beam_record}}, + {iff,drecord,{listing,"record"}}, {unless,no_stack_trimming,{pass,beam_trim}}, {iff,dtrim,{listing,"trim"}}, {pass,beam_flatten}]}, @@ -1849,6 +1851,7 @@ pre_load() -> beam_opcodes, beam_peep, beam_receive, + beam_record, beam_reorder, beam_split, beam_trim, diff --git a/lib/compiler/src/compiler.app.src b/lib/compiler/src/compiler.app.src index 3cb991687b..3961b2af86 100644 --- a/lib/compiler/src/compiler.app.src +++ b/lib/compiler/src/compiler.app.src @@ -38,6 +38,7 @@ beam_peep, beam_receive, beam_reorder, + beam_record, beam_split, beam_trim, beam_type, diff --git a/lib/compiler/src/genop.tab b/lib/compiler/src/genop.tab index dcbdeb32e6..5e0c2b3ebf 100755 --- a/lib/compiler/src/genop.tab +++ b/lib/compiler/src/genop.tab @@ -537,3 +537,9 @@ BEAM_FORMAT_NUMBER=0 156: is_map/2 157: has_map_fields/3 158: get_map_elements/3 + +## @spec is_tagged_tuple Lbl Reg N Atom +## @doc Test the type of Reg and jumps to Lbl if it is not a tuple. +## Test the arity of Reg and jumps to Lbl if it is not N. +## Test the first element of the tuple and jumps to Lbl if it is not Atom. +159: is_tagged_tuple/4 diff --git a/lib/compiler/test/Makefile b/lib/compiler/test/Makefile index e338dbb4e3..63763f31b2 100644 --- a/lib/compiler/test/Makefile +++ b/lib/compiler/test/Makefile @@ -185,6 +185,7 @@ release_tests_spec: make_emakefile echo "-module($$module). %% dummy .erl file" >$$file; \ done $(INSTALL_DATA) $(ERL_DUMMY_FILES) "$(RELSYSDIR)" + rm $(ERL_DUMMY_FILES) chmod -R u+w "$(RELSYSDIR)" @tar cf - *_SUITE_data | (cd "$(RELSYSDIR)"; tar xf -) diff --git a/lib/compiler/test/misc_SUITE.erl b/lib/compiler/test/misc_SUITE.erl index 621524114f..fa6d5ee957 100644 --- a/lib/compiler/test/misc_SUITE.erl +++ b/lib/compiler/test/misc_SUITE.erl @@ -280,6 +280,23 @@ silly_coverage(Config) when is_list(Config) -> {block,[a|b]}]}],0}, expect_error(fun() -> beam_receive:module(ReceiveInput, []) end), + %% beam_record. + RecordInput = {?MODULE,[{foo,0}],[], + [{function,foo,1,2, + [{label,1}, + {func_info,{atom,?MODULE},{atom,foo},1}, + {label,2}, + {test,is_tuple,{f,1},[{x,0}]}, + {test,test_arity,{f,1},[{x,0},3]}, + {block,[{set,[{x,1}],[{x,0}],{get_tuple_element,0}}]}, + {test,is_eq_exact,{f,1},[{x,1},{atom,bar}]}, + {block,[{set,[{x,2}],[{x,0}],{get_tuple_element,1}}|a]}, + {test,is_eq_exact,{f,1},[{x,2},{integer,1}]}, + {block,[{set,[{x,0}],[{atom,ok}],move}]}, + return]}],0}, + + expect_error(fun() -> beam_record:module(RecordInput, []) end), + BeamZInput = {?MODULE,[{foo,0}],[], [{function,foo,0,2, [{label,1}, diff --git a/lib/crypto/src/crypto.erl b/lib/crypto/src/crypto.erl index 631af62615..ce8add6559 100644 --- a/lib/crypto/src/crypto.erl +++ b/lib/crypto/src/crypto.erl @@ -40,6 +40,8 @@ -export([ec_curve/1, ec_curves/0]). -export([rand_seed/1]). +-deprecated({rand_uniform, 2, next_major_release}). + %% This should correspond to the similar macro in crypto.c -define(MAX_BYTES_TO_NIF, 20000). %% Current value is: erlang:system_info(context_reductions) * 10 diff --git a/lib/eunit/src/eunit_surefire.erl b/lib/eunit/src/eunit_surefire.erl index 6b306c51d3..2b9f82b075 100644 --- a/lib/eunit/src/eunit_surefire.erl +++ b/lib/eunit/src/eunit_surefire.erl @@ -424,6 +424,7 @@ escape_suitename(String) -> escape_suitename([], Acc) -> lists:reverse(Acc); escape_suitename([$ | Tail], Acc) -> escape_suitename(Tail, [$_ | Acc]); escape_suitename([$' | Tail], Acc) -> escape_suitename(Tail, Acc); +escape_suitename([$" | Tail], Acc) -> escape_suitename(Tail, Acc); escape_suitename([$/ | Tail], Acc) -> escape_suitename(Tail, [$: | Acc]); escape_suitename([$\\ | Tail], Acc) -> escape_suitename(Tail, [$: | Acc]); escape_suitename([Char | Tail], Acc) when Char < $! -> escape_suitename(Tail, Acc); diff --git a/lib/hipe/amd64/hipe_amd64_ra_sse2_postconditions.erl b/lib/hipe/amd64/hipe_amd64_ra_sse2_postconditions.erl index 8a3ea92156..891c874a15 100644 --- a/lib/hipe/amd64/hipe_amd64_ra_sse2_postconditions.erl +++ b/lib/hipe/amd64/hipe_amd64_ra_sse2_postconditions.erl @@ -53,6 +53,8 @@ do_insn(I, TempMap, Strategy) -> % Insn -> {Insn list, DidSpill} do_fp_unop(I, TempMap, Strategy); #fp_binop{} -> do_fp_binop(I, TempMap, Strategy); + #pseudo_spill_fmove{} -> + do_pseudo_spill_fmove(I, TempMap, Strategy); _ -> %% All non sse2 ops {[I], false} @@ -95,8 +97,13 @@ do_fmove(I, TempMap, Strategy) -> of true -> Tmp = spill_temp(double, Strategy), - {[#fmove{src=Src, dst=Tmp},I#fmove{src=Tmp,dst=Dst}], - true}; + %% pseudo_spill_fmove allows spill slot move coalescing, but must not + %% contain memory operands (except for spilled temps) + Is = case is_float_temp(Src) andalso is_float_temp(Dst) of + true -> [#pseudo_spill_fmove{src=Src, temp=Tmp, dst=Dst}]; + false -> [#fmove{src=Src, dst=Tmp},I#fmove{src=Tmp,dst=Dst}] + end, + {Is, true}; false -> {[I], false} end. @@ -104,6 +111,12 @@ do_fmove(I, TempMap, Strategy) -> is_float_temp(#x86_temp{type=Type}) -> Type =:= double; is_float_temp(#x86_mem{}) -> false. +%%% Fix an pseudo_spill_fmove op. +do_pseudo_spill_fmove(I = #pseudo_spill_fmove{temp=Temp}, TempMap, _Strategy) -> + %% Temp is above the low water mark and must not have been spilled + false = is_mem_opnd(Temp, TempMap), + {[I], false}. % nothing to do + %%% Check if an operand denotes a memory cell (mem or pseudo). is_mem_opnd(Opnd, TempMap) -> diff --git a/lib/hipe/arm/hipe_arm.erl b/lib/hipe/arm/hipe_arm.erl index e34a00f561..3b090b501a 100644 --- a/lib/hipe/arm/hipe_arm.erl +++ b/lib/hipe/arm/hipe_arm.erl @@ -79,6 +79,9 @@ pseudo_move_dst/1, pseudo_move_src/1, + mk_pseudo_spill_move/3, + is_pseudo_spill_move/1, + mk_pseudo_switch/3, mk_pseudo_tailcall/4, @@ -250,6 +253,10 @@ is_pseudo_move(I) -> case I of #pseudo_move{} -> true; _ -> false end. pseudo_move_dst(#pseudo_move{dst=Dst}) -> Dst. pseudo_move_src(#pseudo_move{src=Src}) -> Src. +mk_pseudo_spill_move(Dst, Temp, Src) -> + #pseudo_spill_move{dst=Dst, temp=Temp, src=Src}. +is_pseudo_spill_move(I) -> is_record(I, pseudo_spill_move). + mk_pseudo_switch(JTab, Index, Labels) -> #pseudo_switch{jtab=JTab, index=Index, labels=Labels}. diff --git a/lib/hipe/arm/hipe_arm.hrl b/lib/hipe/arm/hipe_arm.hrl index 67bc07634e..be06b1ebd7 100644 --- a/lib/hipe/arm/hipe_arm.hrl +++ b/lib/hipe/arm/hipe_arm.hrl @@ -101,6 +101,7 @@ -record(pseudo_call_prepare, {nrstkargs}). -record(pseudo_li, {dst, imm, label}). % pre-generated label for use by the assembler -record(pseudo_move, {dst, src}). +-record(pseudo_spill_move, {dst, temp, src}). -record(pseudo_switch, {jtab, index, labels}). -record(pseudo_tailcall, {funv, arity, stkargs, linkage}). -record(pseudo_tailcall_prepare, {}). diff --git a/lib/hipe/arm/hipe_arm_assemble.erl b/lib/hipe/arm/hipe_arm_assemble.erl index 713c148742..9aa730afa9 100644 --- a/lib/hipe/arm/hipe_arm_assemble.erl +++ b/lib/hipe/arm/hipe_arm_assemble.erl @@ -31,7 +31,7 @@ assemble(CompiledCode, Closures, Exports, Options) -> || {MFA, Defun} <- CompiledCode], %% {ConstAlign,ConstSize,ConstMap,RefsFromConsts} = - hipe_pack_constants:pack_constants(Code, 4), + hipe_pack_constants:pack_constants(Code), %% {CodeSize,CodeBinary,AccRefs,LabelMap,ExportMap} = encode(translate(Code, ConstMap), Options), diff --git a/lib/hipe/arm/hipe_arm_cfg.erl b/lib/hipe/arm/hipe_arm_cfg.erl index ea6da67317..0bc3df30b9 100644 --- a/lib/hipe/arm/hipe_arm_cfg.erl +++ b/lib/hipe/arm/hipe_arm_cfg.erl @@ -24,6 +24,7 @@ -export([params/1, reverse_postorder/1]). -export([arity/1]). % for linear scan %%-export([redirect_jmp/3]). +-export([branch_preds/1]). %%% these tell cfg.inc what to define (ugly as hell) -define(BREADTH_ORDER,true). % for linear scan @@ -75,6 +76,26 @@ branch_successors(Branch) -> #pseudo_tailcall{} -> [] end. +branch_preds(Branch) -> + case Branch of + #pseudo_bc{true_label=TrueLab,false_label=FalseLab,pred=Pred} -> + [{FalseLab, 1.0-Pred}, {TrueLab, Pred}]; + #pseudo_call{contlab=ContLab, sdesc=#arm_sdesc{exnlab=[]}} -> + %% A function can still cause an exception, even if we won't catch it + [{ContLab, 1.0-hipe_bb_weights:call_exn_pred()}]; + #pseudo_call{contlab=ContLab, sdesc=#arm_sdesc{exnlab=ExnLab}} -> + CallExnPred = hipe_bb_weights:call_exn_pred(), + [{ContLab, 1.0-CallExnPred}, {ExnLab, CallExnPred}]; + #pseudo_switch{labels=Labels} -> + Prob = 1.0/length(Labels), + [{L, Prob} || L <- Labels]; + _ -> + case branch_successors(Branch) of + [] -> []; + [Single] -> [{Single, 1.0}] + end + end. + -ifdef(REMOVE_TRIVIAL_BBS_NEEDED). fails_to(_Instr) -> []. -endif. diff --git a/lib/hipe/arm/hipe_arm_defuse.erl b/lib/hipe/arm/hipe_arm_defuse.erl index 0e62070c6c..652299a514 100644 --- a/lib/hipe/arm/hipe_arm_defuse.erl +++ b/lib/hipe/arm/hipe_arm_defuse.erl @@ -40,6 +40,7 @@ insn_def_gpr(I) -> #pseudo_call{} -> call_clobbered_gpr(); #pseudo_li{dst=Dst} -> [Dst]; #pseudo_move{dst=Dst} -> [Dst]; + #pseudo_spill_move{dst=Dst, temp=Temp} -> [Dst, Temp]; #pseudo_tailcall_prepare{} -> tailcall_clobbered_gpr(); #smull{dstlo=DstLo,dsthi=DstHi,src1=Src1} -> %% ARM requires DstLo, DstHi, and Src1 to be distinct. @@ -83,6 +84,7 @@ insn_use_gpr(I) -> #pseudo_call{funv=FunV,sdesc=#arm_sdesc{arity=Arity}} -> funv_use(FunV, arity_use_gpr(Arity)); #pseudo_move{src=Src} -> [Src]; + #pseudo_spill_move{src=Src} -> [Src]; #pseudo_switch{jtab=JTabR,index=IndexR} -> addtemp(JTabR, [IndexR]); #pseudo_tailcall{funv=FunV,arity=Arity,stkargs=StkArgs} -> addargs(StkArgs, addtemps(tailcall_clobbered_gpr(), funv_use(FunV, arity_use_gpr(Arity)))); diff --git a/lib/hipe/arm/hipe_arm_frame.erl b/lib/hipe/arm/hipe_arm_frame.erl index e323907e31..a1004fb609 100644 --- a/lib/hipe/arm/hipe_arm_frame.erl +++ b/lib/hipe/arm/hipe_arm_frame.erl @@ -69,6 +69,8 @@ do_insn(I, LiveOut, Context, FPoff) -> do_pseudo_call_prepare(I, FPoff); #pseudo_move{} -> {do_pseudo_move(I, Context, FPoff), FPoff}; + #pseudo_spill_move{} -> + {do_pseudo_spill_move(I, Context, FPoff), FPoff}; #pseudo_tailcall{} -> {do_pseudo_tailcall(I, Context), context_framesize(Context)}; _ -> @@ -100,6 +102,26 @@ pseudo_offset(Temp, FPoff, Context) -> FPoff + context_offset(Context, Temp). %%% +%%% Moves from one spill slot to another +%%% + +do_pseudo_spill_move(I, Context, FPoff) -> + #pseudo_spill_move{dst=Dst, temp=Temp, src=Src} = I, + case temp_is_pseudo(Src) andalso temp_is_pseudo(Dst) of + false -> % Register allocator changed its mind, turn back to move + do_pseudo_move(hipe_arm:mk_pseudo_move(Dst, Src), Context, FPoff); + true -> + SrcOffset = pseudo_offset(Src, FPoff, Context), + DstOffset = pseudo_offset(Dst, FPoff, Context), + case SrcOffset =:= DstOffset of + true -> []; % omit move-to-self + false -> + mk_load('ldr', Temp, SrcOffset, mk_sp(), + mk_store('str', Temp, DstOffset, mk_sp(), [])) + end + end. + +%%% %%% Return - deallocate frame and emit 'ret $N' insn. %%% diff --git a/lib/hipe/arm/hipe_arm_ra_finalise.erl b/lib/hipe/arm/hipe_arm_ra_finalise.erl index 9bfe0a9a83..80cd470708 100644 --- a/lib/hipe/arm/hipe_arm_ra_finalise.erl +++ b/lib/hipe/arm/hipe_arm_ra_finalise.erl @@ -25,11 +25,17 @@ ra_bb(BB, Map) -> hipe_bb:code_update(BB, ra_code(hipe_bb:code(BB), Map, [])). ra_code([I|Insns], Map, Accum) -> - ra_code(Insns, Map, [ra_insn(I, Map) | Accum]); + ra_code(Insns, Map, ra_insn(I, Map, Accum)); ra_code([], _Map, Accum) -> lists:reverse(Accum). -ra_insn(I, Map) -> +ra_insn(I, Map, Accum) -> + case I of + #pseudo_move{} -> ra_pseudo_move(I, Map, Accum); + _ -> [ra_insn_1(I, Map) | Accum] + end. + +ra_insn_1(I, Map) -> case I of #alu{} -> ra_alu(I, Map); #cmp{} -> ra_cmp(I, Map); @@ -38,7 +44,7 @@ ra_insn(I, Map) -> #move{} -> ra_move(I, Map); #pseudo_call{} -> ra_pseudo_call(I, Map); #pseudo_li{} -> ra_pseudo_li(I, Map); - #pseudo_move{} -> ra_pseudo_move(I, Map); + #pseudo_spill_move{} -> ra_pseudo_spill_move(I, Map); #pseudo_switch{} -> ra_pseudo_switch(I, Map); #pseudo_tailcall{} -> ra_pseudo_tailcall(I, Map); #smull{} -> ra_smull(I, Map); @@ -80,10 +86,19 @@ ra_pseudo_li(I=#pseudo_li{dst=Dst}, Map) -> NewDst = ra_temp(Dst, Map), I#pseudo_li{dst=NewDst}. -ra_pseudo_move(I=#pseudo_move{dst=Dst,src=Src}, Map) -> +ra_pseudo_move(I=#pseudo_move{dst=Dst,src=Src}, Map, Accum) -> + NewDst = ra_temp(Dst, Map), + NewSrc = ra_temp(Src, Map), + case NewSrc#arm_temp.reg =:= NewDst#arm_temp.reg of + true -> Accum; + false -> [I#pseudo_move{dst=NewDst,src=NewSrc} | Accum] + end. + +ra_pseudo_spill_move(I=#pseudo_spill_move{dst=Dst,temp=Temp,src=Src}, Map) -> NewDst = ra_temp(Dst, Map), + NewTemp = ra_temp(Temp, Map), NewSrc = ra_temp(Src, Map), - I#pseudo_move{dst=NewDst,src=NewSrc}. + I#pseudo_spill_move{dst=NewDst, temp=NewTemp, src=NewSrc}. ra_pseudo_switch(I=#pseudo_switch{jtab=JTab,index=Index}, Map) -> NewJTab = ra_temp(JTab, Map), diff --git a/lib/hipe/arm/hipe_arm_ra_postconditions.erl b/lib/hipe/arm/hipe_arm_ra_postconditions.erl index 8d1ee1cb94..23c305511f 100644 --- a/lib/hipe/arm/hipe_arm_ra_postconditions.erl +++ b/lib/hipe/arm/hipe_arm_ra_postconditions.erl @@ -56,6 +56,7 @@ do_insn(I, TempMap, Strategy) -> #pseudo_call{} -> do_pseudo_call(I, TempMap, Strategy); #pseudo_li{} -> do_pseudo_li(I, TempMap, Strategy); #pseudo_move{} -> do_pseudo_move(I, TempMap, Strategy); + #pseudo_spill_move{} -> do_pseudo_spill_move(I, TempMap, Strategy); #pseudo_switch{} -> do_pseudo_switch(I, TempMap, Strategy); #pseudo_tailcall{} -> do_pseudo_tailcall(I, TempMap, Strategy); #smull{} -> do_smull(I, TempMap, Strategy); @@ -108,18 +109,25 @@ do_pseudo_li(I=#pseudo_li{dst=Dst}, TempMap, Strategy) -> do_pseudo_move(I=#pseudo_move{dst=Dst,src=Src}, TempMap, Strategy) -> %% Either Dst or Src (but not both) may be a pseudo temp. - %% pseudo_move and pseudo_tailcall are special cases: in - %% all other instructions, all temps must be non-pseudos - %% after register allocation. - case temp_is_spilled(Dst, TempMap) of - true -> % Src must not be a pseudo - {FixSrc,NewSrc,DidSpill} = fix_src1(Src, TempMap, Strategy), - NewI = I#pseudo_move{src=NewSrc}, - {FixSrc ++ [NewI], DidSpill}; + %% pseudo_move, pseudo_spill_move, and pseudo_tailcall + %% are special cases: in all other instructions, all + %% temps must be non-pseudos after register allocation. + case temp_is_spilled(Dst, TempMap) + andalso temp_is_spilled(Dst, TempMap) + of + true -> % Turn into pseudo_spill_move + Temp = clone(Src, temp1(Strategy)), + NewI = #pseudo_spill_move{dst=Dst, temp=Temp, src=Src}, + {[NewI], true}; _ -> {[I], false} end. +do_pseudo_spill_move(I = #pseudo_spill_move{temp=Temp}, TempMap, _Strategy) -> + %% Temp is above the low water mark and must not have been spilled + false = temp_is_spilled(Temp, TempMap), + {[I], false}. % nothing to do + do_pseudo_switch(I=#pseudo_switch{jtab=JTab,index=Index}, TempMap, Strategy) -> {FixJTab,NewJTab,DidSpill1} = fix_src1(JTab, TempMap, Strategy), {FixIndex,NewIndex,DidSpill2} = fix_src2(Index, TempMap, Strategy), diff --git a/lib/hipe/arm/hipe_arm_subst.erl b/lib/hipe/arm/hipe_arm_subst.erl index 7510c197bd..4ff245f414 100644 --- a/lib/hipe/arm/hipe_arm_subst.erl +++ b/lib/hipe/arm/hipe_arm_subst.erl @@ -13,7 +13,7 @@ %% limitations under the License. -module(hipe_arm_subst). --export([insn_temps/2]). +-export([insn_temps/2, insn_lbls/2]). -include("hipe_arm.hrl"). %% These should be moved to hipe_arm and exported @@ -31,6 +31,7 @@ -type am3() :: #am3{}. -type arg() :: temp() | integer(). -type funv() :: #arm_mfa{} | #arm_prim{} | temp(). +-type label() :: non_neg_integer(). -type insn() :: tuple(). % for now -type subst_fun() :: fun((temp()) -> temp()). @@ -58,6 +59,8 @@ insn_temps(T, I) -> #pseudo_call{funv=F} -> I#pseudo_call{funv=funv_temps(T, F)}; #pseudo_call_prepare{} -> I; #pseudo_li{dst=D} -> I#pseudo_li{dst=T(D)}; + #pseudo_spill_move{dst=D,temp=U,src=S} -> + I#pseudo_spill_move{dst=T(D),temp=T(U),src=T(S)}; #pseudo_switch{jtab=J=#arm_temp{},index=Ix=#arm_temp{}} -> I#pseudo_switch{jtab=T(J),index=T(Ix)}; #pseudo_tailcall{funv=F,stkargs=Stk} -> @@ -103,3 +106,22 @@ funv_temps(SubstTemp, T=#arm_temp{}) -> SubstTemp(T). -spec arg_temps(subst_fun(), arg()) -> arg(). arg_temps(_SubstTemp, Imm) when is_integer(Imm) -> Imm; arg_temps(SubstTemp, T=#arm_temp{}) -> SubstTemp(T). + +-type lbl_subst_fun() :: fun((label()) -> label()). + +%% @doc Maps over the branch targets in an instruction +-spec insn_lbls(lbl_subst_fun(), insn()) -> insn(). +insn_lbls(SubstLbl, I) -> + case I of + #b_label{label=Label} -> + I#b_label{label=SubstLbl(Label)}; + #pseudo_bc{true_label=T, false_label=F} -> + I#pseudo_bc{true_label=SubstLbl(T), false_label=SubstLbl(F)}; + #pseudo_call{sdesc=Sdesc, contlab=Contlab} -> + I#pseudo_call{sdesc=sdesc_lbls(SubstLbl, Sdesc), + contlab=SubstLbl(Contlab)} + end. + +sdesc_lbls(_SubstLbl, Sdesc=#arm_sdesc{exnlab=[]}) -> Sdesc; +sdesc_lbls(SubstLbl, Sdesc=#arm_sdesc{exnlab=Exnlab}) -> + Sdesc#arm_sdesc{exnlab=SubstLbl(Exnlab)}. diff --git a/lib/hipe/icode/hipe_beam_to_icode.erl b/lib/hipe/icode/hipe_beam_to_icode.erl index 610578dfbc..2abecf7f18 100644 --- a/lib/hipe/icode/hipe_beam_to_icode.erl +++ b/lib/hipe/icode/hipe_beam_to_icode.erl @@ -513,6 +513,19 @@ trans_fun([{test,test_arity,{f,Lbl},[Reg,N]}|Instructions], Env) -> I = hipe_icode:mk_type([trans_arg(Reg)],{tuple,N}, hipe_icode:label_name(True),map_label(Lbl)), [I,True | trans_fun(Instructions,Env)]; +%%--- test_is_tagged_tuple --- +trans_fun([{test,is_tagged_tuple,{f,Lbl},[Reg,N,Atom]}|Instructions], Env) -> + TrueArity = mk_label(new), + IArity = hipe_icode:mk_type([trans_arg(Reg)],{tuple,N}, + hipe_icode:label_name(TrueArity),map_label(Lbl)), + Var = hipe_icode:mk_new_var(), + IGet = hipe_icode:mk_primop([Var], + #unsafe_element{index=1}, + [trans_arg(Reg)]), + TrueAtom = mk_label(new), + IEQ = hipe_icode:mk_type([Var], Atom, hipe_icode:label_name(TrueAtom), + map_label(Lbl)), + [IArity,TrueArity,IGet,IEQ,TrueAtom | trans_fun(Instructions,Env)]; %%--- is_map --- trans_fun([{test,is_map,{f,Lbl},[Arg]}|Instructions], Env) -> {Code,Env1} = trans_type_test(map,Lbl,Arg,Env), diff --git a/lib/hipe/llvm/hipe_llvm_merge.erl b/lib/hipe/llvm/hipe_llvm_merge.erl index 6e891ac3b0..58d862fbb2 100644 --- a/lib/hipe/llvm/hipe_llvm_merge.erl +++ b/lib/hipe/llvm/hipe_llvm_merge.erl @@ -13,7 +13,7 @@ finalize(CompiledCode, Closures, Exports) -> Code = [{MFA, [], ConstTab} || {MFA, _, _ , ConstTab, _, _} <- CompiledCode1], {ConstAlign, ConstSize, ConstMap, RefsFromConsts} = - hipe_pack_constants:pack_constants(Code, ?ARCH_REGISTERS:alignment()), + hipe_pack_constants:pack_constants(Code), %% Compute total code size separately as a sanity check for alignment CodeSize = compute_code_size(CompiledCode1, 0), %% io:format("Code Size (pre-computed): ~w~n", [CodeSize]), diff --git a/lib/hipe/main/hipe.app.src b/lib/hipe/main/hipe.app.src index af2c02006d..de0b255c01 100644 --- a/lib/hipe/main/hipe.app.src +++ b/lib/hipe/main/hipe.app.src @@ -76,6 +76,7 @@ hipe_arm_specific, hipe_arm_subst, hipe_bb, + hipe_bb_weights, hipe_beam_to_icode, hipe_coalescing_regalloc, hipe_consttab, @@ -83,6 +84,7 @@ hipe_digraph, hipe_dominators, hipe_dot, + hipe_dsets, hipe_gen_cfg, hipe_gensym, hipe_graph_coloring_regalloc, @@ -146,9 +148,11 @@ hipe_ppc_specific_fp, hipe_ppc_subst, hipe_profile, + hipe_range_split, hipe_reg_worklists, hipe_regalloc_loop, hipe_regalloc_prepass, + hipe_restore_reuse, hipe_rtl, hipe_rtl_arch, hipe_rtl_arith_32, diff --git a/lib/hipe/main/hipe.erl b/lib/hipe/main/hipe.erl index fff397b060..19b4e8bfe2 100644 --- a/lib/hipe/main/hipe.erl +++ b/lib/hipe/main/hipe.erl @@ -1230,6 +1230,18 @@ option_text(regalloc) -> " optimistic - another variant of a coalescing allocator"; option_text(remove_comments) -> "Strip comments from intermediate code"; +option_text(ra_range_split) -> + "Split live ranges of temporaries live over call instructions\n" + "before performing register allocation.\n" + "Heuristically tries to move stack accesses to the cold path of function.\n" + "This range splitter is more sophisticated than 'ra_restore_reuse', but has\n" + "a significantly larger impact on compile time.\n" + "Should only be used with move coalescing register allocators."; +option_text(ra_restore_reuse) -> + "Split live ranges of temporaries such that straight-line\n" + "code will not need to contain multiple restores from the same stack\n" + "location.\n" + "Should only be used with move coalescing register allocators."; option_text(rtl_ssa) -> "Perform SSA conversion on the RTL level -- default starting at O2"; option_text(rtl_ssa_const_prop) -> @@ -1371,6 +1383,12 @@ opt_keys() -> pp_rtl_linear, ra_partitioned, ra_prespill, + ra_range_split, + ra_restore_reuse, + range_split_min_gain, + range_split_mode1_fudge, + range_split_weight_power, + range_split_weights, regalloc, remove_comments, rtl_ssa, @@ -1409,7 +1427,8 @@ o1_opts(TargetArch) -> icode_ssa_const_prop, icode_ssa_copy_prop, icode_inline_bifs, rtl_ssa, rtl_ssa_const_prop, rtl_ssapre, spillmin_color, use_indexing, remove_comments, - binary_opt, {regalloc,coalescing} | o0_opts(TargetArch)], + binary_opt, {regalloc,coalescing}, ra_restore_reuse + | o0_opts(TargetArch)], case TargetArch of ultrasparc -> Common; @@ -1429,7 +1448,8 @@ o1_opts(TargetArch) -> o2_opts(TargetArch) -> Common = [icode_type, icode_call_elim, % icode_ssa_struct_reuse, - rtl_lcm | (o1_opts(TargetArch) -- [rtl_ssapre])], + ra_range_split, range_split_weights, % XXX: Having defaults here is ugly + rtl_lcm | (o1_opts(TargetArch) -- [rtl_ssapre, ra_restore_reuse])], case TargetArch of T when T =:= amd64 orelse T =:= ppc64 -> % 64-bit targets [icode_range | Common]; @@ -1477,6 +1497,9 @@ opt_negations() -> {no_pp_rtl_ssapre, pp_rtl_ssapre}, {no_ra_partitioned, ra_partitioned}, {no_ra_prespill, ra_prespill}, + {no_ra_range_split, ra_range_split}, + {no_ra_restore_reuse, ra_restore_reuse}, + {no_range_split_weights, range_split_weights}, {no_remove_comments, remove_comments}, {no_rtl_ssa, rtl_ssa}, {no_rtl_ssa_const_prop, rtl_ssa_const_prop}, diff --git a/lib/hipe/misc/hipe_consttab.erl b/lib/hipe/misc/hipe_consttab.erl index 64e3d3ccaa..741bdb2094 100644 --- a/lib/hipe/misc/hipe_consttab.erl +++ b/lib/hipe/misc/hipe_consttab.erl @@ -63,9 +63,7 @@ %% A hipe_consttab is a tuple {Data, ReferedLabels, NextConstLabel} %% @type hipe_constlbl(). %% An abstract datatype for referring to data. -%% @type element_type() = byte | word | ctab_array() -%% @type ctab_array() = {ctab_array, Type::element_type(), -%% NoElements::pos_integer()} +%% @type element_type() = byte | word %% @type block() = [integer() | label_ref()] %% @type label_ref() = {label, Label::code_label()} %% @type code_label() = hipe_sparc:label_name() | hipe_x86:label_name() @@ -110,8 +108,7 @@ -type label_ref() :: {'label', code_label()}. -type block() :: [hipe_constlbl() | label_ref()]. --type ctab_array() :: {'ctab_array', 'byte' | 'word', pos_integer()}. --type element_type() :: 'byte' | 'word' | ctab_array(). +-type element_type() :: 'byte' | 'word'. -type sort_order() :: term(). % XXX: FIXME @@ -187,7 +184,7 @@ insert_block({ConstTab, RefToLabels, NextLabel}, ElementType, InitList) -> ReferredLabels = get_labels(InitList, []), NewRefTo = ReferredLabels ++ RefToLabels, {NewTa, Id} = insert_const({ConstTab, NewRefTo, NextLabel}, - block, word_size(), false, + block, size_of(ElementType), false, {ElementType,InitList}), {insert_backrefs(NewTa, Id, ReferredLabels), Id}. @@ -256,13 +253,9 @@ get_labels([], Acc) -> %% @spec size_of(element_type()) -> pos_integer() %% @doc Returns the size in bytes of an element_type. -%% The is_atom/1 guard in the clause handling arrays -%% constraints the argument to 'byte' | 'word' -spec size_of(element_type()) -> pos_integer(). size_of(byte) -> 1; -size_of(word) -> word_size(); -size_of({ctab_array,S,N}) when is_atom(S), is_integer(N), N > 0 -> - N * size_of(S). +size_of(word) -> word_size(). %% @spec decompose({element_type(), block()}) -> [byte()] %% @doc Turns a block into a list of bytes. diff --git a/lib/hipe/misc/hipe_pack_constants.erl b/lib/hipe/misc/hipe_pack_constants.erl index 9dd18bce0f..6736d1f503 100644 --- a/lib/hipe/misc/hipe_pack_constants.erl +++ b/lib/hipe/misc/hipe_pack_constants.erl @@ -13,7 +13,7 @@ %% limitations under the License. -module(hipe_pack_constants). --export([pack_constants/2, slim_refs/1, slim_constmap/1, +-export([pack_constants/1, slim_refs/1, slim_constmap/1, find_const/2, mk_data_relocs/2, slim_sorted_exportmap/3]). -include("hipe_consttab.hrl"). @@ -37,8 +37,8 @@ -record(pcm_entry, {mfa :: mfa(), label :: hipe_constlbl(), - const_num :: const_num(), - start :: addr(), + const_num :: const_num(), + start :: addr(), type :: 0 | 1 | 2, raw_data :: raw_data()}). -type pcm_entry() :: #pcm_entry{}. @@ -53,11 +53,11 @@ %%----------------------------------------------------------------------------- --spec pack_constants([{mfa(),[_],hipe_consttab()}], ct_alignment()) -> +-spec pack_constants([{mfa(),[_],hipe_consttab()}]) -> {ct_alignment(), non_neg_integer(), packed_const_map(), mfa_refs_map()}. -pack_constants(Data, Align) -> - pack_constants(Data, 0, Align, 0, [], []). +pack_constants(Data) -> + pack_constants(Data, 0, 1, 0, [], []). % 1 = byte alignment pack_constants([{MFA,_,ConstTab}|Rest], Size, Align, ConstNo, Acc, Refs) -> Labels = hipe_consttab:labels(ConstTab), diff --git a/lib/hipe/opt/Makefile b/lib/hipe/opt/Makefile index 684d6f45b4..5a729d04ae 100644 --- a/lib/hipe/opt/Makefile +++ b/lib/hipe/opt/Makefile @@ -43,7 +43,8 @@ RELSYSDIR = $(RELEASE_PATH)/lib/hipe-$(VSN) # ---------------------------------------------------- # Target Specs # ---------------------------------------------------- -MODULES = hipe_spillmin hipe_spillmin_color hipe_spillmin_scan +MODULES = hipe_spillmin hipe_spillmin_color hipe_spillmin_scan \ + hipe_bb_weights HRL_FILES= ERL_FILES= $(MODULES:%=%.erl) diff --git a/lib/hipe/opt/hipe_bb_weights.erl b/lib/hipe/opt/hipe_bb_weights.erl new file mode 100644 index 0000000000..8ef113b94c --- /dev/null +++ b/lib/hipe/opt/hipe_bb_weights.erl @@ -0,0 +1,449 @@ +%% -*- erlang-indent-level: 2 -*- +%% +%% 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. +%% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%@doc +%% BASIC BLOCK WEIGHTING +%% +%% Computes basic block weights by using branch probabilities as weights in a +%% linear equation system, that is then solved using Gauss-Jordan Elimination. +%% +%% The equation system representation is intentionally sparse, since most blocks +%% have at most two successors. +-module(hipe_bb_weights). +-export([compute/3, compute_fast/3, weight/2, call_exn_pred/0]). +-export_type([bb_weights/0]). + +-compile(inline). + +%%-define(DO_ASSERT,1). +%%-define(DEBUG,1). +-include("../main/hipe.hrl"). + +%% If the equation system is large, it might take too long to solve it exactly. +%% Thus, if there are more than ?HEUR_MAX_SOLVE labels, we use the iterative +%% approximation. +-define(HEUR_MAX_SOLVE, 10000). + +-opaque bb_weights() :: #{label() => float()}. + +-type cfg() :: any(). +-type target_module() :: module(). +-type target_context() :: any(). +-type target() :: {target_module(), target_context()}. + +-type label() :: integer(). +-type var() :: label(). +-type assignment() :: {var(), float()}. +-type eq_assoc() :: [{var(), key()}]. +-type solution() :: [assignment()]. + +%% Constant. Predicted probability of a call resulting in an exception. +-spec call_exn_pred() -> float(). +call_exn_pred() -> 0.01. + +-spec compute(cfg(), target_module(), target_context()) -> bb_weights(). +compute(CFG, TgtMod, TgtCtx) -> + Target = {TgtMod, TgtCtx}, + Labels = labels(CFG, Target), + if length(Labels) > ?HEUR_MAX_SOLVE -> + ?debug_msg("~w: Too many labels (~w), approximating.~n", + [?MODULE, length(Labels)]), + compute_fast(CFG, TgtMod, TgtCtx); + true -> + {EqSys, EqAssoc} = build_eq_system(CFG, Labels, Target), + case solve(EqSys, EqAssoc) of + {ok, Solution} -> + maps:from_list(Solution) + end + end. + +-spec build_eq_system(cfg(), [label()], target()) -> {eq_system(), eq_assoc()}. +build_eq_system(CFG, Labels, Target) -> + StartLb = hipe_gen_cfg:start_label(CFG), + EQS0 = eqs_new(), + {EQS1, Assoc} = build_eq_system(Labels, CFG, Target, [], EQS0), + {StartLb, StartKey} = lists:keyfind(StartLb, 1, Assoc), + StartRow0 = eqs_get(StartKey, EQS1), + StartRow = row_set_const(-1.0, StartRow0), % -1.0 since StartLb coef is -1.0 + EQS = eqs_put(StartKey, StartRow, EQS1), + {EQS, Assoc}. + +build_eq_system([], _CFG, _Target, Map, EQS) -> {EQS, lists:reverse(Map)}; +build_eq_system([L|Ls], CFG, Target, Map, EQS0) -> + PredProb = pred_prob(L, CFG, Target), + {Key, EQS} = eqs_insert(row_new([{L, -1.0}|PredProb], 0.0), EQS0), + build_eq_system(Ls, CFG, Target, [{L, Key}|Map], EQS). + +pred_prob(L, CFG, Target) -> + [begin + BB = bb(CFG, Pred, Target), + Ps = branch_preds(hipe_bb:last(BB), Target), + ?ASSERT(length(lists:ukeysort(1, Ps)) + =:= length(hipe_gen_cfg:succ(CFG, Pred))), + case lists:keyfind(L, 1, Ps) of + {L, Prob} when is_float(Prob) -> {Pred, Prob} + end + end || Pred <- hipe_gen_cfg:pred(CFG, L)]. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +-spec triangelise(eq_system(), eq_assoc()) -> {eq_system(), eq_assoc()}. +triangelise(EQS, VKs) -> + triangelise_1(mk_triix(EQS, VKs), []). + +triangelise_1(TIX0, Acc) -> + case triix_is_empty(TIX0) of + true -> {triix_eqs(TIX0), lists:reverse(Acc)}; + false -> + {V,Key,TIX1} = triix_pop_smallest(TIX0), + Row0 = triix_get(Key, TIX1), + case row_get(V, Row0) of + Coef when Coef > -0.0001, Coef < 0.0001 -> + throw(error); + _ -> + Row = row_normalise(V, Row0), + TIX2 = triix_put(Key, Row, TIX1), + TIX = eliminate_triix(V, Key, Row, TIX2), + triangelise_1(TIX, [{V,Key}|Acc]) + end + end. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Triangelisation maintains its own index, outside of eqs. This index is +%% essentially a BST (used as a heap) of all equations by size, with {Key,Var} +%% as the values and only containing a subset of all the keys in the whole +%% equation system. The key operation is triix_pop_smallest/1, which pops a +%% {Key,Var} from the heap corresponding to one of the smallest equations. This +%% is critical in order to prevent the equations from growing during +%% triangelisation, which would make the algorithm O(n^2) in the common case. +-type tri_eq_system() :: {eq_system(), + gb_trees:tree(non_neg_integer(), + gb_trees:tree(key(), var()))}. + +triix_eqs({EQS, _}) -> EQS. +triix_get(Key, {EQS, _}) -> eqs_get(Key, EQS). +triix_is_empty({_, Tree}) -> gb_trees:is_empty(Tree). +triix_lookup(V, {EQS, _}) -> eqs_lookup(V, EQS). + +mk_triix(EQS, VKs) -> + {EQS, + lists:foldl(fun({V,Key}, Tree) -> + Size = row_size(eqs_get(Key, EQS)), + sitree_insert(Size, Key, V, Tree) + end, gb_trees:empty(), VKs)}. + +sitree_insert(Size, Key, V, SiTree) -> + SubTree1 = + case gb_trees:lookup(Size, SiTree) of + none -> gb_trees:empty(); + {value, SubTree0} -> SubTree0 + end, + SubTree = gb_trees:insert(Key, V, SubTree1), + gb_trees:enter(Size, SubTree, SiTree). + +sitree_update_subtree(Size, SubTree, SiTree) -> + case gb_trees:is_empty(SubTree) of + true -> gb_trees:delete(Size, SiTree); + false -> gb_trees:update(Size, SubTree, SiTree) + end. + +triix_put(Key, Row, {EQS, Tree0}) -> + OldSize = row_size(eqs_get(Key, EQS)), + case row_size(Row) of + OldSize -> {eqs_put(Key, Row, EQS), Tree0}; + Size -> + Tree = + case gb_trees:lookup(OldSize, Tree0) of + none -> Tree0; + {value, SubTree0} -> + case gb_trees:lookup(Key, SubTree0) of + none -> Tree0; + {value, V} -> + SubTree = gb_trees:delete(Key, SubTree0), + Tree1 = sitree_update_subtree(OldSize, SubTree, Tree0), + sitree_insert(Size, Key, V, Tree1) + end + end, + {eqs_put(Key, Row, EQS), Tree} + end. + +triix_pop_smallest({EQS, Tree}) -> + {Size, SubTree0} = gb_trees:smallest(Tree), + {Key, V, SubTree} = gb_trees:take_smallest(SubTree0), + {V, Key, {EQS, sitree_update_subtree(Size, SubTree, Tree)}}. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +row_normalise(Var, Row) -> + %% Normalise v's coef to 1.0 + %% row_set_coef ensures the coef is exactly 1.0 (no rounding errors) + row_set_coef(Var, 1.0, row_scale(Row, 1.0/row_get(Var, Row))). + +%% Precondition: Row must be normalised; i.e. Vars coef must be 1.0 (mod +%% rounding errors) +-spec eliminate(var(), key(), row(), eq_system()) -> eq_system(). +eliminate(Var, Key, Row, TIX0) -> + eliminate_abstr(Var, Key, Row, TIX0, + fun eqs_get/2, fun eqs_lookup/2, fun eqs_put/3). + +-spec eliminate_triix(var(), key(), row(), tri_eq_system()) -> tri_eq_system(). +eliminate_triix(Var, Key, Row, TIX0) -> + eliminate_abstr(Var, Key, Row, TIX0, + fun triix_get/2, fun triix_lookup/2, fun triix_put/3). + +%% The same function implemented for two data types, eqs and triix. +-compile({inline, eliminate_abstr/7}). +-spec eliminate_abstr(var(), key(), row(), ADT, fun((key(), ADT) -> row()), + fun((var(), ADT) -> [key()]), + fun((key(), row(), ADT) -> ADT)) -> ADT. +eliminate_abstr(Var, Key, Row, ADT0, GetFun, LookupFun, PutFun) -> + ?ASSERT(1.0 =:= row_get(Var, Row)), + ADT = + lists:foldl(fun(RK, ADT1) when RK =:= Key -> ADT1; + (RK, ADT1) -> + R = GetFun(RK, ADT1), + PutFun(RK, row_addmul(R, Row, -row_get(Var, R)), ADT1) + end, ADT0, LookupFun(Var, ADT0)), + [Key] = LookupFun(Var, ADT), + ADT. + +-spec solve(eq_system(), eq_assoc()) -> error | {ok, solution()}. +solve(EQS0, EqAssoc0) -> + try triangelise(EQS0, EqAssoc0) + of {EQS1, EqAssoc} -> + {ok, solve_1(EqAssoc, maps:from_list(EqAssoc), EQS1, [])} + catch error -> error + end. + +solve_1([], _VarEqs, _EQS, Acc) -> Acc; +solve_1([{V,K}|Ps], VarEqs, EQS0, Acc0) -> + Row0 = eqs_get(K, EQS0), + VarsToKill = [Var || {Var, _} <- row_coefs(Row0), Var =/= V], + Row1 = kill_vars(VarsToKill, VarEqs, EQS0, Row0), + [{V,_}] = row_coefs(Row1), % assertion + Row = row_normalise(V, Row1), + [{V,1.0}] = row_coefs(Row), % assertion + EQS = eliminate(V, K, Row, EQS0), + [K] = eqs_lookup(V, EQS), + solve_1(Ps, VarEqs, eqs_remove(K, EQS), [{V, row_const(Row)}|Acc0]). + +kill_vars([], _VarEqs, _EQS, Row) -> Row; +kill_vars([V|Vs], VarEqs, EQS, Row0) -> + VRow0 = eqs_get(maps:get(V, VarEqs), EQS), + VRow = row_normalise(V, VRow0), + ?ASSERT(1.0 =:= row_get(V, VRow)), + Row = row_addmul(Row0, VRow, -row_get(V, Row0)), + ?ASSERT(0.0 =:= row_get(V, Row)), % V has been killed + kill_vars(Vs, VarEqs, EQS, Row). + +-spec weight(label(), bb_weights()) -> float(). +weight(Lbl, Weights) -> + maps:get(Lbl, Weights). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Row datatype +%% Invariant: No 0.0 coefficiets! +-spec row_empty() -> row(). +row_empty() -> {orddict:new(), 0.0}. + +-spec row_new([{var(), float()}], float()) -> row(). +row_new(Coefs, Const) when is_float(Const) -> + row_ensure_invar({row_squash_multiples(lists:keysort(1, Coefs)), Const}). + +row_squash_multiples([{K, C1},{K, C2}|Ps]) -> + row_squash_multiples([{K,C1+C2}|Ps]); +row_squash_multiples([P|Ps]) -> [P|row_squash_multiples(Ps)]; +row_squash_multiples([]) -> []. + +row_ensure_invar({Coef, Const}) -> + {orddict:filter(fun(_, 0.0) -> false; (_, F) when is_float(F) -> true end, + Coef), Const}. + +row_const({_, Const}) -> Const. +row_coefs({Coefs, _}) -> orddict:to_list(Coefs). +row_size({Coefs, _}) -> orddict:size(Coefs). + +row_get(Var, {Coefs, _}) -> + case lists:keyfind(Var, 1, Coefs) of + false -> 0.0; + {_, Coef} -> Coef + end. + +row_set_coef(Var, 0.0, {Coefs, Const}) -> + {orddict:erase(Var, Coefs), Const}; +row_set_coef(Var, Coef, {Coefs, Const}) -> + {orddict:store(Var, Coef, Coefs), Const}. + +row_set_const(Const, {Coefs, _}) -> {Coefs, Const}. + +%% Lhs + Rhs*Factor +-spec row_addmul(row(), row(), float()) -> row(). +row_addmul({LhsCoefs, LhsConst}, {RhsCoefs, RhsConst}, Factor) + when is_float(Factor) -> + Coefs = row_addmul_coefs(LhsCoefs, RhsCoefs, Factor), + Const = LhsConst + RhsConst * Factor, + {Coefs, Const}. + +row_addmul_coefs(Ls, [], Factor) when is_float(Factor) -> Ls; +row_addmul_coefs([], Rs, Factor) when is_float(Factor) -> + row_scale_coefs(Rs, Factor); +row_addmul_coefs([L={LV, _}|Ls], Rs=[{RV,_}|_], Factor) + when LV < RV, is_float(Factor) -> + [L|row_addmul_coefs(Ls, Rs, Factor)]; +row_addmul_coefs(Ls=[{LV, _}|_], [{RV, RC}|Rs], Factor) + when LV > RV, is_float(RC), is_float(Factor) -> + [{RV, RC*Factor}|row_addmul_coefs(Ls, Rs, Factor)]; +row_addmul_coefs([{V, LC}|Ls], [{V, RC}|Rs], Factor) + when is_float(LC), is_float(RC), is_float(Factor) -> + case LC + RC * Factor of + 0.0 -> row_addmul_coefs(Ls, Rs, Factor); + C -> [{V,C}|row_addmul_coefs(Ls, Rs, Factor)] + end. + +row_scale(_, 0.0) -> row_empty(); +row_scale({RowCoefs, RowConst}, Factor) when is_float(Factor) -> + {row_scale_coefs(RowCoefs, Factor), RowConst * Factor}. + +row_scale_coefs([{V,C}|Cs], Factor) when is_float(Factor), is_float(C) -> + [{V,C*Factor}|row_scale_coefs(Cs, Factor)]; +row_scale_coefs([], Factor) when is_float(Factor) -> + []. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Equation system ADT +%% +%% Stores a linear equation system, allowing for efficient updates and efficient +%% queries for all equations mentioning a variable. +%% +%% It is sort of like a "database" table of {Primary, Terms, Const} indexed both +%% on Primary as well as the vars (map keys) in Terms. +-type row() :: {Terms :: orddict:orddict(var(), float()), + Const :: float()}. +-type key() :: non_neg_integer(). +-type rev_index() :: #{var() => ordsets:ordset(key())}. +-record(eq_system, { + rows = #{} :: #{key() => row()}, + revidx = revidx_empty() :: rev_index(), + next_key = 0 :: key() + }). +-type eq_system() :: #eq_system{}. + +eqs_new() -> #eq_system{}. + +-spec eqs_insert(row(), eq_system()) -> {key(), eq_system()}. +eqs_insert(Row, EQS=#eq_system{next_key=NextKey0}) -> + Key = NextKey0, + NextKey = NextKey0 + 1, + {Key, eqs_insert(Key, Row, EQS#eq_system{next_key=NextKey})}. + +eqs_insert(Key, Row, EQS=#eq_system{rows=Rows, revidx=RevIdx0}) -> + RevIdx = revidx_add(Key, Row, RevIdx0), + EQS#eq_system{rows=Rows#{Key => Row}, revidx=RevIdx}. + +eqs_put(Key, Row, EQS0) -> + eqs_insert(Key, Row, eqs_remove(Key, EQS0)). + +eqs_remove(Key, EQS=#eq_system{rows=Rows, revidx=RevIdx0}) -> + OldRow = maps:get(Key, Rows), + RevIdx = revidx_remove(Key, OldRow, RevIdx0), + EQS#eq_system{rows = maps:remove(Key, Rows), revidx=RevIdx}. + +-spec eqs_get(key(), eq_system()) -> row(). +eqs_get(Key, #eq_system{rows=Rows}) -> maps:get(Key, Rows). + +%% Keys of all equations containing a nonzero coefficient for Var +-spec eqs_lookup(var(), eq_system()) -> ordsets:ordset(key()). +eqs_lookup(Var, #eq_system{revidx=RevIdx}) -> maps:get(Var, RevIdx). + +%% eqs_rows(#eq_system{rows=Rows}) -> maps:to_list(Rows). + +%% eqs_print(EQS) -> +%% lists:foreach(fun({_, Row}) -> +%% row_print(Row) +%% end, lists:sort(eqs_rows(EQS))). + +%% row_print(Row) -> +%% CoefStrs = [io_lib:format("~wl~w", [Coef, Var]) +%% || {Var, Coef} <- row_coefs(Row)], +%% CoefStr = lists:join(" + ", CoefStrs), +%% io:format("~w = ~s~n", [row_const(Row), CoefStr]). + +revidx_empty() -> #{}. + +-spec revidx_add(key(), row(), rev_index()) -> rev_index(). +revidx_add(Key, Row, RevIdx0) -> + orddict:fold(fun(Var, _Coef, RevIdx1) -> + ?ASSERT(_Coef /= 0.0), + RevIdx1#{Var => ordsets:add_element( + Key, maps:get(Var, RevIdx1, ordsets:new()))} + end, RevIdx0, row_coefs(Row)). + +-spec revidx_remove(key(), row(), rev_index()) -> rev_index(). +revidx_remove(Key, {Coefs, _}, RevIdx0) -> + orddict:fold(fun(Var, _Coef, RevIdx1) -> + case RevIdx1 of + #{Var := Keys0} -> + case ordsets:del_element(Key, Keys0) of + [] -> maps:remove(Var, RevIdx1); + Keys -> RevIdx1#{Var := Keys} + end + end + end, RevIdx0, Coefs). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +-define(FAST_ITERATIONS, 5). + +%% @doc Computes a rough approximation of BB weights. The approximation is +%% particularly poor (converges slowly) for recursive functions and loops. +-spec compute_fast(cfg(), target_module(), target_context()) -> bb_weights(). +compute_fast(CFG, TgtMod, TgtCtx) -> + Target = {TgtMod, TgtCtx}, + StartLb = hipe_gen_cfg:start_label(CFG), + RPO = reverse_postorder(CFG, Target), + PredProbs = [{L, pred_prob(L, CFG, Target)} || L <- RPO, L =/= StartLb], + Probs0 = (maps:from_list([{L, 0.0} || L <- RPO]))#{StartLb := 1.0}, + fast_iterate(?FAST_ITERATIONS, PredProbs, Probs0). + +fast_iterate(0, _Pred, Probs) -> Probs; +fast_iterate(Iters, Pred, Probs0) -> + fast_iterate(Iters-1, Pred, + fast_one(Pred, Probs0)). + +fast_one([{L, Pred}|Ls], Probs0) -> + Weight = fast_sum(Pred, Probs0, 0.0), + Probs = Probs0#{L => Weight}, + fast_one(Ls, Probs); +fast_one([], Probs) -> + Probs. + +fast_sum([{P,EWt}|Pred], Probs, Acc) when is_float(EWt), is_float(Acc) -> + case Probs of + #{P := PWt} when is_float(PWt) -> + fast_sum(Pred, Probs, Acc + PWt * EWt) + end; +fast_sum([], _Probs, Acc) when is_float(Acc) -> + Acc. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Target module interface functions +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +-define(TGT_IFACE_0(N), N( {M,C}) -> M:N( C)). +-define(TGT_IFACE_1(N), N(A1, {M,C}) -> M:N(A1, C)). +-define(TGT_IFACE_2(N), N(A1,A2, {M,C}) -> M:N(A1,A2, C)). +-define(TGT_IFACE_3(N), N(A1,A2,A3,{M,C}) -> M:N(A1,A2,A3,C)). + +?TGT_IFACE_2(bb). +?TGT_IFACE_1(branch_preds). +?TGT_IFACE_1(labels). +?TGT_IFACE_1(reverse_postorder). diff --git a/lib/hipe/opt/hipe_spillmin_color.erl b/lib/hipe/opt/hipe_spillmin_color.erl index 41f1972df7..f87d9a5b61 100644 --- a/lib/hipe/opt/hipe_spillmin_color.erl +++ b/lib/hipe/opt/hipe_spillmin_color.erl @@ -166,9 +166,13 @@ remap_temp_map0(Cols, [_Y|Ys], SpillIndex) -> %% build_ig(CFG, Live, Target, TempMap) -> - try build_ig0(CFG, Live, Target, TempMap) - catch error:Rsn -> exit({regalloc, build_ig, Rsn}) - end. + TempMapping = map_spilled_temporaries(TempMap), + TempMappingTable = setup_ets(TempMapping), + NumSpilled = length(TempMapping), + IG = build_ig_bbs(labels(CFG, Target), CFG, Live, empty_ig(NumSpilled), + Target, TempMap, TempMappingTable), + ets:delete(TempMappingTable), + {normalize_ig(IG), NumSpilled}. %% Creates an ETS table consisting of the keys given in List, with the values %% being an integer which is the position of the key in List. @@ -183,15 +187,6 @@ setup_ets0([X|Xs], Table, N) -> ets:insert(Table, {X, N}), setup_ets0(Xs, Table, N+1). -build_ig0(CFG, Live, Target, TempMap) -> - TempMapping = map_spilled_temporaries(TempMap), - TempMappingTable = setup_ets(TempMapping), - NumSpilled = length(TempMapping), - IG = build_ig_bbs(labels(CFG, Target), CFG, Live, empty_ig(NumSpilled), - Target, TempMap, TempMappingTable), - ets:delete(TempMappingTable), - {normalize_ig(IG), NumSpilled}. - build_ig_bbs([], _CFG, _Live, IG, _Target, _TempMap, _TempMapping) -> IG; build_ig_bbs([L|Ls], CFG, Live, IG, Target, TempMap, TempMapping) -> @@ -212,16 +207,26 @@ build_ig_bb([X|Xs], LiveOut, IG, Target, TempMap, TempMapping) -> build_ig_bb(Xs, LiveOut, IG, Target, TempMap, TempMapping), build_ig_instr(X, Live, NewIG, Target, TempMap, TempMapping). -build_ig_instr(X, Live, IG, Target, TempMap, TempMapping) -> +build_ig_instr(X, Live0, IG0, Target, TempMap, TempMapping) -> {Def, Use} = def_use(X, Target, TempMap), - ?report3("Live ~w\n~w : Def: ~w Use ~w\n",[Live, X, Def,Use]), + ?report3("Live ~w\n~w : Def: ~w Use ~w\n",[Live0, X, Def,Use]), DefListMapped = list_map(Def, TempMapping, []), UseListMapped = list_map(Use, TempMapping, []), DefSetMapped = ordsets:from_list(DefListMapped), UseSetMapped = ordsets:from_list(UseListMapped), - NewIG = interference_arcs(DefListMapped, ordsets:to_list(Live), IG), - NewLive = ordsets:union(UseSetMapped, ordsets:subtract(Live, DefSetMapped)), - {NewLive, NewIG}. + {Live1, IG1} = + analyze_move(X, Live0, IG0, Target, DefSetMapped, UseSetMapped), + IG = interference_arcs(DefListMapped, ordsets:to_list(Live1), IG1), + Live = ordsets:union(UseSetMapped, ordsets:subtract(Live1, DefSetMapped)), + {Live, IG}. + +analyze_move(X, Live0, IG0, Target, DefSetMapped, UseSetMapped) -> + case {is_spill_move(X, Target), DefSetMapped, UseSetMapped} of + {true, [Dst], [Src]} -> + {ordsets:del_element(Src, Live0), add_move(Src, Dst, IG0)}; + {_, _, _} -> + {Live0, IG0} + end. %% Given a list of Keys and an ets-table returns a list of the elements %% in Mapping corresponding to the Keys and appends Acc to this list. @@ -271,15 +276,6 @@ i_arcs(X, [Y|Ys], IG) -> %% throw an exception (the caller should retry with more stack slots) color(IG, StackSlots, NumNodes, Target) -> - try - color_0(IG, StackSlots, NumNodes, Target) - catch - error:Rsn -> - ?error_msg("Coloring failed with ~p~n", [Rsn]), - ?EXIT(Rsn) - end. - -color_0(IG, StackSlots, NumNodes, Target) -> ?report("simplification of IG~n", []), K = ordsets:size(StackSlots), Nodes = list_ig(IG), @@ -382,7 +378,8 @@ select_colors([{X,colorable}|Xs], IG, Cols, PhysRegs) -> select_color(X, IG, Cols, PhysRegs) -> UsedColors = get_colors(neighbors(X, IG), Cols), - Reg = select_unused_color(UsedColors, PhysRegs), + Preferences = get_colors(move_connected(X, IG), Cols), + Reg = select_unused_color(UsedColors, Preferences, PhysRegs), {Reg, set_color(X, Reg, Cols)}. %%%%%%%%%%%%%%%%%%%% @@ -396,10 +393,14 @@ get_colors([X|Xs], Cols) -> [R|get_colors(Xs, Cols)] end. -select_unused_color(UsedColors, PhysRegs) -> +select_unused_color(UsedColors, Preferences, PhysRegs) -> Summary = ordsets:from_list(UsedColors), - AvailRegs = ordsets:to_list(ordsets:subtract(PhysRegs, Summary)), - hd(AvailRegs). + case ordsets:subtract(ordsets:from_list(Preferences), Summary) of + [PreferredColor|_] -> PreferredColor; + _ -> + AvailRegs = ordsets:to_list(ordsets:subtract(PhysRegs, Summary)), + hd(AvailRegs) + end. push_colored(X, Stk) -> [{X, colorable} | Stk]. @@ -456,7 +457,11 @@ init_stackslots(NumSlots, Acc) -> %% %% Note: later on, we may wish to add 'move-related' support. --record(ig_info, {neighbors = [] :: [_], degree = 0 :: non_neg_integer()}). +-record(ig_info, { + neighbors = [] :: [_], + degree = 0 :: non_neg_integer(), + move_connected = [] :: [_] + }). empty_ig(NumNodes) -> hipe_vectors:new(NumNodes, #ig_info{}). @@ -467,16 +472,29 @@ degree(Info) -> neighbors(Info) -> Info#ig_info.neighbors. +move_connected(Info) -> + Info#ig_info.move_connected. + add_edge(X, X, IG) -> IG; add_edge(X, Y, IG) -> add_arc(X, Y, add_arc(Y, X, IG)). +add_move(X, X, IG) -> IG; +add_move(X, Y, IG) -> + add_move_arc(X, Y, add_move_arc(Y, X, IG)). + add_arc(X, Y, IG) -> Info = hipe_vectors:get(IG, X), Old = neighbors(Info), New = Info#ig_info{neighbors = [Y|Old]}, hipe_vectors:set(IG,X,New). +add_move_arc(X, Y, IG) -> + Info = hipe_vectors:get(IG, X), + Old = move_connected(Info), + New = Info#ig_info{move_connected = [Y|Old]}, + hipe_vectors:set(IG,X,New). + normalize_ig(IG) -> Size = hipe_vectors:size(IG), normalize_ig(Size-1, IG). @@ -486,7 +504,8 @@ normalize_ig(-1, IG) -> normalize_ig(I, IG) -> Info = hipe_vectors:get(IG, I), N = ordsets:from_list(neighbors(Info)), - NewInfo = Info#ig_info{neighbors = N, degree = length(N)}, + M = ordsets:subtract(ordsets:from_list(move_connected(Info)), N), + NewInfo = Info#ig_info{neighbors = N, degree = length(N), move_connected = M}, NewIG = hipe_vectors:set(IG, I, NewInfo), normalize_ig(I-1, NewIG). @@ -494,6 +513,10 @@ neighbors(X, IG) -> Info = hipe_vectors:get(IG, X), Info#ig_info.neighbors. +move_connected(X, IG) -> + Info = hipe_vectors:get(IG, X), + Info#ig_info.move_connected. + decrement_degree(X, IG) -> Info = hipe_vectors:get(IG, X), Degree = degree(Info), @@ -555,3 +578,6 @@ def_use(X, Target={TgtMod,TgtCtx}, TempMap) -> reg_names(Regs, {TgtMod,TgtCtx}) -> [TgtMod:reg_nr(X,TgtCtx) || X <- Regs]. + +is_spill_move(Instr, {TgtMod,TgtCtx}) -> + TgtMod:is_spill_move(Instr, TgtCtx). diff --git a/lib/hipe/ppc/hipe_ppc.erl b/lib/hipe/ppc/hipe_ppc.erl index df9f193fa3..63ecd0a0b8 100644 --- a/lib/hipe/ppc/hipe_ppc.erl +++ b/lib/hipe/ppc/hipe_ppc.erl @@ -98,6 +98,9 @@ pseudo_move_dst/1, pseudo_move_src/1, + mk_pseudo_spill_move/3, + is_pseudo_spill_move/1, + mk_pseudo_tailcall/4, pseudo_tailcall_func/1, pseudo_tailcall_stkargs/1, @@ -131,6 +134,9 @@ pseudo_fmove_dst/1, pseudo_fmove_src/1, + mk_pseudo_spill_fmove/3, + is_pseudo_spill_fmove/1, + mk_defun/8, defun_mfa/1, defun_formals/1, @@ -412,6 +418,10 @@ is_pseudo_move(I) -> case I of #pseudo_move{} -> true; _ -> false end. pseudo_move_dst(#pseudo_move{dst=Dst}) -> Dst. pseudo_move_src(#pseudo_move{src=Src}) -> Src. +mk_pseudo_spill_move(Dst, Temp, Src) -> + #pseudo_spill_move{dst=Dst, temp=Temp, src=Src}. +is_pseudo_spill_move(I) -> is_record(I, pseudo_spill_move). + mk_pseudo_tailcall(FunC, Arity, StkArgs, Linkage) -> #pseudo_tailcall{func=FunC, arity=Arity, stkargs=StkArgs, linkage=Linkage}. pseudo_tailcall_func(#pseudo_tailcall{func=FunC}) -> FunC. @@ -495,6 +505,10 @@ is_pseudo_fmove(I) -> case I of #pseudo_fmove{} -> true; _ -> false end. pseudo_fmove_dst(#pseudo_fmove{dst=Dst}) -> Dst. pseudo_fmove_src(#pseudo_fmove{src=Src}) -> Src. +mk_pseudo_spill_fmove(Dst, Temp, Src) -> + #pseudo_spill_fmove{dst=Dst, temp=Temp, src=Src}. +is_pseudo_spill_fmove(I) -> is_record(I, pseudo_spill_fmove). + mk_defun(MFA, Formals, IsClosure, IsLeaf, Code, Data, VarRange, LabelRange) -> #defun{mfa=MFA, formals=Formals, code=Code, data=Data, isclosure=IsClosure, isleaf=IsLeaf, diff --git a/lib/hipe/ppc/hipe_ppc.hrl b/lib/hipe/ppc/hipe_ppc.hrl index a96692c52e..3eef8be487 100644 --- a/lib/hipe/ppc/hipe_ppc.hrl +++ b/lib/hipe/ppc/hipe_ppc.hrl @@ -87,6 +87,7 @@ -record(pseudo_call_prepare, {nrstkargs}). -record(pseudo_li, {dst, imm}). -record(pseudo_move, {dst, src}). +-record(pseudo_spill_move, {dst, temp, src}). -record(pseudo_tailcall, {func, arity, stkargs, linkage}). -record(pseudo_tailcall_prepare, {}). -record(store, {stop, src, disp, base}). % non-indexed, non-update form @@ -99,6 +100,7 @@ -record(fp_binary, {fp_binop, dst, src1, src2}). -record(fp_unary, {fp_unop, dst, src}). -record(pseudo_fmove, {dst, src}). +-record(pseudo_spill_fmove, {dst, temp, src}). %%% Function definitions. diff --git a/lib/hipe/ppc/hipe_ppc_assemble.erl b/lib/hipe/ppc/hipe_ppc_assemble.erl index 66817837df..b0f57e5582 100644 --- a/lib/hipe/ppc/hipe_ppc_assemble.erl +++ b/lib/hipe/ppc/hipe_ppc_assemble.erl @@ -32,7 +32,7 @@ assemble(CompiledCode, Closures, Exports, Options) -> || {MFA, Defun} <- CompiledCode], %% {ConstAlign,ConstSize,ConstMap,RefsFromConsts} = - hipe_pack_constants:pack_constants(Code, hipe_rtl_arch:word_size()), + hipe_pack_constants:pack_constants(Code), %% {CodeSize,CodeBinary,AccRefs,LabelMap,ExportMap} = encode(translate(Code, ConstMap), Options), diff --git a/lib/hipe/ppc/hipe_ppc_cfg.erl b/lib/hipe/ppc/hipe_ppc_cfg.erl index f17c0ac503..d44d38f38d 100644 --- a/lib/hipe/ppc/hipe_ppc_cfg.erl +++ b/lib/hipe/ppc/hipe_ppc_cfg.erl @@ -21,8 +21,8 @@ bb/2, bb_add/3]). -export([postorder/1]). -export([linearise/1, params/1, reverse_postorder/1]). --export([arity/1]). -%%%-export([redirect_jmp/3, arity/1]). +-export([redirect_jmp/3, arity/1]). +-export([branch_preds/1]). %%% these tell cfg.inc what to define (ugly as hell) -define(BREADTH_ORDER,true). @@ -75,11 +75,30 @@ branch_successors(Branch) -> #pseudo_tailcall{} -> [] end. +branch_preds(Branch) -> + case Branch of + #bctr{labels=Labels} -> + Prob = 1.0/length(Labels), + [{L, Prob} || L <- Labels]; + #pseudo_bc{true_label=TrueLab,false_label=FalseLab,pred=Pred} -> + [{FalseLab, 1.0-Pred}, {TrueLab, Pred}]; + #pseudo_call{contlab=ContLab, sdesc=#ppc_sdesc{exnlab=[]}} -> + %% A function can still cause an exception, even if we won't catch it + [{ContLab, 1.0-hipe_bb_weights:call_exn_pred()}]; + #pseudo_call{contlab=ContLab, sdesc=#ppc_sdesc{exnlab=ExnLab}} -> + CallExnPred = hipe_bb_weights:call_exn_pred(), + [{ContLab, 1.0-CallExnPred}, {ExnLab, CallExnPred}]; + _ -> + case branch_successors(Branch) of + [] -> []; + [Single] -> [{Single, 1.0}] + end + end. + -ifdef(REMOVE_TRIVIAL_BBS_NEEDED). fails_to(_Instr) -> []. -endif. --ifdef(notdef). redirect_jmp(I, Old, New) -> case I of #b_label{label=Label} -> @@ -93,10 +112,16 @@ redirect_jmp(I, Old, New) -> if Old =:= FalseLab -> I1#pseudo_bc{false_label=New}; true -> I1 end; - %% handle pseudo_call too? - _ -> I + #pseudo_call{sdesc=SDesc0, contlab=ContLab0} -> + SDesc = case SDesc0 of + #ppc_sdesc{exnlab=Old} -> SDesc0#ppc_sdesc{exnlab=New}; + #ppc_sdesc{exnlab=_} -> SDesc0 + end, + ContLab = if Old =:= ContLab0 -> New; + true -> ContLab0 + end, + I#pseudo_call{sdesc=SDesc, contlab=ContLab} end. --endif. mk_goto(Label) -> hipe_ppc:mk_b_label(Label). diff --git a/lib/hipe/ppc/hipe_ppc_defuse.erl b/lib/hipe/ppc/hipe_ppc_defuse.erl index 9a99611493..d8a864f7d5 100644 --- a/lib/hipe/ppc/hipe_ppc_defuse.erl +++ b/lib/hipe/ppc/hipe_ppc_defuse.erl @@ -41,6 +41,7 @@ insn_def_gpr(I) -> #pseudo_call{} -> call_clobbered_gpr(); #pseudo_li{dst=Dst} -> [Dst]; #pseudo_move{dst=Dst} -> [Dst]; + #pseudo_spill_move{dst=Dst,temp=Temp} -> [Dst, Temp]; #pseudo_tailcall_prepare{} -> tailcall_clobbered_gpr(); #unary{dst=Dst} -> [Dst]; _ -> [] @@ -71,6 +72,7 @@ insn_use_gpr(I) -> #mtspr{src=Src} -> [Src]; #pseudo_call{sdesc=#ppc_sdesc{arity=Arity}} -> arity_use_gpr(Arity); #pseudo_move{src=Src} -> [Src]; + #pseudo_spill_move{src=Src} -> [Src]; #pseudo_tailcall{arity=Arity,stkargs=StkArgs} -> addsrcs(StkArgs, addtemps(tailcall_clobbered_gpr(), arity_use_gpr(Arity))); #store{src=Src,base=Base} -> addtemp(Src, [Base]); @@ -110,6 +112,7 @@ insn_def_fpr(I) -> #fp_binary{dst=Dst} -> [Dst]; #fp_unary{dst=Dst} -> [Dst]; #pseudo_fmove{dst=Dst} -> [Dst]; + #pseudo_spill_fmove{dst=Dst,temp=Temp} -> [Dst, Temp]; _ -> [] end. @@ -126,6 +129,7 @@ insn_use_fpr(I) -> #fp_binary{src1=Src1,src2=Src2} -> addtemp(Src1, [Src2]); #fp_unary{src=Src} -> [Src]; #pseudo_fmove{src=Src} -> [Src]; + #pseudo_spill_fmove{src=Src} -> [Src]; _ -> [] end. diff --git a/lib/hipe/ppc/hipe_ppc_frame.erl b/lib/hipe/ppc/hipe_ppc_frame.erl index a91cb18cc2..b88b75a5bd 100644 --- a/lib/hipe/ppc/hipe_ppc_frame.erl +++ b/lib/hipe/ppc/hipe_ppc_frame.erl @@ -66,10 +66,14 @@ do_insn(I, LiveOut, Context, FPoff) -> do_pseudo_call_prepare(I, FPoff); #pseudo_move{} -> {do_pseudo_move(I, Context, FPoff), FPoff}; + #pseudo_spill_move{} -> + {do_pseudo_spill_move(I, Context, FPoff), FPoff}; #pseudo_tailcall{} -> {do_pseudo_tailcall(I, Context), context_framesize(Context)}; #pseudo_fmove{} -> {do_pseudo_fmove(I, Context, FPoff), FPoff}; + #pseudo_spill_fmove{} -> + {do_pseudo_spill_fmove(I, Context, FPoff), FPoff}; _ -> {[I], FPoff} end. @@ -98,6 +102,22 @@ do_pseudo_move(I, Context, FPoff) -> end end. +do_pseudo_spill_move(I, Context, FPoff) -> + #pseudo_spill_move{dst=Dst,temp=Temp,src=Src} = I, + case temp_is_pseudo(Src) andalso temp_is_pseudo(Dst) of + false -> % Register allocator changed its mind, turn back to move + do_pseudo_move(hipe_ppc:mk_pseudo_move(Dst, Src), Context, FPoff); + true -> + SrcOffset = pseudo_offset(Src, FPoff, Context), + DstOffset = pseudo_offset(Dst, FPoff, Context), + case SrcOffset =:= DstOffset of + true -> []; % omit move-to-self + false -> + mk_load(hipe_ppc:ldop_word(), Temp, SrcOffset, mk_sp(), + mk_store(hipe_ppc:stop_word(), Temp, DstOffset, mk_sp(), [])) + end + end. + do_pseudo_fmove(I, Context, FPoff) -> Dst = hipe_ppc:pseudo_fmove_dst(I), Src = hipe_ppc:pseudo_fmove_src(I), @@ -115,6 +135,22 @@ do_pseudo_fmove(I, Context, FPoff) -> end end. +do_pseudo_spill_fmove(I, Context, FPoff) -> + #pseudo_spill_fmove{dst=Dst,temp=Temp,src=Src} = I, + case temp_is_pseudo(Src) andalso temp_is_pseudo(Dst) of + false -> % Register allocator changed its mind, turn back to move + do_pseudo_fmove(hipe_ppc:mk_pseudo_fmove(Dst, Src), Context, FPoff); + true -> + SrcOffset = pseudo_offset(Src, FPoff, Context), + DstOffset = pseudo_offset(Dst, FPoff, Context), + case SrcOffset =:= DstOffset of + true -> []; % omit move-to-self + false -> + hipe_ppc:mk_fload(Temp, SrcOffset, mk_sp(), 0) + ++ hipe_ppc:mk_fstore(Temp, DstOffset, mk_sp(), 0) + end + end. + pseudo_offset(Temp, FPoff, Context) -> FPoff + context_offset(Context, Temp). diff --git a/lib/hipe/ppc/hipe_ppc_ra_finalise.erl b/lib/hipe/ppc/hipe_ppc_ra_finalise.erl index 74ef7475eb..bca504d754 100644 --- a/lib/hipe/ppc/hipe_ppc_ra_finalise.erl +++ b/lib/hipe/ppc/hipe_ppc_ra_finalise.erl @@ -41,6 +41,7 @@ ra_insn(I, Map, FPMap) -> #mtspr{} -> ra_mtspr(I, Map); #pseudo_li{} -> ra_pseudo_li(I, Map); #pseudo_move{} -> ra_pseudo_move(I, Map); + #pseudo_spill_move{} -> ra_pseudo_spill_move(I, Map); #pseudo_tailcall{} -> ra_pseudo_tailcall(I, Map); #store{} -> ra_store(I, Map); #storex{} -> ra_storex(I, Map); @@ -52,6 +53,7 @@ ra_insn(I, Map, FPMap) -> #fp_binary{} -> ra_fp_binary(I, FPMap); #fp_unary{} -> ra_fp_unary(I, FPMap); #pseudo_fmove{} -> ra_pseudo_fmove(I, FPMap); + #pseudo_spill_fmove{} -> ra_pseudo_spill_fmove(I, FPMap); _ -> I end. @@ -98,6 +100,12 @@ ra_pseudo_move(I=#pseudo_move{dst=Dst,src=Src}, Map) -> NewSrc = ra_temp(Src, Map), I#pseudo_move{dst=NewDst,src=NewSrc}. +ra_pseudo_spill_move(I=#pseudo_spill_move{dst=Dst,temp=Temp,src=Src}, Map) -> + NewDst = ra_temp(Dst, Map), + NewTemp = ra_temp(Temp, Map), + NewSrc = ra_temp(Src, Map), + I#pseudo_spill_move{dst=NewDst,temp=NewTemp,src=NewSrc}. + ra_pseudo_tailcall(I=#pseudo_tailcall{stkargs=StkArgs}, Map) -> NewStkArgs = ra_args(StkArgs, Map), I#pseudo_tailcall{stkargs=NewStkArgs}. @@ -156,6 +164,13 @@ ra_pseudo_fmove(I=#pseudo_fmove{dst=Dst,src=Src}, FPMap) -> NewSrc = ra_temp_fp(Src, FPMap), I#pseudo_fmove{dst=NewDst,src=NewSrc}. +ra_pseudo_spill_fmove(I=#pseudo_spill_fmove{dst=Dst,temp=Temp,src=Src}, + FPMap) -> + NewDst = ra_temp_fp(Dst, FPMap), + NewTemp = ra_temp_fp(Temp, FPMap), + NewSrc = ra_temp_fp(Src, FPMap), + I#pseudo_spill_fmove{dst=NewDst,temp=NewTemp,src=NewSrc}. + ra_args([Arg|Args], Map) -> [ra_temp_or_imm(Arg, Map) | ra_args(Args, Map)]; ra_args([], _) -> diff --git a/lib/hipe/ppc/hipe_ppc_ra_postconditions.erl b/lib/hipe/ppc/hipe_ppc_ra_postconditions.erl index 95aa294fe5..0a97129666 100644 --- a/lib/hipe/ppc/hipe_ppc_ra_postconditions.erl +++ b/lib/hipe/ppc/hipe_ppc_ra_postconditions.erl @@ -57,6 +57,7 @@ do_insn(I, TempMap, Strategy) -> #mtspr{} -> do_mtspr(I, TempMap, Strategy); #pseudo_li{} -> do_pseudo_li(I, TempMap, Strategy); #pseudo_move{} -> do_pseudo_move(I, TempMap, Strategy); + #pseudo_spill_move{} -> do_pseudo_spill_move(I, TempMap, Strategy); #store{} -> do_store(I, TempMap, Strategy); #storex{} -> do_storex(I, TempMap, Strategy); #unary{} -> do_unary(I, TempMap, Strategy); @@ -117,18 +118,25 @@ do_pseudo_li(I=#pseudo_li{dst=Dst}, TempMap, Strategy) -> do_pseudo_move(I=#pseudo_move{dst=Dst,src=Src}, TempMap, Strategy) -> %% Either Dst or Src (but not both) may be a pseudo temp. - %% pseudo_move and pseudo_tailcall are special cases: in - %% all other instructions, all temps must be non-pseudos - %% after register allocation. - case temp_is_spilled(Dst, TempMap) of - true -> % Src must not be a pseudo - {FixSrc,NewSrc,DidSpill} = fix_src1(Src, TempMap, Strategy), - NewI = I#pseudo_move{src=NewSrc}, - {FixSrc ++ [NewI], DidSpill}; + %% pseudo_move, pseudo_spill_move, and pseudo_tailcall are + %% special cases: in all other instructions, all temps + %% must be non-pseudos after register allocation. + case temp_is_spilled(Src, TempMap) + andalso temp_is_spilled(Dst, TempMap) + of + true -> % Turn into pseudo_spill_move + Temp = clone(Src, temp1(Strategy)), + NewI = #pseudo_spill_move{dst=Dst,temp=Temp,src=Src}, + {[NewI], true}; _ -> {[I], false} end. +do_pseudo_spill_move(I=#pseudo_spill_move{temp=Temp}, TempMap, _Strategy) -> + %% Temp is above the low water mark and must not have been spilled + false = temp_is_spilled(Temp, TempMap), + {[I], false}. + do_store(I=#store{src=Src,base=Base}, TempMap, Strategy) -> {FixSrc,NewSrc,DidSpill1} = fix_src1(Src, TempMap, Strategy), {FixBase,NewBase,DidSpill2} = fix_src2(Base, TempMap, Strategy), diff --git a/lib/hipe/ppc/hipe_ppc_ra_postconditions_fp.erl b/lib/hipe/ppc/hipe_ppc_ra_postconditions_fp.erl index 5ec5f29577..7342053620 100644 --- a/lib/hipe/ppc/hipe_ppc_ra_postconditions_fp.erl +++ b/lib/hipe/ppc/hipe_ppc_ra_postconditions_fp.erl @@ -42,6 +42,7 @@ do_insn(I, TempMap) -> #fp_binary{} -> do_fp_binary(I, TempMap); #fp_unary{} -> do_fp_unary(I, TempMap); #pseudo_fmove{} -> do_pseudo_fmove(I, TempMap); + #pseudo_spill_fmove{} -> do_pseudo_spill_fmove(I, TempMap); _ -> {[I], false} end. @@ -81,15 +82,22 @@ do_fp_unary(I=#fp_unary{dst=Dst,src=Src}, TempMap) -> {FixSrc ++ [NewI | FixDst], DidSpill1 or DidSpill2}. do_pseudo_fmove(I=#pseudo_fmove{dst=Dst,src=Src}, TempMap) -> - case temp_is_spilled(Dst, TempMap) of - true -> - {FixSrc,NewSrc,DidSpill} = fix_src(Src, TempMap), - NewI = I#pseudo_fmove{src=NewSrc}, - {FixSrc ++ [NewI], DidSpill}; + case temp_is_spilled(Src, TempMap) + andalso temp_is_spilled(Dst, TempMap) + of + true -> % Turn into pseudo_spill_fmove + Temp = clone(Src), + NewI = #pseudo_spill_fmove{dst=Dst,temp=Temp,src=Src}, + {[NewI], true}; _ -> {[I], false} end. +do_pseudo_spill_fmove(I=#pseudo_spill_fmove{temp=Temp}, TempMap) -> + %% Temp is above the low water mark and must not have been spilled + false = temp_is_spilled(Temp, TempMap), + {[I], false}. + %%% Fix Dst and Src operands. fix_src(Src, TempMap) -> diff --git a/lib/hipe/ppc/hipe_ppc_subst.erl b/lib/hipe/ppc/hipe_ppc_subst.erl index 1cd18b5c01..e282b22774 100644 --- a/lib/hipe/ppc/hipe_ppc_subst.erl +++ b/lib/hipe/ppc/hipe_ppc_subst.erl @@ -48,6 +48,8 @@ insn_temps(T, I) -> #pseudo_call_prepare{} -> I; #pseudo_li{dst=D} -> I#pseudo_li{dst=T(D)}; #pseudo_move{dst=D,src=S} -> I#pseudo_move{dst=T(D),src=T(S)}; + #pseudo_spill_move{dst=D,temp=U,src=S} -> + I#pseudo_spill_move{dst=T(D),temp=T(U),src=T(S)}; #pseudo_tailcall{func=F,stkargs=Stk} when not is_record(F, ppc_temp) -> I#pseudo_tailcall{stkargs=lists:map(A,Stk)}; #pseudo_tailcall_prepare{} -> I; @@ -62,7 +64,9 @@ insn_temps(T, I) -> #fp_binary{dst=D,src1=L,src2=R} -> I#fp_binary{dst=T(D),src1=T(L),src2=T(R)}; #fp_unary{dst=D,src=S} -> I#fp_unary{dst=T(D),src=T(S)}; - #pseudo_fmove{dst=D,src=S} -> I#pseudo_fmove{dst=T(D),src=T(S)} + #pseudo_fmove{dst=D,src=S} -> I#pseudo_fmove{dst=T(D),src=T(S)}; + #pseudo_spill_fmove{dst=D,temp=U,src=S} -> + I#pseudo_spill_fmove{dst=T(D),temp=T(U),src=T(S)} end. -spec oper_temps(subst_fun(), oper()) -> oper(). diff --git a/lib/hipe/regalloc/Makefile b/lib/hipe/regalloc/Makefile index 209f230a9b..81a92e5d35 100644 --- a/lib/hipe/regalloc/Makefile +++ b/lib/hipe/regalloc/Makefile @@ -50,8 +50,10 @@ MODULES = hipe_ig hipe_ig_moves hipe_moves \ hipe_optimistic_regalloc \ hipe_coalescing_regalloc \ hipe_graph_coloring_regalloc \ + hipe_range_split \ hipe_regalloc_loop \ hipe_regalloc_prepass \ + hipe_restore_reuse \ hipe_ls_regalloc \ hipe_ppc_specific hipe_ppc_specific_fp \ hipe_sparc_specific hipe_sparc_specific_fp \ diff --git a/lib/hipe/regalloc/hipe_amd64_specific_sse2.erl b/lib/hipe/regalloc/hipe_amd64_specific_sse2.erl index 9682d37520..d592ba391c 100644 --- a/lib/hipe/regalloc/hipe_amd64_specific_sse2.erl +++ b/lib/hipe/regalloc/hipe_amd64_specific_sse2.erl @@ -30,6 +30,7 @@ def_use/2, is_arg/2, %% used by hipe_ls_regalloc is_move/2, + is_spill_move/2, is_fixed/2, %% used by hipe_graph_coloring_regalloc is_global/2, is_precoloured/2, @@ -50,12 +51,19 @@ -export([check_and_rewrite/3, check_and_rewrite/4]). -%% callbacks for hipe_regalloc_prepass --export([new_reg_nr/1, +%% callbacks for hipe_regalloc_prepass, hipe_range_split +-export([mk_move/3, + mk_goto/2, + redirect_jmp/4, + new_label/1, + new_reg_nr/1, update_reg_nr/3, update_bb/4, subst_temps/3]). +%% callbacks for hipe_bb_weights +-export([branch_preds/2]). + %%---------------------------------------------------------------------------- -include("../flow/cfg.hrl"). @@ -152,6 +160,9 @@ bb(CFG, L, _) -> update_bb(CFG,L,BB,_) -> hipe_x86_cfg:bb_add(CFG,L,BB). +branch_preds(Instr,_) -> + hipe_x86_cfg:branch_preds(Instr). + %% AMD64 stuff def_use(Instruction, _) -> @@ -184,10 +195,34 @@ is_move(Instruction, _) -> andalso hipe_x86:is_temp(Dst) andalso hipe_x86:temp_is_allocatable(Dst); false -> false end. + +is_spill_move(Instruction,_) -> + hipe_x86:is_pseudo_spill_fmove(Instruction). reg_nr(Reg, _) -> hipe_x86:temp_reg(Reg). +mk_move(Src, Dst, _) -> + hipe_x86:mk_fmove(Src, Dst). + +mk_goto(Label, _) -> + hipe_x86:mk_jmp_label(Label). + +redirect_jmp(Jmp, ToOld, ToNew, _) when is_integer(ToOld), is_integer(ToNew) -> + Ref = make_ref(), + put(Ref, false), + I = hipe_x86_subst:insn_lbls( + fun(Tgt) -> + if Tgt =:= ToOld -> put(Ref, true), ToNew; + is_integer(Tgt) -> Tgt + end + end, Jmp), + true = erase(Ref), % Assert that something was rewritten + I. + +new_label(_) -> + hipe_gensym:get_next_label(x86). + new_reg_nr(_) -> hipe_gensym:get_next_var(x86). diff --git a/lib/hipe/regalloc/hipe_arm_specific.erl b/lib/hipe/regalloc/hipe_arm_specific.erl index cef22e5af9..7ebc6aa336 100644 --- a/lib/hipe/regalloc/hipe_arm_specific.erl +++ b/lib/hipe/regalloc/hipe_arm_specific.erl @@ -24,6 +24,7 @@ ,reg_nr/2 ,def_use/2 ,is_move/2 + ,is_spill_move/2 ,is_precoloured/2 ,var_range/2 ,allocatable/1 @@ -46,12 +47,19 @@ %% callbacks for hipe_regalloc_loop -export([check_and_rewrite/3]). -%% callbacks for hipe_regalloc_prepass --export([new_reg_nr/1, +%% callbacks for hipe_regalloc_prepass, hipe_range_split +-export([mk_move/3, + mk_goto/2, + redirect_jmp/4, + new_label/1, + new_reg_nr/1, update_reg_nr/3, update_bb/4, subst_temps/3]). +%% callbacks for hipe_bb_weights, hipe_range_split +-export([branch_preds/2]). + check_and_rewrite(CFG, Coloring, no_context) -> hipe_arm_ra_postconditions:check_and_rewrite(CFG, Coloring, 'normal'). @@ -115,6 +123,9 @@ bb(CFG,L,_) -> update_bb(CFG,L,BB,_) -> hipe_arm_cfg:bb_add(CFG,L,BB). +branch_preds(Branch,_) -> + hipe_arm_cfg:branch_preds(Branch). + %% ARM stuff def_use(Instruction, Ctx) -> @@ -144,9 +155,33 @@ is_move(Instruction, _) -> false -> false end. +is_spill_move(Instruction, _) -> + hipe_arm:is_pseudo_spill_move(Instruction). + reg_nr(Reg, _) -> hipe_arm:temp_reg(Reg). +mk_move(Src, Dst, _) -> + hipe_arm:mk_pseudo_move(Dst, Src). + +mk_goto(Label, _) -> + hipe_arm:mk_b_label(Label). + +redirect_jmp(Jmp, ToOld, ToNew, _) when is_integer(ToOld), is_integer(ToNew) -> + Ref = make_ref(), + put(Ref, false), + I = hipe_arm_subst:insn_lbls( + fun(Tgt) -> + if Tgt =:= ToOld -> put(Ref, true), ToNew; + is_integer(Tgt) -> Tgt + end + end, Jmp), + true = erase(Ref), % Assert that something was rewritten + I. + +new_label(_) -> + hipe_gensym:get_next_label(arm). + new_reg_nr(_) -> hipe_gensym:get_next_var(arm). diff --git a/lib/hipe/regalloc/hipe_coalescing_regalloc.erl b/lib/hipe/regalloc/hipe_coalescing_regalloc.erl index e8ccbec9f1..b8f0a1974c 100644 --- a/lib/hipe/regalloc/hipe_coalescing_regalloc.erl +++ b/lib/hipe/regalloc/hipe_coalescing_regalloc.erl @@ -914,7 +914,7 @@ findCheapest([Node|Nodes], IG, Cost, Cheapest, SpillLimit) -> %% limit are extremely expensive. getCost(Node, IG, SpillLimit) -> - case Node > SpillLimit of + case Node >= SpillLimit of true -> inf; false -> hipe_ig:node_spill_cost(Node, IG) end. diff --git a/lib/hipe/regalloc/hipe_graph_coloring_regalloc.erl b/lib/hipe/regalloc/hipe_graph_coloring_regalloc.erl index 07aa812f4a..f82d3a2cbc 100644 --- a/lib/hipe/regalloc/hipe_graph_coloring_regalloc.erl +++ b/lib/hipe/regalloc/hipe_graph_coloring_regalloc.erl @@ -209,8 +209,8 @@ color(IG, Spill, PhysRegs, SpillIx, SpillLimit, NumNodes, Target, %% Any nodes above the spillimit must be colored first... MustNotSpill = - if NumNodes > SpillLimit+1 -> - sort_on_degree(lists:seq(SpillLimit+1,NumNodes-1) -- Low,IG); + if NumNodes > SpillLimit -> + sort_on_degree(lists:seq(SpillLimit,NumNodes-1) -- Low,IG); true -> [] end, @@ -401,7 +401,7 @@ spill_costs([{N,Info}|Ns], IG, Vis, Spill, SpillLimit, Target) -> true -> spill_costs(Ns, IG, Vis, Spill, SpillLimit, Target); false -> - if N > SpillLimit -> + if N >= SpillLimit -> spill_costs(Ns, IG, Vis, Spill, SpillLimit, Target); true -> [{spill_cost_of(N,Spill)/Deg,N} | diff --git a/lib/hipe/regalloc/hipe_optimistic_regalloc.erl b/lib/hipe/regalloc/hipe_optimistic_regalloc.erl index b96920cbcf..a019c46b90 100644 --- a/lib/hipe/regalloc/hipe_optimistic_regalloc.erl +++ b/lib/hipe/regalloc/hipe_optimistic_regalloc.erl @@ -1933,7 +1933,7 @@ findCheapest([Node|Nodes], IG, Cost, Cheapest, SpillLimit) -> %% limit are extremely expensive. getCost(Node, IG, SpillLimit) -> - case Node > SpillLimit of + case Node >= SpillLimit of true -> inf; false -> SpillCost = hipe_ig:node_spill_cost(Node, IG), diff --git a/lib/hipe/regalloc/hipe_ppc_specific.erl b/lib/hipe/regalloc/hipe_ppc_specific.erl index a6450b4d96..81bb551bd2 100644 --- a/lib/hipe/regalloc/hipe_ppc_specific.erl +++ b/lib/hipe/regalloc/hipe_ppc_specific.erl @@ -24,6 +24,7 @@ ,reg_nr/2 ,def_use/2 ,is_move/2 + ,is_spill_move/2 ,is_precoloured/2 ,var_range/2 ,allocatable/1 @@ -46,12 +47,19 @@ %% callbacks for hipe_regalloc_loop -export([check_and_rewrite/3]). -%% callbacks for hipe_regalloc_prepass --export([new_reg_nr/1, +%% callbacks for hipe_regalloc_prepass, hipe_range_split +-export([mk_move/3, + mk_goto/2, + redirect_jmp/4, + new_label/1, + new_reg_nr/1, update_reg_nr/3, update_bb/4, subst_temps/3]). +%% callbacks for hipe_bb_weights +-export([branch_preds/2]). + check_and_rewrite(CFG, Coloring, _) -> hipe_ppc_ra_postconditions:check_and_rewrite(CFG, Coloring, 'normal'). @@ -115,6 +123,9 @@ bb(CFG,L,_) -> update_bb(CFG,L,BB,_) -> hipe_ppc_cfg:bb_add(CFG,L,BB). +branch_preds(Instr,_) -> + hipe_ppc_cfg:branch_preds(Instr). + %% PowerPC stuff def_use(Instruction, Ctx) -> @@ -144,9 +155,24 @@ is_move(Instruction, _) -> false -> false end. +is_spill_move(Instruction, _) -> + hipe_ppc:is_pseudo_spill_move(Instruction). + reg_nr(Reg, _) -> hipe_ppc:temp_reg(Reg). +mk_move(Src, Dst, _) -> + hipe_ppc:mk_pseudo_move(Dst, Src). + +mk_goto(Label, _) -> + hipe_ppc:mk_b_label(Label). + +redirect_jmp(Jmp, ToOld, ToNew, _) when is_integer(ToOld), is_integer(ToNew) -> + hipe_ppc_cfg:redirect_jmp(Jmp, ToOld, ToNew). + +new_label(_) -> + hipe_gensym:get_next_label(ppc). + new_reg_nr(_) -> hipe_gensym:get_next_var(ppc). diff --git a/lib/hipe/regalloc/hipe_ppc_specific_fp.erl b/lib/hipe/regalloc/hipe_ppc_specific_fp.erl index 23cb6c0318..dcfdf6592c 100644 --- a/lib/hipe/regalloc/hipe_ppc_specific_fp.erl +++ b/lib/hipe/regalloc/hipe_ppc_specific_fp.erl @@ -24,6 +24,7 @@ ,reg_nr/2 ,def_use/2 ,is_move/2 + ,is_spill_move/2 ,is_precoloured/2 ,var_range/2 ,allocatable/1 @@ -46,12 +47,19 @@ %% callbacks for hipe_regalloc_loop -export([check_and_rewrite/3]). -%% callbacks for hipe_regalloc_prepass --export([new_reg_nr/1, +%% callbacks for hipe_regalloc_prepass, hipe_range_split +-export([mk_move/3, + mk_goto/2, + redirect_jmp/4, + new_label/1, + new_reg_nr/1, update_reg_nr/3, update_bb/4, subst_temps/3]). +%% callbacks for hipe_bb_weights +-export([branch_preds/2]). + check_and_rewrite(CFG, Coloring, _) -> hipe_ppc_ra_postconditions_fp:check_and_rewrite(CFG, Coloring). @@ -108,6 +116,9 @@ bb(CFG, L, _) -> update_bb(CFG,L,BB,_) -> hipe_ppc_cfg:bb_add(CFG,L,BB). +branch_preds(Instr,_) -> + hipe_ppc_cfg:branch_preds(Instr). + %% PowerPC stuff def_use(I, Ctx) -> @@ -125,9 +136,24 @@ defines_all_alloc(I, _) -> is_move(I, _) -> hipe_ppc:is_pseudo_fmove(I). +is_spill_move(I, _) -> + hipe_ppc:is_pseudo_spill_fmove(I). + reg_nr(Reg, _) -> hipe_ppc:temp_reg(Reg). +mk_move(Src, Dst, _) -> + hipe_ppc:mk_pseudo_fmove(Dst, Src). + +mk_goto(Label, _) -> + hipe_ppc:mk_b_label(Label). + +redirect_jmp(Jmp, ToOld, ToNew, _) when is_integer(ToOld), is_integer(ToNew) -> + hipe_ppc_cfg:redirect_jmp(Jmp, ToOld, ToNew). + +new_label(_) -> + hipe_gensym:get_next_label(ppc). + new_reg_nr(_) -> hipe_gensym:get_next_var(ppc). diff --git a/lib/hipe/regalloc/hipe_range_split.erl b/lib/hipe/regalloc/hipe_range_split.erl new file mode 100644 index 0000000000..39b086d9f7 --- /dev/null +++ b/lib/hipe/regalloc/hipe_range_split.erl @@ -0,0 +1,1187 @@ +%% -*- erlang-indent-level: 2 -*- +%% +%% 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. +%% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%@doc +%% TEMPORARY LIVE RANGE SPLITTING PASS +%% +%% Live range splitting is useful to allow a register allocator to allocate a +%% temporary to register for a part of its lifetime, even if it cannot be for +%% the entirety. This improves register allocation quality, at the cost of +%% making the allocation problem more time and memory intensive to solve. +%% +%% Optimal allocation can be achieved if all temporaries are split at every +%% program point (between all instructions), but this makes register allocation +%% infeasably slow in practice. Instead, this module uses heuristics to choose +%% which temporaries should have their live ranges split, and at which points. +%% +%% The range splitter only considers temps which are live during a call +%% instruction, since they're known to be spilled. The control-flow graph is +%% partitioned at call instructions and splitting decisions are made separately +%% for each partition. The register copy of a temp (if any) gets a separate name +%% in each partition. +%% +%% There are three different ways the range splitter may choose to split a +%% temporary in a program partition: +%% +%% * Mode1: Spill the temp before calls, and restore it after them +%% * Mode2: Spill the temp after definitions, restore it after calls +%% * Mode3: Spill the temp after definitions, restore it before uses +%% +%% To pick which of these should be used for each temp×partiton pair, the range +%% splitter uses a cost function. The cost is simply the sum of the cost of all +%% expected stack accesses, and the cost for an individual stack access is based +%% on the probability weight of the basic block that it resides in. This biases +%% the range splitter so that it attempts moving stack accesses from a functions +%% hot path to the cold path. +%% +%% The heuristic has a couple of tuning knobs, adjusting its preference for +%% different spilling modes, aggressiveness, and how much influence the basic +%% block probability weights have. +%% +%% Edge case not handled: Call instructions directly defining a pseudo. In that +%% case, if that pseudo has been selected for mode2 spills, no spill is inserted +%% after the call. +-module(hipe_range_split). + +-export([split/5]). + +-compile(inline). + +%% -define(DO_ASSERT, 1). +%% -define(DEBUG, 1). +-include("../main/hipe.hrl"). + +%% Heuristic tuning constants +-define(DEFAULT_MIN_GAIN, 1.1). % option: range_split_min_gain +-define(DEFAULT_MODE1_FUDGE, 1.1). % option: range_split_mode1_fudge +-define(DEFAULT_WEIGHT_POWER, 2). % option: range_split_weight_power +-define(WEIGHT_CONST_FUN(Power), math:log(Power)/math:log(100)). +-define(WEIGHT_FUN(Wt, Const), math:pow(Wt, Const)). +-define(HEUR_MAX_TEMPS, 20000). + +-type target_cfg() :: any(). +-type target_instr() :: any(). +-type target_temp() :: any(). +-type liveness() :: any(). +-type target_module() :: module(). +-type target_context() :: any(). +-type target() :: {target_module(), target_context()}. +-type liveset() :: ordsets:ordset(temp()). +-type temp() :: non_neg_integer(). +-type label() :: non_neg_integer(). + +-spec split(target_cfg(), liveness(), target_module(), target_context(), + comp_options()) + -> target_cfg(). +split(TCFG0, Liveness, TargetMod, TargetContext, Options) -> + Target = {TargetMod, TargetContext}, + NoTemps = number_of_temporaries(TCFG0, Target), + if NoTemps > ?HEUR_MAX_TEMPS -> + ?debug_msg("~w: Too many temps (~w), falling back on restore_reuse.~n", + [?MODULE, NoTemps]), + hipe_restore_reuse:split(TCFG0, Liveness, TargetMod, TargetContext); + true -> + Wts = compute_weights(TCFG0, TargetMod, TargetContext, Options), + {CFG0, Temps} = convert(TCFG0, Target), + Avail = avail_analyse(TCFG0, Liveness, Target), + Defs = def_analyse(CFG0, TCFG0), + RDefs = rdef_analyse(CFG0), + PLive = plive_analyse(CFG0), + {CFG, DUCounts, Costs, DSets0} = + scan(CFG0, Liveness, PLive, Wts, Defs, RDefs, Avail, Target), + {DSets, _} = hipe_dsets:to_map(DSets0), + Renames = decide(DUCounts, Costs, Target, Options), + rewrite(CFG, TCFG0, Target, Liveness, PLive, Defs, Avail, DSets, Renames, + Temps) + end. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Internal program representation +%% +%% Second pass: Convert cfg to internal representation + +-record(cfg, { + rpo_labels :: [label()], + bbs :: #{label() => bb()} + }). +-type cfg() :: #cfg{}. + +cfg_bb(L, #cfg{bbs=BBS}) -> maps:get(L, BBS). + +cfg_postorder(#cfg{rpo_labels=RPO}) -> lists:reverse(RPO). + +-record(bb, { + code :: [code_elem()], + %% If the last instruction of code defines all allocatable registers + has_call :: boolean(), + succ :: [label()] + }). +-type bb() :: #bb{}. +-type code_elem() :: instr() | mode2_spills() | mode3_restores(). + +bb_code(#bb{code=Code}) -> Code. +bb_has_call(#bb{has_call=HasCall}) -> HasCall. +bb_succ(#bb{succ=Succ}) -> Succ. + +bb_butlast(#bb{code=Code}) -> + bb_butlast_1(Code). + +bb_butlast_1([_Last]) -> []; +bb_butlast_1([I|Is]) -> [I|bb_butlast_1(Is)]. + +bb_last(#bb{code=Code}) -> lists:last(Code). + +-record(instr, { + i :: target_instr(), + def :: ordsets:ordset(temp()), + use :: ordsets:ordset(temp()) + }). +-type instr() :: #instr{}. + +-record(mode2_spills, { + temps :: ordsets:ordset(temp()) + }). +-type mode2_spills() :: #mode2_spills{}. + +-record(mode3_restores, { + temps :: ordsets:ordset(temp()) + }). +-type mode3_restores() :: #mode3_restores{}. + +-spec convert(target_cfg(), target()) -> {cfg(), temps()}. +convert(CFG, Target) -> + RPO = reverse_postorder(CFG, Target), + {BBsList, Temps} = convert_bbs(RPO, CFG, Target, #{}, []), + {#cfg{rpo_labels = RPO, + bbs = maps:from_list(BBsList)}, + Temps}. + +convert_bbs([], _CFG, _Target, Temps, Acc) -> {Acc, Temps}; +convert_bbs([L|Ls], CFG, Target, Temps0, Acc) -> + Succs = hipe_gen_cfg:succ(CFG, L), + TBB = bb(CFG, L, Target), + TCode = hipe_bb:code(TBB), + {Code, Last, Temps} = convert_code(TCode, Target, Temps0, []), + HasCall = defines_all_alloc(Last#instr.i, Target), + BB = #bb{code = Code, + has_call = HasCall, + succ = Succs}, + convert_bbs(Ls, CFG, Target, Temps, [{L,BB}|Acc]). + +convert_code([], _Target, Temps, [Last|_]=Acc) -> + {lists:reverse(Acc), Last, Temps}; +convert_code([TI|TIs], Target, Temps0, Acc) -> + {TDef, TUse} = def_use(TI, Target), + I = #instr{i = TI, + def = ordsets:from_list(reg_names(TDef, Target)), + use = ordsets:from_list(reg_names(TUse, Target))}, + Temps = add_temps(TUse, Target, add_temps(TDef, Target, Temps0)), + convert_code(TIs, Target, Temps, [I|Acc]). + +-type temps() :: #{temp() => target_temp()}. +add_temps([], _Target, Temps) -> Temps; +add_temps([T|Ts], Target, Temps) -> + add_temps(Ts, Target, Temps#{reg_nr(T, Target) => T}). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Fourth pass: P({DEF}) lattice fwd dataflow (for eliding stores at SPILL +%% splits) +-type defsi() :: #{label() => defseti() | {call, defseti(), defseti()}}. +-type defs() :: #{label() => defsetf()}. + +-spec def_analyse(cfg(), target_cfg()) -> defs(). +def_analyse(CFG = #cfg{rpo_labels = RPO}, TCFG) -> + Defs0 = def_init(CFG), + def_dataf(RPO, TCFG, Defs0). + +-spec def_init(cfg()) -> defsi(). +def_init(#cfg{bbs = BBs}) -> + maps:from_list( + [begin + {L, case HasCall of + false -> def_init_scan(bb_code(BB), defseti_new()); + true -> + {call, def_init_scan(bb_butlast(BB), defseti_new()), + defseti_from_ordset((bb_last(BB))#instr.def)} + end} + end || {L, BB = #bb{has_call=HasCall}} <- maps:to_list(BBs)]). + +def_init_scan([], Defset) -> Defset; +def_init_scan([#instr{def=Def}|Is], Defset0) -> + Defset = defseti_add_ordset(Def, Defset0), + def_init_scan(Is, Defset). + +-spec def_dataf([label()], target_cfg(), defsi()) -> defs(). +def_dataf(Labels, TCFG, Defs0) -> + case def_dataf_once(Labels, TCFG, Defs0, 0) of + {Defs, 0} -> + def_finalise(Defs); + {Defs, _Changed} -> + def_dataf(Labels, TCFG, Defs) + end. + +-spec def_finalise(defsi()) -> defs(). +def_finalise(Defs) -> + maps:from_list([{K, defseti_finalise(BL)} + || {K, {call, BL, _}} <- maps:to_list(Defs)]). + +-spec def_dataf_once([label()], target_cfg(), defsi(), non_neg_integer()) + -> {defsi(), non_neg_integer()}. +def_dataf_once([], _TCFG, Defs, Changed) -> {Defs, Changed}; +def_dataf_once([L|Ls], TCFG, Defs0, Changed0) -> + AddPreds = + fun(Defset1) -> + lists:foldl(fun(P, Defset2) -> + defseti_union(defout(P, Defs0), Defset2) + end, Defset1, hipe_gen_cfg:pred(TCFG, L)) + end, + Defset = + case Defset0 = maps:get(L, Defs0) of + {call, Butlast, Defout} -> {call, AddPreds(Butlast), Defout}; + _ -> AddPreds(Defset0) + end, + Changed = case Defset =:= Defset0 of + true -> Changed0; + false -> Changed0+1 + end, + def_dataf_once(Ls, TCFG, Defs0#{L := Defset}, Changed). + +-spec defout(label(), defsi()) -> defseti(). +defout(L, Defs) -> + case maps:get(L, Defs) of + {call, _DefButLast, Defout} -> Defout; + Defout -> Defout + end. + +-spec defbutlast(label(), defs()) -> defsetf(). +defbutlast(L, Defs) -> maps:get(L, Defs). + +-spec defseti_new() -> defseti(). +-spec defseti_union(defseti(), defseti()) -> defseti(). +-spec defseti_add_ordset(ordset:ordset(temp()), defseti()) -> defseti(). +-spec defseti_from_ordset(ordset:ordset(temp())) -> defseti(). +-spec defseti_finalise(defseti()) -> defsetf(). +-spec defsetf_member(temp(), defsetf()) -> boolean(). +-spec defsetf_intersect_ordset(ordsets:ordset(temp()), defsetf()) + -> ordsets:ordset(temp()). + +-type defseti() :: bitord(). +defseti_new() -> bitord_new(). +defseti_union(A, B) -> bitord_union(A, B). +defseti_add_ordset(OS, D) -> defseti_union(defseti_from_ordset(OS), D). +defseti_from_ordset(OS) -> bitord_from_ordset(OS). +defseti_finalise(D) -> bitarr_from_bitord(D). + +-type defsetf() :: bitarr(). +defsetf_member(E, D) -> bitarr_get(E, D). + +defsetf_intersect_ordset([], _D) -> []; +defsetf_intersect_ordset([E|Es], D) -> + case bitarr_get(E, D) of + true -> [E|defsetf_intersect_ordset(Es,D)]; + false -> defsetf_intersect_ordset(Es,D) + end. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Fifth pass: P({DEF}) lattice reverse dataflow (for eliding stores at defines +%% in mode2) +-type rdefsi() :: #{label() => + {call, rdefseti(), [label()]} + | {nocall, rdefseti(), rdefseti(), [label()]}}. +-type rdefs() :: #{label() => {final, rdefsetf(), [label()]}}. + +-spec rdef_analyse(cfg()) -> rdefs(). +rdef_analyse(CFG = #cfg{rpo_labels=RPO}) -> + Defs0 = rdef_init(CFG), + PO = rdef_postorder(RPO, CFG, []), + rdef_dataf(PO, Defs0). + +%% Filter out 'call' labels, since they don't change +-spec rdef_postorder([label()], cfg(), [label()]) -> [label()]. +rdef_postorder([], _CFG, Acc) -> Acc; +rdef_postorder([L|Ls], CFG, Acc) -> + case bb_has_call(cfg_bb(L, CFG)) of + true -> rdef_postorder(Ls, CFG, Acc); + false -> rdef_postorder(Ls, CFG, [L|Acc]) + end. + +-spec rdef_init(cfg()) -> rdefsi(). +rdef_init(#cfg{bbs = BBs}) -> + maps:from_list( + [{L, case HasCall of + true -> + Defin = rdef_init_scan(bb_butlast(BB), rdefseti_empty()), + {call, Defin, Succs}; + false -> + Gen = rdef_init_scan(bb_code(BB), rdefseti_empty()), + {nocall, Gen, rdefseti_top(), Succs} + end} + || {L, BB = #bb{has_call=HasCall, succ=Succs}} <- maps:to_list(BBs)]). + +-spec rdef_init_scan([instr()], rdefseti()) -> rdefseti(). +rdef_init_scan([], Defset) -> Defset; +rdef_init_scan([#instr{def=Def}|Is], Defset0) -> + Defset = rdefseti_add_ordset(Def, Defset0), + rdef_init_scan(Is, Defset). + +-spec rdef_dataf([label()], rdefsi()) -> rdefs(). +rdef_dataf(Labels, Defs0) -> + case rdef_dataf_once(Labels, Defs0, 0) of + {Defs, 0} -> + rdef_finalise(Defs); + {Defs, _Changed} -> + rdef_dataf(Labels, Defs) + end. + +-spec rdef_finalise(rdefsi()) -> rdefs(). +rdef_finalise(Defs) -> + maps:map(fun(L, V) -> + Succs = rsuccs_val(V), + Defout0 = rdefout_intersect(L, Defs, rdefseti_top()), + {final, rdefset_finalise(Defout0), Succs} + end, Defs). + +-spec rdef_dataf_once([label()], rdefsi(), non_neg_integer()) + -> {rdefsi(), non_neg_integer()}. +rdef_dataf_once([], Defs, Changed) -> {Defs, Changed}; +rdef_dataf_once([L|Ls], Defs0, Changed0) -> + #{L := {nocall, Gen, Defin0, Succs}} = Defs0, + Defin = rdefseti_union(Gen, rdefout_intersect(L, Defs0, Defin0)), + Defset = {nocall, Gen, Defin, Succs}, + Changed = case Defin =:= Defin0 of + true -> Changed0; + false -> Changed0+1 + end, + rdef_dataf_once(Ls, Defs0#{L := Defset}, Changed). + +-spec rdefin(label(), rdefsi()) -> rdefseti(). +rdefin(L, Defs) -> rdefin_val(maps:get(L, Defs)). +rdefin_val({nocall, _Gen, Defin, _Succs}) -> Defin; +rdefin_val({call, Defin, _Succs}) -> Defin. + +-spec rsuccs(label(), rdefsi()) -> [label()]. +rsuccs(L, Defs) -> rsuccs_val(maps:get(L, Defs)). +rsuccs_val({nocall, _Gen, _Defin, Succs}) -> Succs; +rsuccs_val({call, _Defin, Succs}) -> Succs. + +-spec rdefout(label(), rdefs()) -> rdefsetf(). +rdefout(L, Defs) -> + #{L := {final, Defout, _Succs}} = Defs, + Defout. + +-spec rdefout_intersect(label(), rdefsi(), rdefseti()) -> rdefseti(). +rdefout_intersect(L, Defs, Init) -> + lists:foldl(fun(S, Acc) -> + rdefseti_intersect(rdefin(S, Defs), Acc) + end, Init, rsuccs(L, Defs)). + +-type rdefseti() :: bitord() | top. +rdefseti_top() -> top. +rdefseti_empty() -> bitord_new(). +-spec rdefseti_from_ordset(ordsets:ordset(temp())) -> rdefseti(). +rdefseti_from_ordset(OS) -> bitord_from_ordset(OS). + +-spec rdefseti_add_ordset(ordsets:ordset(temp()), rdefseti()) -> rdefseti(). +rdefseti_add_ordset(_, top) -> top; % Should never happen in rdef_dataf +rdefseti_add_ordset(OS, D) -> rdefseti_union(rdefseti_from_ordset(OS), D). + +-spec rdefseti_union(rdefseti(), rdefseti()) -> rdefseti(). +rdefseti_union(top, _) -> top; +rdefseti_union(_, top) -> top; +rdefseti_union(A, B) -> bitord_union(A, B). + +-spec rdefseti_intersect(rdefseti(), rdefseti()) -> rdefseti(). +rdefseti_intersect(top, D) -> D; +rdefseti_intersect(D, top) -> D; +rdefseti_intersect(A, B) -> bitord_intersect(A, B). + +-type rdefsetf() :: {arr, bitarr()} | top. +-spec rdefset_finalise(rdefseti()) -> rdefsetf(). +rdefset_finalise(top) -> top; +rdefset_finalise(Ord) -> {arr, bitarr_from_bitord(Ord)}. + +%% rdefsetf_top() -> top. +rdefsetf_empty() -> {arr, bitarr_new()}. + +-spec rdefsetf_add_ordset(ordset:ordset(temp()), rdefsetf()) -> rdefsetf(). +rdefsetf_add_ordset(_, top) -> top; +rdefsetf_add_ordset(OS, {arr, Arr}) -> + {arr, lists:foldl(fun bitarr_set/2, Arr, OS)}. + +-spec rdef_step(instr(), rdefsetf()) -> rdefsetf(). +rdef_step(#instr{def=Def}, Defset) -> + %% ?ASSERT(not defines_all_alloc(I, Target)), + rdefsetf_add_ordset(Def, Defset). + +-spec ordset_subtract_rdefsetf(ordsets:ordset(temp()), rdefsetf()) + -> ordsets:ordset(temp()). +ordset_subtract_rdefsetf(_, top) -> []; +ordset_subtract_rdefsetf(OS, {arr, Arr}) -> + %% Lazy implementation; could do better if OS can grow + lists:filter(fun(E) -> not bitarr_get(E, Arr) end, OS). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Integer sets represented as bit sets +%% +%% Two representations; bitord() and bitarr() +-define(LIMB_IX_BITS, 11). +-define(LIMB_BITS, (1 bsl ?LIMB_IX_BITS)). +-define(LIMB_IX(Index), (Index bsr ?LIMB_IX_BITS)). +-define(BIT_IX(Index), (Index band (?LIMB_BITS - 1))). +-define(BIT_MASK(Index), (1 bsl ?BIT_IX(Index))). + +%% bitord(): fast at union/2 and can be compared for equality with '=:=' +-type bitord() :: orddict:orddict(non_neg_integer(), 0..((1 bsl ?LIMB_BITS)-1)). + +-spec bitord_new() -> bitord(). +bitord_new() -> []. + +-spec bitord_union(bitord(), bitord()) -> bitord(). +bitord_union(Lhs, Rhs) -> + orddict:merge(fun(_, L, R) -> L bor R end, Lhs, Rhs). + +-spec bitord_intersect(bitord(), bitord()) -> bitord(). +bitord_intersect([], _) -> []; +bitord_intersect(_, []) -> []; +bitord_intersect([{K, L}|Ls], [{K, R}|Rs]) -> + [{K, L band R} | bitord_intersect(Ls, Rs)]; +bitord_intersect([{LK, _}|Ls], [{RK, _}|_]=Rs) when LK < RK -> + bitord_intersect(Ls, Rs); +bitord_intersect([{LK, _}|_]=Ls, [{RK, _}|Rs]) when LK > RK -> + bitord_intersect(Ls, Rs). + +-spec bitord_from_ordset(ordsets:ordset(non_neg_integer())) -> bitord(). +bitord_from_ordset([]) -> []; +bitord_from_ordset([B|Bs]) -> + bitord_from_ordset_1(Bs, ?LIMB_IX(B), ?BIT_MASK(B)). + +bitord_from_ordset_1([B|Bs], Key, Val) when Key =:= ?LIMB_IX(B) -> + bitord_from_ordset_1(Bs, Key, Val bor ?BIT_MASK(B)); +bitord_from_ordset_1([B|Bs], Key, Val) -> + [{Key,Val} | bitord_from_ordset_1(Bs, ?LIMB_IX(B), ?BIT_MASK(B))]; +bitord_from_ordset_1([], Key, Val) -> [{Key, Val}]. + +%% bitarr(): fast (enough) at get/2 +-type bitarr() :: array:array(0..((1 bsl ?LIMB_BITS)-1)). + +-spec bitarr_new() -> bitarr(). +bitarr_new() -> array:new({default, 0}). + +-spec bitarr_get(non_neg_integer(), bitarr()) -> boolean(). +bitarr_get(Index, Array) -> + Limb = array:get(?LIMB_IX(Index), Array), + 0 =/= (Limb band ?BIT_MASK(Index)). + +-spec bitarr_set(non_neg_integer(), bitarr()) -> bitarr(). +bitarr_set(Index, Array) -> + Limb0 = array:get(?LIMB_IX(Index), Array), + Limb = Limb0 bor ?BIT_MASK(Index), + array:set(?LIMB_IX(Index), Limb, Array). + +-spec bitarr_from_bitord(bitord()) -> bitarr(). +bitarr_from_bitord(Ord) -> + array:from_orddict(Ord, 0). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Sixth pass: Partition-local liveness analysis +%% +%% As temps are not spilled when exiting a partition in mode2, only +%% partition-local uses need to be considered when deciding which temps need +%% restoring at partition entry. + +-type plive() :: #{label() => + {call, liveset(), [label()]} + | {nocall, {liveset(), liveset()}, liveset(), [label()]}}. + +-spec plive_analyse(cfg()) -> plive(). +plive_analyse(CFG) -> + Defs0 = plive_init(CFG), + PO = cfg_postorder(CFG), + plive_dataf(PO, Defs0). + +-spec plive_init(cfg()) -> plive(). +plive_init(#cfg{bbs = BBs}) -> + maps:from_list( + [begin + {L, case HasCall of + true -> + {Gen, _} = plive_init_scan(bb_code(BB)), + {call, Gen, Succs}; + false -> + GenKill = plive_init_scan(bb_code(BB)), + {nocall, GenKill, liveset_empty(), Succs} + end} + end || {L, BB = #bb{has_call=HasCall, succ=Succs}} <- maps:to_list(BBs)]). + +-spec plive_init_scan([instr()]) -> {liveset(), liveset()}. +plive_init_scan([]) -> {liveset_empty(), liveset_empty()}; +plive_init_scan([#instr{def=InstrKill, use=InstrGen}|Is]) -> + {Gen0, Kill0} = plive_init_scan(Is), + Gen1 = liveset_subtract(Gen0, InstrKill), + Gen = liveset_union(Gen1, InstrGen), + Kill1 = liveset_union(Kill0, InstrKill), + Kill = liveset_subtract(Kill1, InstrGen), + {Gen, Kill}. + +-spec plive_dataf([label()], plive()) -> plive(). +plive_dataf(Labels, PLive0) -> + case plive_dataf_once(Labels, PLive0, 0) of + {PLive, 0} -> PLive; + {PLive, _Changed} -> + plive_dataf(Labels, PLive) + end. + +-spec plive_dataf_once([label()], plive(), non_neg_integer()) -> + {plive(), non_neg_integer()}. +plive_dataf_once([], PLive, Changed) -> {PLive, Changed}; +plive_dataf_once([L|Ls], PLive0, Changed0) -> + Liveset = + case Liveset0 = maps:get(L, PLive0) of + {call, Livein, Succs} -> + {call, Livein, Succs}; + {nocall, {Gen, Kill} = GenKill, _OldLivein, Succs} -> + Liveout = pliveout(L, PLive0), + Livein = liveset_union(Gen, liveset_subtract(Liveout, Kill)), + {nocall, GenKill, Livein, Succs} + end, + Changed = case Liveset =:= Liveset0 of + true -> Changed0; + false -> Changed0+1 + end, + plive_dataf_once(Ls, PLive0#{L := Liveset}, Changed). + +-spec pliveout(label(), plive()) -> liveset(). +pliveout(L, PLive) -> + liveset_union([plivein(S, PLive) || S <- psuccs(L, PLive)]). + +-spec psuccs(label(), plive()) -> [label()]. +psuccs(L, PLive) -> psuccs_val(maps:get(L, PLive)). +psuccs_val({call, _Livein, Succs}) -> Succs; +psuccs_val({nocall, _GenKill, _Livein, Succs}) -> Succs. + +-spec plivein(label(), plive()) -> liveset(). +plivein(L, PLive) -> plivein_val(maps:get(L, PLive)). +plivein_val({call, Livein, _Succs}) -> Livein; +plivein_val({nocall, _GenKill, Livein, _Succs}) -> Livein. + +liveset_empty() -> ordsets:new(). +liveset_subtract(A, B) -> ordsets:subtract(A, B). +liveset_union(A, B) -> ordsets:union(A, B). +liveset_union(LivesetList) -> ordsets:union(LivesetList). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Third pass: Compute dataflow analyses required for placing mode3 +%% spills/restores. +%% Reuse analysis implementation in hipe_restore_reuse. +%% XXX: hipe_restore_reuse has it's own "rdef"; we would like to reuse that one +%% too. +-type avail() :: hipe_restore_reuse:avail(). + +-spec avail_analyse(target_cfg(), liveness(), target()) -> avail(). +avail_analyse(CFG, Liveness, Target) -> + hipe_restore_reuse:analyse(CFG, Liveness, Target). + +-spec mode3_split_in_block(label(), avail()) -> ordsets:ordset(temp()). +mode3_split_in_block(L, Avail) -> + hipe_restore_reuse:split_in_block(L, Avail). + +-spec mode3_block_renameset(label(), avail()) -> ordsets:ordset(temp()). +mode3_block_renameset(L, Avail) -> + hipe_restore_reuse:renamed_in_block(L, Avail). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Seventh pass +%% +%% Compute program space partitioning, collect information required by the +%% heuristic. +-type part_key() :: label(). +-type part_dsets() :: hipe_dsets:dsets(part_key()). +-type part_dsets_map() :: #{part_key() => part_key()}. +-type ducounts() :: #{part_key() => ducount()}. + +-spec scan(cfg(), liveness(), plive(), weights(), defs(), rdefs(), avail(), + target()) -> {cfg(), ducounts(), costs(), part_dsets()}. +scan(CFG0, Liveness, PLive, Weights, Defs, RDefs, Avail, Target) -> + #cfg{rpo_labels = Labels, bbs = BBs0} = CFG0, + CFG = CFG0#cfg{bbs=#{}}, % kill reference + DSets0 = hipe_dsets:new(Labels), + Costs0 = costs_new(), + {BBs, DUCounts0, Costs1, DSets1} = + scan_bbs(maps:to_list(BBs0), Liveness, PLive, Weights, Defs, RDefs, Avail, + Target, #{}, Costs0, DSets0, []), + {RLList, DSets2} = hipe_dsets:to_rllist(DSets1), + {Costs, DSets} = costs_map_roots(DSets2, Costs1), + DUCounts = collect_ducounts(RLList, DUCounts0, #{}), + {CFG#cfg{bbs=maps:from_list(BBs)}, DUCounts, Costs, DSets}. + +-spec collect_ducounts([{label(), [label()]}], ducounts(), ducounts()) + -> ducounts(). +collect_ducounts([], _, Acc) -> Acc; +collect_ducounts([{R,Ls}|RLs], DUCounts, Acc) -> + DUCount = lists:foldl( + fun(Key, FAcc) -> + ducount_merge(maps:get(Key, DUCounts, ducount_new()), FAcc) + end, ducount_new(), Ls), + collect_ducounts(RLs, DUCounts, Acc#{R => DUCount}). + +-spec scan_bbs([{label(), bb()}], liveness(), plive(), weights(), defs(), + rdefs(), avail(), target(), ducounts(), costs(), part_dsets(), + [{label(), bb()}]) + -> {[{label(), bb()}], ducounts(), costs(), part_dsets()}. +scan_bbs([], _Liveness, _PLive, _Weights, _Defs, _RDefs, _Avail, _Target, + DUCounts, Costs, DSets, Acc) -> + {Acc, DUCounts, Costs, DSets}; +scan_bbs([{L,BB}|BBs], Liveness, PLive, Weights, Defs, RDefs, Avail, Target, + DUCounts0, Costs0, DSets0, Acc) -> + Wt = weight(L, Weights), + {DSets, Costs5, EntryCode, ExitCode, RDefout, Liveout} = + case bb_has_call(BB) of + false -> + DSets1 = lists:foldl(fun(S, DS) -> hipe_dsets:union(L, S, DS) end, + DSets0, bb_succ(BB)), + {DSets1, Costs0, bb_code(BB), [], rdefout(L, RDefs), + liveout(Liveness, L, Target)}; + true -> + LastI = #instr{def=LastDef} = bb_last(BB), + LiveBefore = ordsets:subtract(liveout(Liveness, L, Target), LastDef), + %% We can omit the spill of a temp that has not been defined since the + %% last time it was spilled + SpillSet = defsetf_intersect_ordset(LiveBefore, defbutlast(L, Defs)), + Costs1 = costs_insert(exit, L, Wt, SpillSet, Costs0), + Costs4 = lists:foldl(fun({S, BranchWt}, Costs2) -> + SLivein = livein(Liveness, S, Target), + SPLivein = plivein(S, PLive), + SWt = weight_scaled(L, BranchWt, Weights), + Costs3 = costs_insert(entry1, S, SWt, SLivein, Costs2), + costs_insert(entry2, S, SWt, SPLivein, Costs3) + end, Costs1, branch_preds(LastI#instr.i, Target)), + {DSets0, Costs4, bb_butlast(BB), [LastI], rdefsetf_empty(), LiveBefore} + end, + Mode3Splits = mode3_split_in_block(L, Avail), + {RevEntryCode, Restored} = scan_bb_fwd(EntryCode, Mode3Splits, [], []), + {Code, DUCount, Mode2Spills} = + scan_bb(RevEntryCode, Wt, RDefout, Liveout, ducount_new(), [], ExitCode), + DUCounts = DUCounts0#{L => DUCount}, + M2SpillSet = ordsets:from_list(Mode2Spills), + Costs6 = costs_insert(spill, L, Wt, M2SpillSet, Costs5), + Mode3Renames = mode3_block_renameset(L, Avail), + Costs7 = costs_insert(restore, L, Wt, ordsets:intersection(M2SpillSet, Mode3Renames), Costs6), + Costs8 = costs_insert(restore, L, Wt, ordsets:from_list(Restored), Costs7), + Costs = add_unsplit_mode3_costs(DUCount, Mode3Renames, L, Costs8), + scan_bbs(BBs, Liveness, PLive, Weights, Defs, RDefs, Avail, Target, DUCounts, + Costs, DSets, [{L,BB#bb{code=Code}}|Acc]). + +-spec add_unsplit_mode3_costs(ducount(), ordsets:ordset(temp()), label(), costs()) + -> costs(). +add_unsplit_mode3_costs(DUCount, Mode3Renames, L, Costs) -> + Unsplit = orddict_without_ordset(Mode3Renames, + orddict:from_list(ducount_to_list(DUCount))), + add_unsplit_mode3_costs_1(Unsplit, L, Costs). + +-spec add_unsplit_mode3_costs_1([{temp(),float()}], label(), costs()) + -> costs(). +add_unsplit_mode3_costs_1([], _L, Costs) -> Costs; +add_unsplit_mode3_costs_1([{T,C}|Cs], L, Costs) -> + add_unsplit_mode3_costs_1(Cs, L, costs_insert(restore, L, C, [T], Costs)). + +%% @doc Returns a new orddict without keys in Set and their associated values. +-spec orddict_without_ordset(ordsets:ordset(K), orddict:orddict(K, V)) + -> orddict:orddict(K, V). +orddict_without_ordset([S|Ss], [{K,_}|_]=Dict) when S < K -> + orddict_without_ordset(Ss, Dict); +orddict_without_ordset([S|_]=Set, [D={K,_}|Ds]) when S > K -> + [D|orddict_without_ordset(Set, Ds)]; +orddict_without_ordset([_S|Ss], [{_K,_}|Ds]) -> % _S == _K + orddict_without_ordset(Ss, Ds); +orddict_without_ordset(_, []) -> []; +orddict_without_ordset([], Dict) -> Dict. + +%% Scans the code forward, collecting and inserting mode3 restores +-spec scan_bb_fwd([instr()], ordsets:ordset(temp()), ordsets:ordset(temp()), + [code_elem()]) + -> {[code_elem()], ordsets:ordset(temp())}. +scan_bb_fwd([], [], Restored, Acc) -> {Acc, Restored}; +scan_bb_fwd([I|Is], SplitHere0, Restored0, Acc0) -> + #instr{def=Def, use=Use} = I, + {ToRestore, SplitHere1} = + lists:partition(fun(R) -> lists:member(R, Use) end, SplitHere0), + SplitHere = lists:filter(fun(R) -> not lists:member(R, Def) end, SplitHere1), + Acc = + case ToRestore of + [] -> [I | Acc0]; + _ -> [I, #mode3_restores{temps=ToRestore} | Acc0] + end, + scan_bb_fwd(Is, SplitHere, ToRestore ++ Restored0, Acc). + +%% Scans the code backwards, collecting def/use counts and mode2 spills +-spec scan_bb([code_elem()], float(), rdefsetf(), liveset(), ducount(), + [temp()], [code_elem()]) + -> {[code_elem()], ducount(), [temp()]}. +scan_bb([], _Wt, _RDefout, _Liveout, DUCount, Spills, Acc) -> + {Acc, DUCount, Spills}; +scan_bb([I=#mode3_restores{}|Is], Wt, RDefout, Liveout, DUCount, Spills, Acc) -> + scan_bb(Is, Wt, RDefout, Liveout, DUCount, Spills, [I|Acc]); +scan_bb([I|Is], Wt, RDefout, Liveout, DUCount0, Spills0, Acc0) -> + #instr{def=Def,use=Use} = I, + DUCount = ducount_add(Use, Wt, ducount_add(Def, Wt, DUCount0)), + Livein = liveness_step(I, Liveout), + RDefin = rdef_step(I, RDefout), + %% The temps that would be spilled after I in mode 2 + NewSpills = ordset_subtract_rdefsetf( + ordsets:intersection(Def, Liveout), + RDefout), + ?ASSERT(NewSpills =:= (NewSpills -- Spills0)), + Spills = NewSpills ++ Spills0, + Acc1 = case NewSpills of + [] -> Acc0; + _ -> [#mode2_spills{temps=NewSpills}|Acc0] + end, + scan_bb(Is, Wt, RDefin, Livein, DUCount, Spills, [I|Acc1]). + +-spec liveness_step(instr(), liveset()) -> liveset(). +liveness_step(#instr{def=Def, use=Use}, Liveout) -> + ordsets:union(Use, ordsets:subtract(Liveout, Def)). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% First pass: compute basic-block weighting + +-type weights() :: no_bb_weights + | {hipe_bb_weights:bb_weights(), float()}. + +-spec weight(label(), weights()) -> float(). +weight(L, Weights) -> weight_scaled(L, 1.0, Weights). + +-spec compute_weights(target_cfg(), target_module(), target_context(), + comp_options()) -> weights(). +compute_weights(CFG, TargetMod, TargetContext, Options) -> + case proplists:get_bool(range_split_weights, Options) of + false -> no_bb_weights; + true -> + {hipe_bb_weights:compute(CFG, TargetMod, TargetContext), + ?WEIGHT_CONST_FUN(proplists:get_value(range_split_weight_power, + Options, ?DEFAULT_WEIGHT_POWER))} + end. + +-spec weight_scaled(label(), float(), weights()) -> float(). +weight_scaled(_L, _Scale, no_bb_weights) -> 1.0; +weight_scaled(L, Scale, {Weights, Const}) -> + Wt0 = hipe_bb_weights:weight(L, Weights) * Scale, + Wt = erlang:min(erlang:max(Wt0, 0.0000000000000000001), 10000.0), + ?WEIGHT_FUN(Wt, Const). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Heuristic splitting decision. +%% +%% Decide which temps to split, in which parts, and pick new names for them. +-type spill_mode() :: mode1 % Spill temps at partition exits + | mode2 % Spill temps at definitions + | mode3.% Spill temps at definitions, restore temps at uses +-type ren() :: #{temp() => {spill_mode(), temp()}}. +-type renames() :: #{label() => ren()}. + +-record(heur_par, { + mode1_fudge :: float(), + min_gain :: float() + }). +-type heur_par() :: #heur_par{}. + +-spec decide(ducounts(), costs(), target(), comp_options()) -> renames(). +decide(DUCounts, Costs, Target, Options) -> + Par = #heur_par{ + mode1_fudge = proplists:get_value(range_split_mode1_fudge, Options, + ?DEFAULT_MODE1_FUDGE), + min_gain = proplists:get_value(range_split_min_gain, Options, + ?DEFAULT_MIN_GAIN)}, + decide_parts(maps:to_list(DUCounts), Costs, Target, Par, #{}). + +-spec decide_parts([{part_key(), ducount()}], costs(), target(), + heur_par(), renames()) + -> renames(). +decide_parts([], _Costs, _Target, _Par, Acc) -> Acc; +decide_parts([{Part,DUCount}|Ps], Costs, Target, Par, Acc) -> + Spills = decide_temps(ducount_to_list(DUCount), Part, Costs, Target, Par, + #{}), + decide_parts(Ps, Costs, Target, Par, Acc#{Part => Spills}). + +-spec decide_temps([{temp(), float()}], part_key(), costs(), target(), + heur_par(), ren()) + -> ren(). +decide_temps([], _Part, _Costs, _Target, _Par, Acc) -> Acc; +decide_temps([{Temp, SpillGain}|Ts], Part, Costs, Target, Par, Acc0) -> + SpillCost1 = costs_query(Temp, entry1, Part, Costs) + + costs_query(Temp, exit, Part, Costs), + SpillCost2 = costs_query(Temp, entry2, Part, Costs) + + costs_query(Temp, spill, Part, Costs), + SpillCost3 = costs_query(Temp, restore, Part, Costs), + Acc = + %% SpillCost1 =:= 0.0 usually means the temp is local to the partition; + %% hence no need to split it + case (SpillCost1 =/= 0.0) %% maps:is_key(Temp, S) + andalso (not is_precoloured(Temp, Target)) + andalso ((Par#heur_par.min_gain*SpillCost1 < SpillGain) + orelse (Par#heur_par.min_gain*SpillCost2 < SpillGain) + orelse (Par#heur_par.min_gain*SpillCost3 < SpillGain)) + of + false -> Acc0; + true -> + Mode = + if Par#heur_par.mode1_fudge*SpillCost1 < SpillCost2, + Par#heur_par.mode1_fudge*SpillCost1 < SpillCost3 -> + mode1; + SpillCost2 < SpillCost3 -> + mode2; + true -> + mode3 + end, + Acc0#{Temp => {Mode, new_reg_nr(Target)}} + end, + decide_temps(Ts, Part, Costs, Target, Par, Acc). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Eighth pass: Rewrite program performing range splitting. + +-spec rewrite(cfg(), target_cfg(), target(), liveness(), plive(), defs(), + avail(), part_dsets_map(), renames(), temps()) + -> target_cfg(). +rewrite(#cfg{bbs=BBs}, TCFG, Target, Liveness, PLive, Defs, Avail, DSets, + Renames, Temps) -> + rewrite_bbs(maps:to_list(BBs), Target, Liveness, PLive, Defs, Avail, DSets, + Renames, Temps, TCFG). + +-spec rewrite_bbs([{label(), bb()}], target(), liveness(), plive(), defs(), + avail(), part_dsets_map(), renames(), temps(), target_cfg()) + -> target_cfg(). +rewrite_bbs([], _Target, _Liveness, _PLive, _Defs, _Avail, _DSets, _Renames, + _Temps, TCFG) -> + TCFG; +rewrite_bbs([{L,BB}|BBs], Target, Liveness, PLive, Defs, Avail, DSets, Renames, + Temps, TCFG0) -> + Code0Rev = lists:reverse(bb_code(BB)), + EntryRen = maps:get(maps:get(L,DSets), Renames), + M3Ren = mode3_block_renameset(L, Avail), + SubstFun = rewrite_subst_fun(Target, EntryRen, M3Ren), + Fun = fun(I) -> subst_temps(SubstFun, I, Target) end, + {Code, TCFG} = + case bb_has_call(BB) of + false -> + Code1 = rewrite_instrs(Code0Rev, Fun, EntryRen, M3Ren, Temps, Target, + []), + {Code1, TCFG0}; + true -> + CallI0 = hd(Code0Rev), + Succ = bb_succ(BB), + {CallTI, TCFG1} = inject_restores(Succ, Target, Liveness, PLive, DSets, + Renames, Temps, CallI0#instr.i, TCFG0), + Liveout1 = liveness_step(CallI0, liveout(Liveness, L, Target)), + Defout = defbutlast(L, Defs), + SpillMap = mk_spillmap(EntryRen, Liveout1, Defout, Temps, Target), + Code1 = rewrite_instrs(tl(Code0Rev), Fun, EntryRen, M3Ren, Temps, + Target, []), + Code2 = lift_spills(lists:reverse(Code1), Target, SpillMap, [CallTI]), + {Code2, TCFG1} + end, + TBB = hipe_bb:code_update(bb(TCFG, L, Target), Code), + rewrite_bbs(BBs, Target, Liveness, PLive, Defs, Avail, DSets, Renames, Temps, + update_bb(TCFG, L, TBB, Target)). + +-spec rewrite_instrs([code_elem()], rewrite_fun(), ren(), + ordsets:ordset(temp()), temps(), target(), + [target_instr()]) + -> [target_instr()]. +rewrite_instrs([], _Fun, _Ren, _M3Ren, _Temps, _Target, Acc) -> Acc; +rewrite_instrs([I|Is], Fun, Ren, M3Ren, Temps, Target, Acc0) -> + Acc = + case I of + #instr{i=TI} -> [Fun(TI)|Acc0]; + #mode2_spills{temps=Mode2Spills} -> + add_mode2_spills(Mode2Spills, Target, Ren, M3Ren, Temps, Acc0); + #mode3_restores{temps=Mode3Restores} -> + add_mode3_restores(Mode3Restores, Target, Ren, Temps, Acc0) + end, + rewrite_instrs(Is, Fun, Ren, M3Ren, Temps, Target, Acc). + +-spec add_mode2_spills(ordsets:ordset(temp()), target(), ren(), + ordsets:ordset(temp()), temps(), [target_instr()]) + -> [target_instr()]. +add_mode2_spills([], _Target, _Ren, _M3Ren, _Temps, Acc) -> Acc; +add_mode2_spills([R|Rs], Target, Ren, M3Ren, Temps, Acc0) -> + Acc = + case Ren of + #{R := {Mode, NewName}} when Mode =:= mode2; Mode =:= mode3 -> + case Mode =/= mode3 orelse lists:member(R, M3Ren) of + false -> Acc0; + true -> + #{R := T} = Temps, + SpillInstr = mk_move(update_reg_nr(NewName, T, Target), T, Target), + [SpillInstr|Acc0] + end; + #{} -> + Acc0 + end, + add_mode2_spills(Rs, Target, Ren, M3Ren, Temps, Acc). + +-spec add_mode3_restores(ordsets:ordset(temp()), target(), ren(), temps(), + [target_instr()]) + -> [target_instr()]. +add_mode3_restores([], _Target, _Ren, _Temps, Acc) -> Acc; +add_mode3_restores([R|Rs], Target, Ren, Temps, Acc) -> + case Ren of + #{R := {mode3, NewName}} -> + #{R := T} = Temps, + RestoreInstr = mk_move(T, update_reg_nr(NewName, T, Target), Target), + add_mode3_restores(Rs, Target, Ren, Temps, [RestoreInstr|Acc]); + #{} -> + add_mode3_restores(Rs, Target, Ren, Temps, Acc) + end. + +-type rewrite_fun() :: fun((target_instr()) -> target_instr()). +-type subst_fun() :: fun((target_temp()) -> target_temp()). +-spec rewrite_subst_fun(target(), ren(), ordsets:ordset(temp())) -> subst_fun(). +rewrite_subst_fun(Target, Ren, M3Ren) -> + fun(Temp) -> + Reg = reg_nr(Temp, Target), + case Ren of + #{Reg := {Mode, NewName}} -> + case Mode =/= mode3 orelse lists:member(Reg, M3Ren) of + false -> Temp; + true -> update_reg_nr(NewName, Temp, Target) + end; + #{} -> Temp + end + end. + +-type spillmap() :: [{temp(), target_instr()}]. +-spec mk_spillmap(ren(), liveset(), defsetf(), temps(), target()) + -> spillmap(). +mk_spillmap(Ren, Livein, Defout, Temps, Target) -> + [begin + Temp = maps:get(Reg, Temps), + {NewName, mk_move(update_reg_nr(NewName, Temp, Target), Temp, Target)} + end || {Reg, {mode1, NewName}} <- maps:to_list(Ren), + lists:member(Reg, Livein), defsetf_member(Reg, Defout)]. + +-spec mk_restores(ren(), liveset(), liveset(), temps(), target()) + -> [target_instr()]. +mk_restores(Ren, Livein, PLivein, Temps, Target) -> + [begin + Temp = maps:get(Reg, Temps), + mk_move(Temp, update_reg_nr(NewName, Temp, Target), Target) + end || {Reg, {Mode, NewName}} <- maps:to_list(Ren), + ( (Mode =:= mode1 andalso lists:member(Reg, Livein )) + orelse (Mode =:= mode2 andalso lists:member(Reg, PLivein)))]. + +-spec inject_restores([label()], target(), liveness(), plive(), + part_dsets_map(), renames(), temps(), target_instr(), + target_cfg()) + -> {target_instr(), target_cfg()}. +inject_restores([], _Target, _Liveness, _PLive, _DSets, _Renames, _Temps, CFTI, + TCFG) -> + {CFTI, TCFG}; +inject_restores([L|Ls], Target, Liveness, PLive, DSets, Renames, Temps, CFTI0, + TCFG0) -> + Ren = maps:get(maps:get(L,DSets), Renames), + Livein = livein(Liveness, L, Target), + PLivein = plivein(L, PLive), + {CFTI, TCFG} = + case mk_restores(Ren, Livein, PLivein, Temps, Target) of + [] -> {CFTI0, TCFG0}; % optimisation + Restores -> + RestBBLbl = new_label(Target), + Code = Restores ++ [mk_goto(L, Target)], + CFTI1 = redirect_jmp(CFTI0, L, RestBBLbl, Target), + TCFG1 = update_bb(TCFG0, RestBBLbl, hipe_bb:mk_bb(Code), Target), + {CFTI1, TCFG1} + end, + inject_restores(Ls, Target, Liveness, PLive, DSets, Renames, Temps, CFTI, + TCFG). + +%% Heuristic. Move spills up until we meet the edge of the BB or a definition of +%% that temp. +-spec lift_spills([target_instr()], target(), spillmap(), [target_instr()]) + -> [target_instr()]. +lift_spills([], _Target, SpillMap, Acc) -> + [SpillI || {_, SpillI} <- SpillMap] ++ Acc; +lift_spills([I|Is], Target, SpillMap0, Acc) -> + Def = reg_defines(I, Target), + {Spills0, SpillMap} = + lists:partition(fun({Reg,_}) -> lists:member(Reg, Def) end, SpillMap0), + Spills = [SpillI || {_, SpillI} <- Spills0], + lift_spills(Is, Target, SpillMap, [I|Spills ++ Acc]). + +reg_defines(I, Target) -> + reg_names(defines(I,Target), Target). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Costs ADT +%% +%% Keeps track of cumulative cost of spilling temps in particular partitions +%% using particular spill modes. +-type cost_map() :: #{[part_key()|temp()] => float()}. +-type cost_key() :: entry1 | entry2 | exit | spill | restore. +-record(costs, {entry1 = #{} :: cost_map() + ,entry2 = #{} :: cost_map() + ,exit = #{} :: cost_map() + ,spill = #{} :: cost_map() + ,restore = #{} :: cost_map() + }). +-type costs() :: #costs{}. + +-spec costs_new() -> costs(). +costs_new() -> #costs{}. + +-spec costs_insert(cost_key(), part_key(), float(), liveset(), costs()) + -> costs(). +costs_insert(entry1, A, Weight, Liveset, Costs=#costs{entry1=Entry1}) -> + Costs#costs{entry1=costs_insert_1(A, Weight, Liveset, Entry1)}; +costs_insert(entry2, A, Weight, Liveset, Costs=#costs{entry2=Entry2}) -> + Costs#costs{entry2=costs_insert_1(A, Weight, Liveset, Entry2)}; +costs_insert(exit, A, Weight, Liveset, Costs=#costs{exit=Exit}) -> + Costs#costs{exit=costs_insert_1(A, Weight, Liveset, Exit)}; +costs_insert(spill, A, Weight, Liveset, Costs=#costs{spill=Spill}) -> + Costs#costs{spill=costs_insert_1(A, Weight, Liveset, Spill)}; +costs_insert(restore, A, Weight, Liveset, Costs=#costs{restore=Restore}) -> + Costs#costs{restore=costs_insert_1(A, Weight, Liveset, Restore)}. + +costs_insert_1(A, Weight, Liveset, CostMap0) when is_float(Weight) -> + lists:foldl(fun(Live, CostMap1) -> + map_update_counter([A|Live], Weight, CostMap1) + end, CostMap0, Liveset). + +-spec costs_map_roots(part_dsets(), costs()) -> {costs(), part_dsets()}. +costs_map_roots(DSets0, Costs) -> + {Entry1, DSets1} = costs_map_roots_1(DSets0, Costs#costs.entry1), + {Entry2, DSets2} = costs_map_roots_1(DSets1, Costs#costs.entry2), + {Exit, DSets3} = costs_map_roots_1(DSets2, Costs#costs.exit), + {Spill, DSets4} = costs_map_roots_1(DSets3, Costs#costs.spill), + {Restore, DSets} = costs_map_roots_1(DSets4, Costs#costs.restore), + {#costs{entry1=Entry1,entry2=Entry2,exit=Exit,spill=Spill,restore=Restore}, + DSets}. + +costs_map_roots_1(DSets0, CostMap) -> + {NewEs, DSets} = lists:mapfoldl(fun({[A|T], Wt}, DSets1) -> + {AR, DSets2} = hipe_dsets:find(A, DSets1), + {{[AR|T], Wt}, DSets2} + end, DSets0, maps:to_list(CostMap)), + {maps_from_list_merge(NewEs, fun erlang:'+'/2, #{}), DSets}. + +maps_from_list_merge([], _MF, Acc) -> Acc; +maps_from_list_merge([{K,V}|Ps], MF, Acc) -> + maps_from_list_merge(Ps, MF, case Acc of + #{K := OV} -> Acc#{K := MF(V, OV)}; + #{} -> Acc#{K => V} + end). + +-spec costs_query(temp(), cost_key(), part_key(), costs()) -> float(). +costs_query(Temp, entry1, Part, #costs{entry1=Entry1}) -> + costs_query_1(Temp, Part, Entry1); +costs_query(Temp, entry2, Part, #costs{entry2=Entry2}) -> + costs_query_1(Temp, Part, Entry2); +costs_query(Temp, exit, Part, #costs{exit=Exit}) -> + costs_query_1(Temp, Part, Exit); +costs_query(Temp, spill, Part, #costs{spill=Spill}) -> + costs_query_1(Temp, Part, Spill); +costs_query(Temp, restore, Part, #costs{restore=Restore}) -> + costs_query_1(Temp, Part, Restore). + +costs_query_1(Temp, Part, CostMap) -> + Key = [Part|Temp], + case CostMap of + #{Key := Wt} -> Wt; + #{} -> 0.0 + end. + +-spec map_update_counter(Key, number(), #{Key => number(), OK => OV}) + -> #{Key := number(), OK => OV}. +map_update_counter(Key, Incr, Map) -> + case Map of + #{Key := Orig} -> Map#{Key := Orig + Incr}; + #{} -> Map#{Key => Incr} + end. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Def and use counting ADT +-type ducount() :: #{temp() => float()}. + +-spec ducount_new() -> ducount(). +ducount_new() -> #{}. + +-spec ducount_add([temp()], float(), ducount()) -> ducount(). +ducount_add([], _Weight, DUCount) -> DUCount; +ducount_add([T|Ts], Weight, DUCount0) -> + DUCount = + case DUCount0 of + #{T := Count} -> DUCount0#{T := Count + Weight}; + #{} -> DUCount0#{T => Weight} + end, + ducount_add(Ts, Weight, DUCount). + +ducount_to_list(DUCount) -> maps:to_list(DUCount). + +-spec ducount_merge(ducount(), ducount()) -> ducount(). +ducount_merge(DCA, DCB) when map_size(DCA) < map_size(DCB) -> + ducount_merge_1(ducount_to_list(DCA), DCB); +ducount_merge(DCA, DCB) when map_size(DCA) >= map_size(DCB) -> + ducount_merge_1(ducount_to_list(DCB), DCA). + +ducount_merge_1([], DUCount) -> DUCount; +ducount_merge_1([{T,AC}|Ts], DUCount0) -> + DUCount = + case DUCount0 of + #{T := BC} -> DUCount0#{T := AC + BC}; + #{} -> DUCount0#{T => AC} + end, + ducount_merge_1(Ts, DUCount). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Target module interface functions +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +-define(TGT_IFACE_0(N), N( {M,C}) -> M:N( C)). +-define(TGT_IFACE_1(N), N(A1, {M,C}) -> M:N(A1, C)). +-define(TGT_IFACE_2(N), N(A1,A2, {M,C}) -> M:N(A1,A2, C)). +-define(TGT_IFACE_3(N), N(A1,A2,A3,{M,C}) -> M:N(A1,A2,A3,C)). + +?TGT_IFACE_2(bb). +?TGT_IFACE_1(def_use). +?TGT_IFACE_1(defines). +?TGT_IFACE_1(defines_all_alloc). +?TGT_IFACE_1(is_precoloured). +?TGT_IFACE_1(mk_goto). +?TGT_IFACE_2(mk_move). +?TGT_IFACE_0(new_label). +?TGT_IFACE_0(new_reg_nr). +?TGT_IFACE_1(number_of_temporaries). +?TGT_IFACE_3(redirect_jmp). +?TGT_IFACE_1(reg_nr). +?TGT_IFACE_1(reverse_postorder). +?TGT_IFACE_2(subst_temps). +?TGT_IFACE_3(update_bb). +?TGT_IFACE_2(update_reg_nr). + +branch_preds(Instr, {TgtMod,TgtCtx}) -> + merge_sorted_preds(lists:keysort(1, TgtMod:branch_preds(Instr, TgtCtx))). + +livein(Liveness, L, Target={TgtMod,TgtCtx}) -> + ordsets:from_list(reg_names(TgtMod:livein(Liveness, L, TgtCtx), Target)). + +liveout(Liveness, L, Target={TgtMod,TgtCtx}) -> + ordsets:from_list(reg_names(TgtMod:liveout(Liveness, L, TgtCtx), Target)). + +merge_sorted_preds([]) -> []; +merge_sorted_preds([{L, P1}, {L, P2}|LPs]) -> + merge_sorted_preds([{L, P1+P2}|LPs]); +merge_sorted_preds([LP|LPs]) -> [LP|merge_sorted_preds(LPs)]. + +reg_names(Regs, {TgtMod,TgtCtx}) -> + [TgtMod:reg_nr(X,TgtCtx) || X <- Regs]. diff --git a/lib/hipe/regalloc/hipe_regalloc_loop.erl b/lib/hipe/regalloc/hipe_regalloc_loop.erl index 5bbb0ba7c1..29ef3adcc2 100644 --- a/lib/hipe/regalloc/hipe_regalloc_loop.erl +++ b/lib/hipe/regalloc/hipe_regalloc_loop.erl @@ -32,9 +32,11 @@ ra_fp(CFG, Liveness, Options, RegAllocMod, TargetMod, TargetCtx) -> ra_common(CFG0, Liveness0, SpillIndex, Options, RegAllocMod, TargetMod, TargetCtx) -> ?inc_counter(ra_calls_counter, 1), - SpillLimit0 = TargetMod:number_of_temporaries(CFG0, TargetCtx), + {CFG1, Liveness1} = + do_range_split(CFG0, Liveness0, TargetMod, TargetCtx, Options), + SpillLimit0 = TargetMod:number_of_temporaries(CFG1, TargetCtx), {Coloring, _, CFG, Liveness} = - call_allocator_initial(CFG0, Liveness0, SpillLimit0, SpillIndex, Options, + call_allocator_initial(CFG1, Liveness1, SpillLimit0, SpillIndex, Options, RegAllocMod, TargetMod, TargetCtx), %% The first iteration, the hipe_regalloc_prepass may create new temps, these %% should not end up above SpillLimit. @@ -96,3 +98,20 @@ call_allocator(CFG, Liveness, SpillLimit, SpillIndex, Options, RegAllocMod, RegAllocMod:regalloc(CFG, Liveness, SpillIndex, SpillLimit, TargetMod, TargetCtx, Options) end. + +do_range_split(CFG0, Liveness0, TgtMod, TgtCtx, Options) -> + {CFG2, Liveness1} = + case proplists:get_bool(ra_restore_reuse, Options) of + true -> + CFG1 = hipe_restore_reuse:split(CFG0, Liveness0, TgtMod, TgtCtx), + {CFG1, TgtMod:analyze(CFG1, TgtCtx)}; + false -> + {CFG0, Liveness0} + end, + case proplists:get_bool(ra_range_split, Options) of + true -> + CFG3 = hipe_range_split:split(CFG2, Liveness1, TgtMod, TgtCtx, Options), + {CFG3, TgtMod:analyze(CFG3, TgtCtx)}; + false -> + {CFG2, Liveness1} + end. diff --git a/lib/hipe/regalloc/hipe_regalloc_prepass.erl b/lib/hipe/regalloc/hipe_regalloc_prepass.erl index e212420ad2..5024840237 100644 --- a/lib/hipe/regalloc/hipe_regalloc_prepass.erl +++ b/lib/hipe/regalloc/hipe_regalloc_prepass.erl @@ -483,8 +483,8 @@ merge_pointless_splits_1([], _ScanBBs, DSets, Acc) -> {Acc, DSets}; merge_pointless_splits_1([P={_,{single,_}}|Ps], ScanBBs, DSets, Acc) -> merge_pointless_splits_1(Ps, ScanBBs, DSets, [P|Acc]); merge_pointless_splits_1([P0={L,{split,_,_}}|Ps], ScanBBs, DSets0, Acc) -> - {EntryRoot, DSets1} = dsets_find({entry,L}, DSets0), - {ExitRoot, DSets} = dsets_find({exit,L}, DSets1), + {EntryRoot, DSets1} = hipe_dsets:find({entry,L}, DSets0), + {ExitRoot, DSets} = hipe_dsets:find({exit,L}, DSets1), case EntryRoot =:= ExitRoot of false -> merge_pointless_splits_1(Ps, ScanBBs, DSets, [P0|Acc]); true -> @@ -501,7 +501,7 @@ merge_pointless_splits_1([P0={L,{split,_,_}}|Ps], ScanBBs, DSets0, Acc) -> -spec merge_small_parts(bb_dsets()) -> {bb_dsets_rllist(), bb_dsets()}. merge_small_parts(DSets0) -> - {RLList, DSets1} = dsets_to_rllist(DSets0), + {RLList, DSets1} = hipe_dsets:to_rllist(DSets0), RLLList = [{R, length(Elems), Elems} || {R, Elems} <- RLList], merge_small_parts_1(RLLList, DSets1, []). @@ -518,8 +518,8 @@ merge_small_parts_1([Fst,{R, L, Es}|Ps], DSets, Acc) merge_small_parts_1([Fst|Ps], DSets, [{R,Es}|Acc]); merge_small_parts_1([{R1,L1,Es1},{R2,L2,Es2}|Ps], DSets0, Acc) -> ?ASSERT(L1 < ?TUNE_TOO_FEW_BBS andalso L2 < ?TUNE_TOO_FEW_BBS), - DSets1 = dsets_union(R1, R2, DSets0), - {R, DSets} = dsets_find(R1, DSets1), + DSets1 = hipe_dsets:union(R1, R2, DSets0), + {R, DSets} = hipe_dsets:find(R1, DSets1), merge_small_parts_1([{R,L2+L1,Es2++Es1}|Ps], DSets, Acc). %% @doc Partition an ordering over BBs into subsequences for the dsets that @@ -531,8 +531,8 @@ part_order(Lbs, DSets) -> part_order(Lbs, DSets, #{}). part_order([], DSets, Acc) -> {Acc, DSets}; part_order([L|Ls], DSets0, Acc0) -> - {EntryRoot, DSets1} = dsets_find({entry,L}, DSets0), - {ExitRoot, DSets2} = dsets_find({exit,L}, DSets1), + {EntryRoot, DSets1} = hipe_dsets:find({entry,L}, DSets0), + {ExitRoot, DSets2} = hipe_dsets:find({exit,L}, DSets1), Acc1 = map_append(EntryRoot, L, Acc0), %% Only include the label once if both entry and exit is in same partition Acc2 = case EntryRoot =:= ExitRoot of @@ -558,73 +558,26 @@ map_append(Key, Elem, Map) -> %% split point, and one from the end to the last split point. -type bb_dset_key() :: {entry | exit, label()}. --type bb_dsets() :: dsets(bb_dset_key()). +-type bb_dsets() :: hipe_dsets:dsets(bb_dset_key()). -type bb_dsets_rllist() :: [{bb_dset_key(), [bb_dset_key()]}]. -spec initial_dsets(target_cfg(), module(), target_context()) -> bb_dsets(). initial_dsets(CFG, TgtMod, TgtCtx) -> Labels = TgtMod:labels(CFG, TgtCtx), - DSets0 = dsets_new(lists:append([[{entry,L},{exit,L}] || L <- Labels])), + DSets0 = hipe_dsets:new(lists:append([[{entry,L},{exit,L}] || L <- Labels])), Edges = lists:append([[{L, S} || S <- hipe_gen_cfg:succ(CFG, L)] || L <- Labels]), - lists:foldl(fun({X, Y}, DS) -> dsets_union({exit,X}, {entry,Y}, DS) end, + lists:foldl(fun({X, Y}, DS) -> hipe_dsets:union({exit,X}, {entry,Y}, DS) end, DSets0, Edges). -spec join_whole_blocks(part_bb_list(), bb_dsets()) -> bb_dsets(). join_whole_blocks(PartBBList, DSets0) -> - lists:foldl(fun({L, {single, _}}, DS) -> dsets_union({entry,L}, {exit,L}, DS); + lists:foldl(fun({L, {single, _}}, DS) -> + hipe_dsets:union({entry,L}, {exit,L}, DS); ({_, {split, _, _}}, DS) -> DS end, DSets0, PartBBList). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -%% The disjoint set forests data structure, for elements of arbitrary types. -%% Note that the find operation mutates the set. -%% -%% We could do this more efficiently if we restricted the elements to integers, -%% and used the (mutable) hipe arrays. For arbitrary terms ETS could be used, -%% for a persistent interface (which isn't that nice when even accessors return -%% modified copies), the array module could be used. --type dsets(X) :: #{X => {node, X} | {root, non_neg_integer()}}. - --spec dsets_new([E]) -> dsets(E). -dsets_new(Elems) -> maps:from_list([{E,{root,0}} || E <- Elems]). - --spec dsets_find(E, dsets(E)) -> {E, dsets(E)}. -dsets_find(E, DS0) -> - case DS0 of - #{E := {root,_}} -> {E, DS0}; - #{E := {node,N}} -> - case dsets_find(N, DS0) of - {N, _}=T -> T; - {R, DS1} -> {R, DS1#{E := {node,R}}} - end - ;_ -> error(badarg, [E, DS0]) - end. - --spec dsets_union(E, E, dsets(E)) -> dsets(E). -dsets_union(X, Y, DS0) -> - {XRoot, DS1} = dsets_find(X, DS0), - case dsets_find(Y, DS1) of - {XRoot, DS2} -> DS2; - {YRoot, DS2} -> - #{XRoot := {root,XRR}, YRoot := {root,YRR}} = DS2, - if XRR < YRR -> DS2#{XRoot := {node,YRoot}}; - XRR > YRR -> DS2#{YRoot := {node,XRoot}}; - true -> DS2#{YRoot := {node,XRoot}, XRoot := {root,XRR+1}} - end - end. - --spec dsets_to_rllist(dsets(E)) -> {[{Root::E, Elems::[E]}], dsets(E)}. -dsets_to_rllist(DS0) -> - {Lists, DS} = dsets_to_rllist(maps:keys(DS0), #{}, DS0), - {maps:to_list(Lists), DS}. - -dsets_to_rllist([], Acc, DS) -> {Acc, DS}; -dsets_to_rllist([E|Es], Acc, DS0) -> - {ERoot, DS} = dsets_find(E, DS0), - dsets_to_rllist(Es, map_append(ERoot, E, Acc), DS). - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %% Third pass %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %% Collect all referenced temps in each partition. diff --git a/lib/hipe/regalloc/hipe_restore_reuse.erl b/lib/hipe/regalloc/hipe_restore_reuse.erl new file mode 100644 index 0000000000..2158bd185e --- /dev/null +++ b/lib/hipe/regalloc/hipe_restore_reuse.erl @@ -0,0 +1,516 @@ +%% -*- erlang-indent-level: 2 -*- +%% +%% 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. +%% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%@doc +%% RESTORE REUSE LIVE RANGE SPLITTING PASS +%% +%% This is a simple live range splitter that tries to avoid sequences where a +%% temporary is accessed on stack multiple times by keeping a copy of that temp +%% around in a register. +%% +%% At any point where a temporary that is expected to be spilled (see uses of +%% spills_add_list/2) is defined or used, this pass considers that temporary +%% "available". +%% +%% Limitations: +%% * If a live range part starts with several different restores, this module +%% will introduce a new temp number for each of them, and later be forced to +%% generate phi blocks. It would be more efficient to introduce just a +%% single temp number. That would also remove the need for the phi blocks. +%% * If a live range part ends in a definition, that definition should just +%% define the base temp rather than the substitution, since some CISC +%% targets might be able to inline the memory access in the instruction. +-module(hipe_restore_reuse). + +-export([split/4]). + +%% Exports for hipe_range_split, which uses restore_reuse as one possible spill +%% "mode" +-export([analyse/3 + ,renamed_in_block/2 + ,split_in_block/2 + ]). +-export_type([avail/0]). + +-compile(inline). + +%% -define(DO_ASSERT, 1). +-include("../main/hipe.hrl"). + +-type target_cfg() :: any(). +-type liveness() :: any(). +-type target_module() :: module(). +-type target_context() :: any(). +-type target() :: {target_module(), target_context()}. +-type label() :: non_neg_integer(). +-type reg() :: non_neg_integer(). +-type instr() :: any(). +-type temp() :: any(). + +-spec split(target_cfg(), liveness(), target_module(), target_context()) + -> target_cfg(). +split(CFG, Liveness, TargetMod, TargetContext) -> + Target = {TargetMod, TargetContext}, + Avail = analyse(CFG, Liveness, Target), + rewrite(CFG, Target, Avail). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +-opaque avail() :: #{label() => avail_bb()}. + +-record(avail_bb, { + %% Blocks where HasCall is true are considered to have too high + %% register pressure to support a register copy of a temp + has_call :: boolean(), + %% AvailOut: Temps that can be split (are available) + out :: availset(), + %% Gen: AvailOut generated locally + gen :: availset(), + %% WantIn: Temps that are split + want :: regset(), + %% Self: Temps with avail-want pairs locally + self :: regset(), + %% DefIn: Temps shadowed by later def in same live range part + defin :: regset(), + pred :: [label()], + succ :: [label()] + }). +-type avail_bb() :: #avail_bb{}. + +avail_get(L, Avail) -> maps:get(L, Avail). +avail_set(L, Val, Avail) -> maps:put(L, Val, Avail). +avail_has_call(L, Avail) -> (avail_get(L, Avail))#avail_bb.has_call. +avail_out(L, Avail) -> (avail_get(L, Avail))#avail_bb.out. +avail_self(L, Avail) -> (avail_get(L, Avail))#avail_bb.self. +avail_pred(L, Avail) -> (avail_get(L, Avail))#avail_bb.pred. +avail_succ(L, Avail) -> (avail_get(L, Avail))#avail_bb.succ. + +avail_in(L, Avail) -> + case avail_pred(L, Avail) of + [] -> availset_empty(); % entry + Pred -> + lists:foldl(fun(P, ASet) -> + availset_intersect(avail_out(P, Avail), ASet) + end, availset_top(), Pred) + end. + +want_in(L, Avail) -> (avail_get(L, Avail))#avail_bb.want. +want_out(L, Avail) -> + lists:foldl(fun(S, Set) -> + ordsets:union(want_in(S, Avail), Set) + end, ordsets:new(), avail_succ(L, Avail)). + +def_in(L, Avail) -> (avail_get(L, Avail))#avail_bb.defin. +def_out(L, Avail) -> + case avail_succ(L, Avail) of + [] -> ordsets:new(); % entry + Succ -> + ordsets:intersection([def_in(S, Avail) || S <- Succ]) + end. + +-type regset() :: ordsets:ordset(reg()). +-type availset() :: top | regset(). +availset_empty() -> []. +availset_top() -> top. +availset_intersect(top, B) -> B; +availset_intersect(A, top) -> A; +availset_intersect(A, B) -> ordsets:intersection(A, B). +availset_union(top, _) -> top; +availset_union(_, top) -> top; +availset_union(A, B) -> ordsets:union(A, B). +ordset_intersect_availset(OS, top) -> OS; +ordset_intersect_availset(OS, AS) -> ordsets:intersection(OS, AS). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Analysis pass +%% +%% The analysis pass collects the set of temps we're interested in splitting +%% (Spills), and computes three dataflow analyses for this subset of temps. +%% +%% Avail, which is the set of temps which are available in register from a +%% previous (potential) spill or restore without going through a HasCall +%% block. +%% Want, which is a liveness analysis for the subset of temps used by an +%% instruction that are also in Avail at that point. In other words, Want is +%% the set of temps that are split (has a register copy) at a particular +%% point. +%% Def, which are the temps that are already going to be spilled later, and so +%% need not be spilled when they're defined. +%% +%% Lastly, it computes the set Self for each block, which is the temps that have +%% avail-want pairs in the same block, and so should be split in that block even +%% if they're not in WantIn for the block. + +-spec analyse(target_cfg(), liveness(), target()) -> avail(). +analyse(CFG, Liveness, Target) -> + Avail0 = analyse_init(CFG, Liveness, Target), + RPO = reverse_postorder(CFG, Target), + AvailLs = [L || L <- RPO, not avail_has_call(L, Avail0)], + Avail1 = avail_dataf(AvailLs, Avail0), + Avail2 = analyse_filter_want(maps:keys(Avail1), Avail1), + PO = lists:reverse(RPO), + want_dataf(PO, Avail2). + +-spec analyse_init(target_cfg(), liveness(), target()) -> avail(). +analyse_init(CFG, Liveness, Target) -> + analyse_init(labels(CFG, Target), CFG, Liveness, Target, #{}, []). + +-spec analyse_init([label()], target_cfg(), liveness(), target(), spillset(), + [{label(), avail_bb()}]) + -> avail(). +analyse_init([], _CFG, _Liveness, Target, Spills0, Acc) -> + %% Precoloured temps can't be spilled + Spills = spills_filter(fun(R) -> not is_precoloured(R, Target) end, Spills0), + analyse_init_1(Acc, Spills, []); +analyse_init([L|Ls], CFG, Liveness, Target, Spills0, Acc) -> + {DefIn, Gen, Self, Want, HasCall0} = + analyse_scan(hipe_bb:code(bb(CFG, L, Target)), Target, + ordsets:new(), ordsets:new(), ordsets:new(), + ordsets:new()), + {Spills, Out, HasCall} = + case HasCall0 of + false -> {Spills0, availset_top(), false}; + {true, CallDefs} -> + Spill = ordsets:subtract(liveout(Liveness, L, Target), CallDefs), + {spills_add_list(Spill, Spills0), Gen, true} + end, + Pred = hipe_gen_cfg:pred(CFG, L), + Succ = hipe_gen_cfg:succ(CFG, L), + Val = #avail_bb{gen=Gen, want=Want, self=Self, out=Out, has_call=HasCall, + pred=Pred, succ=Succ, defin=DefIn}, + analyse_init(Ls, CFG, Liveness, Target, Spills, [{L, Val} | Acc]). + +-spec analyse_init_1([{label(), avail_bb()}], spillset(), + [{label(), avail_bb()}]) + -> avail(). +analyse_init_1([], _Spills, Acc) -> maps:from_list(Acc); +analyse_init_1([{L, Val0}|Vs], Spills, Acc) -> + #avail_bb{out=Out,gen=Gen,want=Want,self=Self} = Val0, + Val = Val0#avail_bb{ + out = spills_filter_availset(Out, Spills), + gen = spills_filter_availset(Gen, Spills), + want = spills_filter_availset(Want, Spills), + self = spills_filter_availset(Self, Spills)}, + analyse_init_1(Vs, Spills, [{L, Val} | Acc]). + +-type spillset() :: #{reg() => []}. +-spec spills_add_list([reg()], spillset()) -> spillset(). +spills_add_list([], Spills) -> Spills; +spills_add_list([R|Rs], Spills) -> spills_add_list(Rs, Spills#{R => []}). + +-spec spills_filter_availset(availset(), spillset()) -> availset(). +spills_filter_availset([E|Es], Spills) -> + case Spills of + #{E := _} -> [E|spills_filter_availset(Es, Spills)]; + #{} -> spills_filter_availset(Es, Spills) + end; +spills_filter_availset([], _) -> []; +spills_filter_availset(top, _) -> top. + +spills_filter(Fun, Spills) -> maps:filter(fun(K, _) -> Fun(K) end, Spills). + +-spec analyse_scan([instr()], target(), Defset, Gen, Self, Want) + -> {Defset, Gen, Self, Want, HasCall} when + HasCall :: false | {true, regset()}, + Defset :: regset(), + Gen :: availset(), + Self :: regset(), + Want :: regset(). +analyse_scan([], _Target, Defs, Gen, Self, Want) -> + {Defs, Gen, Self, Want, false}; +analyse_scan([I|Is], Target, Defs0, Gen0, Self0, Want0) -> + {DefL, UseL} = reg_def_use(I, Target), + Use = ordsets:from_list(UseL), + Def = ordsets:from_list(DefL), + Self = ordsets:union(ordsets:intersection(Use, Gen0), Self0), + Want = ordsets:union(ordsets:subtract(Use, Defs0), Want0), + Defs = ordsets:union(Def, Defs0), + case defines_all_alloc(I, Target) of + true -> + [] = Is, %assertion + {Defs, ordsets:new(), Self, Want, {true, Def}}; + false -> + Gen = ordsets:union(ordsets:union(Def, Use), Gen0), + analyse_scan(Is, Target, Defs, Gen, Self, Want) + end. + +-spec avail_dataf([label()], avail()) -> avail(). +avail_dataf(RPO, Avail0) -> + case avail_dataf_once(RPO, Avail0, 0) of + {Avail, 0} -> Avail; + {Avail, _Changed} -> + avail_dataf(RPO, Avail) + end. + +-spec avail_dataf_once([label()], avail(), non_neg_integer()) + -> {avail(), non_neg_integer()}. +avail_dataf_once([], Avail, Changed) -> {Avail, Changed}; +avail_dataf_once([L|Ls], Avail0, Changed0) -> + ABB = #avail_bb{out=OldOut, gen=Gen} = avail_get(L, Avail0), + In = avail_in(L, Avail0), + {Changed, Avail} = + case availset_union(In, Gen) of + OldOut -> {Changed0, Avail0}; + Out -> {Changed0+1, avail_set(L, ABB#avail_bb{out=Out}, Avail0)} + end, + avail_dataf_once(Ls, Avail, Changed). + +-spec analyse_filter_want([label()], avail()) -> avail(). +analyse_filter_want([], Avail) -> Avail; +analyse_filter_want([L|Ls], Avail0) -> + ABB = #avail_bb{want=Want0, defin=DefIn0} = avail_get(L, Avail0), + In = avail_in(L, Avail0), + Want = ordset_intersect_availset(Want0, In), + DefIn = ordset_intersect_availset(DefIn0, In), + Avail = avail_set(L, ABB#avail_bb{want=Want, defin=DefIn}, Avail0), + analyse_filter_want(Ls, Avail). + +-spec want_dataf([label()], avail()) -> avail(). +want_dataf(PO, Avail0) -> + case want_dataf_once(PO, Avail0, 0) of + {Avail, 0} -> Avail; + {Avail, _Changed} -> + want_dataf(PO, Avail) + end. + +-spec want_dataf_once([label()], avail(), non_neg_integer()) + -> {avail(), non_neg_integer()}. +want_dataf_once([], Avail, Changed) -> {Avail, Changed}; +want_dataf_once([L|Ls], Avail0, Changed0) -> + ABB0 = #avail_bb{want=OldIn,defin=OldDef} = avail_get(L, Avail0), + AvailIn = avail_in(L, Avail0), + Out = want_out(L, Avail0), + DefOut = def_out(L, Avail0), + {Changed, Avail} = + case {ordsets:union(ordset_intersect_availset(Out, AvailIn), OldIn), + ordsets:union(ordset_intersect_availset(DefOut, AvailIn), OldDef)} + of + {OldIn, OldDef} -> {Changed0, Avail0}; + {In, DefIn} -> + ABB = ABB0#avail_bb{want=In,defin=DefIn}, + {Changed0+1, avail_set(L, ABB, Avail0)} + end, + want_dataf_once(Ls, Avail, Changed). + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Rewrite pass +-type subst_dict() :: orddict:orddict(reg(), reg()). +-type input() :: #{label() => subst_dict()}. + +-spec rewrite(target_cfg(), target(), avail()) -> target_cfg(). +rewrite(CFG, Target, Avail) -> + RPO = reverse_postorder(CFG, Target), + rewrite(RPO, Target, Avail, #{}, CFG). + +-spec rewrite([label()], target(), avail(), input(), target_cfg()) + -> target_cfg(). +rewrite([], _Target, _Avail, _Input, CFG) -> CFG; +rewrite([L|Ls], Target, Avail, Input0, CFG0) -> + SplitHere = split_in_block(L, Avail), + {Input1, LInput} = + case Input0 of + #{L := LInput0} -> {Input0, LInput0}; + #{} -> {Input0#{L => []}, []} % entry block + end, + ?ASSERT([] =:= [X || X <- SplitHere, orddict:is_key(X, LInput)]), + ?ASSERT(want_in(L, Avail) =:= orddict:fetch_keys(LInput)), + {CFG1, LOutput} = + case {SplitHere, LInput} of + {[], []} -> % optimisation (rewrite will do nothing, so skip it) + {CFG0, LInput}; + _ -> + Code0 = hipe_bb:code(BB=bb(CFG0, L, Target)), + DefOut = def_out(L, Avail), + {Code, LOutput0, _DefIn} = + rewrite_instrs(Code0, Target, LInput, DefOut, SplitHere), + {update_bb(CFG0, L, hipe_bb:code_update(BB, Code), Target), LOutput0} + end, + {Input, CFG} = rewrite_succs(avail_succ(L, Avail), Target, L, LOutput, Avail, + Input1, CFG1), + rewrite(Ls, Target, Avail, Input, CFG). + +-spec renamed_in_block(label(), avail()) -> ordsets:ordset(reg()). +renamed_in_block(L, Avail) -> + ordsets:union([avail_self(L, Avail), want_in(L, Avail), + want_out(L, Avail)]). + +-spec split_in_block(label(), avail()) -> ordsets:ordset(reg()). +split_in_block(L, Avail) -> + ordsets:subtract(ordsets:union(avail_self(L, Avail), want_out(L, Avail)), + want_in(L, Avail)). + +-spec rewrite_instrs([instr()], target(), subst_dict(), regset(), [reg()]) + -> {[instr()], subst_dict(), regset()}. +rewrite_instrs([], _Target, Output, DefOut, []) -> + {[], Output, DefOut}; +rewrite_instrs([I|Is], Target, Input0, BBDefOut, SplitHere0) -> + {TDef, TUse} = def_use(I, Target), + {Def, Use} = {reg_names(TDef, Target), reg_names(TUse, Target)}, + %% Restores are generated in forward order by picking temps from SplitHere as + %% they're used or defined. After the last instruction, all temps have been + %% picked. + {ISplits, SplitHere} = + lists:partition(fun(R) -> + lists:member(R, Def) orelse lists:member(R, Use) + end, SplitHere0), + {Input, Restores} = + case ISplits of + [] -> {Input0, []}; + _ -> + make_splits(ISplits, Target, TDef, TUse, Input0, []) + end, + %% Here's the recursive call + {Acc0, Output, DefOut} = + rewrite_instrs(Is, Target, Input, BBDefOut, SplitHere), + %% From here we're processing instructions in reverse order, because to avoid + %% redundant spills we need to walk the 'def' dataflow, which is in reverse. + SubstFun = fun(Temp) -> + case orddict:find(reg_nr(Temp, Target), Input) of + {ok, NewTemp} -> NewTemp; + error -> Temp + end + end, + Acc1 = insert_spills(TDef, Target, Input, DefOut, Acc0), + Acc = Restores ++ [subst_temps(SubstFun, I, Target) | Acc1], + DefIn = ordsets:union(DefOut, ordsets:from_list(Def)), + {Acc, Output, DefIn}. + +-spec make_splits([reg()], target(), [temp()], [temp()], subst_dict(), + [instr()]) + -> {subst_dict(), [instr()]}. +make_splits([], _Target, _TDef, _TUse, Input, Acc) -> + {Input, Acc}; +make_splits([S|Ss], Target, TDef, TUse, Input0, Acc0) -> + SubstReg = new_reg_nr(Target), + {Acc, Subst} = + case find_reg_temp(S, TUse, Target) of + error -> + {ok, Temp} = find_reg_temp(S, TDef, Target), + {Acc0, update_reg_nr(SubstReg, Temp, Target)}; + {ok, Temp} -> + Subst0 = update_reg_nr(SubstReg, Temp, Target), + Acc1 = [mk_move(Temp, Subst0, Target) | Acc0], + {Acc1, Subst0} + end, + Input = orddict:store(S, Subst, Input0), + make_splits(Ss, Target, TDef, TUse, Input, Acc). + +-spec find_reg_temp(reg(), [temp()], target()) -> error | {ok, temp()}. +find_reg_temp(_Reg, [], _Target) -> error; +find_reg_temp(Reg, [T|Ts], Target) -> + case reg_nr(T, Target) of + Reg -> {ok, T}; + _ -> find_reg_temp(Reg, Ts, Target) + end. + +-spec insert_spills([temp()], target(), subst_dict(), regset(), [instr()]) + -> [instr()]. +insert_spills([], _Target, _Input, _DefOut, Acc) -> Acc; +insert_spills([T|Ts], Target, Input, DefOut, Acc0) -> + R = reg_nr(T, Target), + Acc = + case orddict:find(R, Input) of + error -> Acc0; + {ok, Subst} -> + case lists:member(R, DefOut) of + true -> Acc0; + false -> [mk_move(Subst, T, Target) | Acc0] + end + end, + insert_spills(Ts, Target, Input, DefOut, Acc). + +-spec rewrite_succs([label()], target(), label(), subst_dict(), avail(), + input(), target_cfg()) -> {input(), target_cfg()}. +rewrite_succs([], _Target, _P, _POutput, _Avail, Input, CFG) -> {Input, CFG}; +rewrite_succs([L|Ls], Target, P, POutput, Avail, Input0, CFG0) -> + NewLInput = orddict_with_ordset(want_in(L, Avail), POutput), + {Input, CFG} = + case Input0 of + #{L := LInput} -> + CFG2 = + case required_phi_moves(LInput, NewLInput) of + [] -> CFG0; + ReqMovs -> + PhiLb = new_label(Target), + Code = [mk_move(S,D,Target) || {S,D} <- ReqMovs] + ++ [mk_goto(L, Target)], + PhiBB = hipe_bb:mk_bb(Code), + CFG1 = update_bb(CFG0, PhiLb, PhiBB, Target), + bb_redirect_jmp(L, PhiLb, P, CFG1, Target) + end, + {Input0, CFG2}; + #{} -> + {Input0#{L => NewLInput}, CFG0} + end, + rewrite_succs(Ls, Target, P, POutput, Avail, Input, CFG). + +-spec bb_redirect_jmp(label(), label(), label(), target_cfg(), target()) + -> target_cfg(). +bb_redirect_jmp(From, To, Lb, CFG, Target) -> + BB0 = bb(CFG, Lb, Target), + Last = redirect_jmp(hipe_bb:last(BB0), From, To, Target), + BB = hipe_bb:code_update(BB0, hipe_bb:butlast(BB0) ++ [Last]), + update_bb(CFG, Lb, BB, Target). + +-spec required_phi_moves(subst_dict(), subst_dict()) -> [{reg(), reg()}]. +required_phi_moves([], []) -> []; +required_phi_moves([P|Is], [P|Os]) -> required_phi_moves(Is, Os); +required_phi_moves([{K, In}|Is], [{K, Out}|Os]) -> + [{Out, In}|required_phi_moves(Is, Os)]. + +%% @doc Returns a new orddict with the keys in Set and their associated values. +-spec orddict_with_ordset(ordsets:ordset(K), orddict:orddict(K, V)) + -> orddict:orddict(K, V). +orddict_with_ordset([S|Ss], [{K, _}|_]=Dict) when S < K -> + orddict_with_ordset(Ss, Dict); +orddict_with_ordset([S|_]=Set, [{K, _}|Ds]) when S > K -> + orddict_with_ordset(Set, Ds); +orddict_with_ordset([_S|Ss], [{_K, _}=P|Ds]) -> % _S == _K + [P|orddict_with_ordset(Ss, Ds)]; +orddict_with_ordset([], _) -> []; +orddict_with_ordset(_, []) -> []. + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%% Target module interface functions +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +-define(TGT_IFACE_0(N), N( {M,C}) -> M:N( C)). +-define(TGT_IFACE_1(N), N(A1, {M,C}) -> M:N(A1, C)). +-define(TGT_IFACE_2(N), N(A1,A2, {M,C}) -> M:N(A1,A2, C)). +-define(TGT_IFACE_3(N), N(A1,A2,A3,{M,C}) -> M:N(A1,A2,A3,C)). + +?TGT_IFACE_2(bb). +?TGT_IFACE_1(def_use). +?TGT_IFACE_1(defines_all_alloc). +?TGT_IFACE_1(is_precoloured). +?TGT_IFACE_1(labels). +?TGT_IFACE_1(mk_goto). +?TGT_IFACE_2(mk_move). +?TGT_IFACE_0(new_label). +?TGT_IFACE_0(new_reg_nr). +?TGT_IFACE_3(redirect_jmp). +?TGT_IFACE_1(reg_nr). +?TGT_IFACE_1(reverse_postorder). +?TGT_IFACE_2(subst_temps). +?TGT_IFACE_3(update_bb). +?TGT_IFACE_2(update_reg_nr). + +liveout(Liveness, L, Target={TgtMod,TgtCtx}) -> + ordsets:from_list(reg_names(TgtMod:liveout(Liveness, L, TgtCtx), Target)). + +reg_names(Regs, {TgtMod,TgtCtx}) -> + [TgtMod:reg_nr(X,TgtCtx) || X <- Regs]. + +reg_def_use(I, Target) -> + {TDef, TUse} = def_use(I, Target), + {reg_names(TDef, Target), reg_names(TUse, Target)}. diff --git a/lib/hipe/regalloc/hipe_sparc_specific.erl b/lib/hipe/regalloc/hipe_sparc_specific.erl index 31fca81316..78b6379eba 100644 --- a/lib/hipe/regalloc/hipe_sparc_specific.erl +++ b/lib/hipe/regalloc/hipe_sparc_specific.erl @@ -24,6 +24,7 @@ ,reg_nr/2 ,def_use/2 ,is_move/2 + ,is_spill_move/2 ,is_precoloured/2 ,var_range/2 ,allocatable/1 @@ -46,12 +47,19 @@ %% callbacks for hipe_regalloc_loop -export([check_and_rewrite/3]). -%% callbacks for hipe_regalloc_prepass --export([new_reg_nr/1, +%% callbacks for hipe_regalloc_prepass, hipe_range_split +-export([mk_move/3, + mk_goto/2, + redirect_jmp/4, + new_label/1, + new_reg_nr/1, update_reg_nr/3, update_bb/4, subst_temps/3]). +%% callbacks for hipe_bb_weights, hipe_range_split +-export([branch_preds/2]). + check_and_rewrite(CFG, Coloring, no_context) -> hipe_sparc_ra_postconditions:check_and_rewrite(CFG, Coloring, 'normal'). @@ -115,6 +123,9 @@ bb(CFG,L,_) -> update_bb(CFG,L,BB,_) -> hipe_sparc_cfg:bb_add(CFG,L,BB). +branch_preds(Branch,_) -> + hipe_sparc_cfg:branch_preds(Branch). + %% SPARC stuff def_use(Instruction, Ctx) -> @@ -144,9 +155,24 @@ is_move(Instruction, _) -> false -> false end. +is_spill_move(Instruction, _) -> + hipe_sparc:is_pseudo_spill_move(Instruction). + reg_nr(Reg, _) -> hipe_sparc:temp_reg(Reg). +mk_move(Src, Dst, _) -> + hipe_sparc:mk_pseudo_move(Src, Dst). + +mk_goto(Label, _) -> + hipe_sparc:mk_b_label(Label). + +redirect_jmp(Jmp, ToOld, ToNew, _) when is_integer(ToOld), is_integer(ToNew) -> + hipe_sparc_cfg:redirect_jmp(Jmp, ToOld, ToNew). + +new_label(_) -> + hipe_gensym:get_next_label(sparc). + new_reg_nr(_) -> hipe_gensym:get_next_var(sparc). diff --git a/lib/hipe/regalloc/hipe_sparc_specific_fp.erl b/lib/hipe/regalloc/hipe_sparc_specific_fp.erl index 050d65e1a9..485fdc212a 100644 --- a/lib/hipe/regalloc/hipe_sparc_specific_fp.erl +++ b/lib/hipe/regalloc/hipe_sparc_specific_fp.erl @@ -24,6 +24,7 @@ ,reg_nr/2 ,def_use/2 ,is_move/2 + ,is_spill_move/2 ,is_precoloured/2 ,var_range/2 ,allocatable/1 @@ -46,12 +47,19 @@ %% callbacks for hipe_regalloc_loop -export([check_and_rewrite/3]). -%% callbacks for hipe_regalloc_prepass --export([new_reg_nr/1, +%% callbacks for hipe_regalloc_prepass, hipe_range_split +-export([mk_move/3, + mk_goto/2, + redirect_jmp/4, + new_label/1, + new_reg_nr/1, update_reg_nr/3, update_bb/4, subst_temps/3]). +%% callbacks for hipe_bb_weights, hipe_range_split +-export([branch_preds/2]). + check_and_rewrite(CFG, Coloring, no_context) -> hipe_sparc_ra_postconditions_fp:check_and_rewrite(CFG, Coloring). @@ -108,6 +116,9 @@ bb(CFG, L, _) -> update_bb(CFG,L,BB,_) -> hipe_sparc_cfg:bb_add(CFG,L,BB). +branch_preds(Branch,_) -> + hipe_sparc_cfg:branch_preds(Branch). + %% SPARC stuff def_use(I, Ctx) -> @@ -125,9 +136,24 @@ defines_all_alloc(I, _) -> is_move(I, _) -> hipe_sparc:is_pseudo_fmove(I). +is_spill_move(I, _) -> + hipe_sparc:is_pseudo_spill_fmove(I). + reg_nr(Reg, _) -> hipe_sparc:temp_reg(Reg). +mk_move(Src, Dst, _) -> + hipe_sparc:mk_pseudo_fmove(Src, Dst). + +mk_goto(Label, _) -> + hipe_sparc:mk_b_label(Label). + +redirect_jmp(Jmp, ToOld, ToNew, _) when is_integer(ToOld), is_integer(ToNew) -> + hipe_sparc_cfg:redirect_jmp(Jmp, ToOld, ToNew). + +new_label(_) -> + hipe_gensym:get_next_label(sparc). + new_reg_nr(_) -> hipe_gensym:get_next_var(sparc). diff --git a/lib/hipe/regalloc/hipe_x86_specific.erl b/lib/hipe/regalloc/hipe_x86_specific.erl index c1c8dbbcd6..dacfb71b00 100644 --- a/lib/hipe/regalloc/hipe_x86_specific.erl +++ b/lib/hipe/regalloc/hipe_x86_specific.erl @@ -46,6 +46,7 @@ def_use/2, is_arg/2, % used by hipe_ls_regalloc is_move/2, + is_spill_move/2, is_fixed/2, % used by hipe_graph_coloring_regalloc is_global/2, is_precoloured/2, @@ -63,12 +64,19 @@ %% callbacks for hipe_regalloc_loop -export([check_and_rewrite/3]). -%% callbacks for hipe_regalloc_prepass --export([new_reg_nr/1, +%% callbacks for hipe_regalloc_prepass, hipe_range_split +-export([mk_move/3, + mk_goto/2, + redirect_jmp/4, + new_label/1, + new_reg_nr/1, update_reg_nr/3, update_bb/4, subst_temps/3]). +%% callbacks for hipe_bb_weights +-export([branch_preds/2]). + check_and_rewrite(CFG, Coloring, _) -> ?HIPE_X86_RA_POSTCONDITIONS:check_and_rewrite(CFG, Coloring, 'normal'). @@ -156,6 +164,9 @@ bb(CFG,L,_) -> update_bb(CFG,L,BB,_) -> hipe_x86_cfg:bb_add(CFG,L,BB). +branch_preds(Instr,_) -> + hipe_x86_cfg:branch_preds(Instr). + %% X86 stuff def_use(Instruction,_) -> @@ -200,9 +211,33 @@ is_move(Instruction,_) -> false -> false end. +is_spill_move(Instruction,_) -> + hipe_x86:is_pseudo_spill_move(Instruction). + reg_nr(Reg,_) -> hipe_x86:temp_reg(Reg). +mk_move(Src, Dst, _) -> + hipe_x86:mk_move(Src, Dst). + +mk_goto(Label, _) -> + hipe_x86:mk_jmp_label(Label). + +redirect_jmp(Jmp, ToOld, ToNew, _) when is_integer(ToOld), is_integer(ToNew) -> + Ref = make_ref(), + put(Ref, false), + I = hipe_x86_subst:insn_lbls( + fun(Tgt) -> + if Tgt =:= ToOld -> put(Ref, true), ToNew; + is_integer(Tgt) -> Tgt + end + end, Jmp), + true = erase(Ref), % Assert that something was rewritten + I. + +new_label(_) -> + hipe_gensym:get_next_label(x86). + new_reg_nr(_) -> hipe_gensym:get_next_var(x86). diff --git a/lib/hipe/regalloc/hipe_x86_specific_x87.erl b/lib/hipe/regalloc/hipe_x86_specific_x87.erl index 4b4c83f76d..3fe49e1f00 100644 --- a/lib/hipe/regalloc/hipe_x86_specific_x87.erl +++ b/lib/hipe/regalloc/hipe_x86_specific_x87.erl @@ -47,6 +47,7 @@ uses/2, defines/2, defines_all_alloc/2, + is_spill_move/2, is_global/2, reg_nr/2, physical_name/2, @@ -158,6 +159,9 @@ defines(I, _) -> defines_all_alloc(I, _) -> hipe_amd64_defuse:insn_defs_all(I). +is_spill_move(I, _) -> + hipe_x86:is_pseudo_spill_fmove(I). + temp_is_double(Temp) -> hipe_x86:temp_type(Temp) =:= 'double'. diff --git a/lib/hipe/sparc/hipe_sparc.erl b/lib/hipe/sparc/hipe_sparc.erl index 916857b224..22e0761b69 100644 --- a/lib/hipe/sparc/hipe_sparc.erl +++ b/lib/hipe/sparc/hipe_sparc.erl @@ -87,6 +87,9 @@ mk_pseudo_set/2, + mk_pseudo_spill_move/3, + is_pseudo_spill_move/1, + mk_pseudo_tailcall/4, pseudo_tailcall_funv/1, pseudo_tailcall_linkage/1, @@ -117,6 +120,9 @@ pseudo_fmove_src/1, pseudo_fmove_dst/1, + mk_pseudo_spill_fmove/3, + is_pseudo_spill_fmove/1, + mk_pseudo_fstore/3, mk_fstore/4, @@ -269,6 +275,10 @@ mk_pseudo_ret() -> #pseudo_ret{}. mk_pseudo_set(Imm, Dst) -> #pseudo_set{imm=Imm, dst=Dst}. +mk_pseudo_spill_move(Src, Temp, Dst) -> + #pseudo_spill_move{src=Src, temp=Temp, dst=Dst}. +is_pseudo_spill_move(I) -> is_record(I, pseudo_spill_move). + mk_pseudo_tailcall(FunV, Arity, StkArgs, Linkage) -> #pseudo_tailcall{funv=FunV, arity=Arity, stkargs=StkArgs, linkage=Linkage}. pseudo_tailcall_funv(#pseudo_tailcall{funv=FunV}) -> FunV. @@ -375,6 +385,10 @@ is_pseudo_fmove(I) -> case I of #pseudo_fmove{} -> true; _ -> false end. pseudo_fmove_src(#pseudo_fmove{src=Src}) -> Src. pseudo_fmove_dst(#pseudo_fmove{dst=Dst}) -> Dst. +mk_pseudo_spill_fmove(Src, Temp, Dst) -> + #pseudo_spill_fmove{src=Src, temp=Temp, dst=Dst}. +is_pseudo_spill_fmove(I) -> is_record(I, pseudo_spill_fmove). + mk_pseudo_fstore(Src, Base, Disp) -> #pseudo_fstore{src=Src, base=Base, disp=Disp}. diff --git a/lib/hipe/sparc/hipe_sparc.hrl b/lib/hipe/sparc/hipe_sparc.hrl index 4eae6777a9..f60e516e59 100644 --- a/lib/hipe/sparc/hipe_sparc.hrl +++ b/lib/hipe/sparc/hipe_sparc.hrl @@ -88,6 +88,8 @@ -record(pseudo_move, {src, dst}). -record(pseudo_ret, {}). -record(pseudo_set, {imm, dst}). +-record(pseudo_spill_fmove, {src, temp, dst}). +-record(pseudo_spill_move, {src, temp, dst}). -record(pseudo_tailcall, {funv, arity, stkargs, linkage}). -record(pseudo_tailcall_prepare, {}). -record(rdy, {dst}). diff --git a/lib/hipe/sparc/hipe_sparc_assemble.erl b/lib/hipe/sparc/hipe_sparc_assemble.erl index 08bd47c4d2..2b82f41d23 100644 --- a/lib/hipe/sparc/hipe_sparc_assemble.erl +++ b/lib/hipe/sparc/hipe_sparc_assemble.erl @@ -32,7 +32,7 @@ assemble(CompiledCode, Closures, Exports, Options) -> || {MFA, Defun} <- CompiledCode], %% {ConstAlign,ConstSize,ConstMap,RefsFromConsts} = - hipe_pack_constants:pack_constants(Code, 4), + hipe_pack_constants:pack_constants(Code), %% {CodeSize,CodeBinary,AccRefs,LabelMap,ExportMap} = encode(translate(Code, ConstMap), Options), diff --git a/lib/hipe/sparc/hipe_sparc_cfg.erl b/lib/hipe/sparc/hipe_sparc_cfg.erl index 27374d187b..45c8e887b5 100644 --- a/lib/hipe/sparc/hipe_sparc_cfg.erl +++ b/lib/hipe/sparc/hipe_sparc_cfg.erl @@ -23,6 +23,7 @@ -export([linearise/1]). -export([params/1]). -export([arity/1]). % for linear scan +-export([redirect_jmp/3, branch_preds/1]). -define(SPARC_CFG, true). % needed for cfg.inc @@ -77,28 +78,53 @@ branch_successors(Branch) -> #pseudo_tailcall{} -> [] end. +branch_preds(Branch) -> + case Branch of + #jmp{labels=Labels} -> + Prob = 1.0/length(Labels), + [{L, Prob} || L <- Labels]; + #pseudo_bp{true_label=TrueLab,false_label=FalseLab,pred=Pred} -> + [{FalseLab, 1.0-Pred}, {TrueLab, Pred}]; + #pseudo_call{contlab=ContLab, sdesc=#sparc_sdesc{exnlab=[]}} -> + %% A function can still cause an exception, even if we won't catch it + [{ContLab, 1.0-hipe_bb_weights:call_exn_pred()}]; + #pseudo_call{contlab=ContLab, sdesc=#sparc_sdesc{exnlab=ExnLab}} -> + CallExnPred = hipe_bb_weights:call_exn_pred(), + [{ContLab, 1.0-CallExnPred}, {ExnLab, CallExnPred}]; + _ -> + case branch_successors(Branch) of + [] -> []; + [Single] -> [{Single, 1.0}] + end + end. + -ifdef(REMOVE_TRIVIAL_BBS_NEEDED). fails_to(_Instr) -> []. -endif. --ifdef(notdef). redirect_jmp(I, Old, New) -> case I of - #b_label{label=Label} -> - if Old =:= Label -> I#b_label{label=New}; + #bp{'cond'='a',label=Label} -> + if Old =:= Label -> I#bp{label=New}; true -> I end; - #pseudo_bc{true_label=TrueLab, false_label=FalseLab} -> - I1 = if Old =:= TrueLab -> I#pseudo_bc{true_label=New}; + #pseudo_bp{true_label=TrueLab, false_label=FalseLab} -> + I1 = if Old =:= TrueLab -> I#pseudo_bp{true_label=New}; true -> I end, - if Old =:= FalseLab -> I1#pseudo_bc{false_label=New}; + if Old =:= FalseLab -> I1#pseudo_bp{false_label=New}; true -> I1 end; - %% handle pseudo_call too? - _ -> I + #pseudo_call{contlab=ContLab0, sdesc=SDesc0} -> + SDesc = case SDesc0 of + #sparc_sdesc{exnlab=Old} -> SDesc0#sparc_sdesc{exnlab=New}; + #sparc_sdesc{exnlab=_} -> SDesc0 + end, + ContLab = if Old =:= ContLab0 -> New; + true -> ContLab0 + end, + I#pseudo_call{sdesc=SDesc, contlab=ContLab} end. --endif. mk_goto(Label) -> hipe_sparc:mk_b_label(Label). diff --git a/lib/hipe/sparc/hipe_sparc_defuse.erl b/lib/hipe/sparc/hipe_sparc_defuse.erl index cb75f82e2b..4d4b11e301 100644 --- a/lib/hipe/sparc/hipe_sparc_defuse.erl +++ b/lib/hipe/sparc/hipe_sparc_defuse.erl @@ -39,6 +39,7 @@ insn_def_gpr(I) -> #pseudo_call{} -> call_clobbered_gpr(); #pseudo_move{dst=Dst} -> [Dst]; #pseudo_set{dst=Dst} -> [Dst]; + #pseudo_spill_move{temp=Temp, dst=Dst} -> [Temp, Dst]; #pseudo_tailcall_prepare{} -> tailcall_clobbered_gpr(); #rdy{dst=Dst} -> [Dst]; #sethi{dst=Dst} -> [Dst]; @@ -72,6 +73,7 @@ insn_use_gpr(I) -> funv_use(FunV, arity_use_gpr(Arity)); #pseudo_move{src=Src} -> [Src]; #pseudo_ret{} -> [hipe_sparc:mk_rv()]; + #pseudo_spill_move{src=Src} -> [Src]; #pseudo_tailcall{funv=FunV,arity=Arity,stkargs=StkArgs} -> addsrcs(StkArgs, addtemps(tailcall_clobbered_gpr(), funv_use(FunV, arity_use_gpr(Arity)))); #store{src=Src,base=Base,disp=Disp} -> @@ -112,6 +114,7 @@ insn_def_fpr(I) -> #fp_unary{dst=Dst} -> [Dst]; #pseudo_fload{dst=Dst} -> [Dst]; #pseudo_fmove{dst=Dst} -> [Dst]; + #pseudo_spill_fmove{temp=Temp, dst=Dst} -> [Temp, Dst]; _ -> [] end. @@ -130,6 +133,7 @@ insn_use_fpr(I) -> #fp_unary{src=Src} -> [Src]; #pseudo_fmove{src=Src} -> [Src]; #pseudo_fstore{src=Src} -> [Src]; + #pseudo_spill_fmove{src=Src} -> [Src]; _ -> [] end. diff --git a/lib/hipe/sparc/hipe_sparc_frame.erl b/lib/hipe/sparc/hipe_sparc_frame.erl index 6f29c3c905..1f2a259ca1 100644 --- a/lib/hipe/sparc/hipe_sparc_frame.erl +++ b/lib/hipe/sparc/hipe_sparc_frame.erl @@ -82,6 +82,10 @@ do_insn(I, LiveOut, Context, FPoff) -> {do_pseudo_tailcall(I, Context), context_framesize(Context)}; #pseudo_fmove{} -> {do_pseudo_fmove(I, Context, FPoff), FPoff}; + #pseudo_spill_move{} -> + {do_pseudo_spill_move(I, Context, FPoff), FPoff}; + #pseudo_spill_fmove{} -> + {do_pseudo_spill_fmove(I, Context, FPoff), FPoff}; _ -> {[I], FPoff} end. @@ -110,6 +114,22 @@ do_pseudo_move(I, Context, FPoff) -> end end. +do_pseudo_spill_move(I, Context, FPoff) -> + #pseudo_spill_move{src=Src,temp=Temp,dst=Dst} = I, + case temp_is_pseudo(Src) andalso temp_is_pseudo(Dst) of + false -> % Register allocator changed its mind, turn back to move + do_pseudo_move(hipe_sparc:mk_pseudo_move(Src, Dst), Context, FPoff); + true -> + SrcOffset = pseudo_offset(Src, FPoff, Context), + DstOffset = pseudo_offset(Dst, FPoff, Context), + case SrcOffset =:= DstOffset of + true -> []; % omit move-to-self + false -> + mk_load(hipe_sparc:mk_sp(), SrcOffset, Temp, + mk_store(Temp, hipe_sparc:mk_sp(), DstOffset, [])) + end + end. + do_pseudo_fmove(I, Context, FPoff) -> Dst = hipe_sparc:pseudo_fmove_dst(I), Src = hipe_sparc:pseudo_fmove_src(I), @@ -127,6 +147,22 @@ do_pseudo_fmove(I, Context, FPoff) -> end end. +do_pseudo_spill_fmove(I, Context, FPoff) -> + #pseudo_spill_fmove{src=Src,temp=Temp,dst=Dst} = I, + case temp_is_pseudo(Src) andalso temp_is_pseudo(Dst) of + false -> % Register allocator changed its mind, turn back to fmove + do_pseudo_fmove(hipe_sparc:mk_pseudo_fmove(Src, Dst), Context, FPoff); + true -> + SrcOffset = pseudo_offset(Src, FPoff, Context), + DstOffset = pseudo_offset(Dst, FPoff, Context), + case SrcOffset =:= DstOffset of + true -> []; % omit move-to-self + false -> + mk_fload(hipe_sparc:mk_sp(), SrcOffset, Temp) + ++ mk_fstore(Temp, hipe_sparc:mk_sp(), DstOffset) + end + end. + pseudo_offset(Temp, FPoff, Context) -> FPoff + context_offset(Context, Temp). diff --git a/lib/hipe/sparc/hipe_sparc_ra_finalise.erl b/lib/hipe/sparc/hipe_sparc_ra_finalise.erl index 5fdb73e197..a724821992 100644 --- a/lib/hipe/sparc/hipe_sparc_ra_finalise.erl +++ b/lib/hipe/sparc/hipe_sparc_ra_finalise.erl @@ -38,6 +38,7 @@ ra_insn(I, Map, FPMap) -> #pseudo_call{} -> ra_pseudo_call(I, Map); #pseudo_move{} -> ra_pseudo_move(I, Map); #pseudo_set{} -> ra_pseudo_set(I, Map); + #pseudo_spill_move{} -> ra_pseudo_spill_move(I, Map); #pseudo_tailcall{} -> ra_pseudo_tailcall(I, Map); #rdy{} -> ra_rdy(I, Map); #sethi{} -> ra_sethi(I, Map); @@ -47,6 +48,7 @@ ra_insn(I, Map, FPMap) -> #pseudo_fload{} -> ra_pseudo_fload(I, Map, FPMap); #pseudo_fmove{} -> ra_pseudo_fmove(I, FPMap); #pseudo_fstore{} -> ra_pseudo_fstore(I, Map, FPMap); + #pseudo_spill_fmove{} -> ra_pseudo_spill_fmove(I, FPMap); _ -> I end. @@ -80,6 +82,12 @@ ra_pseudo_set(I=#pseudo_set{dst=Dst}, Map) -> NewDst = ra_temp(Dst, Map), I#pseudo_set{dst=NewDst}. +ra_pseudo_spill_move(I=#pseudo_spill_move{src=Src,temp=Temp,dst=Dst}, Map) -> + NewSrc = ra_temp(Src, Map), + NewTemp = ra_temp(Temp, Map), + NewDst = ra_temp(Dst, Map), + I#pseudo_spill_move{src=NewSrc,temp=NewTemp,dst=NewDst}. + ra_pseudo_tailcall(I=#pseudo_tailcall{funv=FunV,stkargs=StkArgs}, Map) -> NewFunV = ra_funv(FunV, Map), NewStkArgs = ra_args(StkArgs, Map), @@ -120,6 +128,13 @@ ra_pseudo_fmove(I=#pseudo_fmove{src=Src,dst=Dst}, FPMap) -> NewDst = ra_temp_fp(Dst, FPMap), I#pseudo_fmove{src=NewSrc,dst=NewDst}. +ra_pseudo_spill_fmove(I=#pseudo_spill_fmove{src=Src,temp=Temp,dst=Dst}, + FPMap) -> + NewSrc = ra_temp_fp(Src, FPMap), + NewTemp = ra_temp_fp(Temp, FPMap), + NewDst = ra_temp_fp(Dst, FPMap), + I#pseudo_spill_fmove{src=NewSrc,temp=NewTemp,dst=NewDst}. + ra_pseudo_fstore(I=#pseudo_fstore{src=Src,base=Base}, Map, FPMap) -> NewSrc = ra_temp_fp(Src, FPMap), NewBase = ra_temp(Base, Map), diff --git a/lib/hipe/sparc/hipe_sparc_ra_postconditions.erl b/lib/hipe/sparc/hipe_sparc_ra_postconditions.erl index 984c97fbd4..d3ecb43ec6 100644 --- a/lib/hipe/sparc/hipe_sparc_ra_postconditions.erl +++ b/lib/hipe/sparc/hipe_sparc_ra_postconditions.erl @@ -54,6 +54,7 @@ do_insn(I, TempMap, Strategy) -> #pseudo_call{} -> do_pseudo_call(I, TempMap, Strategy); #pseudo_move{} -> do_pseudo_move(I, TempMap, Strategy); #pseudo_set{} -> do_pseudo_set(I, TempMap, Strategy); + #pseudo_spill_move{} -> do_pseudo_spill_move(I, TempMap, Strategy); #pseudo_tailcall{} -> do_pseudo_tailcall(I, TempMap, Strategy); #rdy{} -> do_rdy(I, TempMap, Strategy); #sethi{} -> do_sethi(I, TempMap, Strategy); @@ -92,14 +93,16 @@ do_pseudo_call(I=#pseudo_call{funv=FunV}, TempMap, Strategy) -> do_pseudo_move(I=#pseudo_move{src=Src,dst=Dst}, TempMap, Strategy) -> %% Either Dst or Src (but not both) may be a pseudo temp. - %% pseudo_move is a special case: in [XXX: not pseudo_tailcall] - %% all other instructions, all temps must be non-pseudos - %% after register allocation. - case temp_is_spilled(Dst, TempMap) of - true -> % Src must not be a pseudo - {FixSrc,NewSrc,DidSpill} = fix_src1(Src, TempMap, Strategy), - NewI = I#pseudo_move{src=NewSrc}, - {FixSrc ++ [NewI], DidSpill}; + %% pseudo_move and pseudo_spill_move [XXX: not pseudo_tailcall] + %% are special cases: in all other instructions, all temps must + %% be non-pseudos after register allocation. + case temp_is_spilled(Src, TempMap) + andalso temp_is_spilled(Dst, TempMap) + of + true -> % Turn into pseudo_spill_move + Temp = clone(Src, temp1(Strategy)), + NewI = #pseudo_spill_move{src=Src,temp=Temp,dst=Dst}, + {[NewI], true}; _ -> {[I], false} end. @@ -109,6 +112,11 @@ do_pseudo_set(I=#pseudo_set{dst=Dst}, TempMap, Strategy) -> NewI = I#pseudo_set{dst=NewDst}, {[NewI | FixDst], DidSpill}. +do_pseudo_spill_move(I=#pseudo_spill_move{temp=Temp}, TempMap, _Strategy) -> + %% Temp is above the low water mark and must not have been spilled + false = temp_is_spilled(Temp, TempMap), + {[I], false}. + do_pseudo_tailcall(I=#pseudo_tailcall{funv=FunV}, TempMap, Strategy) -> {FixFunV,NewFunV,DidSpill} = fix_funv(FunV, TempMap, Strategy), NewI = I#pseudo_tailcall{funv=NewFunV}, diff --git a/lib/hipe/sparc/hipe_sparc_ra_postconditions_fp.erl b/lib/hipe/sparc/hipe_sparc_ra_postconditions_fp.erl index 751e91425c..5fa3a5fc59 100644 --- a/lib/hipe/sparc/hipe_sparc_ra_postconditions_fp.erl +++ b/lib/hipe/sparc/hipe_sparc_ra_postconditions_fp.erl @@ -43,6 +43,7 @@ do_insn(I, TempMap) -> #pseudo_fload{} -> do_pseudo_fload(I, TempMap); #pseudo_fmove{} -> do_pseudo_fmove(I, TempMap); #pseudo_fstore{} -> do_pseudo_fstore(I, TempMap); + #pseudo_spill_fmove{} -> do_pseudo_spill_fmove(I, TempMap); _ -> {[I], false} end. @@ -67,11 +68,13 @@ do_pseudo_fload(I=#pseudo_fload{dst=Dst}, TempMap) -> {[NewI | FixDst], DidSpill}. do_pseudo_fmove(I=#pseudo_fmove{src=Src,dst=Dst}, TempMap) -> - case temp_is_spilled(Dst, TempMap) of - true -> - {FixSrc,NewSrc,DidSpill} = fix_src(Src, TempMap), - NewI = I#pseudo_fmove{src=NewSrc}, - {FixSrc ++ [NewI], DidSpill}; + case temp_is_spilled(Src, TempMap) + andalso temp_is_spilled(Dst, TempMap) + of + true -> % Turn into pseudo_spill_fmove + Temp = clone(Src), + NewI = #pseudo_spill_fmove{src=Src,temp=Temp,dst=Dst}, + {[NewI], true}; _ -> {[I], false} end. @@ -81,6 +84,11 @@ do_pseudo_fstore(I=#pseudo_fstore{src=Src}, TempMap) -> NewI = I#pseudo_fstore{src=NewSrc}, {FixSrc ++ [NewI], DidSpill}. +do_pseudo_spill_fmove(I=#pseudo_spill_fmove{temp=Temp}, TempMap) -> + %% Temp is above the low water mark and must not have been spilled + false = temp_is_spilled(Temp, TempMap), + {[I], false}. + %%% Fix Dst and Src operands. fix_src(Src, TempMap) -> diff --git a/lib/hipe/sparc/hipe_sparc_subst.erl b/lib/hipe/sparc/hipe_sparc_subst.erl index 1d0671464e..ce3bbb813a 100644 --- a/lib/hipe/sparc/hipe_sparc_subst.erl +++ b/lib/hipe/sparc/hipe_sparc_subst.erl @@ -44,6 +44,8 @@ insn_temps(T, I) -> #pseudo_move{src=S,dst=D} -> I#pseudo_move{src=T(S),dst=T(D)}; #pseudo_ret{} -> I; #pseudo_set{dst=D}-> I#pseudo_set{dst=T(D)}; + #pseudo_spill_move{src=S,temp=U,dst=D} -> + I#pseudo_spill_move{src=T(S),temp=T(U),dst=T(D)}; #pseudo_tailcall{funv=F,stkargs=Stk} -> I#pseudo_tailcall{funv=funv_temps(T,F),stkargs=lists:map(Arg,Stk)}; #pseudo_tailcall_prepare{} -> I; @@ -57,7 +59,9 @@ insn_temps(T, I) -> I#pseudo_fload{base=T(B),disp=S2(Di),dst=T(Ds)}; #pseudo_fmove{src=S,dst=D} -> I#pseudo_fmove{src=T(S),dst=T(D)}; #pseudo_fstore{src=S,base=B,disp=D} -> - I#pseudo_fstore{src=T(S),base=T(B),disp=S2(D)} + I#pseudo_fstore{src=T(S),base=T(B),disp=S2(D)}; + #pseudo_spill_fmove{src=S,temp=U,dst=D} -> + I#pseudo_spill_fmove{src=T(S),temp=T(U),dst=T(D)} end. -spec src2_temps(subst_fun(), src2()) -> src2(). diff --git a/lib/hipe/test/basic_SUITE_data/basic_edge_cases.erl b/lib/hipe/test/basic_SUITE_data/basic_edge_cases.erl new file mode 100644 index 0000000000..9bf5cf52cd --- /dev/null +++ b/lib/hipe/test/basic_SUITE_data/basic_edge_cases.erl @@ -0,0 +1,142 @@ +%%% -*- erlang-indent-level: 2 -*- +%%%---------------------------------------------------------------------- +%%% Contains +%%%---------------------------------------------------------------------- +-module(basic_edge_cases). + +-export([test/0]). + +test() -> + ok = test_float_spills(), + ok = test_infinite_loops(), + ok. + +%% Contains more float temps live at a single point than there are float +%% registers in any backend + +test_float_spills() -> + {{{2942.0,4670.0,3198.0,4926.0,2206.0,4734.0}, + {3118.0,2062.0,5174.0,3038.0,3618.0,3014.0}, + {2542.0,2062.0,4934.0,2590.0,3098.0,3062.0}, + {2950.0,3666.0,2574.0,5038.0,1866.0,2946.0}, + {3126.0,3050.0,3054.0,5070.0,2258.0,2714.0}, + {4734.0,2206.0,4926.0,3198.0,4670.0,2942.0}}, + 58937.0} = + mat66_flip_sum(35.0,86.0,32.0,88.0,33.0,57.0, + 22.0,77.0,91.0,80.0,14.0,33.0, + 51.0,28.0,87.0,20.0,91.0,11.0, + 68.0,83.0,64.0,82.0,10.0,86.0, + 74.0,18.0,08.0,52.0,10.0,14.0, + 89.0,34.0,64.0,66.0,58.0,55.0, + 0.0, 5), + ok. + +mat66_flip_sum(M11, M12, M13, M14, M15, M16, + M21, M22, M23, M24, M25, M26, + M31, M32, M33, M34, M35, M36, + M41, M42, M43, M44, M45, M46, + M51, M52, M53, M54, M55, M56, + M61, M62, M63, M64, M65, M66, + Acc, Ctr) + when is_float(M11), is_float(M12), is_float(M13), + is_float(M14), is_float(M15), is_float(M16), + is_float(M21), is_float(M22), is_float(M23), + is_float(M24), is_float(M25), is_float(M26), + is_float(M31), is_float(M32), is_float(M33), + is_float(M34), is_float(M35), is_float(M36), + is_float(M41), is_float(M42), is_float(M43), + is_float(M44), is_float(M45), is_float(M46), + is_float(M51), is_float(M52), is_float(M53), + is_float(M54), is_float(M55), is_float(M56), + is_float(M61), is_float(M62), is_float(M63), + is_float(M64), is_float(M65), is_float(M66), + is_float(Acc) -> + R11 = M66+M11, R12 = M65+M12, R13 = M64+M13, + R14 = M63+M14, R15 = M62+M15, R16 = M61+M16, + R21 = M56+M21, R22 = M55+M22, R23 = M54+M23, + R24 = M53+M24, R25 = M52+M25, R26 = M51+M26, + R31 = M46+M31, R32 = M45+M32, R33 = M44+M33, + R34 = M43+M34, R35 = M42+M35, R36 = M41+M36, + R41 = M26+M41, R42 = M25+M42, R43 = M24+M43, + R44 = M23+M44, R45 = M22+M45, R46 = M21+M46, + R51 = M36+M51, R52 = M35+M52, R53 = M34+M53, + R54 = M33+M54, R55 = M32+M55, R56 = M31+M56, + R61 = M16+M61, R62 = M15+M62, R63 = M14+M63, + R64 = M13+M64, R65 = M12+M65, R66 = M11+M66, + case Ctr of + 0 -> + {{{R11, R12, R13, R14, R15, R16}, + {R21, R22, R23, R24, R25, R26}, + {R31, R32, R33, R34, R35, R36}, + {R41, R42, R43, R44, R45, R46}, + {R51, R52, R53, R54, R55, R56}, + {R61, R62, R63, R64, R65, R66}}, + Acc}; + _ -> + NewAcc = 0.0 + M11 + M12 + M13 + M14 + M15 + M16 + + + M21 + M22 + M23 + M24 + M25 + M26 + + M31 + M32 + M33 + M34 + M35 + M36 + + M41 + M42 + M43 + M44 + M45 + M46 + + M51 + M52 + M53 + M54 + M55 + M56 + + M61 + M62 + M63 + M64 + M65 + M66 + + Acc, + mat66_flip_sum(R11+1.0, R12+1.0, R13+1.0, R14+1.0, R15+1.0, R16+1.0, + R21+1.0, R22+1.0, R23+1.0, R24+1.0, R25+1.0, R26+1.0, + R31+1.0, R32+1.0, R33+1.0, R34+1.0, R35+1.0, R36+1.0, + R41+1.0, R42+1.0, R43+1.0, R44+1.0, R45+1.0, R46+1.0, + R51+1.0, R52+1.0, R53+1.0, R54+1.0, R55+1.0, R56+1.0, + R61+1.0, R62+1.0, R63+1.0, R64+1.0, R65+1.0, R66+1.0, + NewAcc, Ctr-1) + end. + +%% Infinite loops must receive reduction tests, and might trip up basic block +%% weighting, leading to infinite weights and/or divisions by zero. + +test_infinite_loops() -> + OldTrapExit = process_flag(trap_exit, true), + ok = test_infinite_loop(fun infinite_recursion/0), + ok = test_infinite_loop(fun infinite_corecursion/0), + RecursiveFun = fun RecursiveFun() -> RecursiveFun() end, + ok = test_infinite_loop(RecursiveFun), + CorecursiveFunA = fun CorecursiveFunA() -> + CorecursiveFunA1 = fun () -> CorecursiveFunA() end, + CorecursiveFunA1() + end, + ok = test_infinite_loop(CorecursiveFunA), + CorecursiveFunB1 = fun(CorecursiveFunB) -> CorecursiveFunB() end, + CorecursiveFunB = fun CorecursiveFunB() -> + CorecursiveFunB1(CorecursiveFunB) + end, + ok = test_infinite_loop(CorecursiveFunB), + CorecursiveFunC1 = fun CorecursiveFunC1(Other) -> + Other(CorecursiveFunC1) + end, + CorecursiveFunC = fun CorecursiveFunC(Other) -> + Other(CorecursiveFunC) + end, + ok = test_infinite_loop(fun() -> CorecursiveFunC(CorecursiveFunC1) end), + ok = test_infinite_loop(fun() -> CorecursiveFunC(CorecursiveFunC) end), + true = process_flag(trap_exit, OldTrapExit), + ok. + +-define(INFINITE_LOOP_TIMEOUT, 100). +test_infinite_loop(Fun) -> + Tester = spawn_link(Fun), + kill_soon(Tester), + receive {'EXIT', Tester, awake} -> + undefined = process_info(Tester), + ok + after ?INFINITE_LOOP_TIMEOUT -> error(timeout) + end. + +infinite_recursion() -> infinite_recursion(). + +infinite_corecursion() -> infinite_corecursion_1(). +infinite_corecursion_1() -> infinite_corecursion(). + +kill_soon(Pid) -> + _ = spawn_link(fun() -> + timer:sleep(1), + erlang:exit(Pid, awake) + end), + ok. diff --git a/lib/hipe/util/Makefile b/lib/hipe/util/Makefile index 04de7f7823..eeb81ac482 100644 --- a/lib/hipe/util/Makefile +++ b/lib/hipe/util/Makefile @@ -48,7 +48,7 @@ HIPE_MODULES = hipe_vectors else HIPE_MODULES = endif -MODULES = hipe_timing hipe_dot hipe_digraph $(HIPE_MODULES) +MODULES = hipe_timing hipe_dot hipe_digraph hipe_dsets $(HIPE_MODULES) HRL_FILES= ERL_FILES= $(MODULES:%=%.erl) diff --git a/lib/hipe/util/hipe_dsets.erl b/lib/hipe/util/hipe_dsets.erl new file mode 100644 index 0000000000..9492cab0ff --- /dev/null +++ b/lib/hipe/util/hipe_dsets.erl @@ -0,0 +1,84 @@ +%% -*- erlang-indent-level: 2 -*- +%% +%% 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. +%% +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +%%@doc +%% IMMUTABLE DISJOINT SETS OF ARBITRARY TERMS +%% +%% The disjoint set forests data structure, for elements of arbitrary types. +%% Note that the find operation mutates the set. +%% +%% We could do this more efficiently if we restricted the elements to integers, +%% and used the (mutable) hipe arrays. For arbitrary terms ETS could be used, +%% for a persistent interface (which isn't that nice when even accessors return +%% modified copies), the array module could be used. +-module(hipe_dsets). + +-export([new/1, find/2, union/3, to_map/1, to_rllist/1]). +-export_type([dsets/1]). + +-opaque dsets(X) :: #{X => {node, X} | {root, non_neg_integer()}}. + +-spec new([E]) -> dsets(E). +new(Elems) -> maps:from_list([{E,{root,0}} || E <- Elems]). + +-spec find(E, dsets(E)) -> {E, dsets(E)}. +find(E, DS0) -> + case DS0 of + #{E := {root,_}} -> {E, DS0}; + #{E := {node,N}} -> + case find(N, DS0) of + {N, _}=T -> T; + {R, DS1} -> {R, DS1#{E := {node,R}}} + end; + _ -> error(badarg, [E, DS0]) + end. + +-spec union(E, E, dsets(E)) -> dsets(E). +union(X, Y, DS0) -> + {XRoot, DS1} = find(X, DS0), + case find(Y, DS1) of + {XRoot, DS2} -> DS2; + {YRoot, DS2} -> + #{XRoot := {root,XRR}, YRoot := {root,YRR}} = DS2, + if XRR < YRR -> DS2#{XRoot := {node,YRoot}}; + XRR > YRR -> DS2#{YRoot := {node,XRoot}}; + true -> DS2#{YRoot := {node,XRoot}, XRoot := {root,XRR+1}} + end + end. + +-spec to_map(dsets(E)) -> {#{Elem::E => Root::E}, dsets(E)}. +to_map(DS) -> + to_map(maps:keys(DS), DS, #{}). + +to_map([], DS, Acc) -> {Acc, DS}; +to_map([K|Ks], DS0, Acc) -> + {KR, DS} = find(K, DS0), + to_map(Ks, DS, Acc#{K => KR}). + +-spec to_rllist(dsets(E)) -> {[{Root::E, Elems::[E]}], dsets(E)}. +to_rllist(DS0) -> + {Lists, DS} = to_rllist(maps:keys(DS0), #{}, DS0), + {maps:to_list(Lists), DS}. + +to_rllist([], Acc, DS) -> {Acc, DS}; +to_rllist([E|Es], Acc, DS0) -> + {ERoot, DS} = find(E, DS0), + to_rllist(Es, map_append(ERoot, E, Acc), DS). + +map_append(Key, Elem, Map) -> + case Map of + #{Key := List} -> Map#{Key := [Elem|List]}; + #{} -> Map#{Key => [Elem]} + end. diff --git a/lib/hipe/x86/hipe_x86.erl b/lib/hipe/x86/hipe_x86.erl index cc1c75b04d..f514dd1ded 100644 --- a/lib/hipe/x86/hipe_x86.erl +++ b/lib/hipe/x86/hipe_x86.erl @@ -167,6 +167,12 @@ mk_pseudo_spill/1, + mk_pseudo_spill_fmove/3, + is_pseudo_spill_fmove/1, + + mk_pseudo_spill_move/3, + is_pseudo_spill_move/1, + mk_pseudo_tailcall/4, %% is_pseudo_tailcall/1, pseudo_tailcall_fun/1, @@ -425,6 +431,14 @@ mk_pseudo_jcc_simple(Cc, TrueLabel, FalseLabel, Pred) -> mk_pseudo_spill(List) -> #pseudo_spill{args=List}. +mk_pseudo_spill_fmove(Src, Temp, Dst) -> + #pseudo_spill_fmove{src=Src, temp=Temp, dst=Dst}. +is_pseudo_spill_fmove(I) -> is_record(I, pseudo_spill_fmove). + +mk_pseudo_spill_move(Src, Temp, Dst) -> + #pseudo_spill_move{src=Src, temp=Temp, dst=Dst}. +is_pseudo_spill_move(I) -> is_record(I, pseudo_spill_move). + mk_pseudo_tailcall(Fun, Arity, StkArgs, Linkage) -> check_linkage(Linkage), #pseudo_tailcall{'fun'=Fun, arity=Arity, stkargs=StkArgs, linkage=Linkage}. diff --git a/lib/hipe/x86/hipe_x86.hrl b/lib/hipe/x86/hipe_x86.hrl index 567848bae5..6cd69905b2 100644 --- a/lib/hipe/x86/hipe_x86.hrl +++ b/lib/hipe/x86/hipe_x86.hrl @@ -91,6 +91,8 @@ -record(pseudo_call, {'fun', sdesc, contlab, linkage}). -record(pseudo_jcc, {cc, true_label, false_label, pred}). -record(pseudo_spill, {args=[]}). +-record(pseudo_spill_move, {src, temp, dst}). +-record(pseudo_spill_fmove, {src, temp, dst}). -record(pseudo_tailcall, {'fun', arity, stkargs, linkage}). -record(pseudo_tailcall_prepare, {}). -record(push, {src}). diff --git a/lib/hipe/x86/hipe_x86_assemble.erl b/lib/hipe/x86/hipe_x86_assemble.erl index fb0beba293..50919bdf4e 100644 --- a/lib/hipe/x86/hipe_x86_assemble.erl +++ b/lib/hipe/x86/hipe_x86_assemble.erl @@ -63,7 +63,7 @@ assemble(CompiledCode, Closures, Exports, Options) -> || {MFA, Defun} <- CompiledCode], %% {ConstAlign,ConstSize,ConstMap,RefsFromConsts} = - hipe_pack_constants:pack_constants(Code, ?HIPE_X86_REGISTERS:alignment()), + hipe_pack_constants:pack_constants(Code), %% {CodeSize,CodeBinary,AccRefs,LabelMap,ExportMap} = encode(translate(Code, ConstMap, Options), Options), diff --git a/lib/hipe/x86/hipe_x86_cfg.erl b/lib/hipe/x86/hipe_x86_cfg.erl index a4544e1086..0a3c0fc9d6 100644 --- a/lib/hipe/x86/hipe_x86_cfg.erl +++ b/lib/hipe/x86/hipe_x86_cfg.erl @@ -19,7 +19,7 @@ succ/2, pred/2, bb/2, bb_add/3, map_bbs/2, fold_bbs/3]). -export([postorder/1, reverse_postorder/1]). --export([linearise/1, params/1, arity/1, redirect_jmp/3]). +-export([linearise/1, params/1, arity/1, redirect_jmp/3, branch_preds/1]). %%% these tell cfg.inc what to define (ugly as hell) -define(PRED_NEEDED,true). @@ -72,6 +72,26 @@ branch_successors(Branch) -> #ret{} -> [] end. +branch_preds(Branch) -> + case Branch of + #jmp_switch{labels=Labels} -> + Prob = 1.0/length(Labels), + [{L, Prob} || L <- Labels]; + #pseudo_call{contlab=ContLab, sdesc=#x86_sdesc{exnlab=[]}} -> + %% A function can still cause an exception, even if we won't catch it + [{ContLab, 1.0-hipe_bb_weights:call_exn_pred()}]; + #pseudo_call{contlab=ContLab, sdesc=#x86_sdesc{exnlab=ExnLab}} -> + CallExnPred = hipe_bb_weights:call_exn_pred(), + [{ContLab, 1.0-CallExnPred}, {ExnLab, CallExnPred}]; + #pseudo_jcc{true_label=TrueLab,false_label=FalseLab,pred=Pred} -> + [{FalseLab, 1.0-Pred}, {TrueLab, Pred}]; + _ -> + case branch_successors(Branch) of + [] -> []; + [Single] -> [{Single, 1.0}] + end + end. + -ifdef(REMOVE_TRIVIAL_BBS_NEEDED). fails_to(_Instr) -> []. -endif. diff --git a/lib/hipe/x86/hipe_x86_defuse.erl b/lib/hipe/x86/hipe_x86_defuse.erl index 5d7fadf8e5..2731836dc1 100644 --- a/lib/hipe/x86/hipe_x86_defuse.erl +++ b/lib/hipe/x86/hipe_x86_defuse.erl @@ -51,6 +51,8 @@ insn_def(I) -> #movzx{dst=Dst} -> dst_def(Dst); #pseudo_call{} -> call_clobbered(); #pseudo_spill{} -> []; + #pseudo_spill_fmove{temp=Temp, dst=Dst} -> [Temp, Dst]; + #pseudo_spill_move{temp=Temp, dst=Dst} -> [Temp, Dst]; #pseudo_tailcall_prepare{} -> tailcall_clobbered(); #shift{dst=Dst} -> dst_def(Dst); %% call, cmp, comment, jcc, jmp_fun, jmp_label, jmp_switch, label @@ -108,6 +110,8 @@ insn_use(I) -> #pseudo_call{'fun'=Fun,sdesc=#x86_sdesc{arity=Arity}} -> addtemp(Fun, arity_use(Arity)); #pseudo_spill{args=Args} -> Args; + #pseudo_spill_fmove{src=Src} -> [Src]; + #pseudo_spill_move{src=Src} -> [Src]; #pseudo_tailcall{'fun'=Fun,arity=Arity,stkargs=StkArgs} -> addtemp(Fun, addtemps(StkArgs, addtemps(tailcall_clobbered(), arity_use(Arity)))); diff --git a/lib/hipe/x86/hipe_x86_frame.erl b/lib/hipe/x86/hipe_x86_frame.erl index 3c2b67967a..558321d0c3 100644 --- a/lib/hipe/x86/hipe_x86_frame.erl +++ b/lib/hipe/x86/hipe_x86_frame.erl @@ -95,13 +95,17 @@ do_insn(I, LiveOut, Context, FPoff) -> #imul{} -> {[do_imul(I, Context, FPoff)], FPoff}; #move{} -> - {[do_move(I, Context, FPoff)], FPoff}; + {do_move(I, Context, FPoff), FPoff}; #movsx{} -> {[do_movsx(I, Context, FPoff)], FPoff}; #movzx{} -> {[do_movzx(I, Context, FPoff)], FPoff}; #pseudo_call{} -> do_pseudo_call(I, LiveOut, Context, FPoff); + #pseudo_spill_fmove{} -> + {do_pseudo_spill_fmove(I, Context, FPoff), FPoff}; + #pseudo_spill_move{} -> + {do_pseudo_spill_move(I, Context, FPoff), FPoff}; #pseudo_tailcall{} -> {do_pseudo_tailcall(I, Context), context_framesize(Context)}; #push{} -> @@ -144,22 +148,50 @@ do_fp_binop(I, Context, FPoff) -> Dst = conv_opnd(Dst0, FPoff, Context), [I#fp_binop{src=Src,dst=Dst}]. -do_fmove(I, Context, FPoff) -> - #fmove{src=Src0,dst=Dst0} = I, +do_fmove(I0, Context, FPoff) -> + #fmove{src=Src0,dst=Dst0} = I0, Src = conv_opnd(Src0, FPoff, Context), Dst = conv_opnd(Dst0, FPoff, Context), - I#fmove{src=Src,dst=Dst}. + I = I0#fmove{src=Src,dst=Dst}, + case Src =:= Dst of + true -> []; % omit move-to-self + false -> [I] + end. + +do_pseudo_spill_fmove(I0, Context, FPoff) -> + #pseudo_spill_fmove{src=Src0,temp=Temp0,dst=Dst0} = I0, + Src = conv_opnd(Src0, FPoff, Context), + Temp = conv_opnd(Temp0, FPoff, Context), + Dst = conv_opnd(Dst0, FPoff, Context), + case Src =:= Dst of + true -> []; % omit move-to-self + false -> [#fmove{src=Src, dst=Temp}, #fmove{src=Temp, dst=Dst}] + end. do_imul(I, Context, FPoff) -> #imul{src=Src0} = I, Src = conv_opnd(Src0, FPoff, Context), I#imul{src=Src}. -do_move(I, Context, FPoff) -> - #move{src=Src0,dst=Dst0} = I, +do_move(I0, Context, FPoff) -> + #move{src=Src0,dst=Dst0} = I0, Src = conv_opnd(Src0, FPoff, Context), Dst = conv_opnd(Dst0, FPoff, Context), - I#move{src=Src,dst=Dst}. + I = I0#move{src=Src,dst=Dst}, + case Src =:= Dst of + true -> []; % omit move-to-self + false -> [I] + end. + +do_pseudo_spill_move(I0, Context, FPoff) -> + #pseudo_spill_move{src=Src0,temp=Temp0,dst=Dst0} = I0, + Src = conv_opnd(Src0, FPoff, Context), + Temp = conv_opnd(Temp0, FPoff, Context), + Dst = conv_opnd(Dst0, FPoff, Context), + case Src =:= Dst of + true -> []; % omit move-to-self + false -> [#move{src=Src, dst=Temp}, #move{src=Temp, dst=Dst}] + end. do_movsx(I, Context, FPoff) -> #movsx{src=Src0,dst=Dst0} = I, diff --git a/lib/hipe/x86/hipe_x86_ra_finalise.erl b/lib/hipe/x86/hipe_x86_ra_finalise.erl index 4273e3cee8..e8abe78e00 100644 --- a/lib/hipe/x86/hipe_x86_ra_finalise.erl +++ b/lib/hipe/x86/hipe_x86_ra_finalise.erl @@ -140,6 +140,16 @@ ra_insn(I, Map, FpMap) -> I#pseudo_call{'fun'=Fun}; #pseudo_jcc{} -> I; + #pseudo_spill_fmove{src=Src0, temp=Temp0, dst=Dst0} -> + Src = ra_opnd(Src0, Map, FpMap), + Temp = ra_opnd(Temp0, Map, FpMap), + Dst = ra_opnd(Dst0, Map, FpMap), + I#pseudo_spill_fmove{src=Src, temp=Temp, dst=Dst}; + #pseudo_spill_move{src=Src0, temp=Temp0, dst=Dst0} -> + Src = ra_opnd(Src0, Map), + Temp = ra_opnd(Temp0, Map), + Dst = ra_opnd(Dst0, Map), + I#pseudo_spill_move{src=Src, temp=Temp, dst=Dst}; #pseudo_tailcall{'fun'=Fun0,stkargs=StkArgs0} -> Fun = ra_opnd(Fun0, Map), StkArgs = ra_args(StkArgs0, Map), diff --git a/lib/hipe/x86/hipe_x86_ra_postconditions.erl b/lib/hipe/x86/hipe_x86_ra_postconditions.erl index 28ec9c4277..db6391d5c1 100644 --- a/lib/hipe/x86/hipe_x86_ra_postconditions.erl +++ b/lib/hipe/x86/hipe_x86_ra_postconditions.erl @@ -74,6 +74,8 @@ do_insn(I, TempMap, Strategy) -> % Insn -> {Insn list, DidSpill} do_movx(I, TempMap, Strategy); #fmove{} -> do_fmove(I, TempMap, Strategy); + #pseudo_spill_move{} -> + do_pseudo_spill_move(I, TempMap, Strategy); #shift{} -> do_shift(I, TempMap, Strategy); #test{} -> @@ -190,10 +192,19 @@ do_lea(I, TempMap, Strategy) -> do_move(I, TempMap, Strategy) -> #move{src=Src0,dst=Dst0} = I, - {FixSrc, Src, FixDst, Dst, DidSpill} = - do_check_byte_move(Src0, Dst0, TempMap, Strategy), - {FixSrc ++ FixDst ++ [I#move{src=Src,dst=Dst}], - DidSpill}. + case + is_record(Src0, x86_temp) andalso is_record(Dst0, x86_temp) + andalso is_spilled(Src0, TempMap) andalso is_spilled(Dst0, TempMap) + of + true -> + Tmp = clone(Src0, Strategy), + {[hipe_x86:mk_pseudo_spill_move(Src0, Tmp, Dst0)], true}; + false -> + {FixSrc, Src, FixDst, Dst, DidSpill} = + do_check_byte_move(Src0, Dst0, TempMap, Strategy), + {FixSrc ++ FixDst ++ [I#move{src=Src,dst=Dst}], + DidSpill} + end. -ifdef(HIPE_AMD64). @@ -287,6 +298,13 @@ do_fmove(I, TempMap, Strategy) -> {FixSrc ++ FixDst ++ [I#fmove{src=Src,dst=Dst}], DidSpill1 or DidSpill2}. +%%% Fix an pseudo_spill_move op. + +do_pseudo_spill_move(I = #pseudo_spill_move{temp=Temp}, TempMap, _Strategy) -> + %% Temp is above the low water mark and must not have been spilled + false = is_spilled(Temp, TempMap), + {[I], false}. % nothing to do + %%% Fix a shift operation. %%% 1. remove pseudos from any explicit memory operands %%% 2. if the source is a register or memory position diff --git a/lib/hipe/x86/hipe_x86_subst.erl b/lib/hipe/x86/hipe_x86_subst.erl index 7b5fb1352b..7db3b23d92 100644 --- a/lib/hipe/x86/hipe_x86_subst.erl +++ b/lib/hipe/x86/hipe_x86_subst.erl @@ -19,7 +19,7 @@ -endif. -module(?HIPE_X86_SUBST). --export([insn_temps/2]). +-export([insn_temps/2, insn_lbls/2]). -include("../x86/hipe_x86.hrl"). %% These should be moved to hipe_x86 and exported @@ -28,6 +28,7 @@ -type mfarec() :: #x86_mfa{}. -type prim() :: #x86_prim{}. -type funv() :: mfarec() | prim() | temp(). +-type label() :: non_neg_integer(). -type insn() :: tuple(). % for now -type subst_fun() :: fun((temp()) -> temp()). @@ -49,14 +50,19 @@ insn_temps(SubstTemp, I) -> #movzx {src=S, dst=D} -> I#movzx {src=O(S), dst=O(D)}; #shift {src=S, dst=D} -> I#shift {src=O(S), dst=O(D)}; #test {src=S, dst=D} -> I#test {src=O(S), dst=O(D)}; - #fp_unop{arg=A} -> I#fp_unop{arg=O(A)}; - #move64 {dst=D} -> I#move64 {dst=O(D)}; - #push {src=S} -> I#push {src=O(S)}; - #pop {dst=D} -> I#pop {dst=O(D)}; + #fp_unop{arg=[]} -> I; + #fp_unop{arg=A} -> I#fp_unop{arg=O(A)}; + #move64 {dst=D} -> I#move64 {dst=O(D)}; + #push {src=S} -> I#push {src=O(S)}; + #pop {dst=D} -> I#pop {dst=O(D)}; #jmp_switch{temp=T, jtab=J} -> I#jmp_switch{temp=O(T), jtab=jtab_temps(SubstTemp, J)}; #pseudo_call{'fun'=F} -> I#pseudo_call{'fun'=funv_temps(SubstTemp, F)}; + #pseudo_spill_fmove{src=S, temp=T, dst=D} -> + I#pseudo_spill_fmove{src=O(S), temp=O(T), dst=O(D)}; + #pseudo_spill_move{src=S, temp=T, dst=D} -> + I#pseudo_spill_move{src=O(S), temp=O(T), dst=O(D)}; #pseudo_tailcall{'fun'=F, stkargs=Stk} -> I#pseudo_tailcall{'fun'=funv_temps(SubstTemp, F), stkargs=lists:map(O, Stk)}; @@ -85,3 +91,22 @@ jtab_temps(SubstTemp, T=#x86_temp{}) -> SubstTemp(T). -else. jtab_temps(_SubstTemp, DataLbl) when is_integer(DataLbl) -> DataLbl. -endif. + +-type lbl_subst_fun() :: fun((label()) -> label()). + +%% @doc Maps over the branch targets in an instruction +-spec insn_lbls(lbl_subst_fun(), insn()) -> insn(). +insn_lbls(SubstLbl, I) -> + case I of + #jmp_label{label=Label} -> + I#jmp_label{label=SubstLbl(Label)}; + #pseudo_call{sdesc=Sdesc, contlab=Contlab} -> + I#pseudo_call{sdesc=sdesc_lbls(SubstLbl, Sdesc), + contlab=SubstLbl(Contlab)}; + #pseudo_jcc{true_label=T, false_label=F} -> + I#pseudo_jcc{true_label=SubstLbl(T), false_label=SubstLbl(F)} + end. + +sdesc_lbls(_SubstLbl, Sdesc=#x86_sdesc{exnlab=[]}) -> Sdesc; +sdesc_lbls(SubstLbl, Sdesc=#x86_sdesc{exnlab=Exnlab}) -> + Sdesc#x86_sdesc{exnlab=SubstLbl(Exnlab)}. diff --git a/lib/kernel/doc/src/gen_tcp.xml b/lib/kernel/doc/src/gen_tcp.xml index e97db20062..bef8096aed 100644 --- a/lib/kernel/doc/src/gen_tcp.xml +++ b/lib/kernel/doc/src/gen_tcp.xml @@ -140,6 +140,23 @@ do_recv(Sock, Bs) -> <fsummary>Close a TCP socket.</fsummary> <desc> <p>Closes a TCP socket.</p> + <p>Note that in most implementations of TCP, doing a <c>close</c> does + not guarantee that any data sent is delivered to the recipient before + the close is detected at the remote side. If you want to guarantee + delivery of the data to the recipient there are two common ways to + achieve this.</p> + <list type="ordered"> + <item><p>Use <seealso marker="#shutdown/2"> + <c>gen_tcp:shutdown(Sock, write)</c></seealso> to signal that + no more data is to be sent and wait for the read side of the + socket to be closed.</p> + </item> + <item><p>Use the socket option <seealso marker="inet#packet"> + <c>{packet, N}</c></seealso> (or something similar) to make + it possible for the receiver to close the connection when it + knowns it has received all the data.</p> + </item> + </list> </desc> </func> diff --git a/lib/kernel/doc/src/inet.xml b/lib/kernel/doc/src/inet.xml index d557efb6a8..076e50cd10 100644 --- a/lib/kernel/doc/src/inet.xml +++ b/lib/kernel/doc/src/inet.xml @@ -913,7 +913,7 @@ setcap cap_sys_admin,cap_sys_ptrace,cap_dac_read_search+epi beam.smp</code> </item> <tag><c>{packet, PacketType}</c>(TCP/IP sockets)</tag> <item> - <p>Defines the type of packets to use for a socket. + <p><marker id="packet"/>Defines the type of packets to use for a socket. Possible values:</p> <taglist> <tag><c>raw | 0</c></tag> diff --git a/lib/observer/src/cdv_ets_cb.erl b/lib/observer/src/cdv_ets_cb.erl index ddd2d42df6..18f0c86fd3 100644 --- a/lib/observer/src/cdv_ets_cb.erl +++ b/lib/observer/src/cdv_ets_cb.erl @@ -30,26 +30,23 @@ -include("crashdump_viewer.hrl"). %% Defines --define(COL_ID, 0). --define(COL_NAME, ?COL_ID+1). --define(COL_SLOT, ?COL_NAME+1). --define(COL_OWNER, ?COL_SLOT+1). +-define(COL_NAME, 0). +-define(COL_IS_NAMED, ?COL_NAME+1). +-define(COL_OWNER, ?COL_IS_NAMED+1). -define(COL_OBJ, ?COL_OWNER+1). -define(COL_MEM, ?COL_OBJ+1). %% Callbacks for cdv_virtual_list_wx -col_to_elem(id) -> col_to_elem(?COL_ID); -col_to_elem(?COL_ID) -> #ets_table.id; +col_to_elem(id) -> col_to_elem(?COL_NAME); +col_to_elem(?COL_IS_NAMED) -> #ets_table.is_named; col_to_elem(?COL_NAME) -> #ets_table.name; -col_to_elem(?COL_SLOT) -> #ets_table.slot; col_to_elem(?COL_OWNER) -> #ets_table.pid; col_to_elem(?COL_OBJ) -> #ets_table.size; col_to_elem(?COL_MEM) -> #ets_table.memory. col_spec() -> - [{"Id", ?wxLIST_FORMAT_LEFT, 200}, - {"Name", ?wxLIST_FORMAT_LEFT, 200}, - {"Slot", ?wxLIST_FORMAT_RIGHT, 50}, + [{"Name", ?wxLIST_FORMAT_LEFT, 200}, + {"Is Named", ?wxLIST_FORMAT_CENTRE, 70}, {"Owner", ?wxLIST_FORMAT_CENTRE, 120}, {"Objects", ?wxLIST_FORMAT_RIGHT, 80}, {"Memory", ?wxLIST_FORMAT_RIGHT, 80} @@ -68,7 +65,7 @@ get_details(Id, Data) -> {ok,{"Table:" ++ Id,Proplist,""}}. get_detail_cols(all) -> - {[{ets, ?COL_ID}, {process, ?COL_OWNER}],true}; + {[{ets, ?COL_NAME}, {process, ?COL_OWNER}],true}; get_detail_cols(_W) -> {[],true}. diff --git a/lib/observer/src/crashdump_viewer.erl b/lib/observer/src/crashdump_viewer.erl index 13e73f027d..e21f1c501b 100644 --- a/lib/observer/src/crashdump_viewer.erl +++ b/lib/observer/src/crashdump_viewer.erl @@ -1555,10 +1555,14 @@ split_pid_list_no_space([],[],Pids) -> %% Page with external ets tables get_ets_tables(File,Pid,WS) -> ParseFun = fun(Fd,Id) -> - get_etsinfo(Fd,#ets_table{pid=list_to_pid(Id)},WS) + ET = get_etsinfo(Fd,#ets_table{pid=list_to_pid(Id)},WS), + ET#ets_table{is_named=tab_is_named(ET)} end, lookup_and_parse_index(File,{?ets,Pid},ParseFun,"ets"). +tab_is_named(#ets_table{id=Name,name=Name}) -> "yes"; +tab_is_named(#ets_table{}) -> "no". + get_etsinfo(Fd,EtsTable = #ets_table{details=Ds},WS) -> case line_head(Fd) of "Slot" -> diff --git a/lib/observer/src/crashdump_viewer.hrl b/lib/observer/src/crashdump_viewer.hrl index a08659efd6..742e145641 100644 --- a/lib/observer/src/crashdump_viewer.hrl +++ b/lib/observer/src/crashdump_viewer.hrl @@ -118,6 +118,7 @@ slot, id, name, + is_named, data_type="hash", buckets="-", size, diff --git a/lib/observer/src/observer_tv_wx.erl b/lib/observer/src/observer_tv_wx.erl index 4356cb890c..d04fb839c8 100644 --- a/lib/observer/src/observer_tv_wx.erl +++ b/lib/observer/src/observer_tv_wx.erl @@ -78,11 +78,11 @@ init([Notebook, Parent]) -> Col + 1 end, ListItems = [{"Table Name", ?wxLIST_FORMAT_LEFT, 200}, - {"Table Id", ?wxLIST_FORMAT_RIGHT, 100}, {"Objects", ?wxLIST_FORMAT_RIGHT, 100}, {"Size (kB)", ?wxLIST_FORMAT_RIGHT, 100}, {"Owner Pid", ?wxLIST_FORMAT_CENTER, 150}, - {"Owner Name", ?wxLIST_FORMAT_LEFT, 200} + {"Owner Name", ?wxLIST_FORMAT_LEFT, 200}, + {"Table Id", ?wxLIST_FORMAT_LEFT, 250} ], lists:foldl(AddListEntry, 0, ListItems), wxListItem:destroy(Li), @@ -387,8 +387,8 @@ update_grid2(Grid, #opt{sort_key=Sort,sort_incr=Dir}, Tables) -> ({Col, Val}) -> wxListCtrl:setItem(Grid, Row, Col, observer_lib:to_str(Val)) end, - [{0,Name}, {1,Id}, {2,Size}, {3, Memory div 1024}, - {4,Owner}, {5,RegName}]), + [{0,Name}, {1,Size}, {2, Memory div 1024}, + {3,Owner}, {4,RegName}, {5,Id}]), Row + 1 end, ProcInfo = case Dir of diff --git a/lib/public_key/src/public_key.erl b/lib/public_key/src/public_key.erl index 8f185bbbd4..965606045d 100644 --- a/lib/public_key/src/public_key.erl +++ b/lib/public_key/src/public_key.erl @@ -610,7 +610,7 @@ pkix_match_dist_point(#'CertificateList'{ %%-------------------------------------------------------------------- -spec pkix_sign(#'OTPTBSCertificate'{}, - rsa_private_key() | dsa_private_key()) -> Der::binary(). + rsa_private_key() | dsa_private_key() | ec_private_key()) -> Der::binary(). %% %% Description: Sign a pkix x.509 certificate. Returns the corresponding %% der encoded 'Certificate'{} diff --git a/lib/ssh/doc/src/ssh.xml b/lib/ssh/doc/src/ssh.xml index 1f07e826ce..968983c862 100644 --- a/lib/ssh/doc/src/ssh.xml +++ b/lib/ssh/doc/src/ssh.xml @@ -243,21 +243,6 @@ <p><c>Peer</c> is in the format of <c>{Host,Port}</c>.</p> </item> - <tag><c><![CDATA[{public_key_alg, 'ssh-rsa' | 'ssh-dss'}]]></c></tag> - <item> - <note> - <p>This option will be removed in OTP 20, but is kept for compatibility. It is ignored if - the preferred <c>pref_public_key_algs</c> option is used.</p> - </note> - <p>Sets the preferred public key algorithm to use for user - authentication. If the preferred algorithm fails, - the other algorithm is tried. If <c>{public_key_alg, 'ssh-rsa'}</c> is set, it is translated - to <c>{pref_public_key_algs, ['ssh-rsa','ssh-dss']}</c>. If it is - <c>{public_key_alg, 'ssh-dss'}</c>, it is translated - to <c>{pref_public_key_algs, ['ssh-dss','ssh-rsa']}</c>. - </p> - </item> - <tag><c><![CDATA[{pref_public_key_algs, list()}]]></c></tag> <item> <p>List of user (client) public key algorithms to try to use.</p> diff --git a/lib/ssh/src/ssh_options.erl b/lib/ssh/src/ssh_options.erl index 395be6b220..a882a01eaf 100644 --- a/lib/ssh/src/ssh_options.erl +++ b/lib/ssh/src/ssh_options.erl @@ -200,17 +200,6 @@ save({K,V}, _, _) when K == reuseaddr ; save({allow_user_interaction,V}, Opts, Vals) -> save({user_interaction,V}, Opts, Vals); -save({public_key_alg,V}, Defs, Vals) -> % To remove in OTP-20 - New = case V of - 'ssh-rsa' -> ['ssh-rsa', 'ssh-dss']; - ssh_rsa -> ['ssh-rsa', 'ssh-dss']; - 'ssh-dss' -> ['ssh-dss', 'ssh-rsa']; - ssh_dsa -> ['ssh-dss', 'ssh-rsa']; - _ -> error({eoptions, {public_key_alg,V}, - "Unknown algorithm, try pref_public_key_algs instead"}) - end, - save({pref_public_key_algs,New}, Defs, Vals); - %% Special case for socket options 'inet' and 'inet6' save(Inet, Defs, OptMap) when Inet==inet ; Inet==inet6 -> save({inet,Inet}, Defs, OptMap); diff --git a/lib/ssh/test/Makefile b/lib/ssh/test/Makefile index 3fca78237c..fab79a7a43 100644 --- a/lib/ssh/test/Makefile +++ b/lib/ssh/test/Makefile @@ -36,7 +36,7 @@ MODULES= \ ssh_options_SUITE \ ssh_renegotiate_SUITE \ ssh_basic_SUITE \ - ssh_benchmark_SUITE \ + ssh_bench_SUITE \ ssh_connection_SUITE \ ssh_protocol_SUITE \ ssh_sftp_SUITE \ @@ -50,6 +50,7 @@ MODULES= \ ssh_key_cb_options \ ssh_trpt_test_lib \ ssh_echo_server \ + ssh_bench_dev_null \ ssh_peername_sockname_server \ ssh_test_cli \ ssh_relay \ diff --git a/lib/ssh/test/ssh.spec b/lib/ssh/test/ssh.spec index 0076fc275e..68268cb20d 100644 --- a/lib/ssh/test/ssh.spec +++ b/lib/ssh/test/ssh.spec @@ -1,6 +1,7 @@ {suites,"../ssh_test",all}. -{skip_suites, "../ssh_test", [ssh_benchmark_SUITE], +{skip_suites, "../ssh_test", [ssh_bench_SUITE + ], "Benchmarks run separately"}. diff --git a/lib/ssh/test/ssh_bench.spec b/lib/ssh/test/ssh_bench.spec index 029f0bd074..b0b64713cf 100644 --- a/lib/ssh/test/ssh_bench.spec +++ b/lib/ssh/test/ssh_bench.spec @@ -1 +1,2 @@ -{suites,"../ssh_test",[ssh_benchmark_SUITE]}. +{suites,"../ssh_test",[ssh_bench_SUITE + ]}. diff --git a/lib/ssh/test/ssh_bench_SUITE.erl b/lib/ssh/test/ssh_bench_SUITE.erl new file mode 100644 index 0000000000..ac52bb7e28 --- /dev/null +++ b/lib/ssh/test/ssh_bench_SUITE.erl @@ -0,0 +1,252 @@ +%%%------------------------------------------------------------------- +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2015-2016. All Rights Reserved. +%% +%% Licensed under the Apache License, Version 2.0 (the "License"); +%% you may not use this file except in compliance with the License. +%% 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(ssh_bench_SUITE). +-compile(export_all). + +-include_lib("common_test/include/ct_event.hrl"). +-include_lib("common_test/include/ct.hrl"). + +-include_lib("ssh/src/ssh.hrl"). +-include_lib("ssh/src/ssh_transport.hrl"). +-include_lib("ssh/src/ssh_connect.hrl"). +-include_lib("ssh/src/ssh_userauth.hrl"). + +%%%================================================================ +%%% +%%% Suite declarations +%%% + +suite() -> [{ct_hooks,[{ts_install_cth,[{nodenames,2}]}]}, + {timetrap,{minutes,1}} + ]. +all() -> [connect, + transfer_text + ]. + +-define(UID, "foo"). +-define(PWD, "bar"). +-define(Nruns, 8). + +%%%================================================================ +%%% +%%% Init per suite +%%% + +init_per_suite(Config) -> + catch ssh:stop(), + try + ok = ssh:start() + of + ok -> + DataSize = 1000000, + SystemDir = proplists:get_value(data_dir, Config), + Algs = insert_none(ssh:default_algorithms()), + {_ServerPid, _Host, Port} = + ssh_test_lib:daemon([{system_dir, SystemDir}, + {user_passwords, [{?UID,?PWD}]}, + {failfun, fun ssh_test_lib:failfun/2}, + {preferred_algorithms, Algs}, + {max_random_length_padding, 0}, + {subsystems, [{"/dev/null", {ssh_bench_dev_null,[DataSize]}}]} + ]), + [{host,"localhost"}, {port,Port}, {uid,?UID}, {pwd,?PWD}, {data_size,DataSize} | Config] + catch + C:E -> + {skip, io_lib:format("Couldn't start ~p:~p",[C,E])} + end. + +end_per_suite(_Config) -> + catch ssh:stop(), + ok. + +%%%================================================================ +%%% +%%% Init per testcase +%%% + +init_per_testcase(_Func, Conf) -> + Conf. + +end_per_testcase(_Func, _Conf) -> + ok. + +%%%================================================================ +%%% +%%% Testcases +%%% + +%%%---------------------------------------------------------------- +%%% Measure the time for an Erlang client to connect to an Erlang +%%% server on the localhost + +connect(Config) -> + KexAlgs = proplists:get_value(kex, ssh:default_algorithms()), + ct:pal("KexAlgs = ~p",[KexAlgs]), + lists:foreach( + fun(KexAlg) -> + PrefAlgs = preferred_algorithms(KexAlg), + report([{value, measure_connect(Config, + [{preferred_algorithms,PrefAlgs}])}, + {suite, ?MODULE}, + {name, mk_name(["Connect erlc erld ",KexAlg," [µs]"])} + ]) + end, KexAlgs). + + +measure_connect(Config, Opts) -> + Port = proplists:get_value(port, Config), + ConnectOptions = [{user, proplists:get_value(uid, Config)}, + {password, proplists:get_value(pwd, Config)}, + {user_dir, proplists:get_value(priv_dir, Config)}, + {silently_accept_hosts, true}, + {user_interaction, false}, + {max_random_length_padding, 0} + ] ++ Opts, + median( + [begin + {Time, {ok,Pid}} = timer:tc(ssh,connect,["localhost", Port, ConnectOptions]), + ssh:close(Pid), + Time + end || _ <- lists:seq(1,?Nruns)]). + +%%%---------------------------------------------------------------- +%%% Measure the time to transfer a set of data with +%%% and without crypto + +transfer_text(Config) -> + Port = proplists:get_value(port, Config), + Options = [{user, proplists:get_value(uid, Config)}, + {password, proplists:get_value(pwd, Config)}, + {user_dir, proplists:get_value(priv_dir, Config)}, + {silently_accept_hosts, true}, + {user_interaction, false}, + {max_random_length_padding, 0} + ], + Data = gen_data(proplists:get_value(data_size,Config)), + + [connect_measure(Port, Crypto, Mac, Data, Options) + || {Crypto,Mac} <- [{ none, none}, + {'aes128-ctr', 'hmac-sha1'}, + {'aes256-ctr', 'hmac-sha1'}, +%% {'[email protected]', 'hmac-sha1'}, + {'aes128-cbc', 'hmac-sha1'}, + {'3des-cbc', 'hmac-sha1'}, + {'aes128-ctr', 'hmac-sha2-256'}, + {'aes128-ctr', 'hmac-sha2-512'} + ], + crypto_mac_supported(Crypto,Mac)]. + + +crypto_mac_supported(none, none) -> + true; +crypto_mac_supported(C, M) -> + Algs = ssh:default_algorithms(), + [{_,Cs},_] = proplists:get_value(cipher, Algs), + [{_,Ms},_] = proplists:get_value(mac, Algs), + lists:member(C,Cs) andalso lists:member(M,Ms). + + +gen_data(DataSz) -> + Data0 = << <<C>> || _ <- lists:seq(1,DataSz div 256), + C <- lists:seq(0,255) >>, + Data1 = << <<C>> || C <- lists:seq(0,(DataSz rem 256) - 1) >>, + <<Data0/binary, Data1/binary>>. + + +%% connect_measure(Port, Cipher, Mac, Data, Options) -> +%% report([{value, 1}, +%% {suite, ?MODULE}, +%% {name, mk_name(["Transfer 1M bytes ",Cipher,"/",Mac," [µs]"])}]); +connect_measure(Port, Cipher, Mac, Data, Options) -> + Times = + [begin + {ok,C} = ssh:connect("localhost", Port, [{preferred_algorithms, [{cipher,[Cipher]}, + {mac,[Mac]}]} + |Options]), + {ok,Ch} = ssh_connection:session_channel(C, 10000), + success = ssh_connection:subsystem(C, Ch, "/dev/null", 10000), + {Time,ok} = timer:tc(?MODULE, send_wait_acc, [C, Ch, Data]), + ok = ssh_connection:send_eof(C, Ch), + ssh:close(C), + Time + end || _ <- lists:seq(1,?Nruns)], + + report([{value, median(Times)}, + {suite, ?MODULE}, + {name, mk_name(["Transfer 1M bytes ",Cipher,"/",Mac," [µs]"])}]). + +send_wait_acc(C, Ch, Data) -> + ssh_connection:send(C, Ch, Data), + receive + {ssh_cm, C, {data, Ch, 0, <<"READY">>}} -> ok + end. + + +%%%================================================================ +%%% +%%% Private +%%% + +%%%---------------------------------------------------------------- +insert_none(L) -> + lists:foldl(fun insert_none/2, [], L). + +insert_none({T,L}, Acc) when T==cipher ; + T==mac -> + [{T, [{T1,L1++[none]} || {T1,L1} <- L]} | Acc]; +insert_none(_, Acc) -> + Acc. + +%%%---------------------------------------------------------------- +mk_name(Name) -> [char(C) || C <- lists:concat(Name)]. + +char($-) -> $_; +char(C) -> C. + +%%%---------------------------------------------------------------- +preferred_algorithms(KexAlg) -> + [{kex, [KexAlg]}, + {public_key, ['ssh-rsa']}, + {cipher, ['aes128-ctr']}, + {mac, ['hmac-sha1']}, + {compression, [none]} + ]. + +%%%---------------------------------------------------------------- +median(Data) when is_list(Data) -> + SortedData = lists:sort(Data), + N = length(Data), + Median = + case N rem 2 of + 0 -> + MeanOfMiddle = (lists:nth(N div 2, SortedData) + + lists:nth(N div 2 + 1, SortedData)) / 2, + round(MeanOfMiddle); + 1 -> + lists:nth(N div 2 + 1, SortedData) + end, + ct:pal("median(~p) = ~p",[SortedData,Median]), + Median. + + +report(Data) -> + ct:pal("EventData = ~p",[Data]), + ct_event:notify(#event{name = benchmark_data, + data = Data}). diff --git a/lib/ssh/test/ssh_benchmark_SUITE_data/id_dsa b/lib/ssh/test/ssh_bench_SUITE_data/id_dsa index d306f8b26e..d306f8b26e 100644 --- a/lib/ssh/test/ssh_benchmark_SUITE_data/id_dsa +++ b/lib/ssh/test/ssh_bench_SUITE_data/id_dsa diff --git a/lib/ssh/test/ssh_benchmark_SUITE_data/id_ecdsa256 b/lib/ssh/test/ssh_bench_SUITE_data/id_ecdsa256 index 4b1eb12eaa..4b1eb12eaa 100644 --- a/lib/ssh/test/ssh_benchmark_SUITE_data/id_ecdsa256 +++ b/lib/ssh/test/ssh_bench_SUITE_data/id_ecdsa256 diff --git a/lib/ssh/test/ssh_benchmark_SUITE_data/id_ecdsa256.pub b/lib/ssh/test/ssh_bench_SUITE_data/id_ecdsa256.pub index a0147e60fa..a0147e60fa 100644 --- a/lib/ssh/test/ssh_benchmark_SUITE_data/id_ecdsa256.pub +++ b/lib/ssh/test/ssh_bench_SUITE_data/id_ecdsa256.pub diff --git a/lib/ssh/test/ssh_benchmark_SUITE_data/id_ecdsa384 b/lib/ssh/test/ssh_bench_SUITE_data/id_ecdsa384 index 4e8aa40959..4e8aa40959 100644 --- a/lib/ssh/test/ssh_benchmark_SUITE_data/id_ecdsa384 +++ b/lib/ssh/test/ssh_bench_SUITE_data/id_ecdsa384 diff --git a/lib/ssh/test/ssh_benchmark_SUITE_data/id_ecdsa384.pub b/lib/ssh/test/ssh_bench_SUITE_data/id_ecdsa384.pub index 41e722e545..41e722e545 100644 --- a/lib/ssh/test/ssh_benchmark_SUITE_data/id_ecdsa384.pub +++ b/lib/ssh/test/ssh_bench_SUITE_data/id_ecdsa384.pub diff --git a/lib/ssh/test/ssh_benchmark_SUITE_data/id_ecdsa521 b/lib/ssh/test/ssh_bench_SUITE_data/id_ecdsa521 index 7196f46e97..7196f46e97 100644 --- a/lib/ssh/test/ssh_benchmark_SUITE_data/id_ecdsa521 +++ b/lib/ssh/test/ssh_bench_SUITE_data/id_ecdsa521 diff --git a/lib/ssh/test/ssh_benchmark_SUITE_data/id_ecdsa521.pub b/lib/ssh/test/ssh_bench_SUITE_data/id_ecdsa521.pub index 8f059120bc..8f059120bc 100644 --- a/lib/ssh/test/ssh_benchmark_SUITE_data/id_ecdsa521.pub +++ b/lib/ssh/test/ssh_bench_SUITE_data/id_ecdsa521.pub diff --git a/lib/ssh/test/ssh_benchmark_SUITE_data/id_rsa b/lib/ssh/test/ssh_bench_SUITE_data/id_rsa index 9d7e0dd5fb..9d7e0dd5fb 100644 --- a/lib/ssh/test/ssh_benchmark_SUITE_data/id_rsa +++ b/lib/ssh/test/ssh_bench_SUITE_data/id_rsa diff --git a/lib/ssh/test/ssh_benchmark_SUITE_data/ssh_host_dsa_key b/lib/ssh/test/ssh_bench_SUITE_data/ssh_host_dsa_key index 51ab6fbd88..51ab6fbd88 100644 --- a/lib/ssh/test/ssh_benchmark_SUITE_data/ssh_host_dsa_key +++ b/lib/ssh/test/ssh_bench_SUITE_data/ssh_host_dsa_key diff --git a/lib/ssh/test/ssh_benchmark_SUITE_data/ssh_host_dsa_key.pub b/lib/ssh/test/ssh_bench_SUITE_data/ssh_host_dsa_key.pub index 4dbb1305b0..4dbb1305b0 100644 --- a/lib/ssh/test/ssh_benchmark_SUITE_data/ssh_host_dsa_key.pub +++ b/lib/ssh/test/ssh_bench_SUITE_data/ssh_host_dsa_key.pub diff --git a/lib/ssh/test/ssh_benchmark_SUITE_data/ssh_host_ecdsa_key256 b/lib/ssh/test/ssh_bench_SUITE_data/ssh_host_ecdsa_key256 index 2979ea88ed..2979ea88ed 100644 --- a/lib/ssh/test/ssh_benchmark_SUITE_data/ssh_host_ecdsa_key256 +++ b/lib/ssh/test/ssh_bench_SUITE_data/ssh_host_ecdsa_key256 diff --git a/lib/ssh/test/ssh_benchmark_SUITE_data/ssh_host_ecdsa_key256.pub b/lib/ssh/test/ssh_bench_SUITE_data/ssh_host_ecdsa_key256.pub index 85dc419345..85dc419345 100644 --- a/lib/ssh/test/ssh_benchmark_SUITE_data/ssh_host_ecdsa_key256.pub +++ b/lib/ssh/test/ssh_bench_SUITE_data/ssh_host_ecdsa_key256.pub diff --git a/lib/ssh/test/ssh_benchmark_SUITE_data/ssh_host_ecdsa_key384 b/lib/ssh/test/ssh_bench_SUITE_data/ssh_host_ecdsa_key384 index fb1a862ded..fb1a862ded 100644 --- a/lib/ssh/test/ssh_benchmark_SUITE_data/ssh_host_ecdsa_key384 +++ b/lib/ssh/test/ssh_bench_SUITE_data/ssh_host_ecdsa_key384 diff --git a/lib/ssh/test/ssh_benchmark_SUITE_data/ssh_host_ecdsa_key384.pub b/lib/ssh/test/ssh_bench_SUITE_data/ssh_host_ecdsa_key384.pub index 428d5fb7d7..428d5fb7d7 100644 --- a/lib/ssh/test/ssh_benchmark_SUITE_data/ssh_host_ecdsa_key384.pub +++ b/lib/ssh/test/ssh_bench_SUITE_data/ssh_host_ecdsa_key384.pub diff --git a/lib/ssh/test/ssh_benchmark_SUITE_data/ssh_host_ecdsa_key521 b/lib/ssh/test/ssh_bench_SUITE_data/ssh_host_ecdsa_key521 index 3e51ec2ecd..3e51ec2ecd 100644 --- a/lib/ssh/test/ssh_benchmark_SUITE_data/ssh_host_ecdsa_key521 +++ b/lib/ssh/test/ssh_bench_SUITE_data/ssh_host_ecdsa_key521 diff --git a/lib/ssh/test/ssh_benchmark_SUITE_data/ssh_host_ecdsa_key521.pub b/lib/ssh/test/ssh_bench_SUITE_data/ssh_host_ecdsa_key521.pub index 017a29f4da..017a29f4da 100644 --- a/lib/ssh/test/ssh_benchmark_SUITE_data/ssh_host_ecdsa_key521.pub +++ b/lib/ssh/test/ssh_bench_SUITE_data/ssh_host_ecdsa_key521.pub diff --git a/lib/ssh/test/ssh_benchmark_SUITE_data/ssh_host_rsa_key b/lib/ssh/test/ssh_bench_SUITE_data/ssh_host_rsa_key index 79968bdd7d..79968bdd7d 100644 --- a/lib/ssh/test/ssh_benchmark_SUITE_data/ssh_host_rsa_key +++ b/lib/ssh/test/ssh_bench_SUITE_data/ssh_host_rsa_key diff --git a/lib/ssh/test/ssh_benchmark_SUITE_data/ssh_host_rsa_key.pub b/lib/ssh/test/ssh_bench_SUITE_data/ssh_host_rsa_key.pub index 75d2025c71..75d2025c71 100644 --- a/lib/ssh/test/ssh_benchmark_SUITE_data/ssh_host_rsa_key.pub +++ b/lib/ssh/test/ssh_bench_SUITE_data/ssh_host_rsa_key.pub diff --git a/lib/ssh/test/ssh_bench_dev_null.erl b/lib/ssh/test/ssh_bench_dev_null.erl new file mode 100644 index 0000000000..0e390b7712 --- /dev/null +++ b/lib/ssh/test/ssh_bench_dev_null.erl @@ -0,0 +1,58 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2005-2016. All Rights Reserved. +%% +%% Licensed under the Apache License, Version 2.0 (the "License"); +%% you may not use this file except in compliance with the License. +%% 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% +%% + +%% + +%%% Description: Example ssh server +-module(ssh_bench_dev_null). +-behaviour(ssh_daemon_channel). + +-record(state, { + cm, + chid, + n, + sum = 0 + }). + +-export([init/1, handle_msg/2, handle_ssh_msg/2, terminate/2]). + +init([N]) -> {ok, #state{n=N}}. + +handle_msg({ssh_channel_up, ChId, CM}, S) -> + {ok, S#state{cm = CM, + chid = ChId}}. + + + +handle_ssh_msg({ssh_cm, CM, {data,ChId,0,Data}}, #state{n=N, sum=Sum0, cm=CM, chid=ChId} = S) -> + Sum = Sum0 + size(Data), + if Sum == N -> + %% Got all + ssh_connection:send(CM, ChId, <<"READY">>), + {ok, S#state{sum=Sum}}; + Sum < N -> + %% Expects more + {ok, S#state{sum=Sum}} + end; +handle_ssh_msg({ssh_cm, _, {exit_signal,ChId,_,_,_}}, S) -> {stop, ChId, S}; +handle_ssh_msg({ssh_cm, _, {exit_status,ChId,_} }, S) -> {stop, ChId, S}; +handle_ssh_msg({ssh_cm, _, _ }, S) -> {ok, S}. + +terminate(_, _) -> ok. diff --git a/lib/ssh/test/ssh_benchmark_SUITE.erl b/lib/ssh/test/ssh_benchmark_SUITE.erl deleted file mode 100644 index fc90750455..0000000000 --- a/lib/ssh/test/ssh_benchmark_SUITE.erl +++ /dev/null @@ -1,571 +0,0 @@ -%%%------------------------------------------------------------------- -%% %CopyrightBegin% -%% -%% Copyright Ericsson AB 2015-2016. All Rights Reserved. -%% -%% Licensed under the Apache License, Version 2.0 (the "License"); -%% you may not use this file except in compliance with the License. -%% 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(ssh_benchmark_SUITE). --compile(export_all). - --include_lib("common_test/include/ct_event.hrl"). --include_lib("common_test/include/ct.hrl"). - --include_lib("ssh/src/ssh.hrl"). --include_lib("ssh/src/ssh_transport.hrl"). --include_lib("ssh/src/ssh_connect.hrl"). --include_lib("ssh/src/ssh_userauth.hrl"). - - -suite() -> [{ct_hooks,[{ts_install_cth,[{nodenames,2}]}]}, - {timetrap,{minutes,6}} - ]. -%%suite() -> [{ct_hooks,[ts_install_cth]}]. - -all() -> [{group, opensshc_erld} -%% {group, erlc_opensshd} - ]. - -groups() -> - [{opensshc_erld, [{repeat, 3}], [openssh_client_shell, - openssh_client_sftp]} - ]. - - -init_per_suite(Config) -> - catch ssh:stop(), - try - report_client_algorithms(), - ok = ssh:start(), - {ok,TracerPid} = erlang_trace(), - [{tracer_pid,TracerPid} | init_sftp_dirs(Config)] - catch - C:E -> - {skip, io_lib:format("Couldn't start ~p:~p",[C,E])} - end. - -end_per_suite(_Config) -> - catch ssh:stop(), - ok. - - - -init_per_group(opensshc_erld, Config) -> - case ssh_test_lib:ssh_type() of - openSSH -> - DataDir = proplists:get_value(data_dir, Config), - UserDir = proplists:get_value(priv_dir, Config), - ssh_test_lib:setup_dsa(DataDir, UserDir), - ssh_test_lib:setup_rsa(DataDir, UserDir), - ssh_test_lib:setup_ecdsa("256", DataDir, UserDir), - AlgsD = ssh:default_algorithms(), - AlgsC = ssh_test_lib:default_algorithms(sshc), - Common = ssh_test_lib:intersect_bi_dir( - ssh_test_lib:intersection(AlgsD, AlgsC)), - ct:pal("~p~n~nErld:~n~p~n~nOpenSSHc:~n~p~n~nCommon:~n~p", - [inet:gethostname(), AlgsD, AlgsC, Common]), - [{c_kexs, ssh_test_lib:sshc(kex)}, - {c_ciphers, ssh_test_lib:sshc(cipher)}, - {common_algs, Common} - | Config]; - _ -> - {skip, "No OpenSsh client found"} - end; - -init_per_group(erlc_opensshd, _) -> - {skip, "Group erlc_opensshd not implemented"}; - -init_per_group(_GroupName, Config) -> - Config. - -end_per_group(_GroupName, _Config) -> - ok. - - -init_per_testcase(_Func, Conf) -> - Conf. - -end_per_testcase(_Func, _Conf) -> - ok. - - -init_sftp_dirs(Config) -> - UserDir = proplists:get_value(priv_dir, Config), - SrcDir = filename:join(UserDir, "sftp_src"), - ok = file:make_dir(SrcDir), - SrcFile = "big_data", - DstDir = filename:join(UserDir, "sftp_dst"), - ok = file:make_dir(DstDir), - N = 100 * 1024*1024, - ok = file:write_file(filename:join(SrcDir,SrcFile), crypto:strong_rand_bytes(N)), - [{sftp_src_dir,SrcDir}, {sftp_dst_dir,DstDir}, {src_file,SrcFile}, {sftp_size,N} - | Config]. - -%%%================================================================ -openssh_client_shell(Config) -> - lists:foreach( - fun(PrefAlgs=[{kex,[Kex]}]) when Kex == 'diffie-hellman-group-exchange-sha256' -> - lists:foreach( - fun(Grp) -> - openssh_client_shell(Config, - [{preferred_algorithms, PrefAlgs}, - {dh_gex_groups, [Grp]} - ]) - end, moduli()); - (PrefAlgs) -> - openssh_client_shell(Config, - [{preferred_algorithms, PrefAlgs}]) - end, variants(kex,Config) ++ variants(cipher,Config) - ). - - -openssh_client_shell(Config, Options) -> - SystemDir = proplists:get_value(data_dir, Config), - UserDir = proplists:get_value(priv_dir, Config), - KnownHosts = filename:join(UserDir, "known_hosts"), - - {ok, TracerPid} = erlang_trace(), - {ServerPid, _Host, Port} = - ssh_test_lib:daemon([{system_dir, SystemDir}, - {failfun, fun ssh_test_lib:failfun/2} | - Options]), - ct:sleep(500), - - Data = lists:duplicate(100000, $a), - Cmd = lists:concat(["ssh -p ",Port, - " -o UserKnownHostsFile=", KnownHosts, - " -o \"StrictHostKeyChecking no\"", - " localhost '\"",Data,"\"'."]), -%% ct:pal("Cmd ="++Cmd), - - Parent = self(), - SlavePid = spawn(fun() -> - Parent ! {self(),os:cmd(Cmd)} - end), - receive - {SlavePid, _ClientResponse} -> -%% ct:pal("ClientResponse = ~p",[_ClientResponse]), - {ok, List} = get_trace_list(TracerPid), - Times = find_times(List, [accept_to_hello, kex, kex_to_auth, auth, to_prompt]), - Algs = find_algs(List), - ct:pal("Algorithms = ~p~n~nTimes = ~p",[Algs,Times]), - lists:foreach( - fun({Tag,Value,Unit}) -> - EventData = - case Tag of - {A,B} when A==encrypt ; A==decrypt -> - [{value, Value}, - {suite, ?MODULE}, - {name, mk_name(["Cipher ",A," ",B," [",Unit,"]"])} - ]; - kex -> - KexAlgStr = fmt_alg(Algs#alg.kex, List), - [{value, Value}, - {suite, ?MODULE}, - {name, mk_name(["Erl server kex ",KexAlgStr," [",Unit,"]"])} - ]; - _ when is_atom(Tag) -> - [{value, Value}, - {suite, ?MODULE}, - {name, mk_name(["Erl server ",Tag," [",Unit,"]"])} - ] - end, - ct:pal("ct_event:notify ~p",[EventData]), - ct_event:notify(#event{name = benchmark_data, - data = EventData}) - end, Times), - ssh:stop_daemon(ServerPid), - ok - after 60*1000 -> - ssh:stop_daemon(ServerPid), - exit(SlavePid, kill), - {fail, timeout} - end. - - -%%%================================================================ -openssh_client_sftp(Config) -> - lists:foreach( - fun(PrefAlgs) -> - openssh_client_sftp(Config, [{preferred_algorithms,PrefAlgs}]) - end, variants(cipher,Config)). - - -openssh_client_sftp(Config, Options) -> - SystemDir = proplists:get_value(data_dir, Config), - UserDir = proplists:get_value(priv_dir, Config), - SftpSrcDir = proplists:get_value(sftp_src_dir, Config), - SrcFile = proplists:get_value(src_file, Config), - SrcSize = proplists:get_value(sftp_size, Config), - KnownHosts = filename:join(UserDir, "known_hosts"), - - {ok, TracerPid} = erlang_trace(), - {ServerPid, _Host, Port} = - ssh_test_lib:daemon([{system_dir, SystemDir}, - {subsystems,[ssh_sftpd:subsystem_spec([%{cwd, SftpSrcDir}, - {root, SftpSrcDir}])]}, - {failfun, fun ssh_test_lib:failfun/2} - | Options]), - ct:pal("ServerPid = ~p",[ServerPid]), - ct:sleep(500), - Cmd = lists:concat(["sftp", - " -b -", - " -P ",Port, - " -o UserKnownHostsFile=", KnownHosts, - " -o \"StrictHostKeyChecking no\"", - " localhost:",SrcFile - ]), -%% ct:pal("Cmd = ~p",[Cmd]), - - Parent = self(), - SlavePid = spawn(fun() -> - Parent ! {self(),os:cmd(Cmd)} - end), - receive - {SlavePid, _ClientResponse} -> - ct:pal("ClientResponse = ~p~nServerPid = ~p",[_ClientResponse,ServerPid]), - {ok, List} = get_trace_list(TracerPid), -%%ct:pal("List=~p",[List]), - Times = find_times(List, [channel_open_close]), - Algs = find_algs(List), - ct:pal("Algorithms = ~p~n~nTimes = ~p",[Algs,Times]), - lists:foreach( - fun({{A,B},Value,Unit}) when A==encrypt ; A==decrypt -> - Data = [{value, Value}, - {suite, ?MODULE}, - {name, mk_name(["Sftp Cipher ",A," ",B," [",Unit,"]"])} - ], - ct:pal("sftp ct_event:notify ~p",[Data]), - ct_event:notify(#event{name = benchmark_data, - data = Data}); - ({channel_open_close,Value,Unit}) -> - Cipher = fmt_alg(Algs#alg.encrypt, List), - Data = [{value, round( (1024*Value) / SrcSize )}, - {suite, ?MODULE}, - {name, mk_name(["Sftp transfer ",Cipher," [",Unit," per kbyte]"])} - ], - ct:pal("sftp ct_event:notify ~p",[Data]), - ct_event:notify(#event{name = benchmark_data, - data = Data}); - (_) -> - skip - end, Times), - ssh:stop_daemon(ServerPid), - ok - after 2*60*1000 -> - ssh:stop_daemon(ServerPid), - exit(SlavePid, kill), - {fail, timeout} - end. - -%%%================================================================ -variants(Tag, Config) -> - TagType = - case proplists:get_value(Tag, ssh:default_algorithms()) of - [{_,_}|_] -> one_way; - [A|_] when is_atom(A) -> two_way - end, - [ [{Tag,tag_value(TagType,Alg)}] - || Alg <- proplists:get_value(Tag, proplists:get_value(common_algs,Config)) - ]. - -tag_value(two_way, Alg) -> [Alg]; -tag_value(one_way, Alg) -> [{client2server,[Alg]}, - {server2client,[Alg]}]. - -%%%---------------------------------------------------------------- -fmt_alg(Alg, List) when is_atom(Alg) -> - fmt_alg(atom_to_list(Alg), List); -fmt_alg(Alg = "diffie-hellman-group-exchange-sha" ++ _, List) -> - try - integer_to_list(find_gex_size_string(List)) - of - GexSize -> lists:concat([Alg," ",GexSize]) - catch - _:_ -> Alg - end; -fmt_alg(Alg, _List) -> - Alg. - -%%%---------------------------------------------------------------- -mk_name(Name) -> [char(C) || C <- lists:concat(Name)]. - -char($-) -> $_; -char(C) -> C. - -%%%---------------------------------------------------------------- -find_times(L, Xs) -> - [find_time(X,L) || X <- Xs] ++ - function_algs_times_sizes([{ssh_transport,encrypt,2}, - {ssh_transport,decrypt,2}, - {ssh_message,decode,1}, - {ssh_message,encode,1}], L). - --record(call, { - mfa, - pid, - t_call, - t_return, - args, - result - }). - -%%%---------------- --define(send(M), fun(C=#call{mfa = {ssh_message,encode,1}, - args = [M]}) -> - C#call.t_return - end). - --define(recv(M), fun(C=#call{mfa = {ssh_message,decode,1}, - result = M}) -> - C#call.t_call - end). - -find_time(accept_to_hello, L) -> - [T0,T1] = find([fun(C=#call{mfa = {ssh_acceptor,handle_connection,5}}) -> - C#call.t_call - end, - ?LINE, - fun(C=#call{mfa = {ssh_connection_handler,handle_event,4}, - args = [_, {version_exchange,_}, {hello,_}, _]}) -> - C#call.t_call - end, - ?LINE - ], L, []), - {accept_to_hello, now2micro_sec(now_diff(T1,T0)), microsec}; -find_time(kex, L) -> - [T0,T1] = find([fun(C=#call{mfa = {ssh_connection_handler,handle_event,4}, - args = [_, {version_exchange,_}, {hello,_}, _]}) -> - C#call.t_call - end, - ?LINE, - ?send(#ssh_msg_newkeys{}), - ?LINE - ], L, []), - {kex, now2micro_sec(now_diff(T1,T0)), microsec}; -find_time(kex_to_auth, L) -> - [T0,T1] = find([?send(#ssh_msg_newkeys{}), - ?LINE, - ?recv(#ssh_msg_userauth_request{}), - ?LINE - ], L, []), - {kex_to_auth, now2micro_sec(now_diff(T1,T0)), microsec}; -find_time(auth, L) -> - [T0,T1] = find([?recv(#ssh_msg_userauth_request{}), - ?LINE, - ?send(#ssh_msg_userauth_success{}), - ?LINE - ], L, []), - {auth, now2micro_sec(now_diff(T1,T0)), microsec}; -find_time(to_prompt, L) -> - [T0,T1] = find([fun(C=#call{mfa = {ssh_acceptor,handle_connection,5}}) -> - C#call.t_call - end, - ?LINE, - ?recv(#ssh_msg_channel_request{request_type="env"}), - ?LINE - ], L, []), - {to_prompt, now2micro_sec(now_diff(T1,T0)), microsec}; -find_time(channel_open_close, L) -> - [T0,T1] = find([?recv(#ssh_msg_channel_request{request_type="subsystem"}), - ?LINE, - ?send(#ssh_msg_channel_close{}), - ?LINE - ], L, []), - {channel_open_close, now2micro_sec(now_diff(T1,T0)), microsec}. - - - -find([F,Id|Fs], [C|Cs], Acc) when is_function(F,1) -> - try - F(C) - of - T -> find(Fs, Cs, [T|Acc]) - catch - _:_ -> find([F,Id|Fs], Cs, Acc) - end; -find([], _, Acc) -> - lists:reverse(Acc). - - -find_algs(L) -> - {value, #call{result={ok,Algs}}} = - lists:keysearch({ssh_transport,select_algorithm,3}, #call.mfa, L), - Algs. - -find_gex_size_string(L) -> - %% server - {value, #call{result={ok,{Size, _}}}} = - lists:keysearch({public_key,dh_gex_group,4}, #call.mfa, L), - Size. - -%%%---------------- -function_algs_times_sizes(EncDecs, L) -> - Raw = [begin - {Tag,Size} = function_ats_result(EncDec, C), - {Tag, Size, now2micro_sec(now_diff(T1,T0))} - end - || EncDec <- EncDecs, - C = #call{mfa = ED, - % args = Args, %%[S,Data], - t_call = T0, - t_return = T1} <- L, - ED == EncDec - ], - [{Alg, round(1024*Time/Size), "microsec per kbyte"} % Microseconds per 1k bytes. - || {Alg,Size,Time} <- lists:foldl(fun increment/2, [], Raw)]. - -function_ats_result({ssh_transport,encrypt,2}, #call{args=[S,Data]}) -> - {{encrypt,S#ssh.encrypt}, binsize(Data)}; -function_ats_result({ssh_transport,decrypt,2}, #call{args=[S,Data]}) -> - {{decrypt,S#ssh.decrypt}, binsize(Data)}; -function_ats_result({ssh_message,encode,1}, #call{result=Data}) -> - {encode, size(Data)}; -function_ats_result({ssh_message,decode,1}, #call{args=[Data]}) -> - {decode, size(Data)}. - -binsize(B) when is_binary(B) -> size(B); -binsize({B1,B2}) when is_binary(B1), is_binary(B2) -> size(B1) + size(B2); -binsize({B1,B2,_}) when is_binary(B1), is_binary(B2) -> size(B1) + size(B2). - - - - - -increment({Alg,Sz,T}, [{Alg,SumSz,SumT}|Acc]) -> - [{Alg,SumSz+Sz,SumT+T} | Acc]; -increment(Spec, [X|Acc]) -> - [X | increment(Spec,Acc)]; % Not so many Alg, 2 or 3 -increment({Alg,Sz,T},[]) -> - [{Alg,Sz,T}]. - -%%%---------------------------------------------------------------- -%%% -%%% API for the traceing -%%% -get_trace_list(TracerPid) -> - MonRef = monitor(process, TracerPid), - TracerPid ! {get_trace_list,self()}, - receive - {trace_list,L} -> - demonitor(MonRef), - {ok, pair_events(lists:reverse(L))}; - {'DOWN', MonRef, process, TracerPid, Info} -> - {error, {tracer_down,Info}} - - after 3*60*1000 -> - demonitor(MonRef), - {error,no_reply} - end. - -erlang_trace() -> - TracerPid = spawn(fun trace_loop/0), - 0 = erlang:trace(new, true, [call,timestamp,{tracer,TracerPid}]), - [init_trace(MFA, tp(MFA)) - || MFA <- [{ssh_acceptor,handle_connection,5}, -%% {ssh_connection_handler,hello,2}, - {ssh_message,encode,1}, - {ssh_message,decode,1}, - {ssh_transport,select_algorithm,3}, - {ssh_transport,encrypt,2}, - {ssh_transport,decrypt,2}, - {ssh_message,encode,1}, - {ssh_message,decode,1}, - {public_key,dh_gex_group,4} % To find dh_gex group size - ]], - init_trace({ssh_connection_handler,handle_event,4}, - [{['_', {version_exchange,'_'}, {hello,'_'}, '_'], - [], - [return_trace]}]), - {ok, TracerPid}. - -tp({_M,_F,Arity}) -> - [{lists:duplicate(Arity,'_'), [], [{return_trace}]}]. - -%%%---------------------------------------------------------------- -init_trace(MFA = {Module,_,_}, TP) -> - case code:is_loaded(Module) of - false -> code:load_file(Module); - _ -> ok - end, - erlang:trace_pattern(MFA, TP, [local]). - - -trace_loop() -> - trace_loop([]). - -trace_loop(L) -> - receive - {get_trace_list, From} -> - From ! {trace_list, L}, - trace_loop(L); - Ev -> - trace_loop([Ev|L]) - end. - -pair_events(L) -> - pair_events(L, []). - -pair_events([{trace_ts,Pid,call,{M,F,Args},TS0} | L], Acc) -> - Arity = length(Args), - {ReturnValue,TS1} = find_return(Pid, {M,F,Arity}, L), - pair_events(L, [#call{mfa = {M,F,Arity}, - pid = Pid, - t_call = TS0, - t_return = TS1, - args = Args, - result = ReturnValue} | Acc]); -pair_events([_|L], Acc) -> - pair_events(L, Acc); -pair_events([], Acc) -> - lists:reverse(Acc). - - -find_return(Pid, MFA, - [{trace_ts, Pid, return_from, MFA, ReturnValue, TS}|_]) -> - {ReturnValue, TS}; -find_return(Pid, MFA, [_|L]) -> - find_return(Pid, MFA, L); -find_return(_, _, []) -> - {undefined, undefined}. - -%%%---------------------------------------------------------------- -report_client_algorithms() -> - try - ssh_test_lib:extract_algos( ssh_test_lib:default_algorithms(sshc) ) - of - ClientAlgs -> - ct:pal("The client supports:~n~p",[ClientAlgs]) - catch - Cls:Err -> - ct:pal("Testing client about algorithms failed:~n~p ~p",[Cls,Err]) - end. - -%%%---------------------------------------------------------------- - - -now2sec({A,B,C}) -> A*1000000 + B + C/1000000. - -now2micro_sec({A,B,C}) -> (A*1000000 + B)*1000000 + C. - -now_diff({A1,B1,C1}, {A0,B0,C0}) -> {A1-A0, B1-B0, C1-C0}. - -%%%================================================================ -moduli() -> - [{1023, 5, 16#CF973CD39DC7D62F2C45AAC5180491104C76E0FE5D80A10E6C06AE442F1F373167B0FCBC931F3C157B10A5557008FDE20D68051E6A4DB11CEE0B0749F76D7134B937A59DA998C42BC234A5C1A3CFCD70E624D253D7694076F7B1FD7B8D3427849C9377B3555796ACA58C69DFF542EEEC9859D3ADCE5CC88DF6F7817C9D182EB7}, - {2047, 5, 16#F7693FC11FDDEAA493D3BA36F1FFF9264AA9952209203192A88A697BE9D0E306E306A27430BD87AB9EE9DB4BC78C41950C2EB0E5E4C686E8B1BA6D6A2B1FE91EF40C5EA32C51018323E1D305FE637F35ACABDBFC40AD683F779570A76869EB90015A342B2D1F7C81602688081FCAAA8D623090258D9C5C729C8CDDC0C12CA2D561DD987DB79B6AD7A2A509EBC383BF223FD95BC5A2FCC26FB3F3A0DD3FDC1228E338D3290235A596F9465F7BF490974847E616229A9E60B8F4AA161C52F655843CCCAE8821B40C426B535DE087964778652BBD4EC601C0456AE7128B593FCC64402C891227AE6EE88CC839416FBF462B4852999C646BE0BED7D8CF2BE5E381EF}, - {4095, 2, 16#C8842271626E53546E0C712FA265713F2EE073C20A0723C96B6B182B1EAACC96233D4A199BD0E85F264078A513AD2454F284B8DF543D85019D1E70F2FF54BA43EFBC64AF465C170C3E376F5EC328F98E33E1ED8BED84FA097ABE584152B0E9827ED5CC2B1D4F5ECF2DC46F45C59816D02698EA26F319311E2B6973E83C37021CC8B416AEF653896A1764EE0CEE718A45E8B47CB960BD5907D0E843E8A8E7D4698363C3C3FB3ADC512368B72CAF16510C69052EA2AF51BE00BC8CA04DF1F00A00CC2CA4D74254A1E8738460FD244DDB446CB36554B0A24EEF3710E44DBCF39881E7D3F9AE223388084E7A49A3CB12612AE36416C0EB5628DF1477FEE4A5CF77CDC09AA0E2C989C0B7D1310AFA44B81DA79A65226C7EA510057991EABF9388DC5EA9F52FEA5D3B0872843F50878740794E523E9DC60E0EA1FC8746A7B2AA31FCA89AAA2FA907BED116C69D98F912DD5089BECF28577064225DE96FC214ED1794E7CCE8024F94036D915A123A464C951DA96A5ED7F286F205BEE71BDE2D133FD1891B31178FF25D31611A5B7839F0E68EAF0F8901A571E6917C580F31842A9F19C47E0638483B7947DDCD7864660AC2F8B2C430F1E7FC0F22FA51F96F0499332C5AD3FF9DC7F4332DD5BCCA820CC779B90C0F4C5F0CA52E96FAA187361753FBADC5C80D0492CD80A3EEA5D578772DA9FC1C0E10A0203098AF36D0ED2156BA7321EB}, - {6143, 5, 16#FD9E6B52785CD7BE64D396A599DA4B97CD0BB49183F932A97694D80CA553354DBC26E77B8A0EC002257AADDF6AD27819CE64A06416E4A80B6EA92F28EA8D5B96C774109EEE5816B4B18F84368D1B41864C11AA73D6881675D779B174F6B4E344303F3EFD11BD7DE468467242372FD00908F296F5A2B20E2684F9122D08A46D647B05E298F0BCDAB60468349CCA6DA1B9FEBBC69D256FB9A3F1980F68466364FCEF1C98C1405191A6737A3627BA7F7313A8A18FC0B8521BF3430B1C6805CB44BCEB39904DD30130D24B225B598ED83C5FD757B80189FD9D5C2F9596687C40BAB1C6ED6244944629849D074A4C33FB15DDB3F9760FC59C44BEBB0EC032177147F61789769DAAAE2123CE488F7ECF19BDA051925BA9ED11EAA72DF70C9ECC8F714B4C35728E6679E66A1B56CCAE0FBBD3F9EBF950D4D623ED78E77CC3AD604E91F304EA78CE876F036214BD6F1977BD04C9ADD707D7A3BCCE87AD5D5A11C95E7025B0EA9C649DCB37942A3970A4FB04C284E4DDB4DC90163353B98B1C254FFD28443353F17A87C02E0BDB9F05424CC44C86309F1D73706F039CDAAC3EDC1A64F38FB42707D351DB5360C2680ADC1CC8D1C4AD312ACC904382C26BE33DA0E61429A5940820356ED28586BEB629ED1521D12D25B4DA01926295F3DA504DC9F431B719AC63277BE675E6F6DD4F7499CA11A23744577D653941963E8DAB610F7F226DB52CE5C683F72AEED2B6CE35ED07C29410397A6F7F606477CCC0EDE18CD0D96A7863BC4606193A8799B5AC1EEE6AC5EE36AC3077EC8DAB30EE94434B45B78BC13D96F74D6C4056EAA528CD3C68D308344808819B12F2BFB95A5C1A7DEEE188BF139216DDB7D757D7A50D3C46CE18881D776D617DCFFAA62276045373AA4D9446D7570338F99C0CA8A08851B4F9D388B4C275D3F9B7BA25F235D4329F63F7457C2EB5C68CE2A96D19766F0ED8E19F66DF3C5E29A38795B2F92291BB6EAB6F70A7E89DC9691F28486E9CF87FF11D5DF2E6B030A30B5D476AD59A34EE7262712ED96CEF4A5CAC3F08B3563D44683F746DA094C9CDB34427AF8D8CC2AE1B23C3BEB637}, - {8191, 2, 16#DC61EF13E4F3FC10CC946EEABC33F83EFCB35E0F47E4EC25C1CCBB2C7B502B2EFB0691AA231C8476DD51BA73204E6EA10B1A970FE2CF14AF01E72E1AEA87519A91D00D1499189F94A6CDA9E29C05F11F17FE74A4919A710A2787E180744465DF81C62AA65662FDA46FA6175E8A31E5B29E66DED6701C8FC4217E91D733FE94380F046680967D4CEA7BAC8F3916CDF96AA2C474FAD9650F48403FD0B5B756D34667D36A07767FA33027AE55484D0F701C3CA16632F413A14E4B8645AFAF15B78978C19A7661EDC569BEC72394B1204B166A48FCD5F56BE29840C7794CA6D3440356F15858CDCA9B429C7EA92E17242893FDC8C9C63841A382C32F20CFAB121B4BCAFD7BF9EF07FBF7CDFFECA0CEF3A49C3E2B24FA836F3318435255655E1B281071F62D5E4CD63361299B7828F72936E3FEA9E8044562A6F6ADD5321187C3101E4669C6271598FE1A866C93FE2870A4CEB9254BA32A4719E439317EA42200A335B5CFFA7946A7D0F1BD1A69AA11288B73C71C80B77FE3707CB077DDDEA5CA36A449FAB230C9625A0B12F8275D3FF82F5DA380E7A3F11B6F155FE7E91AC960BD95D9B13F7423AB9B15CC3C4DC34EF296033F009468EA16A721AD659F56C18516025050749ABF05E6D3EBD9778142A530979291F46DAA399A86B7BCDF09CC3E6EEF101419762A306DB45AEFC96C64E83F28338D55905F6A387E0F515E580C3A9B35330E21C32198CDEE3AFB355967A098F635FCA7C49CB4E1E82464B2B390EF1F259E40B9A06235C0273F76284FE6BD534EF3AF7CB01A4A5252B8B94CADC2850B2E56D53F9A31D7C029DF967D0A30C05BC64E119BED6076818FABC8CDD93F3255693E14EFC1A740A5D63A5E847FFE87BAB1DDE0506E1762EA61EFA9F9756151ECCCADD91B98A961A901A2D8B01ABDDD29EC804E8C8D28214BBA26048F924CA66316696E51A49D02FF034D20E44914B1115339CAD3819E0CB1640F0084886FEDDE5E28C29DC48ED30A8C3D789734338F5A9DF42584326E536FD1CF30BC85B8DCBD6120D127C98FE4B3614074F13C2CA4854E6D794156C185C40EB3DA7619CE96ADAF0941BD5499848B034C2B11DFECC0BDFA81C594241F759EF53FC7CDE7F2DE4F23CF81A5A0B7D62E31DABB9198D40307F7824DD130B7D1B80E9B6D322FEEDB5ACE34944F0BFB7D016762A9B2E173BFDD69303766AFBAB45FAB75D05430B4A3515858C4B7F04E23414E4AD03842CB0A20D8FF4B59B7C852BA9A5BE982A8ADA5CB70C36CE2A4D2C31A7015C9F3275E43D192C1B2924424088907A057DA7F2D32A2149922AB2E33F2147D637A3508911CB3FEA5E1AAB4525BACF27B6DD7A3E0AFA978FC3A39DE8882FB22688C3CCC92B6E69ACB0BBF575AB3368E51A2F6A20C414C6F146727CC0045F29061E695D29F7C030CE6929EB3AD11A5CBD0CDEE37347869A3}]. diff --git a/lib/ssh/test/ssh_to_openssh_SUITE.erl b/lib/ssh/test/ssh_to_openssh_SUITE.erl index 687e6efaf3..7eda009552 100644 --- a/lib/ssh/test/ssh_to_openssh_SUITE.erl +++ b/lib/ssh/test/ssh_to_openssh_SUITE.erl @@ -333,7 +333,7 @@ erlang_client_openssh_server_publickey_rsa(Config) when is_list(Config) -> [{_,_, not_encrypted}] -> ConnectionRef = ssh_test_lib:connect(?SSH_DEFAULT_PORT, - [{public_key_alg, ssh_rsa}, + [{pref_public_key_algs, ['ssh-rsa','ssh-dss']}, {user_interaction, false}, silently_accept_hosts]), {ok, Channel} = @@ -354,7 +354,7 @@ erlang_client_openssh_server_publickey_dsa() -> erlang_client_openssh_server_publickey_dsa(Config) when is_list(Config) -> ConnectionRef = ssh_test_lib:connect(?SSH_DEFAULT_PORT, - [{public_key_alg, ssh_dsa}, + [{pref_public_key_algs, ['ssh-dss','ssh-rsa']}, {user_interaction, false}, silently_accept_hosts]), {ok, Channel} = diff --git a/lib/ssl/doc/src/ssl.xml b/lib/ssl/doc/src/ssl.xml index 916b41742e..91c590c247 100644 --- a/lib/ssl/doc/src/ssl.xml +++ b/lib/ssl/doc/src/ssl.xml @@ -935,13 +935,14 @@ fun(srp, Username :: string(), UserState :: term()) -> <fsummary>Returns all the connection information. </fsummary> <type> - <v>Item = protocol | cipher_suite | sni_hostname | ecc | atom()</v> + <v>Item = protocol | cipher_suite | sni_hostname | ecc | session_id | atom()</v> <d>Meaningful atoms, not specified above, are the ssl option names.</d> <v>Result = [{Item::atom(), Value::term()}]</v> <v>Reason = term()</v> </type> - <desc><p>Returns all relevant information about the connection, ssl options that - are undefined will be filtered out.</p> + <desc><p>Returns the most relevant information about the connection, ssl options that + are undefined will be filtered out. Note that values that affect the security of the + connection will only be returned if explicitly requested by connection_information/2.</p> </desc> </func> @@ -952,8 +953,10 @@ fun(srp, Username :: string(), UserState :: term()) -> </fsummary> <type> <v>Items = [Item]</v> - <v>Item = protocol | cipher_suite | sni_hostname | atom()</v> - <d>Meaningful atoms, not specified above, are the ssl option names.</d> + <v>Item = protocol | cipher_suite | sni_hostname | ecc | session_id | client_random + | server_random | master_secret | atom()</v> + <d>Note that client_random, server_random and master_secret are values + that affect the security of connection. Meaningful atoms, not specified above, are the ssl option names.</d> <v>Result = [{Item::atom(), Value::term()}]</v> <v>Reason = term()</v> </type> diff --git a/lib/ssl/src/dtls_handshake.erl b/lib/ssl/src/dtls_handshake.erl index fd1f9698fe..4c525fae1b 100644 --- a/lib/ssl/src/dtls_handshake.erl +++ b/lib/ssl/src/dtls_handshake.erl @@ -455,7 +455,7 @@ merge_fragments(#handshake_fragment{ fragment_offset = PreviousOffSet, fragment_length = CurrentLen}) when CurrentLen < PreviousLen -> Previous; -%% Next fragment +%% Next fragment, might be overlapping merge_fragments(#handshake_fragment{ fragment_offset = PreviousOffSet, fragment_length = PreviousLen, @@ -464,10 +464,28 @@ merge_fragments(#handshake_fragment{ #handshake_fragment{ fragment_offset = CurrentOffSet, fragment_length = CurrentLen, - fragment = CurrentData}) when PreviousOffSet + PreviousLen == CurrentOffSet-> - Previous#handshake_fragment{ - fragment_length = PreviousLen + CurrentLen, - fragment = <<PreviousData/binary, CurrentData/binary>>}; + fragment = CurrentData}) + when PreviousOffSet + PreviousLen >= CurrentOffSet andalso + PreviousOffSet + PreviousLen < CurrentOffSet + CurrentLen -> + CurrentStart = PreviousOffSet + PreviousLen - CurrentOffSet, + <<_:CurrentStart/bytes, Data/binary>> = CurrentData, + Previous#handshake_fragment{ + fragment_length = PreviousLen + CurrentLen - CurrentStart, + fragment = <<PreviousData/binary, Data/binary>>}; +%% already fully contained fragment +merge_fragments(#handshake_fragment{ + fragment_offset = PreviousOffSet, + fragment_length = PreviousLen, + fragment = PreviousData + } = Previous, + #handshake_fragment{ + fragment_offset = CurrentOffSet, + fragment_length = CurrentLen, + fragment = CurrentData}) + when PreviousOffSet + PreviousLen >= CurrentOffSet andalso + PreviousOffSet + PreviousLen >= CurrentOffSet + CurrentLen -> + Previous; + %% No merge there is a gap merge_fragments(Previous, Current) -> [Previous, Current]. diff --git a/lib/ssl/src/ssl.erl b/lib/ssl/src/ssl.erl index 45fc29723f..b3d08bdfbe 100644 --- a/lib/ssl/src/ssl.erl +++ b/lib/ssl/src/ssl.erl @@ -38,16 +38,13 @@ getopts/2, setopts/2, getstat/1, getstat/2 ]). %% SSL/TLS protocol handling --export([cipher_suites/0, cipher_suites/1, eccs/0, eccs/1, - connection_info/1, versions/0, session_info/1, format_error/1, - renegotiate/1, prf/5, negotiated_protocol/1, negotiated_next_protocol/1, + +-export([cipher_suites/0, cipher_suites/1, eccs/0, eccs/1, versions/0, + format_error/1, renegotiate/1, prf/5, negotiated_protocol/1, connection_information/1, connection_information/2]). %% Misc -export([handle_options/2, tls_version/1]). --deprecated({negotiated_next_protocol, 1, next_major_release}). --deprecated({connection_info, 1, next_major_release}). - -include("ssl_api.hrl"). -include("ssl_internal.hrl"). -include("ssl_record.hrl"). @@ -307,7 +304,7 @@ controlling_process(#sslsocket{pid = {Listen, %% Description: Return SSL information for the connection %%-------------------------------------------------------------------- connection_information(#sslsocket{pid = Pid}) when is_pid(Pid) -> - case ssl_connection:connection_information(Pid) of + case ssl_connection:connection_information(Pid, false) of {ok, Info} -> {ok, [Item || Item = {_Key, Value} <- Info, Value =/= undefined]}; Error -> @@ -323,8 +320,8 @@ connection_information(#sslsocket{pid = {udp,_}}) -> %% %% Description: Return SSL information for the connection %%-------------------------------------------------------------------- -connection_information(#sslsocket{} = SSLSocket, Items) -> - case connection_information(SSLSocket) of +connection_information(#sslsocket{pid = Pid}, Items) when is_pid(Pid) -> + case ssl_connection:connection_information(Pid, include_security_info(Items)) of {ok, Info} -> {ok, [Item || Item = {Key, Value} <- Info, lists:member(Key, Items), Value =/= undefined]}; @@ -333,21 +330,6 @@ connection_information(#sslsocket{} = SSLSocket, Items) -> end. %%-------------------------------------------------------------------- -%% Deprecated --spec connection_info(#sslsocket{}) -> {ok, {tls_record:tls_atom_version(), ssl_cipher:erl_cipher_suite()}} | - {error, reason()}. -%% -%% Description: Returns ssl protocol and cipher used for the connection -%%-------------------------------------------------------------------- -connection_info(#sslsocket{} = SSLSocket) -> - case connection_information(SSLSocket) of - {ok, Result} -> - {ok, {proplists:get_value(protocol, Result), proplists:get_value(cipher_suite, Result)}}; - Error -> - Error - end. - -%%-------------------------------------------------------------------- -spec peername(#sslsocket{}) -> {ok, {inet:ip_address(), inet:port_number()}} | {error, reason()}. %% %% Description: same as inet:peername/1. @@ -392,20 +374,6 @@ negotiated_protocol(#sslsocket{pid = Pid}) -> ssl_connection:negotiated_protocol(Pid). %%-------------------------------------------------------------------- --spec negotiated_next_protocol(#sslsocket{}) -> {ok, binary()} | {error, reason()}. -%% -%% Description: Returns the next protocol that has been negotiated. If no -%% protocol has been negotiated will return {error, next_protocol_not_negotiated} -%%-------------------------------------------------------------------- -negotiated_next_protocol(Socket) -> - case negotiated_protocol(Socket) of - {error, protocol_not_negotiated} -> - {error, next_protocol_not_negotiated}; - Res -> - Res - end. - -%%-------------------------------------------------------------------- -spec cipher_suites() -> [ssl_cipher:erl_cipher_suite()] | [string()]. %%-------------------------------------------------------------------- cipher_suites() -> @@ -555,19 +523,6 @@ sockname(#sslsocket{pid = Pid, fd = {Transport, Socket, _, _}}) when is_pid(Pid) tls_socket:sockname(Transport, Socket). %%--------------------------------------------------------------- --spec session_info(#sslsocket{}) -> {ok, list()} | {error, reason()}. -%% -%% Description: Returns list of session info currently [{session_id, session_id(), -%% {cipher_suite, cipher_suite()}] -%%-------------------------------------------------------------------- -session_info(#sslsocket{pid = Pid}) when is_pid(Pid) -> - ssl_connection:session_info(Pid); -session_info(#sslsocket{pid = {udp,_}}) -> - {error, enotconn}; -session_info(#sslsocket{pid = {Listen,_}}) when is_port(Listen) -> - {error, enotconn}. - -%%--------------------------------------------------------------- -spec versions() -> [{ssl_app, string()} | {supported, [tls_record:tls_atom_version()]} | {available, [tls_record:tls_atom_version()]}]. %% @@ -1480,3 +1435,13 @@ default_cb_info(tls) -> {gen_tcp, tcp, tcp_closed, tcp_error}; default_cb_info(dtls) -> {gen_udp, udp, udp_closed, udp_error}. + +include_security_info([]) -> + false; +include_security_info([Item | Items]) -> + case lists:member(Item, [client_random, server_random, master_secret]) of + true -> + true; + false -> + include_security_info(Items) + end. diff --git a/lib/ssl/src/ssl_connection.erl b/lib/ssl/src/ssl_connection.erl index ea139ac4b1..df9b9e8a63 100644 --- a/lib/ssl/src/ssl_connection.erl +++ b/lib/ssl/src/ssl_connection.erl @@ -42,9 +42,9 @@ %% User Events -export([send/2, recv/3, close/2, shutdown/2, - new_user/2, get_opts/2, set_opts/2, session_info/1, + new_user/2, get_opts/2, set_opts/2, peer_certificate/1, renegotiation/1, negotiated_protocol/1, prf/5, - connection_information/1, handle_common_event/5 + connection_information/2, handle_common_event/5 ]). %% General gen_statem state functions with extra callback argument @@ -185,12 +185,12 @@ recv(Pid, Length, Timeout) -> call(Pid, {recv, Length, Timeout}). %%-------------------------------------------------------------------- --spec connection_information(pid()) -> {ok, list()} | {error, reason()}. +-spec connection_information(pid(), boolean()) -> {ok, list()} | {error, reason()}. %% %% Description: Get the SNI hostname %%-------------------------------------------------------------------- -connection_information(Pid) when is_pid(Pid) -> - call(Pid, connection_information). +connection_information(Pid, IncludeSecrityInfo) when is_pid(Pid) -> + call(Pid, {connection_information, IncludeSecrityInfo}). %%-------------------------------------------------------------------- -spec close(pid(), {close, Timeout::integer() | @@ -247,14 +247,6 @@ set_opts(ConnectionPid, Options) -> call(ConnectionPid, {set_opts, Options}). %%-------------------------------------------------------------------- --spec session_info(pid()) -> {ok, list()} | {error, reason()}. -%% -%% Description: Returns info about the ssl session -%%-------------------------------------------------------------------- -session_info(ConnectionPid) -> - call(ConnectionPid, session_info). - -%%-------------------------------------------------------------------- -spec peer_certificate(pid()) -> {ok, binary()| undefined} | {error, reason()}. %% %% Description: Returns the peer cert @@ -775,14 +767,12 @@ connection({call, From}, renegotiate, #state{protocol_cb = Connection} = State, connection({call, From}, peer_certificate, #state{session = #session{peer_certificate = Cert}} = State, _) -> hibernate_after(connection, State, [{reply, From, {ok, Cert}}]); -connection({call, From}, connection_information, State, _) -> +connection({call, From}, {connection_information, true}, State, _) -> + Info = connection_info(State) ++ security_info(State), + hibernate_after(connection, State, [{reply, From, {ok, Info}}]); +connection({call, From}, {connection_information, false}, State, _) -> Info = connection_info(State), hibernate_after(connection, State, [{reply, From, {ok, Info}}]); -connection({call, From}, session_info, #state{session = #session{session_id = Id, - cipher_suite = Suite}} = State, _) -> - SessionInfo = [{session_id, Id}, - {cipher_suite, ssl_cipher:erl_suite_definition(Suite)}], - hibernate_after(connection, State, [{reply, From, SessionInfo}]); connection({call, From}, negotiated_protocol, #state{negotiated_protocol = undefined} = State, _) -> hibernate_after(connection, State, [{reply, From, {error, protocol_not_negotiated}}]); @@ -1195,7 +1185,8 @@ handle_alert(#alert{level = ?WARNING} = Alert, StateName, %%% Internal functions %%-------------------------------------------------------------------- connection_info(#state{sni_hostname = SNIHostname, - session = #session{cipher_suite = CipherSuite, ecc = ECCCurve}, + session = #session{session_id = SessionId, + cipher_suite = CipherSuite, ecc = ECCCurve}, protocol_cb = Connection, negotiated_version = {_,_} = Version, ssl_options = Opts}) -> @@ -1210,9 +1201,18 @@ connection_info(#state{sni_hostname = SNIHostname, [] end, [{protocol, RecordCB:protocol_version(Version)}, + {session_id, SessionId}, {cipher_suite, CipherSuiteDef}, {sni_hostname, SNIHostname} | CurveInfo] ++ ssl_options_list(Opts). +security_info(#state{connection_states = ConnectionStates}) -> + #{security_parameters := + #security_parameters{client_random = ClientRand, + server_random = ServerRand, + master_secret = MasterSecret}} = + ssl_record:current_connection_state(ConnectionStates, read), + [{client_random, ClientRand}, {server_random, ServerRand}, {master_secret, MasterSecret}]. + do_server_hello(Type, #hello_extensions{next_protocol_negotiation = NextProtocols} = ServerHelloExt, #state{negotiated_version = Version, diff --git a/lib/ssl/test/Makefile b/lib/ssl/test/Makefile index a2eb4ce449..55d45c98f6 100644 --- a/lib/ssl/test/Makefile +++ b/lib/ssl/test/Makefile @@ -56,7 +56,8 @@ MODULES = \ ssl_upgrade_SUITE\ ssl_sni_SUITE \ make_certs\ - erl_make_certs + erl_make_certs\ + x509_test ERL_FILES = $(MODULES:%=%.erl) diff --git a/lib/ssl/test/erl_make_certs.erl b/lib/ssl/test/erl_make_certs.erl index a6657be995..af217efc11 100644 --- a/lib/ssl/test/erl_make_certs.erl +++ b/lib/ssl/test/erl_make_certs.erl @@ -179,7 +179,7 @@ make_tbs(SubjectKey, Opts) -> subject(proplists:get_value(subject, Opts),false) end, - {#'OTPTBSCertificate'{serialNumber = trunc(random:uniform()*100000000)*10000 + 1, + {#'OTPTBSCertificate'{serialNumber = trunc(rand:uniform()*100000000)*10000 + 1, signature = SignAlgo, issuer = Issuer, validity = validity(Opts), diff --git a/lib/ssl/test/ssl_basic_SUITE.erl b/lib/ssl/test/ssl_basic_SUITE.erl index 86426bdb60..4eabe544d7 100644 --- a/lib/ssl/test/ssl_basic_SUITE.erl +++ b/lib/ssl/test/ssl_basic_SUITE.erl @@ -148,6 +148,7 @@ options_tests_tls() -> api_tests() -> [connection_info, + secret_connection_info, connection_information, peercert, peercert_with_client_cert, @@ -611,7 +612,7 @@ prf(Config) when is_list(Config) -> %%-------------------------------------------------------------------- connection_info() -> - [{doc,"Test the API function ssl:connection_information/1"}]. + [{doc,"Test the API function ssl:connection_information/2"}]. connection_info(Config) when is_list(Config) -> ClientOpts = ssl_test_lib:ssl_options(client_verification_opts, Config), ServerOpts = ssl_test_lib:ssl_options(server_verification_opts, Config), @@ -645,6 +646,38 @@ connection_info(Config) when is_list(Config) -> %%-------------------------------------------------------------------- +secret_connection_info() -> + [{doc,"Test the API function ssl:connection_information/2"}]. +secret_connection_info(Config) when is_list(Config) -> + ClientOpts = ssl_test_lib:ssl_options(client_verification_opts, Config), + ServerOpts = ssl_test_lib:ssl_options(server_verification_opts, Config), + {ClientNode, ServerNode, Hostname} = ssl_test_lib:run_where(Config), + + Server = ssl_test_lib:start_server([{node, ServerNode}, {port, 0}, + {from, self()}, + {mfa, {?MODULE, secret_connection_info_result, []}}, + {options, ServerOpts}]), + + Port = ssl_test_lib:inet_port(Server), + Client = ssl_test_lib:start_client([{node, ClientNode}, {port, Port}, + {host, Hostname}, + {from, self()}, + {mfa, {?MODULE, secret_connection_info_result, []}}, + {options, ClientOpts}]), + + 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), + + ssl_test_lib:close(Server), + ssl_test_lib:close(Client). + + +%%-------------------------------------------------------------------- + connection_information() -> [{doc,"Test the API function ssl:connection_information/1"}]. connection_information(Config) when is_list(Config) -> @@ -3414,7 +3447,6 @@ listen_socket(Config) -> {error, enotconn} = ssl:connection_information(ListenSocket), {error, enotconn} = ssl:peername(ListenSocket), {error, enotconn} = ssl:peercert(ListenSocket), - {error, enotconn} = ssl:session_info(ListenSocket), {error, enotconn} = ssl:renegotiate(ListenSocket), {error, enotconn} = ssl:prf(ListenSocket, 'master_secret', <<"Label">>, client_random, 256), {error, enotconn} = ssl:shutdown(ListenSocket, read_write), @@ -4638,6 +4670,11 @@ version_info_result(Socket) -> {ok, [{version, Version}]} = ssl:connection_information(Socket, [version]), {ok, Version}. +secret_connection_info_result(Socket) -> + {ok, [{client_random, ClientRand}, {server_random, ServerRand}, {master_secret, MasterSecret}]} + = ssl:connection_information(Socket, [client_random, server_random, master_secret]), + is_binary(ClientRand) andalso is_binary(ServerRand) andalso is_binary(MasterSecret). + connect_dist_s(S) -> Msg = term_to_binary({erlang,term}), ok = ssl:send(S, Msg). diff --git a/lib/ssl/test/ssl_packet_SUITE.erl b/lib/ssl/test/ssl_packet_SUITE.erl index 3446a566c4..c8caa9c11a 100644 --- a/lib/ssl/test/ssl_packet_SUITE.erl +++ b/lib/ssl/test/ssl_packet_SUITE.erl @@ -1973,14 +1973,14 @@ passive_recv_packet(Socket, _, 0) -> {error, timeout} = ssl:recv(Socket, 0, 500), ok; Other -> - {other, Other, ssl:session_info(Socket), 0} + {other, Other, ssl:connection_information(Socket, [session_id, cipher_suite]), 0} end; passive_recv_packet(Socket, Data, N) -> case ssl:recv(Socket, 0) of {ok, Data} -> passive_recv_packet(Socket, Data, N-1); Other -> - {other, Other, ssl:session_info(Socket), N} + {other, Other, ssl:connection_information(Socket, [session_id, cipher_suite]), N} end. send(Socket,_, 0) -> @@ -2032,7 +2032,7 @@ active_once_packet(Socket,_, 0) -> {ssl, Socket, []} -> ok; {ssl, Socket, Other} -> - {other, Other, ssl:session_info(Socket), 0} + {other, Other, ssl:connection_information(Socket, [session_id, cipher_suite]), 0} end; active_once_packet(Socket, Data, N) -> receive @@ -2077,7 +2077,7 @@ active_packet(Socket, _, 0) -> {ssl, Socket, []} -> ok; Other -> - {other, Other, ssl:session_info(Socket), 0} + {other, Other, ssl:connection_information(Socket, [session_id, cipher_suite]), 0} end; active_packet(Socket, Data, N) -> receive @@ -2089,7 +2089,7 @@ active_packet(Socket, Data, N) -> {ssl, Socket, Data} -> active_packet(Socket, Data, N -1); Other -> - {other, Other, ssl:session_info(Socket),N} + {other, Other, ssl:connection_information(Socket, [session_id, cipher_suite]),N} end. assert_packet_opt(Socket, Type) -> diff --git a/lib/ssl/test/ssl_test_lib.erl b/lib/ssl/test/ssl_test_lib.erl index 4b740c79db..ae378037dd 100644 --- a/lib/ssl/test/ssl_test_lib.erl +++ b/lib/ssl/test/ssl_test_lib.erl @@ -488,23 +488,32 @@ make_dsa_cert(Config) -> make_ecdsa_cert(Config) -> CryptoSupport = crypto:supports(), case proplists:get_bool(ecdsa, proplists:get_value(public_keys, CryptoSupport)) of - true -> - {ServerCaCertFile, ServerCertFile, ServerKeyFile} = - make_cert_files("server", Config, ec, ec, "", [{digest, appropriate_sha(CryptoSupport)}]), - {ClientCaCertFile, ClientCertFile, ClientKeyFile} = - make_cert_files("client", Config, ec, ec, "", [{digest, appropriate_sha(CryptoSupport)}]), - [{server_ecdsa_opts, [{ssl_imp, new},{reuseaddr, true}, - {cacertfile, ServerCaCertFile}, - {certfile, ServerCertFile}, {keyfile, ServerKeyFile}]}, - {server_ecdsa_verify_opts, [{ssl_imp, new},{reuseaddr, true}, - {cacertfile, ClientCaCertFile}, - {certfile, ServerCertFile}, {keyfile, ServerKeyFile}, - {verify, verify_peer}]}, - {client_ecdsa_opts, [{ssl_imp, new}, - {cacertfile, ClientCaCertFile}, - {certfile, ClientCertFile}, {keyfile, ClientKeyFile}]} + true -> + %% {ServerCaCertFile, ServerCertFile, ServerKeyFile} = + %% make_cert_files("server", Config, ec, ec, "", [{digest, appropriate_sha(CryptoSupport)}]), + %% {ClientCaCertFile, ClientCertFile, ClientKeyFile} = + %% make_cert_files("client", Config, ec, ec, "", [{digest, appropriate_sha(CryptoSupport)}]), + CertFileBase = filename:join([proplists:get_value(priv_dir, Config), "ecdsa_cert.pem"]), + KeyFileBase = filename:join([proplists:get_value(priv_dir, Config), "ecdsa_key.pem"]), + CaCertFileBase = filename:join([proplists:get_value(priv_dir, Config), "ecdsa_cacerts.pem"]), + CurveOid = hd(tls_v1:ecc_curves(0)), + GenCertData = x509_test:gen_test_certs([{server_key_gen, {namedCurve, CurveOid}}, + {client_key_gen, {namedCurve, CurveOid}}, + {server_key_gen_chain, [{namedCurve, CurveOid}, + {namedCurve, CurveOid}]}, + {client_key_gen_chain, [{namedCurve, CurveOid}, + {namedCurve, CurveOid}]}, + {digest, appropriate_sha(CryptoSupport)}]), + [{server_config, ServerConf}, + {client_config, ClientConf}] = + x509_test:gen_pem_config_files(GenCertData, CertFileBase, KeyFileBase, CaCertFileBase), + [{server_ecdsa_opts, [{ssl_imp, new},{reuseaddr, true} | ServerConf]}, + + {server_ecdsa_verify_opts, [{ssl_imp, new}, {reuseaddr, true}, + {verify, verify_peer} | ServerConf]}, + {client_ecdsa_opts, [{ssl_imp, new}, {reuseaddr, true} | ClientConf]} | Config]; - _ -> + false -> Config end. @@ -782,18 +791,18 @@ no_result(_) -> no_result_msg. trigger_renegotiate(Socket, [ErlData, N]) -> - [{session_id, Id} | _ ] = ssl:session_info(Socket), + {ok, [{session_id, Id}]} = ssl:connection_information(Socket, [session_id]), trigger_renegotiate(Socket, ErlData, N, Id). trigger_renegotiate(Socket, _, 0, Id) -> ct:sleep(1000), - case ssl:session_info(Socket) of - [{session_id, Id} | _ ] -> + case ssl:connection_information(Socket, [session_id]) of + {ok, [{session_id, Id}]} -> fail_session_not_renegotiated; %% Tests that uses this function will not reuse %% sessions so if we get a new session id the %% renegotiation has succeeded. - [{session_id, _} | _ ] -> + {ok, [{session_id, _}]} -> ok; {error, closed} -> fail_session_fatal_alert_during_renegotiation; @@ -998,8 +1007,8 @@ cipher_result(Socket, Result) -> end. session_info_result(Socket) -> - ssl:session_info(Socket). - + {ok, Info} = ssl:connection_information(Socket, [session_id, cipher_suite]), + Info. public_key(#'PrivateKeyInfo'{privateKeyAlgorithm = #'PrivateKeyInfo_privateKeyAlgorithm'{algorithm = ?rsaEncryption}, diff --git a/lib/ssl/test/x509_test.erl b/lib/ssl/test/x509_test.erl new file mode 100644 index 0000000000..5cd5c8eca7 --- /dev/null +++ b/lib/ssl/test/x509_test.erl @@ -0,0 +1,310 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2017-2017. 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(x509_test). + +-include_lib("public_key/include/public_key.hrl"). + +-export([gen_test_certs/1, gen_pem_config_files/4]). + +gen_test_certs(Opts) -> + SRootKey = gen_key(proplists:get_value(server_key_gen, Opts)), + CRootKey = gen_key(proplists:get_value(client_key_gen, Opts)), + ServerRoot = root_cert("server", SRootKey, Opts), + ClientRoot = root_cert("client", CRootKey, Opts), + [{ServerCert, ServerKey} | ServerCAsKeys] = config(server, ServerRoot, SRootKey, Opts), + [{ClientCert, ClientKey} | ClientCAsKeys] = config(client, ClientRoot, CRootKey, Opts), + ServerCAs = ca_config(ClientRoot, ServerCAsKeys), + ClientCAs = ca_config(ServerRoot, ClientCAsKeys), + [{server_config, [{cert, ServerCert}, {key, ServerKey}, {cacerts, ServerCAs}]}, + {client_config, [{cert, ClientCert}, {key, ClientKey}, {cacerts, ClientCAs}]}]. + +gen_pem_config_files(GenCertData, CertFileBase, KeyFileBase, CAFileBase) -> + ServerConf = proplists:get_value(server_config, GenCertData), + ClientConf = proplists:get_value(client_config, GenCertData), + + ServerCaCertFile = filename:join("server_", CAFileBase), + ServerCertFile = filename:join("server_", CertFileBase), + ServerKeyFile = filename:join("server_", KeyFileBase), + + ClientCaCertFile = filename:join("client_", CAFileBase), + ClientCertFile = filename:join("client_", CertFileBase), + ClientKeyFile = filename:join("client_", KeyFileBase), + + do_gen_pem_config_files(ServerConf, + ServerCertFile, + ServerKeyFile, + ServerCaCertFile), + do_gen_pem_config_files(ClientConf, + ClientCertFile, + ClientKeyFile, + ClientCaCertFile), + [{server_config, [{certfile, ServerCertFile}, {keyfile, ServerKeyFile}, {cacertfile, ServerCaCertFile}]}, + {client_config, [{certfile, ClientCertFile}, {keyfile, ClientKeyFile}, {cacertfile, ClientCaCertFile}]}]. + + +do_gen_pem_config_files(Config, CertFile, KeyFile, CAFile) -> + CAs = proplists:get_value(cacerts, Config), + Cert = proplists:get_value(cert, Config), + Key = proplists:get_value(key, Config), + der_to_pem(CertFile, [cert_entry(Cert)]), + der_to_pem(KeyFile, [key_entry(Key)]), + der_to_pem(CAFile, ca_entries(CAs)). + +cert_entry(Cert) -> + {'Certificate', Cert, not_encrypted}. + +key_entry(Key = #'RSAPrivateKey'{}) -> + Der = public_key:der_encode('RSAPrivateKey', Key), + {'RSAPrivateKey', Der, not_encrypted}; +key_entry(Key = #'DSAPrivateKey'{}) -> + Der = public_key:der_encode('DSAPrivateKey', Key), + {'DSAPrivateKey', Der, not_encrypted}; +key_entry(Key = #'ECPrivateKey'{}) -> + Der = public_key:der_encode('ECPrivateKey', Key), + {'ECPrivateKey', Der, not_encrypted}. + +ca_entries(CAs) -> + [{'Certificate', CACert, not_encrypted} || CACert <- CAs]. + +gen_key(KeyGen) -> + case is_key(KeyGen) of + true -> + KeyGen; + false -> + public_key:generate_key(KeyGen) + end. + +root_cert(Role, PrivKey, Opts) -> + TBS = cert_template(), + Issuer = issuer("root", Role, " ROOT CA"), + OTPTBS = TBS#'OTPTBSCertificate'{ + signature = sign_algorithm(PrivKey, Opts), + issuer = Issuer, + validity = validity(Opts), + subject = Issuer, + subjectPublicKeyInfo = public_key(PrivKey), + extensions = extensions(Opts) + }, + public_key:pkix_sign(OTPTBS, PrivKey). + +config(Role, Root, Key, Opts) -> + KeyGenOpt = list_to_atom(atom_to_list(Role) ++ "key_gen_chain"), + KeyGens = proplists:get_value(KeyGenOpt, Opts, [{namedCurve, hd(tls_v1:ecc_curves(0))}, + {namedCurve, hd(tls_v1:ecc_curves(0))}]), + Keys = lists:map(fun gen_key/1, KeyGens), + cert_chain(Role, Root, Key, Opts, Keys). + +cert_template() -> + #'OTPTBSCertificate'{ + version = v3, + serialNumber = trunc(rand:uniform()*100000000)*10000 + 1, + issuerUniqueID = asn1_NOVALUE, + subjectUniqueID = asn1_NOVALUE + }. + +issuer(Contact, Role, Name) -> + subject(Contact, Role ++ Name). + +subject(Contact, Name) -> + Opts = [{email, Contact ++ "@erlang.org"}, + {name, Name}, + {city, "Stockholm"}, + {country, "SE"}, + {org, "erlang"}, + {org_unit, "automated testing"}], + subject(Opts). + +subject(SubjectOpts) when is_list(SubjectOpts) -> + Encode = fun(Opt) -> + {Type,Value} = subject_enc(Opt), + [#'AttributeTypeAndValue'{type=Type, value=Value}] + end, + {rdnSequence, [Encode(Opt) || Opt <- SubjectOpts]}. + +subject_enc({name, Name}) -> + {?'id-at-commonName', {printableString, Name}}; +subject_enc({email, Email}) -> + {?'id-emailAddress', Email}; +subject_enc({city, City}) -> + {?'id-at-localityName', {printableString, City}}; +subject_enc({state, State}) -> + {?'id-at-stateOrProvinceName', {printableString, State}}; +subject_enc({org, Org}) -> + {?'id-at-organizationName', {printableString, Org}}; +subject_enc({org_unit, OrgUnit}) -> + {?'id-at-organizationalUnitName', {printableString, OrgUnit}}; +subject_enc({country, Country}) -> + {?'id-at-countryName', Country}; +subject_enc({serial, Serial}) -> + {?'id-at-serialNumber', Serial}; +subject_enc({title, Title}) -> + {?'id-at-title', {printableString, Title}}; +subject_enc({dnQualifer, DnQ}) -> + {?'id-at-dnQualifier', DnQ}; +subject_enc(Other) -> + Other. + +validity(Opts) -> + DefFrom0 = calendar:gregorian_days_to_date(calendar:date_to_gregorian_days(date())-1), + DefTo0 = calendar:gregorian_days_to_date(calendar:date_to_gregorian_days(date())+7), + {DefFrom, DefTo} = proplists:get_value(validity, Opts, {DefFrom0, DefTo0}), + Format = fun({Y,M,D}) -> + lists:flatten(io_lib:format("~w~2..0w~2..0w000000Z",[Y,M,D])) + end, + #'Validity'{notBefore={generalTime, Format(DefFrom)}, + notAfter ={generalTime, Format(DefTo)}}. + +extensions(Opts) -> + case proplists:get_value(extensions, Opts, []) of + false -> + asn1_NOVALUE; + Exts -> + lists:flatten([extension(Ext) || Ext <- default_extensions(Exts)]) + end. + +default_extensions(Exts) -> + Def = [{key_usage,undefined}, + {subject_altname, undefined}, + {issuer_altname, undefined}, + {basic_constraints, default}, + {name_constraints, undefined}, + {policy_constraints, undefined}, + {ext_key_usage, undefined}, + {inhibit_any, undefined}, + {auth_key_id, undefined}, + {subject_key_id, undefined}, + {policy_mapping, undefined}], + Filter = fun({Key, _}, D) -> + lists:keydelete(Key, 1, D) + end, + Exts ++ lists:foldl(Filter, Def, Exts). + +extension({_, undefined}) -> + []; +extension({basic_constraints, Data}) -> + case Data of + default -> + #'Extension'{extnID = ?'id-ce-basicConstraints', + extnValue = #'BasicConstraints'{cA=true}, + critical=true}; + false -> + []; + Len when is_integer(Len) -> + #'Extension'{extnID = ?'id-ce-basicConstraints', + extnValue = #'BasicConstraints'{cA=true, pathLenConstraint = Len}, + critical = true}; + _ -> + #'Extension'{extnID = ?'id-ce-basicConstraints', + extnValue = Data} + end; +extension({Id, Data, Critical}) -> + #'Extension'{extnID = Id, extnValue = Data, critical = Critical}. + +public_key(#'RSAPrivateKey'{modulus=N, publicExponent=E}) -> + Public = #'RSAPublicKey'{modulus=N, publicExponent=E}, + Algo = #'PublicKeyAlgorithm'{algorithm= ?rsaEncryption, parameters='NULL'}, + #'OTPSubjectPublicKeyInfo'{algorithm = Algo, + subjectPublicKey = Public}; +public_key(#'DSAPrivateKey'{p=P, q=Q, g=G, y=Y}) -> + Algo = #'PublicKeyAlgorithm'{algorithm= ?'id-dsa', + parameters={params, #'Dss-Parms'{p=P, q=Q, g=G}}}, + #'OTPSubjectPublicKeyInfo'{algorithm = Algo, subjectPublicKey = Y}; +public_key(#'ECPrivateKey'{version = _Version, + privateKey = _PrivKey, + parameters = Params, + publicKey = PubKey}) -> + Algo = #'PublicKeyAlgorithm'{algorithm= ?'id-ecPublicKey', parameters=Params}, + #'OTPSubjectPublicKeyInfo'{algorithm = Algo, + subjectPublicKey = #'ECPoint'{point = PubKey}}. + +sign_algorithm(#'RSAPrivateKey'{}, Opts) -> + Type = rsa_digest_oid(proplists:get_value(digest, Opts, sha1)), + #'SignatureAlgorithm'{algorithm = Type, + parameters = 'NULL'}; +sign_algorithm(#'DSAPrivateKey'{p=P, q=Q, g=G}, _Opts) -> + #'SignatureAlgorithm'{algorithm = ?'id-dsa-with-sha1', + parameters = {params,#'Dss-Parms'{p=P, q=Q, g=G}}}; +sign_algorithm(#'ECPrivateKey'{parameters = Parms}, Opts) -> + Type = ecdsa_digest_oid(proplists:get_value(digest, Opts, sha1)), + #'SignatureAlgorithm'{algorithm = Type, + parameters = Parms}. + +rsa_digest_oid(sha1) -> + ?'sha1WithRSAEncryption'; +rsa_digest_oid(sha512) -> + ?'sha512WithRSAEncryption'; +rsa_digest_oid(sha384) -> + ?'sha384WithRSAEncryption'; +rsa_digest_oid(sha256) -> + ?'sha256WithRSAEncryption'; +rsa_digest_oid(md5) -> + ?'md5WithRSAEncryption'. + +ecdsa_digest_oid(sha1) -> + ?'ecdsa-with-SHA1'; +ecdsa_digest_oid(sha512) -> + ?'ecdsa-with-SHA512'; +ecdsa_digest_oid(sha384) -> + ?'ecdsa-with-SHA384'; +ecdsa_digest_oid(sha256) -> + ?'ecdsa-with-SHA256'. + +ca_config(Root, CAsKeys) -> + [Root | [CA || {CA, _} <- CAsKeys]]. + +cert_chain(Role, Root, RootKey, Opts, Keys) -> + cert_chain(Role, Root, RootKey, Opts, Keys, 0, []). + +cert_chain(Role, IssuerCert, IssuerKey, Opts, [Key], _, Acc) -> + Cert = cert(Role, public_key:pkix_decode_cert(IssuerCert, otp), IssuerKey, Key, "admin", " Peer cert", Opts), + [{Cert, Key}, {IssuerCert, IssuerKey} | Acc]; +cert_chain(Role, IssuerCert, IssuerKey, Opts, [Key | Keys], N, Acc) -> + Cert = cert(Role, public_key:pkix_decode_cert(IssuerCert, otp), IssuerKey, Key, "webadmin", + " Intermidiate CA " ++ integer_to_list(N), Opts), + cert_chain(Role, Cert, Key, Opts, Keys, N+1, [{IssuerCert, IssuerKey} | Acc]). + +cert(Role, #'OTPCertificate'{tbsCertificate = #'OTPTBSCertificate'{subject = Issuer}}, + PrivKey, Key, Contact, Name, Opts) -> + TBS = cert_template(), + OTPTBS = TBS#'OTPTBSCertificate'{ + signature = sign_algorithm(PrivKey, Opts), + issuer = Issuer, + validity = validity(Opts), + subject = subject(Contact, atom_to_list(Role) ++ Name), + subjectPublicKeyInfo = public_key(Key), + extensions = extensions(Opts) + }, + public_key:pkix_sign(OTPTBS, PrivKey). + +is_key(#'DSAPrivateKey'{}) -> + true; +is_key(#'RSAPrivateKey'{}) -> + true; +is_key(#'ECPrivateKey'{}) -> + true; +is_key(_) -> + false. + +der_to_pem(File, Entries) -> + PemBin = public_key:pem_encode(Entries), + file:write_file(File, PemBin). diff --git a/lib/stdlib/doc/src/proplists.xml b/lib/stdlib/doc/src/proplists.xml index fe6b8cc3bf..990d47b313 100644 --- a/lib/stdlib/doc/src/proplists.xml +++ b/lib/stdlib/doc/src/proplists.xml @@ -344,7 +344,7 @@ split([{c, 2}, {e, 1}, a, {c, 3, 4}, d, {b, 5}, b], [a, b, c])</code> with <c>{K2, true}</c>, thus changing the name of the option and simultaneously negating the value specified by <seealso marker="#get_bool/2"> - <c>get_bool(Key, <anno>ListIn</anno></c></seealso>. + <c>get_bool(Key, <anno>ListIn</anno>)</c></seealso>. If the same <c>K1</c> occurs more than once in <c><anno>Negations</anno></c>, only the first occurrence is used.</p> <p>For example, <c>substitute_negations([{no_foo, foo}], L)</c> diff --git a/lib/stdlib/doc/src/unicode_usage.xml b/lib/stdlib/doc/src/unicode_usage.xml index efc8b75075..a8ef8ff5c5 100644 --- a/lib/stdlib/doc/src/unicode_usage.xml +++ b/lib/stdlib/doc/src/unicode_usage.xml @@ -62,6 +62,10 @@ <item><p>In Erlang/OTP 17.0, the encoding default for Erlang source files was switched to UTF-8.</p></item> + + <item><p>In Erlang/OTP 20.0, atoms and function can contain + Unicode characters. Module names are still restricted to + the ISO-Latin-1 range.</p></item> </list> <p>This section outlines the current Unicode support and gives some @@ -339,9 +343,10 @@ <tag>The language</tag> <item> <p>Having the source code in UTF-8 also allows you to write string - literals containing Unicode characters with code points > 255, - although atoms, module names, and function names are restricted to - the ISO Latin-1 range. Binary literals, where you use type + literals, function names, and atoms containing Unicode + characters with code points > 255. + Module names are still restricted to the ISO Latin-1 range. + Binary literals, where you use type <c>/utf8</c>, can also be expressed using Unicode characters > 255. Having module names using characters other than 7-bit ASCII can cause trouble on operating systems with inconsistent file naming schemes, @@ -432,15 +437,17 @@ external_charlist() = maybe_improper_list(char() | external_unicode_binary() | <section> <title>Basic Language Support</title> - <p><marker id="unicode_in_erlang"/>As from Erlang/OTP R16, Erlang source - files can be written in UTF-8 or bytewise (<c>latin1</c>) encoding. For - information about how to state the encoding of an Erlang source file, see - the <seealso marker="stdlib:epp#encoding"><c>epp(3)</c></seealso> module. - Strings and comments can be written using Unicode, but functions must - still be named using characters from the ISO Latin-1 character set, and - atoms are restricted to the same ISO Latin-1 range. These restrictions in - the language are of course independent of the encoding of the source - file.</p> + <p><marker id="unicode_in_erlang"/>As from Erlang/OTP R16, Erlang + source files can be written in UTF-8 or bytewise (<c>latin1</c>) + encoding. For information about how to state the encoding of an + Erlang source file, see the <seealso + marker="stdlib:epp#encoding"><c>epp(3)</c></seealso> module. As + from Erlang/OTP R16, strings and comments can be written using + Unicode. As from Erlang/OTP 20, also atoms and functions can be + written using Unicode. Modules names must still be named using + characters from the ISO Latin-1 character set. (These + restrictions in the language are independent of the encoding of + the source file.)</p> <section> <title>Bit Syntax</title> diff --git a/lib/stdlib/src/erl_lint.erl b/lib/stdlib/src/erl_lint.erl index 0ffca0886f..0789f5dfb7 100644 --- a/lib/stdlib/src/erl_lint.erl +++ b/lib/stdlib/src/erl_lint.erl @@ -156,6 +156,8 @@ format_error(pmod_unsupported) -> "parameterized modules are no longer supported"; %% format_error({redefine_mod_import, M, P}) -> %% io_lib:format("module '~s' already imported from package '~s'", [M, P]); +format_error(non_latin1_module_unsupported) -> + "module names with non-latin1 characters are not supported"; format_error(invalid_call) -> "invalid function call"; @@ -733,9 +735,15 @@ form(Form, #lint{state=State}=St) -> start_state({attribute,Line,module,{_,_}}=Form, St0) -> St1 = add_error(Line, pmod_unsupported, St0), attribute_state(Form, St1#lint{state=attribute}); -start_state({attribute,_,module,M}, St0) -> +start_state({attribute,Line,module,M}, St0) -> St1 = St0#lint{module=M}, - St1#lint{state=attribute}; + St2 = St1#lint{state=attribute}, + case is_non_latin1_name(M) of + true -> + add_error(Line, non_latin1_module_unsupported, St2); + false -> + St2 + end; start_state(Form, St) -> Anno = case Form of {eof, L} -> erl_anno:new(L); @@ -745,6 +753,9 @@ start_state(Form, St) -> St1 = add_error(Anno, undefined_module, St), attribute_state(Form, St1#lint{state=attribute}). +is_non_latin1_name(Name) -> + lists:any(fun(C) -> C > 255 end, atom_to_list(Name)). + %% attribute_state(Form, State) -> %% State' diff --git a/lib/stdlib/src/ets.erl b/lib/stdlib/src/ets.erl index d6fd1e3ea1..90e19e6b9f 100644 --- a/lib/stdlib/src/ets.erl +++ b/lib/stdlib/src/ets.erl @@ -75,10 +75,28 @@ take/2, update_counter/3, update_counter/4, update_element/3]). +%% internal exports +-export([internal_request_all/0]). + -spec all() -> [Tab] when Tab :: tab(). all() -> + receive_all(ets:internal_request_all(), + erlang:system_info(schedulers), + []). + +receive_all(_Ref, 0, All) -> + All; +receive_all(Ref, N, All) -> + receive + {Ref, SchedAll} -> + receive_all(Ref, N-1, SchedAll ++ All) + end. + +-spec internal_request_all() -> reference(). + +internal_request_all() -> erlang:nif_error(undef). -spec delete(Tab) -> true when diff --git a/lib/stdlib/src/otp_internal.erl b/lib/stdlib/src/otp_internal.erl index fda7a2cd8a..d89ff4a624 100644 --- a/lib/stdlib/src/otp_internal.erl +++ b/lib/stdlib/src/otp_internal.erl @@ -55,6 +55,11 @@ obsolete_1(erlang, now, 0) -> obsolete_1(calendar, local_time_to_universal_time, 1) -> {deprecated, {calendar, local_time_to_universal_time_dst, 1}}; +%% *** CRYPTO added in OTP 20 *** + +obsolete_1(crypto, rand_uniform, 2) -> + {deprecated, {rand, uniform, 1}}; + %% *** CRYPTO added in OTP 19 *** obsolete_1(crypto, rand_bytes, 1) -> @@ -63,178 +68,178 @@ obsolete_1(crypto, rand_bytes, 1) -> %% *** CRYPTO added in R16B01 *** obsolete_1(crypto, md4, 1) -> - {deprecated, {crypto, hash, 2}}; + {removed, {crypto, hash, 2}, "20.0"}; obsolete_1(crypto, md5, 1) -> - {deprecated, {crypto, hash, 2}}; + {removed, {crypto, hash, 2}, "20.0"}; obsolete_1(crypto, sha, 1) -> - {deprecated, {crypto, hash, 2}}; + {removed, {crypto, hash, 2}, "20.0"}; obsolete_1(crypto, md4_init, 0) -> - {deprecated, {crypto, hash_init, 1}}; + {removed, {crypto, hash_init, 1}, "20.0"}; obsolete_1(crypto, md5_init, 0) -> - {deprecated, {crypto, hash_init, 1}}; + {removed, {crypto, hash_init, 1}, "20.0"}; obsolete_1(crypto, sha_init, 0) -> - {deprecated, {crypto, hash_init, 1}}; + {removed, {crypto, hash_init, 1}, "20.0"}; obsolete_1(crypto, md4_update, 2) -> - {deprecated, {crypto, hash_update, 2}}; + {removed, {crypto, hash_update, 2}, "20.0"}; obsolete_1(crypto, md5_update, 2) -> - {deprecated, {crypto, hash_update, 2}}; + {removed, {crypto, hash_update, 2}, "20.0"}; obsolete_1(crypto, sha_update, 2) -> - {deprecated, {crypto, hash_update, 2}}; + {removed, {crypto, hash_update, 2}, "20.0"}; obsolete_1(crypto, md4_final, 1) -> - {deprecated, {crypto, hash_final, 1}}; + {removed, {crypto, hash_final, 1}, "20.0"}; obsolete_1(crypto, md5_final, 1) -> - {deprecated, {crypto, hash_final, 1}}; + {removed, {crypto, hash_final, 1}, "20.0"}; obsolete_1(crypto, sha_final, 1) -> - {deprecated, {crypto, hash_final, 1}}; + {removed, {crypto, hash_final, 1}, "20.0"}; obsolete_1(crypto, md5_mac, 2) -> - {deprecated, {crypto, hmac, 3}}; + {removed, {crypto, hmac, 3}, "20.0"}; obsolete_1(crypto, sha_mac, 2) -> - {deprecated, {crypto, hmac, 3}}; + {removed, {crypto, hmac, 3}, "20.0"}; obsolete_1(crypto, sha_mac, 3) -> - {deprecated, {crypto, hmac, 4}}; + {removed, {crypto, hmac, 4}, "20.0"}; obsolete_1(crypto, sha_mac_96, 2) -> - {deprecated, {crypto, hmac, 4}}; + {removed, {crypto, hmac, 4}, "20.0"}; obsolete_1(crypto, md5_mac_96, 2) -> - {deprecated, {crypto, hmac, 4}}; + {removed, {crypto, hmac, 4}, "20.0"}; obsolete_1(crypto, rsa_sign, 2) -> - {deprecated, {crypto, sign, 4}}; + {removed, {crypto, sign, 4}, "20.0"}; obsolete_1(crypto, rsa_sign, 3) -> - {deprecated, {crypto, sign, 4}}; + {removed, {crypto, sign, 4}, "20.0"}; obsolete_1(crypto, rsa_verify, 3) -> - {deprecated, {crypto, verify, 5}}; + {removed, {crypto, verify, 5}, "20.0"}; obsolete_1(crypto, rsa_verify, 4) -> - {deprecated, {crypto, verify, 5}}; + {removed, {crypto, verify, 5}, "20.0"}; obsolete_1(crypto, dss_sign, 2) -> - {deprecated, {crypto, sign, 4}}; + {removed, {crypto, sign, 4}, "20.0"}; obsolete_1(crypto, dss_sign, 3) -> - {deprecated, {crypto, sign, 4}}; + {removed, {crypto, sign, 4}, "20.0"}; obsolete_1(crypto, dss_verify, 3) -> - {deprecated, {crypto, verify, 5}}; + {removed, {crypto, verify, 5}, "20.0"}; obsolete_1(crypto, dss_verify, 4) -> - {deprecated, {crypto, verify, 5}}; + {removed, {crypto, verify, 5}, "20.0"}; obsolete_1(crypto, mod_exp, 3) -> - {deprecated, {crypto, mod_pow, 3}}; + {removed, {crypto, mod_pow, 3}, "20.0"}; obsolete_1(crypto, dh_compute_key, 3) -> - {deprecated, {crypto, compute_key, 4}}; + {removed, {crypto, compute_key, 4}, "20.0"}; obsolete_1(crypto, dh_generate_key, 1) -> - {deprecated, {crypto, generate_key, 2}}; + {removed, {crypto, generate_key, 2}, "20.0"}; obsolete_1(crypto, dh_generate_key, 2) -> - {deprecated, {crypto, generate_key, 3}}; + {removed, {crypto, generate_key, 3}, "20.0"}; obsolete_1(crypto, des_cbc_encrypt, 3) -> - {deprecated, {crypto, block_encrypt, 4}}; + {removed, {crypto, block_encrypt, 4}, "20.0"}; obsolete_1(crypto, des3_cbc_encrypt, 5) -> - {deprecated, {crypto, block_encrypt, 4}}; + {removed, {crypto, block_encrypt, 4}, "20.0"}; obsolete_1(crypto, des_ecb_encrypt, 2) -> - {deprecated, {crypto, block_encrypt, 3}}; + {removed, {crypto, block_encrypt, 3}, "20.0"}; obsolete_1(crypto, des_ede3_cbc_encrypt, 5) -> - {deprecated, {crypto, block_encrypt, 4}}; + {removed, {crypto, block_encrypt, 4}, "20.0"}; obsolete_1(crypto, des_cfb_encrypt, 3) -> - {deprecated, {crypto, block_encrypt, 4}}; + {removed, {crypto, block_encrypt, 4}, "20.0"}; obsolete_1(crypto, des3_cfb_encrypt, 5) -> - {deprecated, {crypto, block_encrypt, 4}}; + {removed, {crypto, block_encrypt, 4}, "20.0"}; obsolete_1(crypto, blowfish_ecb_encrypt, 2) -> - {deprecated, {crypto, block_encrypt, 3}}; + {removed, {crypto, block_encrypt, 3}, "20.0"}; obsolete_1(crypto, blowfish_cbc_encrypt, 3) -> - {deprecated, {crypto, block_encrypt, 4}}; + {removed, {crypto, block_encrypt, 4}, "20.0"}; obsolete_1(crypto, blowfish_cfb64_encrypt, 3) -> - {deprecated, {crypto, block_encrypt, 4}}; + {removed, {crypto, block_encrypt, 4}, "20.0"}; obsolete_1(crypto, blowfish_ofb64_encrypt, 3) -> - {deprecated, {crypto, block_encrypt, 4}}; + {removed, {crypto, block_encrypt, 4}, "20.0"}; obsolete_1(crypto, aes_cfb_128_encrypt, 3) -> - {deprecated, {crypto, block_encrypt, 4}}; + {removed, {crypto, block_encrypt, 4}, "20.0"}; obsolete_1(crypto, aes_cbc_128_encrypt, 3) -> - {deprecated, {crypto, block_encrypt, 4}}; + {removed, {crypto, block_encrypt, 4}, "20.0"}; obsolete_1(crypto, aes_cbc_256_encrypt, 3) -> - {deprecated, {crypto, block_encrypt, 4}}; + {removed, {crypto, block_encrypt, 4}, "20.0"}; obsolete_1(crypto,rc2_cbc_encrypt, 3) -> - {deprecated, {crypto, block_encrypt, 4}}; + {removed, {crypto, block_encrypt, 4}, "20.0"}; obsolete_1(crypto,rc2_40_cbc_encrypt, 3) -> - {deprecated, {crypto, block_encrypt, 4}}; + {removed, {crypto, block_encrypt, 4}, "20.0"}; obsolete_1(crypto, des_cbc_decrypt, 3) -> - {deprecated, {crypto, block_decrypt, 4}}; + {removed, {crypto, block_decrypt, 4}, "20.0"}; obsolete_1(crypto, des3_cbc_decrypt, 5) -> - {deprecated, {crypto, block_decrypt, 4}}; + {removed, {crypto, block_decrypt, 4}, "20.0"}; obsolete_1(crypto, des_ecb_decrypt, 2) -> - {deprecated, {crypto, block_decrypt, 3}}; + {removed, {crypto, block_decrypt, 3}, "20.0"}; obsolete_1(crypto, des_ede3_cbc_decrypt, 5) -> - {deprecated, {crypto, block_decrypt, 4}}; + {removed, {crypto, block_decrypt, 4}, "20.0"}; obsolete_1(crypto, des_cfb_decrypt, 3) -> - {deprecated, {crypto, block_decrypt, 4}}; + {removed, {crypto, block_decrypt, 4}, "20.0"}; obsolete_1(crypto, des3_cfb_decrypt, 5) -> - {deprecated, {crypto, block_decrypt, 4}}; + {removed, {crypto, block_decrypt, 4}, "20.0"}; obsolete_1(crypto, blowfish_ecb_decrypt, 2) -> - {deprecated, {crypto, block_decrypt, 3}}; + {removed, {crypto, block_decrypt, 3}, "20.0"}; obsolete_1(crypto, blowfish_cbc_decrypt, 3) -> - {deprecated, {crypto, block_decrypt, 4}}; + {removed, {crypto, block_decrypt, 4}, "20.0"}; obsolete_1(crypto, blowfish_cfb64_decrypt, 3) -> - {deprecated, {crypto, block_decrypt, 4}}; + {removed, {crypto, block_decrypt, 4}, "20.0"}; obsolete_1(crypto, blowfish_ofb64_decrypt, 3) -> - {deprecated, {crypto, block_decrypt, 4}}; + {removed, {crypto, block_decrypt, 4}, "20.0"}; obsolete_1(crypto, aes_cfb_128_decrypt, 3) -> - {deprecated, {crypto, block_decrypt, 4}}; + {removed, {crypto, block_decrypt, 4}, "20.0"}; obsolete_1(crypto, aes_cbc_128_decrypt, 3) -> - {deprecated, {crypto, block_decrypt, 4}}; + {removed, {crypto, block_decrypt, 4}, "20.0"}; obsolete_1(crypto, aes_cbc_256_decrypt, 3) -> - {deprecated, {crypto, block_decrypt, 4}}; + {removed, {crypto, block_decrypt, 4}, "20.0"}; obsolete_1(crypto,rc2_cbc_decrypt, 3) -> - {deprecated, {crypto, block_decrypt, 4}}; + {removed, {crypto, block_decrypt, 4}, "20.0"}; obsolete_1(crypto,rc2_40_cbc_decrypt, 3) -> - {deprecated, {crypto, block_decrypt, 4}}; + {removed, {crypto, block_decrypt, 4}, "20.0"}; obsolete_1(crypto, aes_ctr_stream_decrypt, 2) -> - {deprecated, {crypto, stream_decrypt, 2}}; + {removed, {crypto, stream_decrypt, 2}, "20.0"}; obsolete_1(crypto, aes_ctr_stream_encrypt, 2) -> - {deprecated, {crypto, stream_encrypt, 2}}; + {removed, {crypto, stream_encrypt, 2}, "20.0"}; obsolete_1(crypto, aes_ctr_decrypt, 3) -> - {deprecated, {crypto, stream_decrypt, 2}}; + {removed, {crypto, stream_decrypt, 2}, "20.0"}; obsolete_1(crypto, aes_ctr_encrypt, 3) -> - {deprecated, {crypto, stream_encrypt, 2}}; + {removed, {crypto, stream_encrypt, 2}, "20.0"}; obsolete_1(crypto, rc4_encrypt, 2) -> - {deprecated, {crypto, stream_encrypt, 2}}; + {removed, {crypto, stream_encrypt, 2}, "20.0"}; obsolete_1(crypto, rc4_encrypt_with_state, 2) -> - {deprecated, {crypto, stream_encrypt, 2}}; + {removed, {crypto, stream_encrypt, 2}, "20.0"}; obsolete_1(crypto, aes_ctr_stream_init, 2) -> - {deprecated, {crypto, stream_init, 3}}; + {removed, {crypto, stream_init, 3}, "20.0"}; obsolete_1(crypto, rc4_set_key, 1) -> - {deprecated, {crypto, stream_init, 2}}; + {removed, {crypto, stream_init, 2}, "20.0"}; obsolete_1(crypto, rsa_private_decrypt, 3) -> - {deprecated, {crypto, private_decrypt, 4}}; + {removed, {crypto, private_decrypt, 4}, "20.0"}; obsolete_1(crypto, rsa_public_decrypt, 3) -> - {deprecated, {crypto, public_decrypt, 4}}; + {removed, {crypto, public_decrypt, 4}, "20.0"}; obsolete_1(crypto, rsa_private_encrypt, 3) -> - {deprecated, {crypto, private_encrypt, 4}}; + {removed, {crypto, private_encrypt, 4}, "20.0"}; obsolete_1(crypto, rsa_public_encrypt, 3) -> - {deprecated, {crypto, public_encrypt, 4}}; + {removed, {crypto, public_encrypt, 4}, "20.0"}; obsolete_1(crypto, des_cfb_ivec, 2) -> - {deprecated, {crypto, next_iv, 3}}; + {removed, {crypto, next_iv, 3}, "20.0"}; obsolete_1(crypto,des_cbc_ivec, 1) -> - {deprecated, {crypto, next_iv, 2}}; + {removed, {crypto, next_iv, 2}, "20.0"}; obsolete_1(crypto, aes_cbc_ivec, 1) -> - {deprecated, {crypto, next_iv, 2}}; + {removed, {crypto, next_iv, 2}, "20.0"}; obsolete_1(crypto,info, 0) -> - {deprecated, {crypto, module_info, 0}}; + {removed, {crypto, module_info, 0}, "20.0"}; obsolete_1(crypto, strong_rand_mpint, 3) -> - {deprecated, "needed only by deprecated functions"}; + {removed, "removed in 20.0; only needed by removed functions"}; obsolete_1(crypto, erlint, 1) -> - {deprecated, "needed only by deprecated functions"}; + {removed, "removed in 20.0; only needed by removed functions"}; obsolete_1(crypto, mpint, 1) -> - {deprecated, "needed only by deprecated functions"}; + {removed, "removed in 20.0; only needed by removed functions"}; %% *** SNMP *** @@ -387,13 +392,13 @@ obsolete_1(erlang, concat_binary, 1) -> %% Added in R14A. obsolete_1(ssl, peercert, 2) -> - {deprecated,"deprecated (will be removed in R15A); use ssl:peercert/1 and public_key:pkix_decode_cert/2 instead"}; + {removed ,"removed in R15A; use ssl:peercert/1 and public_key:pkix_decode_cert/2 instead"}; %% Added in R14B. obsolete_1(public_key, pem_to_der, 1) -> - {deprecated,"deprecated (will be removed in R15A); use file:read_file/1 and public_key:pem_decode/1"}; + {removed,"removed in R15A; use file:read_file/1 and public_key:pem_decode/1"}; obsolete_1(public_key, decode_private_key, A) when A =:= 1; A =:= 2 -> - {deprecated,{public_key,pem_entry_decode,1},"R15A"}; + {removed, "removed in R15A; use public_key:pem_entry_decode/1"}; %% Added in R14B03. obsolete_1(docb_gen, _, _) -> @@ -415,10 +420,10 @@ obsolete_1(inviso, _, _) -> obsolete_1(gs, _, _) -> {removed,"the gs application has been removed; use the wx application instead"}; obsolete_1(ssh, sign_data, 2) -> - {deprecated,"deprecated (will be removed in R16A); use public_key:pem_decode/1, public_key:pem_entry_decode/1 " + {removed,"removed in R16A; use public_key:pem_decode/1, public_key:pem_entry_decode/1 " "and public_key:sign/3 instead"}; obsolete_1(ssh, verify_data, 3) -> - {deprecated,"deprecated (will be removed in R16A); use public_key:ssh_decode/1, and public_key:verify/4 instead"}; + {removed,"removed in R16A; use public_key:ssh_decode/1, and public_key:verify/4 instead"}; %% Added in R16 obsolete_1(wxCalendarCtrl, enableYearChange, _) -> %% wx bug documented? @@ -515,10 +520,9 @@ obsolete_1(erl_parse, get_attribute, 2) -> obsolete_1(erl_lint, modify_line, 2) -> {removed,{erl_parse,map_anno,2},"19.0"}; obsolete_1(ssl, negotiated_next_protocol, 1) -> - {deprecated,{ssl,negotiated_protocol,1}}; - + {removed,"removed in 20.0; use ssl:negotiated_protocol/1 instead"}; obsolete_1(ssl, connection_info, 1) -> - {deprecated, "deprecated; use connection_information/[1,2] instead"}; + {removed, "removed in 20.0; use ssl:connection_information/[1,2] instead"}; obsolete_1(httpd_conf, check_enum, 2) -> {deprecated, "deprecated; use lists:member/2 instead"}; diff --git a/lib/stdlib/test/erl_lint_SUITE.erl b/lib/stdlib/test/erl_lint_SUITE.erl index df38edf393..fd7de65302 100644 --- a/lib/stdlib/test/erl_lint_SUITE.erl +++ b/lib/stdlib/test/erl_lint_SUITE.erl @@ -64,7 +64,8 @@ predef/1, maps/1,maps_type/1,maps_parallel_match/1, otp_11851/1,otp_11879/1,otp_13230/1, - record_errors/1, otp_xxxxx/1]). + record_errors/1, otp_xxxxx/1, + non_latin1_module/1]). suite() -> [{ct_hooks,[ts_install_cth]}, @@ -84,7 +85,7 @@ all() -> too_many_arguments, basic_errors, bin_syntax_errors, predef, maps, maps_type, maps_parallel_match, otp_11851, otp_11879, otp_13230, - record_errors, otp_xxxxx]. + record_errors, otp_xxxxx, non_latin1_module]. groups() -> [{unused_vars_warn, [], @@ -2098,11 +2099,11 @@ otp_5362(Config) when is_list(Config) -> [{2,erl_lint,disallowed_nowarn_bif_clash}],[]}}, {call_deprecated_function, - <<"t(X) -> crypto:md5(X).">>, + <<"t(X) -> calendar:local_time_to_universal_time(X).">>, [], {warnings, - [{1,erl_lint,{deprecated,{crypto,md5,1}, - {crypto,hash,2}, "a future release"}}]}}, + [{1,erl_lint,{deprecated,{calendar,local_time_to_universal_time,1}, + {calendar,local_time_to_universal_time_dst,1}, "a future release"}}]}}, {call_removed_function, <<"t(X) -> regexp:match(X).">>, @@ -3923,6 +3924,24 @@ otp_xxxxx(Config) -> []}], run(Config, Ts). +%% OTP-14285: We currently don't support non-latin1 module names. + +non_latin1_module(_Config) -> + do_non_latin1_module('юникод'), + do_non_latin1_module(list_to_atom([256,$a,$b,$c])), + do_non_latin1_module(list_to_atom([$a,$b,256,$c])), + ok. + +do_non_latin1_module(Mod) -> + File = atom_to_list(Mod) ++ ".erl", + Forms = [{attribute,1,file,{File,1}}, + {attribute,1,module,Mod}, + {eof,2}], + error = compile:forms(Forms), + {error,_,[]} = compile:forms(Forms, [return]), + ok. + + run(Config, Tests) -> F = fun({N,P,Ws,E}, BadL) -> case catch run_test(Config, P, Ws) of diff --git a/lib/stdlib/test/ets_SUITE.erl b/lib/stdlib/test/ets_SUITE.erl index 8581440d58..ebf7dbff62 100644 --- a/lib/stdlib/test/ets_SUITE.erl +++ b/lib/stdlib/test/ets_SUITE.erl @@ -75,7 +75,7 @@ -export([otp_9423/1]). -export([otp_10182/1]). -export([ets_all/1]). --export([memory_check_summary/1]). +-export([massive_ets_all/1]). -export([take/1]). -export([init_per_testcase/2, end_per_testcase/2]). @@ -93,7 +93,6 @@ init_per_testcase(Case, Config) -> io:format("*** SEED: ~p ***\n", [rand:export_seed()]), start_spawn_logger(), wait_for_test_procs(), %% Ensure previous case cleaned up - put('__ETS_TEST_CASE__', Case), [{test_case, Case} | Config]. end_per_testcase(_Func, _Config) -> @@ -134,9 +133,8 @@ all() -> otp_9932, otp_9423, ets_all, - take, - - memory_check_summary]. % MUST BE LAST + massive_ets_all, + take]. groups() -> [{new, [], @@ -181,27 +179,6 @@ init_per_group(_GroupName, Config) -> end_per_group(_GroupName, Config) -> Config. -%% Test that we did not have "too many" failed verify_etsmem()'s -%% in the test suite. -%% verify_etsmem() may give a low number of false positives -%% as concurrent activities, such as lingering processes -%% from earlier test suites, may do unrelated ets (de)allocations. -memory_check_summary(_Config) -> - case whereis(ets_test_spawn_logger) of - undefined -> - ct:fail("No spawn logger exist"); - _ -> - ets_test_spawn_logger ! {self(), get_failed_memchecks}, - receive {get_failed_memchecks, FailedMemchecks} -> ok end, - io:format("Failed memchecks: ~p\n",[FailedMemchecks]), - NoFailedMemchecks = length(FailedMemchecks), - if NoFailedMemchecks > 1 -> - ct:fail("Too many failed (~p) memchecks", [NoFailedMemchecks]); - true -> - ok - end - end. - %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% @@ -5545,6 +5522,68 @@ ets_all_run() -> false = lists:member(Table, ets:all()), ets_all_run(). +create_tables(N) -> + create_tables(N, []). + +create_tables(0, Ts) -> + Ts; +create_tables(N, Ts) -> + create_tables(N-1, [ets:new(tjo, [])|Ts]). + +massive_ets_all(Config) when is_list(Config) -> + Me = self(), + InitTables = lists:sort(ets:all()), + io:format("InitTables=~p~n", [InitTables]), + PMs0 = lists:map(fun (Sid) -> + my_spawn_opt(fun () -> + Ts = create_tables(250), + Me ! {self(), up, Ts}, + receive {Me, die} -> ok end + end, + [link, monitor, {scheduler, Sid}]) + end, + lists:seq(1, erlang:system_info(schedulers_online))), + AllRes = lists:sort(lists:foldl(fun ({P, _M}, Ts) -> + receive + {P, up, PTs} -> + PTs ++ Ts + end + end, + InitTables, + PMs0)), + AllRes = lists:sort(ets:all()), + PMs1 = lists:map(fun (_) -> + my_spawn_opt(fun () -> + AllRes = lists:sort(ets:all()) + end, + [link, monitor]) + end, lists:seq(1, 50)), + lists:foreach(fun ({P, M}) -> + receive + {'DOWN', M, process, P, _} -> + ok + end + end, PMs1), + PMs2 = lists:map(fun (_) -> + my_spawn_opt(fun () -> + _ = ets:all() + end, + [link, monitor]) + end, lists:seq(1, 50)), + lists:foreach(fun ({P, _M}) -> + P ! {Me, die} + end, PMs0), + lists:foreach(fun ({P, M}) -> + receive + {'DOWN', M, process, P, _} -> + ok + end + end, PMs0 ++ PMs2), + EndTables = lists:sort(ets:all()), + io:format("EndTables=~p~n", [EndTables]), + InitTables = EndTables, + ok. + take(Config) when is_list(Config) -> %% Simple test for set tables. @@ -5712,45 +5751,27 @@ etsmem() -> {Bl0+Bl,BlSz0+BlSz} end, {0,0}, CS) end}, - {Mem,AllTabs, erts_debug:get_internal_state('DbTable_meta')}. + {Mem,AllTabs}. -verify_etsmem(EtsMem) -> +verify_etsmem({MemInfo,AllTabs}) -> wait_for_test_procs(), - verify_etsmem(EtsMem, false). - -verify_etsmem({MemInfo,AllTabs,MetaState}=EtsMem, Adjusted) -> case etsmem() of - {MemInfo,_,_} -> + {MemInfo,_} -> io:format("Ets mem info: ~p", [MemInfo]), case MemInfo 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"}; _ -> - case Adjusted of - true -> - {comment, "Meta state adjusted"}; - false -> - ok - end + ok end; - {MemInfo2, AllTabs2, MetaState2} -> + {MemInfo2, AllTabs2} -> io:format("Expected: ~p", [MemInfo]), io:format("Actual: ~p", [MemInfo2]), io:format("Changed tables before: ~p\n",[AllTabs -- AllTabs2]), io:format("Changed tables after: ~p\n", [AllTabs2 -- AllTabs]), - io:format("Meta state before: ~p\n", [MetaState]), - io:format("Meta state after: ~p\n", [MetaState2]), - case {MetaState =:= MetaState2, Adjusted} of - {false, false} -> - io:format("Adjust meta state and retry...\n\n",[]), - {ok,ok} = erts_debug:set_internal_state('DbTable_meta', MetaState), - verify_etsmem(EtsMem, true); - _ -> - ets_test_spawn_logger ! {failed_memcheck, get('__ETS_TEST_CASE__')}, - {comment, "Failed memory check"} - end + ct:fail("Failed memory check") end. @@ -5772,10 +5793,10 @@ stop_loopers(Loopers) -> looper(Fun, State) -> looper(Fun, Fun(State)). -spawn_logger(Procs, FailedMemchecks) -> +spawn_logger(Procs) -> receive {new_test_proc, Proc} -> - spawn_logger([Proc|Procs], FailedMemchecks); + spawn_logger([Proc|Procs]); {sync_test_procs, Kill, From} -> lists:foreach(fun (Proc) when From == Proc -> ok; @@ -5799,14 +5820,7 @@ spawn_logger(Procs, FailedMemchecks) -> end end, Procs), From ! test_procs_synced, - spawn_logger([From], FailedMemchecks); - - {failed_memcheck, TestCase} -> - spawn_logger(Procs, [TestCase|FailedMemchecks]); - - {Pid, get_failed_memchecks} -> - Pid ! {get_failed_memchecks, FailedMemchecks}, - spawn_logger(Procs, FailedMemchecks) + spawn_logger([From]) end. pid_status(Pid) -> @@ -5822,7 +5836,7 @@ start_spawn_logger() -> case whereis(ets_test_spawn_logger) of Pid when is_pid(Pid) -> true; _ -> register(ets_test_spawn_logger, - spawn_opt(fun () -> spawn_logger([], []) end, + spawn_opt(fun () -> spawn_logger([]) end, [{priority, max}])) end. diff --git a/lib/tools/src/tools.app.src b/lib/tools/src/tools.app.src index 4c7dd24006..17b1d06686 100644 --- a/lib/tools/src/tools.app.src +++ b/lib/tools/src/tools.app.src @@ -41,7 +41,6 @@ ] }, {runtime_dependencies, ["stdlib-3.1","runtime_tools-1.8.14", - "kernel-3.0","inets-5.10","erts-7.0", - "compiler-5.0"]} + "kernel-3.0","erts-7.0","compiler-5.0"]} ] }. |