mercurylang/mercury
1
0
Fork 0
mirror of https://github.com/Mercury-Language/mercury.git synced 2025-12-14 21:35:49 +00:00
Code Issues Projects Releases Wiki Activity
Files
ada4e26dd11e052f8f244cb0af94208f4d329452
mercury/compiler/process_util.m
Peter Wang 9ac81c6659 Add missing import_module and this_file definition. 
Estimated hours taken: 0
Branches: main

process_util.m:
	Add missing import_module and this_file definition.
2007-06-14 02:24:40 +00:00

429 lines
13 KiB
Mathematica
Raw Blame History

%-----------------------------------------------------------------------------%
% vim: ft=mercury ts=4 sw=4 et
%-----------------------------------------------------------------------------%
% Copyright (C) 2002-2006 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.
%-----------------------------------------------------------------------------%
%
% File: process_util.m.
% Main author: stayl.
%
% Process and signal handling, mainly for use by make.m and its sub-modules.
%
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
:- module libs.process_util.
:- interface.
:- import_module bool.
:- import_module io.
%-----------------------------------------------------------------------------%
:- type build0(Info) == pred(bool, Info, Info, io, io).
:- inst build0 == (pred(out, in, out, di, uo) is det).
:- type post_signal_cleanup(Info) == pred(Info, Info, io, io).
:- inst post_signal_cleanup == (pred(in, out, di, uo) is det).
% build_with_check_for_interrupt(Build, Cleanup, Succeeded, !Info):
%
% Apply `Build' with signal handlers installed to check for
% signals which would normally kill the process. If a signal
% occurs call `Cleanup', then restore signal handlers to their
% defaults and reraise the signal to kill the current process.
% An action being performed in a child process by
% call_in_forked_process will be killed if a fatal signal
% (SIGINT, SIGTERM, SIGHUP or SIGQUIT) is received by the
% current process. An action being performed within the current
% process or by system() will run to completion, with the
% interrupt being taken immediately afterwards.
%
:- pred build_with_check_for_interrupt(build0(Info)::in(build0),
post_signal_cleanup(Info)::in(post_signal_cleanup), bool::out,
Info::in, Info::out, io::di, io::uo) is det.
% raise_signal(Signal).
% Send `Signal' to the current process.
%
:- pred raise_signal(int::in, io::di, io::uo) is det.
%-----------------------------------------------------------------------------%
:- type io_pred == pred(bool, io, io).
:- inst io_pred == (pred(out, di, uo) is det).
% Does fork() work on the current platform.
%
:- pred can_fork is semidet.
% call_in_forked_process(P, AltP, Succeeded):
%
% Execute `P' in a separate process.
%
% We prefer to use fork() rather than system() because
% that will avoid shell and Mercury runtime startup overhead.
% Interrupt handling will also work better (system() on Linux
% ignores SIGINT).
%
% If fork() is not supported on the current architecture,
% `AltP' will be called instead in the current process.
%
:- pred call_in_forked_process_with_backup(io_pred::in(io_pred),
io_pred::in(io_pred), bool::out, io::di, io::uo) is det.
% As above, but if fork() is not available, just call the
% predicate in the current process.
%
:- pred call_in_forked_process(io_pred::in(io_pred), bool::out,
io::di, io::uo) is det.
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
:- implementation.
:- import_module libs.compiler_util.
:- import_module libs.globals.
:- import_module libs.options.
%-----------------------------------------------------------------------------%
build_with_check_for_interrupt(Build, Cleanup, Succeeded, !Info, !IO) :-
setup_signal_handlers(MaybeSigIntHandler, !IO),
Build(Succeeded0, !Info, !IO),
restore_signal_handlers(MaybeSigIntHandler, !IO),
check_for_signal(Signalled, Signal, !IO),
( Signalled = 1 ->
Succeeded = no,
globals.io_lookup_bool_option(verbose_make, Verbose, !IO),
(
Verbose = yes,
io.write_string("** Received signal ", !IO),
io.write_int(Signal, !IO),
io.write_string(", cleaning up.\n", !IO)
;
Verbose = no
),
Cleanup(!Info, !IO),
% The signal handler has been restored to the default,
% so this should kill us.
raise_signal(Signal, !IO)
;
Succeeded = Succeeded0
).
:- type signal_action ---> signal_action.
:- pragma foreign_type("C", signal_action, "MR_signal_action").
:- pragma foreign_decl("C",
"
#ifdef MR_HAVE_UNISTD_H
#include <unistd.h>
#endif
#ifdef MR_HAVE_SYS_TYPES_H
#include <sys/types.h>
#endif
#ifdef MR_HAVE_SYS_WAIT_H
#include <sys/wait.h>
#endif
#include <errno.h>
#include ""mercury_signal.h""
#include ""mercury_types.h""
#include ""mercury_heap.h""
#include ""mercury_misc.h""
#if defined(MR_HAVE_FORK) && defined(MR_HAVE_WAIT) && defined(MR_HAVE_KILL)
#define MC_CAN_FORK 1
#endif
#define MC_SETUP_SIGNAL_HANDLER(sig, handler) \
MR_setup_signal(sig, (MR_Code *) handler, MR_FALSE, \
""mercury_compile: cannot install signal handler"");
/* Have we received a signal. */
extern volatile sig_atomic_t MC_signalled;
/*
** Which signal did we receive.
** XXX This assumes a signal number will fit into a sig_atomic_t.
*/
extern volatile sig_atomic_t MC_signal_received;
void MC_mercury_compile_signal_handler(int sig);
").
:- pragma foreign_code("C",
"
volatile sig_atomic_t MC_signalled = MR_FALSE;
volatile sig_atomic_t MC_signal_received = 0;
void
MC_mercury_compile_signal_handler(int sig)
{
MC_signalled = MR_TRUE;
MC_signal_received = sig;
}
").
:- pred setup_signal_handlers(signal_action::out, io::di, io::uo) is det.
setup_signal_handlers(signal_action::out, IO::di, IO::uo).
:- pragma foreign_proc("C",
setup_signal_handlers(SigintHandler::out, IO0::di, IO::uo),
[will_not_call_mercury, promise_pure, tabled_for_io],
"{
IO = IO0;
MC_signalled = MR_FALSE;
/*
** mdb sets up a SIGINT handler, so we should restore
** it after we're done.
*/
MR_get_signal_action(SIGINT, &SigintHandler,
""error getting SIGINT handler"");
MC_SETUP_SIGNAL_HANDLER(SIGINT, MC_mercury_compile_signal_handler);
MC_SETUP_SIGNAL_HANDLER(SIGTERM, MC_mercury_compile_signal_handler);
#ifdef SIGHUP
MC_SETUP_SIGNAL_HANDLER(SIGHUP, MC_mercury_compile_signal_handler);
#endif
#ifdef SIGQUIT
MC_SETUP_SIGNAL_HANDLER(SIGQUIT, MC_mercury_compile_signal_handler);
#endif
}").
:- pred restore_signal_handlers(signal_action::in, io::di, io::uo) is det.
restore_signal_handlers(_::in, IO::di, IO::uo).
:- pragma foreign_proc("C",
restore_signal_handlers(SigintHandler::in, IO0::di, IO::uo),
[will_not_call_mercury, promise_pure, tabled_for_io],
"{
IO = IO0;
MR_set_signal_action(SIGINT, &SigintHandler,
""error resetting SIGINT handler"");
MC_SETUP_SIGNAL_HANDLER(SIGTERM, SIG_DFL);
#ifdef SIGHUP
MC_SETUP_SIGNAL_HANDLER(SIGHUP, SIG_DFL);
#endif
#ifdef SIGQUIT
MC_SETUP_SIGNAL_HANDLER(SIGQUIT, SIG_DFL);
#endif
}").
% Restore all signal handlers to default values in the child so that
% the child will be killed by the signals the parent is catching.
%
:- pred setup_child_signal_handlers(io::di, io::uo) is det.
setup_child_signal_handlers(!IO) :-
restore_signal_handlers(sig_dfl, !IO).
:- func sig_dfl = signal_action.
sig_dfl = (signal_action::out).
:- pragma foreign_proc("C",
sig_dfl = (Result::out),
[will_not_call_mercury, promise_pure],
"
MR_init_signal_action(&Result, SIG_DFL, MR_FALSE, MR_TRUE);
").
:- pred check_for_signal(int::out, int::out, io::di, io::uo) is det.
check_for_signal(0::out, 0::out, IO::di, IO::uo).
:- pragma foreign_proc("C",
check_for_signal(Signalled::out, Signal::out, IO0::di, IO::uo),
[will_not_call_mercury, promise_pure, tabled_for_io],
"
IO = IO0;
Signalled = (MC_signalled ? 1 : 0);
Signal = MC_signal_received;
").
%-----------------------------------------------------------------------------%
:- pragma foreign_decl("C", "#include <signal.h>").
% If this aborted it would cause partially built files
% to be left lying around with `--make'.
raise_signal(_::in, IO::di, IO::uo).
:- pragma foreign_proc("C",
raise_signal(Signal::in, IO0::di, IO::uo),
[will_not_call_mercury, promise_pure, tabled_for_io],
"
IO = IO0;
raise(Signal);
").
%-----------------------------------------------------------------------------%
call_in_forked_process(P, Success, !IO) :-
call_in_forked_process_with_backup(P, P, Success, !IO).
call_in_forked_process_with_backup(P, AltP, Success, !IO) :-
( can_fork ->
do_call_in_forked_process(P, ForkStatus, CallStatus, !IO),
( ForkStatus = 1 ->
Success = no
;
Status = io.handle_system_command_exit_status(CallStatus),
Success = (Status = ok(exited(0)) -> yes ; no)
)
;
AltP(Success, !IO)
).
can_fork :- semidet_fail.
:- pragma foreign_proc("C",
can_fork,
[will_not_call_mercury, thread_safe, promise_pure],
"
/*
** call_in_forked_process_2 is not `thread_safe' so will hold a mutex
** that the child process will want. At the same time the parent process
** waits for the child to exit, so we have a deadlock.
**
** Also, in pthreads, a forked process does not inherit the threads of
** the original process so it is not at all clear whether we could use
** fork() when running in a parallel grade.
*/
#if (defined MC_CAN_FORK) && (!defined MR_THREAD_SAFE)
SUCCESS_INDICATOR = MR_TRUE;
#else
SUCCESS_INDICATOR = MR_FALSE;
#endif
").
:- pred do_call_in_forked_process(io_pred::in(io_pred), int::out, int::out,
io::di, io::uo) is det.
do_call_in_forked_process(_::in(io_pred), _::out, _::out, _::di, _::uo) :-
unexpected(this_file, "do_call_in_forked_process").
:- pragma foreign_proc("C",
do_call_in_forked_process(Pred::in(io_pred), ForkStatus::out, Status::out,
IO0::di, IO::uo),
[may_call_mercury, promise_pure, tabled_for_io],
"{
#ifdef MC_CAN_FORK
pid_t child_pid;
IO = IO0;
ForkStatus = 0;
Status = 0;
child_pid = fork();
if (child_pid == -1) { /* error */
MR_perror(""error in fork()"");
ForkStatus = 1;
} else if (child_pid == 0) { /* child */
MR_Integer exit_status;
MC_call_child_process_io_pred(Pred, &exit_status);
exit(exit_status);
} else { /* parent */
int child_status;
pid_t wait_status;
/*
** Make sure the wait() is interrupted by the signals
** which cause us to exit.
*/
MR_signal_should_restart(SIGINT, MR_FALSE);
MR_signal_should_restart(SIGTERM, MR_FALSE);
#ifdef SIGHUP
MR_signal_should_restart(SIGHUP, MR_FALSE);
#endif
#ifdef SIGQUIT
MR_signal_should_restart(SIGQUIT, MR_FALSE);
#endif
while (1) {
wait_status = wait(&child_status);
if (wait_status == child_pid) {
Status = child_status;
break;
} else if (wait_status == -1) {
if (MR_is_eintr(errno)) {
if (MC_signalled) {
/*
** A normally fatal signal has been received,
** so kill the child immediately.
** Use SIGTERM, not MC_signal_received,
** because the child may be inside a call
** to system() which would cause SIGINT
** to be ignored on some systems (e.g. Linux).
*/
kill(child_pid, SIGTERM);
break;
}
} else {
/*
** This should never happen.
*/
MR_perror(""error in wait(): "");
ForkStatus = 1;
Status = 1;
break;
}
}
}
/*
** Restore the system call signal behaviour.
*/
MR_signal_should_restart(SIGINT, MR_TRUE);
MR_signal_should_restart(SIGTERM, MR_TRUE);
#ifdef SIGHUP
MR_signal_should_restart(SIGHUP, MR_TRUE);
#endif
#ifdef SIGQUIT
MR_signal_should_restart(SIGQUIT, MR_TRUE);
#endif
}
#else /* ! MC_CAN_FORK */
IO = IO0;
ForkStatus = 1;
Status = 1;
#endif /* ! MC_CAN_FORK */
}").
% call_child_process_io_pred(P, ExitStatus).
%
:- pred call_child_process_io_pred(io_pred::in(io_pred), int::out,
io::di, io::uo) is det.
:- pragma foreign_export("C",
call_child_process_io_pred(in(io_pred), out, di, uo),
"MC_call_child_process_io_pred").
call_child_process_io_pred(P, Status, !IO) :-
setup_child_signal_handlers(!IO),
P(Success, !IO),
Status = ( Success = yes -> 0 ; 1 ).
%-----------------------------------------------------------------------------%
:- func this_file = string.
this_file = "process_util.m".
%-----------------------------------------------------------------------------%
:- end_module libs.process_util.
%-----------------------------------------------------------------------------%
Reference in New Issue View Git Blame Copy Permalink