nb_ extra stuff plus an indexing overflow fix.

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

C/globals.c

@@ -908,197 +908,6 @@ CopyTermToArena(Term t, Term arena, int share, UInt arity, Term *newarena, Term
   goto restart;
 }
 
-static Term
-AddTermToArena(Term t, Term arena, UInt arity, Term *newarena, Term *att_arenap, UInt min_grow)
-{
-  UInt old_size = ArenaSz(arena);
-  CELL *oldH = H;
-  CELL *oldHB = HB;
-  CELL *oldASP = ASP;
-  int res;
-#if COROUTINING
-  Term old_delay_arena;
-#endif
-
- restart:
-#if COROUTINING
-  old_delay_arena = *att_arenap;
-#endif
-  t = Deref(t);
-  if (IsVarTerm(t)) {
-    ASP = ArenaLimit(arena);
-    H = HB = ArenaPt(arena);
-#if COROUTINING
-    if (IsAttachedTerm(t)) {
-      return 0;
-    }
-#endif
-    Term tn = MkVarTerm();
-    if (H > ASP - 128) {
-      res = -1;
-      goto error_handler;
-    }
-    CloseArena(oldH, oldHB, oldASP, newarena, old_size);
-    return tn;
-  } else if (IsAtomOrIntTerm(t)) {
-    return t;
-  } else if (IsPairTerm(t)) {
-    Term tf;
-    CELL *ap;
-    CELL *Hi;
-
-    H = HB = ArenaPt(arena);
-    ASP = ArenaLimit(arena);
-    ap = RepPair(t);
-    if (H > ASP - (128+2)) {
-      res = -1;
-      goto error_handler;
-    }
-    Hi = H;
-    tf = AbsPair(H);
-    H[0] = ap[0];
-    H[1] = ap[1];
-    H += 2;
-    CloseArena(oldH, oldHB, oldASP, newarena, old_size);
-    return tf;
-  } else {
-    Functor f;
-    Term tf;
-    CELL *HB0;
-    CELL *ap;
-
-    H = HB = ArenaPt(arena);
-    ASP = ArenaLimit(arena);
-    f = FunctorOfTerm(t);
-    HB0 = H;
-    ap = RepAppl(t);
-    tf = AbsAppl(H);
-    H[0] = (CELL)f;
-    if (IsExtensionFunctor(f)) {
-      switch((CELL)f) {
-      case (CELL)FunctorDBRef:
-	CloseArena(oldH, oldHB, oldASP, newarena, old_size);
-	return t;
-      case (CELL)FunctorLongInt:
-	if (H > ASP - (128+3)) {
-	  res = -1;
-	  goto error_handler;
-	}
-	H[1] = ap[1];
-	H[2] = EndSpecials;
-	H += 3;
-	break;
-      case (CELL)FunctorDouble:
-	if (H > ASP - (128+(2+SIZEOF_DOUBLE/sizeof(CELL)))) {
-	  res = -1;
-	  goto error_handler;
-	}
-	H[1] = ap[1];
-#if SIZEOF_DOUBLE == 2*SIZEOF_LONG_INT
-	H[2] = ap[2];
-	H[3] = EndSpecials;
-	H += 4;
-#else
-	H[2] = EndSpecials;
-	H += 3;
-#endif
-	break;
-      default:
-	{
-	  UInt sz = ArenaSz(t), i;
-
-	  if (H > ASP - (128+sz)) {
-	    res = -1;
-	    goto error_handler;
-	  }
-	  for (i = 1; i < sz; i++) {
-	    H[i] = ap[i];
-	  }
-	  H += sz;
-	}
-      }
-    } else {
-      UInt i;
-
-      if (H+(1+ArityOfFunctor(f)) > ASP-128) {
-	res = -1;
-	goto error_handler;
-      }
-      for (i=0; i<=ArityOfFunctor(f);i++)
-	*H++ = *ap++;
-    }
-    CloseArena(oldH, oldHB, oldASP, newarena, old_size);
-    return tf;
-  }
- error_handler:
-  H = HB;
-  CloseArena(oldH, oldHB, oldASP, newarena, old_size);
-#if COROUTINING
-  if (old_delay_arena != MkIntTerm(0))
-    ResetDelayArena(old_delay_arena, att_arenap);
-#endif
-  XREGS[arity+1] = t;
-  XREGS[arity+2] = arena;
-  XREGS[arity+3] = (CELL)newarena;
-  XREGS[arity+4] = (CELL)att_arenap;
-  {
-    CELL *old_top = ArenaLimit(*newarena);
-    ASP = oldASP;
-    H = oldH;
-    HB = oldHB;
-    switch (res) {
-    case -1:
-      if (arena == GlobalArena)
-	GlobalArenaOverflows++;
-      /* handle arena overflow */
-      /* first, take care of useless stuff */
-      if (!Yap_gc(arity+4, ENV, P)) {
-	Yap_Error(OUT_OF_STACK_ERROR,TermNil,Yap_ErrorMessage);
-	return 0L;
-      }
-      arena = XREGS[arity+2];
-      old_top = ArenaLimit(*newarena);
-      if (!GrowArena(arena, old_top, old_size, min_grow, arity+4)) {
-	Yap_Error(OUT_OF_STACK_ERROR, TermNil, Yap_ErrorMessage);
-	return 0L;
-      }
-      break;
-#if COROUTINING
-    case -3:
-      /* handle delay arena overflow */
-      old_size = DelayArenaSz(*att_arenap);
-      
-      if (!GrowDelayArena(att_arenap, old_size, 0L, arity+4)) {
-	Yap_Error(OUT_OF_STACK_ERROR, TermNil, Yap_ErrorMessage);
-	return 0L;
-      }
-      break;
-#endif
-    case -4:
-      /* handle trail overflow */
-      if(!Yap_growtrail (sizeof(CELL) * 16 * 1024L, FALSE)) {
-	Yap_Error(OUT_OF_TRAIL_ERROR, TermNil, Yap_ErrorMessage);
-	return 0L;
-      }
-      break;
-    default: /* temporary space overflow */
-      if (!Yap_ExpandPreAllocCodeSpace(0,NULL)) {
-	Yap_Error(OUT_OF_AUXSPACE_ERROR, TermNil, Yap_ErrorMessage);
-	return 0L;
-      }
-    }
-  }
-  oldH = H;
-  oldHB = HB;
-  oldASP = ASP;
-  att_arenap = (Term *)XREGS[arity+4];
-  newarena = (CELL *)XREGS[arity+3];
-  arena = Deref(XREGS[arity+2]);
-  t = XREGS[arity+1];
-  old_size = ArenaSz(arena);
-  goto restart;
-}
-
 inline static GlobalEntry *
 FindGlobalEntry(Atom at)
 /* get predicate entry for ap/arity; create it if neccessary.              */
@@ -1174,22 +983,119 @@ garena_overflow_size(CELL *arena)
 }
 
 static Int
-p_nb_copyterm(void)
+p_nb_setarg(void)
 {
-  Term to = CopyTermToArena(ARG1, GlobalArena, TRUE, 2, &GlobalArena, &GlobalDelayArena, garena_overflow_size(ArenaPt(GlobalArena)));
+  Term wheret = Deref(ARG1);
+  Term dest = Deref(ARG2);
+  Term to;
+  UInt arity, pos;
+  CELL *destp;
+
+  if (IsVarTerm(wheret)) {
+    Yap_Error(INSTANTIATION_ERROR,wheret,"nb_setarg");
+    return FALSE; 
+  }
+  if (!IsIntegerTerm(wheret)) {
+    Yap_Error(TYPE_ERROR_INTEGER,wheret,"nb_setarg");
+    return FALSE; 
+  }
+  pos = IntegerOfTerm(wheret);
+  if (IsVarTerm(dest)) {
+    Yap_Error(INSTANTIATION_ERROR,dest,"nb_setarg");
+    return FALSE; 
+  } else if (IsPrimitiveTerm(dest)) {
+    arity = 0;
+    destp = NULL;
+  } else if (IsPairTerm(dest)) {
+    arity = 2;
+    destp = RepPair(dest)-1;
+  } else {
+    arity = ArityOfFunctor(FunctorOfTerm(dest));
+    destp = RepAppl(dest);
+  }
+  if (pos < 1 || pos > arity)
+    return FALSE;
+  to = CopyTermToArena(ARG3, GlobalArena, FALSE, 2, &GlobalArena, &GlobalDelayArena, garena_overflow_size(ArenaPt(GlobalArena)));
   if (to == 0L)
     return FALSE;
-  return Yap_unify(ARG2,to);
+  destp[pos] = to;
+  return TRUE;
 }
 
 static Int
-p_nb_maketerm(void)
+p_nb_set_shared_arg(void)
 {
-  Term to = Deref(ARG1);
+  Term wheret = Deref(ARG1);
-  to = AddTermToArena(ARG1, GlobalArena, 2, &GlobalArena, &GlobalDelayArena, garena_overflow_size(ArenaPt(GlobalArena)));
+  Term dest = Deref(ARG2);
+  Term to;
+  UInt arity, pos;
+  CELL *destp;
+
+  if (IsVarTerm(wheret)) {
+    Yap_Error(INSTANTIATION_ERROR,wheret,"nb_setarg");
+    return FALSE; 
+  }
+  if (!IsIntegerTerm(wheret)) {
+    Yap_Error(TYPE_ERROR_INTEGER,wheret,"nb_setarg");
+    return FALSE; 
+  }
+  pos = IntegerOfTerm(wheret);
+  if (IsVarTerm(dest)) {
+    Yap_Error(INSTANTIATION_ERROR,dest,"nb_setarg");
+    return FALSE; 
+  } else if (IsPrimitiveTerm(dest)) {
+    arity = 0;
+    destp = NULL;
+  } else if (IsPairTerm(dest)) {
+    arity = 2;
+    destp = RepPair(dest)-1;
+  } else {
+    arity = ArityOfFunctor(FunctorOfTerm(dest));
+    destp = RepAppl(dest);
+  }
+  if (pos < 1 || pos > arity)
+    return FALSE;
+  to = CopyTermToArena(ARG3, GlobalArena, TRUE, 2, &GlobalArena, &GlobalDelayArena, garena_overflow_size(ArenaPt(GlobalArena)));
   if (to == 0L)
     return FALSE;
-  return Yap_unify(ARG2,to);
+  destp[pos] = to;
+  return TRUE;
+}
+
+static Int
+p_nb_linkarg(void)
+{
+  Term wheret = Deref(ARG1);
+  Term dest = Deref(ARG2);
+  UInt arity, pos;
+  CELL *destp;
+
+  if (IsVarTerm(wheret)) {
+    Yap_Error(INSTANTIATION_ERROR,wheret,"nb_setarg");
+    return FALSE; 
+  }
+  if (!IsIntegerTerm(wheret)) {
+    Yap_Error(TYPE_ERROR_INTEGER,wheret,"nb_setarg");
+    return FALSE; 
+  }
+  pos = IntegerOfTerm(wheret);
+  if (IsVarTerm(dest)) {
+    Yap_Error(INSTANTIATION_ERROR,dest,"nb_setarg");
+    return FALSE; 
+  } else if (IsPrimitiveTerm(dest)) {
+    arity = 0;
+    destp = NULL;
+  } else if (IsPairTerm(dest)) {
+    arity = 2;
+    destp = RepPair(dest)-1;
+  } else {
+    arity = ArityOfFunctor(FunctorOfTerm(dest));
+    destp = RepAppl(dest);
+  }
+  if (pos < 1 || pos > arity)
+    return FALSE;
+  destp[pos] = Deref(ARG3);
+  return TRUE;
 }
 
 static Int
@@ -2480,12 +2386,13 @@ void Yap_InitGlobals(void)
   Yap_InitCPred("arena_size", 1, p_default_arena_size, 0);
   Yap_InitCPred("b_setval", 2, p_b_setval, SafePredFlag);
   Yap_InitCPred("b_getval", 2, p_nb_getval, SafePredFlag);
-  Yap_InitCPred("nb_copy_term", 2, p_nb_copyterm, 0L);
-  Yap_InitCPred("nb_make_term", 2, p_nb_maketerm, 0L);
   Yap_InitCPred("nb_setval", 2, p_nb_setval, 0L);
   Yap_InitCPred("nb_set_shared_val", 2, p_nb_set_shared_val, 0L);
   Yap_InitCPred("nb_linkval", 2, p_nb_linkval, 0L);
   Yap_InitCPred("nb_getval", 2, p_nb_getval, SafePredFlag);
+  Yap_InitCPred("nb_setarg", 3, p_nb_setarg, 0L);
+  Yap_InitCPred("nb_set_shared_arg", 3, p_nb_set_shared_arg, 0L);
+  Yap_InitCPred("nb_linkarg", 3, p_nb_linkarg, 0L);
   Yap_InitCPred("nb_delete", 1, p_nb_delete, 0L);
   Yap_InitCPredBack("$nb_current", 1, 1, init_current_nb, cont_current_nb, SafePredFlag);
   CurrentModule = GLOBALS_MODULE;

C/index.c

@@ -11,8 +11,11 @@
 * File:		index.c							 *
 * comments:	Indexing a Prolog predicate				 *
 *									 *
-* Last rev:     $Date: 2007-06-20 13:48:45 $,$Author: vsc $						 *
+* Last rev:     $Date: 2007-09-22 08:38:05 $,$Author: vsc $						 *
 * $Log: not supported by cvs2svn $
+* Revision 1.186  2007/06/20 13:48:45  vsc
+* fix bug in index emulator
+*
 * Revision 1.185  2007/05/02 11:01:37  vsc
 * get rid of type punning warnings.
 *
@@ -3338,7 +3341,7 @@ valid_instructions(yamop *end, yamop *cl)
 }
 
 static UInt
-groups_in(ClauseDef *min, ClauseDef *max, GroupDef *grp)
+groups_in(ClauseDef *min, ClauseDef *max, GroupDef *grp, struct intermediates *cint)
 {
   UInt groups = 0;
 
@@ -3392,6 +3395,21 @@ groups_in(ClauseDef *min, ClauseDef *max, GroupDef *grp)
     }
     groups++;
     grp++;
+    while (grp+16 > (GroupDef *)Yap_TrailTop) {
+      UInt sz = (groups+16)*sizeof(GroupDef);
+#if USE_SYSTEM_MALLOC
+      Yap_Error_Size = sz;
+      /* grow stack */
+      save_machine_regs();
+      longjmp(cint->CompilerBotch,4);
+#else
+      if (!Yap_growtrail(sz, TRUE)) {
+	save_machine_regs();
+	longjmp(cint->CompilerBotch,4);
+	return 0;
+      }
+#endif
+    }
   }
   return groups;
 }
@@ -4365,7 +4383,7 @@ do_index(ClauseDef *min, ClauseDef* max, struct intermediates *cint, UInt argno,
   } else {
     found_pvar = cls_info(min, max, argno);
   }
-  ngroups = groups_in(min, max, group);
+  ngroups = groups_in(min, max, group, cint);
   if (IsVarTerm(t)) {
     lablx = new_label(cint);
     Yap_emit(label_op, lablx, Zero, cint);
@@ -4390,7 +4408,7 @@ do_index(ClauseDef *min, ClauseDef* max, struct intermediates *cint, UInt argno,
       } else {
 	found_pvar = cls_info(min, max, argno);
       }
-      ngroups = groups_in(min, max, group);
+      ngroups = groups_in(min, max, group, cint);
     } 
     labl0 = labl = new_label(cint);
   } else {
@@ -4527,7 +4545,7 @@ do_compound_index(ClauseDef *min0, ClauseDef* max0, Term* sreg, struct intermedi
       cl++;
     }
     group = (GroupDef *)top;
-    ngroups = groups_in(min, max, group);    
+    ngroups = groups_in(min, max, group, cint);    
     if (ngroups == 1 && group->VarClauses == 0) {
       /* ok, we are doing a sub-argument */
       /* process group */
@@ -4566,7 +4584,7 @@ do_dbref_index(ClauseDef *min, ClauseDef* max, Term t, struct intermediates *cin
     cl->Tag = cl->u.t_ptr;
     cl++;
   }
-  ngroups = groups_in(min, max, group);
+  ngroups = groups_in(min, max, group, cint);
   if (ngroups > 1 || group->VarClauses) {
     return do_index(min, max, cint, argno+1, fail_l, first, clleft, top);
   } else {
@@ -4603,7 +4621,7 @@ do_blob_index(ClauseDef *min, ClauseDef* max, Term t, struct intermediates *cint
     }
     cl++;
   }
-  ngroups = groups_in(min, max, group);
+  ngroups = groups_in(min, max, group, cint);
   if (ngroups > 1 || group->VarClauses) {
     return do_index(min, max, cint, argno+1, fail_l, first, clleft, top);
   } else {

changes-5.1.html

@@ -16,6 +16,8 @@
 
 <h2>Yap-5.1.3:</h2>
 <ul>
+<li> NEW: add nb_*arg versions.</li>
+<li> FIXED: overflow in indexing code (obs from Jesse Davis).</li>
 <li> NEW: improve nb_ routines with linkvar and set_shared_var.</li>
 <li> NEW: make copy_term share ground-terms and add non-sharing
 version, duplicate_term/2.</li>

docs/yap.tex

@@ -5867,7 +5867,7 @@ order of dispatch.
 
 @end table
 
-@node Term Modification, Profiling, OS, Top
+@node Term Modification, Global Variables, OS, Top
 @section Term Modification
 
 @cindex updating terms
@@ -5923,14 +5923,14 @@ Unify the current value of mutable term @var{M} with term @var{D}.
 Set the current value of mutable term @var{M} to term @var{D}.
 @end table
 
-@node Global Variables, Profiling, Profiling, Term Modification, Top
+@node Global Variables, Profiling, Term Modification, Top
 @section Global Variables
 
 @cindex global variables
 
 Global variables are associations between names (atoms) and
 terms. They differ in various ways from storing information using
-@node{assert/1} or @node{recorda/3}.
+@code{assert/1} or @code{recorda/3}.
 
 @itemize @bullet
 @item The value lives on the Prolog (global) stack. This implies that
@@ -6053,6 +6053,55 @@ A = a(_A),
 B = t(C,a(_A)) ?
 @end example
 
+@item nb_setarg(+@{Arg], +@var{Term}, +@var{Value})
+@findex nb_setarg/3
+@snindex nb_setarg/3
+@cnindex nb_setarg/3
+
+Assigns the @var{Arg}-th argument of the compound term @var{Term} with
+the given @var{Value} as setarg/3, but on backtracking the assignment
+is not reversed. If @var{Term} is not atomic, it is duplicated using
+duplicate_term/2. This predicate uses the same technique as
+@code{nb_setval/2}. We therefore refer to the description of
+@code{nb_setval/2} for details on non-backtrackable assignment of
+terms. This predicate is compatible to GNU-Prolog
+@code{setarg(A,T,V,false)}, removing the type-restriction on
+@var{Value}. See also @code{nb_linkarg/3}. Below is an example for
+counting the number of solutions of a goal. Note that this
+implementation is thread-safe, reentrant and capable of handling
+exceptions. Realising these features with a traditional implementation
+based on assert/retract or flag/3 is much more complicated.
+
+@example
+    succeeds_n_times(Goal, Times) :-
+            Counter = counter(0),
+            (   Goal,
+                arg(1, Counter, N0),
+                N is N0 + 1,
+                nb_setarg(1, Counter, N),
+                fail
+            ;   arg(1, Counter, Times)
+            ).
+@end example
+
+@item nb_set_shared_arg(+@var{Arg}, +@var{Term}, +@var{Value}) 
+@findex nb_set_shared_arg/3
+@snindex nb_set_shared_arg/3
+@cnindex nb_set_shared_arg/3
+
+As @code{nb_setarg/3}, but like @code{nb_linkval/2} it does not
+duplicate the global sub-terms in @var{Value}. Use with extreme care
+and consult the documentation of @code{nb_linkval/2} before use.
+
+@item nb_linkarg(+@var{Arg}, +@var{Term}, +@var{Value}) 
+@findex nb_linkarg/3
+@snindex nb_lnkarg/3
+@cnindex nb_linkarg/3
+
+As @code{nb_setarg/3}, but like @code{nb_linkval/2} it does not
+duplicate @var{Value}. Use with extreme care and consult the
+documentation of @code{nb_linkval/2} before use.
+
 
 @item nb_current(?@var{Name}, ?@var{Value}) 
 @findex nb_current/2