The R13B03 release.OTP_R13B03

1 files changed, 580 insertions, 0 deletions

diff --git a/lib/dialyzer/src/dialyzer_dep.erl b/lib/dialyzer/src/dialyzer_dep.erl
new file mode 100644
index 0000000000..670433f003
--- /dev/null
+++ b/lib/dialyzer/src/dialyzer_dep.erl
@@ -0,0 +1,580 @@
+%% -*- erlang-indent-level: 2 -*-
+%%-----------------------------------------------------------------------
+%% %CopyrightBegin%
+%% 
+%% Copyright Ericsson AB 2006-2009. All Rights Reserved.
+%% 
+%% The contents of this file are subject to the Erlang Public License,
+%% Version 1.1, (the "License"); you may not use this file except in
+%% compliance with the License. You should have received a copy of the
+%% Erlang Public License along with this software. If not, it can be
+%% retrieved online at http://www.erlang.org/.
+%% 
+%% Software distributed under the License is distributed on an "AS IS"
+%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See
+%% the License for the specific language governing rights and limitations
+%% under the License.
+%% 
+%% %CopyrightEnd%
+%%
+
+%%%-------------------------------------------------------------------
+%%% File    : dialyzer_dep.erl
+%%% Author  : Tobias Lindahl <[email protected]>
+%%%
+%%% Description: A pretty limited but efficient escape/dependency
+%%%              analysis of Core Erlang.
+%%%
+%%% Created : 28 Oct 2005 by Tobias Lindahl <[email protected]>
+%%%-------------------------------------------------------------------
+-module(dialyzer_dep).
+
+-export([analyze/1]).
+-define(NO_UNUSED, true).
+-ifndef(NO_UNUSED).
+-export([test/1]).
+-endif.
+
+-include("dialyzer.hrl").
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%%
+%% analyze(CoreTree) -> {Deps, Esc, Calls}.
+%%
+%% Deps =  a dict mapping labels of functions to an ordset of functions
+%%         it calls.
+%%
+%% Esc =   an ordset of the labels of escaping functions. A function
+%%         is considered to escape if the control escapes a function,
+%%         i.e., this analysis is not module-local but rather
+%%         function-local.
+%%
+%% Calls = a dict mapping apply:s to an ordset of function labels to
+%%         which the operation can refer to. If 'external' is part of
+%%         the set the operation can be externally defined.
+%%
+
+-spec analyze(cerl:c_module()) -> {dict(), ordset('external' | label()), dict()}.
+
+analyze(Tree) ->
+  %% io:format("Handling ~w\n", [cerl:atom_val(cerl:module_name(Tree))]),
+  {_, State} = traverse(Tree, map__new(), state__new(Tree), top),
+  Esc = state__esc(State), 
+  %% Add dependency from 'external' to all escaping function
+  State1 = state__add_deps(external, output(Esc), State),
+  Deps = state__deps(State1),
+  Calls = state__calls(State1),
+  {map__finalize(Deps), set__to_ordsets(Esc), map__finalize(Calls)}.
+
+traverse(Tree, Out, State, CurrentFun) ->
+  %% io:format("Type: ~w\n", [cerl:type(Tree)]),
+  case cerl:type(Tree) of
+    apply ->
+      Op = cerl:apply_op(Tree),
+      Args = cerl:apply_args(Tree),
+      %% Op is always a variable and should not be marked as escaping
+      %% based on its use.
+      case var =:= cerl:type(Op) of
+	false -> erlang:error({apply_op_not_a_variable, cerl:type(Op)});
+	true -> ok
+      end,
+      OpFuns = case map__lookup(cerl_trees:get_label(Op), Out) of
+		 none -> output(none);
+		 {value, OF} -> OF
+	       end,
+      {ArgFuns, State2} = traverse_list(Args, Out, State, CurrentFun),
+      State3 = state__add_esc(merge_outs(ArgFuns), State2),
+      State4 = state__add_deps(CurrentFun, OpFuns, State3),
+      State5 = state__store_callsite(cerl_trees:get_label(Tree),
+				     OpFuns, length(Args), State4),
+      {output(set__singleton(external)), State5};
+    binary ->
+      {output(none), State};
+    'case' ->
+      Arg = cerl:case_arg(Tree),
+      {Funs, NewState} = traverse(Arg, Out, State, CurrentFun),
+      Clauses = cerl:case_clauses(Tree),
+      traverse_clauses(Clauses, Funs, Out, NewState, CurrentFun);
+    call ->
+      Args = cerl:call_args(Tree),
+      {ArgFuns, State1} = traverse_list(Args, Out, State, CurrentFun),
+      remote_call(Tree, merge_outs(ArgFuns), State1);
+    'catch' ->
+      traverse(cerl:catch_body(Tree), Out, State, CurrentFun);
+    cons ->
+      {HdFuns, State1} = traverse(cerl:cons_hd(Tree), Out, State, CurrentFun),
+      {TlFuns, State2} = traverse(cerl:cons_tl(Tree), Out, State1, CurrentFun),
+      {merge_outs([HdFuns, TlFuns]), State2};
+    'fun' ->
+      %% io:format("Entering fun: ~w\n", [cerl_trees:get_label(Tree)]),
+      Body = cerl:fun_body(Tree),
+      Label = cerl_trees:get_label(Tree),
+      State1 =
+	if CurrentFun =:= top -> 
+	    state__add_deps(top, output(set__singleton(Label)), State);
+	   true -> 
+	    O1 = output(set__singleton(CurrentFun)),
+	    O2 = output(set__singleton(Label)),
+	    TmpState = state__add_deps(Label, O1, State),
+	    state__add_deps(CurrentFun, O2,TmpState)
+	end,
+      {BodyFuns, State2} = traverse(Body, Out, State1, 
+				    cerl_trees:get_label(Tree)),
+      {output(set__singleton(Label)), state__add_esc(BodyFuns, State2)};
+    'let' ->
+      Vars = cerl:let_vars(Tree),
+      Arg = cerl:let_arg(Tree),
+      Body = cerl:let_body(Tree),
+      {ArgFuns, State1} = traverse(Arg, Out, State, CurrentFun),
+      Out1 = bind_list(Vars, ArgFuns, Out),
+      traverse(Body, Out1, State1, CurrentFun);
+    letrec ->
+      Defs = cerl:letrec_defs(Tree),
+      Body = cerl:letrec_body(Tree),
+      Out1 = bind_defs(Defs, Out),
+      State1 = traverse_defs(Defs, Out1, State, CurrentFun),
+      traverse(Body, Out1, State1, CurrentFun);
+    literal ->
+      {output(none), State};
+    module ->
+      Defs = cerl:module_defs(Tree),
+      Out1 = bind_defs(Defs, Out),
+      State1 = traverse_defs(Defs, Out1, State, CurrentFun),
+      {output(none), State1};
+    primop ->
+      Args = cerl:primop_args(Tree),
+      {ArgFuns, State1} = traverse_list(Args, Out, State, CurrentFun),
+      primop(Tree, merge_outs(ArgFuns), State1);
+    'receive' ->
+      Clauses = cerl:receive_clauses(Tree),
+      TimeOut = cerl:receive_timeout(Tree),
+      Action = cerl:receive_action(Tree),
+      {ClauseFuns, State1} = 
+	traverse_clauses(Clauses, output(none), Out, State, CurrentFun),
+      {_, State2} = traverse(TimeOut, Out, State1, CurrentFun),
+      {ActionFuns, State3} = traverse(Action, Out, State2, CurrentFun),
+      {merge_outs([ClauseFuns, ActionFuns]), State3};
+    seq ->
+      {_, State1} = traverse(cerl:seq_arg(Tree), Out, State, CurrentFun),
+      traverse(cerl:seq_body(Tree), Out, State1, CurrentFun);
+    'try' ->
+      Arg = cerl:try_arg(Tree),
+      Body = cerl:try_body(Tree),
+      Vars = cerl:try_vars(Tree),
+      EVars = cerl:try_evars(Tree),
+      Handler = cerl:try_handler(Tree),
+      {ArgFuns, State1} = traverse(Arg, Out, State, CurrentFun),
+      Out1 = bind_list(Vars, ArgFuns, Out),
+      {BodyFuns, State2} = traverse(Body, Out1, State1, CurrentFun),
+      Out2 = bind_single(EVars, output(set__singleton(external)), Out),
+      {HandlerFuns, State3} = traverse(Handler, Out2, State2, CurrentFun),
+      {merge_outs([BodyFuns, HandlerFuns]), State3};
+    tuple ->
+      Args = cerl:tuple_es(Tree),
+      {List, State1} = traverse_list(Args, Out, State, CurrentFun),
+      {merge_outs(List), State1};
+    values ->      
+      traverse_list(cerl:values_es(Tree), Out, State, CurrentFun);
+    var ->
+      case map__lookup(cerl_trees:get_label(Tree), Out) of
+	none -> {output(none), State};
+	{value, Val} -> 
+	  case is_only_external(Val) of
+	    true ->
+	      %% Do nothing
+	      {Val, State};
+	    false ->
+	      %% If this is used in a function this means a dependency.
+	      {Val, state__add_deps(CurrentFun, Val, State)}
+	  end
+      end
+  end.
+
+traverse_list(Trees, Out, State, CurrentFun) ->
+  traverse_list(Trees, Out, State, CurrentFun, []).
+
+traverse_list([Tree|Left], Out, State, CurrentFun, Acc) ->
+  {X, State1} = traverse(Tree, Out, State, CurrentFun),
+  traverse_list(Left, Out, State1, CurrentFun, [X|Acc]);
+traverse_list([], _Out, State, _CurrentFun, Acc) ->
+  {output(lists:reverse(Acc)), State}.
+
+traverse_defs([{_, Fun}|Left], Out, State, CurrentFun) ->
+  {_, State1} = traverse(Fun, Out, State, CurrentFun),
+  traverse_defs(Left, Out, State1, CurrentFun);
+traverse_defs([], _Out, State, _CurrentFun) ->
+  State.
+
+traverse_clauses(Clauses, ArgFuns, Out, State, CurrentFun) ->
+  case filter_match_fail(Clauses) of
+    [] ->
+      %% Can happen for example with receives used as timouts.
+      {output(none), State};
+    Clauses1 ->
+      traverse_clauses(Clauses1, ArgFuns, Out, State, CurrentFun, [])
+  end.
+
+traverse_clauses([Clause|Left], ArgFuns, Out, State, CurrentFun, Acc) ->
+  Pats = cerl:clause_pats(Clause),
+  Guard = cerl:clause_guard(Clause),
+  Body = cerl:clause_body(Clause),
+  Out1 = bind_pats_list(Pats, ArgFuns, Out),
+  {_, State2} = traverse(Guard, Out1, State, CurrentFun),
+  {BodyFuns, State3} = traverse(Body, Out1, State2, CurrentFun),
+  traverse_clauses(Left, ArgFuns, Out, State3, CurrentFun, [BodyFuns|Acc]);
+traverse_clauses([], _ArgFuns, _Out, State, _CurrentFun, Acc) ->
+  {merge_outs(Acc), State}.
+
+filter_match_fail([Clause]) ->
+  Body = cerl:clause_body(Clause),
+  case cerl:type(Body) of
+    primop ->
+      case cerl:atom_val(cerl:primop_name(Body)) of
+	match_fail -> [];
+	raise -> [];
+	_ -> [Clause]
+      end;
+    _ -> [Clause]
+  end;
+filter_match_fail([H|T]) ->
+  [H|filter_match_fail(T)];
+filter_match_fail([]) ->
+  %% This can actually happen, for example in 
+  %%      receive after 1 -> ok end
+  [].
+
+remote_call(Tree, ArgFuns, State) ->  
+  M = cerl:call_module(Tree),
+  F = cerl:call_name(Tree),
+  A = length(cerl:call_args(Tree)),
+  case cerl:is_c_atom(M) andalso cerl:is_c_atom(F) of
+    false ->
+      %% Unknown function. 
+      {output(set__singleton(external)), state__add_esc(ArgFuns, State)};
+    true ->
+      M1 = cerl:atom_val(M),
+      F1 = cerl:atom_val(F),
+      Literal = cerl_closurean:is_literal_op(M1, F1, A),
+      case erl_bifs:is_pure(M1, F1, A) of
+	true ->
+	  case Literal of
+	    true -> 
+	      {output(none), State};
+	    false -> 
+	      {output(set__singleton(external)), state__add_esc(ArgFuns, State)}
+	  end;
+	false ->	  
+	  State1 = case cerl_closurean:is_escape_op(M1, F1, A) of
+		     true -> state__add_esc(ArgFuns, State);
+		     false -> State
+		   end,
+	  case Literal of
+	    true -> {output(none), State1};
+	    false -> {add_external(ArgFuns), State1}
+	  end
+      end
+  end.
+
+primop(Tree, ArgFuns, State) ->
+  F = cerl:atom_val(cerl:primop_name(Tree)),
+  A = length(cerl:primop_args(Tree)),
+  State1 = case cerl_closurean:is_escape_op(F, A) of
+	     true -> state__add_esc(ArgFuns, State);
+	     false -> State
+	   end,
+  case cerl_closurean:is_literal_op(F, A) of
+    true -> {output(none), State1};
+    false -> {ArgFuns, State1}
+  end.
+
+%%------------------------------------------------------------
+%% Set
+%%
+
+-record(set, {set :: set()}).
+
+set__singleton(Val) ->
+  #set{set = sets:add_element(Val, sets:new())}.
+
+set__from_list(List) ->
+  #set{set = sets:from_list(List)}.
+
+set__is_element(_El, none) ->
+  false;
+set__is_element(El, #set{set = Set}) ->
+  sets:is_element(El, Set).
+
+set__union(none, Set) -> Set;
+set__union(Set, none) -> Set;
+set__union(#set{set = S1}, #set{set = S2}) -> #set{set = sets:union(S1, S2)}.
+
+set__to_ordsets(none) -> [];
+set__to_ordsets(#set{set = Set}) -> ordsets:from_list(sets:to_list(Set)).
+
+set__size(none) -> 0;
+set__size(#set{set = Set}) -> sets:size(Set).
+
+set__filter(#set{set = Set}, Fun) ->
+  NewSet = sets:filter(Fun, Set),
+  case sets:size(NewSet) =:= 0 of
+    true -> none;
+    false -> #set{set = NewSet}
+  end.
+
+%%------------------------------------------------------------
+%% Outputs
+%%
+
+-record(output, {type    :: 'single' | 'list', 
+		 content :: 'none' | #set{} | [{output,_,_}]}).
+
+output(none) -> #output{type = single, content = none};
+output(S = #set{}) -> #output{type = single, content = S};
+output(List) when is_list(List) -> #output{type = list, content = List}.
+
+merge_outs([H|T]) ->
+  merge_outs(T, H);
+merge_outs(#output{type = list, content = [H|T]}) ->
+  merge_outs(T, H);
+merge_outs(#output{type = list, content = []}) ->
+  output(none).
+
+merge_outs([#output{content = none}|Left], O) ->
+  merge_outs(Left, O);
+merge_outs([O|Left], #output{content = none}) ->
+  merge_outs(Left, O);
+merge_outs([#output{type = single, content = S1}|Left], 
+	   #output{type = single, content = S2}) ->
+  merge_outs(Left, output(set__union(S1, S2)));
+merge_outs([#output{type = list, content = L1}|Left],
+	   #output{type = list, content = L2}) ->
+  NewList = [merge_outs([X, Y]) || {X, Y} <- lists:zip(L1, L2)],
+  merge_outs(Left, output(NewList));
+merge_outs([], Res) ->
+  Res.
+
+filter_outs(#output{type = single, content = S}, Fun) -> 
+  output(set__filter(S, Fun)).
+
+add_external(#output{type = single, content = Set}) ->
+  output(set__union(Set, set__singleton(external)));
+add_external(#output{type = list, content = List}) ->
+  output([add_external(O) || O <- List]).
+
+is_only_external(#output{type = single, content = Set}) ->
+  set__is_element(external, Set) andalso (set__size(Set) =:= 1).
+
+%%------------------------------------------------------------
+%% Map
+%%
+
+map__new() ->
+  dict:new().
+
+map__add(_Label, none, Map) ->
+  Map;
+map__add(Label, Set, Map) ->
+  case map__lookup(Label, Map) of
+    {value, OldSet} ->
+      NewSet = set__union(OldSet, Set),
+      map__store(Label, NewSet, Map);
+    none ->
+      map__store(Label, Set, Map)
+  end.
+
+map__store(Label, Val, Map) ->  
+  dict:store(Label, Val, Map).
+
+map__lookup(Label, Map) ->
+  case dict:find(Label, Map) of
+    {ok, Val} -> {value, Val};
+    error -> none
+  end.
+
+map__finalize(Map) ->
+  dict:map(fun (_Key, #set{} = Set) -> set__to_ordsets(Set);
+	       (_Key, #output{type = single, content = Set}) ->
+	           set__to_ordsets(Set)
+	   end, Map).
+
+%%------------------------------------------------------------
+%% Binding outs in the map
+%%
+
+bind_pats_list(_Pats, #output{content = none}, Map) ->
+  Map;
+bind_pats_list([Pat], #output{type = single} = O, Map) ->
+  bind_single(all_vars(Pat), O, Map);
+bind_pats_list(Pats, #output{type = list, content = List}, Map) ->
+  bind_pats_list(Pats, List, Map);
+bind_pats_list([Pat|PatLeft],
+	       [#output{type = single} = O|SetLeft], Map)->
+  Map1 = bind_single(all_vars(Pat), O, Map),
+  bind_pats_list(PatLeft, SetLeft, Map1);
+bind_pats_list([Pat|PatLeft],
+	       [#output{type = list, content = List}|SetLeft], Map) ->
+  Map1 = case cerl:is_c_values(Pat) of
+	   true -> bind_pats_list(cerl:values_es(Pat), List, Map);
+	   false -> bind_single(all_vars(Pat), merge_outs(List), Map)
+	 end,
+  bind_pats_list(PatLeft, SetLeft, Map1);
+bind_pats_list([], [], Map) ->
+  Map.
+  
+bind_single([Var|Left], O, Map) ->
+  bind_single(Left, O, map__store(cerl_trees:get_label(Var), O, Map));
+bind_single([], _O, Map) ->
+  Map.
+
+bind_list(List, #output{type = single} = O, Map) ->
+  bind_single(List, O, Map);
+bind_list(List1, #output{type = list, content = List2}, Map) ->
+  bind_list1(List1, List2, Map).
+
+bind_list1([Var|VarLeft], [O|OLeft], Map) ->
+  bind_list1(VarLeft, OLeft, map__store(cerl_trees:get_label(Var), O, Map));
+bind_list1([], [], Map) ->
+  Map.
+
+bind_defs([{Var, Fun}|Left], Map) ->
+  O = output(set__singleton(cerl_trees:get_label(Fun))),
+  Map1 = map__store(cerl_trees:get_label(Var), O, Map),
+  bind_defs(Left, Map1);
+bind_defs([], Map) ->
+  Map.
+
+all_vars(Tree) ->
+  all_vars(Tree, []).
+
+all_vars(Tree, AccIn) ->
+  cerl_trees:fold(fun(SubTree, Acc) ->
+		      case cerl:is_c_var(SubTree) of
+			true -> [SubTree|Acc];
+			false -> Acc
+		      end
+		  end, AccIn, Tree).
+
+%%------------------------------------------------------------
+%% The state
+%%
+
+-type local_set() :: 'none' | #set{}.
+
+-record(state, {deps    :: dict(), 
+		esc     :: local_set(), 
+		call    :: dict(), 
+		arities :: dict()}).
+
+state__new(Tree) ->
+  Exports = set__from_list([X || X <- cerl:module_exports(Tree)]),
+  InitEsc = set__from_list([cerl_trees:get_label(Fun) 
+			    || {Var, Fun} <- cerl:module_defs(Tree),
+			       set__is_element(Var, Exports)]),
+  Arities = cerl_trees:fold(fun find_arities/2, dict:new(), Tree),
+  #state{deps = map__new(), esc = InitEsc, call = map__new(), arities = Arities}.
+
+find_arities(Tree, AccMap) ->
+  case cerl:is_c_fun(Tree) of
+    true ->
+      Label = cerl_trees:get_label(Tree),
+      Arity = cerl:fun_arity(Tree),
+      dict:store(Label, Arity, AccMap);
+    false ->
+      AccMap
+  end.
+
+state__add_deps(_From, #output{content = none}, State) ->
+  State;
+state__add_deps(From, #output{type = single, content=To}, 
+		#state{deps = Map} = State) ->
+  %% io:format("Adding deps from ~w to ~w\n", [From, set__to_ordsets(To)]),
+  State#state{deps = map__add(From, To, Map)}.
+
+state__deps(#state{deps = Deps}) ->
+  Deps.
+
+state__add_esc(#output{content = none}, State) ->
+  State;
+state__add_esc(#output{type = single, content = Set},
+	       #state{esc = Esc} = State) ->
+  State#state{esc = set__union(Set, Esc)}.
+
+state__esc(#state{esc = Esc}) ->
+  Esc.
+
+state__store_callsite(_From, #output{content = none}, _CallArity, State) ->
+  State;
+state__store_callsite(From, To, CallArity, 
+		      #state{call = Calls, arities = Arities} = State) ->
+  Filter = fun(external) -> true;
+	      (Fun) -> CallArity =:= dict:fetch(Fun, Arities) 
+	   end,
+  case filter_outs(To, Filter) of
+    #output{content = none} -> State;
+    To1 -> State#state{call = map__store(From, To1, Calls)}
+  end.
+
+state__calls(#state{call = Calls}) ->
+  Calls.
+
+%%------------------------------------------------------------
+%% A test function. Not part of the intended interface.
+%%
+
+-ifndef(NO_UNUSED).
+
+test(Mod) ->
+  {ok, _, Code} = compile:file(Mod, [to_core, binary]), 
+  Tree = cerl:from_records(Code),
+  {LabeledTree, _} = cerl_trees:label(Tree),
+  {Deps, Esc, Calls} = analyze(LabeledTree),
+  Edges0 = dict:fold(fun(Caller, Set, Acc) ->
+			 [[{Caller, Callee} || Callee <- Set]|Acc]
+		     end, [], Deps),
+  Edges1 = lists:flatten(Edges0),
+  Edges = [Edge || {X,_Y} = Edge <- Edges1, X =/= top],
+  Fun = fun(SubTree, Acc) ->
+	    case cerl:type(SubTree) of
+	      'fun' ->
+		case lists:keyfind(id, 1, cerl:get_ann(SubTree)) of
+		  false -> Acc;
+		  {id, ID} -> 
+		    dict:store(cerl_trees:get_label(SubTree), ID, Acc)
+		end;
+	      module ->
+		Defs = cerl:module_defs(SubTree),
+		lists:foldl(fun({Var, Fun}, Acc1) ->
+				dict:store(cerl_trees:get_label(Fun),
+					   {cerl:fname_id(Var), 
+					    cerl:fname_arity(Var)},
+					   Acc1)
+			    end, Acc, Defs);
+	      letrec ->
+		Defs = cerl:letrec_defs(SubTree),
+		lists:foldl(fun({Var, Fun}, Acc1) ->
+				dict:store(cerl_trees:get_label(Fun),
+					   {cerl:fname_id(Var), 
+					    cerl:fname_arity(Var)},
+					   Acc1)
+			    end, Acc, Defs);
+	      _ -> Acc
+	    end
+	end,
+  NameMap1 = cerl_trees:fold(Fun, dict:new(), LabeledTree),
+  NameMap = dict:store(external, external, NameMap1),
+  NamedEdges = [{dict:fetch(X, NameMap), dict:fetch(Y, NameMap)}
+		|| {X, Y} <- Edges],
+  NamedEsc = [dict:fetch(X, NameMap) || X <- Esc],
+  %% Color the edges
+  ColorEsc = [{X, {color, red}} || X <- NamedEsc],
+  CallEdges0 = dict:fold(fun(Caller, Set, Acc) ->
+			     [[{Caller, Callee} || Callee <- Set]|Acc]
+			 end, [], Calls),
+  CallEdges = lists:flatten(CallEdges0),
+  NamedCallEdges = [{X, dict:fetch(Y, NameMap)} || {X, Y} <- CallEdges],
+  AllNamedEdges = NamedEdges ++ NamedCallEdges,
+  hipe_dot:translate_list(AllNamedEdges, "/tmp/cg.dot", "CG", ColorEsc),
+  os:cmd("dot -T ps -o /tmp/cg.ps /tmp/cg.dot"),
+  ok.
+
+-endif.