first try of setup_call_cleanup/3 and setup_call_catcher_cleanup/4

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);
 }

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);

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  */

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

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(:,+,:),

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) :-
+setup_call_cleanup(Setup, Goal, Cleanup) :-
-	catch('$call_cleanup'(Goal,Cleanup,Catcher),
+	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),
 	 (