diff options
Diffstat (limited to 'lib/dialyzer/src/cerl_pmatch.erl')
| -rw-r--r-- | lib/dialyzer/src/cerl_pmatch.erl | 620 |
1 files changed, 0 insertions, 620 deletions
diff --git a/lib/dialyzer/src/cerl_pmatch.erl b/lib/dialyzer/src/cerl_pmatch.erl deleted file mode 100644 index 66fce3c8eb..0000000000 --- a/lib/dialyzer/src/cerl_pmatch.erl +++ /dev/null @@ -1,620 +0,0 @@ -%% 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. -%% -%% @copyright 2000-2006 Richard Carlsson -%% @author Richard Carlsson <carlsson.richard@gmail.com> -%% -%% @doc Core Erlang pattern matching compiler. -%% -%% <p>For reference, see Simon L. Peyton Jones "The Implementation of -%% Functional Programming Languages", chapter 5 (by Phil Wadler).</p> -%% -%% @type cerl() = cerl:cerl(). -%% Abstract Core Erlang syntax trees. -%% @type cerl_records() = cerl:cerl_records(). -%% An explicit record representation of Core Erlang syntax trees. - --module(cerl_pmatch). - -%%-define(NO_UNUSED, true). - --export([clauses/2]). --ifndef(NO_UNUSED). --export([transform/2, core_transform/2, expr/2]). --endif. - --import(lists, [all/2, splitwith/2, foldr/3, keysort/2, foldl/3, - mapfoldl/3]). - --define(binary_id, {binary}). --define(cons_id, {cons}). --define(tuple_id, {tuple}). --define(literal_id(V), V). - - -%% @spec core_transform(Module::cerl_records(), Options::[term()]) -> -%% cerl_records() -%% -%% @doc Transforms a module represented by records. See -%% <code>transform/2</code> for details. -%% -%% <p>Use the compiler option <code>{core_transform, cerl_pmatch}</code> -%% to insert this function as a compilation pass.</p> -%% -%% @see transform/2 - --ifndef(NO_UNUSED). --spec core_transform(cerl:c_module(), [_]) -> cerl:c_module(). - -core_transform(M, Opts) -> - cerl:to_records(transform(cerl:from_records(M), Opts)). --endif. % NO_UNUSED -%% @clear - - -%% @spec transform(Module::cerl(), Options::[term()]) -> cerl() -%% -%% @doc Rewrites all <code>case</code>-clauses in <code>Module</code>. -%% <code>receive</code>-clauses are not affected. Currently, no options -%% are available. -%% -%% @see clauses/2 -%% @see expr/2 -%% @see core_transform/2 - --ifndef(NO_UNUSED). --spec transform(cerl:cerl(), [_]) -> cerl:cerl(). - -transform(M, _Opts) -> - expr(M, env__empty()). --endif. % NO_UNUSED -%% @clear - - -%% @spec clauses(Clauses::[Clause], Env) -> {Expr, Vars} -%% Clause = cerl() -%% Expr = cerl() -%% Vars = [cerl()] -%% Env = rec_env:environment() -%% -%% @doc Rewrites a sequence of clauses to an equivalent expression, -%% removing as much repeated testing as possible. Returns a pair -%% <code>{Expr, Vars}</code>, where <code>Expr</code> is the resulting -%% expression, and <code>Vars</code> is a list of new variables (i.e., -%% not already in the given environment) to be bound to the arguments to -%% the switch. The following is a typical example (assuming -%% <code>E</code> is a Core Erlang case expression): -%% <pre> -%% handle_case(E, Env) -> -%% Cs = case_clauses(E), -%% {E1, Vs} = cerl_pmatch(Cs, Env), -%% c_let(Vs, case_arg(E), E1). -%% </pre> -%% -%% <p>The environment is used for generating new variables which do not -%% shadow existing bindings.</p> -%% -%% @see rec_env -%% @see expr/2 -%% @see transform/2 - --spec clauses([cerl:cerl(),...], rec_env:environment()) -> - {cerl:cerl(), [cerl:cerl()]}. - -clauses(Cs, Env) -> - clauses(Cs, none, Env). - -clauses([C | _] = Cs, Else, Env) -> - Vs = new_vars(cerl:clause_arity(C), Env), - E = match(Vs, Cs, Else, add_vars(Vs, Env)), - {E, Vs}. - -%% The implementation very closely follows that described in the book. - -match([], Cs, Else, _Env) -> - %% If the "default action" is the atom 'none', it is simply not - %% added; otherwise it is put in the body of a final catch-all - %% clause (which is often removed by the below optimization). - Cs1 = if Else =:= none -> Cs; - true -> Cs ++ [cerl:c_clause([], Else)] - end, - %% This clause reduction is an important optimization. It selects a - %% clause body if possible, and otherwise just removes dead clauses. - case cerl_clauses:reduce(Cs1) of - {true, {C, []}} -> % if we get bindings, something is wrong! - cerl:clause_body(C); - {false, Cs2} -> - %% This happens when guards are nontrivial. - cerl:c_case(cerl:c_values([]), Cs2) - end; -match([V | _] = Vs, Cs, Else, Env) -> - foldr(fun (CsF, ElseF) -> - match_var_con(Vs, CsF, ElseF, Env) - end, - Else, - group([unalias(C, V) || C <- Cs], fun is_var_clause/1)). - -group([], _F) -> - []; -group([X | _] = Xs, F) -> - group(Xs, F, F(X)). - -group(Xs, F, P) -> - {First, Rest} = splitwith(fun (X) -> F(X) =:= P end, Xs), - [First | group(Rest, F)]. - -is_var_clause(C) -> - cerl:is_c_var(hd(cerl:clause_pats(C))). - -%% To avoid code duplication, if the 'Else' expression is too big, we -%% put it in a local function definition instead, and replace it with a -%% call. (Note that it is important that 'is_lightweight' does not yield -%% 'true' for a simple function application, or we will create a lot of -%% unnecessary extra functions.) - -match_var_con(Vs, Cs, none = Else, Env) -> - match_var_con_1(Vs, Cs, Else, Env); -match_var_con(Vs, Cs, Else, Env) -> - case is_lightweight(Else) of - true -> - match_var_con_1(Vs, Cs, Else, Env); - false -> - F = new_fvar("match_", 0, Env), - Else1 = cerl:c_apply(F, []), - Env1 = add_vars([F], Env), - cerl:c_letrec([{F, cerl:c_fun([], Else)}], - match_var_con_1(Vs, Cs, Else1, Env1)) - end. - -match_var_con_1(Vs, Cs, Else, Env) -> - case is_var_clause(hd(Cs)) of - true -> - match_var(Vs, Cs, Else, Env); - false -> - match_con(Vs, Cs, Else, Env) - end. - -match_var([V | Vs], Cs, Else, Env) -> - Cs1 = [begin - [P | Ps] = cerl:clause_pats(C), - G = make_let([P], V, cerl:clause_guard(C)), - B = make_let([P], V, cerl:clause_body(C)), - cerl:update_c_clause(C, Ps, G, B) - end - || C <- Cs], - match(Vs, Cs1, Else, Env). - -%% Since Erlang is dynamically typed, we must include the possibility -%% that none of the constructors in the group will match, and in that -%% case the "Else" code will be executed (unless it is 'none'), in the -%% body of a final catch-all clause. - -match_con([V | Vs], Cs, Else, Env) -> - case group_con(Cs) of - [{_, _, Gs}] -> - %% Don't create a group type switch if there is only one - %% such group - make_switch(V, [match_congroup(DG, Vs, CsG, Else, Env) - || {DG, _, CsG} <- Gs], - Else, Env); - Ts -> - Cs1 = [match_typegroup(T, V, Vs, Gs, Else, Env) - || {T, _, Gs} <- Ts], - make_switch(V, Cs1, Else, Env) - end. - - -match_typegroup(_T, _V, Vs, [{D, _, Cs}], Else, Env) when element(1, D) /= ?binary_id -> - %% Don't create a group type switch if there is only one constructor - %% in the group. (Note that this always happens for '[]'.) - %% Special case for binaries which always get a group switch - match_congroup(D, Vs, Cs, Else, Env); -match_typegroup(T, V, Vs, Gs, Else, Env) -> - Body = make_switch(V, [match_congroup(D, Vs, Cs, Else, Env) - || {D, _, Cs} <- Gs], - Else, Env), - typetest_clause(T, V, Body, Env). - -match_congroup({?binary_id, Segs}, Vs, Cs, Else, Env) -> - Body = match(Vs, Cs, Else, Env), - cerl:c_clause([make_pat(?binary_id, Segs)], Body); - -match_congroup({D, A}, Vs, Cs, Else, Env) -> - Vs1 = new_vars(A, Env), - Body = match(Vs1 ++ Vs, Cs, Else, add_vars(Vs1, Env)), - cerl:c_clause([make_pat(D, Vs1)], Body). - -make_switch(V, Cs, Else, Env) -> - cerl:c_case(V, if Else =:= none -> Cs; - true -> Cs ++ [cerl:c_clause([new_var(Env)], - Else)] - end). - -%% We preserve the relative order of different-type constructors as they -%% were originally listed. This is done by tracking the clause numbers. - -group_con(Cs) -> - {Cs1, _} = mapfoldl(fun (C, N) -> - [P | Ps] = cerl:clause_pats(C), - Ps1 = sub_pats(P) ++ Ps, - G = cerl:clause_guard(C), - B = cerl:clause_body(C), - C1 = cerl:update_c_clause(C, Ps1, G, B), - D = con_desc(P), - {{D, N, C1}, N + 1} - end, - 0, Cs), - %% Sort and group constructors. - Css = group(keysort(1, Cs1), fun ({D,_,_}) -> D end), - %% Sort each group "back" by line number, and move the descriptor - %% and line number to the wrapper for the group. - Gs = [finalize_congroup(C) || C <- Css], - %% Group by type only (put e.g. different-arity tuples together). - Gss = group(Gs, fun ({D,_,_}) -> con_desc_type(D) end), - %% Sort and wrap the type groups. - Ts = [finalize_typegroup(G) || G <- Gss], - %% Sort type-groups by first clause order - keysort(2, Ts). - -finalize_congroup(Cs) -> - [{D,N,_}|_] = Cs1 = keysort(2, Cs), - {D, N, [C || {_,_,C} <- Cs1]}. - -finalize_typegroup(Gs) -> - [{D,N,_}|_] = Gs1 = keysort(2, Gs), - {con_desc_type(D), N, Gs1}. - -%% Since Erlang clause patterns can contain "alias patterns", we must -%% eliminate these, by turning them into let-definitions in the guards -%% and bodies of the clauses. - -unalias(C, V) -> - [P | Ps] = cerl:clause_pats(C), - B = cerl:clause_body(C), - G = cerl:clause_guard(C), - unalias(P, V, Ps, B, G, C). - -unalias(P, V, Ps, B, G, C) -> - case cerl:type(P) of - alias -> - V1 = cerl:alias_var(P), - B1 = make_let([V1], V, B), - G1 = make_let([V1], V, G), - unalias(cerl:alias_pat(P), V, Ps, B1, G1, C); - _ -> - cerl:update_c_clause(C, [P | Ps], G, B) - end. - -%% Generating a type-switch clause - -typetest_clause([], _V, E, _Env) -> - cerl:c_clause([cerl:c_nil()], E); -typetest_clause(atom, V, E, _Env) -> - typetest_clause_1(is_atom, V, E); -typetest_clause(integer, V, E, _Env) -> - typetest_clause_1(is_integer, V, E); -typetest_clause(float, V, E, _Env) -> - typetest_clause_1(is_float, V, E); -typetest_clause(cons, _V, E, Env) -> - [V1, V2] = new_vars(2, Env), - cerl:c_clause([cerl:c_cons(V1, V2)], E); % there is no 'is cons' -typetest_clause(tuple, V, E, _Env) -> - typetest_clause_1(is_tuple, V, E); -typetest_clause(binary, V, E, _Env) -> - typetest_clause_1(is_binary, V, E). - -typetest_clause_1(T, V, E) -> - cerl:c_clause([V], cerl:c_call(cerl:c_atom('erlang'), - cerl:c_atom(T), [V]), E). - -%% This returns a constructor descriptor, to be used for grouping and -%% pattern generation. It consists of an identifier term and the arity. - -con_desc(E) -> - case cerl:type(E) of - cons -> {?cons_id, 2}; - tuple -> {?tuple_id, cerl:tuple_arity(E)}; - binary -> {?binary_id, cerl:binary_segments(E)}; - literal -> - case cerl:concrete(E) of - [_|_] -> {?cons_id, 2}; - T when is_tuple(T) -> {?tuple_id, tuple_size(T)}; - V -> {?literal_id(V), 0} - end; - _ -> - throw({bad_constructor, E}) - end. - -%% This returns the type class for a constructor descriptor, for -%% grouping of clauses. It does not distinguish between tuples of -%% different arity, nor between different values of atoms, integers and -%% floats. - -con_desc_type({?literal_id([]), _}) -> []; -con_desc_type({?literal_id(V), _}) when is_atom(V) -> atom; -con_desc_type({?literal_id(V), _}) when is_integer(V) -> integer; -con_desc_type({?literal_id(V), _}) when is_float(V) -> float; -con_desc_type({?cons_id, 2}) -> cons; -con_desc_type({?tuple_id, _}) -> tuple; -con_desc_type({?binary_id, _}) -> binary. - -%% This creates a new constructor pattern from a type descriptor and a -%% list of variables. - -make_pat(?cons_id, [V1, V2]) -> cerl:c_cons(V1, V2); -make_pat(?tuple_id, Vs) -> cerl:c_tuple(Vs); -make_pat(?binary_id, Segs) -> cerl:c_binary(Segs); -make_pat(?literal_id(Val), []) -> cerl:abstract(Val). - -%% This returns the list of subpatterns of a constructor pattern. - -sub_pats(E) -> - case cerl:type(E) of - cons -> - [cerl:cons_hd(E), cerl:cons_tl(E)]; - tuple -> - cerl:tuple_es(E); - binary -> - []; - literal -> - case cerl:concrete(E) of - [H|T] -> [cerl:abstract(H), cerl:abstract(T)]; - T when is_tuple(T) -> [cerl:abstract(X) - || X <- tuple_to_list(T)]; - _ -> [] - end; - _ -> - throw({bad_constructor_pattern, E}) - end. - -%% This avoids generating stupid things like "let X = ... in 'true'", -%% and "let X = Y in X", keeping the generated code cleaner. It also -%% prevents expressions from being considered "non-lightweight" when -%% code duplication is disallowed (see is_lightweight for details). - -make_let(Vs, A, B) -> - cerl_lib:reduce_expr(cerl:c_let(Vs, A, B)). - -%% --------------------------------------------------------------------- -%% Rewriting a module or other expression: - -%% @spec expr(Expression::cerl(), Env) -> cerl() -%% Env = rec_env:environment() -%% -%% @doc Rewrites all <code>case</code>-clauses in -%% <code>Expression</code>. <code>receive</code>-clauses are not -%% affected. -%% -%% <p>The environment is used for generating new variables which do not -%% shadow existing bindings.</p> -%% -%% @see clauses/2 -%% @see rec_env - --ifndef(NO_UNUSED). --spec expr(cerl:cerl(), rec_env:environment()) -> cerl:cerl(). - -expr(E, Env) -> - case cerl:type(E) of - binary -> - Es = expr_list(cerl:binary_segments(E), Env), - cerl:update_c_binary(E, Es); - bitstr -> - V = expr(cerl:bitstr_val(E), Env), - Sz = expr(cerl:bitstr_size(E), Env), - Unit = expr(cerl:bitstr_unit(E), Env), - Type = expr(cerl:bitstr_type(E), Env), - cerl:update_c_bitstr(E, V, Sz, Unit, Type, cerl:bitstr_flags(E)); - literal -> - E; - var -> - E; - values -> - Es = expr_list(cerl:values_es(E), Env), - cerl:update_c_values(E, Es); - cons -> - H = expr(cerl:cons_hd(E), Env), - T = expr(cerl:cons_tl(E), Env), - cerl:update_c_cons(E, H, T); - tuple -> - Es = expr_list(cerl:tuple_es(E), Env), - cerl:update_c_tuple(E, Es); - 'let' -> - A = expr(cerl:let_arg(E), Env), - Vs = cerl:let_vars(E), - Env1 = add_vars(Vs, Env), - B = expr(cerl:let_body(E), Env1), - cerl:update_c_let(E, Vs, A, B); - seq -> - A = expr(cerl:seq_arg(E), Env), - B = expr(cerl:seq_body(E), Env), - cerl:update_c_seq(E, A, B); - apply -> - Op = expr(cerl:apply_op(E), Env), - As = expr_list(cerl:apply_args(E), Env), - cerl:update_c_apply(E, Op, As); - call -> - M = expr(cerl:call_module(E), Env), - N = expr(cerl:call_name(E), Env), - As = expr_list(cerl:call_args(E), Env), - cerl:update_c_call(E, M, N, As); - primop -> - As = expr_list(cerl:primop_args(E), Env), - cerl:update_c_primop(E, cerl:primop_name(E), As); - 'case' -> - A = expr(cerl:case_arg(E), Env), - Cs = expr_list(cerl:case_clauses(E), Env), - {E1, Vs} = clauses(Cs, Env), - make_let(Vs, A, E1); - clause -> - Vs = cerl:clause_vars(E), - Env1 = add_vars(Vs, Env), - G = expr(cerl:clause_guard(E), Env1), - B = expr(cerl:clause_body(E), Env1), - cerl:update_c_clause(E, cerl:clause_pats(E), G, B); - 'fun' -> - Vs = cerl:fun_vars(E), - Env1 = add_vars(Vs, Env), - B = expr(cerl:fun_body(E), Env1), - cerl:update_c_fun(E, Vs, B); - 'receive' -> - %% NOTE: No pattern matching compilation is done here! The - %% receive-clauses and patterns cannot be staged as long as - %% we are working with "normal" Core Erlang. - Cs = expr_list(cerl:receive_clauses(E), Env), - T = expr(cerl:receive_timeout(E), Env), - A = expr(cerl:receive_action(E), Env), - cerl:update_c_receive(E, Cs, T, A); - 'try' -> - A = expr(cerl:try_arg(E), Env), - Vs = cerl:try_vars(E), - B = expr(cerl:try_body(E), add_vars(Vs, Env)), - Evs = cerl:try_evars(E), - H = expr(cerl:try_handler(E), add_vars(Evs, Env)), - cerl:update_c_try(E, A, Vs, B, Evs, H); - 'catch' -> - B = expr(cerl:catch_body(E), Env), - cerl:update_c_catch(E, B); - letrec -> - Ds = cerl:letrec_defs(E), - Env1 = add_defs(Ds, Env), - Ds1 = defs(Ds, Env1), - B = expr(cerl:letrec_body(E), Env1), - cerl:update_c_letrec(E, Ds1, B); - module -> - Ds = cerl:module_defs(E), - Env1 = add_defs(Ds, Env), - Ds1 = defs(Ds, Env1), - cerl:update_c_module(E, cerl:module_name(E), - cerl:module_exports(E), - cerl:module_attrs(E), Ds1) - end. - -expr_list(Es, Env) -> - [expr(E, Env) || E <- Es]. - -defs(Ds, Env) -> - [{V, expr(F, Env)} || {V, F} <- Ds]. --endif. % NO_UNUSED -%% @clear - -%% --------------------------------------------------------------------- -%% Support functions - -new_var(Env) -> - Name = env__new_vname(Env), - cerl:c_var(Name). - -new_vars(N, Env) -> - [cerl:c_var(V) || V <- env__new_vnames(N, Env)]. - -new_fvar(A, N, Env) -> - Name = env__new_fname(A, N, Env), - cerl:c_var(Name). - -add_vars(Vs, Env) -> - foldl(fun (V, E) -> env__bind(cerl:var_name(V), [], E) end, Env, Vs). - --ifndef(NO_UNUSED). -add_defs(Ds, Env) -> - foldl(fun ({V, _F}, E) -> - env__bind(cerl:var_name(V), [], E) - end, Env, Ds). --endif. % NO_UNUSED - -%% This decides whether an expression is worth lifting out to a separate -%% function instead of duplicating the code. In other words, whether its -%% cost is about the same or smaller than that of a local function call. -%% Note that variables must always be "lightweight"; otherwise, they may -%% get lifted out of the case switch that introduces them. - -is_lightweight(E) -> - case get('cerl_pmatch_duplicate_code') of - never -> cerl:type(E) =:= var; % Avoids all code duplication - always -> true; % Does not lift code to new functions - _ -> is_lightweight_1(E) - end. - -is_lightweight_1(E) -> - case cerl:type(E) of - var -> true; - literal -> true; - 'fun' -> true; - values -> all(fun is_simple/1, cerl:values_es(E)); - cons -> is_simple(cerl:cons_hd(E)) - andalso is_simple(cerl:cons_tl(E)); - tuple -> all(fun is_simple/1, cerl:tuple_es(E)); - 'let' -> (is_simple(cerl:let_arg(E)) andalso - is_lightweight_1(cerl:let_body(E))); - seq -> (is_simple(cerl:seq_arg(E)) andalso - is_lightweight_1(cerl:seq_body(E))); - primop -> - all(fun is_simple/1, cerl:primop_args(E)); - apply -> - is_simple(cerl:apply_op(E)) - andalso all(fun is_simple/1, cerl:apply_args(E)); - call -> - is_simple(cerl:call_module(E)) - andalso is_simple(cerl:call_name(E)) - andalso all(fun is_simple/1, cerl:call_args(E)); - _ -> - %% The default is to lift the code to a new function. - false - end. - -%% "Simple" things have no (or negligible) runtime cost and are free -%% from side effects. - -is_simple(E) -> - case cerl:type(E) of - var -> true; - literal -> true; - values -> all(fun is_simple/1, cerl:values_es(E)); - _ -> false - end. - - -%% --------------------------------------------------------------------- -%% Abstract datatype: environment() - -env__bind(Key, Val, Env) -> - rec_env:bind(Key, Val, Env). - --ifndef(NO_UNUSED). -%% env__bind_recursive(Ks, Vs, F, Env) -> -%% rec_env:bind_recursive(Ks, Vs, F, Env). - -%% env__lookup(Key, Env) -> -%% rec_env:lookup(Key, Env). - -%% env__get(Key, Env) -> -%% rec_env:get(Key, Env). - -%% env__is_defined(Key, Env) -> -%% rec_env:is_defined(Key, Env). - -env__empty() -> - rec_env:empty(). --endif. % NO_UNUSED - -env__new_vname(Env) -> - rec_env:new_key(Env). - -env__new_vnames(N, Env) -> - rec_env:new_keys(N, Env). - -env__new_fname(F, A, Env) -> - rec_env:new_key(fun (X) -> - S = integer_to_list(X), - {list_to_atom(F ++ S), A} - end, - Env). |