cerl_typean.erl

来自「OTP是开放电信平台的简称」· ERL 代码 · 共 994 行 · 第 1/2 页

%% -*- erlang-indent-level: 4 -*-
%% =====================================================================
%% Type analysis of Core Erlang programs.
%%
%% Copyright (C) 2001-2002 Richard Carlsson
%%
%% This library is free software; you can redistribute it and/or modify
%% it under the terms of the GNU Lesser General Public License as
%% published by the Free Software Foundation; either version 2 of the
%% License, or (at your option) any later version.
%%
%% This library is distributed in the hope that it will be useful, but
%% WITHOUT ANY WARRANTY; without even the implied warranty of
%% MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
%% Lesser General Public License for more details.
%%
%% You should have received a copy of the GNU Lesser General Public
%% License along with this library; if not, write to the Free Software
%% Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307
%% USA
%%
%% Author contact: [e-mail]
%%
%% $Id$
%%
%% @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_is_atom/1, t_binary/0, t_cons/2,
		    t_cons_hd/1, t_cons_tl/1, t_pos_improper_list/0,
		    t_components/1, t_float/0, t_fun/0, t_fun/2,
		    t_inf/2, t_integer/0, t_atom_vals/1, t_is_cons/1,
		    t_is_pos_improper_list/1, t_is_list/1, t_is_tuple/1,
		    t_is_none/1, t_is_any/1, t_limit/2,
		    t_list_elements/1, t_number/0, t_pid/0, t_port/0,
		    t_product/1, t_ref/0, t_tuple/0, t_tuple/1,
		    t_tuple_args/1, t_tuple_arity/1, t_tuple_subtypes/1, 
		    t_sup/2,
		    t_from_range/2, t_from_term/1, t_none/0]).

-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

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 = coreErlang()
%%
%%	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(T) ->
    annotate(T, ?DEF_LIMIT).

annotate(T, Limit) ->
    {_, _, Esc, Dep, Par} = cerl_closurean:analyze(T),
    annotate(T, Limit, Esc, Dep, Par).

annotate(T, Limit, Esc, Dep, Par) ->
    {Type, Out, Vars} = analyze(T, 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, T), Type, Vars}.

append_ann(Tag, Val, [X | Xs]) ->
    if is_tuple(X), 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 is_tuple(X), 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, Escapes}
%%
%%	    Tree = coreErlang()
%%	    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.

analyze(T) ->
    analyze(T, ?DEF_LIMIT).

analyze(T, Limit) ->
    {_, _, Esc, Dep, Par} = cerl_closurean:analyze(T),
    analyze(T, Limit, Esc, Dep, Par).

analyze(T, 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 T only
    %% uses integers, not atoms.
    External = ann_c_var([{label, external}], {external, 1}),
    ExtFun = ann_c_fun([{label, external}], [],
		       ann_c_var([{label, any}], 'Any')),
%%%     io:fwrite("external fun:\n~s.\n",
%%% 	      [cerl_prettypr:format(ExtFun, [noann, {paper, 80}])]),
    Top = ann_c_var([{label, top}], {top, 0}),
    TopFun = ann_c_fun([{label, top}], [], T),

    %% 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 T 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),
	    Vars = bind_vars(let_vars(T), t_components(X), St1#state.vars),
	    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),
	    join_visit_clauses(t_components(X), 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(),
	    Vars = bind_vars(try_vars(T), t_components(X), St1#state.vars),
	    {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),