File 2018-Remove-unused-cerl_-modules.patch of Package erlang
From c91eaa17e235ec2e9acbb922f2b3bacd792d488f Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Bj=C3=B6rn=20Gustavsson?= <bjorn@erlang.org>
Date: Fri, 17 Sep 2021 08:39:39 +0200
Subject: [PATCH 18/20] Remove unused cerl_* modules
---
lib/dialyzer/src/Makefile | 4 -
lib/dialyzer/src/cerl_closurean.erl | 856 ------------------------
lib/dialyzer/src/cerl_lib.erl | 457 -------------
lib/dialyzer/src/cerl_pmatch.erl | 620 -----------------
lib/dialyzer/src/cerl_typean.erl | 994 ----------------------------
lib/dialyzer/src/dialyzer.app.src | 6 +-
6 files changed, 1 insertion(+), 2936 deletions(-)
delete mode 100644 lib/dialyzer/src/cerl_closurean.erl
delete mode 100644 lib/dialyzer/src/cerl_lib.erl
delete mode 100644 lib/dialyzer/src/cerl_pmatch.erl
delete mode 100644 lib/dialyzer/src/cerl_typean.erl
diff --git a/lib/dialyzer/src/Makefile b/lib/dialyzer/src/Makefile
index 0847da9d5a..5e69bd147e 100644
--- a/lib/dialyzer/src/Makefile
+++ b/lib/dialyzer/src/Makefile
@@ -47,11 +47,7 @@ DIALYZER_DIR = $(ERL_TOP)/lib/dialyzer
# Target Specs
# ----------------------------------------------------
MODULES = \
- cerl_closurean \
- cerl_lib \
- cerl_pmatch \
cerl_prettypr \
- cerl_typean \
dialyzer \
dialyzer_analysis_callgraph \
dialyzer_behaviours \
diff --git a/lib/dialyzer/src/cerl_closurean.erl b/lib/dialyzer/src/cerl_closurean.erl
deleted file mode 100644
index e4718cb819..0000000000
--- a/lib/dialyzer/src/cerl_closurean.erl
+++ /dev/null
@@ -1,856 +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 2001-2002 Richard Carlsson
-%% @author Richard Carlsson <carlsson.richard@gmail.com>
-%% @doc Closure analysis of Core Erlang programs.
-
-%% TODO: might need a "top" (`any') element for any-length value lists.
-
--module(cerl_closurean).
-
--export([analyze/1, annotate/1]).
-%% The following functions are exported from this module since they
-%% are also used by Dialyzer (file dialyzer/src/dialyzer_dep.erl)
--export([is_escape_op/2, is_escape_op/3, is_literal_op/2, is_literal_op/3]).
-
--import(cerl, [ann_c_apply/3, ann_c_fun/3, ann_c_var/2, apply_args/1,
- apply_op/1, atom_val/1, bitstr_size/1, bitstr_val/1,
- binary_segments/1, c_letrec/2, c_seq/2, c_tuple/1,
- c_nil/0, call_args/1, call_module/1, call_name/1,
- case_arg/1, case_clauses/1, catch_body/1, clause_body/1,
- clause_guard/1, clause_pats/1, cons_hd/1, cons_tl/1,
- fun_body/1, fun_vars/1, get_ann/1, is_c_atom/1,
- let_arg/1, let_body/1, let_vars/1, letrec_body/1,
- letrec_defs/1, module_defs/1, module_defs/1,
- module_exports/1, pat_vars/1, primop_args/1,
- primop_name/1, receive_action/1, receive_clauses/1,
- receive_timeout/1, seq_arg/1, seq_body/1, set_ann/2,
- try_arg/1, try_body/1, try_vars/1, try_evars/1,
- try_handler/1, tuple_es/1, type/1, values_es/1]).
-
--import(cerl_trees, [get_label/1]).
-
-%% ===========================================================================
-
--type label() :: integer() | 'top' | 'external' | 'external_call'.
--type ordset(X) :: [X]. % XXX: TAKE ME OUT
--type labelset() :: ordset(label()).
--type outlist() :: [labelset()] | 'none'.
--type escapes() :: labelset().
-
-%% ===========================================================================
-%% annotate(Tree) -> {Tree1, OutList, Outputs, Escapes, Dependencies, Parents}
-%%
-%% Tree = cerl:cerl()
-%%
-%% Analyzes `Tree' (see `analyze') and appends terms `{callers,
-%% Labels}' and `{calls, Labels}' to the annotation list of each
-%% fun-expression node and apply-expression node of `Tree',
-%% respectively, where `Labels' is an ordered-set list of labels of
-%% fun-expressions in `Tree', possibly also containing the atom
-%% `external', corresponding to the dependency information derived
-%% by the analysis. Any previous such annotations are removed from
-%% `Tree'. `Tree1' is the modified tree; for details on `OutList',
-%% `Outputs' , `Dependencies', `Escapes' and `Parents', see
-%% `analyze'.
-%%
-%% Note: `Tree' must be annotated with labels in order to use this
-%% function; see `analyze' for details.
-
--spec annotate(cerl:cerl()) ->
- {cerl:cerl(), outlist(), dict:dict(),
- escapes(), dict:dict(), dict:dict()}.
-
-annotate(Tree) ->
- {Xs, Out, Esc, Deps, Par} = analyze(Tree),
- F = fun (T) ->
- case type(T) of
- 'fun' ->
- L = get_label(T),
- X = case dict:find(L, Deps) of
- {ok, X1} -> X1;
- error -> set__new()
- end,
- set_ann(T, append_ann(callers,
- set__to_list(X),
- get_ann(T)));
- apply ->
- L = get_label(T),
- X = case dict:find(L, Deps) of
- {ok, X1} -> X1;
- error -> set__new()
- end,
- set_ann(T, append_ann(calls,
- set__to_list(X),
- get_ann(T)));
- _ ->
-%%% set_ann(T, []) % debug
- T
- end
- end,
- {cerl_trees:map(F, Tree), Xs, Out, Esc, Deps, Par}.
-
-append_ann(Tag, Val, [X | Xs]) ->
- if tuple_size(X) >= 1, element(1, X) =:= Tag ->
- append_ann(Tag, Val, Xs);
- true ->
- [X | append_ann(Tag, Val, Xs)]
- end;
-append_ann(Tag, Val, []) ->
- [{Tag, Val}].
-
-%% =====================================================================
-%% analyze(Tree) -> {OutList, Outputs, Escapes, Dependencies, Parents}
-%%
-%% Tree = cerl()
-%% OutList = [LabelSet] | none
-%% Outputs = dict(Label, OutList)
-%% Escapes = LabelSet
-%% Dependencies = dict(Label, LabelSet)
-%% LabelSet = ordset(Label)
-%% Label = integer() | top | external | external_call
-%% Parents = dict(Label, Label)
-%%
-%% Analyzes a module or an expression represented by `Tree'.
-%%
-%% The returned `OutList' is a list of sets of labels of
-%% fun-expressions which correspond to the possible closures in the
-%% value list produced by `Tree' (viewed as an expression; the
-%% "value" of a module contains its exported functions). The atom
-%% `none' denotes missing or conflicting information.
-%%
-%% The atom `external' in any label set denotes any possible
-%% function outside `Tree', including those in `Escapes'. The atom
-%% `top' denotes the top-level expression `Tree'.
-%%
-%% `Outputs' is a mapping from the labels of fun-expressions in
-%% `Tree' to corresponding lists of sets of labels of
-%% fun-expressions (or the atom `none'), representing the possible
-%% closures in the value lists returned by the respective
-%% functions.
-%%
-%% `Dependencies' is a similar mapping from the labels of
-%% fun-expressions and apply-expressions in `Tree' to sets of
-%% labels of corresponding fun-expressions which may contain call
-%% sites of the functions or be called from the call sites,
-%% respectively. Any such label not defined in `Dependencies'
-%% represents an unreachable function or a dead or faulty
-%% application.
-%%
-%% `Escapes' is the set of labels of fun-expressions in `Tree' such
-%% that corresponding closures may be accessed from outside `Tree'.
-%%
-%% `Parents' is a mapping from labels of fun-expressions in `Tree'
-%% to the corresponding label of the nearest containing
-%% fun-expression or top-level expression. This can be used to
-%% extend the dependency graph, for certain analyses.
-%%
-%% Note: `Tree' must be annotated with labels (as done by the
-%% function `cerl_trees:label/1') in order to use this function.
-%% The label annotation `{label, L}' (where L should be an integer)
-%% must be the first element of the annotation list of each node in
-%% the tree. Instances of variables bound in `Tree' which denote
-%% the same variable must have the same label; apart from this,
-%% labels should be unique. Constant literals do not need to be
-%% labeled.
-
--record(state, {vars, out, dep, work, funs, par}).
-
-%% Note: In order to keep our domain simple, we assume that all remote
-%% calls and primops return a single value, if any.
-
-%% We use the terms `closure', `label', `lambda' and `fun-expression'
-%% interchangeably. The exact meaning in each case can be grasped from
-%% the context.
-%%
-%% Rules:
-%% 1) The implicit top level lambda escapes.
-%% 2) A lambda returned by an escaped lambda also escapes.
-%% 3) An escaped lambda can be passed an external lambda as argument.
-%% 4) A lambda passed as argument to an external lambda also escapes.
-%% 5) An argument passed to an unknown operation escapes.
-%% 6) A call to an unknown operation can return an external lambda.
-%%
-%% Escaped lambdas become part of the set of external lambdas, but this
-%% does not need to be represented explicitly.
-
-%% We wrap the given syntax tree T in a fun-expression labeled `top',
-%% which is initially in the set of escaped labels. `top' will be
-%% visited at least once.
-%%
-%% We create a separate function labeled `external', defined as:
-%% "'external'/1 = fun (Escape) -> do apply 'external'/1(apply Escape())
-%% 'external'/1", which will represent any and all functions outside T,
-%% and which returns itself, and contains a recursive call; this models
-%% rules 2 and 4 above. It will be revisited if the set of escaped
-%% labels changes, or at least once. Its parameter `Escape' is a
-%% variable labeled `escape', which will hold the set of escaped labels.
-%% initially it contains `top' and `external'.
-
--spec analyze(cerl:cerl()) ->
- {outlist(), dict:dict(), escapes(), dict:dict(), dict:dict()}.
-
-analyze(Tree) ->
- %% Note that we use different name spaces for variable labels and
- %% function/call site labels, so we can reuse some names here. We
- %% assume that the labeling of Tree only uses integers, not atoms.
- External = ann_c_var([{label, external}], {external, 1}),
- Escape = ann_c_var([{label, escape}], 'Escape'),
- ExtBody = c_seq(ann_c_apply([{label, loop}], External,
- [ann_c_apply([{label, external_call}],
- Escape, [])]),
- External),
- ExtFun = ann_c_fun([{label, external}], [Escape], ExtBody),
-%%% io:fwrite("external fun:\n~s.\n",
-%%% [cerl_prettypr:format(ExtFun, [noann])]),
- Top = ann_c_var([{label, top}], {top, 0}),
- TopFun = ann_c_fun([{label, top}], [], Tree),
-
- %% The "start fun" just makes the initialisation easier. It will not
- %% be marked as escaped, and thus cannot be called.
- StartFun = ann_c_fun([{label, start}], [],
- c_letrec([{External, ExtFun}, {Top, TopFun}],
- c_nil())),
-%%% io:fwrite("start fun:\n~s.\n",
-%%% [cerl_prettypr:format(StartFun, [noann])]),
-
- %% Gather a database of all fun-expressions in Tree and initialise
- %% all their outputs and parameter variables. Bind all module- and
- %% letrec-defined variables to their corresponding labels.
- Funs0 = dict:new(),
- Vars0 = dict:new(),
- Out0 = dict:new(),
- Empty = empty(),
- F = fun (T, S = {Fs, Vs, Os}) ->
- case type(T) of
- 'fun' ->
- L = get_label(T),
- As = fun_vars(T),
- {dict:store(L, T, Fs),
- bind_vars_single(As, Empty, Vs),
- dict:store(L, none, Os)};
- letrec ->
- {Fs, bind_defs(letrec_defs(T), Vs), Os};
- module ->
- {Fs, bind_defs(module_defs(T), Vs), Os};
- _ ->
- S
- end
- end,
- {Funs, Vars, Out} = cerl_trees:fold(F, {Funs0, Vars0, Out0},
- StartFun),
-
- %% Initialise Escape to the minimal set of escaped labels.
- Vars1 = dict:store(escape, from_label_list([top, external]), Vars),
-
- %% Enter the fixpoint iteration at the StartFun.
- St = loop(StartFun, start, #state{vars = Vars1,
- out = Out,
- dep = dict:new(),
- work = init_work(),
- funs = Funs,
- par = dict:new()}),
-%%% io:fwrite("dependencies: ~p.\n",
-%%% [[{X, set__to_list(Y)}
-%%% || {X, Y} <- dict:to_list(St#state.dep)]]),
- {dict:fetch(top, St#state.out),
- tidy_dict([start, top, external], St#state.out),
- dict:fetch(escape, St#state.vars),
- tidy_dict([loop], St#state.dep),
- St#state.par}.
-
-tidy_dict([X | Xs], D) ->
- tidy_dict(Xs, dict:erase(X, D));
-tidy_dict([], D) ->
- D.
-
-loop(T, L, St0) ->
-%%% io:fwrite("analyzing: ~w.\n", [L]),
-%%% io:fwrite("work: ~w.\n", [St0#state.work]),
- Xs0 = dict:fetch(L, St0#state.out),
- {Xs, St1} = visit(fun_body(T), L, St0),
- {W, M} = case equal(Xs0, Xs) of
- true ->
- {St1#state.work, St1#state.out};
- false ->
-%%% io:fwrite("out (~w) changed: ~w <- ~w.\n",
-%%% [L, Xs, Xs0]),
- M1 = dict:store(L, Xs, St1#state.out),
- case dict:find(L, St1#state.dep) of
- {ok, S} ->
- {add_work(set__to_list(S), St1#state.work),
- M1};
- error ->
- {St1#state.work, M1}
- end
- end,
- St2 = St1#state{out = M},
- case take_work(W) of
- {ok, L1, W1} ->
- T1 = dict:fetch(L1, St2#state.funs),
- loop(T1, L1, St2#state{work = W1});
- none ->
- St2
- end.
-
-visit(T, L, St) ->
- case type(T) of
- literal ->
- {[empty()], St};
- var ->
- %% If a variable is not already in the store here, we
- %% initialize it to empty().
- L1 = get_label(T),
- Vars = St#state.vars,
- case dict:find(L1, Vars) of
- {ok, X} ->
- {[X], St};
- error ->
- X = empty(),
- St1 = St#state{vars = dict:store(L1, X, Vars)},
- {[X], St1}
- end;
- 'fun' ->
- %% Must revisit the fun also, because its environment might
- %% have changed. (We don't keep track of such dependencies.)
- L1 = get_label(T),
- St1 = St#state{work = add_work([L1], St#state.work),
- par = set_parent([L1], L, St#state.par)},
- {[singleton(L1)], St1};
- values ->
- visit_list(values_es(T), L, St);
- cons ->
- {Xs, St1} = visit_list([cons_hd(T), cons_tl(T)], L, St),
- {[join_single_list(Xs)], St1};
- tuple ->
- {Xs, St1} = visit_list(tuple_es(T), L, St),
- {[join_single_list(Xs)], St1};
- 'let' ->
- {Xs, St1} = visit(let_arg(T), L, St),
- Vars = bind_vars(let_vars(T), Xs, St1#state.vars),
- visit(let_body(T), L, St1#state{vars = Vars});
- seq ->
- {_, St1} = visit(seq_arg(T), L, St),
- visit(seq_body(T), L, St1);
- apply ->
- {Xs, St1} = visit(apply_op(T), L, St),
- {As, St2} = visit_list(apply_args(T), L, St1),
- case Xs of
- [X] ->
- %% We store the dependency from the call site to the
- %% called functions
- Ls = set__to_list(X),
- Out = St2#state.out,
- Xs1 = join_list([dict:fetch(Lx, Out) || Lx <- Ls]),
- St3 = call_site(Ls, L, As, St2),
- L1 = get_label(T),
- D = dict:store(L1, X, St3#state.dep),
- {Xs1, St3#state{dep = D}};
- none ->
- {none, St2}
- end;
- call ->
- M = call_module(T),
- F = call_name(T),
- {_, St1} = visit(M, L, St),
- {_, St2} = visit(F, L, St1),
- {Xs, St3} = visit_list(call_args(T), L, St2),
- remote_call(M, F, Xs, St3);
- primop ->
- As = primop_args(T),
- {Xs, St1} = visit_list(As, L, St),
- primop_call(atom_val(primop_name(T)), length(Xs), Xs, St1);
- 'case' ->
- {Xs, St1} = visit(case_arg(T), L, St),
- visit_clauses(Xs, case_clauses(T), L, St1);
- 'receive' ->
- X = singleton(external),
- {Xs1, St1} = visit_clauses([X], receive_clauses(T), L, St),
- {_, St2} = visit(receive_timeout(T), L, St1),
- {Xs2, St3} = visit(receive_action(T), L, St2),
- {join(Xs1, Xs2), St3};
- 'try' ->
- {Xs1, St1} = visit(try_arg(T), L, St),
- X = singleton(external),
- Vars = bind_vars(try_vars(T), [X], St1#state.vars),
- {Xs2, St2} = visit(try_body(T), L, St1#state{vars = Vars}),
- Evars = bind_vars(try_evars(T), [X, X, X], St2#state.vars),
- {Xs3, St3} = visit(try_handler(T), L, St2#state{vars = Evars}),
- {join(join(Xs1, Xs2), Xs3), St3};
- 'catch' ->
- {_, St1} = visit(catch_body(T), L, St),
- {[singleton(external)], St1};
- binary ->
- {_, St1} = visit_list(binary_segments(T), L, St),
- {[empty()], St1};
- bitstr ->
- %% The other fields are constant literals.
- {_, St1} = visit(bitstr_val(T), L, St),
- {_, St2} = visit(bitstr_size(T), L, St1),
- {none, St2};
- letrec ->
- %% All the bound funs should be revisited, because the
- %% environment might have changed.
- Ls = [get_label(F) || {_, F} <- letrec_defs(T)],
- St1 = St#state{work = add_work(Ls, St#state.work),
- par = set_parent(Ls, L, St#state.par)},
- visit(letrec_body(T), L, St1);
- module ->
- %% All the exported functions escape, and can thus be passed
- %% any external closures as arguments. We regard a module as
- %% a tuple of function variables in the body of a `letrec'.
- visit(c_letrec(module_defs(T), c_tuple(module_exports(T))),
- L, St)
- end.
-
-visit_clause(T, Xs, L, St) ->
- Vars = bind_pats(clause_pats(T), Xs, St#state.vars),
- {_, St1} = visit(clause_guard(T), L, St#state{vars = Vars}),
- visit(clause_body(T), L, St1).
-
-%% We assume correct value-list typing.
-
-visit_list([T | Ts], L, St) ->
- {Xs, St1} = visit(T, L, St),
- {Xs1, St2} = visit_list(Ts, L, St1),
- X = case Xs of
- [X1] -> X1;
- none -> none
- end,
- {[X | Xs1], St2};
-visit_list([], _L, St) ->
- {[], St}.
-
-visit_clauses(Xs, [T | Ts], L, St) ->
- {Xs1, St1} = visit_clause(T, Xs, L, St),
- {Xs2, St2} = visit_clauses(Xs, Ts, L, St1),
- {join(Xs1, Xs2), St2};
-visit_clauses(_, [], _L, St) ->
- {none, St}.
-
-bind_defs([{V, F} | Ds], Vars) ->
- bind_defs(Ds, dict:store(get_label(V), singleton(get_label(F)),
- Vars));
-bind_defs([], Vars) ->
- Vars.
-
-bind_pats(Ps, none, Vars) ->
- bind_pats_single(Ps, empty(), Vars);
-bind_pats(Ps, Xs, Vars) ->
- if length(Xs) =:= length(Ps) ->
- bind_pats_list(Ps, Xs, Vars);
- true ->
- bind_pats_single(Ps, empty(), Vars)
- end.
-
-bind_pats_list([P | Ps], [X | Xs], Vars) ->
- bind_pats_list(Ps, Xs, bind_vars_single(pat_vars(P), X, Vars));
-bind_pats_list([], [], Vars) ->
- Vars.
-
-bind_pats_single([P | Ps], X, Vars) ->
- bind_pats_single(Ps, X, bind_vars_single(pat_vars(P), X, Vars));
-bind_pats_single([], _X, Vars) ->
- Vars.
-
-bind_vars(Vs, none, Vars) ->
- bind_vars_single(Vs, empty(), Vars);
-bind_vars(Vs, Xs, Vars) ->
- if length(Vs) =:= length(Xs) ->
- bind_vars_list(Vs, Xs, Vars);
- true ->
- bind_vars_single(Vs, empty(), Vars)
- end.
-
-bind_vars_list([V | Vs], [X | Xs], Vars) ->
- bind_vars_list(Vs, Xs, dict:store(get_label(V), X, Vars));
-bind_vars_list([], [], Vars) ->
- Vars.
-
-bind_vars_single([V | Vs], X, Vars) ->
- bind_vars_single(Vs, X, dict:store(get_label(V), X, Vars));
-bind_vars_single([], _X, Vars) ->
- Vars.
-
-%% This handles a call site - adding dependencies and updating parameter
-%% variables with respect to the actual parameters. The 'external'
-%% function is handled specially, since it can get an arbitrary number
-%% of arguments, which must be unified into a single argument.
-
-call_site(Ls, L, Xs, St) ->
-%%% io:fwrite("call site: ~w -> ~w (~w).\n", [L, Ls, Xs]),
- {D, W, V} = call_site(Ls, L, Xs, St#state.dep, St#state.work,
- St#state.vars, St#state.funs),
- St#state{dep = D, work = W, vars = V}.
-
-call_site([external | Ls], T, Xs, D, W, V, Fs) ->
- D1 = add_dep(external, T, D),
- X = join_single_list(Xs),
- case bind_arg(escape, X, V) of
- {V1, true} ->
-%%% io:fwrite("escape changed: ~w <- ~w + ~w.\n",
-%%% [dict:fetch(escape, V1), dict:fetch(escape, V),
-%%% X]),
- {W1, V2} = update_esc(set__to_list(X), W, V1, Fs),
- call_site(Ls, T, Xs, D1, add_work([external], W1), V2, Fs);
- {V1, false} ->
- call_site(Ls, T, Xs, D1, W, V1, Fs)
- end;
-call_site([L | Ls], T, Xs, D, W, V, Fs) ->
- D1 = add_dep(L, T, D),
- Vs = fun_vars(dict:fetch(L, Fs)),
- case bind_args(Vs, Xs, V) of
- {V1, true} ->
- call_site(Ls, T, Xs, D1, add_work([L], W), V1, Fs);
- {V1, false} ->
- call_site(Ls, T, Xs, D1, W, V1, Fs)
- end;
-call_site([], _, _, D, W, V, _) ->
- {D, W, V}.
-
-%% Note that `visit' makes sure all lambdas are visited at least once.
-%% For every called function, we add a dependency from the *called*
-%% function to the function containing the call site.
-
-add_dep(Source, Target, Deps) ->
- case dict:find(Source, Deps) of
- {ok, X} ->
- case set__is_member(Target, X) of
- true ->
- Deps;
- false ->
-%%% io:fwrite("new dep: ~w <- ~w.\n", [Target, Source]),
- dict:store(Source, set__add(Target, X), Deps)
- end;
- error ->
-%%% io:fwrite("new dep: ~w <- ~w.\n", [Target, Source]),
- dict:store(Source, set__singleton(Target), Deps)
- end.
-
-%% If the arity does not match the call, nothing is done here.
-
-bind_args(Vs, Xs, Vars) ->
- if length(Vs) =:= length(Xs) ->
- bind_args(Vs, Xs, Vars, false);
- true ->
- {Vars, false}
- end.
-
-bind_args([V | Vs], [X | Xs], Vars, Ch) ->
- L = get_label(V),
- {Vars1, Ch1} = bind_arg(L, X, Vars, Ch),
- bind_args(Vs, Xs, Vars1, Ch1);
-bind_args([], [], Vars, Ch) ->
- {Vars, Ch}.
-
-bind_args_single(Vs, X, Vars) ->
- bind_args_single(Vs, X, Vars, false).
-
-bind_args_single([V | Vs], X, Vars, Ch) ->
- L = get_label(V),
- {Vars1, Ch1} = bind_arg(L, X, Vars, Ch),
- bind_args_single(Vs, X, Vars1, Ch1);
-bind_args_single([], _, Vars, Ch) ->
- {Vars, Ch}.
-
-bind_arg(L, X, Vars) ->
- bind_arg(L, X, Vars, false).
-
-bind_arg(L, X, Vars, Ch) ->
- X0 = dict:fetch(L, Vars),
- X1 = join_single(X, X0),
- case equal_single(X0, X1) of
- true ->
- {Vars, Ch};
- false ->
-%%% io:fwrite("arg (~w) changed: ~w <- ~w + ~w.\n",
-%%% [L, X1, X0, X]),
- {dict:store(L, X1, Vars), true}
- end.
-
-%% This handles escapes from things like primops and remote calls.
-
-%% escape(none, St) ->
-%% St;
-escape([X], St) ->
- Vars = St#state.vars,
- X0 = dict:fetch(escape, Vars),
- X1 = join_single(X, X0),
- case equal_single(X0, X1) of
- true ->
- St;
- false ->
-%%% io:fwrite("escape changed: ~w <- ~w + ~w.\n", [X1, X0, X]),
-%%% io:fwrite("updating escaping funs: ~w.\n", [set__to_list(X)]),
- Vars1 = dict:store(escape, X1, Vars),
- {W, Vars2} = update_esc(set__to_list(set__subtract(X, X0)),
- St#state.work, Vars1,
- St#state.funs),
- St#state{work = add_work([external], W), vars = Vars2}
- end.
-
-%% For all escaping lambdas, since they might be called from outside the
-%% program, all their arguments may be an external lambda. (Note that we
-%% only have to include the `external' label once per escaping lambda.)
-%% If the escape set has changed, we need to revisit the `external' fun.
-
-update_esc(Ls, W, V, Fs) ->
- update_esc(Ls, singleton(external), W, V, Fs).
-
-%% The external lambda is skipped here - the Escape variable is known to
-%% contain `external' from the start.
-
-update_esc([external | Ls], X, W, V, Fs) ->
- update_esc(Ls, X, W, V, Fs);
-update_esc([L | Ls], X, W, V, Fs) ->
- Vs = fun_vars(dict:fetch(L, Fs)),
- case bind_args_single(Vs, X, V) of
- {V1, true} ->
- update_esc(Ls, X, add_work([L], W), V1, Fs);
- {V1, false} ->
- update_esc(Ls, X, W, V1, Fs)
- end;
-update_esc([], _, W, V, _) ->
- {W, V}.
-
-set_parent([L | Ls], L1, D) ->
- set_parent(Ls, L1, dict:store(L, L1, D));
-set_parent([], _L1, D) ->
- D.
-
-%% Handle primop calls: (At present, we assume that all unknown primops
-%% yield exactly one value. This might have to be changed.)
-
-primop_call(F, A, Xs, St0) ->
- case is_pure_op(F, A) of
- %% XXX: this case is currently not possible -- commented out.
- %% true ->
- %% case is_literal_op(F, A) of
- %% true -> {[empty()], St0};
- %% false -> {[join_single_list(Xs)], St0}
- %% end;
- false ->
- St1 = case is_escape_op(F, A) of
- true -> escape([join_single_list(Xs)], St0);
- false -> St0
- end,
- case is_literal_op(F, A) of
- true -> {none, St1};
- false -> {[singleton(external)], St1}
- end
- end.
-
-%% Handle remote-calls: (At present, we assume that all unknown calls
-%% yield exactly one value. This might have to be changed.)
-
-remote_call(M, F, Xs, St) ->
- case is_c_atom(M) andalso is_c_atom(F) of
- true ->
- remote_call_1(atom_val(M), atom_val(F), length(Xs), Xs, St);
- false ->
- %% Unknown function
- {[singleton(external)], escape([join_single_list(Xs)], St)}
- end.
-
-remote_call_1(M, F, A, Xs, St0) ->
- case is_pure_op(M, F, A) of
- true ->
- case is_literal_op(M, F, A) of
- true -> {[empty()], St0};
- false -> {[join_single_list(Xs)], St0}
- end;
- false ->
- St1 = case is_escape_op(M, F, A) of
- true -> escape([join_single_list(Xs)], St0);
- false -> St0
- end,
- case is_literal_op(M, F, A) of
- true -> {[empty()], St1};
- false -> {[singleton(external)], St1}
- end
- end.
-
-%% Domain: none | [Vs], where Vs = set(integer()).
-
-join(none, Xs2) -> Xs2;
-join(Xs1, none) -> Xs1;
-join(Xs1, Xs2) ->
- if length(Xs1) =:= length(Xs2) ->
- join_1(Xs1, Xs2);
- true ->
- none
- end.
-
-join_1([X1 | Xs1], [X2 | Xs2]) ->
- [join_single(X1, X2) | join_1(Xs1, Xs2)];
-join_1([], []) ->
- [].
-
-empty() -> set__new().
-
-singleton(X) -> set__singleton(X).
-
-from_label_list(X) -> set__from_list(X).
-
-join_single(none, Y) -> Y;
-join_single(X, none) -> X;
-join_single(X, Y) -> set__union(X, Y).
-
-join_list([Xs | Xss]) ->
- join(Xs, join_list(Xss));
-join_list([]) ->
- none.
-
-join_single_list([X | Xs]) ->
- join_single(X, join_single_list(Xs));
-join_single_list([]) ->
- empty().
-
-equal(none, none) -> true;
-equal(none, _) -> false;
-equal(_, none) -> false;
-equal(X1, X2) -> equal_1(X1, X2).
-
-equal_1([X1 | Xs1], [X2 | Xs2]) ->
- equal_single(X1, X2) andalso equal_1(Xs1, Xs2);
-equal_1([], []) -> true;
-equal_1(_, _) -> false.
-
-equal_single(X, Y) -> set__equal(X, Y).
-
-%% Set abstraction for label sets in the domain.
-
-set__new() -> [].
-
-set__singleton(X) -> [X].
-
-set__to_list(S) -> S.
-
-set__from_list(S) -> ordsets:from_list(S).
-
-set__union(X, Y) -> ordsets:union(X, Y).
-
-set__add(X, S) -> ordsets:add_element(X, S).
-
-set__is_member(X, S) -> ordsets:is_element(X, S).
-
-set__subtract(X, Y) -> ordsets:subtract(X, Y).
-
-set__equal(X, Y) -> X =:= Y.
-
-%% A simple but efficient functional queue.
-
-queue__new() -> {[], []}.
-
-queue__put(X, {In, Out}) -> {[X | In], Out}.
-
-queue__get({In, [X | Out]}) -> {ok, X, {In, Out}};
-queue__get({[], _}) -> empty;
-queue__get({In, _}) ->
- [X | In1] = lists:reverse(In),
- {ok, X, {[], In1}}.
-
-%% The work list - a queue without repeated elements.
-
-init_work() ->
- {queue__new(), sets:new([{version, 2}])}.
-
-add_work(Ls, {Q, Set}) ->
- add_work(Ls, Q, Set).
-
-%% Note that the elements are enqueued in order.
-
-add_work([L | Ls], Q, Set) ->
- case sets:is_element(L, Set) of
- true ->
- add_work(Ls, Q, Set);
- false ->
- add_work(Ls, queue__put(L, Q), sets:add_element(L, Set))
- end;
-add_work([], Q, Set) ->
- {Q, Set}.
-
-take_work({Queue0, Set0}) ->
- case queue__get(Queue0) of
- {ok, L, Queue1} ->
- Set1 = sets:del_element(L, Set0),
- {ok, L, {Queue1, Set1}};
- empty ->
- none
- end.
-
-%% Escape operators may let their arguments escape. Unless we know
-%% otherwise, and the function is not pure, we assume this is the case.
-%% Error-raising functions (fault/match_fail) are not considered as
-%% escapes (but throw/exit are). Zero-argument functions need not be
-%% listed.
-
--spec is_escape_op(atom(), arity()) -> boolean().
-
-is_escape_op(match_fail, 1) -> false;
-is_escape_op(recv_wait_timeout, 1) -> false;
-is_escape_op(F, A) when is_atom(F), is_integer(A) -> true.
-
--spec is_escape_op(atom(), atom(), arity()) -> boolean().
-
-is_escape_op(erlang, error, 1) -> false;
-is_escape_op(erlang, error, 2) -> false;
-is_escape_op(M, F, A) when is_atom(M), is_atom(F), is_integer(A) -> true.
-
-%% "Literal" operators will never return functional values even when
-%% found in their arguments. Unless we know otherwise, we assume this is
-%% not the case. (More functions can be added to this list, if needed
-%% for better precision. Note that the result of `term_to_binary' still
-%% contains an encoding of the closure.)
-
--spec is_literal_op(atom(), arity()) -> boolean().
-
-is_literal_op(recv_wait_timeout, 1) -> true;
-is_literal_op(match_fail, 1) -> true;
-is_literal_op(F, A) when is_atom(F), is_integer(A) -> false.
-
--spec is_literal_op(atom(), atom(), arity()) -> boolean().
-
-is_literal_op(erlang, '+', 2) -> true;
-is_literal_op(erlang, '-', 2) -> true;
-is_literal_op(erlang, '*', 2) -> true;
-is_literal_op(erlang, '/', 2) -> true;
-is_literal_op(erlang, '=:=', 2) -> true;
-is_literal_op(erlang, '==', 2) -> true;
-is_literal_op(erlang, '=/=', 2) -> true;
-is_literal_op(erlang, '/=', 2) -> true;
-is_literal_op(erlang, '<', 2) -> true;
-is_literal_op(erlang, '=<', 2) -> true;
-is_literal_op(erlang, '>', 2) -> true;
-is_literal_op(erlang, '>=', 2) -> true;
-is_literal_op(erlang, 'and', 2) -> true;
-is_literal_op(erlang, 'or', 2) -> true;
-is_literal_op(erlang, 'not', 1) -> true;
-is_literal_op(erlang, length, 1) -> true;
-is_literal_op(erlang, size, 1) -> true;
-is_literal_op(erlang, fun_info, 1) -> true;
-is_literal_op(erlang, fun_info, 2) -> true;
-is_literal_op(erlang, fun_to_list, 1) -> true;
-is_literal_op(erlang, throw, 1) -> true;
-is_literal_op(erlang, exit, 1) -> true;
-is_literal_op(erlang, error, 1) -> true;
-is_literal_op(erlang, error, 2) -> true;
-is_literal_op(M, F, A) when is_atom(M), is_atom(F), is_integer(A) -> false.
-
-%% Pure functions neither affect the state, nor depend on it.
-
-is_pure_op(F, A) when is_atom(F), is_integer(A) -> false.
-
-is_pure_op(M, F, A) -> erl_bifs:is_pure(M, F, A).
-
-%% =====================================================================
diff --git a/lib/dialyzer/src/cerl_lib.erl b/lib/dialyzer/src/cerl_lib.erl
deleted file mode 100644
index 3a6fb1cf51..0000000000
--- a/lib/dialyzer/src/cerl_lib.erl
+++ /dev/null
@@ -1,457 +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 1999-2002 Richard Carlsson
-%% @author Richard Carlsson <carlsson.richard@gmail.com>
-%% @doc Utility functions for Core Erlang abstract syntax trees.
-%%
-%% <p>Syntax trees are defined in the module <a
-%% href=""><code>cerl</code></a>.</p>
-%%
-%% @type cerl() = cerl:cerl()
-
--module(cerl_lib).
-
--define(NO_UNUSED, true).
-
--export([is_safe_expr/2, reduce_expr/1, is_simple_clause/1,
- is_bool_switch/1, bool_switch_cases/1]).
--ifndef(NO_UNUSED).
--export([is_safe_expr/1, is_pure_expr/1, is_pure_expr/2,
- make_bool_switch/3]).
--endif.
-
-
-%% Test if a clause has a single pattern and an always-true guard.
-
--spec is_simple_clause(cerl:c_clause()) -> boolean().
-
-is_simple_clause(C) ->
- case cerl:clause_pats(C) of
- [_P] ->
- G = cerl:clause_guard(C),
- case cerl_clauses:eval_guard(G) of
- {value, true} -> true;
- _ -> false
- end;
- _ -> false
- end.
-
-%% Creating an if-then-else construct that can be recognized as such.
-%% `Test' *must* be guaranteed to return a boolean.
-
--ifndef(NO_UNUSED).
-make_bool_switch(Test, True, False) ->
- Cs = [cerl:c_clause([cerl:c_atom(true)], True),
- cerl:c_clause([cerl:c_atom(false)], False)],
- cerl:c_case(Test, Cs).
--endif.
-
-%% A boolean switch cannot have a catch-all; only true/false branches.
-
--spec is_bool_switch([cerl:c_clause()]) -> boolean().
-
-is_bool_switch([C1, C2]) ->
- case is_simple_clause(C1) andalso is_simple_clause(C2) of
- true ->
- [P1] = cerl:clause_pats(C1),
- [P2] = cerl:clause_pats(C2),
- case cerl:is_c_atom(P1) andalso cerl:is_c_atom(P2) of
- true ->
- A1 = cerl:concrete(P1),
- A2 = cerl:concrete(P2),
- is_boolean(A1) andalso is_boolean(A2)
- andalso A1 =/= A2;
- false ->
- false
- end;
- false ->
- false
- end;
-is_bool_switch(_) ->
- false.
-
-%% Returns the true-body and the false-body for boolean switch clauses.
-
--spec bool_switch_cases([cerl:c_clause()]) -> {cerl:cerl(), cerl:cerl()}.
-
-bool_switch_cases([C1, C2]) ->
- B1 = cerl:clause_body(C1),
- B2 = cerl:clause_body(C2),
- [P1] = cerl:clause_pats(C1),
- case cerl:concrete(P1) of
- true ->
- {B1, B2};
- false ->
- {B2, B1}
- end.
-
-%%
-%% The type of the check functions like the default check below - XXX: refine
-%%
--type check_fun() :: fun((_, _) -> boolean()).
-
-%% The default function property check always returns `false':
-
-default_check(_Property, _Function) -> false.
-
-
-%% @spec is_safe_expr(Expr::cerl()) -> boolean()
-%%
-%% @doc Returns `true' if `Expr' represents a "safe" Core Erlang
-%% expression, otherwise `false'. An expression is safe if it always
-%% completes normally and does not modify the state (although the return
-%% value may depend on the state).
-%%
-%% Expressions of type `apply', `case', `receive' and `binary' are
-%% always considered unsafe by this function.
-
-%% TODO: update cerl_inline to use these functions instead.
-
--ifndef(NO_UNUSED).
-is_safe_expr(E) ->
- Check = fun default_check/2,
- is_safe_expr(E, Check).
--endif.
-%% @clear
-
--spec is_safe_expr(cerl:cerl(), check_fun()) -> boolean().
-
-is_safe_expr(E, Check) ->
- case cerl:type(E) of
- literal ->
- true;
- var ->
- true;
- 'fun' ->
- true;
- values ->
- is_safe_expr_list(cerl:values_es(E), Check);
- tuple ->
- is_safe_expr_list(cerl:tuple_es(E), Check);
- cons ->
- case is_safe_expr(cerl:cons_hd(E), Check) of
- true ->
- is_safe_expr(cerl:cons_tl(E), Check);
- false ->
- false
- end;
- 'let' ->
- case is_safe_expr(cerl:let_arg(E), Check) of
- true ->
- is_safe_expr(cerl:let_body(E), Check);
- false ->
- false
- end;
- letrec ->
- is_safe_expr(cerl:letrec_body(E), Check);
- seq ->
- case is_safe_expr(cerl:seq_arg(E), Check) of
- true ->
- is_safe_expr(cerl:seq_body(E), Check);
- false ->
- false
- end;
- 'catch' ->
- is_safe_expr(cerl:catch_body(E), Check);
- 'try' ->
- %% If the guarded expression is safe, the try-handler will
- %% never be evaluated, so we need only check the body. If
- %% the guarded expression is pure, but could fail, we also
- %% have to check the handler.
- case is_safe_expr(cerl:try_arg(E), Check) of
- true ->
- is_safe_expr(cerl:try_body(E), Check);
- false ->
- case is_pure_expr(cerl:try_arg(E), Check) of
- true ->
- case is_safe_expr(cerl:try_body(E), Check) of
- true ->
- is_safe_expr(cerl:try_handler(E), Check);
- false ->
- false
- end;
- false ->
- false
- end
- end;
- primop ->
- Name = cerl:atom_val(cerl:primop_name(E)),
- As = cerl:primop_args(E),
- case Check(safe, {Name, length(As)}) of
- true ->
- is_safe_expr_list(As, Check);
- false ->
- false
- end;
- call ->
- Module = cerl:call_module(E),
- Name = cerl:call_name(E),
- case cerl:is_c_atom(Module) and cerl:is_c_atom(Name) of
- true ->
- M = cerl:atom_val(Module),
- F = cerl:atom_val(Name),
- As = cerl:call_args(E),
- case Check(safe, {M, F, length(As)}) of
- true ->
- is_safe_expr_list(As, Check);
- false ->
- false
- end;
- false ->
- false % Call to unknown function
- end;
- _ ->
- false
- end.
-
-is_safe_expr_list([E | Es], Check) ->
- case is_safe_expr(E, Check) of
- true ->
- is_safe_expr_list(Es, Check);
- false ->
- false
- end;
-is_safe_expr_list([], _Check) ->
- true.
-
-
-%% @spec (Expr::cerl()) -> bool()
-%%
-%% @doc Returns `true' if `Expr' represents a "pure" Core Erlang
-%% expression, otherwise `false'. An expression is pure if it does not
-%% affect the state, nor depend on the state, although its evaluation is
-%% not guaranteed to complete normally for all input.
-%%
-%% Expressions of type `apply', `case', `receive' and `binary' are
-%% always considered impure by this function.
-
--ifndef(NO_UNUSED).
-is_pure_expr(E) ->
- Check = fun default_check/2,
- is_pure_expr(E, Check).
--endif.
-%% @clear
-
-is_pure_expr(E, Check) ->
- case cerl:type(E) of
- literal ->
- true;
- var ->
- true;
- 'fun' ->
- true;
- values ->
- is_pure_expr_list(cerl:values_es(E), Check);
- tuple ->
- is_pure_expr_list(cerl:tuple_es(E), Check);
- cons ->
- case is_pure_expr(cerl:cons_hd(E), Check) of
- true ->
- is_pure_expr(cerl:cons_tl(E), Check);
- false ->
- false
- end;
- 'let' ->
- case is_pure_expr(cerl:let_arg(E), Check) of
- true ->
- is_pure_expr(cerl:let_body(E), Check);
- false ->
- false
- end;
- letrec ->
- is_pure_expr(cerl:letrec_body(E), Check);
- seq ->
- case is_pure_expr(cerl:seq_arg(E), Check) of
- true ->
- is_pure_expr(cerl:seq_body(E), Check);
- false ->
- false
- end;
- 'catch' ->
- is_pure_expr(cerl:catch_body(E), Check);
- 'try' ->
- case is_pure_expr(cerl:try_arg(E), Check) of
- true ->
- case is_pure_expr(cerl:try_body(E), Check) of
- true ->
- is_pure_expr(cerl:try_handler(E), Check);
- false ->
- false
- end;
- false ->
- false
- end;
- primop ->
- Name = cerl:atom_val(cerl:primop_name(E)),
- As = cerl:primop_args(E),
- case Check(pure, {Name, length(As)}) of
- true ->
- is_pure_expr_list(As, Check);
- false ->
- false
- end;
- call ->
- Module = cerl:call_module(E),
- Name = cerl:call_name(E),
- case cerl:is_c_atom(Module) and cerl:is_c_atom(Name) of
- true ->
- M = cerl:atom_val(Module),
- F = cerl:atom_val(Name),
- As = cerl:call_args(E),
- case Check(pure, {M, F, length(As)}) of
- true ->
- is_pure_expr_list(As, Check);
- false ->
- false
- end;
- false ->
- false % Call to unknown function
- end;
- _ ->
- false
- end.
-
-is_pure_expr_list([E | Es], Check) ->
- case is_pure_expr(E, Check) of
- true ->
- is_pure_expr_list(Es, Check);
- false ->
- false
- end;
-is_pure_expr_list([], _Check) ->
- true.
-
-
-%% Peephole optimizations
-%%
-%% This is only intended to be a light-weight cleanup optimizer,
-%% removing small things that may e.g. have been generated by other
-%% optimization passes or in the translation from higher-level code.
-%% It is not recursive in general - it only descends until it can do no
-%% more work in the current context.
-%%
-%% To expose hidden cases of final expressions (enabling last call
-%% optimization), we try to remove all trivial let-bindings (`let X = Y
-%% in X', `let X = Y in Y', `let X = Y in let ... in ...', `let X = let
-%% ... in ... in ...', etc.). We do not, however, try to recognize any
-%% other similar cases, even for simple `case'-expressions like `case E
-%% of X -> X end', or simultaneous multiple-value bindings.
-
--spec reduce_expr(cerl:cerl()) -> cerl:cerl().
-
-reduce_expr(E) ->
- Check = fun default_check/2,
- reduce_expr(E, Check).
-
--spec reduce_expr(cerl:cerl(), check_fun()) -> cerl:cerl().
-
-reduce_expr(E, Check) ->
- case cerl:type(E) of
- values ->
- case cerl:values_es(E) of
- [E1] ->
- %% Not really an "optimization" in itself, but
- %% enables other rewritings by removing the wrapper.
- reduce_expr(E1, Check);
- _ ->
- E
- end;
- 'seq' ->
- A = reduce_expr(cerl:seq_arg(E), Check),
- B = reduce_expr(cerl:seq_body(E), Check),
- %% `do <E1> <E2>' is equivalent to `<E2>' if `<E1>' is
- %% "safe" (cannot effect the behaviour in any way).
- case is_safe_expr(A, Check) of
- true ->
- B;
- false ->
- case cerl:is_c_seq(B) of
- true ->
- %% Rewrite `do <E1> do <E2> <E3>' to `do do
- %% <E1> <E2> <E3>' so that the "body" of the
- %% outermost seq-operator is the expression
- %% which produces the final result (i.e.,
- %% E3). This can make other optimizations
- %% easier; see `let'.
- B1 = cerl:seq_arg(B),
- B2 = cerl:seq_body(B),
- cerl:c_seq(cerl:c_seq(A, B1), B2);
- false ->
- cerl:c_seq(A, B)
- end
- end;
- 'let' ->
- A = reduce_expr(cerl:let_arg(E), Check),
- case cerl:is_c_seq(A) of
- true ->
- %% `let X = do <E1> <E2> in Y' is equivalent to `do
- %% <E1> let X = <E2> in Y'. Note that `<E2>' cannot
- %% be a seq-operator, due to the `seq' optimization.
- A1 = cerl:seq_arg(A),
- A2 = cerl:seq_body(A),
- E1 = cerl:update_c_let(E, cerl:let_vars(E),
- A2, cerl:let_body(E)),
- cerl:c_seq(A1, reduce_expr(E1, Check));
- false ->
- B = reduce_expr(cerl:let_body(E), Check),
- Vs = cerl:let_vars(E),
- %% We give up if the body does not reduce to a
- %% single variable. This is not a generic copy
- %% propagation.
- case cerl:type(B) of
- var when length(Vs) =:= 1 ->
- %% We have `let <V1> = <E> in <V2>':
- [V] = Vs,
- N1 = cerl:var_name(V),
- N2 = cerl:var_name(B),
- if N1 =:= N2 ->
- %% `let X = <E> in X' equals `<E>'
- A;
- true ->
- %% `let X = <E> in Y' when X and Y
- %% are different variables is
- %% equivalent to `do <E> Y'.
- reduce_expr(cerl:c_seq(A, B), Check)
- end;
- literal ->
- %% `let X = <E> in T' when T is a literal
- %% term is equivalent to `do <E> T'.
- reduce_expr(cerl:c_seq(A, B), Check);
- _ ->
- cerl:update_c_let(E, Vs, A, B)
- end
- end;
- 'try' ->
- %% Get rid of unnecessary try-expressions.
- A = reduce_expr(cerl:try_arg(E), Check),
- B = reduce_expr(cerl:try_body(E), Check),
- case is_safe_expr(A, Check) of
- true ->
- B;
- false ->
- cerl:update_c_try(E, A, cerl:try_vars(E), B,
- cerl:try_evars(E),
- cerl:try_handler(E))
- end;
- 'catch' ->
- %% Just a simpler form of try-expressions.
- B = reduce_expr(cerl:catch_body(E), Check),
- case is_safe_expr(B, Check) of
- true ->
- B;
- false ->
- cerl:update_c_catch(E, B)
- end;
- _ ->
- E
- end.
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).
diff --git a/lib/dialyzer/src/cerl_typean.erl b/lib/dialyzer/src/cerl_typean.erl
deleted file mode 100644
index b0e5c10d7d..0000000000
--- a/lib/dialyzer/src/cerl_typean.erl
+++ /dev/null
@@ -1,994 +0,0 @@
-%% -*- erlang-indent-level: 4 -*-
-%%
-%% 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 2001-2002 Richard Carlsson
-%% @author Richard Carlsson <carlsson.richard@gmail.com>
-%% @doc Type analysis of Core Erlang programs.
-
-%% TODO: filters must handle conjunctions for better precision!
-%% TODO: should get filters from patterns as well as guards.
-%% TODO: unused functions are being included in the analysis.
-
--module(cerl_typean).
-
--export([core_transform/2, analyze/1, pp_hook/0]).
-%%-export([analyze/2, analyze/5, annotate/1, annotate/2, annotate/5]).
-
--import(erl_types, [t_any/0, t_atom/0, t_atom_vals/1, t_binary/0,
- t_cons/2, t_cons_hd/1, t_cons_tl/1, t_float/0,
- t_fun/0, t_fun/2, t_from_range/2, t_from_term/1,
- t_inf/2, t_integer/0,
- t_is_any/1, t_is_atom/1, t_is_cons/1, t_is_list/1,
- t_is_maybe_improper_list/1, t_is_none/1, t_is_tuple/1,
- t_limit/2, t_list_elements/1, t_maybe_improper_list/0,
- t_none/0, t_number/0, t_pid/0, t_port/0, t_product/1,
- t_reference/0, t_sup/2, t_to_tlist/1, t_tuple/0, t_tuple/1,
- t_tuple_args/1, t_tuple_size/1, t_tuple_subtypes/1]).
-
--import(cerl, [ann_c_fun/3, ann_c_var/2, alias_pat/1, alias_var/1,
- apply_args/1, apply_op/1, atom_val/1, bitstr_size/1,
- bitstr_val/1, bitstr_type/1, bitstr_flags/1, binary_segments/1,
- c_letrec/2, c_nil/0,
- c_values/1, call_args/1, call_module/1, call_name/1,
- case_arg/1, case_clauses/1, catch_body/1, clause_body/1,
- clause_guard/1, clause_pats/1, concrete/1, cons_hd/1,
- cons_tl/1, fun_body/1, fun_vars/1, get_ann/1, int_val/1,
- is_c_atom/1, is_c_int/1, let_arg/1, let_body/1, let_vars/1,
- letrec_body/1, letrec_defs/1, module_defs/1,
- module_defs/1, module_exports/1, pat_vars/1,
- primop_args/1, primop_name/1, receive_action/1,
- receive_clauses/1, receive_timeout/1, seq_arg/1,
- seq_body/1, set_ann/2, try_arg/1, try_body/1,
- try_evars/1, try_handler/1, try_vars/1, tuple_arity/1,
- tuple_es/1, type/1, values_es/1, var_name/1]).
-
--import(cerl_trees, [get_label/1]).
-
--ifdef(DEBUG).
--define(ANNOTATE(X), case erl_types:t_to_string(X) of Q when length(Q) < 255 -> list_to_atom(Q); Q -> Q end).
--else.
--define(ANNOTATE(X), X).
--endif.
-
-%% Limit for type representation depth.
--define(DEF_LIMIT, 3).
-
-
-%% @spec core_transform(Module::cerl_records(), Options::[term()]) ->
-%% cerl_records()
-%%
-%% @doc Annotates a module represented by records with type
-%% information. See <code>annotate/1</code> for details.
-%%
-%% <p>Use the compiler option <code>{core_transform, cerl_typean}</code>
-%% to insert this function as a compilation pass.</p>
-%%
-%% @see module/2
-
--spec core_transform(cerl:cerl(), [term()]) -> cerl:cerl().
-
-core_transform(Code, _Opts) ->
- {Code1, _} = cerl_trees:label(cerl:from_records(Code)),
- %% io:fwrite("Running type analysis..."),
- %% {T1,_} = statistics(runtime),
- {Code2, _, _} = annotate(Code1),
- %% {T2,_} = statistics(runtime),
- %% io:fwrite("(~w ms).\n", [T2 - T1]),
- cerl:to_records(Code2).
-
-
-%% =====================================================================
-%% annotate(Tree) -> {Tree1, Type, Vars}
-%%
-%% Tree = cerl:cerl()
-%%
-%% Analyzes `Tree' (see `analyze') and appends terms `{type, Type}'
-%% to the annotation list of each fun-expression node and
-%% apply-expression node of `Tree', respectively, where `Labels' is
-%% an ordered-set list of labels of fun-expressions in `Tree',
-%% possibly also containing the atom `external', corresponding to
-%% the dependency information derived by the analysis. Any previous
-%% such annotations are removed from `Tree'. `Tree1' is the
-%% modified tree; for details on `OutList', `Outputs' ,
-%% `Dependencies' and `Escapes', see `analyze'.
-%%
-%% Note: `Tree' must be annotated with labels in order to use this
-%% function; see `analyze' for details.
-
-annotate(Tree) ->
- annotate(Tree, ?DEF_LIMIT).
-
-annotate(Tree, Limit) ->
- {_, _, Esc, Dep, Par} = cerl_closurean:analyze(Tree),
- annotate(Tree, Limit, Esc, Dep, Par).
-
-annotate(Tree, Limit, Esc, Dep, Par) ->
- {Type, Out, Vars} = analyze(Tree, Limit, Esc, Dep, Par),
- DelAnn = fun (T) -> set_ann(T, delete_ann(type, get_ann(T))) end,
- SetType = fun (T, Dict) ->
- case dict:find(get_label(T), Dict) of
- {ok, X} ->
- case t_is_any(X) of
- true ->
- DelAnn(T);
- false ->
- set_ann(T, append_ann(type,
- ?ANNOTATE(X),
- get_ann(T)))
- end;
- error ->
- DelAnn(T)
- end
- end,
- F = fun (T) ->
- case type(T) of
- var ->
- SetType(T, Vars);
- apply ->
- SetType(T, Out);
- call ->
- SetType(T, Out);
- primop ->
- SetType(T, Out);
- 'fun' ->
- SetType(T, Out);
- _ ->
- DelAnn(T)
- end
- end,
- {cerl_trees:map(F, Tree), Type, Vars}.
-
-append_ann(Tag, Val, [X | Xs]) ->
- if tuple_size(X) >= 1, element(1, X) =:= Tag ->
- append_ann(Tag, Val, Xs);
- true ->
- [X | append_ann(Tag, Val, Xs)]
- end;
-append_ann(Tag, Val, []) ->
- [{Tag, Val}].
-
-delete_ann(Tag, [X | Xs]) ->
- if tuple_size(X) >= 1, element(1, X) =:= Tag ->
- delete_ann(Tag, Xs);
- true ->
- [X | delete_ann(Tag, Xs)]
- end;
-delete_ann(_, []) ->
- [].
-
-
-%% =====================================================================
-%% analyze(Tree) -> {OutList, Outputs, Dependencies}
-%%
-%% Tree = cerl:cerl()
-%% OutList = [LabelSet] | none
-%% Outputs = dict(integer(), OutList)
-%% Dependencies = dict(integer(), LabelSet)
-%% LabelSet = ordset(Label)
-%% Label = integer() | external
-%%
-%% Analyzes a module or an expression represented by `Tree'.
-%%
-%% The returned `OutList' is a list of sets of labels of
-%% fun-expressions which correspond to the possible closures in the
-%% value list produced by `Tree' (viewed as an expression; the
-%% "value" of a module contains its exported functions). The atom
-%% `none' denotes missing or conflicting information.
-%%
-%% The atom `external' in any label set denotes any possible
-%% function outside `Tree', including those in `Escapes'.
-%%
-%% `Outputs' is a mapping from the labels of fun-expressions in
-%% `Tree' to corresponding lists of sets of labels of
-%% fun-expressions (or the atom `none'), representing the possible
-%% closures in the value lists returned by the respective
-%% functions.
-%%
-%% `Dependencies' is a similar mapping from the labels of
-%% fun-expressions and apply-expressions in `Tree' to sets of
-%% labels of corresponding fun-expressions which may contain call
-%% sites of the functions or be called from the call sites,
-%% respectively. Any such label not defined in `Dependencies'
-%% represents an unreachable function or a dead or faulty
-%% application.
-%%
-%% `Escapes' is the set of labels of fun-expressions in `Tree' such
-%% that corresponding closures may be accessed from outside `Tree'.
-%%
-%% Note: `Tree' must be annotated with labels (as done by the
-%% function `cerl_trees:label/1') in order to use this function.
-%% The label annotation `{label, L}' (where L should be an integer)
-%% must be the first element of the annotation list of each node in
-%% the tree. Instances of variables bound in `Tree' which denote
-%% the same variable must have the same label; apart from this,
-%% labels should be unique. Constant literals do not need to be
-%% labeled.
-
--record(state, {k, vars, out, dep, work, funs, envs}).
-
-%% Note: In order to keep our domain simple, we assume that all remote
-%% calls and primops return a single value, if any.
-
-%% We wrap the given syntax tree T in a fun-expression labeled `top',
-%% which is initially in the set of escaped labels. `top' will be
-%% visited at least once.
-%%
-%% We create a separate function labeled `external', defined as:
-%% "External = fun () -> Any", which will represent any and all
-%% functions outside T, and whose return value has unknown type.
-
--type label() :: integer() | 'external' | 'top'.
--type ordset(X) :: [X]. % XXX: TAKE ME OUT
--type labelset() :: ordset(label()).
--type outlist() :: [labelset()] | 'none'.
-
--spec analyze(cerl:cerl()) -> {outlist(), dict:dict(), dict:dict()}.
-
-analyze(Tree) ->
- analyze(Tree, ?DEF_LIMIT).
-
-analyze(Tree, Limit) ->
- {_, _, Esc, Dep, Par} = cerl_closurean:analyze(Tree),
- analyze(Tree, Limit, Esc, Dep, Par).
-
-analyze(Tree, Limit, Esc0, Dep0, Par) ->
- %% Note that we use different name spaces for variable labels and
- %% function/call site labels. We assume that the labeling of Tree
- %% only uses integers, not atoms.
- LabelExtL = [{label, external}],
- External = ann_c_var(LabelExtL, {external, 1}),
- ExtFun = ann_c_fun(LabelExtL, [], ann_c_var([{label, any}], 'Any')),
-%%% io:fwrite("external fun:\n~s.\n",
-%%% [cerl_prettypr:format(ExtFun, [noann, {paper, 80}])]),
- LabelTopL = [{label, top}],
- Top = ann_c_var(LabelTopL, {top, 0}),
- TopFun = ann_c_fun(LabelTopL, [], Tree),
-
- %% The "start fun" just makes the initialisation easier. It is not
- %% itself in the call graph.
- StartFun = ann_c_fun([{label, start}], [],
- c_letrec([{External, ExtFun}, {Top, TopFun}],
- c_nil())),
-%%% io:fwrite("start fun:\n~s.\n",
-%%% [cerl_prettypr:format(StartFun, [{paper, 80}])]),
-
- %% Gather a database of all fun-expressions in Tree and initialise
- %% their outputs and parameter variables. All escaping functions can
- %% receive any values as inputs. Also add an extra dependency edge
- %% from each fun-expression label to its parent fun-expression.
-%%% io:fwrite("Escape: ~p.\n",[Esc0]),
- Esc = sets:from_list(Esc0, [{version, 2}]),
- Any = t_any(),
- None = t_none(),
- Funs0 = dict:new(),
- Vars0 = dict:store(any, Any, dict:new()),
- Out0 = dict:store(top, None,
- dict:store(external, None, dict:new())),
- Envs0 = dict:store(top, dict:new(),
- dict:store(external, dict:new(), dict:new())),
- F = fun (T, S = {Fs, Vs, Os, Es}) ->
- case type(T) of
- 'fun' ->
- L = get_label(T),
- As = fun_vars(T),
- X = case sets:is_element(L, Esc) of
- true -> Any;
- false -> None
- end,
- {dict:store(L, T, Fs),
- bind_vars_single(As, X, Vs),
- dict:store(L, None, Os),
- dict:store(L, dict:new(), Es)};
- _ ->
- S
- end
- end,
- {Funs, Vars, Out, Envs} = cerl_trees:fold(F, {Funs0, Vars0, Out0,
- Envs0}, StartFun),
-
- %% Add dependencies from funs to their parent funs.
- Dep = lists:foldl(fun ({L, L1}, D) -> add_dep(L, L1, D) end,
- Dep0, dict:to_list(Par)),
-
- %% Enter the fixpoint iteration at the StartFun.
- St = loop(TopFun, top, #state{vars = Vars,
- out = Out,
- dep = Dep,
- work = init_work(),
- funs = Funs,
- envs = Envs,
- k = Limit}),
- {dict:fetch(top, St#state.out),
- tidy_dict([top, external], St#state.out),
- tidy_dict([any], St#state.vars)}.
-
-tidy_dict([X | Xs], D) ->
- tidy_dict(Xs, dict:erase(X, D));
-tidy_dict([], D) ->
- D.
-
-loop(T, L, St0) ->
-%%% io:fwrite("analyzing: ~w.\n",[L]),
-%%% io:fwrite("work: ~w.\n", [Queue0]),
- Env = dict:fetch(L, St0#state.envs),
- X0 = dict:fetch(L, St0#state.out),
- {X1, St1} = visit(fun_body(T), Env, St0),
- X = limit(X1, St1#state.k),
- {W, M} = case equal(X0, X) of
- true ->
- {St1#state.work, St1#state.out};
- false ->
-%%% io:fwrite("out (~w) changed: ~s <- ~s.\n",
-%%% [L, erl_types:t_to_string(X),
-%%% erl_types:t_to_string(X0)]),
- M1 = dict:store(L, X, St1#state.out),
- case dict:find(L, St1#state.dep) of
- {ok, S} ->
-%%% io:fwrite("adding work: ~w.\n", [S]),
- {add_work(S, St1#state.work), M1};
- error ->
- {St1#state.work, M1}
- end
- end,
- St2 = St1#state{out = M},
- case take_work(W) of
- {ok, L1, W1} ->
- T1 = dict:fetch(L1, St2#state.funs),
- loop(T1, L1, St2#state{work = W1});
- none ->
- St2
- end.
-
-visit(T, Env, St) ->
- case type(T) of
- literal ->
- {t_from_term(concrete(T)), St};
- var ->
- %% If a variable is not already in the store at this point,
- %% we initialize it to 'none()'.
- L = get_label(T),
- Vars = St#state.vars,
- case dict:find(L, Vars) of
- {ok, X} ->
- case dict:find(var_name(T), Env) of
- {ok, X1} ->
-%%% io:fwrite("filtered variable reference: ~w:~s.\n",
-%%% [var_name(T), erl_types:t_to_string(X1)]),
- {meet(X, X1), St};
- error ->
- {X, St}
- end;
- error ->
- X = t_none(),
- Vars1 = dict:store(L, X, Vars),
- St1 = St#state{vars = Vars1},
- {X, St1}
- end;
- 'fun' ->
- %% Must revisit the fun also, because its environment might
- %% have changed. (We don't keep track of such dependencies.)
- L = get_label(T),
- Xs = [dict:fetch(get_label(V), St#state.vars)
- || V <- fun_vars(T)],
- X = dict:fetch(L, St#state.out),
- St1 = St#state{work = add_work([L], St#state.work),
- envs = dict:store(L, Env, St#state.envs)},
- {t_fun(Xs, X), St1};
- values ->
- {Xs, St1} = visit_list(values_es(T), Env, St),
- {t_product(Xs), St1};
- cons ->
- {[X1, X2], St1} = visit_list([cons_hd(T), cons_tl(T)], Env, St),
- {t_cons(X1, X2), St1};
- tuple ->
- {Xs, St1} = visit_list(tuple_es(T), Env, St),
- {t_tuple(Xs), St1};
- 'let' ->
- {X, St1} = visit(let_arg(T), Env, St),
- LetVars = let_vars(T),
- St1Vars = St1#state.vars,
- Vars = case t_is_any(X) orelse t_is_none(X) of
- true ->
- bind_vars_single(LetVars, X, St1Vars);
- false ->
- bind_vars(LetVars, t_to_tlist(X), St1Vars)
- end,
- visit(let_body(T), Env, St1#state{vars = Vars});
- seq ->
- {_, St1} = visit(seq_arg(T), Env, St),
- visit(seq_body(T), Env, St1);
- apply ->
- {_F, St1} = visit(apply_op(T), Env, St),
- {As, St2} = visit_list(apply_args(T), Env, St1),
- L = get_label(T),
- Ls = get_deps(L, St#state.dep),
- Out = St2#state.out,
- X = join_list([dict:fetch(L1, Out) || L1 <- Ls]),
- Out1 = dict:store(L, X, Out),
- {X, call_site(Ls, As, St2#state{out = Out1})};
- call ->
- M = call_module(T),
- F = call_name(T),
- As = call_args(T),
- {[X1, X2], St1} = visit_list([M, F], Env, St),
- {Xs, St2} = visit_list(As, Env, St1),
-%%% io:fwrite("call: ~w:~w(~w).\n",[X1,X2,Xs]),
- X = case {t_atom_vals(X1), t_atom_vals(X2)} of
- {[M1], [F1]} ->
- A = length(As),
-%%% io:fwrite("known call: ~w:~w/~w.\n",
-%%% [M1, F1, A]),
- call_type(M1, F1, A, Xs);
- _ ->
- t_any()
- end,
- L = get_label(T),
- {X, St2#state{out = dict:store(L, X, St2#state.out)}};
- primop ->
- As = primop_args(T),
- {Xs, St1} = visit_list(As, Env, St),
- F = atom_val(primop_name(T)),
- A = length(As),
- L = get_label(T),
- X = primop_type(F, A, Xs),
- {X, St1#state{out = dict:store(L, X, St1#state.out)}};
- 'case' ->
- {X, St1} = visit(case_arg(T), Env, St),
- Xs = case t_is_any(X) orelse t_is_none(X) of
- true ->
- [X || _ <- cerl:case_clauses(T)];
- false ->
- t_to_tlist(X)
- end,
- join_visit_clauses(Xs, case_clauses(T), Env, St1);
- 'receive' ->
- Any = t_any(),
- {X1, St1} = join_visit_clauses([Any], receive_clauses(T),
- Env, St),
- {X2, St2} = visit(receive_timeout(T), Env, St1),
- case t_is_atom(X2) andalso (t_atom_vals(X2) =:= [infinity]) of
- true ->
- {X1, St2};
- false ->
- {X3, St3} = visit(receive_action(T), Env, St2),
- {join(X1, X3), St3}
- end;
- 'try' ->
- {X, St1} = visit(try_arg(T), Env, St),
- Any = t_any(),
- Atom = t_atom(),
- TryVars = try_vars(T),
- St1Vars = St1#state.vars,
- Vars = case t_is_any(X) orelse t_is_none(X) of
- true ->
- bind_vars_single(TryVars, X, St1Vars);
- false ->
- bind_vars(TryVars, t_to_tlist(X), St1Vars)
- end,
- {X1, St2} = visit(try_body(T), Env, St1#state{vars = Vars}),
- EVars = bind_vars(try_evars(T), [Atom, Any, Any], St2#state.vars),
- {X2, St3} = visit(try_handler(T), Env, St2#state{vars = EVars}),
- {join(X1, X2), St3};
- 'catch' ->
- {_, St1} = visit(catch_body(T), Env, St),
- {t_any(), St1};
- binary ->
- {_, St1} = visit_list(binary_segments(T), Env, St),
- {t_binary(), St1};
- bitstr ->
- %% The other fields are constant literals.
- {_, St1} = visit(bitstr_val(T), Env, St),
- {_, St2} = visit(bitstr_size(T), Env, St1),
- {t_none(), St2};
- letrec ->
- %% All the bound funs should be revisited, because the
- %% environment might have changed.
- Vars = bind_defs(letrec_defs(T), St#state.vars,
- St#state.out),
- Ls = [get_label(F) || {_, F} <- letrec_defs(T)],
- St1 = St#state{work = add_work(Ls, St#state.work),
- vars = Vars},
- visit(letrec_body(T), Env, St1);
- module ->
- %% We handle a module as a sequence of function variables in
- %% the body of a `letrec'.
- {_, St1} = visit(c_letrec(module_defs(T),
- c_values(module_exports(T))),
- Env, St),
- {t_none(), St1}
- end.
-
-visit_clause(T, Xs, Env, St) ->
- Env1 = Env,
- Vars = bind_pats(clause_pats(T), Xs, St#state.vars),
- G = clause_guard(T),
- {_, St1} = visit(G, Env1, St#state{vars = Vars}),
- Env2 = guard_filters(G, Env1),
- visit(clause_body(T), Env2, St1).
-
-%% We assume correct value-list typing.
-
-visit_list([T | Ts], Env, St) ->
- {X, St1} = visit(T, Env, St),
- {Xs, St2} = visit_list(Ts, Env, St1),
- {[X | Xs], St2};
-visit_list([], _Env, St) ->
- {[], St}.
-
-join_visit_clauses(Xs, [T | Ts], Env, St) ->
- {X1, St1} = visit_clause(T, Xs, Env, St),
- {X2, St2} = join_visit_clauses(Xs, Ts, Env, St1),
- {join(X1, X2), St2};
-join_visit_clauses(_, [], _Env, St) ->
- {t_none(), St}.
-
-bind_defs([{V, F} | Ds], Vars, Out) ->
- Xs = [dict:fetch(get_label(V1), Vars) || V1 <- fun_vars(F)],
- X = dict:fetch(get_label(F), Out),
- bind_defs(Ds, dict:store(get_label(V), t_fun(Xs, X), Vars), Out);
-bind_defs([], Vars, _Out) ->
- Vars.
-
-bind_pats(Ps, Xs, Vars) ->
- if length(Xs) =:= length(Ps) ->
- bind_pats_list(Ps, Xs, Vars);
- true ->
- bind_pats_single(Ps, t_none(), Vars)
- end.
-
-bind_pats_list([P | Ps], [X | Xs], Vars) ->
- Vars1 = bind_pat_vars(P, X, Vars),
- bind_pats_list(Ps, Xs, Vars1);
-bind_pats_list([], [], Vars) ->
- Vars.
-
-bind_pats_single([P | Ps], X, Vars) ->
- bind_pats_single(Ps, X, bind_pat_vars(P, X, Vars));
-bind_pats_single([], _X, Vars) ->
- Vars.
-
-bind_pat_vars(P, X, Vars) ->
- case type(P) of
- var ->
- dict:store(get_label(P), X, Vars);
- literal ->
- Vars;
- cons ->
- case t_is_cons(X) of
- true ->
- %% If X is "nonempty proper list of X1", then the
- %% head has type X1 and the tail has type "proper
- %% list of X1". (If X is just "cons cell of X1",
- %% then both head and tail have type X1.)
- Vars1 = bind_pat_vars(cons_hd(P), t_cons_hd(X),
- Vars),
- bind_pat_vars(cons_tl(P), t_cons_tl(X), Vars1);
- false ->
- case t_is_list(X) of
- true ->
- %% If X is "proper list of X1", then the
- %% head has type X1 and the tail has type
- %% "proper list of X1", i.e., type X.
- Vars1 = bind_pat_vars(cons_hd(P),
- t_list_elements(X),
- Vars),
- bind_pat_vars(cons_tl(P), X, Vars1);
- false ->
- case t_is_maybe_improper_list(X) of
- true ->
- %% If X is "cons cell of X1", both
- %% the head and tail have type X1.
- X1 = t_list_elements(X),
- Vars1 = bind_pat_vars(cons_hd(P),
- X1, Vars),
- bind_pat_vars(cons_tl(P), X1,
- Vars1);
- false ->
- bind_vars_single(pat_vars(P),
- top_or_bottom(X),
- Vars)
- end
- end
- end;
- tuple ->
- case t_is_tuple(X) of
- true ->
- case t_tuple_subtypes(X) of
- unknown ->
- bind_vars_single(pat_vars(P), top_or_bottom(X),
- Vars);
- [Tuple] ->
- case t_tuple_size(Tuple) =:= tuple_arity(P) of
- true ->
- bind_pats_list(tuple_es(P),
- t_tuple_args(Tuple), Vars);
-
- false ->
- bind_vars_single(pat_vars(P),
- top_or_bottom(X), Vars)
- end;
- List when is_list(List) ->
- bind_vars_single(pat_vars(P), top_or_bottom(X),
- Vars)
- end;
- false ->
- bind_vars_single(pat_vars(P), top_or_bottom(X), Vars)
- end;
- binary ->
- bind_pats_single(binary_segments(P), t_none(), Vars);
- bitstr ->
- %% Only the Value field is a new binding. Size is already
- %% bound, and the other fields are constant literals.
- %% We could create a filter for Size being an integer().
- Size = bitstr_size(P),
- ValType =
- case concrete(bitstr_type(P)) of
- float -> t_float();
- binary -> t_binary();
- integer ->
- case is_c_int(Size) of
- false -> t_integer();
- true ->
- SizeVal = int_val(Size),
- Flags = concrete(bitstr_flags(P)),
- case lists:member(signed, Flags) of
- true ->
- t_from_range(-(1 bsl (SizeVal - 1)),
- 1 bsl (SizeVal - 1) - 1);
- false ->
- t_from_range(0,1 bsl SizeVal - 1)
- end
- end
- end,
- bind_pat_vars(bitstr_val(P), ValType, Vars);
- alias ->
- P1 = alias_pat(P),
- Vars1 = bind_pat_vars(P1, X, Vars),
- dict:store(get_label(alias_var(P)), pat_type(P1, Vars1),
- Vars1)
- end.
-
-pat_type(P, Vars) ->
- case type(P) of
- var ->
- dict:fetch(get_label(P), Vars);
- literal ->
- t_from_term(concrete(P));
- cons ->
- t_cons(pat_type(cons_hd(P), Vars),
- pat_type(cons_tl(P), Vars));
- tuple ->
- t_tuple([pat_type(E, Vars) || E <- tuple_es(P)]);
- binary ->
- t_binary();
- alias ->
- pat_type(alias_pat(P), Vars)
- end.
-
-bind_vars(Vs, Xs, Vars) ->
- if length(Vs) =:= length(Xs) ->
- bind_vars_list(Vs, Xs, Vars);
- true ->
- bind_vars_single(Vs, t_none(), Vars)
- end.
-
-bind_vars_list([V | Vs], [X | Xs], Vars) ->
- bind_vars_list(Vs, Xs, dict:store(get_label(V), X, Vars));
-bind_vars_list([], [], Vars) ->
- Vars.
-
-bind_vars_single([V | Vs], X, Vars) ->
- bind_vars_single(Vs, X, dict:store(get_label(V), X, Vars));
-bind_vars_single([], _X, Vars) ->
- Vars.
-
-add_dep(Source, Target, Deps) ->
- case dict:find(Source, Deps) of
- {ok, X} ->
- case set__is_member(Target, X) of
- true ->
- Deps;
- false ->
-%%% io:fwrite("new dep: ~w <- ~w.\n", [Target, Source]),
- dict:store(Source, set__add(Target, X), Deps)
- end;
- error ->
-%%% io:fwrite("new dep: ~w <- ~w.\n", [Target, Source]),
- dict:store(Source, set__singleton(Target), Deps)
- end.
-
-%% This handles a call site, updating parameter variables with respect
-%% to the actual parameters.
-
-call_site(Ls, Xs, St) ->
-%% io:fwrite("call site: ~w ~s.\n",
-%% [Ls, erl_types:t_to_string(erl_types:t_product(Xs))]),
- {W, V} = call_site(Ls, Xs, St#state.work, St#state.vars,
- St#state.funs, St#state.k),
- St#state{work = W, vars = V}.
-
-call_site([L | Ls], Xs, W, V, Fs, Limit) ->
- Vs = fun_vars(dict:fetch(L, Fs)),
- case bind_args(Vs, Xs, V, Limit) of
- {V1, true} ->
- call_site(Ls, Xs, add_work([L], W), V1, Fs, Limit);
- {V1, false} ->
- call_site(Ls, Xs, W, V1, Fs, Limit)
- end;
-call_site([], _, W, V, _, _) ->
- {W, V}.
-
-%% If the arity does not match the call, nothing is done here.
-
-bind_args(Vs, Xs, Vars, Limit) ->
- if length(Vs) =:= length(Xs) ->
- bind_args(Vs, Xs, Vars, Limit, false);
- true ->
- {Vars, false}
- end.
-
-bind_args([V | Vs], [X | Xs], Vars, Limit, Ch) ->
- L = get_label(V),
- {Vars1, Ch1} = bind_arg(L, X, Vars, Limit, Ch),
- bind_args(Vs, Xs, Vars1, Limit, Ch1);
-bind_args([], [], Vars, _Limit, Ch) ->
- {Vars, Ch}.
-
-%% bind_arg(L, X, Vars, Limit) ->
-%% bind_arg(L, X, Vars, Limit, false).
-
-bind_arg(L, X, Vars, Limit, Ch) ->
- X0 = dict:fetch(L, Vars),
- X1 = limit(join(X, X0), Limit),
- case equal(X0, X1) of
- true ->
- {Vars, Ch};
- false ->
-%%% io:fwrite("arg (~w) changed: ~s <- ~s + ~s.\n",
-%%% [L, erl_types:t_to_string(X1),
-%%% erl_types:t_to_string(X0),
-%%% erl_types:t_to_string(X)]),
- {dict:store(L, X1, Vars), true}
- end.
-
-%% Domain: type(), defined in module `erl_types'.
-
-meet(X, Y) -> t_inf(X, Y).
-
-join(X, Y) -> t_sup(X, Y).
-
-join_list([Xs | Xss]) ->
- join(Xs, join_list(Xss));
-join_list([]) ->
- t_none().
-
-equal(X, Y) -> X =:= Y.
-
-limit(X, K) -> t_limit(X, K).
-
-top_or_bottom(T) ->
- case t_is_none(T) of
- true ->
- T;
- false ->
- t_any()
- end.
-
-strict(Xs, T) ->
- case erl_types:any_none(Xs) of
- true ->
- t_none();
- false ->
- T
- end.
-
-%% Set abstraction for label sets.
-
-%% set__new() -> [].
-
-set__singleton(X) -> [X].
-
-%% set__to_list(S) -> S.
-
-%% set__from_list(S) -> ordsets:from_list(S).
-
-%% set__union(X, Y) -> ordsets:union(X, Y).
-
-set__add(X, S) -> ordsets:add_element(X, S).
-
-set__is_member(X, S) -> ordsets:is_element(X, S).
-
-%% set__subtract(X, Y) -> ordsets:subtract(X, Y).
-
-%% set__equal(X, Y) -> X =:= Y.
-
-%% A simple but efficient functional queue.
-
-queue__new() -> {[], []}.
-
-queue__put(X, {In, Out}) -> {[X | In], Out}.
-
-queue__get({In, [X | Out]}) -> {ok, X, {In, Out}};
-queue__get({[], _}) -> empty;
-queue__get({In, _}) ->
- [X | In1] = lists:reverse(In),
- {ok, X, {[], In1}}.
-
-%% The work list - a queue without repeated elements.
-
-init_work() ->
- {queue__put(external, queue__new()), sets:new([{version, 2}])}.
-
-add_work(Ls, {Q, Set}) ->
- add_work(Ls, Q, Set).
-
-%% Note that the elements are enqueued in order.
-
-add_work([L | Ls], Q, Set) ->
- case sets:is_element(L, Set) of
- true ->
- add_work(Ls, Q, Set);
- false ->
- add_work(Ls, queue__put(L, Q), sets:add_element(L, Set))
- end;
-add_work([], Q, Set) ->
- {Q, Set}.
-
-take_work({Queue0, Set0}) ->
- case queue__get(Queue0) of
- {ok, L, Queue1} ->
- Set1 = sets:del_element(L, Set0),
- {ok, L, {Queue1, Set1}};
- empty ->
- none
- end.
-
-get_deps(L, Dep) ->
- case dict:find(L, Dep) of
- {ok, Ls} -> Ls;
- error -> []
- end.
-
-%% Type information for built-in functions. We do not check that the
-%% arguments have the correct type; if the call would actually fail,
-%% rather than return a value, this is a safe overapproximation.
-
-primop_type(match_fail, 1, _) -> t_none();
-primop_type(_, _, Xs) -> strict(Xs, t_any()).
-
-call_type(M, F, A, Xs) ->
- erl_bif_types:type(M, F, A, Xs).
-
-guard_filters(T, Env) ->
- guard_filters(T, Env, dict:new()).
-
-guard_filters(T, Env, Vars) ->
- case type(T) of
- call ->
- M = call_module(T),
- F = call_name(T),
- case is_c_atom(M) andalso is_c_atom(F) of
- true ->
- As = call_args(T),
- case {atom_val(M), atom_val(F), length(As)} of
- {erlang, 'and', 2} ->
- [A1, A2] = As,
- guard_filters(A1, guard_filters(A2, Env));
- {erlang, is_atom, 1} ->
- filter(As, t_atom(), Env);
- {erlang, is_binary, 1} ->
- filter(As, t_binary(), Env);
- {erlang, is_float, 1} ->
- filter(As, t_float(), Env);
- {erlang, is_function, 1} ->
- filter(As, t_fun(), Env);
- {erlang, is_integer, 1} ->
- filter(As, t_integer(), Env);
- {erlang, is_list, 1} ->
- filter(As, t_maybe_improper_list(), Env);
- {erlang, is_number, 1} ->
- filter(As, t_number(), Env);
- {erlang, is_pid, 1} ->
- filter(As, t_pid(), Env);
- {erlang, is_port, 1} ->
- filter(As, t_port(), Env);
- {erlang, is_reference, 1} ->
- filter(As, t_reference(), Env);
- {erlang, is_tuple, 1} ->
- filter(As, t_tuple(), Env);
- _ ->
- Env
- end;
- false ->
- Env
- end;
- var ->
- case dict:find(var_name(T), Vars) of
- {ok, T1} ->
- guard_filters(T1, Env, Vars);
- error ->
- Env
- end;
- 'let' ->
- case let_vars(T) of
- [V] ->
- guard_filters(let_body(T), Env,
- dict:store(var_name(V), let_arg(T),
- Vars));
- _ ->
- Env
- end;
- values ->
- case values_es(T) of
- [T1] ->
- guard_filters(T1, Env, Vars);
- _ ->
- Env
- end;
- _ ->
- Env
- end.
-
-filter(As, X, Env) ->
- [A] = As,
- case type(A) of
- var ->
- V = var_name(A),
- case dict:find(V, Env) of
- {ok, X1} ->
- dict:store(V, meet(X, X1), Env);
- error ->
- dict:store(V, X, Env)
- end;
- _ ->
- Env
- end.
-
-%% Callback hook for cerl_prettypr:
-
--spec pp_hook() -> fun((cerl:cerl(), _, fun((_,_) -> any())) -> any()).
-
-pp_hook() ->
- fun pp_hook/3.
-
-pp_hook(Node, Ctxt, Cont) ->
- As = cerl:get_ann(Node),
- As1 = proplists:delete(type, proplists:delete(label, As)),
- As2 = proplists:delete(typesig, proplists:delete(file, As1)),
- D = Cont(cerl:set_ann(Node, []), Ctxt),
- T = case proplists:lookup(type, As) of
- {type, T0} -> T0;
- none ->
- case proplists:lookup(typesig, As) of
- {typesig, T0} -> T0;
- none -> t_any()
- end
- end,
- D1 = case erl_types:t_is_any(T) of
- true ->
- D;
- false ->
- case cerl:is_literal(Node) of
- true ->
- D;
- false ->
- S = erl_types:t_to_string(T),
- Q = prettypr:beside(prettypr:text("::"),
- prettypr:text(S)),
- prettypr:beside(D, Q)
- end
- end,
- cerl_prettypr:annotate(D1, As2, Ctxt).
-
-%% =====================================================================
diff --git a/lib/dialyzer/src/dialyzer.app.src b/lib/dialyzer/src/dialyzer.app.src
index 3090895190..93d004d2e7 100644
--- a/lib/dialyzer/src/dialyzer.app.src
+++ b/lib/dialyzer/src/dialyzer.app.src
@@ -22,11 +22,7 @@
{application, dialyzer,
[{description, "DIscrepancy AnaLYZer of ERlang programs, version %VSN%"},
{vsn, "%VSN%"},
- {modules, [cerl_closurean,
- cerl_lib,
- cerl_pmatch,
- cerl_prettypr,
- cerl_typean,
+ {modules, [cerl_prettypr,
dialyzer,
dialyzer_analysis_callgraph,
dialyzer_behaviours,
--
2.31.1
