diff --git a/lib/compiler/src/sys_core_fold.erl b/lib/compiler/src/sys_core_fold.erl index a9bab7fe6ede..5f62e2cfdb63 100644 --- a/lib/compiler/src/sys_core_fold.erl +++ b/lib/compiler/src/sys_core_fold.erl @@ -2296,6 +2296,97 @@ opt_lc_fun_body(Core, Name, Iterate) -> Other end, Core). +%% opt_lc_append(VarName, Arg, Body) -> {ok, Core} | error. +%% Detect: let V = letrec{LC} in erlang:'++'(V, Tail) +%% Transform: fuse Tail into the LC's base case, eliminating ++. +opt_lc_append(V, Arg, Body) -> + maybe + #c_call{module=#c_literal{val=Mod}, + name=#c_literal{val=Name}, + args=[#c_var{name=V}, Tail]} ?= Body, + true ?= is_append_call(Mod, Name), + #c_letrec{anno=Anno,defs=[{FNameVar, Fun}], + body=LetrecBody} ?= Arg, + true ?= lists:member(list_comprehension, Anno), + false ?= core_lib:is_var_used(V, Tail), + fuse_lc_tail(Arg, FNameVar, Fun, LetrecBody, Tail) + else + _ -> error + end. + +is_append_call(erlang, '++') -> true; +is_append_call(lists, append) -> true; +is_append_call(_, _) -> false. + +%% fuse_lc_tail(Letrec, FNameVar, Fun, LetrecBody, Tail) -> +%% {ok, NewLetrec} | error. +%% Rewrite a list comprehension letrec to use Tail as the base case +%% instead of [], eliminating the need for a ++ call. +fuse_lc_tail(Letrec, FNameVar, Fun, LetrecBody, Tail) -> + try + maybe + #c_var{name={FName, Arity}=Name} ?= FNameVar, + #c_fun{vars=FunVars, body=FunBody} ?= Fun, + TailVar = make_var(cerl:get_ann(FNameVar)), + NewName = {FName, Arity + 1}, + NewFNameVar = FNameVar#c_var{name=NewName}, + {ok, NewFunBody} ?= rewrite_lc_body(FunBody, Name, NewName, TailVar), + NewFun = Fun#c_fun{vars=FunVars ++ [TailVar], body=NewFunBody}, + NewLetrecBody = rewrite_lc_apply(LetrecBody, Name, NewName, Tail), + {ok, Letrec#c_letrec{defs=[{NewFNameVar, NewFun}], + body=NewLetrecBody}} + else + _ -> error + end + catch + throw:not_possible -> error + end. + +rewrite_lc_body(#c_case{clauses=Clauses0}=Case, OldName, NewName, TailVar) -> + maybe + {ok, Clauses} ?= rewrite_lc_clauses(Clauses0, OldName, NewName, TailVar), + {ok, Case#c_case{clauses=Clauses}} + end; +rewrite_lc_body(_, _, _, _) -> + error. + +rewrite_lc_clauses(Clauses, OldName, NewName, TailVar) -> + rewrite_lc_clauses(Clauses, OldName, NewName, TailVar, [], false). + +rewrite_lc_clauses([#c_clause{pats=[#c_literal{val=[]}], + body=#c_literal{val=[]}}=C|Rest], + OldName, NewName, TailVar, Acc, _FoundBase) -> + NewC = C#c_clause{body=TailVar}, + rewrite_lc_clauses(Rest, OldName, NewName, TailVar, [NewC|Acc], true); +rewrite_lc_clauses([C0|Rest], OldName, NewName, TailVar, Acc, FoundBase) -> + Body0 = C0#c_clause.body, + Body = rewrite_lc_applies(Body0, OldName, NewName, TailVar), + C = C0#c_clause{body=Body}, + rewrite_lc_clauses(Rest, OldName, NewName, TailVar, [C|Acc], FoundBase); +rewrite_lc_clauses([], _OldName, _NewName, _TailVar, Acc, true) -> + {ok, lists:reverse(Acc)}; +rewrite_lc_clauses([], _OldName, _NewName, _TailVar, _Acc, false) -> + error. + +rewrite_lc_applies(Core, OldName, NewName, TailVar) -> + cerl_trees:map(fun(#c_apply{op=#c_var{name=OldName0}=Op, args=Args}=Apply) + when OldName0 =:= OldName -> + Apply#c_apply{op=Op#c_var{name=NewName}, + args=Args ++ [TailVar]}; + (Other) -> + Other + end, Core). + +rewrite_lc_apply(#c_apply{op=#c_var{name=OldName}=Op, args=Args}=Apply, + OldName, NewName, Tail) -> + Apply#c_apply{op=Op#c_var{name=NewName}, args=Args ++ [Tail]}; +rewrite_lc_apply(#c_let{body=Body0}=Let, OldName, NewName, Tail) -> + Let#c_let{body=rewrite_lc_apply(Body0, OldName, NewName, Tail)}; +rewrite_lc_apply(#c_seq{body=Body0}=Seq, OldName, NewName, Tail) -> + Seq#c_seq{body=rewrite_lc_apply(Body0, OldName, NewName, Tail)}; +rewrite_lc_apply(_, _, _, _) -> + throw(not_possible). + %% is_simple_case_arg(Expr) -> true|false %% Determine whether the Expr is simple enough to be worth %% substituting into a case argument. (Common substitutions @@ -2674,8 +2765,13 @@ opt_let_2(Let0, Vs0, Arg0, Body, PrevBody, Sub) -> Arg = maybe_suppress_warnings(Arg1, Var, PrevBody), #c_seq{arg=Arg,body=Body}; true -> - Let1 = Let0#c_let{vars=Vars0,arg=Arg1,body=Body}, - post_opt_let(Let1, Sub) + case opt_lc_append(V, Arg1, Body) of + {ok, Fused} -> + Fused; + error -> + Let1 = Let0#c_let{vars=Vars0,arg=Arg1,body=Body}, + post_opt_let(Let1, Sub) + end end; {_,_,_} -> %% The argument for a sequence must be a single value (not diff --git a/lib/compiler/src/v3_core.erl b/lib/compiler/src/v3_core.erl index 13e7a8d8d2ad..d6933fd64483 100644 --- a/lib/compiler/src/v3_core.erl +++ b/lib/compiler/src/v3_core.erl @@ -978,17 +978,6 @@ expr({record_field=Op,Loc,Src0,Id,F0}, St0) -> args=[Src,#c_literal{val=Id},F]}, Aps = Aps0 ++ Aps1, {PrimOp,Aps,St2}; -expr({op,_,'++',{lc,Llc,E,Qs0},More}, St0) -> - %% Optimise '++' here because of the list comprehension algorithm. - %% - %% To avoid achieving quadratic complexity if there is a chain of - %% list comprehensions without generators combined with '++', force - %% evaluation of More now. Evaluating More here could also reduce the - %% number variables in the environment for letrec. - {Mc,Mps,St1} = safe(More, St0), - {Qs,St2} = preprocess_quals(Llc, Qs0, St1), - {Y,Yps,_OptInfo,St} = lc_tq(Llc, {lc, wrap_list(E)}, Qs, Mc, St2), - {Y,Mps++Yps,St}; expr({op,_,'andalso',_,_}=E0, St0) -> {op,L,'andalso',E1,E2} = right_assoc(E0, 'andalso'), Anno = lineno_anno(L, St0), diff --git a/lib/compiler/test/core_fold_SUITE.erl b/lib/compiler/test/core_fold_SUITE.erl index 8cb22c9575b8..5a80ae66fa6f 100644 --- a/lib/compiler/test/core_fold_SUITE.erl +++ b/lib/compiler/test/core_fold_SUITE.erl @@ -21,7 +21,7 @@ %% -module(core_fold_SUITE). --export([all/0, suite/0,groups/0,init_per_suite/1, end_per_suite/1, +-export([all/0, suite/0,groups/0,init_per_suite/1, end_per_suite/1, init_per_group/2,end_per_group/2, t_element/1,setelement/1,t_length/1,append/1,t_apply/1,bifs/1, eq/1,nested_call_in_case/1,guard_try_catch/1,coverage/1, @@ -32,7 +32,7 @@ redundant_stack_frame/1,export_from_case/1, empty_values/1,cover_letrec_effect/1, receive_effect/1,nested_lets/1, - map_effect/1]). + map_effect/1,lc_append/1]). -export([foo/0,foo/1,foo/2,foo/3]). @@ -55,7 +55,7 @@ groups() -> redundant_stack_frame,export_from_case, empty_values,cover_letrec_effect, receive_effect,nested_lets, - map_effect]}]. + map_effect,lc_append]}]. init_per_suite(Config) -> test_lib:recompile(?MODULE), @@ -875,6 +875,49 @@ map_effect_2(Map) -> Map#{key := value}, ok. +lc_append(_Config) -> + %% Basic: intermediate variable LC ++ Tail + [1,2,3,4,5] = lc_append_var([1,2,3], [4,5]), + [4,5] = lc_append_var([], [4,5]), + [1,2,3] = lc_append_var([1,2,3], []), + [] = lc_append_var([], []), + + %% Inline: [E || Qs] ++ Tail + [1,2,3,4,5] = lc_append_inline([1,2,3], [4,5]), + [4,5] = lc_append_inline([], [4,5]), + + %% With filter + [2,3,4,5] = lc_append_filter([1,2,3], [4,5]), + + %% Multi-use variable must NOT be optimized (still correct) + [1,2,3,4,5] = lc_append_multi_use([1,2,3], [4,5]), + + %% Multi-generator + [{1,a},{1,b},{2,a},{2,b},done] = + lc_append_multi_gen([1,2], [a,b], [done]), + + ok. + +lc_append_var(List, Tail) -> + Expanded = id([X || X <- List]), + Expanded ++ Tail. + +lc_append_inline(List, Tail) -> + [X || X <- List] ++ Tail. + +lc_append_filter(List, Tail) -> + Expanded = id([X || X <- List, X > 1]), + Expanded ++ Tail. + +lc_append_multi_use(List, Tail) -> + Expanded = id([X || X <- List]), + _ = length(Expanded), + Expanded ++ Tail. + +lc_append_multi_gen(L1, L2, Tail) -> + Expanded = id([{X,Y} || X <- L1, Y <- L2]), + Expanded ++ Tail. + %%% Common utility functions. id(I) -> I.