call_cleanup/2 and 3

git-svn-id: https://yap.svn.sf.net/svnroot/yap/trunk@1750 b08c6af1-5177-4d33-ba66-4b1c6b8b522a

C/absmi.c

@@ -10,8 +10,12 @@
 *									 *
 * File:		absmi.c							 *
 * comments:	Portable abstract machine interpreter                    *
-* Last rev:     $Date: 2006-12-29 01:57:50 $,$Author: vsc $						 *
+* Last rev:     $Date: 2006-12-30 03:25:44 $,$Author: vsc $						 *
 * $Log: not supported by cvs2svn $
+* Revision 1.216  2006/12/29 01:57:50  vsc
+* allow coroutining plus tabling, this means fixing some trouble with the
+* gc and a bug in global variable handling.
+*
 * Revision 1.215  2006/12/27 01:32:37  vsc
 * diverse fixes
 *
@@ -1914,16 +1918,20 @@ Yap_absmi(int inp)
 #endif /* LIMIT_TABLING */
 #ifdef FROZEN_STACKS  /* TRAIL */
             /* avoid frozen segments */
+	    if (
 #ifdef SBA
-	    if ((ADDR) pt1 >= HeapTop)
+		(ADDR) pt1 >= HeapTop
 #else
-	    if ((ADDR) pt1 >= Yap_TrailBase)
+		IN_BETWEEN(Yap_TrailBase, pt1, Yap_TrailTop)
 #endif /* SBA */
+		)
             {
 	      pt0 = (tr_fr_ptr) pt1;
 	      goto failloop;
-	    }
+	    } else
 #endif /* FROZEN_STACKS */
+	      if (IN_BETWEEN(Yap_GlobalBase, pt1, H0))
+		goto failloop;		       	    
 	    flags = *pt1;
 #if defined(YAPOR) || defined(THREADS)
 	    if (FlagOn(DBClMask, flags)) {
@@ -2114,6 +2122,13 @@ Yap_absmi(int inp)
 		/* skip, this is a problem because we lose information,
                    namely active references */
 		pt1 = (tr_fr_ptr)pt;
+	      } else if (IN_BETWEEN(Yap_GlobalBase, pt, H0)) {
+		CELL val = Deref(*pt);
+		if (IsVarTerm(val)) {
+		  Bind(pt, MkAtomTerm(AtomCut));
+		  Yap_WakeUp(pt);
+		}
+		pt1--;
 	      } else if ((*pt & (LogUpdMask|IndexMask)) == (LogUpdMask|IndexMask)) {
 		LogUpdIndex *cl = ClauseFlagsToLogUpdIndex(pt);
 		int erase;
@@ -2207,7 +2222,14 @@ Yap_absmi(int inp)
 	       }
 	    } else if (IsPairTerm(d1)) {
 	      CELL *pt = RepPair(d1);
-	      if ((*pt & (LogUpdMask|IndexMask)) == (LogUpdMask|IndexMask)) {
+	      
+	      if (IN_BETWEEN(Yap_GlobalBase, pt, H0)) {
+		CELL val = Deref(*pt);
+		if (IsVarTerm(val)) {
+		  Bind(VarOfTerm(val), MkAtomTerm(AtomCut));
+		  Yap_WakeUp(pt);
+		}
+	      } else if ((*pt & (LogUpdMask|IndexMask)) == (LogUpdMask|IndexMask)) {
 		LogUpdIndex *cl = ClauseFlagsToLogUpdIndex(pt);
 		int erase;
 

C/exec.c

@@ -156,6 +156,16 @@ p_save_env_b(void)
   return(TRUE);
 }
 
+static Int
+p_trail_suspension_marker(void)
+{
+  Term t = Deref(ARG1);
+  
+  TrailTerm(TR) = AbsPair((CELL*)t);
+  TR++;
+  return TRUE;
+}
+
 inline static Int
 do_execute(Term t, Term mod)
 {
@@ -1901,6 +1911,7 @@ Yap_InitExecFs(void)
   CurrentModule = HACKS_MODULE;
   Yap_InitCPred("current_choice_point", 1, p_save_cp, HiddenPredFlag);
   Yap_InitCPred("env_choice_point", 1, p_save_env_b, HiddenPredFlag);
+  Yap_InitCPred("trail_suspension_marker", 1, p_trail_suspension_marker, HiddenPredFlag);
   CurrentModule = cm;
   Yap_InitCPred("$pred_goal_expansion_on", 0, p_pred_goal_expansion_on, SafePredFlag|HiddenPredFlag);
   Yap_InitCPred("$restore_regs", 1, p_restore_regs, SafePredFlag|HiddenPredFlag);

C/heapgc.c

@@ -1638,6 +1638,11 @@ mark_trail(tr_fr_ptr trail_ptr, tr_fr_ptr trail_base, CELL *gc_H, choiceptr gc_B
       }
     } else if (IsPairTerm(trail_cell)) {
       /* can safely ignore this */
+      CELL *cptr = RepPair(trail_cell);
+      if (cptr > (CELL*)Yap_GlobalBase && cptr < H0) {
+	trail_base++;
+	continue;
+      }
     }
 #if  MULTI_ASSIGNMENT_VARIABLES
     else {
@@ -2304,6 +2309,12 @@ sweep_trail(choiceptr gc_B, tr_fr_ptr old_TR)
 	CELL flags;
 
 
+	if (pt0 > (CELL*)Yap_GlobalBase && pt0 < H0) {
+	  TrailTerm(dest) = trail_cell;
+	  dest++;
+	  trail_ptr++;
+	  continue;
+	}
 #ifdef FROZEN_STACKS  /* TRAIL */
 	/* process all segments */
 	if (

changes-5.1.html

@@ -16,6 +16,8 @@
 
 <h2>Yap-5.1.2:</h2>
 <ul>
+<li> NEW: call_cleanup/2 and call_cleanup/3 at the request of Paulo
+Moura and Christian1.</li> 
 <li> FIXED: garbage collector would not understand bindings to mavars in
 tabling version.</li> 
 <li> FIXED: cut might not prune correctly around meta-call (obs by

pl/boot.yap

@@ -77,10 +77,6 @@ true :- true.
 	'$startup_reconsult',
 	'$startup_goals'.
 
- % encapsulate $cut_by because of co-routining.
- %
- '$cut_by'(X) :- '$$cut_by'(X).
-
  % Start file for yap
 
  /*		I/O predicates						*/
@@ -675,6 +671,7 @@ incore(G) :- '$execute'(G).
 \+(G) :-     \+ '$execute'(G).
 not(G) :-    \+ '$execute'(G).
 
+'$cut_by'(CP) :- '$$cut_by'(CP).
 
 %
 % do it in ISO mode.
@@ -738,7 +735,7 @@ not(G) :-    \+ '$execute'(G).
 '$call'(not(X), _CP, _G0, _M) :- !,
 	\+ '$execute'(M:X).
 '$call'(!, CP, _,_) :- !,
-	'$cut_by'(CP).
+	'$$cut_by'(CP).
 '$call'([A|B], _, _, M) :- !,
 	'$csult'([A|B], M).
 '$call'(G, CP, G0, CurMod) :-

pl/corout.yap

@@ -77,6 +77,8 @@
 % not act as if a meta-call.
 % 
 %
+'$do_continuation'('$cut_by'(X), _) :- !,
+	'$$cut_by'(X).
 '$do_continuation'('$restore_regs'(X), _) :- !,
 	'$restore_regs'(X).
 '$do_continuation'('$restore_regs'(X,Y), _) :- !,

pl/debug.yap

@@ -390,7 +390,7 @@ debugging :-
 	      (
 		Det == true
 		->
-		'$cut_by'(CP)
+		'$$cut_by'(CP)
 		;
 		true
 	      ),

pl/signals.yap

@@ -89,7 +89,7 @@
 	'$execute_nonstop'(G,Mod).
 % notice that the last signal to be processed must always be creep
 '$start_creep'([_|'$cut_by'(CP)]) :- !,
-	'$cut_by'(CP),
+	'$$cut_by'(CP),
 	'$creep'.
 '$start_creep'([_|true]) :- !,
 	'$creep'.

pl/utils.yap

@@ -166,28 +166,32 @@ call_with_args(A,A1,A2,A3,A4,A5,A6,A7,A8,A9,A10) :- atom(A), !,
 call_with_args(A,A1,A2,A3,A4,A5,A6,A7,A8,A9,A10) :- 
 	'$do_error'(type_error(atom,A),call_with_args(A,A1,A2,A3,A4,A5,A6,A7,A8,A9,A10)).
 	
-/*
+
-	call_cleanup(Goal, Catcher, Cleanup) :-
+call_cleanup(Goal, Cleanup) :-
+	call_cleanup(Goal, Catcher, Cleanup).
+
+call_cleanup(Goal, Catcher, Cleanup) :-
 	catch('$call_cleanup'(Goal,Catcher,Cleanup),
 	      Exception,
 	      '$cleanup_exception'(Exception,Catcher,Cleanup)).
 
 '$cleanup_exception'(Exception, exception(Exception), Cleanup) :-
-	call(cleanup).
+	      call(Cleanup).
 
 '$call_cleanup'(Goal,Catcher,Cleanup) :-
+	'$freeze_goal'(Catcher, once(Cleanup)),
+	yap_hacks:trail_suspension_marker(Catcher),
 	yap_hacks:current_choice_point(CP0),
 	call(Goal),
 	yap_hacks:current_choice_point(CPF),
 	( CP0 =:= CPF ->
-	    Catcher = exit,
+	    Catcher = exit, !
-	    call(Cleanup)
 	;
 	    true
 	).
 '$call_cleanup'(Goal,fail,Cleanup) :-
-	call(Cleanup).
+	call(Cleanup), !,
-*/  
+	fail.
 
 op(P,T,V) :- var(P), !,
 	'$do_error'(instantiation_error,op(P,T,V)).