valgrind it!

enable atom garbage collection.


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

C/absmi.c

@@ -10,8 +10,11 @@
 *									 *
 * File:		absmi.c							 *
 * comments:	Portable abstract machine interpreter                    *
-* Last rev:     $Date: 2007-11-28 23:52:14 $,$Author: vsc $						 *
+* Last rev:     $Date: 2008-01-23 17:57:44 $,$Author: vsc $						 *
 * $Log: not supported by cvs2svn $
+* Revision 1.232  2007/11/28 23:52:14  vsc
+* junction tree algorithm
+*
 * Revision 1.231  2007/11/26 23:43:07  vsc
 * fixes to support threads and assert correctly, even if inefficiently.
 *
@@ -751,6 +754,7 @@ Yap_absmi(int inp)
 	CELL cut_b = LCL0-(CELL *)(SREG[E_CB]);
 
 	saveregs();
+	/* do a garbage collection first to check if we can recover memory */
 	if (!Yap_growheap(FALSE, 0, NULL)) {
 	  Yap_Error(OUT_OF_HEAP_ERROR, TermNil, "YAP failed to grow heap: %s", Yap_ErrorMessage);
 	  setregs();
@@ -11514,6 +11518,7 @@ Yap_absmi(int inp)
 	 */
 	HBREG = H;
 	B = (choiceptr) H;
+	B->cp_h = H;
 	SET_BB(B);
 	save_hb();
 	opresult = Yap_IUnify(d0, d1);

C/agc.c

@@ -270,7 +270,7 @@ mark_trail(void)
 static void
 mark_local(void)
 {
-  register CELL   *pt;
+  CELL   *pt;
 
   /* Adjusting the local */
   pt = LCL0;
@@ -434,9 +434,12 @@ atom_gc(void)
   
 
   UInt		time_start, agc_time;
+#if  defined(YAPOR) || defined(THREADS)
   return;
+#endif
   if (Yap_GetValue(AtomGcTrace) != TermNil)
     gc_trace = 1;
+
   agc_calls++;
   agc_collected = 0;
   

C/alloc.c

@@ -12,7 +12,7 @@
 * Last rev:								 *
 * mods:									 *
 * comments:	allocating space					 *
-* version:$Id: alloc.c,v 1.86 2006-05-19 14:31:31 vsc Exp $		 *
+* version:$Id: alloc.c,v 1.87 2008-01-23 17:57:44 vsc Exp $		 *
 *************************************************************************/
 #ifdef SCCS
 static char SccsId[] = "%W% %G%";
@@ -171,9 +171,11 @@ Yap_ExpandPreAllocCodeSpace(UInt sz0, void *cip)
   UInt sz = ScratchPad.msz;
   if (sz0 < SCRATCH_INC_SIZE)
     sz0 = SCRATCH_INC_SIZE;
-  ScratchPad.msz =
+  if (sz0 < ScratchPad.sz)
-    ScratchPad.sz =
+    sz = ScratchPad.sz+sz0;
-    sz = sz + sz0;
+  else 
+    sz = sz0;
+  sz = AdjustLargePageSize(sz+sz/4);
 
 #if INSTRUMENT_MALLOC
   if (reallocs % 1024*4 == 0) 
@@ -214,6 +216,8 @@ void
 Yap_InitHeap(void *heap_addr)
 {
   InitHeap();
+  Yap_HoleSize = 0;
+  HeapMax = 0;
 }
 
 static void

C/amasm.c

@@ -11,8 +11,11 @@
 * File:		amasm.c							 *
 * comments:	abstract machine assembler				 *
 *									 *
-* Last rev:     $Date: 2007-11-26 23:43:07 $							 *
+* Last rev:     $Date: 2008-01-23 17:57:44 $							 *
 * $Log: not supported by cvs2svn $
+* Revision 1.98  2007/11/26 23:43:07  vsc
+* fixes to support threads and assert correctly, even if inefficiently.
+*
 * Revision 1.97  2007/11/07 09:25:27  vsc
 * speedup meta-calls
 *
@@ -460,8 +463,9 @@ static yamop *
 a_lucl(op_numbers opcode, yamop *code_p, int pass_no, struct intermediates *cip, clause_info *cla)
 {
   if (pass_no) {
+    LogUpdIndex *lcl = (LogUpdIndex *)cip->code_addr;
     code_p->opc = emit_op(opcode);
-    code_p->u.Ill.I = (LogUpdIndex *)cip->code_addr;
+    code_p->u.Ill.I = lcl;
     cip->current_try_lab = &code_p->u.Ill.l1;
     cip->current_trust_lab = &code_p->u.Ill.l2;
     code_p->u.Ill.s  = cip->cpc->rnd3;

C/cdmgr.c

@@ -11,8 +11,12 @@
 * File:		cdmgr.c							 *
 * comments:	Code manager						 *
 *									 *
-* Last rev:     $Date: 2007-12-26 19:50:40 $,$Author: vsc $						 *
+* Last rev:     $Date: 2008-01-23 17:57:44 $,$Author: vsc $						 *
 * $Log: not supported by cvs2svn $
+* Revision 1.217  2007/12/26 19:50:40  vsc
+* new version of clp(fd)
+* fix deadlock with empty args facts in clause/2.
+*
 * Revision 1.216  2007/12/23 22:48:44  vsc
 * recover stack space
 *
@@ -589,7 +593,7 @@ static_in_use(PredEntry *p, int check_everything)
 #else
   CELL pflags = p->PredFlags;
   if (pflags & (DynamicPredFlag|LogUpdatePredFlag)) {
-    return (FALSE);
+    return FALSE;
   }
   if (STATIC_PREDICATES_MARKED) {
     return (p->PredFlags & InUsePredFlag);
@@ -964,13 +968,23 @@ decrease_ref_counter(yamop *ptr, yamop *b, yamop *e, yamop *sc)
   }
 }
 
-static void
+static yamop *
 release_wcls(yamop *cop, OPCODE ecs)
 {
   if (cop->opc == ecs) {
     cop->u.sp.s3--;
     if (!cop->u.sp.s3) {
+      UInt sz = (UInt)NEXTOP((yamop *)NULL,sp)+cop->u.sp.s1*sizeof(yamop *);
       LOCK(ExpandClausesListLock);
+#ifdef DEBUG
+      Yap_expand_clauses_sz -= sz;
+      Yap_ExpandClauses--;
+#endif
+      if (cop->u.sp.p->PredFlags & LogUpdatePredFlag) {
+	Yap_LUIndexSpace_EXT -= sz;
+      } else {
+	Yap_IndexSpace_EXT -= sz;
+      }
       if (ExpandClausesFirst == cop)
 	ExpandClausesFirst = cop->u.sp.snext;
       if (ExpandClausesLast == cop) {
@@ -983,18 +997,11 @@ release_wcls(yamop *cop, OPCODE ecs)
 	cop->u.sp.snext->u.sp.sprev = cop->u.sp.sprev;
       }
       UNLOCK(ExpandClausesListLock);
-#if DEBUG
-      Yap_expand_clauses_sz -= (UInt)(NEXTOP((yamop *)NULL,sp)+cop->u.sp.s1*sizeof(yamop *));
-#endif
       Yap_InformOfRemoval((CODEADDR)cop);
-      if (cop->u.sp.p->PredFlags & LogUpdatePredFlag) {
-	Yap_LUIndexSpace_EXT -= (UInt)NEXTOP((yamop *)NULL,sp)+cop->u.sp.s1*sizeof(yamop *);
-      } else {
-	Yap_IndexSpace_EXT -= (UInt)NEXTOP((yamop *)NULL,sp)+cop->u.sp.s1*sizeof(yamop *);
-      }
       Yap_FreeCodeSpace((char *)cop);
     }
   }
+  return FAILCODE;
 }
 
 
@@ -1015,13 +1022,9 @@ cleanup_dangling_indices(yamop *ipc, yamop *beg, yamop *end, yamop *suspend_code
       ipc = NEXTOP(ipc,e);
       break;
     case _lock_lu:
-      /* just skip for now, but should worry about locking */
-      ipc = NEXTOP(ipc,p);
-      break;
     case _unlock_lu:
-      /* just skip for now, but should worry about locking */
+      /* locking should be done already */
       ipc = NEXTOP(ipc,e);
-      break;
     case _retry_profiled:
     case _count_retry:
       ipc = NEXTOP(ipc,p);
@@ -1065,7 +1068,6 @@ cleanup_dangling_indices(yamop *ipc, yamop *beg, yamop *end, yamop *suspend_code
 	Yap_FreedCps++;
 #endif
       }
-      end = ipc;
       break;
     case _trust_logical:
     case _count_trust_logical:
@@ -1077,9 +1079,10 @@ cleanup_dangling_indices(yamop *ipc, yamop *beg, yamop *end, yamop *suspend_code
       decrease_ref_counter(ipc->u.lld.d->ClCode, beg, end, suspend_code);
       Yap_LUIndexSpace_CP -= (UInt)NEXTOP((yamop *)NULL,lld);
       Yap_FreeCodeSpace((ADDR)ipc);
-      end = ipc;
       return;
     case _enter_lu_pred:
+      {
+	yamop *oipc = ipc;
 	if (ipc->u.Ill.I->ClFlags & InUseMask || ipc->u.Ill.I->ClRefCount)
 	  return;
 #ifdef DEBUG
@@ -1087,46 +1090,49 @@ cleanup_dangling_indices(yamop *ipc, yamop *beg, yamop *end, yamop *suspend_code
 	Yap_LiveCps-=ipc->u.Ill.s;
 #endif
 	ipc = ipc->u.Ill.l1;
-      end = ipc;
+	/* in case we visit again */
+	oipc->u.Ill.l1 = FAILCODE;
+	oipc->u.Ill.s = 0;
+      }
       break;
     case _try_in:
     case _jump:
     case _jump_if_var:
-      release_wcls(ipc->u.l.l, ecs);
+      ipc->u.l.l = release_wcls(ipc->u.l.l, ecs);
       ipc = NEXTOP(ipc,l);
       break;
       /* instructions type xl */
     case _jump_if_nonvar:
-      release_wcls(ipc->u.xll.l1, ecs);
+      ipc->u.xll.l1 = release_wcls(ipc->u.xll.l1, ecs);
       ipc = NEXTOP(ipc,xll);
       break;
       /* instructions type e */
     case _switch_on_type:
-      release_wcls(ipc->u.llll.l1, ecs);
+      ipc->u.llll.l1 = release_wcls(ipc->u.llll.l1, ecs);
-      release_wcls(ipc->u.llll.l2, ecs);
+      ipc->u.llll.l2 = release_wcls(ipc->u.llll.l2, ecs);
-      release_wcls(ipc->u.llll.l3, ecs);
+      ipc->u.llll.l3 = release_wcls(ipc->u.llll.l3, ecs);
-      release_wcls(ipc->u.llll.l4, ecs);
+      ipc->u.llll.l4 = release_wcls(ipc->u.llll.l4, ecs);
       ipc = NEXTOP(ipc,llll);
       break;
     case _switch_list_nl:
-      release_wcls(ipc->u.ollll.l1, ecs);
+      ipc->u.ollll.l1 = release_wcls(ipc->u.ollll.l1, ecs);
-      release_wcls(ipc->u.ollll.l2, ecs);
+      ipc->u.ollll.l2 = release_wcls(ipc->u.ollll.l2, ecs);
-      release_wcls(ipc->u.ollll.l3, ecs);
+      ipc->u.ollll.l3 = release_wcls(ipc->u.ollll.l3, ecs);
-      release_wcls(ipc->u.ollll.l4, ecs);
+      ipc->u.ollll.l4 = release_wcls(ipc->u.ollll.l4, ecs);
       ipc = NEXTOP(ipc,ollll);
       break;
     case _switch_on_arg_type:
-      release_wcls(ipc->u.xllll.l1, ecs);
+      ipc->u.xllll.l1 = release_wcls(ipc->u.xllll.l1, ecs);
-      release_wcls(ipc->u.xllll.l2, ecs);
+      ipc->u.xllll.l2 = release_wcls(ipc->u.xllll.l2, ecs);
-      release_wcls(ipc->u.xllll.l3, ecs);
+      ipc->u.xllll.l3 = release_wcls(ipc->u.xllll.l3, ecs);
-      release_wcls(ipc->u.xllll.l4, ecs);
+      ipc->u.xllll.l4 = release_wcls(ipc->u.xllll.l4, ecs);
       ipc = NEXTOP(ipc,xllll);
       break;
     case _switch_on_sub_arg_type:
-      release_wcls(ipc->u.sllll.l1, ecs);
+      ipc->u.sllll.l1 = release_wcls(ipc->u.sllll.l1, ecs);
-      release_wcls(ipc->u.sllll.l2, ecs);
+      ipc->u.sllll.l2 = release_wcls(ipc->u.sllll.l2, ecs);
-      release_wcls(ipc->u.sllll.l3, ecs);
+      ipc->u.sllll.l3 = release_wcls(ipc->u.sllll.l3, ecs);
-      release_wcls(ipc->u.sllll.l4, ecs);
+      ipc->u.sllll.l4 = release_wcls(ipc->u.sllll.l4, ecs);
       ipc = NEXTOP(ipc,sllll);
       break;
     case _if_not_then:
@@ -1140,6 +1146,8 @@ cleanup_dangling_indices(yamop *ipc, yamop *beg, yamop *end, yamop *suspend_code
     case _go_on_cons:
       ipc = NEXTOP(ipc,sssl);
       break;
+    case _op_fail:
+      return;
     default:
       Yap_Error(SYSTEM_ERROR,TermNil,"Bug in Indexing Code: opcode %d", op);
       return;
@@ -1168,10 +1176,9 @@ decrease_log_indices(LogUpdIndex *c, yamop *suspend_code)
     OPCODE ecs = Yap_opcode(_expand_clauses);
 
     while (beg < end) {
-      yamop *cop;
+      yamop **x = (yamop **)(beg+1);
-      cop = (yamop *)beg[1];
       beg += 2;
-      release_wcls(cop, ecs);
+      *x = release_wcls(*x, ecs);
     }
     return;
   }
@@ -1221,6 +1228,7 @@ kill_children(LogUpdIndex *c, PredEntry *ap)
   c->ClRefCount--;
 }
 
+
 /* assumes c is already locked */
 static void
 kill_off_lu_block(LogUpdIndex *c, LogUpdIndex *parent, PredEntry *ap)
@@ -1242,17 +1250,14 @@ kill_off_lu_block(LogUpdIndex *c, LogUpdIndex *parent, PredEntry *ap)
       }
     }
   }
-  {
+  decrease_log_indices(c, (yamop *)&(ap->cs.p_code.ExpandCode));
-    LogUpdIndex *parent = DBErasedIList, *c0 = NULL;
+  /* remove from list */
-    while (parent != NULL) {
+  if (c->SiblingIndex)
-      if (c == parent) {
+    c->SiblingIndex->PrevSiblingIndex = c->PrevSiblingIndex;
-	if (c0) c0->SiblingIndex = c->SiblingIndex;
+  if (c->PrevSiblingIndex) {
-	else DBErasedIList = c->SiblingIndex;
+    c->PrevSiblingIndex->SiblingIndex = c->SiblingIndex;
-	break;
+  } else {
-      }
+    DBErasedIList = c->SiblingIndex;
-      c0 = parent;
-      parent = parent->SiblingIndex;
-    }
   }
   Yap_InformOfRemoval((CODEADDR)c);
   if (c->ClFlags & SwitchTableMask)
@@ -1288,10 +1293,16 @@ kill_first_log_iblock(LogUpdIndex *c, LogUpdIndex *parent, PredEntry *ap)
       RemoveMainIndex(ap);
     }
   }
+  decrease_log_indices(c, (yamop *)&(ap->cs.p_code.ExpandCode));
   /* make sure that a child cannot remove us */
   kill_children(c, ap);
   /* check if we are still the main index */
-  decrease_log_indices(c, (yamop *)&(ap->cs.p_code.ExpandCode));
+  /* always add to erased list */
+  c->SiblingIndex = DBErasedIList;
+  c->PrevSiblingIndex = NULL;
+  if (DBErasedIList)
+    DBErasedIList->PrevSiblingIndex = c;
+  DBErasedIList = c;
   if (!((c->ClFlags & InUseMask) || c->ClRefCount)) {
     kill_off_lu_block(c, parent, ap);
   } else {
@@ -1306,8 +1317,6 @@ kill_first_log_iblock(LogUpdIndex *c, LogUpdIndex *parent, PredEntry *ap)
       parent->ParentIndex->ClRefCount++;
       parent->ClRefCount--;
     }
-    c->SiblingIndex = DBErasedIList;
-    DBErasedIList = c;
   }
 }
 
@@ -1536,6 +1545,15 @@ add_first_static(PredEntry *p, yamop *cp, int spy_flag)
   }
   p->cs.p_code.TrueCodeOfPred = pt;
   p->cs.p_code.FirstClause = p->cs.p_code.LastClause = cp;
+  p->OpcodeOfPred = pt->opc;
+#if defined(YAPOR) || defined(THREADS)
+  if (p->PredFlags & LogUpdatePredFlag &&
+      p->ModuleOfPred != IDB_MODULE) {
+    p->OpcodeOfPred = LOCKPRED_OPCODE;
+    p->CodeOfPred = (yamop *)(&(p->OpcodeOfPred)); 
+  } else
+#endif
+    p->CodeOfPred = pt;
   p->cs.p_code.NOfClauses = 1;
   p->StatisticsForPred.NOfEntries = 0;
   p->StatisticsForPred.NOfHeadSuccesses = 0;
@@ -4944,6 +4962,144 @@ p_continue_log_update_clause(void)
   return fetch_next_lu_clause(pe, ipc, Deref(ARG3), ARG4, ARG5, B->cp_cp, FALSE);
 }
 
+static Int
+fetch_next_lu_clause_erase(PredEntry *pe, yamop *i_code, Term th, Term tb, Term tr, yamop *cp_ptr, int first_time)
+{
+  LogUpdClause *cl;
+  Term rtn;
+  Term Terms[3];
+
+  Terms[0] = th;
+  Terms[1] = tb;
+  Terms[2] = tr;
+  cl = Yap_FollowIndexingCode(pe, i_code, Terms, NEXTOP(PredLogUpdClauseErase->CodeOfPred,ld), cp_ptr);
+  th = Terms[0];
+  tb = Terms[1];
+  tr = Terms[2];
+  /* don't do this!! I might have stored a choice-point and changed ASP
+     Yap_RecoverSlots(3);
+  */
+  if (cl == NULL) {
+    UNLOCK(pe->PELock);
+    return FALSE;
+  }
+  rtn = MkDBRefTerm((DBRef)cl);
+#if defined(YAPOR) || defined(THREADS)
+  TRAIL_CLREF(cl);		/* So that fail will erase it */
+  INC_CLREF_COUNT(cl);
+#else
+  if (!(cl->ClFlags & InUseMask)) {
+    cl->ClFlags |= InUseMask;
+    TRAIL_CLREF(cl);	/* So that fail will erase it */
+  }
+#endif
+  if (cl->ClFlags & FactMask) {
+    if (!Yap_unify_constant(tb, MkAtomTerm(AtomTrue)) ||
+	!Yap_unify(tr, rtn)) {
+      UNLOCK(pe->PELock);
+      return FALSE;
+    }
+    if (pe->ArityOfPE) {
+      Functor f = FunctorOfTerm(th);
+      UInt arity = ArityOfFunctor(f), i;
+      CELL *pt = RepAppl(th)+1;
+
+      for (i=0; i<arity; i++) {
+	XREGS[i+1] = pt[i];
+      }
+      /* don't need no ENV */
+      if (first_time) {
+	CP = P;
+	ENV = YENV;
+	YENV = ASP;
+	YENV[E_CB] = (CELL) B;
+      }
+      P = cl->ClCode;
+#if defined(YAPOR) || defined(THREADS)
+      PP = pe;
+#endif
+    } else {
+      /* we don't actually need to execute code */
+      UNLOCK(pe->PELock);
+    }
+    Yap_ErLogUpdCl(cl);
+    return TRUE;
+  } else {
+    Term t;
+    Int res;
+
+    while ((t = Yap_FetchTermFromDB(cl->ClSource)) == 0L) {
+      if (first_time) {
+	ARG5 = th;
+	ARG6 = tb;
+	ARG7 = tr;
+	if (Yap_Error_TYPE == OUT_OF_ATTVARS_ERROR) {
+	  Yap_Error_TYPE = YAP_NO_ERROR;
+	  if (!Yap_growglobal(NULL)) {
+	    UNLOCK(pe->PELock);
+	    Yap_Error(OUT_OF_ATTVARS_ERROR, TermNil, Yap_ErrorMessage);
+	    return FALSE;
+	  }
+	} else {
+	  Yap_Error_TYPE = YAP_NO_ERROR;
+	  if (!Yap_gcl(Yap_Error_Size, 7, YENV, P)) {
+	    UNLOCK(pe->PELock);
+	    Yap_Error(OUT_OF_STACK_ERROR, TermNil, Yap_ErrorMessage);
+	    return FALSE;
+	  }
+	}
+	th = ARG5;
+	tb = ARG6;
+	tr = ARG7;
+      } else {
+	ARG6 = th;
+	ARG7 = tb;
+	ARG8 = tr;
+	if (!Yap_gcl(Yap_Error_Size, 8, ENV, CP)) {
+	  UNLOCK(pe->PELock);
+	  Yap_Error(OUT_OF_STACK_ERROR, TermNil, Yap_ErrorMessage);
+	  return FALSE;
+	}
+	th = ARG6;
+	tb = ARG7;
+	tr = ARG8;
+      }
+    }
+    res = Yap_unify(th, ArgOfTerm(1,t)) &&
+      Yap_unify(tb, ArgOfTerm(2,t)) &&
+      Yap_unify(tr, rtn);
+    if (res)
+      Yap_ErLogUpdCl(cl);
+    UNLOCK(pe->PELock);
+    return res;
+  }
+}
+
+static Int			/* $hidden_predicate(P) */
+p_log_update_clause_erase(void)
+{
+  PredEntry      *pe;
+  Term t1 = Deref(ARG1);
+  Int ret;
+
+  pe = get_pred(t1, Deref(ARG2), "clause/3");
+  if (pe == NULL || EndOfPAEntr(pe))
+    return FALSE;
+  LOCK(pe->PELock);
+  ret = fetch_next_lu_clause_erase(pe, pe->CodeOfPred, t1, ARG3, ARG4, P, TRUE);
+  return ret;
+}
+
+static Int			/* $hidden_predicate(P) */
+p_continue_log_update_clause_erase(void)
+{
+  PredEntry *pe = (PredEntry *)IntegerOfTerm(Deref(ARG1));
+  yamop *ipc = (yamop *)IntegerOfTerm(ARG2);
+
+  LOCK(pe->PELock);
+  return fetch_next_lu_clause_erase(pe, ipc, Deref(ARG3), ARG4, ARG5, B->cp_cp, FALSE);
+}
+
 static Int
 fetch_next_lu_clause0(PredEntry *pe, yamop *i_code, Term th, Term tb, yamop *cp_ptr, int first_time)
 {
@@ -5097,6 +5253,7 @@ Yap_UpdateTimestamps(PredEntry *ap)
   choiceptr bptr = B;
   yamop *cl0 = NEXTOP(PredLogUpdClause0->CodeOfPred,ld);
   yamop *cl = NEXTOP(PredLogUpdClause->CodeOfPred,ld);
+  yamop *cle = NEXTOP(PredLogUpdClauseErase->CodeOfPred,ld);
   UInt ar = ap->ArityOfPE;
   UInt *arp, *top, *base;
   LogUpdClause *lcl;
@@ -5137,7 +5294,7 @@ Yap_UpdateTimestamps(PredEntry *ap)
       bptr = bptr->cp_b;
       break;
     case _retry:
-      if ((bptr->cp_ap == cl0 || bptr->cp_ap == cl) &&
+      if ((bptr->cp_ap == cl0 || bptr->cp_ap == cl || bptr->cp_ap == cle) &&
 	  ((PredEntry *)IntegerOfTerm(bptr->cp_args[0]) == ap)) {
 	UInt ts = IntegerOfTerm(bptr->cp_args[5]);
 	if (ts != arp[0]) {
@@ -5193,7 +5350,7 @@ Yap_UpdateTimestamps(PredEntry *ap)
       bptr = bptr->cp_b;
       break;
     case _retry:
-      if ((bptr->cp_ap == cl0 || bptr->cp_ap == cl) &&
+      if ((bptr->cp_ap == cl0 || bptr->cp_ap == cl || bptr->cp_ap == cle) &&
 	  ((PredEntry *)IntegerOfTerm(bptr->cp_args[0]) == ap)) {
 	UInt ts = IntegerOfTerm(bptr->cp_args[5]);
 	while (ts != arp[0])
@@ -5601,8 +5758,8 @@ p_predicate_erased_statistics(void)
   PredEntry *pe;
   LogUpdClause *cl = DBErasedList;
   LogUpdIndex *icl = DBErasedIList;
-  Term tpred = ArgOfTerm(1,Deref(ARG1));
+  Term tpred = ArgOfTerm(2,Deref(ARG1));
-  Term tmod = ArgOfTerm(2,Deref(ARG1));
+  Term tmod = ArgOfTerm(1,Deref(ARG1));
 
   if (EndOfPAEntr(pe=get_pred(tpred,  tmod, "predicate_erased_statistics")))
     return FALSE;
@@ -5966,6 +6123,8 @@ Yap_InitCdMgr(void)
   Yap_InitCPred("$current_stack", 1, p_current_stack, SyncPredFlag|HiddenPredFlag);
   Yap_InitCPred("$log_update_clause", 4, p_log_update_clause, SyncPredFlag|HiddenPredFlag);
   Yap_InitCPred("$continue_log_update_clause", 5, p_continue_log_update_clause, SafePredFlag|SyncPredFlag|HiddenPredFlag);
+  Yap_InitCPred("$log_update_clause_erase", 4, p_log_update_clause_erase, SyncPredFlag|HiddenPredFlag);
+  Yap_InitCPred("$continue_log_update_clause_erase", 5, p_continue_log_update_clause_erase, SafePredFlag|SyncPredFlag|HiddenPredFlag);
   Yap_InitCPred("$log_update_clause", 3, p_log_update_clause0, SyncPredFlag|HiddenPredFlag);
   Yap_InitCPred("$continue_log_update_clause", 4, p_continue_log_update_clause0, SafePredFlag|SyncPredFlag|HiddenPredFlag);
   Yap_InitCPred("$static_clause", 4, p_static_clause, SyncPredFlag|HiddenPredFlag);

C/dbase.c

@@ -3807,14 +3807,10 @@ p_total_erased(void)
   LogUpdClause *cl = DBErasedList;
   LogUpdIndex *icl = DBErasedIList;
 
-  int i=200000;
-  while (cl &&  i>0)
-    cl=cl->ClNext,i--;
-  if (cl)
-    fprintf(stderr,"cl=%p\n",cl);
   /* only for log upds */
   while (cl) {
     cls++;
+    fprintf(stderr,"cl=%p, %x %d\n",cl,cl->ClFlags,cl->ClRefCount);
     sz += cl->ClSize;
     cl = cl->ClNext;
   }
@@ -4007,6 +4003,7 @@ static void
 complete_lu_erase(LogUpdClause *clau)
 {
   DBRef *cp;
+
   if (clau->ClSource)
     cp = clau->ClSource->DBRefs;
   else 
@@ -4015,6 +4012,7 @@ complete_lu_erase(LogUpdClause *clau)
     return;
   }
   if (clau->ClFlags & LogUpdRuleMask &&
+      clau->ClExt &&
       clau->ClExt->u.EC.ClRefs > 0) {
     return;
   }
@@ -4116,9 +4114,12 @@ EraseLogUpdCl(LogUpdClause *clau)
 	  ap->LastCallOfPred = LUCALL_RETRACT;
 	} else {
 	  /* OK, there's noone left */
+#ifndef THREADS
 	  if (ap->cs.p_code.NOfClauses == 0) {
+	    /* Other threads may hold refs to clauses */
 	    ap->TimeStampOfPred = 0L;
 	  }
+#endif
 	/*	  fprintf(stderr,"- %x--%d--%ul\n",ap,ap->TimeStampOfPred,ap->ArityOfPE);*/
 	  ap->LastCallOfPred = LUCALL_ASSERT;
 	}
@@ -4201,8 +4202,9 @@ PrepareToEraseLogUpdClause(LogUpdClause *clau, DBRef dbr)
   PredEntry *p = clau->ClPred;
   yamop *cl = code_p;
 
-  if (clau->ClFlags & ErasedMask)
+  if (clau->ClFlags & ErasedMask) {
     return;
+  }
   clau->ClFlags |= ErasedMask;
   if (p->cs.p_code.FirstClause != cl) {
     /* we are not the first clause... */

C/exec.c

@@ -1983,9 +1983,11 @@ Yap_InitYaamRegs(void)
   CreepFlag = CalculateStackGap();
   UNLOCK(SignalLock);
   EX = 0L;
-  init_stack(0, NULL, TRUE, NULL);
   /* for slots to work */
   Yap_StartSlots();
+  init_stack(0, NULL, TRUE, NULL);
+  /* the first real choice-point will also have AP=FAIL */ 
+  Yap_StartSlots();
   GlobalArena = TermNil;
   h0var = MkVarTerm();
 #if COROUTINING

C/globals.c

@@ -488,6 +488,9 @@ copy_complex_term(register CELL *pt0, register CELL *pt0_end, int share, CELL *p
 	    H[1] = ap2[1];
 	    H[2] = EndSpecials;
 	    H += 3;
+	    if (H > ASP - 128) {
+	      goto overflow;
+	    }
 	    break;
 	  case (CELL)FunctorDouble:
 	    if (H > ASP - (128+(2+SIZEOF_DOUBLE/sizeof(CELL)))) {

C/grow.c

@@ -67,13 +67,13 @@ STATIC_PROTO(void MoveLocalAndTrail, (void));
 STATIC_PROTO(void SetHeapRegs, (void));
 STATIC_PROTO(void AdjustTrail, (int));
 STATIC_PROTO(void AdjustLocal, (void));
-STATIC_PROTO(void AdjustGlobal, (void));
+STATIC_PROTO(void AdjustGlobal, (long));
 STATIC_PROTO(void AdjustGrowStack, (void));
 STATIC_PROTO(int  static_growheap, (long,int,struct intermediates *,tr_fr_ptr *, TokEntry **, VarEntry **));
 STATIC_PROTO(void cpcellsd, (CELL *, CELL *, CELL));
 STATIC_PROTO(CELL AdjustAppl, (CELL));
 STATIC_PROTO(CELL AdjustPair, (CELL));
-STATIC_PROTO(void AdjustStacksAndTrail, (void));
+STATIC_PROTO(void AdjustStacksAndTrail, (long));
 STATIC_PROTO(void AdjustRegs, (int));
 
 static void
@@ -127,6 +127,7 @@ SetHeapRegs(void)
   OldTR = TR;
   OldHeapBase = Yap_HeapBase;
   OldHeapTop = HeapTop;
+  OldDelayTop = CurrentDelayTop;
   /* Adjust stack addresses */
   Yap_TrailBase = TrailAddrAdjust(Yap_TrailBase);
   Yap_TrailTop = TrailAddrAdjust(Yap_TrailTop);
@@ -155,6 +156,8 @@ SetHeapRegs(void)
     HB = PtoGloAdjust(HB);
   if (B)
     B = ChoicePtrAdjust(B);
+  if (CurrentDelayTop)
+    CurrentDelayTop = PtoGloAdjust(CurrentDelayTop);
 #ifdef CUT_C
   if (Yap_REGS.CUT_C_TOP)
     Yap_REGS.CUT_C_TOP = (cut_c_str_ptr)ChoicePtrAdjust((choiceptr)Yap_REGS.CUT_C_TOP);
@@ -291,7 +294,7 @@ AdjustPair(register CELL t0)
 static void
 AdjustTrail(int adjusting_heap)
 {
-  register tr_fr_ptr ptt;
+  volatile tr_fr_ptr ptt;
 
   ptt = TR;
   /* moving the trail is simple */
@@ -382,8 +385,10 @@ AdjustGlobTerm(Term reg)
   return AtomTermAdjust(reg);
 }
 
+static volatile CELL *cpt=NULL;
+
 static void
-AdjustGlobal(void)
+AdjustGlobal(long sz)
 {
   CELL *pt;
   ArrayEntry *al = DynamicArrays;
@@ -419,10 +424,11 @@ AdjustGlobal(void)
    * to clean the global now that functors are just variables pointing to
    * the code 
    */
-  pt = CellPtr(Yap_GlobalBase);
+  pt = CurrentDelayTop;
-  while (pt < H) {
+  while (pt < (H-sz/CellSize)) {
     CELL reg;
     
+    cpt = pt;
     reg = *pt;
     if (IsVarTerm(reg)) {
 	if (IsOldGlobal(reg))
@@ -431,8 +437,7 @@ AdjustGlobal(void)
 	  *pt = LocalAdjust(reg);
 	else if (IsOldCode(reg)) {
 	  Functor f;
-	  f = (Functor)(*pt = CodeAdjust(reg));
+	  f = (Functor)reg;
-	  if (f <= FunctorDouble && f >= FunctorLongInt) {
 	  /* skip bitmaps */
 	  switch((CELL)f) {
 	  case (CELL)FunctorDouble:
@@ -446,17 +451,19 @@ AdjustGlobal(void)
 	  case (CELL)FunctorBigInt:
 	    {
 	      Int sz = 1+
-		  sizeof(MP_INT)+
+		(sizeof(MP_INT)+
-		  (((MP_INT *)(pt+1))->_mp_alloc*sizeof(mp_limb_t));
+		 (((MP_INT *)(pt+1))->_mp_alloc*sizeof(mp_limb_t)))/CellSize;
 	      pt += sz;
 	    }
 	    break;
 #endif
+	  case (CELL)0L:
+	    break;
 	  case (CELL)FunctorLongInt:
-	    default:
 	    pt += 2;
 	    break;
-	    }
+	  default:
+	    *pt = CodeAdjust(reg);
 	  }
 	}
 #ifdef MULTI_ASSIGNMENT_VARIABLES
@@ -479,17 +486,17 @@ AdjustGlobal(void)
  * (just once) the trail cells pointing both to the global and to the local
  */
 static void
-AdjustStacksAndTrail(void)
+AdjustStacksAndTrail(long sz)
 {
   AdjustTrail(TRUE);
   AdjustLocal();
-  AdjustGlobal();
+  AdjustGlobal(sz);
 }
 
 void
 Yap_AdjustStacksAndTrail(void)
 {
-  AdjustStacksAndTrail();
+  AdjustStacksAndTrail(0);
 }
 
 /*
@@ -622,6 +629,7 @@ static_growheap(long size, int fix_code, struct intermediates *cip, tr_fr_ptr *o
   int gc_verbose;
   UInt minimal_request = 0L;
 
+  CurrentDelayTop = (CELL *)DelayTop();
   /* adjust to a multiple of 256) */
   size = AdjustPageSize(size);
   Yap_ErrorMessage = NULL;
@@ -641,7 +649,10 @@ static_growheap(long size, int fix_code, struct intermediates *cip, tr_fr_ptr *o
   gc_verbose = Yap_is_gc_verbose();
   heap_overflows++;
   if (gc_verbose) {
-    fprintf(Yap_stderr, "%% Database overflow %d\n", heap_overflows);
+#if  defined(YAPOR) || defined(THREADS)
+    fprintf(Yap_stderr, "%% Worker Id %d:\n", worker_id);
+#endif
+    fprintf(Yap_stderr, "%% Database Overflow %d\n", heap_overflows);
     fprintf(Yap_stderr, "%%   growing the heap %ld bytes\n", size);
   }
   /* CreepFlag is set to force heap expansion */
@@ -672,10 +683,10 @@ static_growheap(long size, int fix_code, struct intermediates *cip, tr_fr_ptr *o
     nTR = TR;
     *old_trp = PtoTRAdjust(*old_trp);
     TR = *old_trp;
-    AdjustStacksAndTrail();
+    AdjustStacksAndTrail(0);
     TR = nTR;
   } else {
-    AdjustStacksAndTrail();
+    AdjustStacksAndTrail(0);
   }
   AdjustRegs(MaxTemps);
   YAPLeaveCriticalSection();
@@ -705,6 +716,7 @@ static_growglobal(long size, CELL **ptr, CELL *hsplit)
   char vb_msg1 = '\0', *vb_msg2;
   int do_grow = TRUE;
 
+  CurrentDelayTop = (CELL *)omax;
   if (hsplit) {
     /* just a little bit of sanity checking */
     if (hsplit < (CELL*)omax ||
@@ -757,7 +769,10 @@ static_growglobal(long size, CELL **ptr, CELL *hsplit)
       vb_msg1 = 'D';
       vb_msg2 = "Delay";
     }
-    fprintf(Yap_stderr, "%% %cO %s overflow %d\n", vb_msg1, vb_msg2, delay_overflows);
+#if  defined(YAPOR) || defined(THREADS)
+    fprintf(Yap_stderr, "%% Worker Id %d:\n", worker_id);
+#endif
+    fprintf(Yap_stderr, "%% %cO %s Overflow %d\n", vb_msg1, vb_msg2, delay_overflows);
     fprintf(Yap_stderr, "%% %cO   growing the stacks %ld bytes\n", vb_msg1, size);
   }
   ASP -= 256;
@@ -810,7 +825,12 @@ static_growglobal(long size, CELL **ptr, CELL *hsplit)
       MoveExpandedGlobal();
     }
   }
-  AdjustStacksAndTrail();
+  /* don't run through garbage */
+  if (hsplit && (OldH != hsplit)) {
+    AdjustStacksAndTrail(sz);
+  } else {
+    AdjustStacksAndTrail(0);
+  }
   AdjustRegs(MaxTemps);
   if (ptr) {
     *ptr = PtoLocAdjust(*ptr);
@@ -1151,7 +1171,10 @@ growatomtable(void)
   }
   atom_table_overflows++;
   if (gc_verbose) {
-    fprintf(Yap_stderr, "%% Atom Table overflow %d\n", atom_table_overflows);
+#if  defined(YAPOR) || defined(THREADS)
+    fprintf(Yap_stderr, "%% Worker Id %d:\n", worker_id);
+#endif
+    fprintf(Yap_stderr, "%% Atom Table Overflow %d\n", atom_table_overflows);
     fprintf(Yap_stderr, "%%    growing the atom table to %ld entries\n", (long int)(nsize));
   }
   YAPEnterCriticalSection();
@@ -1170,7 +1193,7 @@ growatomtable(void)
 #if USE_SYSTEM_MALLOC
   return TRUE;
 #else
-  if (HeapTop + sizeof(YAP_SEG_SIZE) < HeapLim) {
+  if (HeapTop + sizeof(YAP_SEG_SIZE)  > HeapLim - MinHeapGap) {
     /* make sure there is no heap overflow */
     int res;
     YAPEnterCriticalSection();
@@ -1274,6 +1297,7 @@ execute_growstack(long size0, int from_trail, int in_parser, tr_fr_ptr *old_trp,
   long size = size0;
   ADDR old_Yap_GlobalBase = Yap_GlobalBase;
   
+  CurrentDelayTop = (CELL *)DelayTop();
   if (!Yap_ExtendWorkSpace(size)) {
     /* make sure stacks and trail are contiguous */
 
@@ -1331,10 +1355,10 @@ execute_growstack(long size0, int from_trail, int in_parser, tr_fr_ptr *old_trp,
       nTR = TR;
       *old_trp = PtoTRAdjust(*old_trp);
       TR = *old_trp;
-      AdjustStacksAndTrail();
+      AdjustStacksAndTrail(0);
       TR = nTR;
     } else {
-      AdjustStacksAndTrail();
+      AdjustStacksAndTrail(0);
     }
     AdjustRegs(MaxTemps);
 #ifdef TABLING
@@ -1379,6 +1403,9 @@ growstack(long size)
   gc_verbose = Yap_is_gc_verbose();
   stack_overflows++;
   if (gc_verbose) {
+#if  defined(YAPOR) || defined(THREADS)
+    fprintf(Yap_stderr, "%% Worker Id %d:\n", worker_id);
+#endif
     fprintf(Yap_stderr, "%% Stack Overflow %d\n", stack_overflows);
     fprintf(Yap_stderr, "%%   Global: %8ld cells (%p-%p)\n", (unsigned long int)(H-(CELL *)Yap_GlobalBase),Yap_GlobalBase,H);
     fprintf(Yap_stderr, "%%   Local:%8ld cells (%p-%p)\n", (unsigned long int)(LCL0-ASP),LCL0,ASP);
@@ -1413,6 +1440,9 @@ Yap_growstack_in_parser(tr_fr_ptr *old_trp, TokEntry **tksp, VarEntry **vep)
   gc_verbose = Yap_is_gc_verbose();
   stack_overflows++;
   if (gc_verbose) {
+#if  defined(YAPOR) || defined(THREADS)
+    fprintf(Yap_stderr, "%% Worker Id %d:\n", worker_id);
+#endif
     fprintf(Yap_stderr, "%% Stack Overflow %d\n", stack_overflows);
     fprintf(Yap_stderr, "%%   Global: %8ld cells (%p-%p)\n", (unsigned long int)(H-(CELL *)Yap_GlobalBase),Yap_GlobalBase,H);
     fprintf(Yap_stderr, "%%   Local:%8ld cells (%p-%p)\n", (unsigned long int)(LCL0-ASP),LCL0,ASP);
@@ -1455,7 +1485,10 @@ static int do_growtrail(long size, int contiguous_only, int in_parser, tr_fr_ptr
   size = AdjustPageSize(size);
   trail_overflows++;
   if (gc_verbose) {
-    fprintf(Yap_stderr, "%% Trail overflow %d\n", trail_overflows);
+#if  defined(YAPOR) || defined(THREADS)
+    fprintf(Yap_stderr, "%% Worker Id %d:\n", worker_id);
+#endif
+    fprintf(Yap_stderr, "%% Trail Overflow %d\n", trail_overflows);
 #if USE_SYSTEM_MALLOC
     fprintf(Yap_stderr, "%%  Heap: %8ld cells (%p-%p)\n", (unsigned long int)(H-(CELL *)Yap_GlobalBase),(CELL *)Yap_GlobalBase,H);
     fprintf(Yap_stderr, "%%  Local:%8ld cells (%p-%p)\n", (unsigned long int)(LCL0-ASP),LCL0,ASP);

C/heapgc.c

@@ -937,7 +937,7 @@ init_dbtable(tr_fr_ptr trail_ptr) {
 #ifdef SBA
 	  (ADDR) pt0 >= HeapTop
 #else
-	  (ADDR) pt0 >= Yap_TrailBase
+	  (ADDR) pt0 >= Yap_TrailBase && (ADDR) pt0 < Yap_TrailTop
 #endif
 	  ) {
 	continue;
@@ -1347,7 +1347,7 @@ mark_variable(CELL_PTR current)
       case (CELL)FunctorBigInt:
 	{
 	  UInt sz = (sizeof(MP_INT)+
-		     (((MP_INT *)(next+1))->_mp_alloc*sizeof(mp_limb_t)))/CellSize;
+		     ((MP_INT *)(next+1))->_mp_alloc*sizeof(mp_limb_t))/CellSize;
 	  MARK(next);
 	  /* size is given by functor + friends */
 	  if (next < HGEN)
@@ -1819,6 +1819,7 @@ mark_choicepoints(register choiceptr gc_B, tr_fr_ptr saved_TR, int very_verbose)
   
   yamop *lu_cl0 = NEXTOP(PredLogUpdClause0->CodeOfPred,ld),
     *lu_cl = NEXTOP(PredLogUpdClause->CodeOfPred,ld),
+    *lu_cle = NEXTOP(PredLogUpdClauseErase->CodeOfPred,ld),
     *su_cl = NEXTOP(PredStaticClause->CodeOfPred,ld);
 #ifdef TABLING
   dep_fr_ptr depfr = LOCAL_top_dep_fr;
@@ -2133,9 +2134,16 @@ mark_choicepoints(register choiceptr gc_B, tr_fr_ptr saved_TR, int very_verbose)
 
       if (gc_B->cp_ap == lu_cl0 ||
 	  gc_B->cp_ap == lu_cl ||
+	  gc_B->cp_ap == lu_cle ||
 	  gc_B->cp_ap == su_cl) {
-	CELL *pt = (CELL *)IntegerOfTerm(gc_B->cp_args[1]);
+	yamop *pt = (yamop *)IntegerOfTerm(gc_B->cp_args[1]);
-	mark_db_fixed(pt);
+	if (gc_B->cp_ap == su_cl) {
+	  mark_db_fixed((CELL *)pt);
+	} else {
+	  while (pt->opc != trust_lu)
+	    pt = pt->u.lld.n;
+	  mark_ref_in_use((DBRef)pt->u.lld.t.block);
+	}
       }
       /* for each saved register */
       for (saved_reg = &gc_B->cp_a1;
@@ -3595,6 +3603,9 @@ do_gc(Int predarity, CELL *current_env, yamop *nextop)
   if (gc_trace) {
     fprintf(Yap_stderr, "%% gc\n");
   } else if (gc_verbose) {
+#if  defined(YAPOR) || defined(THREADS)
+    fprintf(Yap_stderr, "%% Worker Id %d:\n", worker_id);
+#endif
     fprintf(Yap_stderr, "%% Start of garbage collection %d:\n", GcCalls);
     fprintf(Yap_stderr, "%%       Global: %8ld cells (%p-%p)\n", (long int)heap_cells,H0,H);
     fprintf(Yap_stderr, "%%       Local:%8ld cells (%p-%p)\n", (unsigned long int)(LCL0-ASP),LCL0,ASP);
@@ -3815,15 +3826,16 @@ call_gc(UInt gc_lim, Int predarity, CELL *current_env, yamop *nextop)
   UInt   gc_margin = MinStackGap;
   Term   Tgc_margin;
   Int    effectiveness = 0;
-  int    gc_on = FALSE;
+  int    gc_on = FALSE, gc_t = FALSE;
 
   if (Yap_GetValue(AtomGc) != TermNil)
     gc_on = TRUE;
   if (IsIntegerTerm(Tgc_margin = Yap_GetValue(AtomGcMargin)) &&
       gc_margin > 0) {
     gc_margin = (UInt)IntegerOfTerm(Tgc_margin);
+    gc_t = TRUE;
   } else {
-    /* only go exponential for the first 8 calls */
+    /* only go exponential for the first 6 calls, that would ask about 2MB minimum */
     if (GcCalls < 8) 
       gc_margin <<= GcCalls;
     else {
@@ -3845,8 +3857,8 @@ call_gc(UInt gc_lim, Int predarity, CELL *current_env, yamop *nextop)
     effectiveness = do_gc(predarity, current_env, nextop);
     if (effectiveness < 0)
       return FALSE;
-    if (effectiveness > 90) {
+    if (effectiveness > 90 && !gc_t) {
-      while (gc_margin < H-H0) 
+      while (gc_margin < (H-H0)/sizeof(CELL)) 
 	gc_margin <<= 1;
     }
   } else {
@@ -3856,7 +3868,7 @@ call_gc(UInt gc_lim, Int predarity, CELL *current_env, yamop *nextop)
   if (ASP - H < gc_margin/sizeof(CELL) ||
       effectiveness < 20) {
     LeaveGCMode();
-    return Yap_growstack(gc_margin);
+    return Yap_growstack(gc_margin-((ASP-H)*sizeof(CELL)));
   }
   /*
    * debug for(save_total=1; save_total<=N; ++save_total)

C/index.c

@@ -11,8 +11,11 @@
 * File:		index.c							 *
 * comments:	Indexing a Prolog predicate				 *
 *									 *
-* Last rev:     $Date: 2007-11-26 23:43:08 $,$Author: vsc $						 *
+* Last rev:     $Date: 2008-01-23 17:57:46 $,$Author: vsc $						 *
 * $Log: not supported by cvs2svn $
+* Revision 1.192  2007/11/26 23:43:08  vsc
+* fixes to support threads and assert correctly, even if inefficiently.
+*
 * Revision 1.191  2007/11/08 15:52:15  vsc
 * fix some bugs in new dbterm code.
 *
@@ -488,10 +491,10 @@ cleanup_sw_on_clauses(CELL larg, UInt sz, OPCODE ecls)
 	}
 	UNLOCK(ExpandClausesListLock);
 #if DEBUG
+	Yap_ExpandClauses--;
 	Yap_expand_clauses_sz -= (UInt)(NEXTOP((yamop *)NULL,sp))+xp->u.sp.s1*sizeof(yamop *);
 #endif
 	if (xp->u.sp.p->PredFlags & LogUpdatePredFlag) {
-	  //	fprintf(stderr,"VSC %p %d - %d\n",xp,(UInt)NEXTOP((yamop *)NULL,sp)+xp->u.sp.s1*sizeof(yamop *),Yap_LUIndexSpace_EXT);
 	  Yap_LUIndexSpace_EXT -= (UInt)NEXTOP((yamop *)NULL,sp)+xp->u.sp.s1*sizeof(yamop *);
 	} else
 	  Yap_IndexSpace_EXT -= (UInt)(NEXTOP((yamop *)NULL,sp))+xp->u.sp.s1*sizeof(yamop *);
@@ -2521,7 +2524,6 @@ add_info(ClauseDef *clause, UInt regno)
       return;
 #ifdef BEAM
     case _run_eam:
-      //      clause->Tag = (CELL)NULL;
       cl = NEXTOP(cl,os);
       break;
     case _retry_eam:
@@ -3563,7 +3565,7 @@ emit_type_switch(compiler_vm_op op, struct intermediates *cint)
 
 
 static yamop *
-emit_switch_space(UInt n, UInt item_size, struct intermediates *cint)
+emit_switch_space(UInt n, UInt item_size, struct intermediates *cint, CELL func_mask)
 {
   PredEntry *ap = cint->CurrentPred;
 
@@ -3576,7 +3578,7 @@ emit_switch_space(UInt n, UInt item_size, struct intermediates *cint)
       longjmp(cint->CompilerBotch,2);
     }
     Yap_LUIndexSpace_SW += sz;
-    cl->ClFlags = SwitchTableMask|LogUpdMask;
+    cl->ClFlags = SwitchTableMask|LogUpdMask|func_mask;
     cl->ClSize = sz;
     cl->ClPred = cint->CurrentPred;
     /* insert into code chain */
@@ -3622,7 +3624,7 @@ emit_cswitch(int n, yamop *fail_l, struct intermediates *cint)
     while (cases < n) cases *= 2;
     n = cases;
     op = switch_c_op;
-    target = (AtomSwiEntry *)emit_switch_space(n, sizeof(AtomSwiEntry), cint);
+    target = (AtomSwiEntry *)emit_switch_space(n, sizeof(AtomSwiEntry), cint, 0);
     for (i=0; i<n; i++) {
       target[i].Tag = Zero;
       target[i].u.labp = fail_l;
@@ -3632,7 +3634,7 @@ emit_cswitch(int n, yamop *fail_l, struct intermediates *cint)
     UInt i;
 
     op = if_c_op;
-    target = (AtomSwiEntry *)emit_switch_space(n+1, sizeof(AtomSwiEntry), cint);
+    target = (AtomSwiEntry *)emit_switch_space(n+1, sizeof(AtomSwiEntry), cint, 0);
 
     for (i=0; i<n; i++) {
       target[i].u.labp = fail_l;
@@ -3689,7 +3691,7 @@ emit_fswitch(int n, yamop *fail_l, struct intermediates *cint)
     while (cases < n) cases *= 2;
     n = cases;
     op = switch_f_op;
-    target = (FuncSwiEntry *)emit_switch_space(n, sizeof(FuncSwiEntry), cint);
+    target = (FuncSwiEntry *)emit_switch_space(n, sizeof(FuncSwiEntry), cint, FuncSwitchMask);
     for (i=0; i<n; i++) {
       target[i].Tag = NULL;
       target[i].u.labp = fail_l;
@@ -3699,7 +3701,7 @@ emit_fswitch(int n, yamop *fail_l, struct intermediates *cint)
     UInt i;
 
     op = if_f_op;
-    target = (FuncSwiEntry *)emit_switch_space(n+1, sizeof(FuncSwiEntry), cint);
+    target = (FuncSwiEntry *)emit_switch_space(n+1, sizeof(FuncSwiEntry), cint, FuncSwitchMask);
     for (i=0; i<n; i++) {
       target[i].u.labp = fail_l;
     }
@@ -3913,15 +3915,15 @@ suspend_indexing(ClauseDef *min, ClauseDef *max, PredEntry *ap, struct intermedi
       tels = cls;
     }
     sz = (UInt)NEXTOP((yamop *)NULL,sp)+tels*sizeof(yamop *), sz;
-#if DEBUG
-    Yap_expand_clauses_sz += sz;
-#endif
     if ((ncode = (yamop *)Yap_AllocCodeSpace(sz)) == NULL) {
       save_machine_regs();
       longjmp(cint->CompilerBotch, 2);
     }
+#if DEBUG
+    Yap_ExpandClauses++;
+    Yap_expand_clauses_sz += sz;
+#endif
     if (ap->PredFlags & LogUpdatePredFlag) {
-      //	fprintf(stderr,"VSC %p %d + %d\n",ncode,sz,Yap_LUIndexSpace_EXT);
       Yap_LUIndexSpace_EXT += sz;
     } else {
       Yap_IndexSpace_EXT += sz;
@@ -3980,6 +3982,7 @@ recover_ecls_block(yamop *ipc)
     }
     UNLOCK(ExpandClausesListLock);
 #if DEBUG
+    Yap_ExpandClauses--;
     Yap_expand_clauses_sz -= (UInt)(NEXTOP((yamop *)NULL,sp))+ipc->u.sp.s1*sizeof(yamop *);
 #endif
     /* no dangling pointers for gprof */
@@ -6158,6 +6161,7 @@ replace_index_block(ClauseUnion *parent_block, yamop *cod, yamop *ncod, PredEntr
     if (c == cl) {
       parent_block->lui.ChildIndex = ncl;
     } else {
+      if (cl->PrevSiblingIndex)
 	cl->PrevSiblingIndex->SiblingIndex = ncl;
     }
     if (cl->SiblingIndex) {
@@ -6221,7 +6225,7 @@ expand_ctable(yamop *pc, ClauseUnion *blk, struct intermediates *cint, Term at)
       return fetch_centry(old_ae, at, n-1, n);
     }
     /* initialise */
-    target = (AtomSwiEntry *)emit_switch_space(cases, sizeof(AtomSwiEntry), cint);
+    target = (AtomSwiEntry *)emit_switch_space(cases, sizeof(AtomSwiEntry), cint, 0);
     pc->opc = Yap_opcode(_switch_on_cons);
     pc->u.sssl.s = cases;
     for (i=0; i<cases; i++) {
@@ -6231,7 +6235,7 @@ expand_ctable(yamop *pc, ClauseUnion *blk, struct intermediates *cint, Term at)
   } else {
     pc->opc = Yap_opcode(_if_cons);
     pc->u.sssl.s = n;
-    target = (AtomSwiEntry *)emit_switch_space(n+1, sizeof(AtomSwiEntry), cint);
+    target = (AtomSwiEntry *)emit_switch_space(n+1, sizeof(AtomSwiEntry), cint, 0);
     target[n].Tag = Zero;
     target[n].u.Label = fail_l;
   }
@@ -6285,7 +6289,7 @@ expand_ftable(yamop *pc, ClauseUnion *blk, struct intermediates *cint, Functor f
     pc->u.sssl.e = n;
     pc->u.sssl.w = 0;
     /* initialise */
-    target = (FuncSwiEntry *)emit_switch_space(cases, sizeof(FuncSwiEntry), cint);
+    target = (FuncSwiEntry *)emit_switch_space(cases, sizeof(FuncSwiEntry), cint, FuncSwitchMask);
     for (i=0; i<cases; i++) {
       target[i].Tag = NULL;
       target[i].u.Label = fail_l;
@@ -6295,7 +6299,7 @@ expand_ftable(yamop *pc, ClauseUnion *blk, struct intermediates *cint, Functor f
     pc->u.sssl.s = n;
     pc->u.sssl.e = n;
     pc->u.sssl.w = 0;
-    target = (FuncSwiEntry *)emit_switch_space(n+1, sizeof(FuncSwiEntry), cint);
+    target = (FuncSwiEntry *)emit_switch_space(n+1, sizeof(FuncSwiEntry), cint, FuncSwitchMask);
     target[n].Tag = Zero;
     target[n].u.Label = fail_l;
   }
@@ -7354,7 +7358,6 @@ remove_from_index(PredEntry *ap, path_stack_entry *sp, ClauseDef *cls, yamop *bg
   yamop *ipc = ap->cs.p_code.TrueCodeOfPred;
   UInt current_arity = 0;
 
-  sp = init_block_stack(sp, ipc, ap);
   if (ap->cs.p_code.NOfClauses == 1) {
     if (ap->PredFlags & IndexedPredFlag) {
       Yap_RemoveIndexation(ap);
@@ -7377,6 +7380,7 @@ remove_from_index(PredEntry *ap, path_stack_entry *sp, ClauseDef *cls, yamop *bg
     }
     return;
   }
+  sp = init_block_stack(sp, ipc, ap);
   /* try to refine the interval using the indexing code */
   while (ipc != NULL) {
     op_numbers op = Yap_op_from_opcode(ipc->opc);
@@ -7819,15 +7823,14 @@ Yap_RemoveClauseFromIndex(PredEntry *ap, yamop *beg) {
     if (ap->PredFlags & LogUpdatePredFlag &&
 	ap->ModuleOfPred != IDB_MODULE) {
       ap->cs.p_code.TrueCodeOfPred = FAILCODE;
-      ap->OpcodeOfPred = LOCKPRED_OPCODE;
       ap->CodeOfPred = (yamop *)(&(ap->OpcodeOfPred)); 
     } else {
 #endif
       ap->CodeOfPred = ap->cs.p_code.TrueCodeOfPred = FAILCODE;
-      ap->OpcodeOfPred = Yap_opcode(_op_fail);
 #if defined(YAPOR) || defined(THREADS)
     }
 #endif
+    ap->OpcodeOfPred = Yap_opcode(_op_fail);
   } else {
     remove_from_index(ap, sp, &cl, beg, last, &cint); 
   }
@@ -8078,7 +8081,7 @@ Yap_FollowIndexingCode(PredEntry *ap, yamop *ipc, Term Terms[3], yamop *ap_pc, y
 	update_clause_choice_point(ipc->u.lld.n, ap_pc);
       }
       {
-	UInt timestamp = ((CELL *)(B+1))[5];
+	UInt timestamp = IntegerOfTerm(((CELL *)(B+1))[5]);
    
 	if (!VALID_TIMESTAMP(timestamp, ipc->u.lld.d)) {
 	  /* jump to next instruction */
@@ -8091,7 +8094,7 @@ Yap_FollowIndexingCode(PredEntry *ap, yamop *ipc, Term Terms[3], yamop *ap_pc, y
     case _profiled_retry_logical:
     case _count_retry_logical:
       {
-	UInt timestamp = ((CELL *)(B+1))[5];
+	UInt timestamp = IntegerOfTerm(((CELL *)(B+1))[5]);
 	if (!VALID_TIMESTAMP(timestamp, ipc->u.lld.d)) {
 	  /* jump to next instruction */
 	  ipc = ipc->u.lld.n;
@@ -8139,7 +8142,7 @@ Yap_FollowIndexingCode(PredEntry *ap, yamop *ipc, Term Terms[3], yamop *ap_pc, y
 	  /* next, recover space for the indexing code if it was erased */
 	  if (cl->ClFlags & (ErasedMask|DirtyMask)) {
 	    LogUpdClause *lcl = ipc->u.lld.d;
-	    /* make sure we don't erase the clause we are jumping too */
+	    /* make sure we don't erase the clause we are jumping to */
 	    if (lcl->ClRefCount == 1 && !(lcl->ClFlags & (DirtyMask|InUseMask))) {
 	      lcl->ClFlags |= InUseMask;
 	      TRAIL_CLREF(lcl);

C/init.c

@@ -915,6 +915,7 @@ InitCodes(void)
   Yap_heap_regs->expand_op_code = Yap_opcode(_expand_index);
   Yap_heap_regs->expand_clauses_first = NULL;
   Yap_heap_regs->expand_clauses_last = NULL;
+  Yap_heap_regs->expand_clauses = 0;
   Yap_heap_regs->failcode->opc = Yap_opcode(_op_fail);
   Yap_heap_regs->failcode_1 = Yap_opcode(_op_fail);
   Yap_heap_regs->failcode_2 = Yap_opcode(_op_fail);
@@ -986,8 +987,14 @@ InitCodes(void)
       Yap_heap_regs->wl[i].static_arrays = NULL;
       Yap_heap_regs->wl[i].global_variables = NULL;
       Yap_heap_regs->wl[i].global_arena = 0L;
+      Yap_heap_regs->wl[i].global_arena_overflows = 0;
       Yap_heap_regs->wl[i].global_delay_arena = 0L;
       Yap_heap_regs->wl[i].allow_restart = FALSE;
+      Yap_heap_regs->wl[i].tot_gc_time = 0;
+      Yap_heap_regs->wl[i].tot_gc_recovered = 0;
+      Yap_heap_regs->wl[i].gc_calls = 0;
+      Yap_heap_regs->wl[i].last_gc_time = 0;
+      Yap_heap_regs->wl[i].last_ss_time = 0;
       Yap_heap_regs->wl[i].consultlow = (consult_obj *)Yap_AllocCodeSpace(sizeof(consult_obj)*InitialConsultCapacity);
       if (Yap_heap_regs->wl[i].consultlow == NULL) {
 	Yap_Error(OUT_OF_HEAP_ERROR,TermNil,"No Heap Space in InitCodes");
@@ -1003,8 +1010,14 @@ InitCodes(void)
   Yap_heap_regs->wl.static_arrays = NULL;
   Yap_heap_regs->wl.global_variables = NULL;
   Yap_heap_regs->wl.global_arena = 0L;
+  Yap_heap_regs->wl.global_arena_overflows = 0;
   Yap_heap_regs->wl.allow_restart = FALSE;
   Yap_heap_regs->wl.global_delay_arena = 0L;
+  Yap_heap_regs->wl.tot_gc_time = 0;
+  Yap_heap_regs->wl.tot_gc_recovered = 0;
+  Yap_heap_regs->wl.gc_calls = 0;
+  Yap_heap_regs->wl.last_gc_time = 0;
+  Yap_heap_regs->wl.last_ss_time = 0;
   Yap_heap_regs->wl.consultlow = (consult_obj *)Yap_AllocCodeSpace(sizeof(consult_obj)*InitialConsultCapacity);
   if (Yap_heap_regs->wl.consultlow == NULL) {
     Yap_Error(OUT_OF_HEAP_ERROR,TermNil,"No Heap Space in InitCodes");
@@ -1251,6 +1264,7 @@ InitCodes(void)
   Yap_heap_regs->pred_dollar_catch = RepPredProp(PredPropByFunc(Yap_MkFunctor(Yap_FullLookupAtom("$catch"),3),PROLOG_MODULE));
   Yap_heap_regs->pred_recorded_with_key = RepPredProp(PredPropByFunc(Yap_MkFunctor(Yap_FullLookupAtom("$recorded_with_key"),3),PROLOG_MODULE));
   Yap_heap_regs->pred_log_upd_clause = RepPredProp(PredPropByFunc(Yap_MkFunctor(Yap_FullLookupAtom("$do_log_upd_clause"),6),PROLOG_MODULE));
+  Yap_heap_regs->pred_log_upd_clause_erase = RepPredProp(PredPropByFunc(Yap_MkFunctor(Yap_FullLookupAtom("$do_log_upd_clause_erase"),6),PROLOG_MODULE));
   Yap_heap_regs->pred_log_upd_clause0 = RepPredProp(PredPropByFunc(Yap_MkFunctor(Yap_FullLookupAtom("$do_log_upd_clause0"),6),PROLOG_MODULE));
   Yap_heap_regs->pred_static_clause = RepPredProp(PredPropByFunc(Yap_MkFunctor(Yap_FullLookupAtom("$do_static_clause"),5),PROLOG_MODULE));
   Yap_heap_regs->pred_throw = RepPredProp(PredPropByFunc(FunctorThrow,PROLOG_MODULE));
@@ -1271,6 +1285,7 @@ InitCodes(void)
   Yap_heap_regs->db_erased_marker =
     (DBRef)Yap_AllocCodeSpace(sizeof(DBStruct));
   Yap_LUClauseSpace += sizeof(DBStruct);
+  Yap_heap_regs->dbterms_list = NULL;
   Yap_heap_regs->db_erased_marker->id = FunctorDBRef;
   Yap_heap_regs->db_erased_marker->Flags = ErasedMask;
   Yap_heap_regs->db_erased_marker->Code = NULL;
@@ -1420,7 +1435,6 @@ Yap_InitWorkspace(int Heap, int Stack, int Trail, int max_table_size,
   for (i = 0; i <= LAST_FLAG; i++) {
     yap_flags[i] = 0;
   }
-  GcCalls = 0;
 #ifdef LOW_PROF
   ProfilerOn = FALSE;
   FPreds = NULL;

C/inlines.c

@@ -406,6 +406,7 @@ p_dif(void)
      */
     HBREG = H;
     B = (choiceptr) H;
+    B->cp_h = H;
     SET_BB(B);
     save_hb();
     d0 = Yap_IUnify(d0, d1);

C/iopreds.c

@@ -3087,6 +3087,8 @@ static Int
 init_cur_s (void)
 {				/* Init current_stream */
   Term t3 = Deref(ARG3);
+  /* make valgrind happy by always filling in memory */
+  EXTRA_CBACK_ARG (3, 1) = MkIntTerm (0);
   if (!IsVarTerm(t3)) {
     
     Int i;
@@ -3107,7 +3109,6 @@ init_cur_s (void)
       cut_fail();
     }
   } else {
-    EXTRA_CBACK_ARG (3, 1) = MkIntTerm (0);
     return (cont_cur_s ());
   }
 }

C/load_foreign.c

@@ -39,8 +39,8 @@ STD_PROTO(Int p_load_foreign, (void));
 Int
 p_load_foreign(void)
 {
-  StringList ofiles = NIL;
+  StringList ofiles = NULL;
-  StringList libs = NIL;
+  StringList libs = NULL;
   char *InitProcName;
   YapInitProc InitProc = NULL;
   Term t, t1;
@@ -94,6 +94,17 @@ p_load_foreign(void)
     f_code->next = ForeignCodeLoaded;
     f_code->module = CurrentModule;
     ForeignCodeLoaded = (void *)f_code;
+  } else {
+    while (ofiles) {
+      new = ofiles->next;
+      Yap_FreeCodeSpace((ADDR)ofiles);
+      ofiles = new;
+    }
+    while (libs) {
+      new = libs->next;
+      Yap_FreeCodeSpace((ADDR)libs);
+      libs = new;
+    }
   }
   return returncode;
 }

C/stdpreds.c

@@ -11,8 +11,11 @@
 * File:		stdpreds.c						 *
 * comments:	General-purpose C implemented system predicates		 *
 *									 *
-* Last rev:     $Date: 2007-11-26 23:43:08 $,$Author: vsc $						 *
+* Last rev:     $Date: 2008-01-23 17:57:53 $,$Author: vsc $						 *
 * $Log: not supported by cvs2svn $
+* Revision 1.124  2007/11/26 23:43:08  vsc
+* fixes to support threads and assert correctly, even if inefficiently.
+*
 * Revision 1.123  2007/11/06 17:02:12  vsc
 * compile ground terms away.
 *
@@ -727,9 +730,6 @@ runtime(void)
   return(Yap_cputime()-Yap_total_gc_time()-Yap_total_stack_shift_time());
 }
 
-Int last_gc_time = 0;
-Int last_ss_time = 0;
-
 /* $runtime(-SinceInterval,-SinceStart)	 */
 static Int 
 p_runtime(void)
@@ -737,16 +737,20 @@ p_runtime(void)
   Int now, interval,
     gc_time,
     ss_time;
+  Term tnow, tinterval;
 
   Yap_cputime_interval(&now, &interval);
   gc_time = Yap_total_gc_time();
+  now -= gc_time;
   ss_time = Yap_total_stack_shift_time();
-  now -= gc_time+ss_time;
+  now -= ss_time;
-  interval -= (gc_time-last_gc_time)+(ss_time-last_ss_time);
+  interval -= (gc_time-LastGcTime)+(ss_time-LastSSTime);
-  last_gc_time = gc_time;
+  LastGcTime = gc_time;
-  last_ss_time = ss_time;
+  LastSSTime = ss_time;
-  return( Yap_unify_constant(ARG1, MkIntegerTerm(now)) && 
+  tnow = MkIntegerTerm(now);
-	 Yap_unify_constant(ARG2, MkIntegerTerm(interval)) );
+  tinterval = MkIntegerTerm(interval);
+  return( Yap_unify_constant(ARG1, tnow) && 
+	 Yap_unify_constant(ARG2, tinterval) );
 }
 
 /* $cputime(-SinceInterval,-SinceStart)	 */
@@ -3229,7 +3233,7 @@ p_statistics_heap_info(void)
 
   Term tmax = MkIntegerTerm((mi.arena+mi.hblkhd)-Yap_HoleSize);
 #else
-  Term tmax = MkIntegerTerm((Unsigned(H0) - Unsigned(Yap_HeapBase))-Yap_HoleSize);
+  Term tmax = MkIntegerTerm((Yap_GlobalBase - Yap_HeapBase)-Yap_HoleSize);
 #endif
 
   return(Yap_unify(tmax, ARG1) && Yap_unify(tusage,ARG2));

C/tracer.c

@@ -161,6 +161,8 @@ low_level_trace(yap_low_level_port port, PredEntry *pred, CELL *args)
   LOCK(Yap_heap_regs->low_level_trace_lock);
   sc = Yap_heap_regs;
   vsc_count++;
+  //*(H0+(0xb65f2850-0xb64b2008)/sizeof(CELL))==0xc || 
+  //0x4fd4d
 #ifdef COMMENTED
   if (vsc_count == 40650191LL)
     jmp_deb(1);

H/Heap.h

@@ -10,7 +10,7 @@
 * File:		Heap.h         						 *
 * mods:									 *
 * comments:	Heap Init Structure					 *
-* version:      $Id: Heap.h,v 1.122 2007-12-05 12:17:23 vsc Exp $	 *
+* version:      $Id: Heap.h,v 1.123 2008-01-23 17:57:53 vsc Exp $	 *
 *************************************************************************/
 
 /* information that can be stored in Code Space */
@@ -88,6 +88,7 @@ typedef struct restore_info {
   CELL    *g_split;
   tr_fr_ptr old_TR;  
   CELL    *old_GlobalBase, *old_H, *old_H0;
+  CELL    *old_DelayTop, *current_DelayTop;
   ADDR     old_TrailBase, old_TrailTop;
   ADDR     old_HeapBase, old_HeapTop;
 } restoreinfo;
@@ -131,6 +132,7 @@ typedef struct worker_local_struct {
   unsigned int      gc_calls;	/* number of times GC has been called */ 
   Int      tot_gc_time; /* total time spent in GC */
   YAP_ULONG_LONG      tot_gc_recovered; /* number of heap objects in all garbage collections */
+  Int      last_gc_time, last_ss_time; /* number of heap objects in all garbage collections */
 /* in a single gc */
 #if defined(YAPOR) || defined(THREADS)
   /* otherwise, use global variables for speed */
@@ -238,6 +240,7 @@ typedef struct various_codes {
 #endif /* TABLING */
   OPCODE expand_op_code;
   yamop *expand_clauses_first, *expand_clauses_last;
+  UInt expand_clauses;
 #if defined(YAPOR) || defined(THREADS)
   lockvar expand_clauses_list_lock;
   lockvar op_list_lock;
@@ -504,6 +507,7 @@ typedef struct various_codes {
   struct pred_entry *pred_dollar_catch;
   struct pred_entry *pred_recorded_with_key;
   struct pred_entry *pred_log_upd_clause;
+  struct pred_entry *pred_log_upd_clause_erase;
   struct pred_entry *pred_log_upd_clause0;
   struct pred_entry *pred_static_clause;
   struct pred_entry *pred_throw;
@@ -611,6 +615,7 @@ struct various_codes *Yap_heap_regs;
 #define  ExpandClausesFirst       Yap_heap_regs->expand_clauses_first
 #define  ExpandClausesLast        Yap_heap_regs->expand_clauses_last
 #define  ExpandClausesListLock    Yap_heap_regs->expand_clauses_list_lock
+#define  Yap_ExpandClauses        Yap_heap_regs->expand_clauses
 #define  OpListLock               Yap_heap_regs->op_list_lock
 #define  COMMA_CODE               Yap_heap_regs->comma_code
 #define  FAILCODE                 Yap_heap_regs->failcode
@@ -809,6 +814,7 @@ struct various_codes *Yap_heap_regs;
 #define  PredDollarCatch          Yap_heap_regs->pred_dollar_catch
 #define  PredRecordedWithKey      Yap_heap_regs->pred_recorded_with_key
 #define  PredLogUpdClause         Yap_heap_regs->pred_log_upd_clause
+#define  PredLogUpdClauseErase    Yap_heap_regs->pred_log_upd_clause_erase
 #define  PredLogUpdClause0        Yap_heap_regs->pred_log_upd_clause0
 #define  PredStaticClause         Yap_heap_regs->pred_static_clause
 #define  PredThrow                Yap_heap_regs->pred_throw
@@ -886,6 +892,8 @@ struct various_codes *Yap_heap_regs;
 #define  OldTrailTop              RINFO.old_TrailTop
 #define  OldHeapBase              RINFO.old_HeapBase
 #define  OldHeapTop               RINFO.old_HeapTop
+#define  OldDelayTop              RINFO.old_DelayTop
+#define  CurrentDelayTop          RINFO.current_DelayTop
 #define  ClDiff                   RINFO.cl_diff
 #define  GDiff                    RINFO.g_diff
 #define  GDiff0                   RINFO.g_diff0
@@ -924,6 +932,8 @@ struct various_codes *Yap_heap_regs;
 #define  GcCalls                  Yap_heap_regs->WL.gc_calls
 #define  TotGcTime                Yap_heap_regs->WL.tot_gc_time
 #define  TotGcRecovered           Yap_heap_regs->WL.tot_gc_recovered
+#define  LastGcTime               Yap_heap_regs->WL.last_gc_time
+#define  LastSSTime               Yap_heap_regs->WL.last_ss_time
 #define  Yap_gc_restore           Yap_heap_regs->WL.gc_restore
 #define  TrustLUCode              Yap_heap_regs->WL.trust_lu_code
 #define  DynamicArrays            Yap_heap_regs->WL.dynamic_arrays

H/Yatom.h

@@ -798,6 +798,7 @@ IsPredProperty (int flags)
 /* There are several flags for code and data base entries */
 typedef enum
 {
+  FuncSwitchMask = 0x800000,	/* is a switch of functors */
   HasDBTMask = 0x400000,	/* includes a pointer to a DBTerm */
   MegaMask = 0x200000,		/* mega clause */
   FactMask = 0x100000,		/* a fact */

H/alloc.h

@@ -80,15 +80,17 @@ typedef	struct FREEB {
 /* I'll assume page size is always a power of two */
 #if _WIN32
 /* in WIN32 VirtualAlloc works in multiples of 64K */
-#define ALLOC_SIZE (64*1024)
+#define YAP_ALLOC_SIZE (64*1024)
+#define LG_PAGE_SIZE ALLOC_SIZE
 
-#define AdjustPageSize(X)  (((X)+ (ALLOC_SIZE-1))/ALLOC_SIZE)*ALLOC_SIZE;
 #else
-#define AdjustPageSize(X)  ((X) & (Yap_page_size-1) ? \
+#define YAP_ALLOC_SIZE Yap_page_size
-      ((X) + Yap_page_size) & (~(Yap_page_size-1)) :      \
+#define LGPAGE_SIZE (16*Yap_page_size)
-      (X) )
 #endif
 
+#define AdjustPageSize(X)  (((X)+ (YAP_ALLOC_SIZE-1))/YAP_ALLOC_SIZE)*YAP_ALLOC_SIZE;
+#define AdjustLargePageSize(X)  (((X)+ (LGPAGE_SIZE-1))/LGPAGE_SIZE)*LGPAGE_SIZE;
+
 #define BlockTrailer(b)		((YAP_SEG_SIZE *)b)[((BlockHeader *) b)->b_size]
 
 /* Operating system and architecture dependent page size */

H/clause.h

@@ -221,6 +221,7 @@ Term    STD_PROTO(Yap_cp_as_integer,(choiceptr));
 yamop   *STD_PROTO(Yap_PredIsIndexable,(PredEntry *, UInt));
 yamop   *STD_PROTO(Yap_ExpandIndex,(PredEntry *, UInt));
 void     STD_PROTO(Yap_CleanUpIndex,(struct logic_upd_index *));
+void     STD_PROTO(Yap_CleanKids,(struct logic_upd_index *));
 void     STD_PROTO(Yap_AddClauseToIndex,(PredEntry *,yamop *,int));
 void     STD_PROTO(Yap_RemoveClauseFromIndex,(PredEntry *,yamop *));
 LogUpdClause  *STD_PROTO(Yap_NthClause,(PredEntry *,Int));

H/rclause.h

@@ -12,8 +12,11 @@
 * File:		rclause.h						 *
 * comments:	walk through a clause					 *
 *									 *
-* Last rev:     $Date: 2007-11-26 23:43:09 $,$Author: vsc $						 *
+* Last rev:     $Date: 2008-01-23 17:57:55 $,$Author: vsc $						 *
 * $Log: not supported by cvs2svn $
+* Revision 1.21  2007/11/26 23:43:09  vsc
+* fixes to support threads and assert correctly, even if inefficiently.
+*
 * Revision 1.20  2007/11/07 09:25:27  vsc
 * speedup meta-calls
 *

H/rheap.h

@@ -11,8 +11,13 @@
 * File:		rheap.h							 *
 * comments:	walk through heap code					 *
 *									 *
-* Last rev:     $Date: 2007-12-05 12:17:23 $,$Author: vsc $						 *
+* Last rev:     $Date: 2008-01-23 17:57:55 $,$Author: vsc $						 *
 * $Log: not supported by cvs2svn $
+* Revision 1.82  2007/12/05 12:17:23  vsc
+* improve JT
+* fix graph compatibility with SICStus
+* re-export declaration.
+*
 * Revision 1.81  2007/11/26 23:43:09  vsc
 * fixes to support threads and assert correctly, even if inefficiently.
 *
@@ -360,14 +365,45 @@ RestoreDBTermEntry(struct dbterm_list *dbl) {
   }
 }
 
+static void
+restore_switch(CELL *start, CELL *end, int is_func)
+{
+  CELL *pt = start;
+  if (is_func) {
+    while (pt < end) {
+      yamop **x = (yamop **)(pt+1);
+      Functor *fp = (Functor *)pt;
+
+      *fp = FuncAdjust(*fp);
+      *x = PtoOpAdjust(*x);
+      pt += 2;
+    }
+  } else {
+    while (pt < end) {
+      Term *tp = (Term *)pt;
+      Term t = *tp;
+      yamop **x = (yamop **)(pt+1);
+
+      if (IsAtomTerm(t))
+	*tp = AtomTermAdjust(t);
+      else if (IsApplTerm(t) && *(Functor *)DBRefAdjust(DBRefOfTerm(t)) == FunctorDBRef)
+	*tp = AbsAppl((CELL *)DBRefAdjust(DBRefOfTerm(t)));
+      *x = PtoOpAdjust(*x);
+      pt += 2;
+    }
+  }
+}
+
 static void 
 CleanLUIndex(LogUpdIndex *idx)
 {
-  idx->ClRefCount = 0;
   INIT_LOCK(idx->ClLock);
   idx->ClPred = PtoPredAdjust(idx->ClPred);
   if (idx->ParentIndex)
     idx->ParentIndex = LUIndexAdjust(idx->ParentIndex);
+  if (idx->PrevSiblingIndex) {
+    idx->PrevSiblingIndex = LUIndexAdjust(idx->PrevSiblingIndex);
+  }
   if (idx->SiblingIndex) {
     idx->SiblingIndex = LUIndexAdjust(idx->SiblingIndex);
     CleanLUIndex(idx->SiblingIndex);
@@ -376,7 +412,9 @@ CleanLUIndex(LogUpdIndex *idx)
     idx->ChildIndex = LUIndexAdjust(idx->ChildIndex);
     CleanLUIndex(idx->ChildIndex);
   }
-  if (!(idx->ClFlags & SwitchTableMask)) {
+  if (idx->ClFlags & SwitchTableMask) {
+    restore_switch((CELL *)idx->ClCode, (CELL *)((char *)idx+idx->ClSize), ((idx->ClFlags & FuncSwitchMask) == FuncSwitchMask));
+  } else {
     restore_opcodes(idx->ClCode);
   }
 }
@@ -393,7 +431,9 @@ CleanSIndex(StaticIndex *idx)
     idx->ChildIndex = SIndexAdjust(idx->ChildIndex);
     CleanSIndex(idx->ChildIndex);
   }
-  if (!(idx->ClFlags & SwitchTableMask)) {
+  if (idx->ClFlags & SwitchTableMask) {
+    restore_switch((CELL *)idx->ClCode, (CELL *)((char *)idx+idx->ClSize), ((idx->ClFlags & FuncSwitchMask) == FuncSwitchMask));
+  } else {
     restore_opcodes(idx->ClCode);
   }
 }
@@ -760,6 +800,8 @@ restore_codes(void)
     PredEntryAdjust(Yap_heap_regs->pred_recorded_with_key);
   Yap_heap_regs->pred_log_upd_clause =
     PredEntryAdjust(Yap_heap_regs->pred_log_upd_clause);
+  Yap_heap_regs->pred_log_upd_clause_erase =
+    PredEntryAdjust(Yap_heap_regs->pred_log_upd_clause_erase);
   Yap_heap_regs->pred_log_upd_clause0 =
     PredEntryAdjust(Yap_heap_regs->pred_log_upd_clause0);
   Yap_heap_regs->pred_static_clause =

H/sshift.h

@@ -31,7 +31,11 @@ inline EXTERN int IsHeapP (CELL *);
 inline EXTERN int
 IsHeapP (CELL * ptr)
 {
+#if USE_SYSTEM_MALLOC
+  return (int) ((ptr < (CELL *) Yap_GlobalBase || ptr > (CELL *) Yap_TrailTop));
+#else
   return (int) ((ptr >= (CELL *) Yap_HeapBase && ptr <= (CELL *) HeapTop));
+#endif
 }
 
 
@@ -740,7 +744,11 @@ inline EXTERN int IsOldCode (CELL);
 inline EXTERN int
 IsOldCode (CELL reg)
 {
+#if USE_SYSTEM_MALLOC
+  return reg < (CELL)OldGlobalBase || reg > (CELL)OldTrailTop;
+#else 
   return (int) (IN_BETWEEN (OldHeapBase, reg, OldHeapTop));
+#endif
 }
 
 

changes-5.1.html

@@ -17,6 +17,14 @@
 
 <h2>Yap-5.1.3:</h2>
 <ul>
+<li> NEW: start atom garbage collector by default (except for threads).</li>
+<li> FIXED: restore indices should run over the indices, and not mess
+  them up.</li>
+<li> FIXED: make sure to always remove try-trust chains.</li>
+<li> FIXED: don't adjust garbage when doing stack shift.</li>
+<li> FIXED: stack shifter would get ignore big terms.</li>
+<li> FIXED: retract and friends should remove mf pointers.</li>
+<li> FIXED: small memory leaks and use of uninitialised memory (valgrind).</li>
 <li> NEW: char_type/2 and code_type/2 (request from Brian DeVries).</li>
 <li> FIXED: memory leak where I'd try to clear refs from an index
 block before I released the kids (so the refs would never be released).</li>

pl/consult.yap

@@ -297,6 +297,7 @@ use_module(M,F,Is) :-
 	'$show_consult_level'(Level1),
 	% it will be done after we leave the current consult level.
 	Level is Level1-1,
+	format(user_error,'add~w~n',[G]),
 	recorda('$initialisation',do(Level,G),_),
 	fail.
 '$initialization'(_).

pl/errors.yap

@@ -11,8 +11,11 @@
 * File:		errors.yap						 *
 * comments:	error messages for YAP					 *
 *									 *
-* Last rev:     $Date: 2007-11-26 23:43:10 $,$Author: vsc $						 *
+* Last rev:     $Date: 2008-01-23 17:57:55 $,$Author: vsc $						 *
 * $Log: not supported by cvs2svn $
+* Revision 1.83  2007/11/26 23:43:10  vsc
+* fixes to support threads and assert correctly, even if inefficiently.
+*
 * Revision 1.82  2007/09/27 23:02:00  vsc
 * encoding/1
 *
@@ -666,6 +669,9 @@ print_message(Level, Mss) :-
 '$output_error_message'(existence_error(stream,Stream), Where) :-
 	format(user_error,'% EXISTENCE ERROR- ~w: ~w not an open stream~n',
 	[Where,Stream]).
+'$output_error_message'(existence_error(thread,Thread), Where) :-
+	format(user_error,'% EXISTENCE ERROR- ~w: ~w not a running thread~n',
+	[Where,Thread]).
 '$output_error_message'(evaluation_error(int_overflow), Where) :-
 	format(user_error,'% INTEGER OVERFLOW ERROR- ~w~n',
 	[Where]).

pl/preds.yap

@@ -339,6 +339,13 @@ clause(V,Q,R) :-
 
 :- '$do_log_upd_clause'(_,_,_,_,_,_), !.
 
+'$do_log_upd_clause_erase'(_,_,_,_,_,_).
+'$do_log_upd_clause_erase'(A,B,C,D,E,_) :-
+	'$continue_log_update_clause_erase'(A,B,C,D,E).
+'$do_log_upd_clause_erase'(_,_,_,_,_,_).
+
+:- '$do_log_upd_clause_erase'(_,_,_,_,_,_), !.
+
 '$do_log_upd_clause0'(_,_,_,_,_,_).
 '$do_log_upd_clause0'(A,B,C,D,_,_) :-
 	'$continue_log_update_clause'(A,B,C,D).
@@ -405,21 +412,27 @@ retract(C) :-
 	'$retract'(C,M).
 '$retract'(C,M) :- 
 	'$check_head_and_body'(C,H,B,retract(M:C)), !,
-	'$retract2'(H,M,B).
+	'$flags'(H, M, F, F),
+	'$retract2'(F, H,M,B,_).
 
-'$retract2'(H,M,B) :- 	
+'$retract2'(F, H, M, B, R) :-
-	'$is_log_updatable'(H, M), !,
+	F /\ 0x08000000 =:= 0x08000000, !,
+%	'$is_log_updatable'(H, M), !,
 	'$log_update_clause'(H,M,B,R),
+	( F /\ 0x20000000  =:= 0x20000000, recorded('$mf','$mf_clause'(_,_,_,_,R),MR), erase(MR), fail ; true),
 	erase(R).
-'$retract2'(H,M,B) :- 	
+'$retract2'(F, H, M, B, R) :- 	
-	'$is_dynamic'(H,M), !,
+%	'$is_dynamic'(H,M), !,
-	'$recordedp'(M:H,(H:-B),R), erase(R).
+	F /\ 0x00002000 =:= 0x00002000, !,
-'$retract2'(H,M,_) :- 	
+	'$recordedp'(M:H,(H:-B),R),
+	( F /\ 0x20000000  =:= 0x20000000, recorded('$mf','$mf_clause'(_,_,_,_,MRef),MR), erase(MR), fail ; true),
+	erase(R).
+'$retract2'(_, H,M,_,_) :- 	
 	'$undefined'(H,M), !,
 	functor(H,Na,Ar),
 	'$dynamic'(Na/Ar,M),
 	fail.
-'$retract2'(H,M,B) :- 	
+'$retract2'(_, H,M,B,_) :- 	
 	functor(H,Na,Ar),
 	'$do_error'(permission_error(modify,static_procedure,Na/Ar),retract(M:(H:-B))).
 
@@ -439,16 +452,8 @@ retract(C,R) :-
 	instance(R,(H:-B)), erase(R).
 '$retract'(C,M,R) :-
 	'$check_head_and_body'(C,H,B,retract(C,R)),
-	'$is_dynamic'(H,M), !,
+	var(R), !,
-	var(R),
+	'$retract2'(H, M, B, R).
-	'$recordedp'(M:H,(H:-B),R),
-	erase(R).
-'$retract'(C,M,R) :- 
-	'$check_head_and_body'(C,H,_,retract(M:C,R)),
-	'$undefined'(H,M), !,
-	functor(H,Na,Ar),
-	'$dynamic'(Na/Ar,M),
-	fail.
 '$retract'(C,M,_) :-
 	'$fetch_predicate_indicator_from_clause'(C, PI),
 	'$do_error'(permission_error(modify,static_procedure,PI),retract(M:C)).
@@ -472,7 +477,11 @@ retractall(V) :-
 '$retractall'(T,M) :-
 	(
 	  '$is_log_updatable'(T, M) ->
+	 ( '$is_multifile'(T, M) ->
+	   '$retractall_lu_mf'(T,M)
+	 ;
 	   '$retractall_lu'(T,M)
+	 )
 	;
 	  '$undefined'(T,M) ->
 	  functor(T,Na,Ar),
@@ -485,13 +494,19 @@ retractall(V) :-
 	  '$do_error'(permission_error(modify,static_procedure,Na/Ar),retractall(T))
 	).
 	
-
 '$retractall_lu'(T,M) :-
 	'$log_update_clause'(T,M,_,R),
 	erase(R),
 	fail.
 '$retractall_lu'(_,_).
 
+'$retractall_lu_mf'(T,M) :-
+	'$log_update_clause'(T,M,_,R),
+	( recorded('$mf','$mf_clause'(_,_,_,_,R),MR), erase(MR), fail ; true),
+	erase(R),
+	fail.
+'$retractall_lu_mf'(_,_).
+
 '$erase_all_clauses_for_dynamic'(T, M) :-
 	'$recordedp'(M:T,(T :- _),R), erase(R), fail.
 '$erase_all_clauses_for_dynamic'(T,M) :-
@@ -777,7 +792,7 @@ hide_predicate(M:P) :- !,
 	'$hide_predicate2'(P, M).
 hide_predicate(P) :-
 	'$current_module'(M),
-	'$hide_predicate2'(M, P).
+	'$hide_predicate2'(P, M).
 
 '$hide_predicate2'(V, M) :- var(V), !,
 	'$do_error'(instantiation_error,hide_predicate(M:V)).

pl/threads.yap

@@ -38,18 +38,19 @@
 	'$thread_self'(Id),
 	(Detached == true -> '$detach_thread'(Id) ; true),
 	'$current_module'(Module),
-	'$system_catch'((G,'$close_thread'(Detached,true) ; '$close_thread'(Detached,false)),Module,Exception,'$thread_exception'(Exception,Detached)).
+	% always finish with a throw to make sure we clean stacks.
+	'$system_catch'((G -> throw('$thread_finished'(true)) ; throw('$thread_finished'(false))),Module,Exception,'$close_thread'(Exception,Detached)).
 
-'$close_thread'(Detached, Status) :-
+'$close_thread'('$thread_finished'(Status), Detached) :- !,
 	'$thread_self'(Id0),
 	(Detached == true ->
 	    true
 	;
 	    recorda('$thread_exit_status', [Id0|Status], _)
 	),
+	format(user_error,'closing thread ~w~n',[v([Id0|Status])]).
 	'$run_at_thread_exit'(Id0).	
-
+'$close_thread'(Exception,Detached) :-
-'$thread_exception'(Exception,Detached) :-
 	'$thread_self'(Id0),
 	(Detached == true ->
 	    true

pl/utils.yap

@@ -200,17 +200,24 @@ call_cleanup(Goal, Catcher, Cleanup) :-
 '$call_cleanup'(Goal, Cleanup, Result) :-
 	'$freeze_goal'(Result, '$clean_call'(Cleanup)),
 	yap_hacks:trail_suspension_marker(Result),
+	(
 	 yap_hacks:current_choice_point(CP0),
-	(	'$execute'(Goal),
+	 '$execute'(Goal),
 	 yap_hacks:current_choice_point(CPF),
-		(	CP0 =:= CPF ->
+	 (
-	    	Result = exit, !
+	  CP0 =:= CPF ->
-		;	true
+	  Result = exit,
+	  !
+	 ;
+	  true
 	 )
-	;	Result = fail,
+	;
+	 Result = fail,
 	 fail
 	).
 
+'$holds_true'.
+
 '$clean_call'(Cleanup) :-
 	'$execute'(Cleanup), !.
 '$clean_call'(_).