cerl_messagean.erl

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

%% =====================================================================
%% Message analysis of Core Erlang programs.
%%
%% Copyright (C) 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$
%%
%% =====================================================================

%% TODO: might need a "top" (`any') element for any-length value lists.

-module(cerl_messagean).

-export([annotate/1]).

-import(cerl, [alias_pat/1, alias_var/1, ann_c_var/2, ann_c_fun/3,
	       apply_args/1, apply_op/1, atom_val/1, bitstr_size/1,
	       bitstr_val/1, binary_segments/1, c_letrec/2,
	       ann_c_tuple/2, 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, 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_vars/1,
	       try_evars/1, try_handler/1, tuple_es/1, type/1,
	       values_es/1]).

-import(cerl_trees, [get_label/1]).

-define(DEF_LIMIT, 4).

%-export([test/1, test1/1, ttest/1]).

% ttest(F) ->
%     {T, _} = cerl_trees:label(user_default:read(F)),
%     {Time0, _} = erlang:statistics(runtime),
%     analyze(T),
%     {Time1, _} = erlang:statistics(runtime),
%     Time1 - Time0.

% test(F) ->
%     {T, _} = cerl_trees:label(user_default:read(F)),
%     {Time0, _} = erlang:statistics(runtime),
%     {Esc, _Vars} = analyze(T),
%     {Time1, _} = erlang:statistics(runtime),
%     io:fwrite("messages: ~p.\n", [Esc]),
%     Set = sets:from_list(Esc),
%     H = fun (Node, Ctxt, Cont) ->
% 		Doc = case get_ann(Node) of
% 			  [{label, L} | _] ->
% 			      B = sets:is_element(L, Set),
% 			      bf(Node, Ctxt, Cont, B);
% 			  _ ->
% 			      bf(Node, Ctxt, Cont, false)
% 		      end,
% 		case type(Node) of
% 		    cons -> color(Doc);
% 		    tuple -> color(Doc);
% 		    _ -> Doc
% 		end
% 	end,
%     {ok, FD} = file:open("out.html",[write]),
%     Txt = cerl_prettypr:format(T, [{hook, H},{user,false}]),
%     io:put_chars(FD, "<pre>\n"),
%     io:put_chars(FD, html(Txt)),
%     io:put_chars(FD, "</pre>\n"),
%     file:close(FD),
%     {ok, Time1 - Time0}.

% test1(F) ->
%     {T, _} = cerl_trees:label(user_default:read(F)),
%     {Time0, _} = erlang:statistics(runtime),
%     {T1, Esc, Vars} = annotate(T),
%     {Time1, _} = erlang:statistics(runtime),
%     io:fwrite("messages: ~p.\n", [Esc]),
% %%%     io:fwrite("vars: ~p.\n", [[X || X <- dict:to_list(Vars)]]),
%     T2 = hhl_transform:transform(T1, Vars),
%     Set = sets:from_list(Esc),
%     H = fun (Node, Ctxt, Cont) ->
% 		case get_ann(Node) of
% 		    [{label, L} | _] ->
% 			B = sets:is_element(L, Set),
% 			bf(Node, Ctxt, Cont, B);
% 		    _ ->
% 			bf(Node, Ctxt, Cont, false)
% 		end
% 	end,
%     {ok, FD} = file:open("out.html",[write]),
%     Txt = cerl_prettypr:format(T2, [{hook, H},{user,false}]),
%     io:put_chars(FD, "<pre>\n"),
%     io:put_chars(FD, html(Txt)),
%     io:put_chars(FD, "</pre>\n"),
%     file:close(FD),
%     {ok, Time1 - Time0}.

% html(Cs) ->
%     html(Cs, []).

% html([$#, $< | Cs], As) ->
%     html_1(Cs, [$< | As]);
% html([$< | Cs], As) ->
%     html(Cs, ";tl&" ++ As);
% html([$> | Cs], As) ->
%     html(Cs, ";tg&" ++ As);
% html([$& | Cs], As) ->
%     html(Cs, ";pma&" ++ As);
% html([C | Cs], As) ->
%     html(Cs, [C | As]);
% html([], As) ->
%     lists:reverse(As).

% html_1([$> | Cs], As) ->
%     html(Cs, [$> | As]);
% html_1([C | Cs], As) ->
%     html_1(Cs, [C | As]).

% bf(Node, Ctxt, Cont, B) ->
%     B0 = cerl_prettypr:get_ctxt_user(Ctxt),
%     if B /= B0 ->
% 	    Ctxt1 = cerl_prettypr:set_ctxt_user(Ctxt, B),
% 	    Doc = Cont(Node, Ctxt1),
% 	    case B of
% 		true ->
% 		    Start = "<b>",
% 		    End = "</b>";
% 		false ->
% 		    Start = "</b>",
% 		    End = "<b>"
% 	    end,
% 	    markup(Doc, Start, End);
%        true ->
% 	    Cont(Node, Ctxt)
%     end.

% color(Doc) ->
% %    Doc.
%     markup(Doc, "<font color=blue>", "</font>").

% markup(Doc, Start, End) ->
%     prettypr:beside(
%       prettypr:null_text([$# | Start]),
%       prettypr:beside(Doc,
% 		      prettypr:null_text([$# | End]))).


%% =====================================================================
%% annotate(Tree) -> {Tree1, Escapes}
%%
%%	    Tree = coreErlang()
%%
%%	Analyzes `Tree' (see `analyze') and appends a term 'escapes', to
%%	the annotation list of each constructor expression node and of
%%	`Tree', corresponding to the escape 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.

annotate(T) ->
    {Esc0, Vars} = analyze(T),
    Esc = sets:from_list(Esc0),
    F = fun (T) ->
		case type(T) of
		    literal -> T;
%%% 		    var ->
%%% 			L = get_label(T),
%%% 			T1 = ann_escape(T, L, Esc),
%%% 			X = dict:fetch(L, Vars),
%%% 			set_ann(T1, append_ann({s,X}, get_ann(T1)));
		    _ ->
			L = get_label(T),
			ann_escape(T, L, Esc)
		end
	end,
    {cerl_trees:map(F, T), Esc0, Vars}.

ann_escape(T, L, Esc) ->
    case sets:is_element(L, Esc) of
	true ->
	    set_ann(T, append_ann(escapes, get_ann(T)));
	false ->
	    T
    end.

append_ann(Tag, [X | Xs]) ->
    if is_tuple(X), size(X) >= 1, element(1, X) =:= Tag -> 
	    append_ann(Tag, Xs);
       true ->
	    [X | append_ann(Tag, Xs)]
    end;
append_ann(Tag, []) ->
    [Tag].


%% =====================================================================
%% analyze(Tree) -> Escapes
%%
%%	    Tree = coreErlang()
%%	    Escapes = ordset(Label)
%%	    Label = integer() | external | top
%%
%%	Analyzes a module or an expression represented by `Tree'.
%%
%%	`Escapes' is the set of labels of constructor expressions in
%%	`Tree' such that the created values 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, {vars, out, dep, work, funs, k}).

%% Note: We assume that all remote calls and primops return a single
%% value.

%% The analysis determines which objects (identified by the
%% corresponding "cons-point" labels in the code) are likely to be
%% passed in a message. (If so, we say that they "escape".) It is always
%% safe to assume either case, because the send operation will assure
%% that things are copied if necessary. This analysis tries to
%% anticipate that copying will be done.
%%
%% Rules:
%%   1) An object passed as message argument (or part of such an
%%   argument) to a known send-operation, will probably be a message.
%%   2) A received value is always a message (safe).
%%   3) The external function can return any object (unsafe).
%%   4) A function called from the external function can receive any
%%   object (unsafe) as argument.
%%   5) Unknown functions/operations can return any object (unsafe).

%% 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 () -> Any", which will represent any and all
%% functions outside T, and which returns the 'unsafe' value.

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

analyze(T, Limit) ->
    {_, _, Esc, Dep, _Par} = cerl_closurean:analyze(T),
%%%     io:fwrite("dependencies: ~w.\n", [dict:to_list(Dep)]),
    analyze(T, Limit, Dep, Esc).

analyze(T, Limit, Dep0, Esc0) ->
    %% 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 T only uses integers, not atoms.
    Any = ann_c_var([{label, any}], 'Any'),
    External = ann_c_var([{label, external}], {external, 1}),
    ExtFun = ann_c_fun([{label, external}], [], 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}])]),

    %% Initialise the Any and Escape variables. 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. Bind all module- and letrec-defined variables to their
    %% corresponding labels.
    Esc = sets:from_list(Esc0),
    Unsafe = unsafe(),
    Empty = empty(),
    Funs0 = dict:new(),
    Vars0 = dict:store(escape, empty(), 
		       dict:store(any, Unsafe, dict:new())),
    Out0 = dict:new(),
    F = fun (T, S = {Fs, Vs, Os}) ->
		case type(T) of
		    'fun' ->
			L = get_label(T),
			As = fun_vars(T),
			X = case sets:is_element(L, Esc) of
				true -> Unsafe;
				false -> Empty
			    end,
			{dict:store(L, T, Fs),
			 bind_vars_single(As, X, 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),

    %% Add the dependency for the loop in 'external':
    Dep = add_dep(loop, external, Dep0),

    %% Enter the fixpoint iteration at the StartFun.
    St = loop(StartFun, start, #state{vars = Vars,
				      out = Out,
				      dep = Dep,
				      work = init_work(),
				      funs = Funs,
				      k = Limit}),
    Ms = labels(dict:fetch(escape, St#state.vars)),
    {Ms, St#state.vars}.

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),
    {Xs1, St1} = visit(fun_body(T), L, St0),
    Xs = limit(Xs1, St1#state.k),
    {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},