%% -*- erlang-indent-level: 4 -*-
%%
%% %CopyrightBegin%
%%
%% Copyright Ericsson AB 2003-2016. All Rights Reserved.
%%
%% Licensed under the Apache License, Version 2.0 (the "License");
%% you may not use this file except in compliance with the License.
%% You may obtain a copy of the License at
%%
%% http://www.apache.org/licenses/LICENSE-2.0
%%
%% Unless required by applicable law or agreed to in writing, software
%% distributed under the License is distributed on an "AS IS" BASIS,
%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
%% See the License for the specific language governing permissions and
%% limitations under the License.
%%
%% %CopyrightEnd%
%%
%% Type analysis of Core Erlang programs.
%%
%% Copyright (C) 2001-2002 Richard Carlsson
%%
%% Author contact: richardc@it.uu.se
%%
%% @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 annotate/1 for details.
%%
%% Use the compiler option {core_transform, cerl_typean}
%% to insert this function as a compilation pass.
%%
%% @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),
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()}.
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).
%% =====================================================================