support interface to foreign objects that have a backtrack handler.

C/absmi.c

@@ -2081,8 +2081,13 @@ Yap_absmi(int inp)
 	      goto failloop;
 	    } else
 #endif /* FROZEN_STACKS */
-	      if (IN_BETWEEN(H0,pt1,H) && IsAttVar(pt1))
+	      if (IN_BETWEEN(H0,pt1,H)) {
-		goto failloop;		       	    
+		if (IsAttVar(pt1)) {
+		  goto failloop;	
+		} else if (*pt1 == (CELL)FunctorBigInt) {
+		  Yap_CleanOpaqueVariable(pt1);
+		}	       	  
+	      }  
 #ifdef FROZEN_STACKS  /* TRAIL */
 	    /* don't reset frozen variables */
 	    if (pt0 < TR_FZ)

C/bignum.c

@@ -25,9 +25,10 @@ static char     SccsId[] = "%W% %G%";
 #include <string.h>
 #endif
 
+#include "YapHeap.h"
+
 #ifdef USE_GMP
 
-#include "YapHeap.h"
 #include "eval.h"
 #include "alloc.h"
 
@@ -59,27 +60,6 @@ Yap_MkBigIntTerm(MP_INT *big)
   return AbsAppl(ret);
 }
 
-Term
-Yap_AllocExternalDataInStack(size_t bytes)
-{
-  CACHE_REGS
-  Int nlimbs;
-  MP_INT *dst = (MP_INT *)(H+2);
-  CELL *ret = H;
-
-  nlimbs = ALIGN_YAPTYPE(bytes,CELL)/CellSize;
-  if (nlimbs > (ASP-ret)-1024) {
-    return TermNil;
-  }
-  H[0] = (CELL)FunctorBigInt;
-  H[1] = EXTERNAL_BLOB;
-  dst->_mp_size = 0;
-  dst->_mp_alloc = nlimbs;
-  H = (CELL *)(dst+1)+nlimbs;
-  H[0] = EndSpecials;
-  H++;
-  return AbsAppl(ret);
-}
 
 MP_INT *
 Yap_BigIntOfTerm(Term t)
@@ -149,9 +129,58 @@ Yap_RatTermToApplTerm(Term t)
   return Yap_MkApplTerm(FunctorRDiv,2,ts);
 }
 
-
 #endif
 
+Term
+Yap_AllocExternalDataInStack(CELL tag, size_t bytes)
+{
+  CACHE_REGS
+  Int nlimbs;
+  MP_INT *dst = (MP_INT *)(H+2);
+  CELL *ret = H;
+
+  nlimbs = ALIGN_YAPTYPE(bytes,CELL)/CellSize;
+  if (nlimbs > (ASP-ret)-1024) {
+    return TermNil;
+  }
+  H[0] = (CELL)FunctorBigInt;
+  H[1] = tag;
+  dst->_mp_size = 0;
+  dst->_mp_alloc = nlimbs;
+  H = (CELL *)(dst+1)+nlimbs;
+  H[0] = EndSpecials;
+  H++;
+  if (tag != EXTERNAL_BLOB) {
+    TrailTerm(TR) = AbsPair(ret);
+    TR++;
+  }
+  return AbsAppl(ret);
+}
+
+int Yap_CleanOpaqueVariable(CELL *pt)
+{
+  CELL blob_info, blob_tag;
+  MP_INT *blobp;
+#ifdef DEBUG
+  /* sanity checking */
+  if (pt[0] != (CELL)FunctorBigInt) {
+    Yap_Error(SYSTEM_ERROR, TermNil, "CleanOpaqueVariable bad call");
+    return FALSE;
+  }
+#endif
+  blob_tag = pt[1];
+  if (blob_tag < USER_BLOB_START ||
+      blob_tag >= USER_BLOB_END) {
+    Yap_Error(SYSTEM_ERROR, AbsAppl(pt), "clean opaque: bad blob with tag " UInt_FORMAT ,blob_tag);
+    return FALSE;
+  }
+  blob_info = blob_tag - USER_BLOB_START;
+  if (!GLOBAL_OpaqueHandlers)
+    return FALSE;
+  blobp = (MP_INT *)(pt+2);
+  return (GLOBAL_OpaqueHandlers[blob_info].fail_handler)((void *)(blobp+1));
+}
+
 Term
 Yap_MkULLIntTerm(YAP_ULONG_LONG n)
 {

C/c_interface.c

@@ -391,6 +391,7 @@ X_API Bool    STD_PROTO(YAP_IsAtomTerm,(Term));
 X_API Bool    STD_PROTO(YAP_IsPairTerm,(Term));
 X_API Bool    STD_PROTO(YAP_IsApplTerm,(Term));
 X_API Bool    STD_PROTO(YAP_IsExternalDataInStackTerm,(Term));
+X_API Bool    STD_PROTO(YAP_IsOpaqueObjectTerm,(Term, int));
 X_API Term    STD_PROTO(YAP_MkIntTerm,(Int));
 X_API Term    STD_PROTO(YAP_MkBigNumTerm,(void *));
 X_API Term    STD_PROTO(YAP_MkRationalTerm,(void *));
@@ -539,6 +540,9 @@ X_API int      STD_PROTO(YAP_MaxOpPriority,(Atom, Term));
 X_API int      STD_PROTO(YAP_OpInfo,(Atom, Term, int, int *, int *));
 X_API Term     STD_PROTO(YAP_AllocExternalDataInStack,(size_t));
 X_API void    *STD_PROTO(YAP_ExternalDataInStackFromTerm,(Term));
+X_API int      STD_PROTO(YAP_NewOpaqueType,(void *));
+X_API Term     STD_PROTO(YAP_NewOpaqueObject,(int, size_t));
+X_API void    *STD_PROTO(YAP_OpaqueObjectFromTerm,(Term));
 
 static int (*do_putcf)(wchar_t);
 
@@ -2320,7 +2324,7 @@ YAP_RunGoal(Term t)
 X_API Term
 YAP_AllocExternalDataInStack(size_t bytes)
 {
-  Term t = Yap_AllocExternalDataInStack(bytes);
+  Term t = Yap_AllocExternalDataInStack(EXTERNAL_BLOB, bytes);
   if (t == TermNil)
     return 0L;
   return t;
@@ -2329,7 +2333,7 @@ YAP_AllocExternalDataInStack(size_t bytes)
 X_API Bool
 YAP_IsExternalDataInStackTerm(Term t)
 {
-  return IsExternalBlobTerm(t);
+  return IsExternalBlobTerm(t, EXTERNAL_BLOB);
 }
 
 X_API void *
@@ -2338,6 +2342,44 @@ YAP_ExternalDataInStackFromTerm(Term t)
   return ExternalBlobFromTerm (t);
 }
 
+int YAP_NewOpaqueType(void *f)
+{
+  int i;
+  if (!GLOBAL_OpaqueHandlers) {
+    GLOBAL_OpaqueHandlers = malloc(sizeof(opaque_handler_t)*(USER_BLOB_END-USER_BLOB_START));
+    if (!GLOBAL_OpaqueHandlers) {
+      /* no room */
+      return -1;
+    }
+  } else if (GLOBAL_OpaqueHandlersCount == USER_BLOB_END-USER_BLOB_START) {
+    /* all types used */
+    return -1;
+  }
+  i = GLOBAL_OpaqueHandlersCount++;
+  memcpy(GLOBAL_OpaqueHandlers+i,f,sizeof(opaque_handler_t));
+  return i+USER_BLOB_START;
+}
+
+Term YAP_NewOpaqueObject(int tag, size_t bytes)
+{
+  Term t = Yap_AllocExternalDataInStack((CELL)tag, bytes);
+  if (t == TermNil)
+    return 0L;
+  return t;
+}
+
+X_API Bool
+YAP_IsOpaqueObjectTerm(Term t, int tag)
+{
+  return IsExternalBlobTerm(t, (CELL)tag);
+}
+
+X_API void *
+YAP_OpaqueObjectFromTerm(Term t)
+{
+  return ExternalBlobFromTerm (t);
+}
+
 X_API Term
 YAP_RunGoalOnce(Term t)
 {

C/grow.c

@@ -399,7 +399,7 @@ AdjustTrail(int adjusting_heap, int thread_copying USES_REGS)
 #if defined(YAPOR_THREADS)
   }
 #endif
-  /* moving the trail is simple */
+  /* moving the trail is simple, yeaahhh! */
   while (ptt != tr_base) {
     register CELL reg = TrailTerm(ptt-1);
 #ifdef FROZEN_STACKS
@@ -420,8 +420,6 @@ AdjustTrail(int adjusting_heap, int thread_copying USES_REGS)
     } else if (IsPairTerm(reg)) {
       TrailTerm(ptt) = AdjustPair(reg PASS_REGS);
 #ifdef MULTI_ASSIGNMENT_VARIABLES /* does not work with new structures */
-    /* check it whether we are protecting a
-       multi-assignment */
     } else if (IsApplTerm(reg)) {
       TrailTerm(ptt) = AdjustAppl(reg PASS_REGS);
 #endif

C/heapgc.c

@@ -1658,14 +1658,23 @@ mark_trail(tr_fr_ptr trail_ptr, tr_fr_ptr trail_base, CELL *gc_H, choiceptr gc_B
 #endif
       }
     } else if (IsPairTerm(trail_cell)) {
-      /* can safely ignore this */
+      /* cannot safely ignore this */
       CELL *cptr = RepPair(trail_cell);
-      if (IN_BETWEEN(LOCAL_GlobalBase,cptr,H) &&
+      if (IN_BETWEEN(LOCAL_GlobalBase,cptr,H)) {
-	  GlobalIsAttVar(cptr)) {
+	if (GlobalIsAttVar(cptr)) {
-	TrailTerm(trail_base) = (CELL)cptr;
+	  TrailTerm(trail_base) = (CELL)cptr;
-	mark_external_reference(&TrailTerm(trail_base) PASS_REGS);
+	  mark_external_reference(&TrailTerm(trail_base) PASS_REGS);
-	TrailTerm(trail_base) = trail_cell;
+	  TrailTerm(trail_base) = trail_cell;
-      } 
+	} else if (*cptr == (CELL)FunctorBigInt) {
+	  TrailTerm(trail_base) = AbsAppl(cptr);
+	  mark_external_reference(&TrailTerm(trail_base) PASS_REGS);
+	  TrailTerm(trail_base) = trail_cell;	  
+	} 
+#ifdef DEBUG
+	else
+	  fprintf(GLOBAL_stderr,"OOPS in GC: weird trail entry at %p:" UInt_FORMAT "\n", &TrailTerm(trail_base), (CELL)cptr);
+#endif
+      }
     }
 #if  MULTI_ASSIGNMENT_VARIABLES
     else {
@@ -2450,11 +2459,19 @@ sweep_trail(choiceptr gc_B, tr_fr_ptr old_TR USES_REGS)
 	CELL *pt0 = RepPair(trail_cell);
 	CELL flags;
 
-	if (IN_BETWEEN(LOCAL_GlobalBase, pt0, H) && GlobalIsAttVar(pt0)) {
+	if (IN_BETWEEN(LOCAL_GlobalBase, pt0, H)) {
-	  TrailTerm(dest) = trail_cell;
+	  if (GlobalIsAttVar(pt0)) {
-	  /* be careful with partial gc */
+	    TrailTerm(dest) = trail_cell;
-	  if (HEAP_PTR(TrailTerm(dest))) {
+	    /* be careful with partial gc */
-	    into_relocation_chain(&TrailTerm(dest), GET_NEXT(trail_cell) PASS_REGS);
+	    if (HEAP_PTR(TrailTerm(dest))) {
+	      into_relocation_chain(&TrailTerm(dest), GET_NEXT(trail_cell) PASS_REGS);
+	    }
+	  } else if (*pt0 == (CELL)FunctorBigInt) {
+	    TrailTerm(dest) = trail_cell;
+	    /* be careful with partial gc */
+	    if (HEAP_PTR(TrailTerm(dest))) {
+	      into_relocation_chain(&TrailTerm(dest), GET_NEXT(trail_cell) PASS_REGS);
+	    }
 	  }
 	  dest++;
 	  trail_ptr++;

H/TermExt.h

@@ -86,7 +86,9 @@ typedef enum
     CLAUSE_LIST =  0x40,
     BLOB_STRING =  0x80, /* SWI style strings */
     BLOB_WIDE_STRING =  0x81, /* SWI style strings */
-    EXTERNAL_BLOB =  0x100 /* generic data */
+    EXTERNAL_BLOB =  0x100, /* generic data */
+    USER_BLOB_START =  0x1000, /* user defined blob */
+    USER_BLOB_END =  0x1100 /* end of user defined blob */
   } 
 big_blob_type;
 
@@ -438,14 +440,14 @@ IsLargeNumTerm (Term t)
 		    && (FunctorOfTerm (t) >= FunctorLongInt)));
 }
 
-inline EXTERN int IsExternalBlobTerm (Term);
+inline EXTERN int IsExternalBlobTerm (Term, CELL);
 
 inline EXTERN int
-IsExternalBlobTerm (Term t)
+IsExternalBlobTerm (Term t, CELL tag)
 {
   return (int) (IsApplTerm (t) &&
 		FunctorOfTerm (t) == FunctorBigInt &&
-		RepAppl(t)[1] == EXTERNAL_BLOB);
+		RepAppl(t)[1] == tag);
 }
 
 inline EXTERN void *ExternalBlobFromTerm (Term);

H/YapHeap.h

@@ -33,6 +33,12 @@ typedef int (*SWI_PLGetStreamPositionFunction)(void *);
 
 #include "../include/dswiatoms.h"
 
+typedef int (*Opaque_CallOnFail)(void *);
+
+typedef struct opaque_handler_struct {
+  Opaque_CallOnFail fail_handler;
+} opaque_handler_t;
+
 #ifndef INT_KEYS_DEFAULT_SIZE
 #define INT_KEYS_DEFAULT_SIZE 256
 #endif

H/Yapproto.h

@@ -120,7 +120,8 @@ int    STD_PROTO(Yap_IsStringTerm, (Term));
 int    STD_PROTO(Yap_IsWideStringTerm, (Term));
 Term   STD_PROTO(Yap_RatTermToApplTerm, (Term));
 void   STD_PROTO(Yap_InitBigNums, (void));
-Term   STD_PROTO(Yap_AllocExternalDataInStack, (size_t));
+Term   STD_PROTO(Yap_AllocExternalDataInStack, (CELL, size_t));
+int    STD_PROTO(Yap_CleanOpaqueVariable, (CELL *));
 
 /* c_interface.c */
 Int    STD_PROTO(YAP_Execute,(struct pred_entry *, CPredicate));

H/dglobals.h

@@ -102,6 +102,8 @@
 
 #define GLOBAL_Executable Yap_global->Executable_
 #endif
+#define GLOBAL_OpaqueHandlersCount Yap_global->OpaqueHandlersCount_
+#define GLOBAL_OpaqueHandlers Yap_global->OpaqueHandlers_
 #if  __simplescalar__
 #define GLOBAL_pwd Yap_global->pwd_
 #endif

H/hglobals.h

@@ -102,6 +102,8 @@ typedef struct global_data {
 
   char  Executable_[YAP_FILENAME_MAX];
 #endif
+  int  OpaqueHandlersCount_;
+  struct opaque_handler_struct*  OpaqueHandlers_;
 #if  __simplescalar__
   char  pwd_[YAP_FILENAME_MAX];
 #endif

H/iglobals.h

@@ -102,6 +102,8 @@ static void InitGlobal(void) {
 
 
 #endif
+  GLOBAL_OpaqueHandlersCount = 0;
+  GLOBAL_OpaqueHandlers = NULL;
 #if  __simplescalar__
 
 #endif

H/rglobals.h

@@ -102,6 +102,8 @@ static void RestoreGlobal(void) {
 
 
 #endif
+
+
 #if  __simplescalar__
 
 #endif

include/YapInterface.h

@@ -558,11 +558,13 @@ extern X_API int  PROTO(YAP_OpInfo,(YAP_Atom, YAP_Term, int, int *, int *));
 /*    YAP_Bool  YAP_IsExternalDataInStackTerm(YAP_Term)  */
 extern X_API YAP_Bool PROTO(YAP_IsExternalDataInStackTerm,(YAP_Term));
 
-/*    Term  YAP_AllocExternalDataInStack(size_t)  */
+extern X_API YAP_opaque_tag_t PROTO(YAP_NewOpaqueType,(struct YAP_opaque_handler_struct *));
-extern X_API YAP_Term PROTO(YAP_AllocExternalDataInStack,(size_t));
 
-/*    void  *YAP_ExternalDataInStackFromTerm(YAP_Term)  */
+extern X_API YAP_Bool PROTO(YAP_IsOpaqueObjectTerm,(YAP_Term, YAP_opaque_tag_t));
-extern X_API void *PROTO(YAP_ExternalDataInStackFromTerm,(YAP_Term));
+
+extern X_API YAP_Term PROTO(YAP_NewOpaqueObject,(YAP_opaque_tag_t, size_t));
+
+extern X_API void *PROTO(YAP_OpaqueObjectFromTerm,(YAP_Term));
 
 #define YAP_InitCPred(N,A,F)  YAP_UserCPredicate(N,F,A)
 

include/yap_structs.h

@@ -204,6 +204,14 @@ typedef int  (*YAP_agc_hook)(void *_Atom);
 
 typedef void  (*YAP_halt_hook)(int exit_code, void *closure);
 
+typedef int YAP_opaque_tag_t;
+
+typedef int (*YAP_Opaque_CallOnFail)(void *);
+
+typedef struct YAP_opaque_handler_struct {
+  YAP_Opaque_CallOnFail fail_handler;
+} YAP_opaque_handler_t;
+
 /********* execution mode ***********************/
 
 typedef enum

misc/GLOBALS

@@ -120,6 +120,8 @@ char*				DIRNAME					=NULL
 char 				Executable[YAP_FILENAME_MAX]		void
 #endif
 
+int				OpaqueHandlersCount			=0
+struct opaque_handler_struct* 	OpaqueHandlers				=NULL
 
 #if  __simplescalar__
 char				pwd[YAP_FILENAME_MAX]			void