gated call

2017-09-03 00:15:54 +01:00 · 2017-09-03 00:15:54 +01:00 · 5448987ad0
parent 22c0cbeca3
commit 5448987ad0
4 changed files with 143 additions and 167 deletions
--- a/C/exec.c
+++ b/C/exec.c
@ -765,22 +765,13 @@ static void complete_inner_computation(choiceptr old_B) {
  ENV = myB->cp_env;
 }

-static Int Yap_ignore(Term t USES_REGS) {
+static Int Yap_ignore(Term t, bool fail USES_REGS) {
  yamop *oP = P, *oCP = CP;
  Int oENV = LCL0 - ENV;
  Int oYENV = LCL0 - YENV;
  Int oB = LCL0 - (CELL *)B;
  bool rc = Yap_RunTopGoal(t, false);

-  if (Yap_RaiseException()) {
-    P = oP;
-    CP = oCP;
-    ENV = LCL0 - oENV;
-    YENV = LCL0 - oYENV;
-    B = (choiceptr)(LCL0 - oB);
-    return false;
-  }
-
  if (!rc) {
    complete_inner_computation((choiceptr)(LCL0 - oB));
    // We'll pass it through
@ -816,15 +807,18 @@ static bool watch_cut(Term ext USES_REGS) {
  //
  Term task = TailOfTerm(ext);
  Term cleanup = ArgOfTerm(3, task);
-  bool complete = !IsVarTerm(Deref(ArgOfTerm(4, task)));
+  Term e = 0;
+  bool complete = IsNonVarTerm(Deref(ArgOfTerm(4, task)));
  bool active = ArgOfTerm(5, task) == TermTrue;
-  
+  bool ex_mode = false;
+
  if (complete) {
    return true;
  }
  CELL *port_pt = deref_ptr(RepAppl(task) + 2);
-  if (Yap_HasException()) {
-    Term e = Yap_GetException();
+  CELL *completion_pt = deref_ptr(RepAppl(task) + 4);
+  if ((ex_mode = Yap_HasException())) {
+    e = Yap_GetException();
    Term t;
    if (active) {
      t = Yap_MkApplTerm(FunctorException, 1, &e);
@ -832,12 +826,17 @@ static bool watch_cut(Term ext USES_REGS) {
      t = Yap_MkApplTerm(FunctorExternalException, 1, &e);
    }
    port_pt[0] = t;
+    completion_pt[0] = TermException;
  } else {
-    port_pt[0] = TermCut;
+    completion_pt[0] = port_pt[0] = TermCut;
  }
-  Yap_ignore(cleanup);
+  Yap_ignore(cleanup, false);
  CELL *complete_pt = deref_ptr(RepAppl(task) + 4);
  complete_pt[0] = TermTrue;
+  if (ex_mode) {
+    Yap_PutException(e);
+    return true;
+  }
  if (Yap_RaiseException())
    return false;
  return true;
@ -854,31 +853,34 @@ static bool watch_cut(Term ext USES_REGS) {
 static bool watch_retry(Term d0 USES_REGS) {
  // called after backtracking..
  //
-  CELL d = ((CELL *)Yap_blob_info(HeadOfTerm(d0)))[0];
-
-  choiceptr B0 = (choiceptr)(LCL0 - d);
  Term task = TailOfTerm(d0);
  bool box = ArgOfTerm(1, task) == TermTrue;
  Term cleanup = ArgOfTerm(3, task);
  bool complete = !IsVarTerm(ArgOfTerm(4, task));
  bool active = ArgOfTerm(5, task) == TermTrue;
+  choiceptr B0 = (choiceptr)(LCL0 - IntegerOfTerm(ArgOfTerm(6, task)));

-  if ( complete)
+  if (complete)
    return true;
-  CELL *port_pt= deref_ptr(RepAppl(Deref(task))+ 2);
-  CELL *complete_pt= deref_ptr(RepAppl(Deref(task))+ 4);
-  Term t;
+  CELL *port_pt = deref_ptr(RepAppl(Deref(task)) + 2);
+  CELL *complete_pt = deref_ptr(RepAppl(Deref(task)) + 4);
+  Term t, e = 0;
+  bool ex_mode = false;

  while (B->cp_ap->opc == FAIL_OPCODE)
    B = B->cp_b;
-  if (Yap_HasException()) {
-    Term e = Yap_GetException();
+
+  // just do the frrpest
+  if (B >= B0 && !ex_mode && !active)
+    return true;
+  if ((ex_mode = Yap_HasException())) {
+    e = Yap_GetException();
    if (active) {
      t = Yap_MkApplTerm(FunctorException, 1, &e);
    } else {
      t = Yap_MkApplTerm(FunctorExternalException, 1, &e);
    }
-    complete_pt[0] = t;
+    complete_pt[0] = TermException;
  } else if (B >= B0) {
    t = TermFail;
    complete_pt[0] = t;
@ -889,8 +891,12 @@ static bool watch_retry(Term d0 USES_REGS) {
    return true;
  }
  port_pt[0] = t;
-  Yap_ignore(cleanup);
-  if ( Yap_RaiseException())
+  Yap_ignore(cleanup, true);
+  if (ex_mode) {
+    Yap_PutException(e);
+    return true;
+  }
+  if (Yap_RaiseException())
    return false;
  return true;
 }
@ -947,27 +953,30 @@ static Int cleanup_on_exit(USES_REGS1) {
  bool box = ArgOfTerm(1, task) == TermTrue;
  Term cleanup = ArgOfTerm(3, task);
  Term catcher = ArgOfTerm(2, task);
-  Term complete = !IsVarTerm( ArgOfTerm(4, task));
+  Term complete = IsNonVarTerm(ArgOfTerm(4, task));

  while (B->cp_ap->opc == FAIL_OPCODE)
    B = B->cp_b;
-  if (complete )
+  if (complete) {
    return true;
-  CELL *catcher_p = deref_ptr(RepAppl(Deref(task))+2);
-  if (B < B0)
-  {
+  }
+  CELL *catcher_pt = deref_ptr(RepAppl(Deref(task)) + 2);
+  CELL *complete_pt = deref_ptr(RepAppl(Deref(task)) + 4);
+  if (B < B0) {
    // non-deterministic
    set_watch(LCL0 - (CELL *)B, task);
-    catcher_p[0] =  TermAnswer;
    if (!box) {
      return true;
    }
+    catcher_pt[0] = TermAnswer;
  } else {
-    catcher_p[0] =   TermExit;
-    CELL *complete_p = deref_ptr(RepAppl(Deref(task))+4);
-    complete_p[0] = TermExit;
+    catcher_pt[0] = TermExit;
+    complete_pt[0] = TermExit;
+  }
+  Yap_ignore(cleanup, false);
+  if (Yap_RaiseException()) {
+    return false;
  }
-  Yap_ignore(cleanup);
  return true;
 }

--- a/pl/boot.yap
+++ b/pl/boot.yap
@ -1091,23 +1091,19 @@ incore(G) :- '$execute'(G).
 	'$call'(G, CP, G, M).

 '$user_call'(G, M) :-
-	(
-	 '$$save_by'(CP),
-	 '$enable_debugging',
-	 '$call'(G, CP, M:G, M),
-	 '$$save_by'(CP2),
-	 (
-	  CP == CP2
-	 ->
-	  !
-	 ;
-	  ( true ; '$enable_debugging', fail )
-	 ),
-	 '$disable_debugging'
-	;
-	 '$disable_debugging',
-	 fail
-	).
+    '$gated_call'(
+       ('$$save_by'(CP),
+       '$enable_debugging'),
+  	 '$call'(G, CP, M:G, M),
+       Port,
+  	   '$disable_debugging_on_port'(Port)
+       ).
+
+'$disable_debugging_on_port'(retry) :-
+    !,
+    '$enable_debugging'.
+'$disable_debugging_on_port'(_Port) :-
+	 '$disable_debugging'.



@ -1433,6 +1429,19 @@ Command = (H --> B) ->
 '$head_and_body'((H:-B),H,B) :- !.
 '$head_and_body'(H,H,true).

+
+gated_call(Setup, Goal, Catcher, Cleanup) :-
+'$setup_call_catcher_cleanup'(Setup),
+'$gated_call'( true , Goal, Catcher, Cleanup)  .
+
+'$gated_call'( All , Goal, Catcher, Cleanup) :-
+	Task0 = cleanup( All, Catcher, Cleanup, Tag, true, CP0),
+	TaskF = cleanup( All, Catcher, Cleanup, Tag, false, CP0),
+	'$tag_cleanup'(CP0, Task0),
+	call( Goal ),
+	'$cleanup_on_exit'(CP0, TaskF).
+
+
 %
 % split head and body, generate an error if body is unbound.
 %
--- a/pl/control.yap
+++ b/pl/control.yap
@ -262,12 +262,10 @@ This is similar to call_cleanup/1 but with an additional

 */
 call_cleanup(Goal, Cleanup) :-
-	call_cleanup(Goal, _Catcher, Cleanup).
+'$gated_call'( false , Goal,_Catcher, Cleanup)  .

 call_cleanup(Goal, Catcher, Cleanup) :-
-    '$tag_cleanup'(CP0, cleanup( false, Catcher, Cleanup, Tag, 0, Done)),
-    call( Goal ),
-    '$cleanup_on_exit'(CP0, cleanup( false, Catcher, Cleanup, Tag, 1, Done	)).
+'$gated_call'( false , Goal, Catcher, Cleanup)  .

 /** @pred setup_call_cleanup(: _Setup_,: _Goal_, : _CleanUpGoal_)

@ -291,15 +289,6 @@ setup_call_catcher_cleanup(Setup, Goal, Catcher, Cleanup) :-
    '$setup_call_catcher_cleanup'(Setup),
 	call_cleanup(Goal, Catcher, Cleanup).

-gated_call(Setup, Goal, Catcher, Cleanup) :-
-	Task0 = cleanup( true, Catcher, Cleanup, Tag, true, Done),
-	TaskF = cleanup( true, Catcher, Cleanup, Tag, false, Done),
-	'$setup_call_catcher_cleanup'(Setup),
-	'$tag_cleanup'(CP0, Task0),
-	call( Goal ),
-	'$cleanup_on_exit'(CP0, TaskF).
-
-

 /** @pred  call_with_args(+ _Name_,...,? _Ai_,...)

--- a/pl/debug.yap
+++ b/pl/debug.yap
@ -406,45 +406,83 @@ be lost.
 '$do_spy'(ignore(G), M, CP, CalledFromDebugger) :- !,
 	ignore( '$do_spy'(G, M, CP, CalledFromDebugger) ).
 '$do_spy'(G, Module, _, CalledFromDebugger) :-
+    '$loop_spy'(G, Module, CalledFromDebugger).
+
+% we are skipping, so we can just call the goal,
+% while leaving the minimal structure in place.
+'$loop_spy'(G, Module, CalledFromDebugger) :-
+    catch(
+    gated_call(
+	'$enter_spy'(GoalNumber, G, Module, CalledFromDebugger, H),
+	'$loop_spy2'(GoalNumber, G, Module, CalledFromDebugger),
+		Port,
+        '$spy_port'(Port, GoalNumber, G, Module, CalledFromDebugger, H)),
+        E,
+        '$redo_spy'( E, G, Module, CalledFromDebugger, GoalNumber, H)
+        ).
+
+%%% fail just fails.
+'$redo_spy'(abort, _G, _Module, _CalledFromDebugger, _GoalNumber, _H) :-
+	z
+    abort.
+'$redo_spy'('$forward'('$wrapper'(E),G0), _G, _Module, _CalledFromDebugger, _                           z'$redo_spy'('$forward'('$fail_spy',G0), __G, __Module, __CalledFromDebugger, GoalNumber, _H) :-
+    GoalNumber =< G0,
+    !,
+    fail.
+'$redo_spy'('$forward'('$retry_spy',G0), G, Module, CalledFromDebugger, GoalNumber, H) :-
+    GoalNumber =< G0,
+    !,
+    catch(
+    gated_call(
+	'$enter_spy'(GoalNumber, G, Module, CalledFromDebugger, H),
+	'$loop_spy2'(GoalNumber, G, Module, CalledFromDebugger),
+		Port,
+        '$spy_port'(Port, GoalNumber, G, Module, CalledFromDebugger, H)),
+        E,
+        '$redo_spy'( G, Module, CalledFromDebugger, H)
+        ).
+'$redo_spy'('$forward'(C,G0), G, Module, CalledFromDebugger, GoalNumber, H) :-
+            throw(C,G0).
+
+'$enter_spy'(GoalNumber, G, Module, CalledFromDebugger, H) :-
        '__NB_getval__'('$spy_gn',L,fail),		/* get goal no.			*/
 	L1 is L+1,			/* bump it			*/
 	'__NB_setval__'('$spy_gn',L1),	/* and save it globaly		*/
        '__NB_getval__'('$spy_glist',History,true),	/* get goal list		*/
-	'__B_setval__'('$spy_glist',[info(L,Module,G,_Retry,_Det,_HasFoundAnswers)|History]),
+    H  = [info(L,Module,G,_Retry,_Det,_HasFoundAnswers)|History],
+	'__B_setval__'('$spy_glist',H).
 	/* and update it		*/
-	'$loop_spy'(L, G, Module, CalledFromDebugger).

-% we are skipping, so we can just call the goal,
-% while leaving the minimal structure in place.
-'$loop_spy'(GoalNumber, G, Module, CalledFromDebugger) :-
-	'$current_choice_point'(CP),
-	'$system_catch'('$loop_spy2'(GoalNumber, G, Module, CalledFromDebugger, CP),
-		    Module, Error,
-		    '$TraceError'(Error, GoalNumber, G, Module, CalledFromDebugger)).
+'$spy_port'(Port, GoalNumber, G, Module, CalledFromDebugger, Info) :-
+    '$stop_creeping'(_) ,
+    '$spy_port_'(Port, GoalNumber, G, Module, CalledFromDebugger, Info).
+
+'$spy_port_'(exit, GoalNumber, G, Module, CalledFromDebugger, Info) :-
+    nb_setarg(6, Info, true),
+    '$show_trace'(exit,G,Module,GoalNumber,true),
+    '$continue_debugging'(exit, CalledFromDebugger).
+'$spy_port_'(answer, GoalNumber, G, Module, CalledFromDebugger, Info) :-
+    '$show_trace'(exit,G,Module,GoalNumber,false),
+    '$continue_debugging'(exit, CalledFromDebugger).
+'$spy_port_'(redo, GoalNumber, G, Module, CalledFromDebugger, Info) :-
+    '$show_trace'(redo,G,Module,GoalNumber,_), /* inform user_error		*/
+    '$continue_debugging'(fail, CalledFromDebugger).
+'$spy_port_'(fail, GoalNumber, G, Module, CalledFromDebugger, Info) :-
+    '$show_trace'(fail,G,Module,GoalNumber,_), /* inform user_error		*/
+    '$continue_debugging'(fail, CalledFromDebugger).
+'$spy_port_'(! ,G,Module,GoalNumber,_) :- /* inform user_error		*/
+    !.
+'$spy_port_'(exception(E), GoalNumber, G, Module, CalledFromDebugger, _Info) :-
+    '$TraceError'(E, GoalNumber, G, Module, CalledFromDebugger).
+'$spy_port_'(external_exception(E), GoalNumber, G, Module, CalledFromDebugger, _Info) :-
+    '$TraceError'(E, GoalNumber, G, Module, CalledFromDebugger).
+

-/**
-  * @pred '$TraceError'(+Exception, +CurrentGoalId, +CurrentGoal, +Module, +Status)
-  *
-  * forward exception until leaving the debugger or
-  * finding a matching frame:
-  *
-*/
 %%% - retry: forward throw while the call is newer than goal
-'$TraceError'( abort, _, _, _, _) :-
-    '$stop_creeping'(_),
-    abort.
-'$TraceError'('$forward'('$retry_spy'(G0)), GoalNumber, G, Module, CalledFromDebugger) :-
-	( G0 >= GoalNumber
-  ->
-	'$loop_spy'(GoalNumber, G, Module, CalledFromDebugger)
-;
-	throw('$forward'('$retry_spy'(G0)))
-  ).
+'$TraceError'( abort, _, _, _, _).
+'$TraceError'('$forward'('$retry_spy'(G0)), _, _, _, _).
 %%% - backtrack long distance
-'$TraceError'('$forward'('$fail_spy'(G0)), GoalNumber, G, Module, CalledFromDebugger) :-
-	G0 >= GoalNumber, !,
-	'$loop_fail'(GoalNumber, G, Module, CalledFromDebugger).
-'$TraceError'('$forward'('$fail_spy'(GoalNumber)), _, _, _, _) :- !,
+'$TraceError'('$forward'('$fail_spy'(G0)), _, _, _, _) :- !,
 	throw(error('$fail_spy'(GoalNumber))).
 %%%
 %%% - forward through the debugger
@ -473,75 +511,6 @@ be lost.
 	'$continue_debugging'(fail, CalledFromDebugger),
 	fail.

-/**
- * core routine for the debugger
- *
- * @param _ GoalNumbera id
- * @param _ S9c
- * @param _
- * @param Retry
- * @param Det
- * @param false
- *
- * @return
-*/
-'$loop_spy2'(GoalNumber, G, Module, CalledFromDebugger, CP) :-
-/* the following choice point is where the predicate is  called */
-	   '__NB_getval__'('$spy_glist',[Info|_],true),	/* get goal list		*/
-	   Info = info(_,_,_,Retry,Det,false),
-	   (
-	    /* call port */
-	    '$enter_goal'(GoalNumber, G, Module),
-	    '$spycall'(G, Module, CalledFromDebugger, Retry),
-	    '$stop_creeping'(_) ,
-	    % make sure we are in system mode when running the debugger.
-	    (
-	      '$debugger_deterministic_goal'(G) ->
-	      Det=true
-	    ;
-	      Det=false
-	    ),
-	    /* go execute the continuation	*/
-	    (
-	       /* exit port */
-         Retry = false,
-         /* found an answer, so it can redo */
-         nb_setarg(6, Info, true),
-         '$show_trace'(exit,G,Module,GoalNumber,Det),	/* output message at exit	*/
-        /* exit port */
-        /* get rid of deterministic computations */
-        (
-         Det == true
-		->
-         '$$cut_by'(CP)
-		;
-         true
-        ),
-         '$continue_debugging'(exit, CalledFromDebugger)
-	     ;
-	     /* make sure we are in system mode when running the debugger. */
-         /* backtracking from exit				*/
-         /* we get here when we want to redo a goal		*/
-         /* redo port */
-         (
-          arg(6, Info, true)
-         ->
-          '$stop_creeping'(_) ,
-          '$show_trace'(redo,G,Module,GoalNumber,_), /* inform user_error		*/
-         nb_setarg(6, Info, false)
-         ;
-          true
-         ),
-	     '$continue_debugging'(fail, CalledFromDebugger),
-	     fail			/* to backtrack to spycall	*/
-        )
-	  ;
-        '$stop_creeping'(_) ,
-	    '$show_trace'(fail,G,Module,GoalNumber,_), /* inform at fail port		*/
-       '$continue_debugging'(fail, CalledFromDebugger),
-	    /* fail port */
-	    fail
-       ).

 '$enter_goal'(GoalNumber, G, Module) :-
    '$zip'(GoalNumber, G, Module), !.