[m-rev.] for review: make the deep profiler work again

[Zoltan Somogyi]

On 14-Nov-2002, Zoltan Somogyi <zs at cs.mu.OZ.AU> wrote:
> Make the deep profiler work again.

The diffs of mdprof_cgi.m and timeout.m may be hard to read, since
mdprof_cgi.m was totally rewritten and timeout.m was partially rewritten.
I therefore enclose their new contents.

Zoltan.

::::::::::::::
mdprof_cgi.m
::::::::::::::
%-----------------------------------------------------------------------------%
% Copyright (C) 2001-2002 The University of Melbourne.
% This file may only be copied under the terms of the GNU General
% Public License - see the file COPYING in the Mercury distribution.
%-----------------------------------------------------------------------------%
%
% Author of initial version: conway.
% Author of this version: zs.
%
% This file contains the CGI "script" that is executed by the web server
% to handle web page requests implemented by the Mercury deep profiler server.

:- module mdprof_cgi.

:- interface.

:- import_module io.

:- pred main(io__state::di, io__state::uo) is cc_multi.

:- implementation.

:- import_module profile, interface, startup, query, conf, timeout, util.
:- import_module bool, char, string, int, array, list, set.
:- import_module require, std_util, getopt.

:- import_module int, string, list, array, map, exception, require.

% The web server should always set QUERY_STRING. It may also pass its contents
% as arguments, but if any characters specials to the shell occur in the query,
% they will screw up the argument list. We therefore look at the argument list
% only if QUERY_STRING isn't set, which means that the program was invoked
% from the command line for debugging.

main -->
	write_html_header,
	io__get_environment_var("QUERY_STRING", MaybeQueryString),
	(
		{ MaybeQueryString = yes(QueryString0) },
		{ getopt__process_options(option_ops(short, long, defaults),
			[], _, MaybeOptions) },
		{
			MaybeOptions = ok(Options)
		;
			MaybeOptions = error(_Msg),
			error("mdprof_cgi: error parsing empty command line")
		},
		{ split(QueryString0, query_separator_char, Pieces) },
		( { Pieces = [CmdStr, PrefStr, FileName] } ->
			{ Cmd = url_component_to_cmd(CmdStr, menu) },
			process_query(Cmd, yes(PrefStr), FileName,
				Options)
		; { Pieces = [CmdStr, FileName] } ->
			{ Cmd = url_component_to_cmd(CmdStr, menu) },
			process_query(Cmd, no, FileName, Options)
		; { Pieces = [FileName] } ->
			process_query(menu, no, FileName, Options)
		;
			io__set_exit_status(1),
			% Give the simplest URL in the error message.
			io__write_string("Bad URL; expected filename\n")
		)
	;
		{ MaybeQueryString = no },
		process_command_line
	).


:- pred process_command_line(io__state::di, io__state::uo) is cc_multi.

process_command_line -->
	io__progname_base("mdprof_cgi", ProgName),
	io__command_line_arguments(Args0),
	% io__write_string("Args0: "),
	% io__write_list(Args0, " ", write_bracketed_string),
	% io__nl,
	{ getopt__process_options(option_ops(short, long, defaults),
		Args0, Args, MaybeOptions) },
	(
		{ MaybeOptions = ok(Options) },
		process_args(Args, Options)
	;
		{ MaybeOptions = error(Msg) },
		io__set_exit_status(1),
		io__format("%s: error parsing options: %s\n",
			[s(ProgName), s(Msg)])
	).

:- pred process_args(list(string)::in, option_table::in,
	io__state::di, io__state::uo) is cc_multi.

process_args(Args, Options) -->
	( { Args = [FileName] } ->
		% Although this mode of usage is not intended for production
		% use, allowing the filename and a limited range of commands
		% to be supplied on the command line makes debugging very much
		% easier.
		process_query(default_cmd(Options), no, FileName, Options)
	;
		io__set_exit_status(1),
		% The options are deliberately not documented; they change
		% quite rapidly, based on the debugging needs of the moment.
		io__write_string("Usage: mdprof_cgi [filename]\n"),
		io__write_list(Args, " ", write_bracketed_string)
	).

:- pred write_bracketed_string(string::in, io__state::di, io__state::uo)
	is det.

write_bracketed_string(S) -->
	io__write_string("<"),
	io__write_string(S),
	io__write_string(">").

:- pred write_html_header(io__state::di, io__state::uo) is det.

write_html_header -->
	io__write_string(html_header_text),
	io__flush_output.

:- func html_header_text = string.

html_header_text = "Content-type: text/html\n\n".

%-----------------------------------------------------------------------------%

:- pred process_query(cmd::in, maybe(string)::in, string::in,
	option_table::in, io__state::di, io__state::uo) is cc_multi.

process_query(Cmd, MaybePrefStr, DataFileName, Options) -->
	{
		MaybePrefStr = yes(PrefStr),
		MaybePref = url_component_to_maybe_pref(PrefStr)
	;
		MaybePrefStr = no,
		MaybePref = no
	},
	{
		MaybePref = yes(Pref)
	;
		MaybePref = no,
		Pref = default_preferences
	},
	{ ToServerPipe = to_server_pipe_name(DataFileName) },
	{ FromServerPipe = from_server_pipe_name(DataFileName) },
	{ StartupFile = server_startup_name(DataFileName) },
	{ MutexFile = mutex_file_name(DataFileName) },
	{ lookup_bool_option(Options, debug, Debug) },
	{ WantFile = want_file_name },
	make_want_file(WantFile),
	get_lock(Debug, MutexFile),
	(
		{ Debug = yes }
		% Do not set up any cleanups; leave all files around,
		% since they may be needed for postmortem examination.
	;
		{ Debug = no },
		setup_signals(MutexFile, want_dir, want_prefix)
	),
	check_for_existing_fifos(ToServerPipe, FromServerPipe, FifoCount),
	( { FifoCount = 0 } ->
		handle_query_from_new_server(Cmd, Pref, DataFileName,
			ToServerPipe, FromServerPipe, StartupFile,
			MutexFile, WantFile, Options)
	; { FifoCount = 2 } ->
		handle_query_from_existing_server(Cmd, Pref,
			ToServerPipe, FromServerPipe,
			MutexFile, WantFile, Options)
	;
		release_lock(Debug, MutexFile),
		remove_want_file(WantFile),
		io__set_exit_status(1),
		io__write_string("mdprof internal error: bad fifo count")
	).

% Handle the given query using the existing server. Delete the mutex and want
% files when we get out of the critical region.

:- pred handle_query_from_existing_server(cmd::in, preferences::in,
	string::in, string::in, string::in, string::in, option_table::in,
	io__state::di, io__state::uo) is det.

handle_query_from_existing_server(Cmd, Pref, ToServerPipe, FromServerPipe,
		MutexFile, WantFile, Options) -->
	{ lookup_bool_option(Options, debug, Debug) },
	send_term(ToServerPipe, Debug, cmd_pref(Cmd, Pref)),
	release_lock(Debug, MutexFile),
	remove_want_file(WantFile),
	recv_string(FromServerPipe, Debug, ResponseFileName),
	{ CatCmd = string__format("cat %s", [s(ResponseFileName)]) },
	io__call_system(CatCmd, _),
	(
		{ Debug = yes }
		% Leave the response file to be examined.
	;
		{ Debug = no },
		{ RmCmd = string__format("rm %s", [s(ResponseFileName)]) },
		io__call_system(RmCmd, _)
	).

% Handle the given query and then become the new server. Delete the mutex
% and want files when we get out of the critical region.

:- pred handle_query_from_new_server(cmd::in, preferences::in, string::in,
	string::in, string::in, string::in, string::in, string::in,
	option_table::in, io__state::di, io__state::uo) is cc_multi.

handle_query_from_new_server(Cmd, Pref, FileName, ToServerPipe, FromServerPipe,
		StartupFile, MutexFile, WantFile, Options) -->
	server_name(Machine),
	{ lookup_bool_option(Options, canonical_clique, Canonical) },
	{ lookup_bool_option(Options, server_process, ServerProcess) },
	{ lookup_bool_option(Options, debug, Debug) },
	{ lookup_bool_option(Options, record_startup, RecordStartup) },
	( 
		{ RecordStartup = yes },
		io__open_output(StartupFile, StartupStreamRes),
		(
			{ StartupStreamRes = ok(StartupStream0) },
			{ MaybeStartupStream = yes(StartupStream0) },
			register_file_for_cleanup(StartupFile)
		;
			{ StartupStreamRes = error(_) },
			{ error("cannot create startup file") }
		)
	;
		{ RecordStartup = no },
		{ MaybeStartupStream = no }
	),
	read_and_startup(Machine, [FileName], Canonical, MaybeStartupStream,
		Res),
	(
		{ Res = ok(Deep) },
		try_exec(Cmd, Pref, Deep, HTML),
		(
			{ MaybeStartupStream = yes(StartupStream1) },
			io__format(StartupStream1, "query 0 output:\n%s\n",
				[s(HTML)]),
			% If we don't flush the output before the fork, it will
			% be flushed twice, once by the parent process and
			% once by the child process.
			io__flush_output(StartupStream1)
		;
			{ MaybeStartupStream = no }
		),
		(
			{ ServerProcess = no },
			% --no-server process should be specified only during
			% debugging.
			release_lock(Debug, MutexFile),
			remove_want_file(WantFile),
			io__write_string(HTML)
		;
			{ ServerProcess = yes },
			make_pipes(FileName, Success),
			(
				{ Success = yes },
				io__write_string(HTML),
				io__flush_output,
				start_server(Options,
					ToServerPipe, FromServerPipe,
					MaybeStartupStream,
					MutexFile, WantFile, Deep)
			;
				{ Success = no },
				release_lock(Debug, MutexFile),
				remove_want_file(WantFile),
				io__set_exit_status(1),
				io__write_string("could not make pipes\n")
			)
		)
	;
		{ Res = error(Error) },
		release_lock(Debug, MutexFile),
		remove_want_file(WantFile),
		io__set_exit_status(1),
		io__format("error reading data file: %s\n", [s(Error)])
	).

% Become the new server. Delete the mutex and want files when we get out
% of the critical region.

:- pred start_server(option_table::in, string::in, string::in,
	maybe(io__output_stream)::in, string::in, string::in, deep::in,
	io__state::di, io__state::uo) is cc_multi.

start_server(Options, ToServerPipe, FromServerPipe, MaybeStartupStream,
		MutexFile, WantFile, Deep) -->
	{ lookup_bool_option(Options, detach_process, DetachProcess) },
	{ lookup_bool_option(Options, record_loop, RecordLoop) },
	{ lookup_bool_option(Options, debug, Debug) },
	(
		{ DetachProcess = no },
		% We behave as if we were in the child, to allow the server
		% loop to be debugged.
		{ DetachRes = in_child(child_has_no_parent) }
	;
		{ DetachProcess = yes },
		detach_process(DetachRes)
	),
	(
		{ DetachRes = in_child(ChildHasParent) } ->
		% We are in the child; start serving queries.
		(
			{ ChildHasParent = child_has_parent },
			% Our parent process will perform the file removals
			% needed to exit the critical section; we don't
			% want to duplicate them. We also don't want to delete
			% the pipes we need or the startup file.
			unregister_file_for_cleanup(MutexFile),
			unregister_file_for_cleanup(WantFile)
		;
			{ ChildHasParent = child_has_no_parent },
			% We don't actually have a parent process, so we need
			% to perform the file removals needed to exit the
			% critical section ourselves.
			release_lock(Debug, MutexFile),
			remove_want_file(WantFile)
		),
		(
			{ RecordLoop = yes },
			{ MaybeDebugStream = MaybeStartupStream }
		;
			{ RecordLoop = no },
			{ MaybeDebugStream = no }
		),
		{ lookup_int_option(Options, timeout, TimeOut) },
		{ lookup_bool_option(Options, canonical_clique, Canonical) },
		server_loop(ToServerPipe, FromServerPipe, TimeOut,
			MaybeDebugStream, Debug, Canonical, 0, Deep)
	;
		{ DetachRes = in_parent } ->
		% We are in the parent after we spawned the child. We cause
		% the process to exit simply by not calling server_loop.
		% 
		% We leave the pipes and the startup file; we clean up only
		% the files involved in the critical section.
		release_lock(Debug, MutexFile),
		remove_want_file(WantFile)
	;
		% We are in the parent because the fork failed. Again we cause
		% the process to exit simply by not calling server_loop, but we
		% also report the failure through the exit status. We don't
		% report it via the generated web page, since the cause could
		% be transitory and may not recur.
		%
		% This deletes all the files created by the process, including
		% WantFile and MutexFile, with MutexFile being deleted last.
		delete_cleanup_files,
		io__set_exit_status(1)
	).

:- pred server_loop(string::in, string::in, int::in,
	maybe(io__output_stream)::in, bool::in, bool::in, int::in, deep::in,
	io__state::di, io__state::uo) is cc_multi.

server_loop(ToServerPipe, FromServerPipe, TimeOut0, MaybeStartupStream,
		Debug, Canonical, QueryNum0, Deep0) -->
	setup_timeout(TimeOut0),
	{ QueryNum = QueryNum0 + 1 },
	recv_term(ToServerPipe, Debug, CmdPref0),
	(
		{ MaybeStartupStream = yes(StartupStream0) },
		io__format(StartupStream0, "server loop query %d\n",
			[i(QueryNum)]),
		io__write(StartupStream0, CmdPref0),
		io__nl(StartupStream0),
		io__flush_output(StartupStream0)
	;
		{ MaybeStartupStream = no }
	),
	{ CmdPref0 = cmd_pref(Cmd0, Pref0) },
	( { Cmd0 = restart } ->
		read_and_startup(Deep0 ^ server_name, [Deep0 ^ data_file_name],
			Canonical, MaybeStartupStream, MaybeDeep),
		(
			{ MaybeDeep = ok(Deep) },
			{ MaybeMsg = no },
			{ Cmd = menu }
		;
			{ MaybeDeep = error(ErrorMsg) },
			{ MaybeMsg = yes(ErrorMsg) },
			{ Deep = Deep0 },
			{ Cmd = quit }
		)
	;
		{ Deep = Deep0 },
		{ MaybeMsg = no },
		{ Cmd = Cmd0 }
	),
	(
		{ MaybeMsg = yes(HTML) }
	;
		{ MaybeMsg = no },
		try_exec(Cmd, Pref0, Deep, HTML)
	),

	{ ResponseFileName =
		response_file_name(Deep0 ^ data_file_name, QueryNum) },
	io__open_output(ResponseFileName, ResponseRes),
	(
		{ ResponseRes = ok(ResponseStream) }
	;
		{ ResponseRes = error(_) },
		{ error("cannot open response file") }
	),
	io__write_string(ResponseStream, HTML),
	io__close_output(ResponseStream),

	send_string(FromServerPipe, Debug, ResponseFileName),

	(
		{ MaybeStartupStream = yes(StartupStream1) },
		io__format(StartupStream1, "query %d output:\n%s\n",
			[i(QueryNum), s(HTML)]),
		io__flush_output(StartupStream1)
	;
		{ MaybeStartupStream = no }
	),

	( { Cmd = quit } ->
		% The lack of a recursive call here shuts down the server.
		%
		% This deletes all the files created by the process, including
		% WantFile and MutexFile, with MutexFile being deleted last.
		delete_cleanup_files
	; { Cmd = timeout(TimeOut) } ->
		server_loop(ToServerPipe, FromServerPipe, TimeOut,
			MaybeStartupStream, Debug, Canonical, QueryNum, Deep)
	;
		server_loop(ToServerPipe, FromServerPipe, TimeOut0,
			MaybeStartupStream, Debug, Canonical, QueryNum, Deep)
	).

%-----------------------------------------------------------------------------%

:- pred make_pipes(string::in, bool::out, io__state::di, io__state::uo) is det.

make_pipes(FileName, Success) -->
	{ ToServerPipe = to_server_pipe_name(FileName) },
	{ FromServerPipe = from_server_pipe_name(FileName) },
	{ MakeToServerPipeCmd = make_pipe_cmd(ToServerPipe) },
	{ MakeFromServerPipeCmd = make_pipe_cmd(FromServerPipe) },
	io__call_system(MakeToServerPipeCmd, ToServerRes),
	io__call_system(MakeFromServerPipeCmd, FromServerRes),
	(
		{ ToServerRes = ok(0) },
		{ FromServerRes = ok(0) }
	->
		register_file_for_cleanup(ToServerPipe),
		register_file_for_cleanup(FromServerPipe),
		{ Success = yes }
	;
		% In case one of the pipes was created.
		io__remove_file(ToServerPipe, _),
		io__remove_file(FromServerPipe, _),
		{ Success = no }
	).

%-----------------------------------------------------------------------------%

:- pragma foreign_decl("C", "
#include <sys/types.h>
#include <sys/stat.h>
#include <unistd.h>
").

:- pragma foreign_decl("C", "
#include <stdio.h>
#include <stdlib.h>
#include <unistd.h>
#include <sys/types.h>
#include <sys/stat.h>
#include <fcntl.h>
").

:- pred check_for_existing_fifos(string::in, string::in, int::out,
	io__state::di, io__state::uo) is det.

:- pragma foreign_proc("C",
	check_for_existing_fifos(Fifo1::in, Fifo2::in, FifoCount::out,
		S0::di, S::uo),
	[will_not_call_mercury, promise_pure, tabled_for_io],
"
	struct stat	statbuf;
	int		status;

	FifoCount = 0;
	status = stat(Fifo1, &statbuf);
	if ((status == 0) && (S_ISFIFO(statbuf.st_mode))) {
		FifoCount++;
	}
	status = stat(Fifo2, &statbuf);
	if ((status == 0) && (S_ISFIFO(statbuf.st_mode))) {
		FifoCount++;
	}

	S = S0;
").

:- type child_has_parent
	--->	child_has_parent
	;	child_has_no_parent.

:- type detach_process_result
	--->	in_child(child_has_parent)
	;	in_parent
	;	fork_failed.

:- pred detach_process(detach_process_result::out,
	io__state::di, io__state::uo) is cc_multi.

detach_process(Result) -->
	raw_detach_process(ResCode),
	{ ResCode < 0 ->
		Result = fork_failed
	; ResCode > 0 ->
		Result = in_parent
	;
		Result = in_child(child_has_parent)
	}.

% Raw_detach_process performs a fork.
%
% If the fork succeeds, the result returned by detach_process is:
%
% - a positive number in the parent, and
% - zero in the child.
%
% If the fork fails, the result returned by detach_process is:
%
% - a negative number in the parent (there is no child process).

:- pred raw_detach_process(int::out, io__state::di, io__state::uo) is cc_multi.

:- pragma foreign_proc("C",
	raw_detach_process(ResCode::out, S0::di, S::uo),
	[will_not_call_mercury, promise_pure],
"{
	pid_t	status;

	fflush(stdout);
	fflush(stderr);
	status = fork();
	if (status < 0) {
		ResCode = -1;
	} else if (status > 0) {
		ResCode = 1;
	} else {
#ifdef	MR_HAVE_SETPGID
		/* detach the server process from the parent's process group */
		setpgid(0, 0);
#else
		/* hope that web server doesn't depend on the process group */
#endif
		ResCode = 0;
	}

	S = S0;
}").

%-----------------------------------------------------------------------------%

:- type option
	--->	canonical_clique
	;	clique
	;	debug
	;	detach_process
	;	modules
	;	proc
	;	quit
	;	root
	;	record_startup
	;	record_loop
	;	server_process
	;	timeout
	;	write_query_string.

:- type options ---> options.
:- type option_table == (option_table(option)).

:- pred short(char::in, option::out) is semidet.

short('c',	canonical_clique).
short('C',	clique).
short('d',	debug).
short('m',	modules).
short('p',	proc).
short('q',	quit).
short('r',	root).
short('s',	server_process).
short('t',	timeout).
short('w',	write_query_string).

:- pred long(string::in, option::out) is semidet.

long("canonical-clique",	canonical_clique).
long("clique",			clique).
long("debug",			debug).
long("detach-process",		detach_process).
long("modules",			modules).
long("proc",			proc).
long("quit",			quit).
long("root",			root).
long("record-startup",		record_startup).
long("record-loop",		record_loop).
long("server-process",		server_process).
long("timeout",			timeout).
long("write-query-string",	write_query_string).

:- pred defaults(option::out, option_data::out) is nondet.

defaults(Option, Data) :-
	semidet_succeed,
	defaults0(Option, Data).

:- pred defaults0(option::out, option_data::out) is multi.

defaults0(canonical_clique,	bool(no)).
defaults0(clique,		int(0)).
defaults0(debug,		bool(no)).
defaults0(detach_process,	bool(yes)).
defaults0(modules,		bool(no)).
defaults0(proc,			int(0)).
defaults0(quit,			bool(no)).
defaults0(root,			bool(no)).
defaults0(record_loop,		bool(yes)).
defaults0(record_startup,	bool(yes)).
defaults0(server_process,	bool(yes)).
defaults0(timeout,		int(30)).
defaults0(write_query_string,	bool(yes)).

:- func default_cmd(option_table) = cmd.

default_cmd(Options) = Cmd :-
	lookup_bool_option(Options, quit, Quit),
	lookup_bool_option(Options, root, Root),
	lookup_bool_option(Options, modules, Modules),
	lookup_int_option(Options, clique, CliqueNum),
	lookup_int_option(Options, proc, ProcNum),
	( Root = yes ->
		Cmd = root(no)
	; Modules = yes ->
		Cmd = modules
	; CliqueNum > 0 ->
		Cmd = clique(CliqueNum)
	; ProcNum > 0 ->
		Cmd = proc(ProcNum)
	; Quit = yes ->
		Cmd = quit
	;
		Cmd = menu
	).

%-----------------------------------------------------------------------------%
::::::::::::::
timeout.m
::::::::::::::
%-----------------------------------------------------------------------------%
% Copyright (C) 2001-2002 The University of Melbourne.
% This file may only be copied under the terms of the GNU General
% Public License - see the file COPYING in the Mercury distribution.
%-----------------------------------------------------------------------------%
%
% Author: zs.
%
% This module implements timeouts and cleanup for the deep profiler.
%
% The timeout design we use and its rationale are given in the file DESIGN.
%
% The cleanup system consists of an array of filenames. When the profiler
% creates a temporary file, it adds its name to the array; when it deletes
% the temporary file, it deletes its name from the array. When we get an
% unexpected signal, we clean up by deleting all the temporary files named
% in the array. The 
%
% We establish the exit action to clean up the files as soon as they are
% created, but we don't want the parent process after the fork to delete them
% while they are still in use by the child process. This is prevented by the
% boolean flag process_is_detached_server.

:- module timeout.

:- interface.

:- import_module bool, io.

% Add the given file name to the list of files to be cleaned up.

:- pred register_file_for_cleanup(string::in, io__state::di, io__state::uo)
	is det.

% Remove the given file name from the list of files to be cleaned up.

:- pred unregister_file_for_cleanup(string::in, io__state::di, io__state::uo)
	is det.

% Remove all file names from the list of files to be cleaned up.

:- pred unregister_all_files_for_cleanup(io__state::di, io__state::uo) is det.

% Delete all the files on the cleanup list.

:- pred delete_cleanup_files(io__state::di, io__state::uo) is det.

% Set up signal handlers for all the signals we can catch. The three strings
% specify the name of the mutex file, the name of the directory containing the
% `want' files, and the prefix of the names of the `want' files.

:- pred setup_signals(string::in, string::in, string::in,
	io__state::di, io__state::uo) is det.

% Set up a timeout for the given number of minutes in the future.

:- pred setup_timeout(int::in, io__state::di, io__state::uo) is det.

% Get the lock on the named mutex file if the bool is `no'.
% If the bool is `yes', meaning debugging is enabled, do nothing.

:- pred get_lock(bool::in, string::in,
	io__state::di, io__state::uo) is det.

% Release the lock on the named mutex file if the bool is `no'.
% If the bool is `yes', meaning debugging is enabled, do nothing.

:- pred release_lock(bool::in, string::in,
	io__state::di, io__state::uo) is det.

% Create the `want' file with the given name.

:- pred make_want_file(string::in, io__state::di, io__state::uo) is det.

% Delete the `want' file with the given name.

:- pred remove_want_file(string::in, io__state::di, io__state::uo) is det.

:- implementation.

:- import_module int.
:- import_module string.

:- pragma foreign_decl("C",
"
#include <sys/types.h>
#include <sys/stat.h>
#include <fcntl.h>
#include <stdio.h>
#include <signal.h>	/* for signal numbers */
#include <unistd.h>	/* for alarm() */
#include <stdlib.h>	/* for atexit() */
#include <errno.h>	/* for EEXIST etc */
#include ""mercury_signal.h""

#define	MP_MAX_CLEANUP_FILES	20	/* this should be plenty */

extern	const char	*MP_cleanup_files[MP_MAX_CLEANUP_FILES];
extern	int		MP_cleanup_file_next;

extern	void		MP_maybe_print_cleanup_files(const char *msg);
extern	void		MP_register_cleanup_file(const char *filename);
extern	void		MP_unregister_cleanup_file(const char *filename);
extern	void		MP_handle_fatal_exception(void *data);
extern	void		MP_delete_cleanup_files(void);
extern	void		MP_delete_cleanup_files_and_exit_failure(
				const char *signal_name);

extern	int		MP_timeout_seconds;
extern	const char	*MP_timeout_mutex_file;
extern	const char	*MP_timeout_want_dir;
extern	const char	*MP_timeout_want_prefix;

typedef	struct
{
	int	MP_signum;
	void	(*MP_handler)(void);
} MP_sig_handler;

extern	const MP_sig_handler	MP_signal_structs[];

extern	void	MP_handle_timeout(void);

extern	void	MP_handle_sig_term(void);
extern	void	MP_handle_sig_hup(void);
extern	void	MP_handle_sig_int(void);
extern	void	MP_handle_sig_quit(void);
extern	void	MP_handle_sig_ill(void);
extern	void	MP_handle_sig_abrt(void);
extern	void	MP_handle_sig_bus(void);
extern	void	MP_handle_sig_fpe(void);
extern	void	MP_handle_sig_segv(void);
extern	void	MP_handle_sig_pipe(void);

extern	MR_bool	MP_do_try_get_lock(const char *mutex_file);
extern	void	MP_do_get_lock(const char *mutex_file);
extern	void	MP_do_release_lock(const char *mutex_file);
").

:- pragma foreign_code("C",
"
#if defined(MR_HAVE_DIRENT_H)
  #include	<sys/types.h>
  #include	<dirent.h>
#else
  /* if we get here, the deep profiler isn't enabled */
#endif

const char	*MP_cleanup_files[MP_MAX_CLEANUP_FILES];
int		MP_cleanup_file_next = 0;

int		MP_timeout_seconds = 30 * 60;
const char	*MP_timeout_mutex_file = NULL;
const char	*MP_timeout_want_dir = NULL;
const char	*MP_timeout_want_prefix = NULL;

/* set this variable to MR_TRUE to debug the code cleanup array */
MR_bool		MP_print_cleanup_files = MR_FALSE;

void
MP_maybe_print_cleanup_files(const char *msg)
{
	int	i;

	if (MP_print_cleanup_files) {
		fprintf(stderr, ""\n%s cleanup files:\n"", msg);
		for (i = 0; i < MP_cleanup_file_next; i++) {
			fprintf(stderr, ""%i %s\n"", i, MP_cleanup_files[i]);
		}
	}
}

void
MP_register_cleanup_file(const char *filename)
{
	int	i;

	if (MP_cleanup_file_next >= MP_MAX_CLEANUP_FILES - 1) {
		MR_fatal_error(""MP_register_cleanup_file: too many entries"");
	}

	for (i = 0; i < MP_cleanup_file_next; i++) {
		if (MR_streq(filename, MP_cleanup_files[i])) {
			MR_fatal_error(""MP_register_cleanup_file: duplicate"");
		}
	}

	MP_cleanup_files[MP_cleanup_file_next] = filename;
	MP_cleanup_file_next++;
	MP_maybe_print_cleanup_files(""register"");
}

void
MP_unregister_cleanup_file(const char *filename)
{
	int	i;
	int	j;

	for (i = 0; i < MP_cleanup_file_next; i++) {
		if (MR_streq(filename, MP_cleanup_files[i])) {
			/* shift the array entries above index i down one */
			for (j = i + 1; j < MP_cleanup_file_next; j++) {
				MP_cleanup_files[j - 1] = MP_cleanup_files[j];
			}

			MP_cleanup_file_next--;
			MP_maybe_print_cleanup_files(""unregister"");
			return;
		}
	}

	MR_fatal_error(""MP_unregister_cleanup_file: not found"");
}

void
MP_handle_fatal_exception(void *data)
{
	/* we ignore data */
	MP_delete_cleanup_files();
}

void
MP_delete_cleanup_files(void)
{
	int	i;
	MR_bool	delayed_mutex_file;

	/*
	** We want to remove the mutex file only after we have removed the
	** files manipulated by the critical section it was protecting.
	*/

	MP_maybe_print_cleanup_files(""delete"");

	delayed_mutex_file = MR_FALSE;
	for (i = 0; i < MP_cleanup_file_next; i++) {
		if (MR_streq(MP_timeout_mutex_file, MP_cleanup_files[i])) {
			delayed_mutex_file = MR_TRUE;
		} else {
			if (remove(MP_cleanup_files[i]) != 0) {
				perror(MP_cleanup_files[i]);
			}
		}
	}

	if (delayed_mutex_file) {
		if (remove(MP_timeout_mutex_file) != 0) {
			perror(MP_timeout_mutex_file);
		}
	}

	MP_cleanup_file_next = 0;
}

void
MP_delete_cleanup_files_and_exit_failure(const char *signal_name)
{
	FILE	*fp;
	char	buf[1024];	/* that should be big enough */

#ifdef	MP_DEBUG_SIGNAL
	fp = fopen(""/tmp/mdprof_signal"", ""w"");
	if (fp != NULL) {
		fprintf(fp, ""%s\n"", signal_name);
		(void) fclose(fp);
	}
#endif

	MP_delete_cleanup_files();

#ifdef	MP_DEBUG_SIGNAL
	sprintf(buf, ""Mercury deep profiler: received unexpected signal %s"",
		signal_name);
	MR_fatal_error(buf);
#else
	exit(EXIT_FAILURE);
#endif
}

/*
** SIGALRM alarm signal indicates a timeout. SIGTERM usually indicates the
** machine is being shut down. The others are there to catch forceful shutdowns
** during development, both intentional ones where the programmer sends the
** signal and those caused by bugs in the server code. We would like to include
** all catchable, fatal signals in this list, but that set is somewhat OS
** dependent. The set whose existence we test for here includes all the
** signals that are at all likely to be sent to server process.
**
** We don't test for the existence of SIGALRM, because we want compilation to
** fail if it does not exist. Without alarm signals, server processes will
** never be timed out, and thus constitute a resource leak (mostly of virtual
** memory/swap space).
**
** We could avoid this problem if we had a version of atexit that executed
** its actions even when the program exits after a signal.
*/

const MP_sig_handler MP_signal_structs[] =
{
	{ SIGALRM,	MP_handle_timeout },
#ifdef SIGTERM
	{ SIGTERM,	MP_handle_sig_term },
#endif
#ifdef SIGHUP
	{ SIGHUP,	MP_handle_sig_hup },
#endif
#ifdef SIGINT
	{ SIGINT,	MP_handle_sig_int },
#endif
#ifdef SIGQUIT
	{ SIGQUIT,	MP_handle_sig_quit },
#endif
#ifdef SIGILL
	{ SIGILL,	MP_handle_sig_ill },
#endif
#ifdef SIGABRT
	{ SIGABRT,	MP_handle_sig_abrt },
#endif
#ifdef SIGBUS
	{ SIGBUS,	MP_handle_sig_bus },
#endif
#ifdef SIGFPE
	{ SIGFPE,	MP_handle_sig_fpe },
#endif
#ifdef SIGSEGV
	{ SIGSEGV,	MP_handle_sig_segv },
#endif
#ifdef SIGPIPE
	{ SIGPIPE,	MP_handle_sig_pipe },
#endif
	{ -1, 		NULL }
};

void
MP_handle_timeout(void)
{
#if defined(MR_HAVE_DIRENT_H) && defined(MR_HAVE_OPENDIR) \
		&& defined(MR_HAVE_READDIR) && defined(MR_HAVE_CLOSEDIR)

	DIR		*dir;
	struct	dirent	*dirent;
	int		matchlen;
	MR_bool		success;

	if (MP_timeout_want_dir == NULL || MP_timeout_want_prefix == NULL) {
		MR_fatal_error(""MP_handle_timeout: null dir or prefix"");
	}

	matchlen = strlen(MP_timeout_want_prefix);

	success = MP_do_try_get_lock(MP_timeout_mutex_file);
	if (! success) {
		/*
		** We could not get the lock, so some other process holds it.
		** We therefore abort the timeout, but schedule the next one.
		*/

		(void) alarm(MP_timeout_seconds);
		return;
	}

	dir = opendir(MP_timeout_want_dir);
	if (dir == NULL) {
		MR_fatal_error(""MP_handle_timeout: opendir failed"");
	}

	while ((dirent = readdir(dir)) != NULL) {
		if (MR_strneq(dirent->d_name, MP_timeout_want_prefix,
			matchlen))
		{
			/* abort the timeout */
			(void) closedir(dir);
			(void) alarm(MP_timeout_seconds);
			return;
		}
	}

	(void) closedir(dir);

	/*
	** This call will delete the mutex file last, releasing the mutex
	*/
	MP_delete_cleanup_files();
	exit(EXIT_SUCCESS);

#else
	/* if we get here, the deep profiler isn't enabled */
#endif
}

void
MP_handle_sig_term(void)
{
	MP_delete_cleanup_files_and_exit_failure(""SIGTERM"");
}

void
MP_handle_sig_hup(void)
{
	MP_delete_cleanup_files_and_exit_failure(""SIGHUP"");
}

void
MP_handle_sig_int(void)
{
	MP_delete_cleanup_files_and_exit_failure(""SIGINT"");
}

void
MP_handle_sig_quit(void)
{
	MP_delete_cleanup_files_and_exit_failure(""SIGQUIT"");
}

void
MP_handle_sig_ill(void)
{
	MP_delete_cleanup_files_and_exit_failure(""SIGILL"");
}

void
MP_handle_sig_abrt(void)
{
	MP_delete_cleanup_files_and_exit_failure(""SIGABRT"");
}

void
MP_handle_sig_bus(void)
{
	MP_delete_cleanup_files_and_exit_failure(""SIGBUS"");
}

void
MP_handle_sig_fpe(void)
{
	MP_delete_cleanup_files_and_exit_failure(""SIGFPE"");
}

void
MP_handle_sig_segv(void)
{
	MP_delete_cleanup_files_and_exit_failure(""SIGSEGV"");
}

void
MP_handle_sig_pipe(void)
{
	MP_delete_cleanup_files_and_exit_failure(""SIGPIPE"");
}

MR_bool
MP_do_try_get_lock(const char *mutex_file)
{
	int	res;
	MR_bool	success;

	res = open(mutex_file, O_CREAT | O_EXCL, 0);
	if (res >= 0) {
		(void) close(res);
		MP_register_cleanup_file(mutex_file);
		success = MR_TRUE;
	} else if (res < 0 && errno == EEXIST) {
		success = MR_FALSE;
	} else {
		MR_fatal_error(""MP_do_try_get_lock failed"");
	}

	return res;
}

void
MP_do_get_lock(const char *mutex_file)
{
	int	res;

	for (;;) {
		res = open(mutex_file, O_CREAT | O_EXCL, 0);
		if (res >= 0) {
			(void) close(res);
			MP_register_cleanup_file(mutex_file);
			return;
		} else if (res < 0 && errno == EEXIST) {
			sleep(5);
			continue;
		} else {
			MR_fatal_error(""MP_do_get_lock failed"");
		}
	}
}

void
MP_do_release_lock(const char *mutex_file)
{
	MP_unregister_cleanup_file(mutex_file);
	(void) unlink(mutex_file);
}
").

:- pragma foreign_proc("C",
	register_file_for_cleanup(File::in, S0::di, S::uo),
	[will_not_call_mercury, promise_pure],
"
	MP_register_cleanup_file(File);
	S = S0;
").

:- pragma foreign_proc("C",
	unregister_file_for_cleanup(File::in, S0::di, S::uo),
	[will_not_call_mercury, promise_pure],
"
	MP_unregister_cleanup_file(File);
	S = S0;
").

:- pragma foreign_proc("C",
	unregister_all_files_for_cleanup(S0::di, S::uo),
	[will_not_call_mercury, promise_pure],
"
	MP_cleanup_file_next = 0;
	S = S0;
").

:- pragma foreign_proc("C",
	delete_cleanup_files(S0::di, S::uo),
	[will_not_call_mercury, promise_pure],
"
	MP_delete_cleanup_files();
	S = S0;
").

:- pragma foreign_proc("C",
	setup_signals(MutexFile::in, WantDir::in, WantPrefix::in,
		S0::di, S::uo),
	[will_not_call_mercury, promise_pure],
"
	int	i;

	MP_timeout_mutex_file = MutexFile;
	MP_timeout_want_dir = WantDir;
	MP_timeout_want_prefix = WantPrefix;

	for (i = 0; MP_signal_structs[i].MP_signum >= 0; i++) {
		MR_setup_signal(MP_signal_structs[i].MP_signum,
			MP_signal_structs[i].MP_handler, MR_FALSE,
			""Mercury deep profiler: cannot setup signal exit"");
	}

	/*
	** Mercury exceptions do not cause signals. The default exception
	** handler prints and error message and exits. To ensure that
	** we delete up the files we need to clean up, we get the exit
	** library function to invoke MP_delete_cleanup_files through
	** MP_handle_fatal_exception.
	*/

	MR_register_exception_cleanup(MP_handle_fatal_exception, NULL);

	S = S0;
").

:- pragma foreign_proc("C",
	setup_timeout(Minutes::in, S0::di, S::uo),
	[will_not_call_mercury, promise_pure],
"
	MP_timeout_seconds = Minutes * 60;
	(void) alarm(MP_timeout_seconds);
	S = S0;
").

%-----------------------------------------------------------------------------%

get_lock(Debug, MutexFile) -->
	(
		{ Debug = yes }
	;
		{ Debug = no },
		do_get_lock(MutexFile)
	).

release_lock(Debug, MutexFile) -->
	(
		{ Debug = yes }
	;
		{ Debug = no },
		do_release_lock(MutexFile)
	).

:- pred do_get_lock(string::in, io__state::di, io__state::uo) is det.

:- pragma foreign_proc("C",
	do_get_lock(MutexFile::in, S0::di, S::uo),
	[will_not_call_mercury, promise_pure, tabled_for_io],
"
	MP_do_get_lock(MutexFile);
	S = S0;
").

:- pred do_release_lock(string::in, io__state::di, io__state::uo)
	is det.

:- pragma foreign_proc("C",
	do_release_lock(MutexFile::in, S0::di, S::uo),
	[will_not_call_mercury, promise_pure, tabled_for_io],
"
	MP_do_release_lock(MutexFile);
	S = S0;
").

:- pragma foreign_proc("C",
	make_want_file(WantFileName::in, S0::di, S::uo),
	[will_not_call_mercury, promise_pure],
"
	int	fd;

	fd = open(WantFileName, O_CREAT, 0);
	if (fd < 0) {
		MR_fatal_error(""make_want_file: open failed"");
	}
	(void) close(fd);
	MP_register_cleanup_file(WantFileName);
	S = S0;
").

:- pragma foreign_proc("C",
	remove_want_file(WantFileName::in, S0::di, S::uo),
	[will_not_call_mercury, promise_pure],
"
	MP_unregister_cleanup_file(WantFileName);
	(void) unlink(WantFileName);
	S = S0;
").
--------------------------------------------------------------------------
mercury-reviews mailing list
post:  mercury-reviews at cs.mu.oz.au
administrative address: owner-mercury-reviews at cs.mu.oz.au
unsubscribe: Address: mercury-reviews-request at cs.mu.oz.au Message: unsubscribe
subscribe:   Address: mercury-reviews-request at cs.mu.oz.au Message: subscribe
--------------------------------------------------------------------------