xref_compiler.erl

OTP是开放电信平台的简称

	      {projection, ?Q({external, fun({M1,_M2}) -> M1 end}), MEs}}}},
	   MEs},
    special(edge, function, ToType, VEs);
special(edge, application, ToType, AEs) ->
    MEs = {inverse_image, {get, me2ae}, AEs},
    special(edge, module, ToType, MEs);
special(edge, release, ToType, REs) ->
    AEs = {inverse_image, {get, ae}, REs},
    special(edge, application, ToType, AEs);
special(vertex, function, {line, _LineType}, V) ->
    {restriction, 
       {union_of_family, {restriction, {get, def_at}, {domain, V}}},
       {union_of_family, V}};
special(vertex, module, ToType, M) ->
    V = {restriction, {get, v}, M},
    special(vertex, function, ToType, V);
special(vertex, application, ToType, A) ->
    M = {inverse_image, {get, m2a}, A},
    special(vertex, module, ToType, M);
special(vertex, release, ToType, R) ->
    A = {inverse_image, {get, a2r}, R},
    special(vertex, application, ToType, A).

line_edges(VEs, CallAt) ->
    {put, ?T(ves), VEs, 
        {put, ?T(m1), 
             {projection, ?Q({external, fun({{M1,_,_},_}) -> M1 end}), 
	      {get, ?T(ves)}},
	     {image, {projection, ?Q({external, fun(C={VV,_L}) -> {VV,C} end}),
		      {union, {image, {get, CallAt}, {get, ?T(m1)}}}},
		     {get, ?T(ves)}}}}.

%% {(((v1,l1),(v2,l2)),l) : 
%%       (v1,l1) in DefAt and (v2,l2) in DefAt and ((v1,v2),L) in CallAt}
funs_to_lines(DefAt, CallAt) ->
    T1 = multiple_relative_product({DefAt, DefAt}, projection(1, CallAt)),
    T2 = composite(substitution(1, T1), CallAt),
    Fun = fun({{{V1,V2},{L1,L2}},Ls}) -> {{{V1,L1},{V2,L2}},Ls} end,
    projection({external, Fun}, T2).

what_type('Rel')         -> release;
what_type('App')         -> application;
what_type('Mod')         -> module;
what_type('Fun')         -> function;
what_type('Lin')         -> {line, line};
what_type('LLin')        -> {line, local_call};
what_type('XLin')        -> {line, external_call};
what_type('ELin')        -> {line, export_call};
what_type('XXL')         -> {line, all_line_call}.

type_ord({line, all_line_call}) -> 0;
type_ord({line, _LT})           -> 1;
type_ord(function)              -> 2;
type_ord(module)                -> 3;
type_ord(application)           -> 4;
type_ord(release)               -> 5.

%% While evaluating, sets of vertices are represented as families.
%% Sets of edges are not families, but plain sets (this might change).
%% Calls (with line numbers) are "straightened" out here, but will be
%% families again shortly, unless just counted.
un_familiarize(function, vertex, E) ->
    {union_of_family, E};
un_familiarize({line, _}, edge, E) ->
    {family_to_relation, E};
un_familiarize(_Type, _OType, E) ->
    E.

%% Expressions are evaluated using a stack and tail recursion.
%% Common subexpressions are evaluated once only, using a table for
%% storing temporary results.
%% (Using a table _and_ a stack is perhaps not a very good way of
%% doing things.)
i(E, Table) ->
    Start = 1,
    {N, _NE, _NI, NT} = find_nodes(E, Start, dict:new()),
    {Vs, UVs0, L} = save_vars(dict:to_list(NT), NT, [], [], []),

    VarsToSave = to_external(relation_to_family(relation(Vs))),
    Fun = fun({NN,S}, D) ->
		  dict:store(NN, {extra,S,dict:fetch(NN, D)}, D)
	  end,
    D = foldl(Fun, dict:from_list(L), VarsToSave),

    UVs = reverse(sort(UVs0)),
    {_D, Is0} = make_instructions(N, UVs, D),
    Is = insert_unput(Is0),
    ?FORMAT("Instructions:~n~p~n~n~n", [Is]),
    %% Well, compiles _and_ evaluates...
    evaluate(Is, Table, []).

%% Traverses the expression tree in postorder, giving a unique number
%% to each node. A table is created, and common subexpressions found.
find_nodes(E={quote,_}, I, T) ->
    find_node(E, I, T);
find_nodes({get, Var}, I, T) ->
    find_node({var,Var}, I, T);
find_nodes({put, Var, E1, E2}, I, T) ->
    {_NE1_N, NE1, I1, T1} = find_nodes(E1, I, T),
    %% Now NE1 is considered used once, which is wrong. Fixed below.
    NT = dict:store({var, Var}, NE1, T1),
    find_nodes(E2, I1, NT);
find_nodes(Tuple, I, T) when is_tuple(Tuple) ->
    [Tag0 | L] = tuple_to_list(Tuple),
    Fun = fun(A, {L0, I0, T0}) ->
		  {NA, _E, NI, NT} = find_nodes(A, I0, T0),
		  {[NA | L0], NI, NT}
	  end,
    {NL, NI, T1} = foldl(Fun, {[], I, T}, L),
    Tag = case Tag0 of
	      _ when is_function(Tag0) -> Tag0;
	      _ when is_atom(Tag0) -> {sofs, Tag0}
	  end,
    find_node({apply, Tag, NL}, NI, T1).

find_node(E, I, T) ->
    case dict:find(E, T) of
        {ok, {reuse, N}} ->
	    {N, E, I, T};
	{ok, N} when is_integer(N) ->
	    {N, E, I, dict:store(E, {reuse, N}, T)};
	{ok, E1} ->
	    find_node(E1, I, T);
	error ->
 	    {I, E, I+1, dict:store(E, I, T)}
    end.

%% Creates save instructions for those values (stored on the stack while
%% evaluating) that are to be used after the result has been popped.
save_vars([{I, {reuse,N}} | DL], D, Vs, UVs, L) ->
    save_vars(DL, D, [{N, {save, {tmp, N}}} | Vs], UVs, [{N, I} | L]);
save_vars([{I, N} | DL], D, Vs, UVs, L) when is_integer(N) ->
    save_vars(DL, D, Vs, UVs, [{N, I} | L]);
save_vars([{{var,V={user,_}}, I} | DL], D, Vs, UVs, L) ->
    N = case dict:fetch(I, D) of
	    {reuse, N0} -> N0;
	    N0 -> N0
	end,
    save_vars(DL, D, [{N, {save, V}} | Vs], [N | UVs], L);
save_vars([{{var,{tmp,_}}, _I} | DL], D, Vs, UVs, L) ->
    save_vars(DL, D, Vs, UVs, L);
save_vars([], _D, Vs, UVs, L) ->
    {Vs, UVs, L}.

%% Traverses the expression again, this time using more or less the
%% inverse of the table created by find_nodes. The first time a node
%% is visited, its children are traversed, the following times a 
%% get instructions are inserted (using the saved value).
make_instructions(N, UserVars, D) ->
    {D1, Is0} = make_instrs(N, D, []),
    %% Assignments the results of which are not used by the final
    %% expression are handled here. Instructions are created for user
    %% variables only (assignment of a closure is handled properly
    %% without further action).
    make_more_instrs(UserVars, D1, Is0).

make_more_instrs([UV | UVs], D, Is) ->
    case dict:find(UV, D) of
	error -> 
	    make_more_instrs(UVs, D, Is);
	_Else -> 
	    {ND, NIs} = make_instrs(UV, D, Is),
	    make_more_instrs(UVs, ND, [pop | NIs])
    end;
make_more_instrs([], D, Is) ->
    {D, Is}.

make_instrs(N, D, Is) ->
    case dict:find(N, D) of
	{ok, {extra, Save, Val}} ->
	    {D1, Is1} = make_instr(Val, D, Is),
	    {dict:erase(N, D1), Save ++ Is1};
	{ok, Val} ->
	    {D1, Is1} = make_instr(Val, D, Is),
	    {dict:erase(N, D1), Is1};
	error ->
	    {D, [{get, {tmp, N}} | Is]}
    end.

make_instr({var, V}, D, Is) ->
    {D, [{get, V} | Is]};
make_instr(Q = {quote, _T}, D, Is) ->
    {D, [Q | Is]};
make_instr({apply, MF, Ns}, D, Is) ->
    Fun = fun(N, {D0, Is0}) -> make_instrs(N, D0, Is0) end,
    {D1, Is1} = foldl(Fun, {D, Is}, Ns),
    {D1, [{apply, MF, length(Ns)} | Is1]}.

%% Makes sure that temporary results are removed from the table as soon
%% as they are no longer needed.
%% Assignments may create extra save instructions, which are removed here.
insert_unput(L) ->
    insert_unput(L, dict:new(), []).

insert_unput([I={get, V={tmp, _}} | Is], D, L) ->
    case dict:find(V, D) of
        {ok, _} -> insert_unput(Is, D, [I | L]);
        error ->   insert_unput(Is, dict:store(V, [], D), [I,  {unput, V} | L])
    end;
insert_unput([I={save, V={tmp,_}} | Is], D, L) ->
    case dict:find(V, D) of
	{ok, _} ->
	    insert_unput(Is, dict:erase(V, D), [I | L]);
	error ->
	    %% Extra save removed.
	    insert_unput(Is, dict:erase(V, D), L)
    end;
insert_unput([I | Is], D, L) ->
    insert_unput(Is, D, [I | L]);
insert_unput([], _D, L) ->
    L.

graph_access(_G, V) ->
    %% _G may have been deleted by an unput already
    V.

evaluate([{apply, MF, NoAs} | P], T, S) ->
    Args = sublist(S, NoAs),
    NewS = nthtail(NoAs, S),
    ?FORMAT("Applying ~p/~p~n", [MF,NoAs]),
    evaluate(P, T, [apply(MF, Args) | NewS]);
evaluate([{quote, Val} | P], T, S) ->
    evaluate(P, T, [Val | S]);
evaluate([{get, Var} | P], T, S) when is_atom(Var) -> % predefined
    Value = fetch_value(Var, T),
    Val = case Value of 
	      {R, _} -> R; % relation
	      _ -> Value   % simple set
	  end,
    evaluate(P, T, [Val | S]);    
evaluate([{get, {inverse, Var}} | P], T, S) -> % predefined, inverse
    {_, R} = fetch_value(Var, T),
    evaluate(P, T, [R | S]);    
evaluate([{get, {user, Var}} | P], T, S) ->
    Val = fetch_value(Var, T),
    evaluate(P, T, [Val | S]);    
evaluate([{get, Var} | P], T, S) -> % tmp
    evaluate(P, T, [dict:fetch(Var, T) | S]);
evaluate([{save, Var={tmp, _}} | P], T, S=[Val | _]) ->
    T1 = update_graph_counter(Val, +1, T),
    evaluate(P, dict:store(Var, Val, T1), S);
evaluate([{save, {user, Name}} | P], T, S=[Val | _]) ->
    #xref_var{vtype = user, otype = OType, type = Type} = dict:fetch(Name, T),
    NewVar = #xref_var{name = Name, value = Val, 
		       vtype = user, otype = OType, type = Type},
    T1 = update_graph_counter(Val, +1, T),
    NT = dict:store(Name, NewVar, T1),
    evaluate(P, NT, S);
evaluate([{unput, Var} | P], T, S) ->
    T1 = update_graph_counter(dict:fetch(Var, T), -1, T),
    evaluate(P, dict:erase(Var, T1), S);
evaluate([pop | P], T, [_ | S]) ->
    evaluate(P, T, S);
evaluate([], T, [R]) ->
    {T, R}.

%% (PossibleGraph, 1 | -1, dict()) -> dict()
%% Use the same table for everything... Here: Reference counters for digraphs.
update_graph_counter(Value, Inc, T) ->
    case catch digraph:info(Value) of
	Info when is_list(Info) ->
	    case dict:find(Value, T) of
		{ok, 1} when Inc =:= -1 ->
		    true = digraph:delete(Value),
		    dict:erase(Value, T);
		{ok, C} ->
		    dict:store(Value, C+Inc, T);
		error when Inc =:= 1 ->
		    dict:store(Value, 1, T)
	    end;
	_EXIT -> 
	    T
    end.

fetch_value(V, D) ->
    #xref_var{value = Value} = dict:fetch(V, D),
    Value.

format_parse_error(["invalid_regexp", String, Error], Line) ->
    io_lib:format("Invalid regular expression \"~s\"~s: ~s~n",
		  [String, Line, lists:flatten(Error)]);
format_parse_error(["invalid_regexp_variable", Var], Line) ->
    io_lib:format("Invalid wildcard variable ~p~s "
		  "(only '_' is allowed)~n", [Var, Line]);
format_parse_error(["missing_type", Expr], Line) ->
    io_lib:format("Missing type of regular expression ~s~s~n",
		  [Expr, Line]);
format_parse_error(["type_mismatch", Expr], Line) ->
    io_lib:format("Type does not match structure of constant~s: ~s~n",
		  [Line, Expr]);
format_parse_error(["invalid_operator", Op], Line) ->
    io_lib:format("Invalid operator ~p~s~n", [Op, Line]);
format_parse_error(Error, Line) ->
    io_lib:format("Parse error~s: ~s~n", [Line, lists:flatten(Error)]).

format_line(at_end) ->
    " at end of string";
format_line(0) ->
    "";
format_line(Line) when is_integer(Line) ->
    concat([" on line ", Line]).

throw_error(Reason) ->
    throw(error(Reason)).

error(Reason) ->
    {error, ?MODULE, Reason}.