diff options
Diffstat (limited to 'lib/tools/src/fprof.erl')
| -rw-r--r-- | lib/tools/src/fprof.erl | 2762 |
1 files changed, 2762 insertions, 0 deletions
diff --git a/lib/tools/src/fprof.erl b/lib/tools/src/fprof.erl new file mode 100644 index 0000000000..155965a65a --- /dev/null +++ b/lib/tools/src/fprof.erl @@ -0,0 +1,2762 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2001-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 : fprof.erl +%%% Author : Raimo Niskanen <[email protected]> +%%% Purpose : File tracing profiling tool wich accumulated times. +%%% Created : 18 Jun 2001 by Raimo Niskanen <[email protected]> +%%%---------------------------------------------------------------------- + +-module(fprof). +-author('[email protected]'). + +%% External exports +-export([ + apply/2, apply/3, apply/4, + start/0, stop/0, stop/1, + trace/1, trace/2, + profile/0, profile/1, profile/2, + analyse/0, analyse/1, analyse/2]). +%% Debug functions +-export([get_state/0, + save_profile/0, save_profile/1, save_profile/2, + load_profile/0, load_profile/1, load_profile/2, + code_change/0]). + +%% Debug exports +-export([call/1, just_call/1, reply/2]). +-export([trace_off/0, trace_on/3]). +-export([getopts/2, setopts/1]). +-export([println/5, print_callers/2, print_func/2, print_called/2]). +-export([trace_call_collapse/1]). +-export([parsify/1]). + +%% Internal exports +-export(['$code_change'/1]). + + + +-define(FNAME_WIDTH, 72). +-define(NR_WIDTH, 15). + +-define(TRACE_FILE, "fprof.trace"). +-define(DUMP_FILE, "fprof.dump"). +-define(PROFILE_FILE, "fprof.profile"). +-define(ANALYSIS_FILE, "fprof.analysis"). + +-define(FPROF_SERVER, fprof_server). +-define(FPROF_SERVER_TIMEOUT, infinity). + + + +-define(debug, 9). +%-define(debug, 0). +-ifdef(debug). +dbg(Level, F, A) when Level >= ?debug -> + io:format(F, A), + ok; +dbg(_, _, _) -> + ok. +-define(dbg(Level, F, A), dbg((Level), (F), (A))). +-else. +-define(dbg(Level, F, A), ok). +-endif. + + + +%%%---------------------------------------------------------------------- +%%% Higher order API functions +%%%---------------------------------------------------------------------- + + + +apply({M, F} = Function, Args) + when is_atom(M), is_atom(F), is_list(Args) -> + apply_1(Function, Args, []); +apply(Fun, Args) + when is_function(Fun), is_list(Args) -> + apply_1(Fun, Args, []); +apply(A, B) -> + erlang:error(badarg, [A, B]). + +apply(M, F, Args) when is_atom(M), is_atom(F), is_list(Args) -> + apply_1({M, F}, Args, []); +apply({M, F} = Function, Args, Options) + when is_atom(M), is_atom(F), is_list(Args), is_list(Options) -> + apply_1(Function, Args, Options); +apply(Fun, Args, Options) + when is_function(Fun), is_list(Args), is_list(Options) -> + apply_1(Fun, Args, Options); +apply(A, B, C) -> + erlang:error(badarg, [A, B, C]). + +apply(Module, Function, Args, Options) + when is_atom(Module), is_atom(Function), is_list(Args), is_list(Options) -> + apply_1({Module, Function}, Args, Options); +apply(A, B, C, D) -> + erlang:error(badarg, [A, B, C, D]). + + +apply_1(Function, Args, Options) -> + {[_, Procs, Continue], Options_1} = + getopts(Options, [start, procs, continue]), + Procs_1 = case Procs of + [{procs, P}] when is_list(P) -> + P; + _ -> + [] + end, + case Continue of + [] -> + apply_start_stop(Function, Args, Procs_1, Options_1); + [continue] -> + apply_continue(Function, Args, Procs_1, Options_1); + _ -> + erlang:error(badarg, [Function, Args, Options]) + end. + + + +apply_start_stop(Function, Args, Procs, Options) -> + Ref = make_ref(), + Parent = self(), + Child = + spawn( + fun() -> + MRef = erlang:monitor(process, Parent), + receive + {Parent, Ref, start_trace} -> + case trace([start, + {procs, [Parent | Procs]} + | Options]) of + ok -> + catch Parent ! {self(), Ref, trace_started}, + receive + {Parent, Ref, stop_trace} -> + trace([stop]), + catch Parent + ! {self(), Ref, trace_stopped}, + done; + {'DOWN', MRef, _, _, _} -> + trace([stop]) + end; + {error, Reason} -> + exit(Reason) + end; + {'DOWN', MRef, _, _, _} -> + done + end + end), + MRef = erlang:monitor(process, Child), + catch Child ! {self(), Ref, start_trace}, + receive + {Child, Ref, trace_started} -> + try erlang:apply(Function, Args) + after + catch Child ! {self(), Ref, stop_trace}, + receive + {Child, Ref, trace_stopped} -> + receive + {'DOWN', MRef, _, _, _} -> + ok + end; + {'DOWN', MRef, _, _, _} -> + trace([stop]) + end + end; + {'DOWN', MRef, _, _, Reason} -> + exit(Reason) + end. + +apply_continue(Function, Args, Procs, Options) -> + Ref = make_ref(), + Parent = self(), + Child = + spawn( + fun() -> + MRef = erlang:monitor(process, Parent), + receive + {Parent, Ref, start_trace} -> + case trace([start, + {procs, [Parent | Procs]} + | Options]) of + ok -> + exit({Ref, trace_started}); + {error, Reason} -> + exit(Reason) + end; + {'DOWN', MRef, _, _, _} -> + done + end + end), + MRef = erlang:monitor(process, Child), + catch Child ! {self(), Ref, start_trace}, + receive + {'DOWN', MRef, _, _, {Ref, trace_started}} -> + erlang:apply(Function, Args); + {'DOWN', MRef, _, _, Reason} -> + exit(Reason) + end. + + + +%%%---------------------------------------------------------------------- +%%% Requests to ?FPROF_SERVER +%%%---------------------------------------------------------------------- + +-record(trace_start, {procs, % List of processes + mode, % normal | verbose + type, % file | tracer + dest}). % Filename | Pid/Port + +-record(trace_stop, {}). + +% -record(open_out, {file}). + +% -record(close_out, {}). + +-record(profile, {src, % Filename + group_leader, % IoPid + dump, % Filename | IoPid + flags}). % List + +-record(profile_start, {group_leader, % IoPid + dump, % Filename | IoPid + flags}). % List + +-record(profile_stop, {}). + +-record(analyse, {group_leader, % IoPid + dest, % Filename | IoPid + flags, % List + cols, % Integer + callers, % Boolean + sort, % acc_r | own_r + totals, % Boolean + details}). % Boolean + +-record(stop, { + reason}). + + + +%%--------------- +%% Debug requests +%%--------------- + +-record(get_state, {}). + +-record(save_profile, {file}). + +-record(load_profile, {file}). + + + +%%%---------------------------------------------------------------------- +%%% Basic API functions +%%%---------------------------------------------------------------------- + + + +trace(start, Filename) -> + trace([start, {file, Filename}]); +trace(verbose, Filename) -> + trace([start, verbose, {file, Filename}]); +trace(Option, Value) when is_atom(Option) -> + trace([{Option, Value}]); +trace(Option, Value) -> + erlang:error(badarg, [Option, Value]). + +trace(stop) -> + %% This shortcut is present to minimize the number of undesired + %% function calls at the end of the trace. + call(#trace_stop{}); +trace(verbose) -> + trace([start, verbose]); +trace([stop]) -> + %% This shortcut is present to minimize the number of undesired + %% function calls at the end of the trace. + call(#trace_stop{}); +trace({Opt, _Val} = Option) when is_atom(Opt) -> + trace([Option]); +trace(Option) when is_atom(Option) -> + trace([Option]); +trace(Options) when is_list(Options) -> + case getopts(Options, + [start, stop, procs, verbose, file, tracer, cpu_time]) of + {[[], [stop], [], [], [], [], []], []} -> + call(#trace_stop{}); + {[[start], [], Procs, Verbose, File, Tracer, CpuTime], []} -> + {Type, Dest} = case {File, Tracer} of + {[], [{tracer, Pid} = T]} + when is_pid(Pid); is_port(Pid) -> + T; + {[file], []} -> + {file, ?TRACE_FILE}; + {[{file, []}], []} -> + {file, ?TRACE_FILE}; + {[{file, _} = F], []} -> + F; + {[], []} -> + {file, ?TRACE_FILE}; + _ -> + erlang:error(badarg, [Options]) + end, + V = case Verbose of + [] -> normal; + [verbose] -> verbose; + [{verbose, true}] -> verbose; + [{verbose, false}] -> normal; + _ -> erlang:error(badarg, [Options]) + end, + CT = case CpuTime of + [] -> wallclock; + [cpu_time] -> cpu_time; + [{cpu_time, true}] -> cpu_time; + [{cpu_time, false}] -> wallclock; + _ -> erlang:error(badarg, [Options]) + end, + call(#trace_start{procs = case Procs of + [] -> + [self()]; + [{procs, P}] when is_list(P) -> + P; + [{procs, P}] -> + [P]; + _ -> + erlang:error(badarg, [Options]) + end, + mode = {V, CT}, + type = Type, + dest = Dest}); + _ -> + erlang:error(badarg, [Options]) + end; +trace(Options) -> + erlang:error(badarg, [Options]). + + + +profile() -> + profile([]). + +profile(Option, Value) when is_atom(Option) -> + profile([{Option, Value}]); +profile(Option, Value) -> + erlang:error(badarg, [Option, Value]). + +profile(Option) when is_atom(Option) -> + profile([Option]); +profile({Opt, _Val} = Option) when is_atom(Opt) -> + profile([Option]); +profile(Options) when is_list(Options) -> + case getopts(Options, [start, stop, file, dump, append]) of + {[Start, [], File, Dump, Append], []} -> + {Target, Flags} = + case {Dump, Append} of + {[], []} -> + {[], []}; + {[dump], []} -> + {group_leader(), []}; + {[{dump, []}], []} -> + {?DUMP_FILE, []}; + {[{dump, []}], [append]} -> + {?DUMP_FILE, [append]}; + {[{dump, D}], [append]} when is_pid(D) -> + erlang:error(badarg, [Options]); + {[{dump, D}], [append]} -> + {D, [append]}; + {[{dump, D}], []} -> + {D, []}; + _ -> + erlang:error(badarg, [Options]) + end, + case {Start, File} of + {[start], []} -> + call(#profile_start{group_leader = group_leader(), + dump = Target, + flags = Flags}); + {[], _} -> + Src = + case File of + [] -> + ?TRACE_FILE; + [file] -> + ?TRACE_FILE; + [{file, []}] -> + ?TRACE_FILE; + [{file, F}] -> + F; + _ -> + erlang:error(badarg, [Options]) + end, + call(#profile{src = Src, + group_leader = group_leader(), + dump = Target, + flags = Flags}); + _ -> + erlang:error(badarg, [Options]) + end; + {[[], [stop], [], [], []], []} -> + call(#profile_stop{}); + _ -> + erlang:error(badarg, [Options]) + end; +profile(Options) -> + erlang:error(badarg, [Options]). + + + +analyse() -> + analyse([]). + +analyse(Option, Value) when is_atom(Option) -> + analyse([{Option, Value}]); +analyse(Option, Value) -> + erlang:error(badarg, [Option, Value]). + +analyse(Option) when is_atom(Option) -> + analyse([Option]); +analyse({Opt, _Val} = Option) when is_atom(Opt) -> + analyse([Option]); +analyse(Options) when is_list(Options) -> + case getopts(Options, + [dest, append, cols, callers, no_callers, + sort, totals, details, no_details]) of + {[Dest, Append, Cols, Callers, NoCallers, + Sort, Totals, Details, NoDetails], []} -> + {Target, Flags} = + case {Dest, Append} of + {[], []} -> + {group_leader(), []}; + {[dest], []} -> + {group_leader(), []}; + {[{dest, []}], []} -> + {?ANALYSIS_FILE, []}; + {[{dest, []}], [append]} -> + {?ANALYSIS_FILE, [append]}; + {[{dest, F}], [append]} when is_pid(F) -> + erlang:error(badarg, [Options]); + {[{dest, F}], [append]} -> + {F, [append]}; + {[{dest, F}], []} -> + {F, []}; + _ -> + erlang:error(badarg, [Options]) + end, + call(#analyse{group_leader = group_leader(), + dest = Target, + flags = Flags, + cols = case Cols of + [] -> + 80; + [{cols, C}] when is_integer(C), C > 0 -> + C; + _ -> + erlang:error(badarg, [Options]) + end, + callers = case {Callers, NoCallers} of + {[], []} -> + true; + {[callers], []} -> + true; + {[{callers, true}], []} -> + true; + {[{callers, false}], []} -> + false; + {[], [no_callers]} -> + false; + _ -> + erlang:error(badarg, [Options]) + end, + sort = case Sort of + [] -> + acc; + [{sort, acc}] -> + acc; + [{sort, own}] -> + own; + _ -> + erlang:error(badarg, [Options]) + end, + totals = case Totals of + [] -> + false; + [totals] -> + true; + [{totals, true}] -> + true; + [{totals, false}] -> + false; + _ -> + erlang:error(badarg, [Options]) + end, + details = case {Details, NoDetails} of + {[], []} -> + true; + {[details], []} -> + true; + {[{details, true}], []} -> + true; + {[{details, false}], []} -> + false; + {[], [no_details]} -> + false; + _ -> + erlang:error(badarg, [Options]) + end}); + _ -> + erlang:error(badarg, [Options]) + end; +analyse(Options) -> + erlang:error(badarg, [Options]). + + + +%%---------------- +%% Debug functions +%%---------------- + + + +get_state() -> + just_call(#get_state{}). + + + +save_profile() -> + save_profile([]). + +save_profile(Option, Value) when is_atom(Option) -> + save_profile([{Option, Value}]); +save_profile(Option, Value) -> + erlang:error(badarg, [Option, Value]). + +save_profile(Option) when is_atom(Option) -> + save_profile([Option]); +save_profile(Options) when is_list(Options) -> + case getopts(Options, [file]) of + {[File], []} -> + call(#save_profile{file = case File of + [] -> + ?PROFILE_FILE; + [{file, F}] -> + F; + _ -> + erlang:error(badarg, [Options]) + end}); + _ -> + erlang:error(badarg, [Options]) + end; +save_profile(Options) -> + erlang:error(badarg, [Options]). + + + +load_profile() -> + load_profile([]). + +load_profile(Option, Value) when is_atom(Option) -> + load_profile([{Option, Value}]); +load_profile(Option, Value) -> + erlang:error(badarg, [Option, Value]). + +load_profile(Option) when is_atom(Option) -> + load_profile([Option]); +load_profile(Options) when is_list(Options) -> + case getopts(Options, [file]) of + {[File], []} -> + call(#load_profile{file = case File of + [] -> + ?PROFILE_FILE; + [{file, F}] -> + F; + _ -> + erlang:error(badarg, [Options]) + end}); + _ -> + erlang:error(badarg, [Options]) + end; +load_profile(Options) -> + erlang:error(badarg, [Options]). + + + +code_change() -> + just_call('$code_change'). + + + +%%%---------------------------------------------------------------------- +%%% ETS table record definitions +%%% The field 'id' must be first in these records; +%%% it is the common ets table index field. +%%%---------------------------------------------------------------------- + +-record(clocks, { + id, + cnt = 0, % Number of calls + own = 0, % Own time (wall clock) + acc = 0}). % Accumulated time : own + subfunctions (wall clock) + +-record(proc, { + id, + parent, + spawned_as, % Spawned MFArgs + init_log = [], % List of first calls, head is newest + init_cnt = 2}). % First calls counter, counts down to 0 + +-record(misc, {id, + data}). + + + +%% Analysis summary record +-record(funcstat, { + callers_sum, % #clocks{id = {Pid, Caller, Func}} + called_sum, % #clocks{id = {Pid, Caller, Func}} + callers = [], % [#clocks{}, ...] + called = []}). % [#clocks{}, ...] + + + +%%%---------------------------------------------------------------------- +%%% ?FPROF_SERVER +%%%---------------------------------------------------------------------- + +%%%------------------- +%%% Exported functions +%%%------------------- + +%% Start server process +start() -> + spawn_3step( + fun () -> + try register(?FPROF_SERVER, self()) of + true -> + process_flag(trap_exit, true), + {{ok, self()}, loop} + catch + error:badarg -> + {{error, {already_started, whereis(?FPROF_SERVER)}}, + already_started} + end + end, + fun (X) -> + X + end, + fun (loop) -> + put(trace_state, idle), + put(profile_state, {idle, undefined}), + put(pending_stop, []), + server_loop([]); + (already_started) -> + ok + end). + + + +%% Stop server process + +stop() -> + stop(normal). + +stop(kill) -> + case whereis(?FPROF_SERVER) of + undefined -> + ok; + Pid -> + exit(Pid, kill), + ok + end; +stop(Reason) -> + just_call(#stop{reason = Reason}), + ok. + + + +%%%------------------------ +%%% Client helper functions +%%%------------------------ + +%% Send request to server process and return the server's reply. +%% First start server if it ain't started. +call(Request) -> + case whereis(?FPROF_SERVER) of + undefined -> + start(), + just_call(Request); + Server -> + just_call(Server, Request) + end. + +%% Send request to server process, and return the server's reply. +%% Returns {'EXIT', Pid, Reason} if the server dies during the +%% call, or if it wasn't started. +just_call(Request) -> + just_call(whereis(?FPROF_SERVER), Request). + +just_call(undefined, _) -> + {'EXIT', ?FPROF_SERVER, noproc}; +just_call(Pid, Request) -> + Mref = erlang:monitor(process, Pid), + receive + {'DOWN', Mref, _, _, Reason} -> + {'EXIT', Pid, Reason} + after 0 -> + Tag = {Mref, self()}, + {T, Demonitor} = case Request of + #stop{} -> + {?FPROF_SERVER_TIMEOUT, false}; + _ -> + {0, true} + end, + %% io:format("~p request: ~p~n", [?MODULE, Request]), + catch Pid ! {?FPROF_SERVER, Tag, Request}, + receive + {?FPROF_SERVER, Mref, Reply} -> + case Demonitor of + true -> erlang:demonitor(Mref); + false -> ok + end, + receive {'DOWN', Mref, _, _, _} -> ok after T -> ok end, + Reply; + {'DOWN', Mref, _, _, Reason} -> + receive {?FPROF_SERVER, Mref, _} -> ok after T -> ok end, + {'EXIT', Pid, Reason} + after ?FPROF_SERVER_TIMEOUT -> + timeout + end + end. + + + +%%%------------------------ +%%% Server helper functions +%%%------------------------ + +%% Return the reply to the client's request. +reply({Mref, Pid}, Reply) when is_reference(Mref), is_pid(Pid) -> + catch Pid ! {?FPROF_SERVER, Mref, Reply}, + ok. + + + +server_loop(State) -> + receive + {?FPROF_SERVER, {Mref, Pid} = Tag, '$code_change'} + when is_reference(Mref), is_pid(Pid) -> + reply(Tag, ok), + ?MODULE:'$code_change'(State); + {?FPROF_SERVER, {Mref, Pid} = Tag, Request} + when is_reference(Mref), is_pid(Pid) -> + server_loop(handle_req(Request, Tag, State)); + Other -> + server_loop(handle_other(Other, State)) + end. + +%-export. +'$code_change'(State) -> + case lists:keysearch(time, 1, module_info(compile)) of + {value, {time, {Y, M, D, HH, MM, SS}}} -> + io:format("~n~w: code change to compile time " + ++"~4..0w-~2..0w-~2..0w ~2..0w:~2..0w:~2..0w~n", + [?MODULE, Y, M, D, HH, MM, SS]); + false -> + ok + end, + server_loop(State). + + + +%% Server help function that stops the server iff the +%% sub state machines are in proper states. Sends the reply +%% to all waiting clients. +try_pending_stop(State) -> + case {get(trace_state), get(profile_state), get(pending_stop)} of + {idle, {idle, _}, [_|_] = PendingStop} -> + Reason = get(stop_reason), + Reply = result(Reason), + lists:foreach( + fun (Tag) -> + reply(Tag, Reply) + end, + PendingStop), + exit(Reason); + _ -> + State + end. + +%%------------------ +%% Server handle_req +%%------------------ + +handle_req(#trace_start{procs = Procs, + mode = Mode, + type = file, + dest = Filename}, Tag, State) -> + case {get(trace_state), get(pending_stop)} of + {idle, []} -> + trace_off(), + Port = open_dbg_trace_port(file, Filename), + case trace_on(Procs, Port, Mode) of + ok -> + put(trace_state, running), + put(trace_type, file), + put(trace_pid, Port), + reply(Tag, ok), + State; + Error -> + reply(Tag, Error), + State + end; + _ -> + reply(Tag, {error, already_tracing}), + State + end; +handle_req(#trace_start{procs = Procs, + mode = Mode, + type = tracer, + dest = Tracer}, Tag, State) -> + case {get(trace_state), get(pending_stop)} of + {idle, []} -> + trace_off(), + case trace_on(Procs, Tracer, Mode) of + ok -> + put(trace_state, running), + put(trace_type, tracer), + put(trace_pid, Tracer), + reply(Tag, ok), + State; + Error -> + reply(Tag, Error), + State + end; + _ -> + reply(Tag, {error, already_tracing}), + State + end; + +handle_req(#trace_stop{}, Tag, State) -> + case get(trace_state) of + running -> + TracePid = get(trace_pid), + trace_off(), + case erase(trace_type) of + file -> + catch erlang:port_close(TracePid), + put(trace_state, stopping), + put(trace_tag, Tag), + State; + tracer -> + erase(trace_pid), + put(trace_state, idle), + case {get(profile_state), get(profile_type), + get(profile_pid)} of + {running, tracer, TracePid} -> + exit(TracePid, normal), + put(profile_tag, Tag), + State; + _ -> + reply(Tag, ok), + try_pending_stop(State) + end + end; + _ -> + reply(Tag, {error, not_tracing}), + State + end; + +handle_req(#profile{src = Filename, + group_leader = GroupLeader, + dump = Dump, + flags = Flags}, Tag, State) -> + case {get(profile_state), get(pending_stop)} of + {{idle, _}, []} -> + case ensure_open(Dump, [write | Flags]) of + {already_open, DumpPid} -> + put(profile_dump, DumpPid), + put(profile_close_dump, false); + {ok, DumpPid} -> + put(profile_dump, DumpPid), + put(profile_close_dump, true); + {error, _} = Error -> + reply(Tag, Error), + State + end, + Table = ets:new(?MODULE, [set, public, {keypos, #clocks.id}]), + Pid = spawn_link_dbg_trace_client(Filename, Table, + GroupLeader, + get(profile_dump)), + put(profile_state, running), + put(profile_type, file), + put(profile_pid, Pid), + put(profile_tag, Tag), + put(profile_table, Table), + State; + _ -> + reply(Tag, {error, already_profiling}), + State + end; + +handle_req(#profile_start{group_leader = GroupLeader, + dump = Dump, + flags = Flags}, Tag, State) -> + case {get(profile_state), get(pending_stop)} of + {{idle, _}, []} -> + case ensure_open(Dump, [write | Flags]) of + {already_open, DumpPid} -> + put(profile_dump, DumpPid), + put(profile_close_dump, false); + {ok, DumpPid} -> + put(profile_dump, DumpPid), + put(profile_close_dump, true); + {error, _} = Error -> + reply(Tag, Error), + State + end, + Table = ets:new(?MODULE, [set, public, {keypos, #clocks.id}]), + Pid = spawn_link_trace_client(Table, GroupLeader, + get(profile_dump)), + put(profile_state, running), + put(profile_type, tracer), + put(profile_pid, Pid), + put(profile_table, Table), + reply(Tag, {ok, Pid}), + State; + _ -> + reply(Tag, {error, already_profiling}), + State + end; + +handle_req(#profile_stop{}, Tag, State) -> + case {get(profile_state), get(profile_type)} of + {running, tracer} -> + ProfilePid = get(profile_pid), + case {get(trace_state), get(trace_type), get(trace_pid)} of + {running, tracer, ProfilePid} -> + trace_off(), + erase(trace_type), + erase(trace_pid), + put(trace_state, idle); + _ -> + ok + end, + exit(ProfilePid, normal), + put(profile_tag, Tag), + State; + {running, file} -> + reply(Tag, {error, profiling_file}), + State; + {_, _} -> + reply(Tag, {error, not_profiling}), + State + end; + +handle_req(#analyse{dest = Dest, + flags = Flags} = Request, Tag, State) -> + case get(profile_state) of + {idle, undefined} -> + reply(Tag, {error, no_profile}), + State; + {idle, _} -> + case ensure_open(Dest, [write | Flags]) of + {error, _} = Error -> + reply(Tag, Error), + State; + {DestState, DestPid} -> + ProfileTable = get(profile_table), + reply(Tag, + spawn_3step( + fun() -> + do_analyse(ProfileTable, + Request#analyse{dest = DestPid}) + end, + fun(Result) -> + {Result,finish} + end, + fun(finish) -> + ok + end)), + case DestState of + already_open -> + ok; + ok -> + file:close(DestPid) + end, + State + end; + _ -> + reply(Tag, {error, profiling}), + State + end; + +handle_req(#stop{reason = Reason}, Tag, State) -> + PendingStop = get(pending_stop), + case PendingStop of + [] -> + put(stop_reason, Reason); + _ -> + ok + end, + put(pending_stop, [Tag | PendingStop]), + try_pending_stop(State); + +%%---------------------- +%% Server debug requests +%%---------------------- + +handle_req(#get_state{}, Tag, State) -> + reply(Tag, {ok, get()}), + State; + +handle_req(#save_profile{file = File}, Tag, State) -> + case get(profile_state) of + {idle, undefined} -> + reply(Tag, {error, no_profile}); + {idle, _} -> + reply(Tag, ets:tab2file(get(profile_table), File)), + State; + _ -> + reply(Tag, {error, profiling}), + State + end; + +handle_req(#load_profile{file = File}, Tag, State) -> + case get(profile_state) of + {idle, Result} -> + case ets:file2tab(File) of + {ok, Table} -> + put(profile_state, {idle, ok}), + case Result of + {error, no_profile} -> + ets:delete(put(profile_table, Table)); + _ -> + put(profile_table, Table) + end, + reply(Tag, ok), + State; + Error -> + reply(Tag, Error), + State + end; + _ -> + reply(Tag, {error, profiling}), + State + end; + + + +handle_req(Request, Tag, State) -> + io:format("~n~p:handle_req, unknown request - ~p~n", + [?MODULE, Request]), + reply(Tag, {error, unknown_request}), + State. + +%%-------------------- +%% Server handle_other +%%-------------------- + +handle_other({'EXIT', Pid, Reason} = Other, State) when is_pid(Pid); is_port(Pid) -> + case {get(trace_state), get(trace_pid)} of + {running, Pid} -> + trace_off(), + io:format("~n~p:handle_other, unexpected ~p (trace_pid)~n", + [?MODULE, Other]), + put(trace_state, idle), + erase(trace_type), + erase(trace_pid), + try_pending_stop(State); + {stopping, Pid} -> + put(trace_state, idle), + erase(trace_pid), + reply(erase(trace_tag), result(Reason)), + try_pending_stop(State); + _ -> + case {get(profile_state), get(profile_pid)} of + {running, Pid} -> + Result = result(Reason), + put(profile_state, {idle, Result}), + erase(profile_type), + erase(profile_pid), + case erase(profile_close_dump) of + true -> + file:close(erase(profile_dump)); + false -> + erase(profile_dump) + end, + reply(erase(profile_tag), Result), + try_pending_stop(State); + _ -> + io:format("~n~p:handle_other, unexpected ~p~n", + [?MODULE, Other]), + State + end + end; + +handle_other(Other, State) -> + io:format("~p:handle_other, unknown - ~p", + [?MODULE, Other]), + State. + + + +%%%---------------------------------------------------------------------- +%%% Internal functions +%%%---------------------------------------------------------------------- + +result(normal) -> + ok; +result(Reason) -> + {error, Reason}. + +ensure_open(Pid, _Options) when is_pid(Pid) -> + {already_open, Pid}; +ensure_open([], _Options) -> + {already_open, undefined}; +ensure_open(Filename, Options) when is_atom(Filename); is_list(Filename) -> + file:open(Filename, Options). + +%%%--------------------------------- +%%% Fairly generic utility functions +%%%--------------------------------- + + + +%% getopts(List, Options)) -> {DecodedOptions, RestOptions} +%% +%% List = [Option] +%% Options = [OptionTag] +%% Option = OptionTag | OptionTuple +%% OptionTuple = tuple(), element(1, OptionTuple) == OptionTag +%% OptionTag = term() +%% OptionValue = term() +%% DecodedOptions = [OptionList] +%% OptionList = [Option] +%% RestOptions = [Option] +%% +%% Searches List for options with tags defined in Options. +%% Returns DecodedOptions containing one OptionList per +%% OptionTag in Options, and RestOptions which contains +%% all terms from List not matching any OptionTag. +%% +%% All returned lists preserve the order from Options and List. +%% +%% An example: +%% getopts([{f, 1}, e, {d, 2}, {c, 3, 4}, {b, 5}, a, b], +%% [a, b, c, d]) -> +%% {[[a], [{b, 5}, b],[{c, 3, 4}], [{d, 2}]], +%% [{f, 1}, e]} +%% +getopts(List, Options) when is_list(List), is_list(Options) -> + getopts_1(Options, List, []). + +getopts_1([], List, Result) -> + {lists:reverse(Result), List}; +getopts_1([Option | Options], List, Result) -> + {Optvals, Remaining} = getopts_2(List, Option, [], []), + getopts_1(Options, Remaining, [Optvals | Result]). + +getopts_2([], _Option, Result, Remaining) -> + {lists:reverse(Result), lists:reverse(Remaining)}; +getopts_2([Option | Tail], Option, Result, Remaining) -> + getopts_2(Tail, Option, [Option | Result], Remaining); +getopts_2([Optval | Tail], Option, Result, Remaining) + when element(1, Optval) =:= Option -> + getopts_2(Tail, Option, [Optval | Result], Remaining); +getopts_2([Other | Tail], Option, Result, Remaining) -> + getopts_2(Tail, Option, Result, [Other | Remaining]). + +%% setopts(Options) -> List +%% +%% The reverse of getopts, almost. +%% Re-creates (approximately) List from DecodedOptions in +%% getopts/2 above. The original order is not preserved, +%% but rather the order from Options. +%% +%% An example: +%% setopts([[a], [{b,5}, b], [{c, 3, 4}], [{d,2}]]) -> +%% [a, {b, 5}, b, {c, 3, 4}, {d, 2}] +%% +%% And a more generic example: +%% {D, R} = getopts(L, O), +%% L2 = setopts(D) ++ R +%% L2 will contain exactly the same terms as L, but not in the same order. +%% +setopts(Options) when is_list(Options) -> + lists:append(Options). + + + +spawn_3step(FunPrelude, FunAck, FunBody) -> + spawn_3step(spawn, FunPrelude, FunAck, FunBody). + +spawn_link_3step(FunPrelude, FunAck, FunBody) -> + spawn_3step(spawn_link, FunPrelude, FunAck, FunBody). + +spawn_3step(Spawn, FunPrelude, FunAck, FunBody) + when Spawn =:= spawn; Spawn =:= spawn_link -> + Parent = self(), + Ref = make_ref(), + Child = + erlang:Spawn( + fun() -> + Ack = FunPrelude(), + catch Parent ! {self(), Ref, Ack}, + MRef = erlang:monitor(process, Parent), + receive + {Parent, Ref, Go} -> + erlang:demonitor(MRef), + receive {'DOWN', MRef, _, _, _} -> ok + after 0 -> ok + end, + FunBody(Go); + {'DOWN', MRef, _, _, _} -> + ok + end + end), + MRef = erlang:monitor(process, Child), + receive + {Child, Ref, Ack} -> + erlang:demonitor(MRef), + receive {'DOWN', MRef, _, _, _} -> ok after 0 -> ok end, + try FunAck(Ack) of + {Result, Go} -> + catch Child ! {Parent, Ref, Go}, + Result + catch + Class:Reason -> + Stacktrace = erlang:get_stacktrace(), + catch exit(Child, kill), + erlang:raise(Class, Reason, Stacktrace) + end; + {'DOWN', MRef, _, _, Reason} -> + receive {Child, Ref, _Ack} -> ok after 0 -> ok end, + case Spawn of + spawn_link -> + receive {'EXIT', Reason} -> ok after 0 -> ok end; + spawn -> + ok + end, + exit(Reason) + end. + + + +%%%--------------------------------- +%%% Trace message handling functions +%%%--------------------------------- + +trace_off() -> + try erlang:trace_delivered(all) of + Ref -> receive {trace_delivered, all, Ref} -> ok end + catch + error:undef -> ok + end, + try erlang:trace(all, false, [all, cpu_timestamp]) + catch + error:badarg -> erlang:trace(all, false, [all]) + end, + erlang:trace_pattern(on_load, false, [local]), + erlang:trace_pattern({'_', '_', '_'}, false, [local]), + ok. + + + +trace_on(Procs, Tracer, {V, CT}) -> + case case CT of + cpu_time -> + try erlang:trace(all, true, [cpu_timestamp]) of _ -> ok + catch + error:badarg -> {error, not_supported} + end; + wallclock -> ok + end + of ok -> + MatchSpec = [{'_', [], [{message, {{cp, {caller}}}}]}], + erlang:trace_pattern(on_load, MatchSpec, [local]), + erlang:trace_pattern({'_', '_', '_'}, MatchSpec, [local]), + lists:foreach( + fun (P) -> + erlang:trace(P, true, [{tracer, Tracer} | trace_flags(V)]) + end, + Procs), + ok; + Error -> + Error + end. + + + +trace_flags(normal) -> + [call, return_to, + running, procs, garbage_collection, + arity, timestamp, set_on_spawn]; +trace_flags(verbose) -> + [call, return_to, + send, 'receive', + running, procs, garbage_collection, + timestamp, set_on_spawn]. + + + +%%%------------------------------------- +%%% Tracer process functions, for +%%% the 'dbg' tracer and for a lookalike +%%%------------------------------------- + +open_dbg_trace_port(Type, Spec) -> + Fun = dbg:trace_port(Type, Spec), + Fun(). + + + +spawn_link_dbg_trace_client(File, Table, GroupLeader, Dump) -> + case dbg:trace_client(file, File, + {fun handler/2, + {init, GroupLeader, Table, Dump}}) of + Pid when is_pid(Pid) -> + link(Pid), + Pid; + Other -> + exit(Other) + end. + + + + +spawn_link_trace_client(Table, GroupLeader, Dump) -> + Parent = self(), + spawn_link_3step( + fun() -> + process_flag(trap_exit, true), + {self(),go} + end, + fun(Ack) -> + Ack + end, + fun(go) -> + Init = {init, GroupLeader, Table, Dump}, + tracer_loop(Parent, fun handler/2, Init) + end). + +tracer_loop(Parent, Handler, State) -> + receive + Trace when element(1, Trace) =:= trace -> + tracer_loop(Parent, Handler, Handler(Trace, State)); + Trace when element(1, Trace) =:= trace_ts -> + tracer_loop(Parent, Handler, Handler(Trace, State)); + {'EXIT', Parent, Reason} -> + handler(end_of_trace, State), + exit(Reason); + _ -> + tracer_loop(Parent, Handler, State) + end. + + + +%%%--------------------------------- +%%% Trace message handling functions +%%%--------------------------------- + +handler(end_of_trace, {init, GroupLeader, Table, Dump}) -> + dump(Dump, start_of_trace), + dump(Dump, end_of_trace), + info(GroupLeader, Dump, "Empty trace!~n", []), + end_of_trace(Table, undefined), + done; +handler(end_of_trace, {error, Reason, _, GroupLeader, Dump}) -> + info(GroupLeader, Dump, "~nEnd of erroneous trace!~n", []), + exit(Reason); +handler(end_of_trace, {_, TS, GroupLeader, Table, Dump}) -> + dump(Dump, end_of_trace), + info(GroupLeader, Dump, "~nEnd of trace!~n", []), + end_of_trace(Table, TS), + done; +handler(Trace, {init, GroupLeader, Table, Dump}) -> + dump(Dump, start_of_trace), + info(GroupLeader, Dump, "Reading trace data...~n", []), + try trace_handler(Trace, Table, GroupLeader, Dump) of + TS -> + ets:insert(Table, #misc{id = first_ts, data = TS}), + ets:insert(Table, #misc{id = last_ts_n, data = {TS, 1}}), + {1, TS, GroupLeader, Table, Dump} + catch + Error -> + dump(Dump, {error, Error}), + end_of_trace(Table, undefined), + {error, Error, 1, GroupLeader, Dump} + end; +%% case catch trace_handler(Trace, Table, GroupLeader, Dump) of +%% {'EXIT', Reason} -> +%% dump(Dump, {error, Reason}), +%% end_of_trace(Table, undefined), +%% {error, Reason, 1, GroupLeader, Dump}; +%% TS -> +%% ets:insert(Table, #misc{id = first_ts, data = TS}), +%% ets:insert(Table, #misc{id = last_ts_n, data = {TS, 1}}), +%% {1, TS, GroupLeader, Table, Dump} +%% end; +handler(_, {error, Reason, M, GroupLeader, Dump}) -> + N = M+1, + info_dots(GroupLeader, Dump, N), + {error, Reason, N, GroupLeader, Dump}; +handler(Trace, {M, TS0, GroupLeader, Table, Dump}) -> + N = M+1, + info_dots(GroupLeader, Dump, N), + try trace_handler(Trace, Table, GroupLeader, Dump) of + TS -> + ets:insert(Table, #misc{id = last_ts_n, data = {TS, N}}), + {N, TS, GroupLeader, Table, Dump} + catch + Error -> + dump(Dump, {error, Error}), + end_of_trace(Table, TS0), + {error, Error, N, GroupLeader, Dump} + end. +%% case catch trace_handler(Trace, Table, GroupLeader, Dump) of +%% {'EXIT', Reason} -> +%% dump(Dump, {error, Reason}), +%% end_of_trace(Table, TS0), +%% {error, Reason, N, GroupLeader, Dump}; +%% TS -> +%% ets:insert(Table, #misc{id = last_ts_n, data = {TS, N}}), +%% {N, TS, GroupLeader, Table, Dump} +%% end. + + + +end_of_trace(Table, TS) -> + %% + %% Close all process stacks, as if the processes exited. + %% + Procs = get(), + put(table, Table), + ?dbg(2, "get() -> ~p~n", [Procs]), + lists:map( + fun ({Pid, _}) when is_pid(Pid) -> + trace_exit(Table, Pid, TS) + end, + Procs), + erase(), + ok. + + + +info_dots(GroupLeader, GroupLeader, _) -> + ok; +info_dots(GroupLeader, _, N) -> + if (N rem 100000) =:= 0 -> + io:format(GroupLeader, ",~n", []); + (N rem 50000) =:= 0 -> + io:format(GroupLeader, ".~n", []); + (N rem 1000) =:= 0 -> + io:put_chars(GroupLeader, "."); + true -> + ok + end. + +info_suspect_call(GroupLeader, GroupLeader, _, _) -> + ok; +info_suspect_call(GroupLeader, _, Func, Pid) -> + io:format(GroupLeader, + "~nWarning: ~p called in ~p - trace may become corrupt!~n", + parsify([Func, Pid])). + +info(GroupLeader, GroupLeader, _, _) -> + ok; +info(GroupLeader, _, Format, List) -> + io:format(GroupLeader, Format, List). + +dump_stack(undefined, _, _) -> + false; +dump_stack(Dump, Stack, Term) -> + {Depth, _D} = + case Stack of + undefined -> + {0, 0}; + _ -> + case length(Stack) of + 0 -> + {0, 0}; + N -> + {N, length(hd(Stack))} + end + end, + io:format(Dump, "~s~p.~n", [lists:duplicate(Depth, " "), parsify(Term)]), + true. + +dump(undefined, _) -> + false; +dump(Dump, Term) -> + io:format(Dump, "~p.~n", [parsify(Term)]), + true. + + + +%%%---------------------------------- +%%% Profiling state machine functions +%%%---------------------------------- + + + +trace_handler({trace_ts, Pid, call, _MFA, _TS} = Trace, + _Table, _, Dump) -> + Stack = get(Pid), + dump_stack(Dump, Stack, Trace), + throw({incorrect_trace_data, ?MODULE, ?LINE, + [Trace, Stack]}); +trace_handler({trace_ts, Pid, call, {_M, _F, Arity} = Func, + {cp, CP}, TS} = Trace, + Table, GroupLeader, Dump) + when is_integer(Arity) -> + dump_stack(Dump, get(Pid), Trace), + case Func of + {erlang, trace, 3} -> + info_suspect_call(GroupLeader, Dump, Func, Pid); + {erlang, trace_pattern, 3} -> + info_suspect_call(GroupLeader, Dump, Func, Pid); + _ -> + ok + end, + trace_call(Table, Pid, Func, TS, CP), + TS; +trace_handler({trace_ts, Pid, call, {_M, _F, Args} = MFArgs, + {cp, CP}, TS} = Trace, + Table, _, Dump) + when is_list(Args) -> + dump_stack(Dump, get(Pid), Trace), + Func = mfarity(MFArgs), + trace_call(Table, Pid, Func, TS, CP), + TS; +%% +%% return_to +trace_handler({trace_ts, Pid, return_to, undefined, TS} = Trace, + Table, _, Dump) -> + dump_stack(Dump, get(Pid), Trace), + trace_return_to(Table, Pid, undefined, TS), + TS; +trace_handler({trace_ts, Pid, return_to, {_M, _F, Arity} = Func, TS} = Trace, + Table, _, Dump) + when is_integer(Arity) -> + dump_stack(Dump, get(Pid), Trace), + trace_return_to(Table, Pid, Func, TS), + TS; +trace_handler({trace_ts, Pid, return_to, {_M, _F, Args} = MFArgs, TS} = Trace, + Table, _, Dump) + when is_list(Args) -> + dump_stack(Dump, get(Pid), Trace), + Func = mfarity(MFArgs), + trace_return_to(Table, Pid, Func, TS), + TS; +%% +%% spawn +trace_handler({trace_ts, Pid, spawn, Child, MFArgs, TS} = Trace, + Table, _, Dump) -> + dump_stack(Dump, get(Pid), Trace), + trace_spawn(Table, Child, MFArgs, TS, Pid), + TS; +%% +%% exit +trace_handler({trace_ts, Pid, exit, _Reason, TS} = Trace, + Table, _, Dump) -> + dump_stack(Dump, get(Pid), Trace), + trace_exit(Table, Pid, TS), + TS; +%% +%% out +trace_handler({trace_ts, Pid, out, 0, TS} = Trace, + Table, _, Dump) -> + dump_stack(Dump, get(Pid), Trace), + trace_out(Table, Pid, undefined, TS), + TS; +trace_handler({trace_ts, Pid, out, {_M, _F, Arity} = Func, TS} = Trace, + Table, _, Dump) + when is_integer(Arity) -> + dump_stack(Dump, get(Pid), Trace), + trace_out(Table, Pid, Func, TS), + TS; +trace_handler({trace_ts, Pid, out, {_M, _F, Args} = MFArgs, TS} = Trace, + Table, _, Dump) + when is_list(Args) -> + dump_stack(Dump, get(Pid), Trace), + Func = mfarity(MFArgs), + trace_out(Table, Pid, Func, TS), + TS; +%% +%% in +trace_handler({trace_ts, Pid, in, 0, TS} = Trace, + Table, _, Dump) -> + dump_stack(Dump, get(Pid), Trace), + trace_in(Table, Pid, undefined, TS), + TS; +trace_handler({trace_ts, Pid, in, {_M, _F, Arity} = Func, TS} = Trace, + Table, _, Dump) + when is_integer(Arity) -> + dump_stack(Dump, get(Pid), Trace), + trace_in(Table, Pid, Func, TS), + TS; +trace_handler({trace_ts, Pid, in, {_M, _F, Args} = MFArgs, TS} = Trace, + Table, _, Dump) + when is_list(Args) -> + dump_stack(Dump, get(Pid), Trace), + Func = mfarity(MFArgs), + trace_in(Table, Pid, Func, TS), + TS; +%% +%% gc_start +trace_handler({trace_ts, Pid, gc_start, _Func, TS} = Trace, + Table, _, Dump) -> + dump_stack(Dump, get(Pid), Trace), + trace_gc_start(Table, Pid, TS), + TS; +%% +%% gc_end +trace_handler({trace_ts, Pid, gc_end, _Func, TS} = Trace, + Table, _, Dump) -> + dump_stack(Dump, get(Pid), Trace), + trace_gc_end(Table, Pid, TS), + TS; +%% +%% link +trace_handler({trace_ts, Pid, link, _OtherPid, TS} = Trace, + _Table, _, Dump) -> + dump_stack(Dump, get(Pid), Trace), + TS; +%% +%% unlink +trace_handler({trace_ts, Pid, unlink, _OtherPid, TS} = Trace, + _Table, _, Dump) -> + dump_stack(Dump, get(Pid), Trace), + TS; +%% +%% getting_linked +trace_handler({trace_ts, Pid, getting_linked, _OtherPid, TS} = Trace, + _Table, _, Dump) -> + dump_stack(Dump, get(Pid), Trace), + TS; +%% +%% getting_unlinked +trace_handler({trace_ts, Pid, getting_unlinked, _OtherPid, TS} = Trace, + _Table, _, Dump) -> + dump_stack(Dump, get(Pid), Trace), + TS; +%% +%% register +trace_handler({trace_ts, Pid, register, _Name, TS} = Trace, + _Table, _, Dump) -> + dump_stack(Dump, get(Pid), Trace), + TS; +%% +%% unregister +trace_handler({trace_ts, Pid, unregister, _Name, TS} = Trace, + _Table, _, Dump) -> + dump_stack(Dump, get(Pid), Trace), + TS; +%% +%% send +trace_handler({trace_ts, Pid, send, _OtherPid, _Msg, TS} = Trace, + _Table, _, Dump) -> + dump_stack(Dump, get(Pid), Trace), + TS; +%% +%% 'receive' +trace_handler({trace_ts, Pid, 'receive', _Msg, TS} = Trace, + _Table, _, Dump) -> + dump_stack(Dump, get(Pid), Trace), + TS; +%% +%% Others +trace_handler(Trace, _Table, _, Dump) -> + dump(Dump, Trace), + throw({incorrect_trace_data, ?MODULE, ?LINE, [Trace]}). + + + +%% The call stack +%% -------------- +%% +%% The call stack can be modeled as a tree, with each level in the tree +%% corresponding to a real (non-tail recursive) stack entry, +%% and the nodes within a level corresponding to tail recursive +%% calls on that real stack depth. +%% +%% Example: +%% a() -> +%% b(). +%% b() -> +%% c(), +%% d(). +%% c() -> ok. +%% d() -> +%% e(), +%% c(). +%% e() -> +%% f(). +%% f() -> ok. +%% +%% During the execution the call tree would be, for each call and return_to: +%% +%% a() b() c() ->b d() e() f() ->d c() ->a +%% +%% a a a a a a a a a a +%% | | | |\ |\ |\ |\ /|\ +%% b b b b d b d b d b d b d c +%% | | /| +%% c e e f +%% +%% The call tree is in this code represented as a two level list, +%% which for the biggest tree (5 nodes) in the example above would be: +%% [[{f, _}, {e, _}], [{d, _}, {b, _}], [{a, _}]] +%% where the undefined fields are timestamps of the calls to the +%% functions, and the function name fields are really +%% {Module, Function, Arity} tuples. +%% +%% Since tail recursive calls can form an infinite loop, cycles +%% within a tail recursive level must be collapsed or else the +%% stack (tree) size may grow towards infinity. + + + +trace_call(Table, Pid, Func, TS, CP) -> + Stack = get_stack(Pid), + ?dbg(0, "trace_call(~p, ~p, ~p, ~p)~n~p~n", + [Pid, Func, TS, CP, Stack]), + {Proc,InitCnt} = + case ets:lookup(Table, Pid) of + [#proc{init_cnt = N} = P] -> + {P,N}; + [] -> + {undefined,0} + end, + case Stack of + [] -> + init_log(Table, Proc, Func), + OldStack = + if CP =:= undefined -> + Stack; + true -> + [[{CP, TS}]] + end, + put(Pid, trace_call_push(Table, Pid, Func, TS, OldStack)); + [[{Func, FirstInTS}]] when InitCnt=:=2 -> + %% First call on this process. Take the timestamp for first + %% time the process was scheduled in. + init_log(Table, Proc, Func), + OldStack = + if CP =:= undefined -> + []; + true -> + [[{CP, FirstInTS}]] + end, + put(Pid, trace_call_push(Table, Pid, Func, FirstInTS, OldStack)); + [[{suspend, _} | _] | _] -> + throw({inconsistent_trace_data, ?MODULE, ?LINE, + [Pid, Func, TS, CP, Stack]}); + [[{garbage_collect, _} | _] | _] -> + throw({inconsistent_trace_data, ?MODULE, ?LINE, + [Pid, Func, TS, CP, Stack]}); + [[{CP, _} | _], [{CP, _} | _] | _] -> + %% This is a difficult case - current function becomes + %% new stack top but is already pushed. It might be that + %% this call is actually tail recursive, or maybe not. + %% Assume tail recursive to not build the stack infinitely + %% and fix the problem at the next call after a return to + %% this level. + %% + %% This can be viewed as collapsing a very short stack + %% recursive stack cykle. + init_log(Table, Proc, Func), + put(Pid, trace_call_shove(Table, Pid, Func, TS, Stack)); + [[{CP, _} | _] | _] -> + %% Current function becomes new stack top -> stack push + init_log(Table, Proc, Func), + put(Pid, trace_call_push(Table, Pid, Func, TS, Stack)); + [_, [{CP, _} | _] | _] -> + %% Stack top unchanged -> no push == tail recursive call + init_log(Table, Proc, Func), + put(Pid, trace_call_shove(Table, Pid, Func, TS, Stack)); + [[{Func0, _} | _], [{Func0, _} | _], [{CP, _} | _] | _] -> + %% Artificial case that only should happen when + %% stack recursive short cycle collapsing has been done, + %% otherwise CP should not occur so far from the stack front. + %% + %% It is a tail recursive call but fix the stack first. + init_log(Table, Proc, Func), + put(Pid, + trace_call_shove(Table, Pid, Func, TS, + trace_return_to_int(Table, Pid, Func0, TS, + Stack))); + [[{_, TS0} | _] = Level0] -> + %% Current function known, but not stack top + %% -> assume tail recursive call + init_log(Table, Proc, Func), + OldStack = + if CP =:= undefined -> + Stack; + true -> + [Level0, [{CP, TS0}]] + end, + put(Pid, trace_call_shove(Table, Pid, Func, TS, OldStack)); + [_ | _] -> + %% Weird case when the stack is seriously f***ed up. + %% CP is not at stack top nor at previous stack top, + %% which is impossible, if we had a correct stack view. + OldStack = + if CP =:= undefined -> + %% Assume that CP is unknown because it is + %% the stack bottom for the process, and that + %% the whole call stack is invalid. Waste it. + trace_return_to_int(Table, Pid, CP, TS, Stack); + true -> + %% Assume that we have collapsed a tail recursive + %% call stack cykle too many. Introduce CP in + %% the current tail recursive level so it at least + %% gets charged for something. + init_log(Table, Proc, CP), + trace_call_shove(Table, Pid, CP, TS, Stack) + end, + %% Regard this call as a stack push. + init_log(Table, Pid, Func), % will lookup Pid in Table + put(Pid, trace_call_push(Table, Pid, Func, TS, OldStack)) + end, + ok. + +%% Normal stack push +trace_call_push(Table, Pid, Func, TS, Stack) -> + case Stack of + [] -> + ok; + [_ | _] -> + trace_clock(Table, Pid, TS, Stack, #clocks.own) + end, + NewStack = [[{Func, TS}] | Stack], + trace_clock(Table, Pid, 1, NewStack, #clocks.cnt), + NewStack. + +%% Tail recursive stack push +trace_call_shove(Table, Pid, Func, TS, Stack) -> + trace_clock(Table, Pid, TS, Stack, #clocks.own), + [[_ | NewLevel0] | NewStack1] = + case Stack of + [] -> + [[{Func, TS}]]; + [Level0 | Stack1] -> + [trace_call_collapse([{Func, TS} | Level0]) | Stack1] + end, + NewStack = [[{Func, TS} | NewLevel0] | NewStack1], + trace_clock(Table, Pid, 1, NewStack, #clocks.cnt), + NewStack. + +%% Collapse tail recursive call stack cycles to prevent them from +%% growing to infinite length. +trace_call_collapse([]) -> + []; +trace_call_collapse([_] = Stack) -> + Stack; +trace_call_collapse([_, _] = Stack) -> + Stack; +trace_call_collapse([_ | Stack1] = Stack) -> + trace_call_collapse_1(Stack, Stack1, 1). + +%% Find some other instance of the current function in the call stack +%% and try if that instance may be used as stack top instead. +trace_call_collapse_1(Stack, [], _) -> + Stack; +trace_call_collapse_1([{Func0, _} | _] = Stack, [{Func0, _} | S1] = S, N) -> + case trace_call_collapse_2(Stack, S, N) of + true -> + S; + false -> + trace_call_collapse_1(Stack, S1, N+1) + end; +trace_call_collapse_1(Stack, [_ | S1], N) -> + trace_call_collapse_1(Stack, S1, N+1). + +%% Check if all caller/called pairs in the perhaps to be collapsed +%% stack segment (at the front) are present in the rest of the stack, +%% and also in the same order. +trace_call_collapse_2(_, _, 0) -> + true; +trace_call_collapse_2([{Func1, _} | [{Func2, _} | _] = Stack2], + [{Func1, _} | [{Func2, _} | _] = S2], + N) -> + trace_call_collapse_2(Stack2, S2, N-1); +trace_call_collapse_2([{Func1, _} | _], [{Func1, _} | _], _N) -> + false; +trace_call_collapse_2(_Stack, [_], _N) -> + false; +trace_call_collapse_2(Stack, [_ | S], N) -> + trace_call_collapse_2(Stack, S, N); +trace_call_collapse_2(_Stack, [], _N) -> + false. + + + +trace_return_to(Table, Pid, Func, TS) -> + Stack = get_stack(Pid), + ?dbg(0, "trace_return_to(~p, ~p, ~p)~n~p~n", + [Pid, Func, TS, Stack]), + case Stack of + [[{suspend, _} | _] | _] -> + throw({inconsistent_trace_data, ?MODULE, ?LINE, + [Pid, Func, TS, Stack]}); + [[{garbage_collect, _} | _] | _] -> + throw({inconsistent_trace_data, ?MODULE, ?LINE, + [Pid, Func, TS, Stack]}); + [_ | _] -> + put(Pid, trace_return_to_int(Table, Pid, Func, TS, Stack)); + [] -> + put(Pid, trace_return_to_int(Table, Pid, Func, TS, Stack)) + end, + ok. + +trace_return_to_int(Table, Pid, Func, TS, Stack) -> + %% The old stack must be sent to trace_clock, so + %% the function we just returned from is charged with + %% own time. + trace_clock(Table, Pid, TS, Stack, #clocks.own), + case trace_return_to_2(Table, Pid, Func, TS, Stack) of + {undefined, _} -> + [[{Func, TS}] | Stack]; + {[[{Func, _} | Level0] | Stack1], _} -> + [[{Func, TS} | Level0] | Stack1]; + {NewStack, _} -> + NewStack + end. + +%% A list of charged functions is passed around to assure that +%% any function is charged with ACC time only once - the first time +%% it is encountered. The function trace_return_to_1 is called only +%% for the front of a tail recursive level, and if the front +%% does not match the returned-to function, trace_return_to_2 +%% is called for all functions within the tail recursive level. +%% +%% Charging is done in reverse order, i.e from stack rear to front. + +%% Search the call stack until the returned-to function is found at +%% a tail recursive level's front, and charge it with ACC time. +trace_return_to_1(_, _, undefined, _, []) -> + {[], []}; +trace_return_to_1(_, _, _, _, []) -> + {undefined, []}; +trace_return_to_1(Table, Pid, Func, TS, + [[{Func, _} | Level0] | Stack1] = Stack) -> + %% Match at front of tail recursive level + Charged = trace_return_to_3([Level0 | Stack1], []), + case lists:member(Func, Charged) of + false -> + trace_clock(Table, Pid, TS, Stack, #clocks.acc), + {Stack, [Func | Charged]}; + true -> + {Stack, Charged} + end; +trace_return_to_1(Table, Pid, Func, TS, Stack) -> + trace_return_to_2(Table, Pid, Func, TS, Stack). + +%% Charge all functions within one tail recursive level, +%% from rear to front, with ACC time. +trace_return_to_2(Table, Pid, Func, TS, [] = Stack) -> + trace_return_to_1(Table, Pid, Func, TS, Stack); +trace_return_to_2(Table, Pid, Func, TS, [[] | Stack1]) -> + trace_return_to_1(Table, Pid, Func, TS, Stack1); +trace_return_to_2(Table, Pid, Func, TS, + [[{Func0, _} | Level1] | Stack1] = Stack) -> + case trace_return_to_2(Table, Pid, Func, TS, [Level1 | Stack1]) of + {undefined, _} = R -> + R; + {NewStack, Charged} = R -> + case lists:member(Func0, Charged) of + false -> + trace_clock(Table, Pid, TS, Stack, #clocks.acc), + {NewStack, [Func0 | Charged]}; + true -> + R + end + end. + +%% Return a flat list of all function names in the given stack +trace_return_to_3([], R) -> + R; +trace_return_to_3([[] | Stack1], R) -> + trace_return_to_3(Stack1, R); +trace_return_to_3([[{Func0, _} | Level0] | Stack1], R) -> + trace_return_to_3([Level0 | Stack1], [Func0 | R]). + + + +trace_spawn(Table, Pid, MFArgs, TS, Parent) -> + Stack = get(Pid), + ?dbg(0, "trace_spawn(~p, ~p, ~p, ~p)~n~p~n", + [Pid, MFArgs, TS, Parent, Stack]), + case Stack of + undefined -> + {M,F,Args} = MFArgs, + OldStack = [[{{M,F,length(Args)},TS}]], + put(Pid, trace_call_push(Table, Pid, suspend, TS, OldStack)), + ets:insert(Table, #proc{id = Pid, parent = Parent, + spawned_as = MFArgs}); + _ -> + throw({inconsistent_trace_data, ?MODULE, ?LINE, + [Pid, MFArgs, TS, Parent, Stack]}) + end. + + + +trace_exit(Table, Pid, TS) -> + Stack = erase(Pid), + ?dbg(0, "trace_exit(~p, ~p)~n~p~n", [Pid, TS, Stack]), + case Stack of + undefined -> + ok; + [] -> + ok; + [_ | _] = Stack -> + trace_return_to_int(Table, Pid, undefined, TS, Stack), + ok + end, + ok. + + + +trace_out(Table, Pid, Func, TS) -> + Stack = get_stack(Pid), + ?dbg(0, "trace_out(~p, ~p, ~p)~n~p~n", [Pid, Func, TS, Stack]), + case Stack of + [] -> + put(Pid, trace_call_push(Table, Pid, suspend, TS, + case Func of + undefined -> []; + _ -> + [[{Func,TS}]] + end)); + [[{suspend,_}] | _] -> + %% No stats update for a suspend on suspend + put(Pid, [[{suspend,TS}] | Stack]); + [_ | _] -> + put(Pid, trace_call_push(Table, Pid, suspend, TS, Stack)) + end. + + + +trace_in(Table, Pid, Func, TS) -> + Stack = get(Pid), + ?dbg(0, "trace_in(~p, ~p, ~p)~n~p~n", [Pid, Func, TS, Stack]), + case Stack of + undefined -> + %% First activity on a process which existed at the time + %% the fprof trace was started. + put(Pid, [[{Func,TS}]]); + [] -> + put(Pid, [[{Func,TS}]]); + [[{suspend, _}]] -> + put(Pid, trace_return_to_int(Table, Pid, undefined, TS, Stack)); + [[{suspend,_}] | [[{suspend,_}] | _]=NewStack] -> + %% No stats update for a suspend on suspend + put(Pid, NewStack); + [[{suspend, _}] | [[{Func1, _} | _] | _]] -> + %% This is a new process (suspend and Func1 was inserted + %% by trace_spawn) or any process that has just been + %% scheduled out and now back in. + put(Pid, trace_return_to_int(Table, Pid, Func1, TS, Stack)); + _ -> + throw({inconsistent_trace_data, ?MODULE, ?LINE, + [Pid, Func, TS, Stack]}) + end. + + + +trace_gc_start(Table, Pid, TS) -> + Stack = get_stack(Pid), + ?dbg(0, "trace_gc_start(~p, ~p)~n~p~n", [Pid, TS, Stack]), + put(Pid, trace_call_push(Table, Pid, garbage_collect, TS, Stack)). + + + +trace_gc_end(Table, Pid, TS) -> + Stack = get(Pid), + ?dbg(0, "trace_gc_end(~p, ~p)~n~p~n", [Pid, TS, Stack]), + case Stack of + undefined -> + put(Pid, []); + [] -> + ok; + [[{garbage_collect, _}]] -> + put(Pid, trace_return_to_int(Table, Pid, undefined, TS, Stack)); + [[{garbage_collect, _}], [{Func1, _} | _] | _] -> + put(Pid, trace_return_to_int(Table, Pid, Func1, TS, Stack)); + _ -> + throw({inconsistent_trace_data, ?MODULE, ?LINE, + [Pid, TS, Stack]}) + end. + + + +%%%----------------------------------------- +%%% Statistics calculating support functions +%%%----------------------------------------- + + + +get_stack(Id) -> + case get(Id) of + undefined -> + []; + Stack -> + Stack + end. + + + +mfarity({M, F, Args}) when is_list(Args) -> + {M, F, length(Args)}; +mfarity(MFA) -> + MFA. + + + +init_log(_Table, _Proc, suspend) -> + ok; +init_log(_Table, _Proc, void) -> + ok; +init_log(_Table, undefined, _Entry) -> + ok; +init_log(_Table, #proc{init_cnt = 0}, _Entry) -> + ok; +init_log(Table, #proc{init_cnt = N, init_log = L} = Proc, Entry) -> + ets:insert(Table, Proc#proc{init_cnt = N-1, init_log = [Entry | L]}); +init_log(Table, Id, Entry) -> + Proc = + case ets:lookup(Table, Id) of + [P] -> P; + [] -> undefined + end, + init_log(Table,Proc,Entry). + + +trace_clock(_Table, _Pid, _T, + [[{suspend, _}], [{suspend, _}] | _]=_Stack, _Clock) -> + ?dbg(9, "trace_clock(Table, ~w, ~w, ~w, ~w)~n", + [_Pid, _T, _Stack, _Clock]), + void; +trace_clock(Table, Pid, T, + [[{garbage_collect, TS0}], [{suspend, _}]], Clock) -> + trace_clock_1(Table, Pid, T, TS0, undefined, garbage_collect, Clock); +trace_clock(Table, Pid, T, + [[{garbage_collect, TS0}], [{suspend, _}], [{Func2, _} | _] | _], + Clock) -> + trace_clock_1(Table, Pid, T, TS0, Func2, garbage_collect, Clock); +trace_clock(Table, Pid, T, [[{Func0, TS0}, {Func1, _} | _] | _], Clock) -> + trace_clock_1(Table, Pid, T, TS0, Func1, Func0, Clock); +trace_clock(Table, Pid, T, [[{Func0, TS0}], [{Func1, _} | _] | _], Clock) -> + trace_clock_1(Table, Pid, T, TS0, Func1, Func0, Clock); +trace_clock(Table, Pid, T, [[{Func0, TS0}]], Clock) -> + trace_clock_1(Table, Pid, T, TS0, undefined, Func0, Clock); +trace_clock(_, _, _, [], _) -> + void. + +trace_clock_1(Table, Pid, _, _, Caller, suspend, #clocks.own) -> + clock_add(Table, {Pid, Caller, suspend}, #clocks.own, 0); +trace_clock_1(Table, Pid, T, TS, Caller, Func, Clock) -> + clock_add(Table, {Pid, Caller, Func}, Clock, + if is_integer(T) -> + T; + true -> + ts_sub(T, TS) + end). + +clock_add(Table, Id, Clock, T) -> + ?dbg(1, "clock_add(Table, ~w, ~w, ~w)~n", [Id, Clock, T]), + try ets:update_counter(Table, Id, {Clock, T}) + catch + error:badarg -> + ets:insert(Table, #clocks{id = Id}), + X = ets:update_counter(Table, Id, {Clock, T}), + if X >= 0 -> ok; + true -> ?dbg(0, "Negative counter value ~p ~p ~p ~p~n", + [X, Id, Clock, T]) + end, + X + end. + +clocks_add(Table, #clocks{id = Id} = Clocks) -> + ?dbg(1, "clocks_add(Table, ~w)~n", [Clocks]), + case ets:lookup(Table, Id) of + [Clocks0] -> + ets:insert(Table, clocks_sum(Clocks, Clocks0, Id)); + [] -> + ets:insert(Table, Clocks) + end. + + + +clocks_sum(#clocks{id = _Id1, + cnt = Cnt1, + own = Own1, + acc = Acc1}, + #clocks{id = _Id2, + cnt = Cnt2, + own = Own2, + acc = Acc2}, + Id) -> + #clocks{id = Id, + cnt = Cnt1 + Cnt2, + own = Own1 + Own2, + acc = Acc1 + Acc2}. + + + +ts_sub({A, B, C} = _T, {A0, B0, C0} = _T0) -> + X = ((((A-A0)*1000000) + (B-B0))*1000000) + C - C0, + if X >= 0 -> ok; + true -> ?dbg(9, "Negative counter value ~p ~p ~p~n", + [X, _T, _T0]) + end, + X; +ts_sub(_, _) -> + undefined. + + + +%%%-------------------------------- +%%% Profile data analysis functions +%%%-------------------------------- + + + +do_analyse(Table, Analyse) -> + ?dbg(5, "do_analyse_1(~p, ~p)~n", [Table, Analyse]), + Result = + try do_analyse_1(Table, Analyse) + catch + Error -> Error + end, + ?dbg(5, "do_analyse_1(_, _) ->~p~n", [Result]), + Result. + +do_analyse_1(Table, + #analyse{group_leader = GroupLeader, + dest = Io, + cols = Cols0, + callers = PrintCallers, + sort = Sort, + totals = PrintTotals, + details = PrintDetails} = _Analyse) -> + Waste = 11, + MinCols = Waste + 12, %% We need Width >= 1 + Cols = if Cols0 < MinCols -> MinCols; true -> Cols0 end, + Width = (Cols-Waste) div 12, + FnameWidth = Cols - Waste - 5*Width, + Dest = {Io, [FnameWidth, Width, 2*Width, 2*Width]}, + SortElement = case Sort of + own -> + #clocks.own; + acc -> + #clocks.acc + end, + %% + %% Clean out the process dictionary before the next step + %% + _Erase = erase(), + ?dbg(2, "erase() -> ~p~n", [_Erase]), + %% + %% Process the collected data and spread it to 3 places: + %% * Per {process, caller, func}. Stored in the process dictionary. + %% * Sum per process. Stored in an ets table. + %% * Extra info per process. Stored in another ets table. + %% + io:format(GroupLeader, "Processing data...~n", []), + PidTable = ets:new(?MODULE, [set, private, {keypos, #clocks.id}]), + ProcTable = ets:new(?MODULE, [set, private, {keypos, #proc.id}]), + ets_select_foreach( + Table, [{'_', [], ['$_']}], 100, + fun (#clocks{id = {Pid, Caller, Func}} = Clocks) -> + case PrintDetails of + true -> + funcstat_pd(Pid, Caller, Func, Clocks), + clocks_add(PidTable, Clocks#clocks{id = Pid}); + false -> + ok + end, + clocks_add(PidTable, Clocks#clocks{id = totals}), + case PrintTotals of + true -> + funcstat_pd(totals, Caller, Func, Clocks); + false -> + ok + end; + (#proc{} = Proc) -> + ets:insert(ProcTable, Proc); + (#misc{} = Misc) -> + ets:insert(ProcTable, Misc) + end), + ?dbg(3, "get() -> ~p~n", [get()]), + {FirstTS, LastTS, _TraceCnt} = + case {ets:lookup(ProcTable, first_ts), + ets:lookup(ProcTable, last_ts_n)} of + {[#misc{data = FTS}], [#misc{data = {LTS, TC}}]} + when FTS =/= undefined, LTS =/= undefined -> + {FTS, LTS, TC}; + _ -> + throw({error,empty_trace}) + end, + Totals0 = + case ets:lookup(PidTable, totals) of + [T0] -> + ets:delete(PidTable, totals), + T0; + _ -> + throw({error,empty_trace}) + end, + Totals = Totals0#clocks{acc = ts_sub(LastTS, FirstTS)}, + ?dbg(3, "Totals0 = ~p~n", [Totals0]), + ?dbg(3, "PidTable = ~p~n", [ets:tab2list(PidTable)]), + ?dbg(3, "ProcTable = ~p~n", [ets:tab2list(ProcTable)]), + ?dbg(4, "Totals = ~p~n", [Totals]), + %% + %% Reorganize the process dictionary by Pid. + %% + lists:foreach( + fun ({{Pid, _Func}, Funcstat}) -> + put(Pid, [Funcstat | case get(Pid) of + undefined -> []; + Other -> Other + end]) + end, + erase()), + ?dbg(4, "get() -> ~p~n", [get()]), + %% + %% Sort the processes + %% + PidSorted = + postsort_r( + lists:sort( + ets:select(PidTable, + [{'_', [], [[{element, #clocks.own, '$_'} | '$_']]}]))), + ?dbg(4, "PidSorted = ~p~n", [PidSorted]), + %% + %% Print the functions per process + %% + io:format(GroupLeader, "Creating output...~n", []), + println(Dest, "%% ", [], "Analysis results:", ""), + println(Dest, "{ ", analysis_options, ",", ""), + println(Dest, " [{", {callers, PrintCallers}, "},", ""), + println(Dest, " {", {sort, Sort}, "},", ""), + println(Dest, " {", {totals, PrintTotals}, "},", ""), + println(Dest, " {", {details, PrintDetails}, "}]}.", ""), + println(Dest), + lists:foreach( + fun ({#clocks{} = Clocks, ProcOrPid, FuncstatList}) -> + println(Dest, "% ", head, "", ""), + case ProcOrPid of + #proc{} -> + println(Dest, "[{ ", Clocks, "},", "%%"), + print_proc(Dest, ProcOrPid); + totals -> + println(Dest, "[{ ", Clocks, "}].", "%%%"); + _ when is_pid(ProcOrPid) -> + println(Dest, "[{ ", Clocks, "}].", "%%") + end, + println(Dest), + lists:foreach( + fun (#funcstat{callers_sum = CallersSum, +% called_sum = CalledSum, + callers = Callers, + called = Called}) -> + case {PrintCallers, Callers} of +% {true, []} -> +% ok; + {true, _} -> + print_callers(Dest, Callers), + println(Dest, " { ", CallersSum, "},", "%"), + print_called(Dest, Called), + println(Dest); + {false, _} -> + println(Dest, "{ ", CallersSum, "}.", "") + end, + ok + end, + %% Sort the functions within the process, + %% and the callers and called within the function. + funcstat_sort_r(FuncstatList, SortElement)), + println(Dest) + end, + %% Look up the processes in sorted order + lists:map( + fun (#clocks{id = Pid} = Clocks) -> + Proc = case ets:lookup(ProcTable, Pid) of + [] -> Pid; + [ProcX] -> ProcX + end, + FuncstatList = + case get(Pid) of + undefined -> + []; + FL -> + FL + end, + {Clocks, Proc, FuncstatList} + end, + case PrintDetails of + true -> + [Totals | PidSorted]; + false -> + [Totals] + end)), + %% + %% Cleanup + %% + ets:delete(PidTable), + ets:delete(ProcTable), + io:format(GroupLeader, "Done!~n", []), + ok. + + + +%%---------------------------- +%% Analysis printout functions +%%---------------------------- + + + +print_proc({undefined, _}, _) -> + ok; +print_proc(Dest, + #proc{id = _Pid, + parent = Parent, + spawned_as = SpawnedAs, + init_log = InitLog}) -> + case {Parent, SpawnedAs, InitLog} of + {undefined, undefined, []} -> + println(Dest, " ", [], "].", ""); + {_, undefined, []} -> + println(Dest, " { ", {spawned_by, parsify(Parent)}, "}].", ""); + _ -> + println(Dest, " { ", {spawned_by, parsify(Parent)}, "},", ""), + case {SpawnedAs, InitLog} of + {_, []} -> + println(Dest, " { ", + {spawned_as, SpawnedAs}, + "}].", ""); + {undefined, _} -> + println(Dest, " { ", + {initial_calls, lists:reverse(InitLog)}, + "}].", ""); + _ -> + println(Dest, " { ", + {spawned_as, SpawnedAs}, + "},", ""), + println(Dest, " { ", + {initial_calls, lists:reverse(InitLog)}, + "}].", "") + end + end. + + + +print_callers(Dest, []) -> + println(Dest, "{[", [], "],", ""); +print_callers(Dest, [Clocks]) -> + println(Dest, "{[{", Clocks, "}],", ""); +print_callers(Dest, [Clocks | Tail]) -> + println(Dest, "{[{", Clocks, "},", ""), + print_callers_1(Dest, Tail). + +print_callers_1(Dest, [Clocks]) -> + println(Dest, " {", Clocks, "}],", ""); +print_callers_1(Dest, [Clocks | Tail]) -> + println(Dest, " {", Clocks, "},", ""), + print_callers_1(Dest, Tail). + + + +print_func(Dest, Clocks) -> + println(Dest, " { ", Clocks, "},", "%"). + + + +print_called(Dest, []) -> + println(Dest, " [", [], "]}.", ""); +print_called(Dest, [Clocks]) -> + println(Dest, " [{", Clocks, "}]}.", ""); +print_called(Dest, [Clocks | Tail]) -> + println(Dest, " [{", Clocks, "},", ""), + print_called_1(Dest, Tail). + +print_called_1(Dest, [Clocks]) -> + println(Dest, " {", Clocks, "}]}.", ""); +print_called_1(Dest, [Clocks | Tail]) -> + println(Dest, " {", Clocks, "},", ""), + print_called_1(Dest, Tail). + + + +println({undefined, _}) -> + ok; +println({Io, _}) -> + io:nl(Io). + +println({undefined, _}, _Head, + _, + _Tail, _Comment) -> + ok; +println({Io, [W1, W2, W3, W4]}, Head, + #clocks{id = Pid, cnt = Cnt, acc = _, own = Own}, + Tail, Comment) when is_pid(Pid) -> + io:put_chars(Io, + [pad(Head, $ , 3), + flat_format(parsify(Pid), $,, W1), + flat_format(Cnt, $,, W2, right), + flat_format(undefined, $,, W3, right), + flat_format(Own*0.001, [], W4-1, right), + pad(Tail, $ , 4), + pad($ , Comment, 4), + io_lib:nl()]); +println({Io, [W1, W2, W3, W4]}, Head, + #clocks{id = {_M, _F, _A} = Func, cnt = Cnt, acc = Acc, own = Own}, + Tail, Comment) -> + io:put_chars(Io, + [pad(Head, $ , 3), + flat_format(Func, $,, W1), + flat_format(Cnt, $,, W2, right), + flat_format(Acc*0.001, $,, W3, right), + flat_format(Own*0.001, [], W4-1, right), + pad(Tail, $ , 4), + pad($ , Comment, 4), + io_lib:nl()]); +println({Io, [W1, W2, W3, W4]}, Head, + #clocks{id = Id, cnt = Cnt, acc = Acc, own = Own}, + Tail, Comment) -> + io:put_chars(Io, + [pad(Head, $ , 3), + flat_format(parsify(Id), $,, W1), + flat_format(Cnt, $,, W2, right), + flat_format(Acc*0.001, $,, W3, right), + flat_format(Own*0.001, [], W4-1, right), + pad(Tail, $ , 4), + pad($ , Comment, 4), + io_lib:nl()]); +println({Io, [W1, W2, W3, W4]}, Head, + head, + Tail, Comment) -> + io:put_chars(Io, + [pad(Head, $ , 3), + pad(" ", $ , W1), + pad($ , " CNT ", W2), + pad($ , " ACC ", W3), + pad($ , " OWN", W4-1), + pad(Tail, $ , 4), + pad($ , Comment, 4), + io_lib:nl()]); +println({Io, _}, Head, + [], + Tail, Comment) -> + io:format(Io, "~s~s~s~n", + [pad(Head, $ , 3), Tail, Comment]); +println({Io, _}, Head, + {Tag, Term}, + Tail, Comment) -> + io:format(Io, "~s~p, ~p~s~s~n", + [pad(Head, $ , 3), parsify(Tag), parsify(Term), Tail, Comment]); +println({Io, _}, Head, + Term, + Tail, Comment) -> + io:format(Io, "~s~p~s~s~n", + [pad(Head, $ , 3), parsify(Term), Tail, Comment]). + + + +%%%-------------------------- +%%% Sorting support functions +%%%-------------------------- + + +%% Add a Clocks record to the callers and called funcstat records +%% in the process dictionary. +%% +funcstat_pd(Pid, Func1, Func0, Clocks) -> + put({Pid, Func0}, + case get({Pid, Func0}) of + undefined -> + #funcstat{callers_sum = Clocks#clocks{id = Func0}, + called_sum = #clocks{id = Func0}, + callers = [Clocks#clocks{id = Func1}]}; + #funcstat{callers_sum = CallersSum, + callers = Callers} = FuncstatCallers -> + FuncstatCallers#funcstat{ + callers_sum = clocks_sum(CallersSum, Clocks, Func0), + callers = [Clocks#clocks{id = Func1} | Callers]} + end), + put({Pid, Func1}, + case get({Pid, Func1}) of + undefined -> + #funcstat{callers_sum = #clocks{id = Func1}, + called_sum = Clocks#clocks{id = Func1}, + called = [Clocks#clocks{id = Func0}]}; + #funcstat{called_sum = CalledSum, + called = Called} = FuncstatCalled -> + FuncstatCalled#funcstat{ + called_sum = clocks_sum(CalledSum, Clocks, Func1), + called = [Clocks#clocks{id = Func0} | Called]} + end). + + + +%% Sort a list of funcstat records, +%% and sort the callers and called lists within the funcstat record. +funcstat_sort_r(FuncstatList, Element) -> + funcstat_sort_r_1(FuncstatList, Element, []). + +funcstat_sort_r_1([], _, R) -> + postsort_r(lists:sort(R)); +funcstat_sort_r_1([#funcstat{callers_sum = #clocks{} = Clocks, + callers = Callers, + called = Called} = Funcstat + | L], + Element, + R) -> + funcstat_sort_r_1(L, + Element, + [[element(Element, Clocks) + |Funcstat#funcstat{ + callers = clocks_sort_r(Callers, Element), + called = clocks_sort_r(Called, Element)}] + | R]). + + + +%% Sort a list of clocks records. +clocks_sort_r(L, E) -> + clocks_sort_r_1(L, E, []). + +clocks_sort_r_1([], _, R) -> + postsort_r(lists:sort(R)); +clocks_sort_r_1([#clocks{} = C | L], E, R) -> + clocks_sort_r_1(L, E, [[element(E, C)|C] | R]). + + +%% Take a list of terms with sort headers and strip the headers. +postsort_r(L) -> + postsort_r(L, []). + +postsort_r([], R) -> + R; +postsort_r([[_|C] | L], R) -> + postsort_r(L, [C | R]). + + + +%%%---------------------------------------------------------------------- +%%% Fairly generic support functions +%%% + +%% Standard format and flatten. +flat_format(F, Trailer) when is_float(F) -> + lists:flatten([io_lib:format("~.3f", [F]), Trailer]); +flat_format(W, Trailer) -> + lists:flatten([io_lib:format("~p", [W]), Trailer]). + +%% Format, flatten, and pad. +flat_format(Term, Trailer, Width) -> + flat_format(Term, Trailer, Width, left). + +flat_format(Term, Trailer, Width, left) -> + flat_format(Term, Trailer, Width, {left, $ }); +flat_format(Term, Trailer, Width, {left, Filler}) -> + pad(flat_format(Term, Trailer), Filler, Width); +flat_format(Term, Trailer, Width, right) -> + flat_format(Term, Trailer, Width, {right, $ }); +flat_format(Term, Trailer, Width, {right, Filler}) -> + pad(Filler, flat_format(Term, Trailer), Width). + + + +%% Left pad a string using a given char. +pad(Char, L, Size) when is_integer(Char), is_list(L), is_integer(Size) -> + List = lists:flatten(L), + Length = length(List), + if Length >= Size -> + List; + true -> + lists:append(lists:duplicate(Size - Length, Char), List) + end; +%% Right pad a string using a given char. +pad(L, Char, Size) when is_list(L), is_integer(Char), is_integer(Size) -> + List = lists:flatten(L), + Length = length(List), + if Length >= Size -> + List; + true -> + lists:append(List, lists:duplicate(Size - Length, Char)) + end. + + + +ets_select_foreach(Table, MatchSpec, Limit, Fun) -> + ets:safe_fixtable(Table, true), + ets_select_foreach_1(ets:select(Table, MatchSpec, Limit), Fun). + +ets_select_foreach_1('$end_of_table', _) -> + ok; +ets_select_foreach_1({Matches, Continuation}, Fun) -> + ?dbg(2, "Matches = ~p~n", [Matches]), + lists:foreach(Fun, Matches), + ets_select_foreach_1(ets:select(Continuation), Fun). + + + +%% Converts the parts of a deep term that are not parasable when printed +%% with io:format() into their string representation. +parsify([]) -> + []; +parsify([Hd | Tl]) -> + [parsify(Hd) | parsify(Tl)]; +parsify({A, B}) -> + {parsify(A), parsify(B)}; +parsify({A, B, C}) -> + {parsify(A), parsify(B), parsify(C)}; +parsify(Tuple) when is_tuple(Tuple) -> + list_to_tuple(parsify(tuple_to_list(Tuple))); +parsify(Pid) when is_pid(Pid) -> + erlang:pid_to_list(Pid); +parsify(Port) when is_port(Port) -> + erlang:port_to_list(Port); +parsify(Ref) when is_reference(Ref) -> + erlang:ref_to_list(Ref); +parsify(Fun) when is_function(Fun) -> + erlang:fun_to_list(Fun); +parsify(Term) -> + Term. + + + +%% A simple loop construct. +%% +%% Calls 'Fun' with argument 'Start' first and then repeatedly with +%% its returned value (state) until 'Fun' returns 'Stop'. Then +%% the last state value that was not 'Stop' is returned. + +% iterate(Start, Done, Fun) when is_function(Fun) -> +% iterate(Start, Done, Fun, Start). + +% iterate(Done, Done, Fun, I) -> +% I; +% iterate(I, Done, Fun, _) -> +% iterate(Fun(I), Done, Fun, I). |