yap-commits — Logs of commits to the CVS

[Yap-commits] CVS: C mavar.c,1.4,1.5

[Vitor S. C. <vs...@us...>]

Update of /cvsroot/yap/C
In directory usw-pr-cvs1:/tmp/cvs-serv31838/C

Modified Files:
	mavar.c 
Log Message:
support for configure 2.5
recover memory in catch/throw.


Index: mavar.c
===================================================================
RCS file: /cvsroot/yap/C/mavar.c,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- mavar.c	2001/06/08 20:23:38	1.4
+++ mavar.c	2001/06/11 15:12:07	1.5
@@ -160,6 +160,11 @@
     else
 #endif
       tv->value = new;
+#if defined(SBA) || defined(TABLING)
+    if (Unsigned((Int)(tv)-(Int)(HBREG)) >
+      Unsigned(BBREG)-(Int)(HBREG))
+    TrailVal(timestmp-1) = new;
+#endif    
   } else {
     Term nclock = (Term)H;
     MaBind(&(tv->value), new);

[Yap-commits] CVS: C heapgc.c,1.16,1.17

[Vitor S. C. <vs...@us...>]

Update of /cvsroot/yap/C
In directory usw-pr-cvs1:/tmp/cvs-serv31281/C

Modified Files:
	heapgc.c 
Log Message:
fix big ints in gc
recount trail pointers that were reset in the previous step


Index: heapgc.c
===================================================================
RCS file: /cvsroot/yap/C/heapgc.c,v
retrieving revision 1.16
retrieving revision 1.17
diff -u -r1.16 -r1.17
--- heapgc.c	2001/06/08 19:33:16	1.16
+++ heapgc.c	2001/06/11 15:09:36	1.17
@@ -22,7 +22,9 @@
 #include "yapio.h"
 
 #define EARLY_RESET 1
+#ifndef TABLING
 #define EASY_SHUNTING 1
+#endif
 #define HYBRID_SCHEME 1
 
 
@@ -663,7 +665,7 @@
 #ifdef DEBUG
 
 #define INSTRUMENT_GC 1
-/* #define CHECK_CHOICEPOINTS 1 */
+#define CHECK_CHOICEPOINTS 1
 
 #ifdef INSTRUMENT_GC
 typedef enum {
@@ -969,9 +971,9 @@
 	  (sizeof(MP_INT)+
 	   (((MP_INT *)(next+1))->_mp_alloc*sizeof(mp_limb_t)))/CellSize;
 	{
-	  int i = 1;
+	  int i;
 	  PUSH_POINTER(next);
-	  for (i = 0; i <= (sizeof(MP_INT)+
+	  for (i = 1; i <= (sizeof(MP_INT)+
 		 (((MP_INT *)(next+1))->_mp_alloc*sizeof(mp_limb_t)))/CellSize;
 	       i++)
 	    PUSH_POINTER(next+i);
@@ -1198,6 +1200,10 @@
     
     trail_cell = TrailTerm(trail_ptr);
 
+    if (trail_cell == 0xa0000006) {
+      printf("Oops at %p->%x\n", trail_ptr, trail_cell);
+    }      
+
     if (IsVarTerm(trail_cell)) {
       CELL *hp = (CELL *)trail_cell;
       /* if a variable older than the current CP has not been marked yet,
@@ -1230,6 +1236,8 @@
 #endif
 	discard_trail_entries++;
       } else {
+	if (trail_cell == (CELL)trail_ptr)
+	  discard_trail_entries++;
 #ifdef EASY_SHUNTING
 	if (hp < gc_H   && hp >= H0) {
 	  CELL *cptr = (CELL *)trail_cell;
@@ -1773,6 +1781,8 @@
 	    (ADDR) pt0 >= TrailBase
 #endif
 	    ) {
+	  trail_ptr++;
+	  dest++;
 	  continue;
 	}
 #endif /* FROZEN_REGS */

[Yap-commits] CVS: C mavar.c,1.3,1.4

[Vitor S. C. <vs...@us...>]

Update of /cvsroot/yap/C
In directory usw-pr-cvs1:/tmp/cvs-serv28379/C

Modified Files:
	mavar.c 
Log Message:
Partial update of tabling/SBA code to new timestamp


Index: mavar.c
===================================================================
RCS file: /cvsroot/yap/C/mavar.c,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- mavar.c	2001/06/06 19:10:50	1.3
+++ mavar.c	2001/06/08 20:23:38	1.4
@@ -149,7 +149,7 @@
 
   if (B->cp_h <= timestmp
 #if defined(SBA) || defined(TABLING)
-      && timestmp <= (CELL)H
+      && timestmp <= H
 #endif
       ) {
     /* last assignment more recent than last B */
@@ -160,11 +160,6 @@
     else
 #endif
       tv->value = new;
-#if defined(SBA) || defined(TABLING)
-    if (Unsigned((Int)(tv)-(Int)(HBREG)) >
-      Unsigned(BBREG)-(Int)(HBREG))
-    TrailVal(timestmp-1) = new;
-#endif    
   } else {
     Term nclock = (Term)H;
     MaBind(&(tv->value), new);

[Yap-commits] CVS: OPTYap tab.insts.i,1.1.1.1,1.2

[Vitor S. C. <vs...@us...>]

Update of /cvsroot/yap/OPTYap
In directory usw-pr-cvs1:/tmp/cvs-serv26985/OPTYap

Modified Files:
	tab.insts.i 
Log Message:
TRAIL_REF changed to TRAIL_LINK


Index: tab.insts.i
===================================================================
RCS file: /cvsroot/yap/OPTYap/tab.insts.i,v
retrieving revision 1.1.1.1
retrieving revision 1.2
diff -u -r1.1.1.1 -r1.2
--- tab.insts.i	2001/04/09 19:53:53	1.1.1.1
+++ tab.insts.i	2001/06/08 20:21:59	1.2
@@ -808,7 +808,7 @@
 #endif /* TABLING_ERRORS */
           B = chain_cp;
           TR = TR_FZ;
-          TRAIL_REF(B->cp_tr);
+          TRAIL_LINK(B->cp_tr);
           consume_answer_and_procceed(dep_fr, ans_node);
 	}
         UNLOCK(DepFr_lock(dep_fr));
@@ -903,7 +903,7 @@
 #endif /* YAPOR */
           B = chain_cp;
           TR = TR_FZ;
-          TRAIL_REF(B->cp_tr);
+          TRAIL_LINK(B->cp_tr);
           goto completion;
 	}
       }
@@ -912,7 +912,7 @@
       PREFETCH_OP(PREG);
       B = chain_cp;
       TR = TR_FZ;
-      TRAIL_REF(B->cp_tr);
+      TRAIL_LINK(B->cp_tr);
       GONext();
     }
     END_PREFETCH()
@@ -1058,7 +1058,7 @@
         B = DepFr_cons_cp(dep_fr);
         TR = TR_FZ;
         if (TR != B->cp_tr)
-          TRAIL_REF(B->cp_tr);
+          TRAIL_LINK(B->cp_tr);
         consume_answer_and_procceed(dep_fr, ans_node);
       }
       UNLOCK(DepFr_lock(dep_fr));
@@ -1097,7 +1097,7 @@
               B = LOCAL_top_cp;
               SET_BB(B_FZ);
               TR = TR_FZ;
-              TRAIL_REF(B->cp_tr);
+              TRAIL_LINK(B->cp_tr);
               goto completion;
             }
             LOCAL_top_susp_or_fr = OrFr_nearest_suspnode(susp_or_fr);
@@ -1132,7 +1132,7 @@
             B = LOCAL_top_cp;
             SET_BB(B_FZ);
             TR = TR_FZ;
-            TRAIL_REF(B->cp_tr);
+            TRAIL_LINK(B->cp_tr);
             goto completion;
           }
           LOCAL_top_susp_or_fr = OrFr_nearest_suspnode(susp_or_fr);

[Yap-commits] CVS: C heapgc.c,1.15,1.16

[Vitor S. C. <vs...@us...>]

Update of /cvsroot/yap/C
In directory usw-pr-cvs1:/tmp/cvs-serv18782/C

Modified Files:
	heapgc.c 
Log Message:
fix divide by zero error on debugging message if trail was empty


Index: heapgc.c
===================================================================
RCS file: /cvsroot/yap/C/heapgc.c,v
retrieving revision 1.15
retrieving revision 1.16
diff -u -r1.15 -r1.16
--- heapgc.c	2001/06/08 14:52:53	1.15
+++ heapgc.c	2001/06/08 19:33:16	1.16
@@ -1851,11 +1851,12 @@
   }
   new_TR = dest;
   if (is_gc_verbose()) {
-    YP_fprintf(YP_stderr,
-	       "[GC]       Trail: discarded %d (%ld%%) cells out of %ld\n",
-	       discard_trail_entries,
-	       (unsigned long int)(discard_trail_entries*100/(old_TR-(tr_fr_ptr)TrailBase)),
-	       (unsigned long int)(old_TR-(tr_fr_ptr)TrailBase));
+    if (old_TR != (tr_fr_ptr)TrailBase)
+      YP_fprintf(YP_stderr,
+		 "[GC]       Trail: discarded %d (%ld%%) cells out of %ld\n",
+		 discard_trail_entries,
+		 (unsigned long int)(discard_trail_entries*100/(old_TR-(tr_fr_ptr)TrailBase)),
+		 (unsigned long int)(old_TR-(tr_fr_ptr)TrailBase));
 #ifdef DEBUG
     if (hp_entrs > 0)
       YP_fprintf(YP_stderr,

[Yap-commits] CVS: C arrays.c,1.3,1.4

[Vitor S. C. <vs...@us...>]

Update of /cvsroot/yap/C
In directory usw-pr-cvs1:/tmp/cvs-serv17064/C

Modified Files:
	arrays.c 
Log Message:
access_array_element is unsafe


Index: arrays.c
===================================================================
RCS file: /cvsroot/yap/C/arrays.c,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- arrays.c	2001/06/08 19:10:43	1.3
+++ arrays.c	2001/06/08 19:22:35	1.4
@@ -1637,7 +1637,7 @@
   InitCPred("resize_static_array", 3, p_resize_static_array, SafePredFlag|SyncPredFlag);
   InitCPred("mmapped_array", 4, p_create_mmapped_array, SafePredFlag|SyncPredFlag);
   InitCPred("update_array", 3, p_assign_static, SafePredFlag);
-  InitCPred("array_element", 3, p_access_array, SafePredFlag);
+  InitCPred("array_element", 3, p_access_array, 0);
   InitCPred("close_static_array", 1, p_close_static_array, SafePredFlag);
   InitCPred("$sync_mmapped_arrays", 0, p_sync_mmapped_arrays, SafePredFlag);
   InitCPred("$compile_array_refs", 0, p_compile_array_refs, SafePredFlag);

[Yap-commits] CVS: pl boot.yap,1.8,1.9

[Vitor S. C. <vs...@us...>]

Update of /cvsroot/yap/pl
In directory usw-pr-cvs1:/tmp/cvs-serv13822/pl

Modified Files:
	boot.yap 
Log Message:
use arrays to implement catch and throw instead of record
cleanup queues at top-level and at catch-throw.


Index: boot.yap
===================================================================
RCS file: /cvsroot/yap/pl/boot.yap,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -r1.8 -r1.9
--- boot.yap	2001/06/06 19:10:51	1.8
+++ boot.yap	2001/06/08 19:10:43	1.9
@@ -43,6 +43,7 @@
 	),
 	'$set_yap_flags'(10,0),
 	'$set_value'('$gc',on),
+	'$init_catch',
 	prompt('  ?- '),
 	(
 	    '$get_value'('$break',0)
@@ -61,13 +62,25 @@
 		( exists('~/prolog.ini') -> [-'~/prolog.ini'] ; true )
 	    ),
 	    '$clean_catch_and_throw',
+	    '$db_clean_queues'(0),
 	    '$startup_reconsult',
 	    '$startup_goals'
 	;
 	    true
 	).
 
-%
+'$init_catch' :-
+	% initialise access to the catch queue
+	( '$has_static_array'('$catch_queue') ->
+	    true
+	;
+	    static_array('$catch_queue',2, term)
+	),
+	update_array('$catch_queue', 0, '$'),
+	update_array('$catch_queue', 1, '$').
+
+
+				%
 % encapsulate $cut_by because of co-routining.
 %
 '$cut_by'(X) :- '$$cut_by'(X).
@@ -1122,9 +1135,9 @@
 	'$catch'(G,C,A).
 
 '$catch'(G,C,A) :-
-	'$get_value'('$catch_counter', I),
+	'$get_value'('$catch', I),
 	I1 is I+1,
-	'$set_value'('$catch_counter', I1),
+	'$set_value'('$catch', I1),
 	'$current_module'(M),
 	'$catch'(G,C,A,I,M).
 
@@ -1134,23 +1147,35 @@
 	'$catch_call'(X,G,I).
 % someone sent us a throw.
 '$catch'(_,C,A,_,M) :-
-        ('$recorded'('$throw',X,R)->true),
-        erase(R),
+	array_element('$catch_queue', 1, X), X \= '$',
+	update_array('$catch_queue', 1, '$'),
+	array_element('$catch_queue', 0, catch(_,Lev,Q)),
+	update_array('$catch_queue', 0, Q),
+	'$db_clean_queues'(Lev),
         ( C=X -> '$current_module'(_,M), '$execute'(A) ; throw(X)).
 % normal exit: make sure we only erase what we should erase!
 '$catch'(_,_,_,I,_) :-
-        '$recorded'('$catch','$catch'(_,J),R), J >= I,
-        erase(R), fail.
+	array_element('$catch_queue', 0, OldCatch),
+	'$erase_catch_elements'(OldCatch, I, Catch),
+	update_array('$catch_queue', 0, Catch),
+	fail.
 
+'$erase_catch_elements'(catch(X, J, P), I, Catch) :-
+          J >= I, !,
+	  '$erase_catch_elements'(P, I, Catch).
+'$erase_catch_elements'(Catch, _, Catch).
+	  
 '$catch_call'(X,G,I) :-
-        '$recorda'('$catch','$catch'(X,I),_),
+	array_element('$catch_queue', 0, OldCatch),
+	update_array('$catch_queue', 0, catch(X,I,OldCatch)),
         '$execute'(G),
         ( % on exit remove the catch
-          ('$recorded'('$catch','$catch'(X,I),R)->true),
-          erase(R)
+	  array_element('$catch_queue', 0, catch(X,I,Catch)),
+	  update_array('$catch_queue', 0, Catch)
         ;
           % on backtracking reinstate the catch before backtracking to G
-          '$recorda'('$catch','$catch'(X,I),_),
+	  array_element('$catch_queue', 0, Catch),
+	  update_array('$catch_queue', 0, catch(X,I,Catch)),
           fail
         ).
 
@@ -1161,9 +1186,9 @@
 % also avoids module preprocessing and goal_expansion
 %
 '$system_catch'(G,C,A) :-
-	'$get_value'('$catch_counter', I),
+	'$get_value'('$catch', I),
 	I1 is I+1,
-	'$set_value'('$catch_counter', I1),
+	'$set_value'('$catch', I1),
 	'$current_module'(M),
 	'$system_catch'(G,C,A,I,M).
 
@@ -1173,8 +1198,11 @@
 	'$system_catch_call'(X,G,I).
 % someone sent us a throw.
 '$system_catch'(_,C,A,_,M0) :-
-        ('$recorded'('$throw',X,R)->true),
-        erase(R),
+	array_element('$catch_queue', 1, X), X \= '$',
+	update_array('$catch_queue', 1, '$'),
+	array_element('$catch_queue', 0, catch(_,Lev,Q)),
+	'$db_clean_queues'(Lev),
+	update_array('$catch_queue', 0, Q),
         ( C=X ->
 	    '$current_module'(_,M0),
 	    (A = M:G -> '$mod_switch'(M,G) ; '$mod_switch'(M0,A))
@@ -1183,27 +1211,30 @@
         ).
 % normal exit: make sure we only erase what we should erase!
 '$system_catch'(_,_,_,I,_) :-
-        '$recorded'('$catch','$catch'(_,J),R), J >= I,
-        erase(R), fail.
+	array_element('$catch_queue', 0, OldCatch),
+	'$erase_catch_elements'(OldCatch, I, Catch),
+	update_array('$catch_queue', 0, Catch),
+	fail.
 
 '$system_catch_call'(X,G,I) :-
-        '$recorda'('$catch','$catch'(X,I),_),
+	array_element('$catch_queue', 0, OldCatch),
+	update_array('$catch_queue', 0, catch(X,I,OldCatch)),
         '$execute0'(G),
         ( % on exit remove the catch
-          ('$recorded'('$catch','$catch'(X,I),R)->true),
-          erase(R)
+	  array_element('$catch_queue', 0, catch(X,I,Catch)),
+	  update_array('$catch_queue', 0, Catch)
         ;
           % on backtracking reinstate the catch before backtracking to G
-          '$recorda'('$catch','$catch'(X,I),_),
+	  array_element('$catch_queue', 0, Catch),
+	  update_array('$catch_queue', 0, catch(X,I,Catch)),
           fail
         ).
 
 throw(A) :-
 	% fetch the point to jump to
-        '$recorded'('$catch','$catch'(X,_),R), !,
-        erase(R),
+	array_element('$catch_queue', 0, catch(X,_,_)), !,
 	% now explain why we are jumping.
-        '$recordz'('$throw',A,_),
+	update_array('$catch_queue', 1, A),
         '$$cut_by'(X),
         fail.
 throw(G) :-
@@ -1218,7 +1249,7 @@
 	throw(error(type_error(list,S),T)).
 
 '$clean_catch_and_throw' :-
-	'$set_value'('$catch_counter', 0),
+	'$set_value'('$catch', 0),
 	fail.
 '$clean_catch_and_throw' :-
 	'$recorded'('$catch',_,R),

[Yap-commits] CVS: C arrays.c,1.2,1.3 dbase.c,1.4,1.5 init.c,1.6,1.7 save.c,1.9,1.10 sysbits.c,1.3,1.4

[Vitor S. C. <vs...@us...>]

Update of /cvsroot/yap/C
In directory usw-pr-cvs1:/tmp/cvs-serv13822/C

Modified Files:
	arrays.c dbase.c init.c save.c sysbits.c 
Log Message:
use arrays to implement catch and throw instead of record
cleanup queues at top-level and at catch-throw.


Index: arrays.c
===================================================================
RCS file: /cvsroot/yap/C/arrays.c,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -r1.2 -r1.3
--- arrays.c	2001/06/08 14:52:53	1.2
+++ arrays.c	2001/06/08 19:10:43	1.3
@@ -771,6 +771,36 @@
   }
 }
 
+/* has a static array associated (+Name) */
+static Int 
+p_has_static_array(void)
+{
+  Term t = Deref(ARG1);
+
+  if (IsVarTerm(t)) {
+    return (FALSE);
+  }
+  else if (IsAtomTerm(t)) {
+    /* Create a named array */
+    AtomEntry *ae = RepAtom(AtomOfTerm(t));
+    StaticArrayEntry *pp;
+
+    READ_LOCK(ae->ARWLock);
+    pp = RepStaticArrayProp(ae->PropOfAE);
+    while (!EndOfPAEntr(pp) && pp->KindOfPE != ArrayProperty)
+      pp = RepStaticArrayProp(pp->NextOfPE);
+    if (EndOfPAEntr(pp) || pp->ValueOfVE.ints == NULL) {
+      READ_UNLOCK(ae->ARWLock);
+      return (FALSE);
+    } else {
+      READ_UNLOCK(ae->ARWLock);
+      return(TRUE);
+    }
+  } else {
+    return (FALSE);
+  }
+}
+
 /* resize a static array (+Name, + Size, +Props) */
 /* does not work for mmap arrays yet */
 static Int 
@@ -1369,7 +1399,7 @@
     Error(INSTANTIATION_ERROR,t3,"assign_static");
     return (FALSE);
   }
-  if (indx < 0 || indx >= - ptr->ArrayEArity) {
+   if (indx < 0 || indx >= - ptr->ArrayEArity) {
     WRITE_UNLOCK(ptr->ArRWLock);
     Error(DOMAIN_ERROR_ARRAY_OVERFLOW,t2,"assign_static");
   }
@@ -1543,6 +1573,60 @@
   return(TRUE);
 }
 
+/*
+  This is a hack, to steal the first element of a key.
+
+   It first fetches the first element in the chain, and then erases it
+   through its reference.
+
+  Be careful when using this routine. It is especially evil because if
+  the term is ground it should be copied to the stack, as space for
+  the entry may be deleted. For the moment, the terms I want are just
+  integers, so no problemo, amigo.
+
+ */
+static Term
+StealFirstFromDB(DBRef ref)
+{
+  Term TermDB, out;
+
+  if ((TermDB = FetchTermFromDB(ref,3)) == (CELL)0) {
+    /* oops, we are in trouble, not enough stack space */
+    return(TermNil);
+  }
+  if (IsVarTerm(TermDB) || !IsApplTerm(TermDB))
+    /* it's not a wonderful world afterall */
+    return(TermNil);
+  out = ArgOfTerm(1,TermDB);
+  /* now, return what once was there, only nevermore */
+  return(out);
+}
+
+Int
+SetDBForThrow(Term Message)
+{
+  Term cut_pt_term;
+  Atom a = FullLookupAtom("$catch_queue");
+  AtomEntry *ae = RepAtom(a);
+  StaticArrayEntry *ptr;
+  DBRef ref;
+  READ_LOCK(ae->ARWLock);
+  ptr =  RepStaticArrayProp(ae->PropOfAE);    
+  while (!EndOfPAEntr(ptr) && ptr->KindOfPE != ArrayProperty)
+    ptr = RepStaticArrayProp(ptr->NextOfPE);
+  READ_UNLOCK(ae->ARWLock);
+  ref = ptr->ValueOfVE.terms[0];
+
+  cut_pt_term = StealFirstFromDB(ref);
+  if (IsVarTerm(cut_pt_term) || !IsIntegerTerm(cut_pt_term)) {
+    /* ooops, babe we are in trouble */
+    return(-1);
+  }
+  /* OK, we've got the place to cut to, next store the new throw */
+  ptr->ValueOfVE.terms[1] = StoreTermInDB(Message,3);
+  return(IntegerOfTerm(cut_pt_term));  
+}
+
 void 
 InitArrayPreds(void)
 {
@@ -1558,5 +1642,6 @@
   InitCPred("$sync_mmapped_arrays", 0, p_sync_mmapped_arrays, SafePredFlag);
   InitCPred("$compile_array_refs", 0, p_compile_array_refs, SafePredFlag);
   InitCPred("$array_refs_compiled", 0, p_array_refs_compiled, SafePredFlag);
+  InitCPred("$has_static_array", 1, p_has_static_array, TestPredFlag|SafePredFlag);
 }
 

Index: dbase.c
===================================================================
RCS file: /cvsroot/yap/C/dbase.c,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- dbase.c	2001/06/08 14:52:53	1.4
+++ dbase.c	2001/06/08 19:10:43	1.5
@@ -114,7 +114,7 @@
 }               SFKeep;
 #endif
 
-typedef struct
+typedef struct idb_queue
 {
   Functor id;		/* identify this as being pointed to by a DBRef */
   Term	EntryTerm;	/* cell bound to itself			*/
@@ -123,6 +123,8 @@
   rwlock_t    QRWLock;         /* a simple lock to protect this entry */
 #endif
   DBRef FirstInQueue, LastInQueue;
+  Int age;        /* the number of catches when we created the queue */
+  struct idb_queue *next, *prev;
 }  db_queue;
 
 #define HashFieldMask		((CELL)0xffL)
@@ -263,7 +265,6 @@
 STATIC_PROTO(Int  p_first_age, (void));
 STATIC_PROTO(Int  p_db_nb_to_ref, (void));
 STATIC_PROTO(Int  p_last_age, (void));
-STATIC_PROTO(Term StealFirstFromDB, (Atom, Int));
 
 #if OS_HANDLES_TR_OVERFLOW
 #define check_trail(x)
@@ -3451,24 +3452,6 @@
   return (TRUE);
 }
 
-/* erase(+Ref)	 */
-static Int 
-p_smash(void)
-{
-  Term t1 = Deref(ARG1);
-
-  if (IsVarTerm(t1)) {
-    Error(INSTANTIATION_ERROR, t1, "erase");
-    return (FALSE);
-  }
-  if (!IsDBRefTerm(t1)) {
-    Error(TYPE_ERROR_DBREF, t1, "erase");
-    return (FALSE);
-  }
-  EraseEntry(DBRefOfTerm(t1));
-  return (TRUE);
-}
-
 /* eraseall(+Key)	 */
 static Int 
 p_eraseall(void)
@@ -3799,7 +3782,7 @@
   db_queue *dbq;
   Term t;
 
-  while ((dbq = (db_queue *)AllocDBSpace(sizeof(db_queue))) == NIL) {
+  while ((dbq = (db_queue *)AllocDBSpace(sizeof(db_queue))) == NULL) {
     if (!growheap(FALSE)) {
       Abort("[ SYSTEM ERROR: YAP failed to reserve space in growheap ]\n");
       return(FALSE);
@@ -3808,12 +3791,17 @@
   dbq->id = FunctorDBRef;
   dbq->EntryTerm = MkAtomTerm(AbsAtom((AtomEntry *)dbq));
   dbq->Flags = DBClMask;
-  dbq->FirstInQueue = dbq->LastInQueue = NIL;
+  dbq->FirstInQueue = dbq->LastInQueue = NULL;
+  dbq->next = DBQueues;
+  dbq->prev = NULL;
+  DBQueues = dbq;
+  dbq->age = IntOfTerm(GetValue(AtomCatch));
   INIT_RWLOCK(dbq->QRWLock);
   t = MkDBRefTerm((DBRef)dbq);
   return(unify(ARG1, t));
 }
 
+
 static Int 
 p_enqueue(void)
 {
@@ -3887,6 +3875,12 @@
   WRITE_LOCK(father_key->QRWLock);
   if ((cur_instance = father_key->FirstInQueue) == NIL) {
     /* an empty queue automatically goes away */
+    if (father_key == DBQueues)
+      DBQueues = father_key->next;
+    else 
+      father_key->prev->next = father_key->next;
+    if (father_key->next != NULL)
+      father_key->next->prev = father_key->prev;
     WRITE_UNLOCK(father_key->QRWLock);
     FreeDBSpace((char *) father_key);
     return(FALSE);
@@ -3906,78 +3900,35 @@
     return(unify(ARG2, TDB));
   }
 }
-
-/*
-  This is a hack, to steal the first element of a key.
 
-   It first fetches the first element in the chain, and then erases it
-   through its reference.
-
-  Be careful when using this routine. It is especially evil because if
-  the term is ground it should be copied to the stack, as space for
-  the entry may be deleted. For the moment, the terms I want are just
-  integers, so no problemo, amigo.
-
- */
-static Term
-StealFirstFromDB(Atom key, Int arity)
+static Int
+p_clean_queues(void)
 {
-  Prop            AtProp;
-  Register DBRef  ref;
-  Term            TermDB;
-  Term out;
-
-  /* get the DB property */
-  if ((AtProp = FindDBProp(RepAtom(key), 0, arity)) == NIL) {
-    return(TermNil);
-  }
-  /* get the first entry */
-#ifdef KEEP_OLD_ENTRIES_HANGING_ABOUT
-  ref = RepDBProp(AtProp)->FirstNEr;
-#else
-  ref = RepDBProp(AtProp)->First;
-#endif
-  /* is there anyone home ? */
-  while (ref != NIL
-	 && (ref->Flags & (DBCode | ErasedMask)))
-    ref = NextDBRef(ref);
-  if (ref == NIL) {
-    return(TermNil);
-  }
-  /* get our fine  term */
-  if ((TermDB = GetDBTerm(ref)) == (CELL)0) {
-    /* oops, we are in trouble, not enough stack space */
-    return(TermNil);
+  Int myage = IntOfTerm(ARG1);
+  db_queue *ptr;
+  YAPEnterCriticalSection();
+  ptr = DBQueues;
+  while (ptr) {
+    if (ptr->age >= myage) {
+      DBRef cur_instance;
+      db_queue *optr = ptr;
+
+      while ((cur_instance = ptr->FirstInQueue)) {
+	/* release space for cur_instance */
+	ptr->FirstInQueue = (DBRef)(cur_instance->Parent);	
+	ErasePendingRefs(cur_instance);
+	FreeDBSpace((char *) cur_instance);
+      }
+      ptr = ptr->next;
+      FreeDBSpace((char *) optr);
+    } else
+      break;
   }
-  if (IsVarTerm(TermDB) || !IsApplTerm(TermDB))
-    /* it's not a wonderful world afterall */
-    return(TermNil);
-  
-  out = ArgOfTerm(1,TermDB);
-  /* next, make it disappear from the DB */
-  EraseEntry(ref);
-  /* now, return what once was there, only nevermore */
-  return(out);
-}
-
-Int
-SetDBForThrow(Term Message)
-{
-  Term cut_pt_term;
-
-  /* who's gonna catch us? */
-  DBModule = 0;
-  cut_pt_term = StealFirstFromDB(AtomCatch, 0);
-  if (IsVarTerm(cut_pt_term) || !IsIntegerTerm(cut_pt_term)) {
-    /* ooops, babe we are in trouble */
-    return(-1);
-  }
-  /* OK, we've got the place to cut to, next store the new throw */
-  if (record(MkFirst, MkAtomTerm(AtomThrow), Message, TermNil) == NIL)
-    return (-1);
-  else
-    /* off we go, to see the wizard of Oz */
-    return(IntegerOfTerm(cut_pt_term));  
+  if (ptr)
+    ptr->prev = NULL;
+  DBQueues = ptr;
+  YAPLeaveCriticalSection();
+  return(TRUE);
 }
 
 /* given a key, find the clock number for the first entry */
@@ -4187,7 +4138,6 @@
   InitCPred("$recordzp", 4, p_drcdzp, SafePredFlag|SyncPredFlag);
   InitCPred("$recordaifnot", 3, p_rcdaifnot, SafePredFlag|SyncPredFlag);
   InitCPred("$recordzifnot", 3, p_rcdzifnot, SafePredFlag|SyncPredFlag);
-  InitCPred("$db_smash", 1, p_smash, SafePredFlag|SyncPredFlag);
   InitCPred("erase", 1, p_erase, SafePredFlag|SyncPredFlag);
   InitCPred("erased", 1, p_erased, TestPredFlag | SafePredFlag|SyncPredFlag);
   InitCPred("instance", 2, p_instance, SyncPredFlag);
@@ -4199,6 +4149,7 @@
   InitCPred("$db_key", 2, p_db_key, 0);
   InitCPred("$db_enqueue", 2, p_enqueue, SyncPredFlag);
   InitCPred("$db_dequeue", 2, p_dequeue, SyncPredFlag);
+  InitCPred("$db_clean_queues", 1, p_clean_queues, SyncPredFlag);
   InitCPred("$db_first_age", 2, p_first_age, TestPredFlag|SafePredFlag|SyncPredFlag);
   InitCPred("$db_nb_to_ref", 3, p_db_nb_to_ref, TestPredFlag|SafePredFlag);
   InitCPred("$db_last_age", 2, p_last_age, TestPredFlag|SafePredFlag|SyncPredFlag);

Index: init.c
===================================================================
RCS file: /cvsroot/yap/C/init.c,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -r1.6 -r1.7
--- init.c	2001/06/06 19:10:50	1.6
+++ init.c	2001/06/08 19:10:43	1.7
@@ -820,6 +820,7 @@
   heap_regs->no_of_modules = 1;
   heap_regs->primitives_module = 0;
   heap_regs->user_module = 1;
+  heap_regs->db_queues = NULL;
   heap_regs->atom_abol = LookupAtom("$abol");
   AtomAltNot = LookupAtom("not");
   heap_regs->atom_append = LookupAtom ("append");

Index: save.c
===================================================================
RCS file: /cvsroot/yap/C/save.c,v
retrieving revision 1.9
retrieving revision 1.10
diff -u -r1.9 -r1.10
--- save.c	2001/06/08 14:52:53	1.9
+++ save.c	2001/06/08 19:10:43	1.10
@@ -944,6 +944,10 @@
     heap_regs->dead_clauses = (Clause *)
       AddrAdjust((ADDR)(heap_regs->dead_clauses));
   }
+  if (heap_regs->db_queues != NULL) {
+    heap_regs->db_queues = (struct idb_queue *)
+      AddrAdjust((ADDR)(heap_regs->db_queues));
+  }
   heap_regs->retry_recorded_code = 
     PtoOpAdjust(heap_regs->retry_recorded_code);
   heap_regs->retry_recorded_k_code =

Index: sysbits.c
===================================================================
RCS file: /cvsroot/yap/C/sysbits.c,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- sysbits.c	2001/05/21 20:00:05	1.3
+++ sysbits.c	2001/06/08 19:10:43	1.4
@@ -1099,7 +1099,7 @@
 	    if (in_readline) {
 	      /* readline must eat a newline, otherwise we will
 		 have to wait before we do the Abort() */
-	    } else {
+	    } else if (!(PrologMode & CritMode)) {
 #endif
 #if defined(__MINGW32__) || _MSC_VER
 	      /* we can't do a direct abort, so ask the system to do it for us */

[Yap-commits] CVS: H Heap.h,1.4,1.5

[Vitor S. C. <vs...@us...>]

Update of /cvsroot/yap/H
In directory usw-pr-cvs1:/tmp/cvs-serv13822/H

Modified Files:
	Heap.h 
Log Message:
use arrays to implement catch and throw instead of record
cleanup queues at top-level and at catch-throw.


Index: Heap.h
===================================================================
RCS file: /cvsroot/yap/H/Heap.h,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- Heap.h	2001/06/08 13:38:42	1.4
+++ Heap.h	2001/06/08 19:10:43	1.5
@@ -133,6 +133,7 @@
 #endif
   int   primitives_module;
   int   user_module;
+  struct idb_queue *db_queues;
   Atom
     atom_abol,
     atom_alarm,
@@ -316,6 +317,7 @@
 #define  ModuleName               heap_regs->module_name
 #define  PrimitivesModule         heap_regs->primitives_module
 #define  UserModule               heap_regs->user_module
+#define  DBQueues                 heap_regs->db_queues
 #define  NoOfModules              heap_regs->no_of_modules
 #define  AtomAbol                 heap_regs->atom_abol
 #define  AtomAlarm                heap_regs->atom_alarm

[Yap-commits] CVS: changes4.3.html,1.25,1.26

[Vitor S. C. <vs...@us...>]

Update of /cvsroot/yap
In directory usw-pr-cvs1:/tmp/cvs-serv13822

Modified Files:
	changes4.3.html 
Log Message:
use arrays to implement catch and throw instead of record
cleanup queues at top-level and at catch-throw.

[Yap-commits] CVS: C attvar.c,1.4,1.5

[Luis C. <lfc...@us...>]

Update of /cvsroot/yap/C
In directory usw-pr-cvs1:/tmp/cvs-serv3837

Modified Files:
	attvar.c 
Log Message:
* the previous typo correction seemed to be reversed, so...


Index: attvar.c
===================================================================
RCS file: /cvsroot/yap/C/attvar.c,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- attvar.c	2001/06/08 18:16:07	1.4
+++ attvar.c	2001/06/08 18:21:35	1.5
@@ -199,10 +199,10 @@
 static Int
 PutAtt(attvar_record *attv, Int i, Term tatt) {
   Int pos = i*2;
-  CELL *timestamp = (CELL *)(attv->Atts[pos]);
-  if (B->cp_h <= timestamp
+  CELL *timestmp = (CELL *)(attv->Atts[pos]);
+  if (B->cp_h <= timestmp
 #if defined(SBA) || defined(TABLING)
-      && timestamp <= H
+      && timestmp <= H
 #endif
     ) {
 #if defined(SBA)

[Yap-commits] CVS: C attvar.c,1.3,1.4

[Luis C. <lfc...@us...>]

Update of /cvsroot/yap/C
In directory usw-pr-cvs1:/tmp/cvs-serv3007

Modified Files:
	attvar.c 
Log Message:
* fixed a typo in PutAtt (timestmp -> timestamp)


Index: attvar.c
===================================================================
RCS file: /cvsroot/yap/C/attvar.c,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- attvar.c	2001/06/06 19:10:50	1.3
+++ attvar.c	2001/06/08 18:16:07	1.4
@@ -202,7 +202,7 @@
   CELL *timestamp = (CELL *)(attv->Atts[pos]);
   if (B->cp_h <= timestamp
 #if defined(SBA) || defined(TABLING)
-      && timestmp <= H
+      && timestamp <= H
 #endif
     ) {
 #if defined(SBA)