diff options
Diffstat (limited to 'lib/tools/src/xref_compiler.erl')
| -rw-r--r-- | lib/tools/src/xref_compiler.erl | 928 |
1 files changed, 928 insertions, 0 deletions
diff --git a/lib/tools/src/xref_compiler.erl b/lib/tools/src/xref_compiler.erl new file mode 100644 index 0000000000..67ac8c617d --- /dev/null +++ b/lib/tools/src/xref_compiler.erl @@ -0,0 +1,928 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2000-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% +%% + +-module(xref_compiler). + +-include("xref.hrl"). + +%-define(debug, true). + +-ifdef(debug). +-define(FORMAT(P, A), io:format(P, A)). +-define(CALL(F), F). +-else. +-define(FORMAT(P, A), ok). +-define(CALL(F), ok). +-endif. + +-export([compile/2]). + +-export([update_graph_counter/3]). + +-export([format_error/1]). + +-import(lists, + [concat/1, foldl/3, nthtail/2, reverse/1, sort/1, sublist/2]). + +-import(sofs, + [composite/2, difference/2, empty_set/0, from_term/1, + intersection/2, is_empty_set/1, multiple_relative_product/2, + projection/2, relation/1, relation_to_family/1, + restriction/2, substitution/2, to_external/1, union/2, + union_of_family/1]). + +%% +%% Exported functions +%% + +compile(Chars, Table) -> + case xref_scanner:scan(Chars) of + {ok, Tokens} -> + case xref_parser:parse(Tokens) of + {ok, ParseTree} -> + ?FORMAT("ParseTree ~p~n", [ParseTree]), + case catch statements(ParseTree, Table) of + E={error, _, _} -> + E; + {ok, UV, P} -> + %% User variables to be. + Table1 = user_vars(UV, Table), + ?CALL(statistics(runtime)), + Reply = i(P, Table1), + ?CALL({_, Time} = statistics(runtime)), + ?FORMAT("Result in ~p ms~n",[Time]), + Reply + end; + {error, {Line, _Module, Error}} -> + error({parse_error, Line, Error}) + end; + {error, Info, Line} -> + error({parse_error, Line, Info}) + end. + +format_error({error, Module, Error}) -> + Module:format_error(Error); +format_error({parse_error, Line, Error}) -> + format_parse_error(Error, format_line(Line)); +format_error({variable_reassigned, Expr}) -> + io_lib:format("Variable assigned more than once: ~s~n", [Expr]); +format_error({unknown_variable, Name}) -> + io_lib:format("Variable ~p used before set~n", [Name]); +format_error({type_error, Expr}) -> + io_lib:format("Operator applied to argument(s) of different or " + "invalid type(s): ~s~n", [Expr]); +format_error({type_mismatch, Expr1, Expr2}) -> + io_lib:format("Constants of different types: ~s, ~s~n", + [Expr1, Expr2]); +format_error({unknown_constant, Constant}) -> + io_lib:format("Unknown constant ~s~n", [Constant]); +format_error(E) -> + io_lib:format("~p~n", [E]). + +%% +%% Local functions +%% + +user_vars([{{user,Name}, Val} | UV], Table) -> + user_vars(UV, dict:store(Name, Val, Table)); +user_vars([_V | UV], Table) -> + user_vars(UV, Table); +user_vars([], Table) -> + Table. + +statements(Stmts, Table) -> + statements(Stmts, Table, [], []). + +statements([Stmt={assign, VarType, Name, E} | Stmts0], Table, L, UV) -> + case dict:find(Name, Table) of + {ok, _} -> + throw_error({variable_reassigned, xref_parser:t2s(Stmt)}); + error -> + {Type, OType, NewE} = t_expr(E, Table), + Val = #xref_var{name = Name, vtype = VarType, + otype = OType, type = Type}, + NewTable = dict:store(Name, Val, Table), + Stmts = if Stmts0 =:= [] -> [{variable, Name}]; true -> Stmts0 end, + Variable = {VarType, Name}, + Put = {put, Variable, NewE}, + statements(Stmts, NewTable, [Put | L], [{Variable,Val} | UV]) + end; +statements([Expr], Table, L, UV) -> + {Type, OType, NewE} = t_expr(Expr, Table), + E1 = un_familiarize(Type, OType, NewE), + NE = case {Type, OType} of + %% Edges with empty sets of line numbers are removed. + {{line, _}, edge} -> + {relation_to_family, E1}; + {_Type, edge_closure} -> + %% Fake a closure usage, just to make sure it is destroyed. + E2 = {fun graph_access/2, E1, E1}, + {fun(_E) -> 'closure()' end, E2}; + _Else -> E1 + end, + {ok, UV, stats(L, NE)}. + +stats([{put, V, X} | Ss], E) -> + stats(Ss, {put, V, X, E}); +stats([], E) -> + E. + +t_expr(E, Table) -> + {expr, Type, OType, E1} = check_expr(E, Table), + ?FORMAT("TExpr:~n~p~n",[E1]), + E2 = convert(E1), + ?FORMAT("After conversion:~n~p~n",[E2]), + {Type, OType, E2}. + +%%% check_expr/2 translates Expr in xref_parser.yrl into TExpr: +%%% +%%% TExpr = {expr, Type, ObjectType, Expr} +%%% Expr = {constants, [Constant]} +%%% | {variable, {VarType, VarName}} +%%% | {call, Call, Expr} +%%% | {call, Call, Expr, Expr} +%%% | {call, restriction, integer(), Expr, Expr} +%%% | {convert, ObjectType, Type, Type} +%%% | {convert, Type, Type} +%%% Constant = atom() | {atom(), atom()} | MFA | {MFA, MFA} +%%% Call = atom() % function in the sofs module +%%% | fun() +%%% Type = {line, LineType} | function | module | application | release +%%% | number +%%% LineType = line | local_call | external_call | export_call | all_line_call +%%% VarType = predef | user | tmp +%%% ObjectType = vertex | vertex_set | edge | edge_set | edge_closure | path +%%% | number +%%% MFA = {atom(), atom(), integer()} + +%% -> TExpr +check_expr({list, L}, Table) -> + check_constants(L, Table); +check_expr({tuple, L}, Table) -> + {expr, Type, vertex, _Consts} = check_constants(L, Table), + Cs = reverse(constant_vertices(L, [])), + {expr, Type, path, {constants, Cs}}; +check_expr({variable, Name}, Table) -> + case dict:find(Name, Table) of + {ok, #xref_var{vtype = VarType, otype = OType, type = Type}} -> + V0 = {variable, {VarType, Name}}, + V = case {VarType, Type, OType} of + {predef, release, _} -> V0; + {predef, application, _} -> V0; + {predef, module, _} -> V0; + {predef, function, vertex} -> V0; + {predef, function, edge} -> {call, union_of_family, V0}; + _Else -> V0 + end, + {expr, Type, OType, V}; + error -> + throw_error({unknown_variable, Name}) + end; +check_expr({type, {type, _Type}, E}, Table) -> + check_expr(E, Table); +check_expr(Expr={type, {convert, NewType0}, E}, Table) -> + NewType = what_type(NewType0), + {expr, OldType, OType, NE} = check_expr(E, Table), + ok = check_conversion(OType, OldType, NewType, Expr), + {expr, NewType, OType, {convert, OType, OldType, NewType, NE}}; +check_expr(Expr={set, SOp, E}, Table) -> + {expr, Type, OType0, E1} = check_expr(E, Table), + OType = case {OType0, SOp} of + {edge, range} -> vertex; + {edge, domain} -> vertex; + {edge, weak} -> edge; + {edge, strict} -> edge; + {edge_set, range} -> vertex_set; + {edge_set, domain} -> vertex_set; + {edge_set, weak} -> edge_set; + {edge_set, strict} -> edge_set; + _ -> + throw_error({type_error, xref_parser:t2s(Expr)}) + end, + Op = set_op(SOp), + NE = function_vertices_to_family(Type, OType, {call, Op, E1}), + {expr, Type, OType, NE}; +check_expr(Expr={graph, Op, E}, Table) -> + {expr, Type, NOType, E1} = check_expr(E, Table), + case Type of + {line, _LineType} -> + throw_error({type_error, xref_parser:t2s(Expr)}); + _Else -> + ok + end, + OType = + case {NOType, Op} of + {edge, components} -> vertex_set; + {edge, condensation} -> edge_set; + {edge, closure} -> edge_closure; + {edge_closure, components} -> vertex_set; + {edge_closure, condensation} -> edge_set; + {edge_closure, closure} -> edge_closure; + %% Neither need nor want these ones: + %% {edge_set, closure} -> edge_set_closure; + %% {edge_set, components} -> vertex_set_set; + _ -> + throw_error({type_error, xref_parser:t2s(Expr)}) + end, + E2 = {convert, NOType, edge_closure, E1}, + NE = case Op of + closure -> E2; + _Op -> use_of_closure(Op, E2) + end, + {expr, Type, OType, NE}; +check_expr(Expr={numeric, '#', E}, Table) -> + {expr, Type, OType, E1} = check_expr(E, Table), + case OType of + vertex -> ok; + vertex_set -> ok; + edge -> ok; + edge_set -> ok; + _Else -> throw_error({type_error, xref_parser:t2s(Expr)}) + end, + NE = {convert, OType, Type, number, E1}, + {expr, number, number, {call, no_elements, NE}}; +check_expr(Expr={set, SOp, E1, E2}, Table) -> + %% sets and numbers... + {expr, Type1, OType1, NE1} = check_expr(E1, Table), + {expr, Type2, OType2, NE2} = check_expr(E2, Table), + OType = case {OType1, OType2} of + {vertex, vertex} -> vertex; + {edge, edge} -> edge; + {number, number} -> number; + _ -> throw_error({type_error, xref_parser:t2s(Expr)}) + end, + case OType of + number -> + {expr, number, number, {call, ari_op(SOp), NE1, NE2}}; + _Else -> % set + {Type, NewE1, NewE2} = + case {type_ord(Type1), type_ord(Type2)} of + {T1, T2} when T1 =:= T2 -> + %% Example: if Type1 = {line, line} and + %% Type2 = {line, export_line}, then this is not + %% correct, but works: + {Type1, NE1, NE2}; + {T1, T2} when T1 < 2; T2 < 2 -> + throw_error({type_error, xref_parser:t2s(Expr)}); + {T1, T2} when T1 > T2 -> + {Type2, {convert, OType, Type1, Type2, NE1}, NE2}; + {T1, T2} when T1 < T2 -> + {Type1, NE1, {convert, OType, Type2, Type1, NE2}} + end, + Op = set_op(SOp, Type, OType), + {expr, Type, OType, {call, Op, NewE1, NewE2}} + end; +check_expr(Expr={restr, ROp, E1, E2}, Table) -> + {expr, Type1, OType1, NE1} = check_expr(E1, Table), + {expr, Type2, OType2, NE2} = check_expr(E2, Table), + case {Type1, Type2} of + {{line, _LineType1}, _Type2} -> + throw_error({type_error, xref_parser:t2s(Expr)}); + {_Type1, {line, _LineType2}} -> + throw_error({type_error, xref_parser:t2s(Expr)}); + _ -> + ok + end, + case {OType1, OType2} of + {edge, vertex} when ROp =:= '|||' -> + {expr, _, _, R1} = restriction('|', E1, Type1, NE1, Type2, NE2), + {expr, _, _, R2} = restriction('||', E1, Type1, NE1, Type2, NE2), + {expr, Type1, edge, {call, intersection, R1, R2}}; + {edge, vertex} -> + restriction(ROp, E1, Type1, NE1, Type2, NE2); + {edge_closure, vertex} when ROp =:= '|||' -> + {expr, _, _, R1} = + closure_restriction('|', Type1, Type2, OType2, NE1, NE2), + {expr, _, _, R2} = + closure_restriction('||', Type1, Type2, OType2, NE1, NE2), + {expr, Type1, edge, {call, intersection, R1, R2}}; + {edge_closure, vertex} -> + closure_restriction(ROp, Type1, Type2, OType2, NE1, NE2); + _ -> + throw_error({type_error, xref_parser:t2s(Expr)}) + end; +check_expr(Expr={path, E1, E2}, Table) -> + {expr, Type1, OType1a, E1a} = check_expr(E1, Table), + {expr, Type2, OType2, E2a} = check_expr(E2, Table), + case {Type1, Type2} of + {{line, _LineType1}, _Type2} -> + throw_error({type_error, xref_parser:t2s(Expr)}); + {_Type1, {line, _LineType2}} -> + throw_error({type_error, xref_parser:t2s(Expr)}); + _Else -> + ok + end, + E2b = {convert, OType2, Type2, Type1, E2a}, + {OType1, NE1} = path_arg(OType1a, E1a), + NE2 = case {OType1, OType2} of + {path, edge} -> {convert, OType2, edge_closure, E2b}; + {path, edge_closure} when Type1 =:= Type2 -> E2b; + _ -> throw_error({type_error, xref_parser:t2s(Expr)}) + end, + {expr, Type1, path, use_of_closure(path, NE2, NE1)}; +check_expr({regexpr, RExpr, Type0}, _Table) -> + %% Using the "universal" variables is not optimal as regards speed, + %% but it is simple... + Type = what_type(Type0), + V = case Type of + function -> v; + module -> 'M'; + application -> 'A'; + release -> 'R' + end, + Var = {variable, {predef, V}}, + Call = {call, fun(E, V2) -> xref_utils:regexpr(E, V2) end, + {constants, RExpr}, Var}, + {expr, Type, vertex, Call}; +check_expr(C={constant, _Type, _OType, _C}, Table) -> + check_constants([C], Table). + +path_arg(edge, E={constants, C}) -> + case to_external(C) of + [{V1,V2}] -> {path, {constants, [V1, V2]}}; + _ -> {edge, E} + end; +path_arg(OType, E) -> + {OType, E}. + +check_conversion(OType, Type1, Type2, Expr) -> + case conversions(OType, Type1, Type2) of + ok -> ok; + not_ok -> throw_error({type_error, xref_parser:t2s(Expr)}) + end. + +%% Allowed conversions. +conversions(_OType, {line, LineType}, {line, LineType}) -> ok; +conversions(edge, {line, _}, {line, all_line_call}) -> ok; +conversions(edge, From, {line, Line}) + when is_atom(From), Line =/= all_line_call -> ok; +conversions(vertex, From, {line, line}) when is_atom(From) -> ok; +conversions(vertex, From, To) when is_atom(From), is_atom(To) -> ok; +conversions(edge, From, To) when is_atom(From), is_atom(To) -> ok; +%% "Extra": +conversions(edge, {line, Line}, To) + when is_atom(To), Line =/= all_line_call -> ok; +conversions(vertex, {line, line}, To) when is_atom(To) -> ok; +conversions(_OType, _From, _To) -> not_ok. + +set_op(union, {line, _LineType}, edge) -> family_union; +set_op(intersection, {line, _LineType}, edge) -> family_intersection; +set_op(difference, {line, _LineType}, edge) -> family_difference; +set_op(union, function, vertex) -> family_union; +set_op(intersection, function, vertex) -> family_intersection; +set_op(difference, function, vertex) -> family_difference; +set_op(SOp, _Type, _OType) -> SOp. + +set_op(weak) -> weak_relation; +set_op(strict) -> strict_relation; +set_op(Op) -> Op. + +ari_op(union) -> fun(X, Y) -> X + Y end; +ari_op(intersection) -> fun(X, Y) -> X * Y end; +ari_op(difference) -> fun(X, Y) -> X - Y end. + +restriction(ROp, E1, Type1, NE1, Type2, NE2) -> + {Column, _} = restr_op(ROp), + case NE1 of + {call, union_of_family, _E} when ROp =:= '|' -> + restriction(Column, Type1, E1, Type2, NE2); + {call, union_of_family, _E} when ROp =:= '||' -> + E1p = {inverse, E1}, + restriction(Column, Type1, E1p, Type2, NE2); + _ -> + NE2a = {convert, vertex, Type2, Type1, NE2}, + NE2b = family_to_function_vertices(Type1, vertex, NE2a), + {expr, Type1, edge, {call, restriction, Column, NE1, NE2b}} + end. + +restriction(Column, Type1, VE, Type2, E2) when Type1 =:= function -> + M = {convert, vertex, Type2, module, E2}, + Restr = {call, union_of_family, {call, restriction, VE, M}}, + C = {convert, vertex, Type2, Type1, E2}, + F = family_to_function_vertices(Type1, vertex, C), + {expr, Type1, edge, {call, restriction, Column, Restr, F}}. + +closure_restriction(Op, Type1, Type2, OType2, E1, E2) -> + {_, Fun} = restr_op(Op), + E2a = {convert, OType2, Type2, Type1, E2}, + E2b = family_to_function_vertices(Type1, vertex, E2a), + {expr, Type1, edge, use_of_closure(Fun, E1, E2b)}. + +restr_op('|') -> {1, call}; +restr_op('||') -> {2, use}. + +%% Closures (digraphs) must be deleted, but not too soon. A wrapper +%% is inserted here for every use of a closure, to make sure that a +%% 'save' and an 'unput' instruction are inserted for every digraph, in +%% particular the temporary ones. The 'unput' instruction must occur +%% _after_ the call to the function that uses the digraph (the default +%% is that it is inserted _before_ the call). +use_of_closure(Op, C) -> + access_of_closure(C, {call, fun(X) -> xref_utils:Op(X) end, C}). + +use_of_closure(Op, C, E) -> + access_of_closure(C, {call, fun(X, Y) -> xref_utils:Op(X, Y) end, C, E}). + +access_of_closure(C, E) -> + {call, fun graph_access/2, C, E}. + +check_constants(Cs=[C={constant, Type0, OType, _Con} | Cs1], Table) -> + check_mix(Cs1, Type0, OType, C), + Types = case Type0 of + unknown -> ['Rel', 'App', 'Mod']; + T -> [T] + end, + case split(Types, Cs, Table) of + [{TypeToBe, _Cs}] -> + S = from_term([Con || {constant, _T, _OT, Con} <- Cs]), + Type = what_type(TypeToBe), + E = function_vertices_to_family(Type, OType, {constants, S}), + {expr, Type, OType, E}; + [{Type1, [C1|_]}, {Type2, [C2|_]} | _] -> + throw_error({type_mismatch, + make_vertex(Type1, C1), + make_vertex(Type2, C2)}) + end. + +check_mix([C={constant, 'Fun', OType, _Con} | Cs], 'Fun', OType, _C0) -> + check_mix(Cs, 'Fun', OType, C); +check_mix([C={constant, Type, OType, _Con} | Cs], Type0, OType, _C0) + when Type =/= 'Fun', Type0 =/= 'Fun' -> + check_mix(Cs, Type, OType, C); +check_mix([C | _], _Type0, _OType0, C0) -> + throw_error({type_mismatch, xref_parser:t2s(C0), xref_parser:t2s(C)}); +check_mix([], _Type0, _OType0, _C0) -> + ok. + +split(Types, Cs, Table) -> + Vs = from_term(constant_vertices(Cs, [])), + split(Types, Vs, empty_set(), unknown, Table, []). + +split([Type | Types], Vs, AllSoFar, _Type, Table, L) -> + S0 = known_vertices(Type, Vs, Table), + S = difference(S0, AllSoFar), + case is_empty_set(S) of + true -> + split(Types, Vs, AllSoFar, Type, Table, L); + false -> + All = union(AllSoFar, S0), + split(Types, Vs, All, Type, Table, + [{Type, to_external(S)} | L]) + end; +split([], Vs, All, Type, _Table, L) -> + case to_external(difference(Vs, All)) of + [] -> L; + [C|_] -> throw_error({unknown_constant, make_vertex(Type, C)}) + end. + +make_vertex(Type, C) -> + xref_parser:t2s({constant, Type, vertex, C}). + +constant_vertices([{constant, _Type, edge, {A,B}} | Cs], L) -> + constant_vertices(Cs, [A, B | L]); +constant_vertices([{constant, _Type, vertex, V} | Cs], L) -> + constant_vertices(Cs, [V | L]); +constant_vertices([], L) -> + L. + +known_vertices('Fun', Cs, T) -> + M = projection(1, Cs), + F = union_of_family(restriction(fetch_value(v, T), M)), + intersection(Cs, F); +known_vertices('Mod', Cs, T) -> + intersection(Cs, fetch_value('M', T)); +known_vertices('App', Cs, T) -> + intersection(Cs, fetch_value('A', T)); +known_vertices('Rel', Cs, T) -> + intersection(Cs, fetch_value('R', T)). + +function_vertices_to_family(function, vertex, E) -> + {call, partition_family, 1, E}; +function_vertices_to_family(_Type, _OType, E) -> + E. + +family_to_function_vertices(function, vertex, E) -> + {call, union_of_family, E}; +family_to_function_vertices(_Type, _OType, E) -> + E. + +-define(Q(E), {quote, E}). + +convert({inverse, {variable, Variable}}) -> + {get, {inverse, var_name(Variable)}}; +convert({variable, Variable}) -> + {get, var_name(Variable)}; +convert({convert, FromOType, ToOType, E}) -> + convert(convert(E), FromOType, ToOType); +convert({convert, OType, FromType, ToType, E}) -> + convert(convert(E), OType, FromType, ToType); +convert({call, Op, E}) -> + {Op, convert(E)}; +convert({call, Op, E1, E2}) -> + {Op, convert(E1), convert(E2)}; +convert({call, Op, E1, E2, E3}) -> + {Op, convert(E1), convert(E2), convert(E3)}; +convert({constants, Constants}) -> + ?Q(Constants); +convert(I) when is_integer(I) -> + ?Q(I). + +var_name({predef, VarName}) -> VarName; +var_name(Variable) -> Variable. + +convert(E, OType, OType) -> + E; +convert(E, edge, edge_closure) -> + {fun(S) -> xref_utils:closure(S) end, E}. + +convert(E, OType, FromType, number) -> + un_familiarize(FromType, OType, E); +convert(E, OType, FromType, ToType) -> + case {type_ord(FromType), type_ord(ToType)} of + {FT, To} when FT =:= To -> + E; + {FT, ToT} when FT > ToT -> + special(OType, FromType, ToType, E); + {FT, ToT} when FT < ToT -> + general(OType, FromType, ToType, E) + end. + +-define(T(V), {tmp, V}). + +general(_ObjectType, FromType, ToType, X) when FromType =:= ToType -> + X; +general(edge, {line, _LineType}, ToType, LEs) -> + VEs = {projection, ?Q({external, fun({V1V2,_Ls}) -> V1V2 end}), LEs}, + general(edge, function, ToType, VEs); +general(edge, function, ToType, VEs) -> + MEs = {projection, + ?Q({external, fun({{M1,_,_},{M2,_,_}}) -> {M1,M2} end}), + VEs}, + general(edge, module, ToType, MEs); +general(edge, module, ToType, MEs) -> + AEs = {image, {get, me2ae}, MEs}, + general(edge, application, ToType, AEs); +general(edge, application, release, AEs) -> + {image, {get, ae}, AEs}; +general(vertex, {line, _LineType}, ToType, L) -> + V = {partition_family, ?Q(1), {domain, L}}, + general(vertex, function, ToType, V); +general(vertex, function, ToType, V) -> + M = {domain, V}, + general(vertex, module, ToType, M); +general(vertex, module, ToType, M) -> + A = {image, {get, m2a}, M}, + general(vertex, application, ToType, A); +general(vertex, application, release, A) -> + {image, {get, a2r}, A}. + +special(_ObjectType, FromType, ToType, X) when FromType =:= ToType -> + X; +special(edge, {line, _LineType}, {line, all_line_call}, Calls) -> + {put, ?T(mods), + {projection, + ?Q({external, fun({{{M1,_,_},{M2,_,_}},_}) -> {M1,M2} end}), + Calls}, + {put, ?T(def_at), + {union, {image, {get, def_at}, + {union, {domain, {get, ?T(mods)}}, + {range, {get, ?T(mods)}}}}}, + {fun funs_to_lines/2, + {get, ?T(def_at)}, Calls}}}; +special(edge, function, {line, LineType}, VEs) -> + Var = if + LineType =:= line -> call_at; + LineType =:= export_call -> e_call_at; + LineType =:= local_call -> l_call_at; + LineType =:= external_call -> x_call_at + end, + line_edges(VEs, Var); +special(edge, module, ToType, MEs) -> + VEs = {image, + {projection, + ?Q({external, fun(FE={{M1,_,_},{M2,_,_}}) -> {{M1,M2},FE} end}), + {union, + {image, {get, e}, + {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(-1) -> + " 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}. |