call the garbage collector the right way

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

C/absmi.c

@@ -1185,7 +1185,14 @@ Yap_absmi(int inp)
 	LogUpdClause *cl = ClauseCodeToLogUpdClause(PREG);
 	Term t;
 
-	t = Yap_FetchTermFromDB(cl->ClSource, 3);
+	saveregs();
+	while ((t = Yap_FetchTermFromDB(cl->ClSource)) == 0L) {
+	  if (!Yap_gc(3, ENV, CP)) {
+	    Yap_Error(OUT_OF_STACK_ERROR, TermNil, Yap_ErrorMessage);
+	    FAIL();
+	  }
+	}
+	setregs();
 	if (!Yap_IUnify(ARG2, t)) {
 	  FAIL();
 	}

C/amasm.c

@@ -376,8 +376,9 @@ a_cle(op_numbers opcode)
 inline static void
 a_e(op_numbers opcode)
 {
-  if (pass_no)
+  if (pass_no) {
     code_p->opc = emit_op(opcode);
+  }
   GONEXT(e);  
 }
 
@@ -1199,6 +1200,27 @@ a_ifnot(op_numbers opcode)
   GONEXT(clll);
 }
 
+/*
+static void
+a_cut_e(void)
+{
+  if (pass_no) {
+    code_p->opc = emit_op(_cut_e);
+    code_p->u.sla.s = emit_count(-Signed(RealEnvSize) - CELLSIZE
+				     * (cpc->rnd2));
+    code_p->u.sla.sla_u.m_num = cpc->rnd3;
+    if (cpc->rnd2) {
+      code_p->u.sla.bmap = emit_bmlabel(cpc->rnd1);
+    } else {
+    // there is no bitmap as there are no variables in the environment 
+      code_p->u.sla.bmap = NULL;
+    }
+    code_p->u.sla.p0 =  CurrentPred;
+  }
+  GONEXT(sla);
+}
+*/
+
 static void
 a_cut(void)
 {

C/arrays.c

@@ -259,7 +259,12 @@ AccessNamedArray(Atom a, Int indx)
 
 	  READ_UNLOCK(ptr->ArRWLock);
 	  if (ref != NULL) {
-	    TRef = Yap_FetchTermFromDB(ref,3);
+	    while ((TRef = Yap_FetchTermFromDB(ref)) == 0L) {
+	      if (!Yap_gc(3, ENV, CP)) {
+		Yap_Error(OUT_OF_STACK_ERROR, TermNil, Yap_ErrorMessage);
+		return(TermNil);
+	      }
+	    }
 	  } else {
 	    P = (yamop *)FAILCODE;
 	    TRef = TermNil;
@@ -1917,7 +1922,12 @@ p_static_array_to_term(void)
 	    Term TRef;
 
 	    if (ref != NULL) {
-	      TRef = Yap_FetchTermFromDB(ref,3);
+	      while ((TRef = Yap_FetchTermFromDB(ref)) == 0L) {
+		if (!Yap_gc(3, YENV, P)) {
+		  Yap_Error(OUT_OF_STACK_ERROR, TermNil, Yap_ErrorMessage);
+		  return(TermNil);
+		}
+	      }
 	    } else {
 	      P = (yamop *)FAILCODE;
 	      TRef = TermNil;
@@ -1960,6 +1970,6 @@ Yap_InitArrayPreds(void)
   Yap_InitCPred("$compile_array_refs", 0, p_compile_array_refs, SafePredFlag);
   Yap_InitCPred("$array_refs_compiled", 0, p_array_refs_compiled, SafePredFlag);
   Yap_InitCPred("$static_array_properties", 3, p_static_array_properties, SafePredFlag);
-  Yap_InitCPred("static_array_to_term", 2, p_static_array_to_term, SafePredFlag);
+  Yap_InitCPred("static_array_to_term", 2, p_static_array_to_term, 0L);
 }
 

C/bb.c

@@ -271,7 +271,12 @@ p_bb_get(void)
   if (p == NULL || p->Element == NULL)
     return(FALSE);
   READ_LOCK(p->BBRWLock);  
-  out = Yap_FetchTermFromDB(p->Element,3);
+  while ((out = Yap_FetchTermFromDB(p->Element)) == 0L) {
+    if (!Yap_gc(2, YENV, P)) {
+      Yap_Error(OUT_OF_STACK_ERROR, TermNil, Yap_ErrorMessage);
+      return(TermNil);
+    }
+  }
   READ_UNLOCK(p->BBRWLock);
   return(Yap_unify(ARG2,out));
 }
@@ -286,7 +291,12 @@ p_bb_delete(void)
   p = FetchBBProp(t1, "bb_delete/2", CurrentModule);
   if (p == NULL || p->Element == NULL)
     return(FALSE);
-  out = Yap_FetchTermFromDB(p->Element,3);
+  while ((out = Yap_FetchTermFromDB(p->Element)) == 0L) {
+    if (!Yap_gc(2, YENV, P)) {
+      Yap_Error(OUT_OF_STACK_ERROR, TermNil, Yap_ErrorMessage);
+      return(TermNil);
+    }
+  }
   WRITE_LOCK(p->BBRWLock);  
   Yap_ReleaseTermFromDB(p->Element);
   p->Element = NULL;
@@ -305,7 +315,12 @@ p_bb_update(void)
   if (p == NULL || p->Element == NULL)
     return(FALSE);
   WRITE_LOCK(p->BBRWLock);  
-  out = Yap_FetchTermFromDB(p->Element,3);
+  while ((out = Yap_FetchTermFromDB(p->Element)) == 0L) {
+    if (!Yap_gc(3, YENV, P)) {
+      Yap_Error(OUT_OF_STACK_ERROR, TermNil, Yap_ErrorMessage);
+      return(TermNil);
+    }
+  }
   if (!Yap_unify(ARG2,out)) {
     WRITE_UNLOCK(p->BBRWLock);  
     return(FALSE);

C/cdmgr.c

@@ -2918,7 +2918,7 @@ get_pred(Term t1, Term tmod, char *command)
 }
 
 static Int
-fetch_next_lu_clause(PredEntry *pe, yamop *i_code, Term th, Term tb, Term tr, yamop *cp_ptr)
+fetch_next_lu_clause(PredEntry *pe, yamop *i_code, Term th, Term tb, Term tr, yamop *cp_ptr, int first_time)
 {
   LogUpdClause *cl = Yap_follow_lu_indexing_code(pe, i_code, th, tb, tr, NextClause(PredLogUpdClause->cs.p_code.FirstClause), cp_ptr);
   Term t;
@@ -2926,7 +2926,19 @@ fetch_next_lu_clause(PredEntry *pe, yamop *i_code, Term th, Term tb, Term tr, ya
 
   if (cl == NULL)
     return FALSE;
-  t = Yap_FetchTermFromDB(cl->ClSource, 4);
+  while ((t = Yap_FetchTermFromDB(cl->ClSource)) == 0L) {
+    if (first_time) {
+      if (!Yap_gc(4, YENV, P)) {
+	Yap_Error(OUT_OF_STACK_ERROR, TermNil, Yap_ErrorMessage);
+	return FALSE;
+      }
+    } else {
+      if (!Yap_gc(5, ENV, CP)) {
+	Yap_Error(OUT_OF_STACK_ERROR, TermNil, Yap_ErrorMessage);
+	return FALSE;
+      }
+    }
+  }
   rtn = MkDBRefTerm((DBRef)cl);
 #if defined(OR) || defined(THREADS)
   LOCK(cl->ClLock);
@@ -2959,7 +2971,7 @@ p_log_update_clause(void)
   pe = get_pred(t1, Deref(ARG2), "clause/3");
   if (pe == NULL || EndOfPAEntr(pe))
     return FALSE;
-  return fetch_next_lu_clause(pe, pe->cs.p_code.TrueCodeOfPred, t1, ARG3, ARG4,P);
+  return fetch_next_lu_clause(pe, pe->cs.p_code.TrueCodeOfPred, t1, ARG3, ARG4, P, TRUE);
 }
 
 static Int			/* $hidden_predicate(P) */
@@ -2968,18 +2980,30 @@ p_continue_log_update_clause(void)
   PredEntry *pe = (PredEntry *)IntegerOfTerm(Deref(ARG1));
   yamop *ipc = (yamop *)IntegerOfTerm(ARG2);
 
-  return fetch_next_lu_clause(pe, ipc, Deref(ARG3), ARG4, ARG5, B->cp_ap);
+  return fetch_next_lu_clause(pe, ipc, Deref(ARG3), ARG4, ARG5, B->cp_ap, FALSE);
 }
 
 static Int
-fetch_next_lu_clause0(PredEntry *pe, yamop *i_code, Term th, Term tb, yamop *cp_ptr)
+fetch_next_lu_clause0(PredEntry *pe, yamop *i_code, Term th, Term tb, yamop *cp_ptr, int first_time)
 {
   LogUpdClause *cl = Yap_follow_lu_indexing_code(pe, i_code, th, tb, TermNil, NextClause(PredLogUpdClause0->cs.p_code.FirstClause), cp_ptr);
   Term t;
 
   if (cl == NULL)
     return FALSE;
-  t = Yap_FetchTermFromDB(cl->ClSource, 4);
+  while ((t = Yap_FetchTermFromDB(cl->ClSource)) == 0L) {
+    if (first_time) {
+      if (!Yap_gc(4, YENV, P)) {
+	Yap_Error(OUT_OF_STACK_ERROR, TermNil, Yap_ErrorMessage);
+	return FALSE;
+      }
+    } else {
+      if (!Yap_gc(5, ENV, CP)) {
+	Yap_Error(OUT_OF_STACK_ERROR, TermNil, Yap_ErrorMessage);
+	return FALSE;
+      }
+    }
+  }
   if (IsApplTerm(t) && FunctorOfTerm(t) == FunctorAssert) {
     return(Yap_unify(th, ArgOfTerm(1,t)) &&
 	   Yap_unify(tb, ArgOfTerm(2,t)));
@@ -2998,7 +3022,7 @@ p_log_update_clause0(void)
   pe = get_pred(t1, Deref(ARG2), "clause/3");
   if (pe == NULL || EndOfPAEntr(pe))
     return FALSE;
-  return fetch_next_lu_clause0(pe, pe->cs.p_code.TrueCodeOfPred, t1, ARG3, P);
+  return fetch_next_lu_clause0(pe, pe->cs.p_code.TrueCodeOfPred, t1, ARG3, P, TRUE);
 }
 
 static Int			/* $hidden_predicate(P) */
@@ -3007,18 +3031,30 @@ p_continue_log_update_clause0(void)
   PredEntry *pe = (PredEntry *)IntegerOfTerm(Deref(ARG1));
   yamop *ipc = (yamop *)IntegerOfTerm(ARG2);
 
-  return fetch_next_lu_clause0(pe, ipc, Deref(ARG3), ARG4, B->cp_ap);
+  return fetch_next_lu_clause0(pe, ipc, Deref(ARG3), ARG4, B->cp_ap, FALSE);
 }
 
 static Int
-fetch_next_lu_retract(PredEntry *pe, yamop *i_code, Term th, Term tb, yamop *cp_ptr)
+fetch_next_lu_retract(PredEntry *pe, yamop *i_code, Term th, Term tb, yamop *cp_ptr, int first_time)
 {
   LogUpdClause *cl = Yap_follow_lu_indexing_code(pe, i_code, th, tb, TermNil, NextClause(PredLogUpdRetract->cs.p_code.FirstClause), cp_ptr);
   Term t;
 
   if (cl == NULL)
     return FALSE;
-  t = Yap_FetchTermFromDB(cl->ClSource, 4);
+  while ((t = Yap_FetchTermFromDB(cl->ClSource)) == 0L) {
+    if (first_time) {
+      if (!Yap_gc(3, YENV, P)) {
+	Yap_Error(OUT_OF_STACK_ERROR, TermNil, Yap_ErrorMessage);
+	return FALSE;
+      }
+    } else {
+      if (!Yap_gc(4, ENV, CP)) {
+	Yap_Error(OUT_OF_STACK_ERROR, TermNil, Yap_ErrorMessage);
+	return FALSE;
+      }
+    }
+  }
   if (IsApplTerm(t) && FunctorOfTerm(t) == FunctorAssert) {
     if (!(Yap_unify(th, ArgOfTerm(1,t)) &&
 	  Yap_unify(tb, ArgOfTerm(2,t))))
@@ -3041,7 +3077,7 @@ p_log_update_retract(void)
   pe = get_pred(t1, Deref(ARG2), "retract/2");
   if (pe == NULL || EndOfPAEntr(pe))
     return FALSE;
-  return fetch_next_lu_retract(pe, pe->cs.p_code.TrueCodeOfPred, t1, ARG3, P);
+  return fetch_next_lu_retract(pe, pe->cs.p_code.TrueCodeOfPred, t1, ARG3, P, TRUE);
 }
 
 static Int			/* $hidden_predicate(P) */
@@ -3050,7 +3086,7 @@ p_continue_log_update_retract(void)
   PredEntry *pe = (PredEntry *)IntegerOfTerm(Deref(ARG1));
   yamop *ipc = (yamop *)IntegerOfTerm(ARG2);
 
-  return fetch_next_lu_retract(pe, ipc, Deref(ARG3), ARG4, B->cp_ap);
+  return fetch_next_lu_retract(pe, ipc, Deref(ARG3), ARG4, B->cp_ap, FALSE);
 }
 
 #ifdef LOW_PROF

C/compiler.c

@@ -1184,20 +1184,20 @@ c_goal(Term Goal, int mod)
 #ifdef TABLING
 	READ_LOCK(CurrentPred->PRWLock);
 	if (is_tabled(CurrentPred)) {
-	  Yap_emit(cut_op, Zero, Zero);
+	  Yap_emit_3ops(cut_op, Zero, Zero, Zero);
 	  Yap_emit(table_new_answer_op, Zero, CurrentPred->ArityOfPE);
 	}
 	else
 #endif /* TABLING */
 	  {
-	    Yap_emit(cutexit_op, Zero, Zero);
+	    Yap_emit_3ops(cutexit_op, Zero, Zero, Zero);
 	  }
 #ifdef TABLING
 	READ_UNLOCK(CurrentPred->PRWLock);
 #endif
       }
       else {
-	Yap_emit(cut_op, Zero, Zero);
+	Yap_emit_3ops(cut_op, Zero, Zero, Zero);
 	/* needs to adjust previous commits */
 	adjust_current_commits();
       }
@@ -1611,10 +1611,9 @@ c_goal(Term Goal, int mod)
       && !(p->PredFlags & SyncPredFlag)
 #endif /* YAPOR */
       ) {
-    if (onlast)
-      Yap_emit(deallocate_op, Zero, Zero);
     Yap_emit(safe_call_op, (CELL) p0, Zero);
     if (onlast) {
+      Yap_emit(deallocate_op, Zero, Zero);
 #ifdef TABLING
       READ_LOCK(CurrentPred->PRWLock);
       if (is_tabled(CurrentPred))
@@ -1842,6 +1841,8 @@ AssignPerm(PInstr *pc)
       }
 #endif
       pc->rnd2 = nperm;
+    } else if (pc->op == cut_op || pc->op == cutexit_op) {
+      pc->rnd2 = nperm;
     }
     opc = pc;
     pc = npc;
@@ -2054,6 +2055,14 @@ CheckUnsafe(PInstr *pc)
       pc->rnd1 = (CELL)labelno;
       add_bvarray_op(pc, vstat, pc->rnd2);
       break;
+    case cut_op:
+    case cutexit_op:
+      /* just get ourselves a label describing how
+	 many permanent variables are alive */
+      Yap_emit(label_op, ++labelno, Zero);
+      pc->rnd1 = (CELL)labelno;
+      add_bvarray_op(pc, vstat, pc->rnd2);
+      break;
     case call_op:
       Yap_emit(label_op, ++labelno, Zero);
       pc->ops.opseqt[1] = (CELL)labelno;
@@ -2490,6 +2499,18 @@ c_layout(void)
       for (rn = 1; rn < MaxCTemps; ++rn)
 	*up++ = *cop++ = NIL;
       break;
+    case cut_op:
+    case cutexit_op:
+      {
+	int i, max;
+
+	max = 0;
+	for (i = 1; i < MaxCTemps; ++i) {
+	  if (Contents[i]) max = i;
+	}
+	cpc->ops.opseqt[1] = max;
+      }
+      break;
     case restore_tmps_and_skip_op:
     case restore_tmps_op:
       /*

C/corout.c

@@ -964,23 +964,25 @@ can_unify(Term t1, Term t2, Term *Vars)
 {
   t1 = Deref(t1);
   t2 = Deref(t2);
-  if (t1 == t2)
+  if (t1 == t2) {
-    return (TRUE);
+    *Vars = TermNil;
+    return TRUE;
+  }
   if (IsVarTerm(t1)) {
     /* we know for sure  they can't be different */
     if (IsVarTerm(t2)) {
       /* we need to suspend on both variables because otherwise
 	 Y = susp(_) would not wakeup susp ! */
       *Vars = MkPairTerm(t1,MkPairTerm(t2,TermNil));
-      return(TRUE);
+      return TRUE;
     } else {
       *Vars = MkPairTerm(t1,TermNil);
-      return(TRUE);
+      return TRUE;
     }
   } else if (IsVarTerm(t2)) {
     /* wait until t2 is bound */
     *Vars = MkPairTerm(t2,TermNil);
-    return(TRUE);
+    return TRUE;
   }
   /* Two standard terms at last! */
   if (IsAtomOrIntTerm(t1) || IsAtomOrIntTerm(t2)) {
@@ -988,44 +990,44 @@ can_unify(Term t1, Term t2, Term *Vars)
        the same. If they are, $eq succeeds without further ado.
        */
     if (t1 != t2)
-      return(FALSE);
+      return FALSE;
     else {
       *Vars = TermNil;
-      return(TRUE);
+      return TRUE;
     }
   } else if (IsPairTerm(t1)) {
     if (IsPairTerm(t2)) {
       return(can_unify_complex(RepPair(t1)-1, RepPair(t1)+1,
 			       RepPair(t2)-1, Vars));
-    } else return(FALSE);
+    } else return FALSE;
   } else {
     Functor f = FunctorOfTerm(t1);
     if (f != FunctorOfTerm(t2))
-      return (FALSE);
+      return FALSE;
     if (IsExtensionFunctor(f)) {
       switch((CELL)f) {
       case (CELL)FunctorDBRef:
 	if (t1 == t2) return(FALSE);
-	return(FALSE);
+	return FALSE;
       case (CELL)FunctorLongInt:
 	if (RepAppl(t1)[1] == RepAppl(t2)[1]) return(TRUE);
-	return(FALSE);
+	return FALSE;
       case (CELL)FunctorDouble:
 	if (FloatOfTerm(t1) == FloatOfTerm(t2)) return(TRUE);
-	return(FALSE);
+	return FALSE;
 #ifdef USE_GMP
       case (CELL)FunctorBigInt:
 	if (mpz_cmp(Yap_BigIntOfTerm(t1),Yap_BigIntOfTerm(t2)) == 0) return(TRUE);
 	return(FALSE);
 #endif /* USE_GMP */
       default:
-	return(FALSE);
+	return FALSE;
       }
     }
     /* Two complex terms with the same functor */
-    return(can_unify_complex(RepAppl(t1),
+    return can_unify_complex(RepAppl(t1),
 			     RepAppl(t1)+ArityOfFunctor(f),
-			     RepAppl(t2), Vars));
+			     RepAppl(t2), Vars);
   }
 }
 
@@ -1164,10 +1166,10 @@ static Int p_can_unify(void)
 #ifdef COROUTINING
   Term r = TermNil;
   if (!can_unify(ARG1, ARG2, &r))
-    return(FALSE);
+    return FALSE;
-  return (Yap_unify(ARG3, r));
+  return Yap_unify(ARG3, r);
 #else
-  return(FALSE);
+  return FALSE;
 #endif
 }
 

C/dbase.c

@@ -257,7 +257,6 @@ STATIC_PROTO(PredEntry *new_lu_entry, (Term));
 STATIC_PROTO(PredEntry *new_lu_int_key, (Int));
 STATIC_PROTO(PredEntry *find_lu_entry, (Term));
 STATIC_PROTO(DBProp find_int_key, (Int));
-STATIC_PROTO(Term  FetchTermFromDB, (DBTerm *, int));
 
 #if OS_HANDLES_TR_OVERFLOW
 #define db_check_trail(x)
@@ -4021,7 +4020,7 @@ p_instance(void)
     if (opc == _unify_idb_term) {
       return Yap_unify(ARG2, cl->ClSource->Entry);
     } else {
-      while ((TermDB = FetchTermFromDB(cl->ClSource, 2)) == TermNil) {
+      while ((TermDB = GetDBTerm(cl->ClSource)) == 0L) {
 	/* oops, we are in trouble, not enough stack space */
 	if (!Yap_gc(2, ENV, P)) {
 	  Yap_Error(OUT_OF_STACK_ERROR, TermNil, Yap_ErrorMessage);
@@ -4031,7 +4030,7 @@ p_instance(void)
       return Yap_unify(ARG2, TermDB);
     }
   } else {
-    while ((TermDB = GetDBTermFromDBEntry(dbr)) == (CELL)0) {
+    while ((TermDB = GetDBTermFromDBEntry(dbr)) == 0L) {
       /* oops, we are in trouble, not enough stack space */
       if (!Yap_gc(2, ENV, P)) {
 	Yap_Error(OUT_OF_STACK_ERROR, TermNil, Yap_ErrorMessage);
@@ -4250,24 +4249,10 @@ cont_current_key_integer(void)
   return(Yap_unify(term,ARG1) && Yap_unify(term,ARG2));
 }
 
-static Term 
-FetchTermFromDB(DBTerm *ref, int args)
-{
-  Term TDB;
-  while ((TDB = GetDBTerm(ref)) == (CELL)0) {
-    /* oops, we are in trouble, not enough stack space */
-    if (!Yap_gc(args, ENV, P)) {
-      Yap_Error(OUT_OF_STACK_ERROR, TermNil, Yap_ErrorMessage);
-      return(TermNil);
-    }
-  }
-  return(TDB);
-}
-
 Term 
-Yap_FetchTermFromDB(DBTerm *ref, int args)
+Yap_FetchTermFromDB(DBTerm *ref)
 {
-  return FetchTermFromDB(ref,args);
+  return GetDBTerm(ref);
 }
 
 static DBTerm *
@@ -4433,7 +4418,12 @@ p_dequeue(void)
     else
       father_key->FirstInQueue = cur_instance->next;
     WRITE_UNLOCK(father_key->QRWLock);
-    TDB = FetchTermFromDB(cur_instance->DBT, 2);
+    while ((TDB = GetDBTerm(cur_instance->DBT)) == 0L) {
+      if (!Yap_gc(2, YENV, P)) {
+	Yap_Error(OUT_OF_STACK_ERROR, TermNil, Yap_ErrorMessage);
+	return FALSE;
+      }
+    }
     /* release space for cur_instance */
     keepdbrefs(cur_instance->DBT);
     ErasePendingRefs(cur_instance->DBT);

H/YapOpcodes.h

@@ -138,7 +138,7 @@
     OPCODE(call_bfunc_yx           ,lxy),
     OPCODE(call_bfunc_yy           ,lyy),
     OPCODE(cut_t                   ,e),		
-    OPCODE(cut_e                   ,e),	
+    OPCODE(cut_e                   ,sla),	
     OPCODE(try_clause              ,ld),		
     OPCODE(retry                   ,ld),		
     OPCODE(trust                   ,ld),		

m4/Yatom.h.m4

@@ -487,7 +487,7 @@ int		STD_PROTO(Yap_RemoveIndexation,(PredEntry *));
 /* dbase.c */
 void		STD_PROTO(Yap_ErDBE,(DBRef));
 DBTerm	       *STD_PROTO(Yap_StoreTermInDB,(Term,int));
-Term		STD_PROTO(Yap_FetchTermFromDB,(DBTerm *,int));
+Term		STD_PROTO(Yap_FetchTermFromDB,(DBTerm *));
 void		STD_PROTO(Yap_ReleaseTermFromDB,(DBTerm *));
 
 /* init.c */

pl/preds.yap

@@ -293,9 +293,8 @@ clause(V,Q) :-
 	'$clause'(P,M,Q,_).
 
 clause(P,Q,R) :- db_reference(R), !,
-	'$instance_module'(R, M),
 	instance(R,T),
-	( T = (H :- B) -> P = M:H, Q = B ; P=M:T, Q = true).
+	( T = (H :- B) -> P = H, Q = B ; P=T, Q = true).
 clause(M:P,Q,R) :- !,
 	'$clause'(P,M,Q,R).
 clause(V,Q,R) :-