diff --git a/C/stdpreds.c b/C/stdpreds.c index d07c99534..ad8ba5fa4 100644 --- a/C/stdpreds.c +++ b/C/stdpreds.c @@ -473,7 +473,8 @@ inline static void do_signal(yap_signals sig) { LOCK(SignalLock); - CreepFlag = Unsigned(LCL0); + if (Yap_InterruptsEnabled) + CreepFlag = Unsigned(LCL0); ActiveSignals |= sig; UNLOCK(SignalLock); } diff --git a/C/sysbits.c b/C/sysbits.c index c43fbcfa2..2b5f1599d 100644 --- a/C/sysbits.c +++ b/C/sysbits.c @@ -1107,6 +1107,7 @@ HandleMatherr(int sig, siginfo_t *sip, ucontext_t *uap) } +#if HAVE_SIGSEGV && !defined(THREADS) static void my_signal_info(int sig, void (*handler)(int, siginfo_t *, ucontext_t *)) { @@ -1118,6 +1119,7 @@ my_signal_info(int sig, void (*handler)(int, siginfo_t *, ucontext_t *)) sigaction(sig,&sigact,NULL); } +#endif static void my_signal(int sig, void (*handler)(int, siginfo_t *, ucontext_t *)) @@ -1221,6 +1223,7 @@ SearchForTrailFault(siginfo_t *siginfo) } } +#if HAVE_SIGSEGV && !defined(THREADS) static RETSIGTYPE HandleSIGSEGV(int sig, siginfo_t *siginfo, void *context) { @@ -1229,6 +1232,7 @@ HandleSIGSEGV(int sig, siginfo_t *siginfo, void *context) } SearchForTrailFault(siginfo); } +#endif static void my_signal_info(int sig, void (*handler)(int,siginfo_t *,void *)) @@ -1509,13 +1513,20 @@ HandleSIGINT (int sig, siginfo_t *x, ucontext_t *y) HandleSIGINT (int sig) #endif { + LOCK(SignalLock); my_signal(SIGINT, HandleSIGINT); /* do this before we act */ #if HAVE_ISATTY if (!isatty(0) && !Yap_sockets_io) { + UNLOCK(SignalLock); Yap_Error(INTERRUPT_ERROR,MkIntTerm(SIGINT),NULL); + return; } #endif + if (!Yap_InterruptsEnabled) { + UNLOCK(SignalLock); + return; + } if (Yap_PrologMode & (CritMode|ConsoleGetcMode)) { Yap_PrologMode |= InterruptMode; #if HAVE_LIBREADLINE @@ -1527,6 +1538,7 @@ HandleSIGINT (int sig) #endif } #endif + UNLOCK(SignalLock); return; } #ifdef HAVE_SETBUF @@ -1535,9 +1547,11 @@ HandleSIGINT (int sig) #endif if (snoozing) { snoozing = FALSE; + UNLOCK(SignalLock); return; } ProcessSIGINT(); + UNLOCK(SignalLock); } #if !defined(_WIN32) @@ -1619,6 +1633,8 @@ ReceiveSignal (int s) #if (_MSC_VER || defined(__MINGW32__)) static BOOL WINAPI MSCHandleSignal(DWORD dwCtrlType) { + if (!Yap_InterruptsEnabled) { + return FALSE; switch(dwCtrlType) { case CTRL_C_EVENT: case CTRL_BREAK_EVENT: @@ -2824,6 +2840,27 @@ p_win32(void) #endif } + +static Int +p_enable_interrupts(void) +{ + LOCK(SignalLock); + Yap_InterruptsEnabled = TRUE; + UNLOCK(SignalLock); + return TRUE; +} + +static Int +p_disable_interrupts(void) +{ + LOCK(SignalLock); + if (ActiveSignals) + CreepFlag = Unsigned(LCL0); + Yap_InterruptsEnabled = FALSE; + UNLOCK(SignalLock); + return TRUE; +} + static Int p_ld_path(void) { @@ -3047,6 +3084,8 @@ Yap_InitSysPreds(void) Yap_InitCPred ("$env_separator", 1, p_env_separator, SafePredFlag); Yap_InitCPred ("$unix", 0, p_unix, SafePredFlag); Yap_InitCPred ("$win32", 0, p_win32, SafePredFlag); + Yap_InitCPred ("$enable_interrupts", 0, p_enable_interrupts, SafePredFlag); + Yap_InitCPred ("$disable_interrupts", 0, p_disable_interrupts, SafePredFlag); Yap_InitCPred ("$ld_path", 1, p_ld_path, SafePredFlag); #ifdef _WIN32 Yap_InitCPred ("win_registry_get_value", 3, p_win_registry_get_value,0); diff --git a/H/Heap.h b/H/Heap.h index 80ec556a3..becd7fda0 100644 --- a/H/Heap.h +++ b/H/Heap.h @@ -123,6 +123,7 @@ typedef struct worker_local_struct { union CONSULT_OBJ *consultlow; struct pred_entry *last_asserted_pred; int debug_on; + int interrupts_enabled; UInt consultcapacity; UInt active_signals; UInt i_pred_arity; @@ -687,6 +688,7 @@ extern struct various_codes *Yap_heap_regs; #define XDiff RINFO.x_diff #define DelayDiff RINFO.delay_diff #define BaseDiff RINFO.base_diff +#define Yap_InterruptsEnabled Yap_heap_regs->WL.interrupts_enabled /* current consult stack */ #define ConsultSp Yap_heap_regs->WL.consultsp /* top of consult stack */ diff --git a/docs/yap.tex b/docs/yap.tex index c52f01dcc..bb9d7f84d 100644 --- a/docs/yap.tex +++ b/docs/yap.tex @@ -11078,7 +11078,7 @@ it will be called through call_cleanup/1. :- fragile foo/1,bar:baz/2. @end example -@item call_cleanup(+@var{Goal}) +@item call_cleanup(:@var{Goal}) @findex call_cleanup/1 @syindex call_cleanup/1 @cnindex call_cleanup/1 @@ -11087,13 +11087,80 @@ might register cleanup Goals which are called right after the end of the call to @var{Goal}. Cuts and exceptions inside Goal do not prevent the execution of the cleanup calls. @t{call_cleanup} might be nested. -@item call_cleanup(+@var{Goal}, +@var{CleanUpGoal}) +@item call_cleanup(:@var{Goal}, :@var{CleanUpGoal}) @findex call_cleanup/2 @syindex call_cleanup/2 @cnindex call_cleanup/2 This is similar to @t{call_cleanup/1} with an additional @var{CleanUpGoal} which gets called after @var{Goal} is finished. +@item setup_call_cleanup(:@var{Setup},:@var{Goal}, :@var{CleanUpGoal}) +@findex setup_call_cleanup/3 +@snindex setup_call_cleanup/3 +@cnindex setup_call_cleanup/3 +Calls @code{(Setup, Goal)}. For each sucessful execution of @var{Setup}, calling @var{Goal}, the +cleanup handler @var{Cleanup} is guaranteed to be called exactly once. +This will happen after @var{Goal} completes, either through failure, +deterministic success, commit, or an exception. @var{Setup} will +contain the goals that need to be protected from asynchronous interrupts +such as the ones received from @code{call_with_time_limit/2} or @code{thread_signal/2}. In +most uses, @var{Setup} will perform temporary side-effects required by +@var{Goal} that are finally undone by \arg{Cleanup}. + +Success or failure of @var{Cleanup} is ignored and choice-points it +created are destroyed (as @code{once/1}). If @var{Cleanup} throws an exception, +this is executed as normal. + +Typically, this predicate is used to cleanup permanent data storage +required to execute @var{Goal}, close file-descriptors, etc. The example +below provides a non-deterministic search for a term in a file, closing +the stream as needed. + +@example +term_in_file(Term, File) :- + setup_call_cleanup(open(File, read, In), + term_in_stream(Term, In), + close(In) ). + +term_in_stream(Term, In) :- + repeat, + read(In, T), + ( T == end_of_file + -> !, fail + ; T = Term + ). +@end example + +Note that it is impossible to implement this predicate in Prolog other than +by reading all terms into a list, close the file and call @code{member/2}. +Without @code{setup_call_cleanup/3} there is no way to gain control if the +choice-point left by code{repeat} is removed by a cut or an exception. + +@code{setup_call_cleanup/2} can also be used to test determinism of a goal: + +@example +?- setup_call_cleanup(true,(X=1;X=2), Det=yes). + +X = 1 ; + +X = 2, +Det = yes ; +@end example + +This predicate is under consideration for inclusion into the ISO standard. +For compatibility with other Prolog implementations see @code{call_cleanup/2}. + + @item setup_call_cleanup(:@var{Setup},:@var{Goal}, +@var{Catcher},:@var{CleanUpGoal}) +@findex setup_call_cleanup/3 +@snindex setup_call_cleanup/3 +@cnindex setup_call_cleanup/3 +Similar to @code{setup_call_cleanup}{@var{Setup},@var{ Goal}, @var{Cleanup}} with +additional information on the reason of calling @var{Cleanup}. Prior +to calling @var{Cleanup}, @var{Catcher} unifies with the termination +code. If this unification fails, @var{Cleanup} is +@strong{not} called. + + @item on_cleanup(+@var{CleanUpGoal}) @findex on_cleanup/1 @syindex on_cleanup/1 diff --git a/pl/modules.yap b/pl/modules.yap index daae3584a..9b29c8c73 100644 --- a/pl/modules.yap +++ b/pl/modules.yap @@ -511,6 +511,8 @@ source_module(Mod) :- format(+,+,:), call_cleanup(:,:), call_cleanup(:,?,:), + setup_call_cleanup(:,:,:), + setup_call_catcher_cleanup(:,:,?,:), call_residue(:,?), call_residue_vars(:,?), catch(:,+,:), diff --git a/pl/utils.yap b/pl/utils.yap index cef506031..6e516743a 100644 --- a/pl/utils.yap +++ b/pl/utils.yap @@ -56,13 +56,37 @@ call(X,A1,A2,A3,A4,A5,A6,A7,A8,A9,A10) :- '$execute'(X,A1,A2,A3,A4,A5,A6,A7,A8,A call(X,A1,A2,A3,A4,A5,A6,A7,A8,A9,A10,A11) :- '$execute'(X,A1,A2,A3,A4,A5,A6,A7,A8,A9,A10,A11). call_cleanup(Goal, Cleanup) :- - call_cleanup(Goal, _Catcher, Cleanup). + setup_call_cleanup(true, Goal, _Catcher, Cleanup). -call_cleanup(Goal, Catcher, Cleanup) :- - catch('$call_cleanup'(Goal,Cleanup,Catcher), +setup_call_cleanup(Setup, Goal, Cleanup) :- + setup_call_catcher_cleanup(Setup, Goal, Catcher, Cleanup). + +setup_call_catcher_cleanup(Setup, Goal, Catcher, Cleanup) :- + '$disable_interrupts', + '$do_setup'(Setup), + catch('$safe_call_cleanup'(Goal,Cleanup,Catcher), Exception, '$cleanup_exception'(Exception,Catcher,Cleanup)). +% this is simple, do nothing +'$do_setup'(A:true) :- atom(A), !. +% this is tricky: please don't forget that interrupts are disabled at this point +% and that they will only be enabled after setting up Cleanup +'$do_setup'(Setup) :- + ( + yap_hacks:current_choice_point(CP0), + '$execute'(Setup), + yap_hacks:current_choice_point(CP1), + % are we looking at a deterministic goal? + % we don't need to care about enabling interrupts + (CP1 == CP0 -> ! ; true) + ; + % reenable interrupts if Setup failed + '$enable_interrupts', + fail + ). + + '$cleanup_exception'(Exception, exception(Exception), Cleanup) :- !, % whatever happens, let exception go through catch('$clean_call'(Cleanup),_,true), @@ -70,11 +94,13 @@ call_cleanup(Goal, Catcher, Cleanup) :- '$cleanup_exception'(Exception, _, _) :- throw(Exception). -'$call_cleanup'(Goal, Cleanup, Catcher) :- +'$safe_call_cleanup'(Goal, Cleanup, Catcher) :- + yap_hacks:current_choice_point(MyCP1), '$freeze_goal'(Catcher, '$clean_call'(Cleanup)), yap_hacks:trail_suspension_marker(Catcher), ( yap_hacks:current_choice_point(CP0), + '$enable_interrupts', '$execute'(Goal), yap_hacks:current_choice_point(CPF), (