diff options
Diffstat (limited to 'lib/compiler/src')
| -rw-r--r-- | lib/compiler/src/beam_bsm.erl | 1 | ||||
| -rw-r--r-- | lib/compiler/src/beam_disasm.erl | 6 | ||||
| -rw-r--r-- | lib/compiler/src/beam_validator.erl | 5 | ||||
| -rw-r--r-- | lib/compiler/src/compile.erl | 7 | ||||
| -rw-r--r-- | lib/compiler/src/core_lib.erl | 4 | ||||
| -rw-r--r-- | lib/compiler/src/sys_core_fold.erl | 143 | ||||
| -rw-r--r-- | lib/compiler/src/v3_codegen.erl | 138 | ||||
| -rw-r--r-- | lib/compiler/src/v3_core.erl | 24 | ||||
| -rw-r--r-- | lib/compiler/src/v3_kernel.erl | 105 | ||||
| -rw-r--r-- | lib/compiler/src/v3_kernel.hrl | 4 | ||||
| -rw-r--r-- | lib/compiler/src/v3_kernel_pp.erl | 17 | ||||
| -rw-r--r-- | lib/compiler/src/v3_life.erl | 14 |
12 files changed, 283 insertions, 185 deletions
diff --git a/lib/compiler/src/beam_bsm.erl b/lib/compiler/src/beam_bsm.erl index fdfcb08125..d54c2a9fde 100644 --- a/lib/compiler/src/beam_bsm.erl +++ b/lib/compiler/src/beam_bsm.erl @@ -209,6 +209,7 @@ btb_reaches_match_2([{call,Arity,{f,Lbl}}|Is], Regs, D) -> btb_reaches_match_2([{apply,Arity}|Is], Regs, D) -> btb_call(Arity+2, apply, Regs, Is, D); btb_reaches_match_2([{call_fun,Live}=I|Is], Regs, D) -> + btb_ensure_not_used([{x,Live}], I, Regs), btb_call(Live, I, Regs, Is, D); btb_reaches_match_2([{make_fun2,_,_,_,Live}|Is], Regs, D) -> btb_call(Live, make_fun2, Regs, Is, D); diff --git a/lib/compiler/src/beam_disasm.erl b/lib/compiler/src/beam_disasm.erl index e0d0d0fd1d..57fdf95677 100644 --- a/lib/compiler/src/beam_disasm.erl +++ b/lib/compiler/src/beam_disasm.erl @@ -1134,7 +1134,7 @@ resolve_inst({line,[Index]},_,_,_) -> {line,resolve_arg(Index)}; %% -%% R17A. +%% 17.0 %% resolve_inst({put_map_assoc,Args},_,_,_) -> [FLbl,Src,Dst,{u,N},{{z,1},{u,_Len},List0}] = Args, @@ -1150,6 +1150,10 @@ resolve_inst({is_map,Args0},_,_,_) -> [FLbl|Args] = resolve_args(Args0), {test, is_map, FLbl, Args}; +resolve_inst({has_map_field,Args0},_,_,_) -> + [FLbl|Args] = resolve_args(Args0), + {test,has_map_field,FLbl,Args}; + resolve_inst({get_map_element,Args},_,_,_) -> [FLbl,Src,Key,Dst] = resolve_args(Args), {get_map_element,FLbl,Src,Key,Dst}; diff --git a/lib/compiler/src/beam_validator.erl b/lib/compiler/src/beam_validator.erl index 97f84da08f..2486d486ed 100644 --- a/lib/compiler/src/beam_validator.erl +++ b/lib/compiler/src/beam_validator.erl @@ -574,6 +574,7 @@ valfun_4({apply,Live}, Vst) -> valfun_4({apply_last,Live,_}, Vst) -> tail_call(apply, Live+2, Vst); valfun_4({call_fun,Live}, Vst) -> + validate_src([{x,Live}], Vst), call('fun', Live+1, Vst); valfun_4({call,Live,Func}, Vst) -> call(Func, Live, Vst); @@ -881,7 +882,7 @@ valfun_4(_, _) -> verify_put_map(Fail, Src, Dst, Live, List, Vst0) -> verify_live(Live, Vst0), verify_y_init(Vst0), - [assert_term(Term, Vst0) || Term <- List], + foreach(fun (Term) -> assert_term(Term, Vst0) end, List), assert_term(Src, Vst0), Vst1 = heap_alloc(0, Vst0), Vst2 = branch_state(Fail, Vst1), @@ -908,7 +909,7 @@ validate_bs_skip_utf(Fail, Ctx, Live, Vst0) -> branch_state(Fail, Vst). %% -%% Special state handling for setelement/3 and the set_tuple_element/3 instruction. +%% Special state handling for setelement/3 and set_tuple_element/3 instructions. %% A possibility for garbage collection must not occur between setelement/3 and %% set_tuple_element/3. %% diff --git a/lib/compiler/src/compile.erl b/lib/compiler/src/compile.erl index 0bb4de6f17..e79fe41f9b 100644 --- a/lib/compiler/src/compile.erl +++ b/lib/compiler/src/compile.erl @@ -623,9 +623,11 @@ core_passes() -> [{core_old_inliner,fun test_old_inliner/1,fun core_old_inliner/1}, {iff,doldinline,{listing,"oldinline"}}, ?pass(core_fold_module), + {iff,dcorefold,{listing,"corefold"}}, {core_inline_module,fun test_core_inliner/1,fun core_inline_module/1}, {iff,dinline,{listing,"inline"}}, - {core_fold_after_inlining,fun test_core_inliner/1,fun core_fold_module_after_inlining/1}, + {core_fold_after_inlining,fun test_any_inliner/1, + fun core_fold_module_after_inlining/1}, ?pass(core_transforms)]}, {iff,dcopt,{listing,"copt"}}, {iff,'to_core',{done,"core"}}]} @@ -1171,6 +1173,9 @@ test_core_inliner(#compile{options=Opts}) -> end, Opts) end. +test_any_inliner(St) -> + test_old_inliner(St) orelse test_core_inliner(St). + core_old_inliner(#compile{code=Code0,options=Opts}=St) -> {ok,Code} = sys_core_inline:module(Code0, Opts), {ok,St#compile{code=Code}}. diff --git a/lib/compiler/src/core_lib.erl b/lib/compiler/src/core_lib.erl index f506901099..ed181e3baa 100644 --- a/lib/compiler/src/core_lib.erl +++ b/lib/compiler/src/core_lib.erl @@ -105,8 +105,8 @@ vu_expr(V, #c_cons{hd=H,tl=T}) -> vu_expr(V, H) orelse vu_expr(V, T); vu_expr(V, #c_tuple{es=Es}) -> vu_expr_list(V, Es); -vu_expr(V, #c_map{es=Es}) -> - vu_expr_list(V, Es); +vu_expr(V, #c_map{var=M,es=Es}) -> + vu_expr(V, M) orelse vu_expr_list(V, Es); vu_expr(V, #c_map_pair{key=Key,val=Val}) -> vu_expr_list(V, [Key,Val]); vu_expr(V, #c_binary{segments=Ss}) -> diff --git a/lib/compiler/src/sys_core_fold.erl b/lib/compiler/src/sys_core_fold.erl index 1cdbac5693..e2b9213891 100644 --- a/lib/compiler/src/sys_core_fold.erl +++ b/lib/compiler/src/sys_core_fold.erl @@ -305,6 +305,10 @@ expr(#c_let{}=Let, Ctxt, Sub) -> %% Now recursively re-process the new expression. expr(Expr, Ctxt, sub_new_preserve_types(Sub)) end; +expr(#c_letrec{body=#c_var{}}=Letrec, effect, _Sub) -> + %% This is named fun in an 'effect' context. Warn and ignore. + add_warning(Letrec, useless_building), + void(); expr(#c_letrec{defs=Fs0,body=B0}=Letrec, Ctxt, Sub) -> Fs1 = map(fun ({Name,Fb}) -> {Name,expr(Fb, {letrec,Ctxt}, Sub)} @@ -349,7 +353,12 @@ expr(#c_case{}=Case0, Ctxt, Sub) -> Case = Case1#c_case{arg=Arg2,clauses=Cs2}, warn_no_clause_match(Case1, Case), Expr = eval_case(Case, Sub), - bsm_an(Expr); + case move_case_into_arg(Case, Sub) of + impossible -> + bsm_an(Expr); + Other -> + expr(Other, Ctxt, sub_new_preserve_types(Sub)) + end; Other -> expr(Other, Ctxt, Sub) end; @@ -598,6 +607,14 @@ eval_binary_1([#c_bitstr{val=#c_literal{val=Val},size=#c_literal{val=Sz}, error:_ -> throw(impossible) end; +eval_binary_1([#c_bitstr{val=#c_literal{},size=#c_literal{}, + unit=#c_literal{},type=#c_literal{}, + flags=#c_cons{}=Flags}=Bitstr|Ss], Acc0) -> + case cerl:fold_literal(Flags) of + #c_literal{} = Flags1 -> + eval_binary_1([Bitstr#c_bitstr{flags=Flags1}|Ss], Acc0); + _ -> throw(impossible) + end; eval_binary_1([], Acc) -> Acc; eval_binary_1(_, _) -> throw(impossible). @@ -1536,9 +1553,17 @@ map_pair_pattern_list(Ps0, Isub, Osub0) -> {Ps,{_,Osub}} = mapfoldl(fun map_pair_pattern/2, {Isub,Osub0}, Ps0), {Ps,Osub}. -map_pair_pattern(#c_map_pair{op=#c_literal{val=exact},key=K0,val=V0}=Pair, {Isub,Osub0}) -> - {K,Osub1} = pattern(K0, Isub, Osub0), - {V,Osub} = pattern(V0, Isub, Osub1), +map_pair_pattern(#c_map_pair{op=#c_literal{val=exact},key=K0,val=V0}=Pair,{Isub,Osub0}) -> + {K,Osub1} = case cerl:type(K0) of + binary -> + K1 = eval_binary(K0), + case cerl:type(K1) of + literal -> {K1,Osub0}; + _ -> pattern(K0,Isub,Osub0) + end; + _ -> pattern(K0,Isub,Osub0) + end, + {V,Osub} = pattern(V0,Isub,Osub1), {Pair#c_map_pair{key=K,val=V},{Isub,Osub}}. bin_pattern_list(Ps0, Isub, Osub0) -> @@ -1920,14 +1945,45 @@ opt_bool_case_guard(Arg, [#c_clause{pats=[#c_literal{val=false}]}=Fc,Tc]) -> %% last clause is guaranteed to match so if there is only one clause %% with a pattern containing only variables then rewrite to a let. -eval_case(#c_case{arg=E,clauses=[#c_clause{pats=Ps0,body=B}]}, Sub) -> +eval_case(#c_case{arg=E,clauses=[#c_clause{pats=Ps0, + guard=#c_literal{val=true}, + body=B}]}=Case, Sub) -> Es = case cerl:is_c_values(E) of true -> cerl:values_es(E); false -> [E] end, - {true,Bs} = cerl_clauses:match_list(Ps0, Es), - {Ps,As} = unzip(Bs), - expr(#c_let{vars=Ps,arg=core_lib:make_values(As),body=B}, sub_new(Sub)); + %% Consider: + %% + %% case SomeSideEffect() of + %% X=Y -> ... + %% end + %% + %% We must not rewrite it to: + %% + %% let <X,Y> = <SomeSideEffect(),SomeSideEffect()> in ... + %% + %% because SomeSideEffect() would be evaluated twice. + %% + %% Instead we must evaluate the case expression in an outer let + %% like this: + %% + %% let NewVar = SomeSideEffect() in + %% let <X,Y> = <NewVar,NewVar> in ... + %% + Vs = make_vars([], length(Es)), + case cerl_clauses:match_list(Ps0, Vs) of + {false,_} -> + %% This can only happen if the Core Erlang code is + %% handwritten or generated by another code generator + %% than v3_core. Assuming that the Core Erlang program + %% is correct, the clause will always match at run-time. + Case; + {true,Bs} -> + {Ps,As} = unzip(Bs), + InnerLet = cerl:c_let(Ps, core_lib:make_values(As), B), + Let = cerl:c_let(Vs, E, InnerLet), + expr(Let, sub_new(Sub)) + end; eval_case(Case, _) -> Case. %% case_opt(CaseArg, [Clause]) -> {CaseArg,[Clause]}. @@ -2555,6 +2611,77 @@ opt_simple_let_2(Let, Vs0, Arg0, Body, value, Sub) -> value, Sub) end. +move_case_into_arg(#c_case{arg=#c_let{vars=OuterVars0,arg=OuterArg, + body=InnerArg0}=Outer, + clauses=InnerClauses}=Inner, Sub) -> + %% + %% case let <OuterVars> = <OuterArg> in <InnerArg> of + %% <InnerClauses> + %% end + %% + %% ==> + %% + %% let <OuterVars> = <OuterArg> + %% in case <InnerArg> of <InnerClauses> end + %% + ScopeSub0 = sub_subst_scope(Sub#sub{t=[]}), + {OuterVars,ScopeSub} = pattern_list(OuterVars0, ScopeSub0), + InnerArg = body(InnerArg0, ScopeSub), + Outer#c_let{vars=OuterVars,arg=OuterArg, + body=Inner#c_case{arg=InnerArg,clauses=InnerClauses}}; +move_case_into_arg(#c_case{arg=#c_case{arg=OuterArg, + clauses=[OuterCa0,OuterCb]}=Outer, + clauses=InnerClauses}=Inner0, Sub) -> + case is_failing_clause(OuterCb) of + true -> + #c_clause{pats=OuterPats0,guard=OuterGuard0, + body=InnerArg0} = OuterCa0, + %% + %% case case <OuterArg> of + %% <OuterPats> when <OuterGuard> -> <InnerArg> + %% <OuterCb> + %% ... + %% end of + %% <InnerClauses> + %% end + %% + %% ==> + %% + %% case <OuterArg> of + %% <OuterPats> when <OuterGuard> -> + %% case <InnerArg> of <InnerClauses> end + %% <OuterCb> + %% end + %% + ScopeSub0 = sub_subst_scope(Sub#sub{t=[]}), + {OuterPats,ScopeSub} = pattern_list(OuterPats0, ScopeSub0), + OuterGuard = guard(OuterGuard0, ScopeSub), + InnerArg = body(InnerArg0, ScopeSub), + Inner = Inner0#c_case{arg=InnerArg,clauses=InnerClauses}, + OuterCa = OuterCa0#c_clause{pats=OuterPats,guard=OuterGuard, + body=Inner}, + Outer#c_case{arg=OuterArg, + clauses=[OuterCa,OuterCb]}; + false -> + impossible + end; +move_case_into_arg(#c_case{arg=#c_seq{arg=OuterArg,body=InnerArg}=Outer, + clauses=InnerClauses}=Inner, _Sub) -> + %% + %% case do <OuterArg> <InnerArg> of + %% <InnerClauses> + %% end + %% + %% ==> + %% + %% do <OuterArg> + %% case <InnerArg> of <InerClauses> end + %% + Outer#c_seq{arg=OuterArg, + body=Inner#c_case{arg=InnerArg,clauses=InnerClauses}}; +move_case_into_arg(_, _) -> + impossible. + %% In guards only, rewrite a case in a let argument like %% %% let <Var> = case <> of diff --git a/lib/compiler/src/v3_codegen.erl b/lib/compiler/src/v3_codegen.erl index c8735a76e8..4d155c0fd0 100644 --- a/lib/compiler/src/v3_codegen.erl +++ b/lib/compiler/src/v3_codegen.erl @@ -459,7 +459,7 @@ basic_block([Le|Les], Acc) -> %% sets that may garbage collect are not allowed in basic blocks. collect_block({set,_,{binary,_}}) -> no_block; -collect_block({set,_,{map,_,_}}) -> no_block; +collect_block({set,_,{map,_,_,_}}) -> no_block; collect_block({set,_,_}) -> include; collect_block({call,{var,_}=Var,As,_Rs}) -> {block_end,As++[Var]}; collect_block({call,Func,As,_Rs}) -> {block_end,As++func_vars(Func)}; @@ -928,7 +928,7 @@ select_extract_tuple(Src, Vs, I, Vdb, Bef, St) -> select_map(Scs, V, Tf, Vf, Bef, St0) -> Reg = fetch_var(V, Bef), {Is,Aft,St1} = - match_fmf(fun(#l{ke={val_clause,{map,Es},B},i=I,vdb=Vdb}, Fail, St1) -> + match_fmf(fun(#l{ke={val_clause,{map,_,Es},B},i=I,vdb=Vdb}, Fail, St1) -> select_map_val(V, Es, B, Fail, I, Vdb, Bef, St1) end, Vf, St0, Scs), {[{test,is_map,{f,Tf},[Reg]}|Is],Aft,St1}. @@ -1488,55 +1488,35 @@ set_cg([{var,R}], {binary,Segs}, Le, Vdb, Bef, %% Now generate the complete code for constructing the binary. Code = cg_binary(PutCode, Target, Temp, Fail, MaxRegs, Le#l.a), {Sis++Code,Aft,St}; -set_cg([{var,R}], {map,SrcMap,Es0}, Le, Vdb, Bef, +set_cg([{var,R}], {map,Op,Map,Es}, Le, Vdb, Bef, #cg{in_catch=InCatch,bfail=Bfail}=St) -> + Fail = {f,Bfail}, {Sis,Int0} = case InCatch of true -> adjust_stack(Bef, Le#l.i, Le#l.i+1, Vdb); false -> {[],Bef} end, + SrcReg = cg_reg_arg(Map,Int0), Line = line(Le#l.a), - SrcReg = case SrcMap of - {var,SrcVar} -> fetch_var(SrcVar, Int0); - _ -> SrcMap - end, - {Assoc,Exact} = - try - cg_map_pairs(Es0) - catch - throw:badarg -> - {[],[{{float,0.0},{atom,badarg}}, - {{integer,0},{atom,badarg}}]} - end, - F = fun ({K,{var,V}}) -> [K,fetch_var(V, Int0)]; - ({K,E}) -> [K,E] - end, - AssocList = flatmap(F, Assoc), - ExactList = flatmap(F, Exact), - Live0 = max_reg(Bef#sr.reg), - Int1 = clear_dead(Int0, Le#l.i, Vdb), - Aft = Bef#sr{reg=put_reg(R, Int1#sr.reg)}, - Target = fetch_reg(R, Aft#sr.reg), - Code = [Line] ++ - case {AssocList,ExactList} of - {[_|_],[]} -> - [{put_map_assoc,Fail,SrcReg,Target,Live0,{list,AssocList}}]; - {[_|_],[_|_]} -> - Live = case Target of - {x,TargetX} when TargetX =:= Live0 -> - Live0 + 1; - _ -> - Live0 - end, - [{put_map_assoc,Fail,SrcReg,Target,Live0,{list,AssocList}}, - {put_map_exact,Fail,Target,Target,Live,{list,ExactList}}]; - {[],[_|_]} -> - [{put_map_exact,Fail,SrcReg,Target,Live0,{list,ExactList}}]; - {[],[]} -> - [{put_map_assoc,Fail,SrcReg,Target,Live0,{list,[]}}] - end, - {Sis++Code,Aft,St}; + + %% The instruction needs to store keys in term sorted order + %% All keys has to be unique here + Pairs = map_pair_strip_and_termsort(Es), + + %% fetch registers for values to be put into the map + List = flatmap(fun({K,V}) -> [K,cg_reg_arg(V,Int0)] end, Pairs), + + Live = max_reg(Bef#sr.reg), + Int1 = Int0#sr{reg=put_reg(R, Int0#sr.reg)}, + Aft = clear_dead(Int1, Le#l.i, Vdb), + Target = fetch_reg(R, Int1#sr.reg), + + I = case Op of + assoc -> put_map_assoc; + exact -> put_map_exact + end, + {Sis++[Line]++[{I,Fail,SrcReg,Target,Live,{list,List}}],Aft,St}; set_cg([{var,R}], Con, Le, Vdb, Bef, St) -> %% Find a place for the return register first. Int = Bef#sr{reg=put_reg(R, Bef#sr.reg)}, @@ -1549,70 +1529,12 @@ set_cg([{var,R}], Con, Le, Vdb, Bef, St) -> end, {Ais,clear_dead(Int, Le#l.i, Vdb),St}. -%% cg_map_pairs(MapPairs) -> {Assoc,Exact} -%% Assoc = Exact = [{K,V}] -%% -%% Remove multiple assignments to the same key, and return -%% one list key-value list with all keys that may or may not exist -%% (Assoc), and one with keys that must exist (Exact). -%% - -cg_map_pairs(Es0) -> - Es = cg_map_pairs_1(Es0, 0), - R0 = sofs:relation(Es), - R1 = sofs:relation_to_family(R0), - R2 = sofs:to_external(R1), - - %% R2 is now [{KeyValue,[{Order,Op,OriginalKey,Value}]}] - R3 = [begin - %% The value for the last pair determines the value. - {_,_,_,V} = lists:last(Vs), - {Op,{_,SortOrder}=K} = map_pair_op_and_key(Vs), - {Op,{SortOrder,K,V}} - end || {_,Vs} <- R2], - - %% R3 is now [{Op,{Key,Value}}] - R = termsort(R3), - - %% R4 is now sorted with all alloc first in the list, followed by - %% all exact. - {Assoc,Exact} = lists:partition(fun({Op,_}) -> Op =:= assoc end, R), - {[{K,V} || {_,{_,K,V}} <- Assoc], - [{K,V} || {_,{_,K,V}} <- Exact]}. - -cg_map_pairs_1([{map_pair_assoc,{_,Kv}=K,V}|T], Order) -> - [{Kv,{Order,assoc,K,V}}|cg_map_pairs_1(T, Order+1)]; -cg_map_pairs_1([{map_pair_exact,{_,Kv}=K,V}|T], Order) -> - [{Kv,{Order,exact,K,V}}|cg_map_pairs_1(T, Order+1)]; -cg_map_pairs_1([], _) -> []. - -%% map_pair_op_and_key({_,Op,K,_}) -> {Operator,Key} -%% Determine the operator and key to use. Throw a 'badarg' -%% exception if there are contradictory exact updates. - -map_pair_op_and_key(L) -> - case [K || {_,exact,K,_} <- L] of - [K] -> - %% There is a single ':=' operator. Use that key. - {exact,K}; - [K|T] -> - %% There is more than one ':=' operator. All of them - %% must have the same key. - case lists:all(fun(E) -> E =:= K end, T) of - true -> - {exact,K}; - false -> - %% Some keys are different, e.g. 1 and 1.0. - throw(badarg) - end; - [] -> - %% Only '=>' operators. Use the first key in the list. - [{_,assoc,K,_}|_] = L, - {assoc,K} - end. - -termsort(Ls) -> - lists:sort(fun(A,B) -> erts_internal:cmp_term(A,B) < 0 end, Ls). +map_pair_strip_and_termsort(Es) -> + %% format in + %% [{map_pair,K,V}] + %% where K is for example {integer, 1} and we want to sort on 1. + Ls = [{K,V}||{_,K,V}<-Es], + lists:sort(fun({{_,A},_},{{_,B},_}) -> erts_internal:cmp_term(A,B) < 0 end, Ls). %%% %%% Code generation for constructing binaries. @@ -2085,7 +2007,7 @@ load_vars(Vs, Regs) -> foldl(fun ({var,V}, Rs) -> put_reg(V, Rs) end, Regs, Vs). %% put_reg(Val, Regs) -> Regs. -%% find_reg(Val, Regs) -> ok{r{R}} | error. +%% find_reg(Val, Regs) -> {ok,r{R}} | error. %% fetch_reg(Val, Regs) -> r{R}. %% Functions to interface the registers. diff --git a/lib/compiler/src/v3_core.erl b/lib/compiler/src/v3_core.erl index c58bedac1a..ec5deb6905 100644 --- a/lib/compiler/src/v3_core.erl +++ b/lib/compiler/src/v3_core.erl @@ -74,7 +74,7 @@ -export([module/2,format_error/1]). -import(lists, [reverse/1,reverse/2,map/2,member/2,foldl/3,foldr/3,mapfoldl/3, - splitwith/2,keyfind/3,sort/1,foreach/2]). + splitwith/2,keyfind/3,sort/1,foreach/2,droplast/1,last/1]). -import(ordsets, [add_element/2,del_element/2,is_element/2, union/1,union/2,intersection/2,subtract/2]). -import(cerl, [ann_c_cons/3,ann_c_cons_skel/3,ann_c_tuple/2,c_tuple/1]). @@ -226,13 +226,13 @@ guard(Gs0, St0) -> Gt1 = guard_tests(Gt0), L = element(2, Gt1), {op,L,'or',Gt1,Rhs} - end, guard_tests(last(Gs0)), first(Gs0)), + end, guard_tests(last(Gs0)), droplast(Gs0)), {Gs,St} = gexpr_top(Gs1, St0#core{in_guard=true}), {Gs,St#core{in_guard=false}}. guard_tests(Gs) -> L = element(2, hd(Gs)), - {protect,L,foldr(fun (G, Rhs) -> {op,L,'and',G,Rhs} end, last(Gs), first(Gs))}. + {protect,L,foldr(fun (G, Rhs) -> {op,L,'and',G,Rhs} end, last(Gs), droplast(Gs))}. %% gexpr_top(Expr, State) -> {Cexpr,State}. %% Generate an internal core expression of a guard test. Explicitly @@ -513,7 +513,7 @@ expr({bin,L,Es0}, St0) -> end; expr({block,_,Es0}, St0) -> %% Inline the block directly. - {Es1,St1} = exprs(first(Es0), St0), + {Es1,St1} = exprs(droplast(Es0), St0), {E1,Eps,St2} = expr(last(Es0), St1), {E1,Es1 ++ Eps,St2}; expr({'if',L,Cs0}, St0) -> @@ -1594,15 +1594,6 @@ pat_alias_list(_, _) -> throw(nomatch). pattern_list(Ps, St) -> [pattern(P, St) || P <- Ps]. -%% first([A]) -> [A]. -%% last([A]) -> A. - -first([_]) -> []; -first([H|T]) -> [H|first(T)]. - -last([L]) -> L; -last([_|T]) -> last(T). - %% make_vars([Name]) -> [{Var,Name}]. make_vars(Vs) -> [ #c_var{name=V} || V <- Vs ]. @@ -1685,13 +1676,13 @@ uclause(#iclause{anno=Anno,pats=Ps0,guard=G0,body=B0}, Pks, Ks0, St0) -> uguard([], [], _, St) -> {[],St}; uguard(Pg, [], Ks, St) -> %% No guard, so fold together equality tests. - uguard(first(Pg), [last(Pg)], Ks, St); + uguard(droplast(Pg), [last(Pg)], Ks, St); uguard(Pg, Gs0, Ks, St0) -> %% Gs0 must contain at least one element here. {Gs3,St5} = foldr(fun (T, {Gs1,St1}) -> {L,St2} = new_var(St1), {R,St3} = new_var(St2), - {[#iset{var=L,arg=T}] ++ first(Gs1) ++ + {[#iset{var=L,arg=T}] ++ droplast(Gs1) ++ [#iset{var=R,arg=last(Gs1)}, #icall{anno=#a{}, %Must have an #a{} module=#c_literal{val=erlang}, @@ -2094,7 +2085,8 @@ cexpr(#ifun{anno=#a{us=Us0}=A0,name={named,Name},fc=#iclause{pats=Ps}}=Fun0, RecVar = #c_var{name={Name,length(Ps)}}, Let = #c_let{vars=[#c_var{name=Name}],arg=RecVar,body=Body}, CFun1 = CFun0#c_fun{body=Let}, - Letrec = #c_letrec{defs=[{RecVar,CFun1}], + Letrec = #c_letrec{anno=A0#a.anno, + defs=[{RecVar,CFun1}], body=RecVar}, {Letrec,[],Us1,St1} end; diff --git a/lib/compiler/src/v3_kernel.erl b/lib/compiler/src/v3_kernel.erl index 9a2b1605ad..bc5ca0314a 100644 --- a/lib/compiler/src/v3_kernel.erl +++ b/lib/compiler/src/v3_kernel.erl @@ -81,7 +81,7 @@ -export([module/2,format_error/1]). -import(lists, [map/2,foldl/3,foldr/3,mapfoldl/3,splitwith/2,member/2, - keymember/3,keyfind/3,partition/2]). + keymember/3,keyfind/3,partition/2,droplast/1,last/1]). -import(ordsets, [add_element/2,del_element/2,union/2,union/1,subtract/2]). -import(cerl, [c_tuple/1]). @@ -274,8 +274,7 @@ expr(#c_tuple{anno=A,es=Ces}, Sub, St0) -> {#k_tuple{anno=A,es=Kes},Ep,St1}; expr(#c_map{anno=A,var=Var0,es=Ces}, Sub, St0) -> {Var,[],St1} = expr(Var0, Sub, St0), - {Kes,Ep,St2} = map_pairs(Ces, Sub, St1), - {#k_map{anno=A,var=Var,es=Kes},Ep,St2}; + map_split_pairs(A, Var, Ces, Sub, St1); expr(#c_binary{anno=A,segments=Cv}, Sub, St0) -> try atomic_bin(Cv, Sub, St0) of {Kv,Ep,St1} -> @@ -351,7 +350,7 @@ expr(#c_case{arg=Ca,clauses=Ccs}, Sub, St0) -> {Kvs,Pv,St2} = match_vars(Ka, St1), %Must have variables here! {Km,St3} = kmatch(Kvs, Ccs, Sub, St2), Match = flatten_seq(build_match(Kvs, Km)), - {last(Match),Pa ++ Pv ++ first(Match),St3}; + {last(Match),Pa ++ Pv ++ droplast(Match),St3}; expr(#c_receive{anno=A,clauses=Ccs0,timeout=Ce,action=Ca}, Sub, St0) -> {Ke,Pe,St1} = atomic(Ce, Sub, St0), %Force this to be atomic! {Rvar,St2} = new_var(St1), @@ -497,15 +496,71 @@ translate_match_fail_1(Anno, As, Sub, #kern{ff=FF}) -> translate_fc(Args) -> [#c_literal{val=function_clause},make_list(Args)]. -%% FIXME: Not completed -map_pairs(Es, Sub, St) -> - foldr(fun - (#c_map_pair{op=#c_literal{val=Op},key=K0,val=V0}, {Kes,Esp,St0}) when - Op =:= assoc; Op =:= exact -> %% assert Op - {K,[],St1} = expr(K0, Sub, St0), - {V,Ep,St2} = atomic(V0, Sub, St1), - {[#k_map_pair{op=Op,key=K,val=V}|Kes],Ep ++ Esp,St2} - end, {[],[],St}, Es). + %{Kes,Ep,St2} = map_pairs(Ces, Sub, St1), +map_split_pairs(A, Var, Ces, Sub, St0) -> + %% two steps + %% 1. force variables + %% 2. remove multiples + Pairs0 = [{Op,K,V} || #c_map_pair{op=#c_literal{val=Op},key=K,val=V} <- Ces], + {Pairs,Esp,St1} = foldr(fun + ({Op,K0,V0}, {Ops,Espi,Sti0}) when Op =:= assoc; Op =:= exact -> + {K,[],Sti1} = expr(K0, Sub, Sti0), + {V,Ep,Sti2} = atomic(V0, Sub, Sti1), + {[{Op,K,V}|Ops],Ep ++ Espi,Sti2} + end, {[],[],St0}, Pairs0), + + case map_group_pairs(Pairs) of + {Assoc,[]} -> + Kes = [#k_map_pair{key=K,val=V}||{_,{assoc,K,V}} <- Assoc], + {#k_map{anno=A,op=assoc,var=Var,es=Kes},Esp,St1}; + {[],Exact} -> + Kes = [#k_map_pair{key=K,val=V}||{_,{exact,K,V}} <- Exact], + {#k_map{anno=A,op=exact,var=Var,es=Kes},Esp,St1}; + {Assoc,Exact} -> + Kes1 = [#k_map_pair{key=K,val=V}||{_,{assoc,K,V}} <- Assoc], + {Mvar,Em,St2} = force_atomic(#k_map{anno=A,op=assoc,var=Var,es=Kes1},St1), + Kes2 = [#k_map_pair{key=K,val=V}||{_,{exact,K,V}} <- Exact], + {#k_map{anno=A,op=exact,var=Mvar,es=Kes2},Em ++ Esp,St2} + + end. + +%% Group map by Assoc operations and Exact operations + +map_group_pairs(Es) -> + Groups = dict:to_list(map_group_pairs(Es,dict:new())), + partition(fun({_,{Op,_,_}}) -> Op =:= assoc end, Groups). + +map_group_pairs([{assoc,K,V}|Es0],Used0) -> + Used1 = case map_key_is_used(K,Used0) of + {ok, {assoc,_,_}} -> map_key_set_used(K,{assoc,K,V},Used0); + {ok, {exact,_,_}} -> map_key_set_used(K,{exact,K,V},Used0); + _ -> map_key_set_used(K,{assoc,K,V},Used0) + end, + map_group_pairs(Es0,Used1); +map_group_pairs([{exact,K,V}|Es0],Used0) -> + Used1 = case map_key_is_used(K,Used0) of + {ok, {assoc,_,_}} -> map_key_set_used(K,{assoc,K,V},Used0); + {ok, {exact,_,_}} -> map_key_set_used(K,{exact,K,V},Used0); + _ -> map_key_set_used(K,{exact,K,V},Used0) + end, + map_group_pairs(Es0,Used1); +map_group_pairs([],Used) -> + Used. + +map_key_set_used(K,How,Used) -> + dict:store(map_key_clean(K),How,Used). + +map_key_is_used(K,Used) -> + dict:find(map_key_clean(K),Used). + +%% Be explicit instead of using set_kanno(K,[]) +map_key_clean(#k_literal{val=V}) -> {k_literal,V}; +map_key_clean(#k_int{val=V}) -> {k_int,V}; +map_key_clean(#k_float{val=V}) -> {k_float,V}; +map_key_clean(#k_atom{val=V}) -> {k_atom,V}; +map_key_clean(#k_nil{}) -> k_nil; +map_key_clean(#k_var{name=V}) -> {k_var,V}. + %% call_type(Module, Function, Arity) -> call | bif | apply | error. %% Classify the call. @@ -664,11 +719,11 @@ pattern(#c_tuple{anno=A,es=Ces}, Isub, Osub0, St0) -> {#k_tuple{anno=A,es=Kes},Osub1,St1}; pattern(#c_map{anno=A,es=Ces}, Isub, Osub0, St0) -> {Kes,Osub1,St1} = pattern_list(Ces, Isub, Osub0, St0), - {#k_map{anno=A,es=Kes},Osub1,St1}; + {#k_map{anno=A,op=exact,es=Kes},Osub1,St1}; pattern(#c_map_pair{op=#c_literal{val=exact},anno=A,key=Ck,val=Cv},Isub, Osub0, St0) -> {Kk,Osub1,St1} = pattern(Ck, Isub, Osub0, St0), {Kv,Osub2,St2} = pattern(Cv, Isub, Osub1, St1), - {#k_map_pair{anno=A,op=exact,key=Kk,val=Kv},Osub2,St2}; + {#k_map_pair{anno=A,key=Kk,val=Kv},Osub2,St2}; pattern(#c_binary{anno=A,segments=Cv}, Isub, Osub0, St0) -> {Kv,Osub1,St1} = pattern_bin(Cv, Isub, Osub0, St0), {#k_binary{anno=A,segs=Kv},Osub1,St1}; @@ -847,15 +902,6 @@ foldr2(Fun, Acc0, [E1|L1], [E2|L2]) -> foldr2(Fun, Acc1, L1, L2); foldr2(_, Acc, [], []) -> Acc. -%% first([A]) -> [A]. -%% last([A]) -> A. - -last([L]) -> L; -last([_|T]) -> last(T). - -first([_]) -> []; -first([H|T]) -> [H|first(T)]. - %% This code implements the algorithm for an optimizing compiler for %% pattern matching given "The Implementation of Functional %% Programming Languages" by Simon Peyton Jones. The code is much @@ -1365,9 +1411,8 @@ new_clauses(Cs0, U, St) -> [S,N|As]; #k_bin_int{next=N} -> [N|As]; - #k_map{es=Es} -> - Vals = [V || - #k_map_pair{op=exact,val=V} <- Es], + #k_map{op=exact,es=Es} -> + Vals = [V || #k_map_pair{val=V} <- Es], Vals ++ As; _Other -> As @@ -1467,9 +1512,9 @@ arg_val(Arg, C) -> _ -> {set_kanno(S, []),U,T,Fs} end; - #k_map{es=Es} -> + #k_map{op=exact,es=Es} -> Keys = [begin - #k_map_pair{op=exact,key=#k_literal{val=Key}} = Pair, + #k_map_pair{key=#k_literal{val=Key}} = Pair, Key end || Pair <- Es], %% multiple keys may have the same name @@ -1885,7 +1930,7 @@ pat_vars(#k_tuple{es=Es}) -> pat_list_vars(Es); pat_vars(#k_map{es=Es}) -> pat_list_vars(Es); -pat_vars(#k_map_pair{op=exact,val=V}) -> +pat_vars(#k_map_pair{val=V}) -> pat_vars(V). pat_list_vars(Ps) -> diff --git a/lib/compiler/src/v3_kernel.hrl b/lib/compiler/src/v3_kernel.hrl index c7886a070d..ab66445f73 100644 --- a/lib/compiler/src/v3_kernel.hrl +++ b/lib/compiler/src/v3_kernel.hrl @@ -38,8 +38,8 @@ -record(k_nil, {anno=[]}). -record(k_tuple, {anno=[],es}). --record(k_map, {anno=[],var,es}). --record(k_map_pair, {anno=[],op,key,val}). +-record(k_map, {anno=[],var,op,es}). +-record(k_map_pair, {anno=[],key,val}). -record(k_cons, {anno=[],hd,tl}). -record(k_binary, {anno=[],segs}). -record(k_bin_seg, {anno=[],size,unit,type,flags,seg,next}). diff --git a/lib/compiler/src/v3_kernel_pp.erl b/lib/compiler/src/v3_kernel_pp.erl index edbd3f74f8..639c6737e2 100644 --- a/lib/compiler/src/v3_kernel_pp.erl +++ b/lib/compiler/src/v3_kernel_pp.erl @@ -110,15 +110,18 @@ format_1(#k_map{var=#k_var{}=Var,es=Es}, Ctxt) -> " | ",format_1(Var, Ctxt), $},$~ ]; -format_1(#k_map{es=Es}, Ctxt) -> - [$~,${, +format_1(#k_map{op=assoc,es=Es}, Ctxt) -> + ["~{", format_hseq(Es, ",", ctxt_bump_indent(Ctxt, 1), fun format/2), - $},$~ + "}~" + ]; +format_1(#k_map{op=exact,es=Es}, Ctxt) -> + ["::{", + format_hseq(Es, ",", ctxt_bump_indent(Ctxt, 1), fun format/2), + "}::" ]; -format_1(#k_map_pair{op=assoc,key=K,val=V}, Ctxt) -> - ["~<",format(K, Ctxt),",",format(V, Ctxt),">"]; -format_1(#k_map_pair{op=exact,key=K,val=V}, Ctxt) -> - ["::<",format(K, Ctxt),",",format(V, Ctxt),">"]; +format_1(#k_map_pair{key=K,val=V}, Ctxt) -> + ["<",format(K, Ctxt),",",format(V, Ctxt),">"]; format_1(#k_binary{segs=S}, Ctxt) -> ["#<",format(S, ctxt_bump_indent(Ctxt, 2)),">#"]; format_1(#k_bin_seg{next=Next}=S, Ctxt) -> diff --git a/lib/compiler/src/v3_life.erl b/lib/compiler/src/v3_life.erl index ae928e955c..c4f54a7970 100644 --- a/lib/compiler/src/v3_life.erl +++ b/lib/compiler/src/v3_life.erl @@ -367,12 +367,10 @@ literal(#k_bin_end{}, Ctxt) -> {bin_end,Ctxt}; literal(#k_tuple{es=Es}, Ctxt) -> {tuple,literal_list(Es, Ctxt)}; -literal(#k_map{var=Var,es=Es}, Ctxt) -> - {map,literal(Var, Ctxt),literal_list(Es, Ctxt)}; -literal(#k_map_pair{op=assoc,key=K,val=V}, Ctxt) -> - {map_pair_assoc,literal(K, Ctxt),literal(V, Ctxt)}; -literal(#k_map_pair{op=exact,key=K,val=V}, Ctxt) -> - {map_pair_exact,literal(K, Ctxt),literal(V, Ctxt)}; +literal(#k_map{op=Op,var=Var,es=Es}, Ctxt) -> + {map,Op,literal(Var, Ctxt),literal_list(Es, Ctxt)}; +literal(#k_map_pair{key=K,val=V}, Ctxt) -> + {map_pair,literal(K, Ctxt),literal(V, Ctxt)}; literal(#k_literal{val=V}, _Ctxt) -> {literal,V}. @@ -402,8 +400,8 @@ literal2(#k_bin_end{}, Ctxt) -> {bin_end,Ctxt}; literal2(#k_tuple{es=Es}, Ctxt) -> {tuple,literal_list2(Es, Ctxt)}; -literal2(#k_map{es=Es}, Ctxt) -> - {map,literal_list2(Es, Ctxt)}; +literal2(#k_map{op=Op,es=Es}, Ctxt) -> + {map,Op,literal_list2(Es, Ctxt)}; literal2(#k_map_pair{key=K,val=V}, Ctxt) -> {map_pair,literal2(K, Ctxt),literal2(V, Ctxt)}. |