WIN32 fixes

compiler bug fixes
extend interface


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

C/alloc.c

@@ -12,7 +12,7 @@
 * Last rev:								 *
 * mods:									 *
 * comments:	allocating space					 *
-* version:$Id: alloc.c,v 1.83 2006-04-28 13:23:22 vsc Exp $		 *
+* version:$Id: alloc.c,v 1.84 2006-05-16 18:37:30 vsc Exp $		 *
 *************************************************************************/
 #ifdef SCCS
 static char SccsId[] = "%W% %G%";
@@ -676,6 +676,10 @@ ExtendWorkSpace(Int s, int fixed_allocation)
 
 
   Yap_PrologMode = ExtendStackMode;
+
+#if DEBUG_WIN32_ALLOC
+  fprintf(stderr,"trying: %p--%x %d\n",b, s, fixed_allocation);
+#endif
   if (fixed_allocation) {
     b = VirtualAlloc(b, s, MEM_RESERVE, PAGE_NOACCESS);
   } else {
@@ -686,7 +690,16 @@ ExtendWorkSpace(Int s, int fixed_allocation)
   }
   if (!b) {
     Yap_PrologMode = OldPrologMode;
-    /*  fprintf(stderr,"NOT OK1: %p--%p\n",b,brk);*/
+#if DEBUG_WIN32_ALLOC
+    {
+      char msg[256];
+      FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM | FORMAT_MESSAGE_IGNORE_INSERTS,
+		    NULL, GetLastError(), 
+		    MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), msg, 256,
+		    NULL);
+      fprintf(stderr,"NOT OK1: %p--%p %s\n",b, brk, msg);
+    }
+#endif
     return FALSE;
   }
   b = VirtualAlloc(b, s, MEM_COMMIT, PAGE_READWRITE);
@@ -696,11 +709,15 @@ ExtendWorkSpace(Int s, int fixed_allocation)
 	      "VirtualAlloc could not commit %ld bytes",
 	      (long int)s);
     Yap_PrologMode = OldPrologMode;
-    /*  fprintf(stderr,"NOT OK2: %p--%p\n",b,brk);*/
+#if DEBUG_WIN32_ALLOC
+    fprintf(stderr,"NOT OK2: %p--%p\n",b,brk);
+#endif
     return FALSE;
   }
   brk = (LPVOID) ((Int) b + s);
-  /*  fprintf(stderr,"OK: %p--%p\n",b,brk);*/
+#if DEBUG_WIN32_ALLOC
+  fprintf(stderr,"OK: %p--%p\n",b,brk);
+#endif
   Yap_PrologMode = OldPrologMode;
   return TRUE;
 }
@@ -1412,10 +1429,7 @@ Yap_ExtendWorkSpaceThroughHole(UInt s)
     /* progress 1 MB */
     WorkSpaceTop += 512*1024;
     if (ExtendWorkSpace(s, MAP_FIXED)) {
-#if USE_DL_MALLOC 
+      Yap_add_memory_hole((ADDR)WorkSpaceTop0, (ADDR)WorkSpaceTop-s);
-      Yap_hole_start = (ADDR)WorkSpaceTop0;
-      Yap_hole_end = (ADDR)WorkSpaceTop-s;
-#endif
       Yap_ErrorMessage = NULL;
       return WorkSpaceTop-WorkSpaceTop0;
     }
@@ -1430,6 +1444,7 @@ Yap_ExtendWorkSpaceThroughHole(UInt s)
   WorkSpaceTop = WorkSpaceTop0;
 #endif
   if (ExtendWorkSpace(s, 0)) {
+    Yap_add_memory_hole((ADDR)WorkSpaceTop0, (ADDR)WorkSpaceTop-s);
     Yap_ErrorMessage = NULL;
     return WorkSpaceTop-WorkSpaceTop0;
   }

C/c_interface.c

@@ -10,8 +10,11 @@
 * File:		c_interface.c						 *
 * comments:	c_interface primitives definition 			 *
 *									 *
-* Last rev:	$Date: 2006-03-09 15:52:04 $,$Author: tiagosoares $						 *
+* Last rev:	$Date: 2006-05-16 18:37:30 $,$Author: vsc $						 *
 * $Log: not supported by cvs2svn $
+* Revision 1.84  2006/03/09 15:52:04  tiagosoares
+* CUT_C and MYDDAS support for 64 bits architectures
+*
 * Revision 1.83  2006/02/08 17:29:54  tiagosoares
 * MYDDAS: Myddas Top Level for MySQL and Datalog
 *
@@ -323,13 +326,17 @@ X_API void   *STD_PROTO(YAP_ExtraSpaceCut,(void));
 #endif
 X_API Term     STD_PROTO(YAP_CurrentModule,(void));
 X_API Term     STD_PROTO(YAP_CreateModule,(Atom));
-X_API int     STD_PROTO(YAP_ThreadSelf,(void));
+X_API int      STD_PROTO(YAP_ThreadSelf,(void));
-X_API int     STD_PROTO(YAP_GetThreadRefCount,(int));
+X_API int      STD_PROTO(YAP_GetThreadRefCount,(int));
-X_API void    STD_PROTO(YAP_SetThreadRefCount,(int,int));
+X_API void     STD_PROTO(YAP_SetThreadRefCount,(int,int));
 X_API CELL     STD_PROTO(YAP_ThreadCreateEngine,(thread_attr *));
-X_API int     STD_PROTO(YAP_ThreadAttachEngine,(int));
+X_API int      STD_PROTO(YAP_ThreadAttachEngine,(int));
-X_API int     STD_PROTO(YAP_ThreadDetachEngine,(int));
+X_API int      STD_PROTO(YAP_ThreadDetachEngine,(int));
-X_API int     STD_PROTO(YAP_ThreadDestroyEngine,(int));
+X_API int      STD_PROTO(YAP_ThreadDestroyEngine,(int));
+X_API int      STD_PROTO(YAP_ArgsToIntArray,(Term, UInt, const Int *));
+X_API Term     STD_PROTO(YAP_IntArrayToArgs,(UInt, const Int *));
+X_API int      STD_PROTO(YAP_ArgsToFloatArray,(Term, UInt, const Float *));
+X_API Term     STD_PROTO(YAP_FloatArrayToArgs,(UInt, const Float *));
 
 static int (*do_getf)(void);
 
@@ -1627,3 +1634,86 @@ YAP_ThreadDestroyEngine(int wid)
 #endif
 } 
 
+/* Copy a number of terms to an array of integers */
+X_API int
+YAP_ArgsToIntArray(Term t, UInt size, const Int *ar)
+{
+  Int *dest = (Int *)ar;
+  CELL *ptr;
+
+  if (IsVarTerm(t) ||
+      !IsApplTerm(t)) return FALSE;
+  if (ArityOfFunctor(FunctorOfTerm(t)) != size)
+    return FALSE;
+  ptr = RepAppl(t)+1;
+  while (size) {
+    Term t = *ptr++;
+    if (IsVarTerm(t) || !IsIntegerTerm(t))
+      return FALSE;
+    *dest++ = IntegerOfTerm(t);
+  }
+  return TRUE;
+} 
+
+X_API Term
+YAP_IntArrayToArgs(UInt size, const Int *ar)
+{
+  Term t; 
+  BACKUP_H();
+  CELL *ptr = H+1;
+  Int *source = (Int *)ar;
+
+  if (H+(size+1) >= ASP) {
+    return TermNil;
+  }
+  t = AbsAppl(H);
+  *H++ = (CELL)Yap_MkFunctor(Yap_LookupAtom("data"),size);
+  H+=size;
+  while (size) {
+    *ptr++ = MkIntegerTerm(*source++);
+  }
+  RECOVER_H();
+  return t;
+} 
+
+X_API int
+YAP_ArgsToFloatArray(Term t, UInt size, const Float *ar)
+{
+  CELL *ptr;
+  Float *dest = (Float *)ar;
+
+  if (IsVarTerm(t) ||
+      !IsApplTerm(t)) return FALSE;
+  if (ArityOfFunctor(FunctorOfTerm(t)) != size)
+    return FALSE;
+  ptr = RepAppl(t)+1;
+  while (size) {
+    Term t = *ptr++;
+    if (IsVarTerm(t) || !IsFloatTerm(t))
+      return FALSE;
+    *dest++ = FloatOfTerm(t);
+  }
+  return TRUE;
+} 
+
+X_API Term
+YAP_FloatArrayToArgs(UInt size, const Float *ar)
+{
+  Term t; 
+  BACKUP_H();
+  CELL *ptr = H+1;
+  Float *source = (Float *)ar;
+
+  if (H+(size+1) >= ASP) {
+    return TermNil;
+  }
+  t = AbsAppl(H);
+  *H++ = (CELL)Yap_MkFunctor(Yap_LookupAtom("data"),size);
+  H+=size;
+  while (size) {
+    *ptr++ = MkFloatTerm(*source++);
+  }
+  RECOVER_H();
+  return t;
+} 
+

C/compiler.c

@@ -11,8 +11,11 @@
 * File:		compiler.c						 *
 * comments:	Clause compiler						 *
 *									 *
-* Last rev:     $Date: 2006-04-13 02:04:24 $,$Author: vsc $						 *
+* Last rev:     $Date: 2006-05-16 18:37:30 $,$Author: vsc $						 *
 * $Log: not supported by cvs2svn $
+* Revision 1.74  2006/04/13 02:04:24  vsc
+* fix debugging typo
+*
 * Revision 1.73  2006/04/12 20:08:51  vsc
 * make it sure that making vars safe does not propagate across branches of disjunctions.
 *
@@ -882,15 +885,21 @@ c_bifun(Int Op, Term t1, Term t2, Term t3, int mod, compiler_struct *cglobs)
       }
     } else {
       if (Op == _arg) {
-	Term tn = MkVarTerm();
+	/* we know the second argument is bound */
-	Int v1 = --cglobs->tmpreg;
+	if (IsPrimitiveTerm(t2) || IsNumTerm(t2)) {
-	Int v2 = --cglobs->tmpreg;
+	  Yap_emit(fail_op, Zero, Zero, &cglobs->cint);
+	  return;
+	} else {
+	  Term tn = MkVarTerm();
+	  Int v1 = --cglobs->tmpreg;
+	  Int v2 = --cglobs->tmpreg;
 
-	c_arg(t2, v2, 0, 0, cglobs);
+	  c_eq(t2, tn, cglobs);
-	Yap_emit(fetch_args_vv_op, Zero, Zero, &cglobs->cint);
+	  Yap_emit(fetch_args_vv_op, Zero, Zero, &cglobs->cint);
-	/* these should be the arguments */
+	  /* these should be the arguments */
-	c_var(t1, v1, 0, 0, cglobs);
+	  c_var(t1, v1, 0, 0, cglobs);
-	c_var(tn, v2, 0, 0, cglobs);
+	  c_var(tn, v2, 0, 0, cglobs);
+	}
       /* it has to be either an integer or a floating point */
       } else if (IsIntegerTerm(t2)) {
 	/* first temp */

C/dlmalloc.c

@@ -176,16 +176,34 @@ ChunkPtrAdjust (struct malloc_chunk *ptr)
 
 /* vsc: emulation of sbrk with YAP contiguous memory management */
 
+void
+Yap_add_memory_hole(ADDR start, ADDR end)
+{
+  if (Yap_NOfMemoryHoles == MAX_DLMALLOC_HOLES) {
+    Yap_Error(OPERATING_SYSTEM_ERROR, 0L, "Unexpected Too Much Memory Fragmentation: please contact YAP maintainers");
+    return;
+  }
+  Yap_MemoryHoles[Yap_NOfMemoryHoles].start = start;
+  Yap_MemoryHoles[Yap_NOfMemoryHoles].end = end;
+  Yap_NOfMemoryHoles++;
+}
+
 static void *
 yapsbrk(long size)
 {
   ADDR newHeapTop = HeapTop, oldHeapTop = HeapTop;
   LOCK(HeapUsedLock);
   newHeapTop = HeapTop+size;
-  if (Yap_hole_start && newHeapTop > Yap_hole_start) {
+  if (Yap_NOfMemoryHoles && newHeapTop > Yap_MemoryHoles[0].start) {
-    HeapTop = oldHeapTop = Yap_hole_end;
+    UInt i;
+
+    HeapTop = oldHeapTop = Yap_MemoryHoles[0].end;
     newHeapTop = oldHeapTop+size;
-    Yap_hole_start = Yap_hole_end = NULL;
+    Yap_NOfMemoryHoles--;
+    for (i=0; i < Yap_NOfMemoryHoles; i++) {
+      Yap_MemoryHoles[i].start = Yap_MemoryHoles[i+1].start;
+      Yap_MemoryHoles[i].end = Yap_MemoryHoles[i+1].end;
+    }
   }
   if (newHeapTop > HeapLim - MinHeapGap) {
     if (HeapTop + size < HeapLim) {
@@ -1150,6 +1168,7 @@ static Void_t* sYSMALLOc(nb, av) INTERNAL_SIZE_T nb; mstate av;
     
     /* check that one of the above allocation paths succeeded */
     if ((CHUNK_SIZE_T)(size) >= (CHUNK_SIZE_T)(nb + MINSIZE)) {
+
       remainder_size = size - nb;
       remainder = chunk_at_offset(p, nb);
       av->top = remainder;
@@ -1168,7 +1187,6 @@ static Void_t* sYSMALLOc(nb, av) INTERNAL_SIZE_T nb; mstate av;
 
 
 
-
 /*
   sYSTRIm is an inverse of sorts to sYSMALLOc.  It gives memory back
   to the system (via negative arguments to sbrk) if there is unused
@@ -2901,6 +2919,7 @@ void
 Yap_initdlmalloc(void)
 {
   HeapTop = (ADDR)ALIGN_SIZE(HeapTop,16);
+  Yap_NOfMemoryHoles = 0;
   Yap_av = (struct malloc_state *)HeapTop;
   memset((void *)Yap_av, 0, sizeof(struct malloc_state));
   HeapTop += sizeof(struct malloc_state);

C/errors.c

@@ -281,8 +281,13 @@ dump_stack(void)
 #if !USE_SYSTEM_MALLOC
     fprintf (stderr,"%ldKB of Code Space (%p--%p)\n",(long int)((CELL)HeapTop-(CELL)Yap_HeapBase)/1024,Yap_HeapBase,HeapTop); 
 #if USE_DL_MALLOC 
-    if (Yap_hole_start) {
+    if (Yap_NOfMemoryHoles) {
-      fprintf (stderr,"  Last hole: %p--%p\n", Yap_hole_start, Yap_hole_end);
+      UInt i;
+
+      for (i=0; i < Yap_NOfMemoryHoles; i++)
+	fprintf(stderr,"  Current hole: %p--%p\n", 
+		Yap_MemoryHoles[i].start,
+		Yap_MemoryHoles[i].end);
     }
 #endif
 #endif

C/grow.c

@@ -263,9 +263,20 @@ MoveGlobalOnly(void)
 	 * absmi.asm 
 	 */
 #if HAVE_MEMMOVE
-  cpcellsd(H0, (CELL *)((ADDR)OldH0+DelayDiff), OldH - OldH0);  
+  cpcellsd(H0, OldH0, OldH - OldH0);  
 #else
-  cpcellsd(H, (CELL *)((ADDR)OldH+DelayDiff), OldH - OldH0);
+  cpcellsd(H, OldH, OldH - OldH0);
+#endif
+}
+
+static void
+MoveDelays(void)
+{
+  UInt sz = (ADDR)OldH0-(ADDR)OldGlobalBase;
+#if HAVE_MEMMOVE
+  cpcellsd((CELL *)Yap_GlobalBase, OldGlobalBase, sz);  
+#else
+  cpcellsd(H0, OldH0, sz);
 #endif
 }
 
@@ -633,18 +644,25 @@ static_growglobal(long size, CELL **ptr)
   int gc_verbose;
   char *omax = (ADDR)DelayTop();
   ADDR old_GlobalBase = Yap_GlobalBase;
-  Int ReallocDiff;
+  UInt minimal_request = 0L;
+  long size0;
 
   /* adjust to a multiple of 256) */
   Yap_PrologMode |= GrowStackMode;
   if (size < (omax-Yap_GlobalBase)/8)
     size = (omax-Yap_GlobalBase)/8;
-  size = AdjustPageSize(size);
+  size0 = size = AdjustPageSize(size);
   Yap_ErrorMessage = NULL;
   if (!Yap_ExtendWorkSpace(size)) {
-    Yap_ErrorMessage = "Global Stack crashed against Local Stack";
+
-    Yap_PrologMode &= ~GrowStackMode;
+    Yap_ErrorMessage = NULL;
-    return FALSE;
+    size += AdjustPageSize(((CELL)Yap_TrailTop-(CELL)Yap_GlobalBase)+MinHeapGap);   minimal_request = size;
+    size = Yap_ExtendWorkSpaceThroughHole(size);
+    if (size < 0) {
+      Yap_ErrorMessage = "Global Stack crashed against Local Stack";
+      Yap_PrologMode &= ~GrowStackMode;
+      return FALSE;
+    }
   }
   start_growth_time = Yap_cputime();
   gc_verbose = Yap_is_gc_verbose();
@@ -655,13 +673,20 @@ static_growglobal(long size, CELL **ptr)
   }
   ASP -= 256;
   YAPEnterCriticalSection();
-  ReallocDiff = Yap_GlobalBase-old_GlobalBase;
+  if (minimal_request) {
-  TrDiff = LDiff = GDiff = size + ReallocDiff;
+    DelayDiff = size-size0;
-  DelayDiff = ReallocDiff;
+    TrDiff = LDiff = GDiff = size;
+  } else {
+    TrDiff = LDiff = GDiff = size;
+    DelayDiff = 0;
+  }
   XDiff = HDiff = 0;
   Yap_GlobalBase = old_GlobalBase;
   SetHeapRegs();
   MoveLocalAndTrail();
+  if (minimal_request) {
+    MoveDelays();
+  }
   MoveGlobalOnly();
   AdjustStacksAndTrail();
   AdjustRegs(MaxTemps);
@@ -669,6 +694,9 @@ static_growglobal(long size, CELL **ptr)
     *ptr = PtoLocAdjust(*ptr);
   YAPLeaveCriticalSection();
   ASP += 256;
+  if (minimal_request) {
+    Yap_AllocHole(minimal_request, size);
+  }
   growth_time = Yap_cputime()-start_growth_time;
   total_delay_overflow_time += growth_time;
   if (gc_verbose) {
@@ -885,7 +913,6 @@ do_growheap(int fix_code, UInt in_size, struct intermediates *cip)
   }
 #if YAPOR
   Yap_Error(OUT_OF_HEAP_ERROR,TermNil,"cannot grow Heap: more than a worker/thread running");
-  fprintf(stderr,"ERROR 1\n");
   return FALSE;
 #endif
   if (SizeOfOverflow > sz)
@@ -894,7 +921,6 @@ do_growheap(int fix_code, UInt in_size, struct intermediates *cip)
     size = size/2;
     sz =  size << shift_factor;
     if (sz < in_size) {
-fprintf(stderr,"ERROR 2\n");
       return FALSE;
     }
   }
@@ -925,7 +951,6 @@ fprintf(stderr,"ERROR 2\n");
     return TRUE;
   }
   /* failed */
-fprintf(stderr,"ERROR 3\n");
   return FALSE;
 }
 

C/index.c

@@ -11,8 +11,11 @@
 * File:		index.c							 *
 * comments:	Indexing a Prolog predicate				 *
 *									 *
-* Last rev:     $Date: 2006-05-02 16:44:11 $,$Author: vsc $						 *
+* Last rev:     $Date: 2006-05-16 18:37:30 $,$Author: vsc $						 *
 * $Log: not supported by cvs2svn $
+* Revision 1.167  2006/05/02 16:44:11  vsc
+* avoid uninitialised memory at overflow.
+*
 * Revision 1.166  2006/05/02 16:39:06  vsc
 * bug in indexing code
 * fix warning messages for write.c
@@ -381,8 +384,6 @@ UInt STATIC_PROTO(do_compound_index, (ClauseDef *,ClauseDef *,Term *t,struct int
 UInt STATIC_PROTO(do_dbref_index, (ClauseDef *,ClauseDef *,Term,struct intermediates *,UInt,UInt,int,int,CELL *));
 UInt STATIC_PROTO(do_blob_index, (ClauseDef *,ClauseDef *,Term,struct intermediates *,UInt,UInt,int,int,CELL *));
 
-static UInt labelno;
-
 static UInt
 cleanup_sw_on_clauses(CELL larg, UInt sz, OPCODE ecls)
 {
@@ -3223,10 +3224,10 @@ groups_in(ClauseDef *min, ClauseDef *max, GroupDef *grp)
 }
 
 static UInt
-new_label(void)
+new_label(struct intermediates *cint)
 {
-  UInt lbl = labelno;
+  UInt lbl = cint->i_labelno;
-  labelno += 2;
+  cint->i_labelno += 2;
   return lbl;
 }
 
@@ -3507,7 +3508,7 @@ do_var_clauses(ClauseDef *c0, ClauseDef *cf, int var_group, struct intermediates
   UInt labl;
   UInt labl_dyn0 = 0, labl_dynf = 0;
 
-  labl = new_label();
+  labl = new_label(cint);
   Yap_emit(label_op, labl, Zero, cint);
   /*
     add expand_node if var_group == TRUE (jump on var) ||
@@ -3516,11 +3517,11 @@ do_var_clauses(ClauseDef *c0, ClauseDef *cf, int var_group, struct intermediates
   if (first &&
       cint->CurrentPred->PredFlags & LogUpdatePredFlag) {
     UInt ncls;
-    labl_dyn0 = new_label();
+    labl_dyn0 = new_label(cint);
     if (clleft)
       labl_dynf = labl_dyn0;
     else
-      labl_dynf = new_label();
+      labl_dynf = new_label(cint);
     if (clleft == 0) /* trust*/
       ncls = (cf-c0)+1;
     else
@@ -3637,7 +3638,7 @@ emit_single_switch_case(ClauseDef *min, struct intermediates *cint, int first, i
     /* with tabling we don't clean trust at the very end of computation.
     */
     if (clleft == 0 && !first) {
-      UInt lbl = new_label();
+      UInt lbl = new_label(cint);
 
       Yap_emit(label_op, lbl, Zero, cint);
       /* vsc: should check if this condition is sufficient */
@@ -3775,7 +3776,7 @@ do_consts(GroupDef *grp, Term t, struct intermediates *cint, int compound_term,
     return nxtlbl;
   }
   n = count_consts(grp);
-  lbl = new_label();
+  lbl = new_label(cint);
   Yap_emit(label_op, lbl, Zero, cint);
   cs = emit_cswitch(n, (UInt)FAILCODE, cint);
   for (i = 0; i < n; i++) {
@@ -3848,7 +3849,7 @@ do_funcs(GroupDef *grp, Term t, struct intermediates *cint, UInt argno, int firs
     /* no clauses, just skip */
     return nxtlbl;
   }
-  lbl = new_label();
+  lbl = new_label(cint);
   Yap_emit(label_op, lbl, Zero, cint);
   /* generate a switch */
   fs = emit_fswitch(n, (UInt)FAILCODE, cint);
@@ -3935,7 +3936,7 @@ emit_protection_choicepoint(int first, int clleft, UInt nxtlbl, struct intermedi
   if (first) {
     if (clleft) {
       if (cint->CurrentPred->PredFlags & LogUpdatePredFlag) {
-	UInt labl = new_label();
+	UInt labl = new_label(cint);
 
 	Yap_emit_3ops(enter_lu_op, labl, labl, 0, cint);
 	Yap_emit(label_op, labl, Zero, cint);
@@ -4063,7 +4064,7 @@ do_optims(GroupDef *group, int ngroups, UInt fail_l, ClauseDef *min, struct inte
     CELL *sp;
     UInt labl;
 
-    labl = new_label();
+    labl = new_label(cint);
     sp = Yap_emit_extra_size(if_not_op, Zero, 4*CellSize, cint);
     sp[0] = (CELL)(group[0].FirstClause->Tag);
     sp[1] = (CELL)(group[1].FirstClause->Code);
@@ -4134,7 +4135,7 @@ do_index(ClauseDef *min, ClauseDef* max, struct intermediates *cint, UInt argno,
   }
   ngroups = groups_in(min, max, group);
   if (IsVarTerm(t)) {
-    lablx = new_label();
+    lablx = new_label(cint);
     Yap_emit(label_op, lablx, Zero, cint);
     while (IsVarTerm(t)) {
       if (ngroups > 1 || !group->VarClauses) {
@@ -4159,9 +4160,9 @@ do_index(ClauseDef *min, ClauseDef* max, struct intermediates *cint, UInt argno,
       }
       ngroups = groups_in(min, max, group);
     } 
-    labl0 = labl = new_label();
+    labl0 = labl = new_label(cint);
   } else {
-    lablx = labl0 = labl = new_label();
+    lablx = labl0 = labl = new_label(cint);
   }
   cint->expand_block = eblk;
   top = (CELL *)(group+ngroups);
@@ -4214,7 +4215,7 @@ do_index(ClauseDef *min, ClauseDef* max, struct intermediates *cint, UInt argno,
 	       (ap->PredFlags & LogUpdatePredFlag && group[0].VarClauses)) {
       /* make sure we know where to suspend */
       Yap_emit(label_op, labl0, Zero, cint);
-      labl = new_label();
+      labl = new_label(cint);
       Yap_emit(jump_v_op, suspend_indexing(min, max, ap, cint), Zero, cint); 
     }
   }
@@ -4224,7 +4225,7 @@ do_index(ClauseDef *min, ClauseDef* max, struct intermediates *cint, UInt argno,
     /* a group may end up not having clauses*/
 
     if (i < ngroups-1) {
-      nextlbl = new_label();
+      nextlbl = new_label(cint);
     } else {
       nextlbl = fail_l;
     }
@@ -4306,7 +4307,7 @@ do_compound_index(ClauseDef *min0, ClauseDef* max0, Term* sreg, struct intermedi
     if (ngroups == 1 && group->VarClauses == 0) {
       /* ok, we are doing a sub-argument */
       /* process groups */
-      *newlabp = new_label();
+      *newlabp = new_label(cint);
       top = (CELL *)(group+1);
       newlabp = do_nonvar_group(group, (sreg == NULL ? 0L : Deref(sreg[i])), i+1, (isvt ? NULL : sreg), arity, *newlabp, cint, argno, argno == 1, (last_arg && i+1 == arity), fail_l, clleft, top);
       if (newlabp == NULL) {
@@ -4350,7 +4351,7 @@ do_dbref_index(ClauseDef *min, ClauseDef* max, Term t, struct intermediates *cin
   if (ngroups > 1 || group->VarClauses) {
     return do_index(min, max, cint, argno+1, fail_l, first, clleft, top);
   } else {
-    int labl = new_label();
+    int labl = new_label(cint);
 
     Yap_emit(label_op, labl, Zero, cint);
     Yap_emit(index_dbref_op, Zero, Zero, cint);
@@ -4382,7 +4383,7 @@ do_blob_index(ClauseDef *min, ClauseDef* max, Term t, struct intermediates *cint
   if (ngroups > 1 || group->VarClauses) {
     return do_index(min, max, cint, argno+1, fail_l, first, clleft, top);
   } else {
-    int labl = new_label();
+    int labl = new_label(cint);
 
     Yap_emit(label_op, labl, Zero, cint);
     Yap_emit(index_blob_op, Zero, Zero, cint);
@@ -4439,7 +4440,7 @@ compile_index(struct intermediates *cint)
   CELL *top = (CELL *) TR;
 
   /* only global variable I use directly */
-  labelno = 1;
+  cint->i_labelno = 1;
 
   Yap_Error_Size = 0;
   /* reserve double the space for compiler */
@@ -4453,7 +4454,7 @@ compile_index(struct intermediates *cint)
   cint->freep = (char *)(cls+NClauses);
   if (ap->PredFlags & LogUpdatePredFlag) {
     /* throw away a label */
-    new_label();
+    new_label(cint);
     init_log_upd_clauses(cls,ap);
   } else {
     /* prepare basic data structures */ 
@@ -5005,7 +5006,7 @@ expand_index(struct intermediates *cint) {
   first = ap->cs.p_code.FirstClause;
   NClauses = ap->cs.p_code.NOfClauses;
   sp = stack = (istack_entry *)top;
-  labelno = 1;
+  cint->i_labelno = 1;
   stack[0].pos = 0;
   /* try to refine the interval using the indexing code */
 
@@ -8711,7 +8712,7 @@ find_caller(PredEntry *ap, yamop *code, struct intermediates *cint) {
   UInt arity = 0;
   sp = stack = (istack_entry *)top;
 
-  labelno = 1;
+  cint->i_labelno = 1;
   stack[0].pos = 0;
 
   /* try to refine the interval using the indexing code */

C/save.c

@@ -1467,6 +1467,7 @@ CloseRestore(void)
   Yap_PrologMode = UserMode;
 }
 
+#if !defined(_WIN32)
 static int 
 check_opcodes(OPCODE old_ops[])
 {
@@ -1479,11 +1480,13 @@ check_opcodes(OPCODE old_ops[])
       break;
     }
   }
-  return(have_shifted);
+  return have_shifted;
 #else
-  return(FALSE);
+  /* be conservative */
+  return TRUE;
 #endif
 }
+#endif
 
 static void 
 RestoreHeap(OPCODE old_ops[])
@@ -1492,7 +1495,13 @@ RestoreHeap(OPCODE old_ops[])
   Term mod = CurrentModule;
 
   CurrentModule = PROLOG_MODULE;
+#if defined(_WIN32)
+  /* It seems that under WIN32 opcodes may not have moved but the
+     remaining code may have bmoved */ 
+  opcodes_moved = TRUE;
+#else
   opcodes_moved = check_opcodes(old_ops);
+#endif
   /* opcodes_moved has side-effects and should be tried first */
   if (heap_moved) {
     RestoreFreeSpace();

C/tracer.c

@@ -161,8 +161,6 @@ 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++;
-  if (vsc_count < 81000)
-    return;
 #ifdef COMMENTED
   if (worker_id != 04 || worker_id != 03) return;
   //  if (vsc_count == 218280)

H/Heap.h

@@ -10,7 +10,7 @@
 * File:		Heap.h         						 *
 * mods:									 *
 * comments:	Heap Init Structure					 *
-* version:      $Id: Heap.h,v 1.97 2006-04-28 15:48:32 vsc Exp $	 *
+* version:      $Id: Heap.h,v 1.98 2006-05-16 18:37:30 vsc Exp $	 *
 *************************************************************************/
 
 /* information that can be stored in Code Space */
@@ -31,6 +31,16 @@
 #define INT_KEYS_DEFAULT_SIZE 256
 #endif
 
+#if USE_DL_MALLOC
+
+#define MAX_DLMALLOC_HOLES 32
+
+typedef struct memory_hole {
+  ADDR start;
+  ADDR end;
+} memory_hole_type;
+#endif
+
 
 #define GC_MAVARS_HASH_SIZE 512
 
@@ -181,7 +191,10 @@ typedef int   (*Agc_hook)(Atom);
 typedef struct various_codes {
   special_functors funcs;
   struct malloc_state *av_;
-  ADDR hole_start, hole_end;
+#if USE_DL_MALLOC
+  struct memory_hole memory_holes[MAX_DLMALLOC_HOLES];
+  UInt nof_memory_holes;
+#endif
   Int heap_used;
   Int heap_max;
   ADDR heap_top;
@@ -527,8 +540,8 @@ struct various_codes *Yap_heap_regs;
 #endif
 
 #define  Yap_av                  Yap_heap_regs->av_
-#define  Yap_hole_start          Yap_heap_regs->hole_start
+#define  Yap_MemoryHoles         Yap_heap_regs->memory_holes
-#define  Yap_hole_end            Yap_heap_regs->hole_end
+#define  Yap_NOfMemoryHoles      Yap_heap_regs->nof_memory_holes
 #define  HeapUsed                Yap_heap_regs->heap_used
 #define  HeapMax                 Yap_heap_regs->heap_max
 #define  HeapTop                 Yap_heap_regs->heap_top

H/alloc.h

@@ -131,6 +131,13 @@ MALLOC_T calloc(size_t,size_t);
 
 #endif
 
+#if USE_DL_MALLOC
+void Yap_add_memory_hole(ADDR, ADDR);
+#else
+#define Yap_add_memory_hole(Start, End)
+#endif
+
 #define SCRATCH_START_SIZE        (64*1024L)
 #define SCRATCH_INC_SIZE          (64*1024L)
 
+

H/compile.h

@@ -244,6 +244,7 @@ typedef struct intermediates {
   jmp_buf CompilerBotch;
   yamop *code_addr;
   yamop *expand_block;
+  UInt  i_labelno;
   /* for expanding code */
   union { 
     struct static_index *si;

changes-5.1.html

@@ -16,6 +16,14 @@
 
 <h2>Yap-5.1.2:</h2>
 <ul>
+<li> NEW: make YAP large address aware on WIN32 (should be able to
+allocate up to 3GB).</li>
+<li> FIXED: WIN32 may have a lot of fragmentation so several memory holes may be active at the same time, keep up to 32 open holes.</li>
+<li> FIXED: WIN32 may move functions without moving emulator: always fix C-functtions.</li>
+<li> FIXED: use $SYSTEMDRIVE to install YAP in WIN32.</li>
+<li> FIXED: compilation bug in arg(X,1,A).</li>
+<li> NEW: extend interface to pass chunks of integers/floats.</li>
+<li> FIXED: get rid of some more global variables.</li>
 <li> NEW: thread_yield/0 (request Paulo Moura).</li>
 <li> FIXED: current_thread was not returning aliases (obs Paulo Moura).</li>
 <li> FIXED: AuxSp was not properly initialised for new threads (obs Paulo Moura).</li>

configure.in

@@ -360,7 +360,7 @@ then
     yap_cv_readline=no
     if test "$prefix" = "NONE"
     then
-      prefix="c:/Yap"
+      prefix="$SYSTEMDRIVE/Yap"
     fi
   else
     use_malloc="yes"
@@ -722,6 +722,7 @@ dnl Linux has both elf and a.out, in this case we found elf
         SHLIB_LD="\$(CC) -shared ../../yap.dll"
 	SHLIB_SUFFIX=".dll"
 	C_PARSER_FLAGS="$C_INTERF_FLAGS"
+	LDFLAGS="-Wl,--large-address-aware $LDFLAGS"
 	EXEC_SUFFIX=".exe"
 	INSTALL_DLLS=""
 	DO_SECOND_LD=""

include/YapInterface.h

@@ -366,6 +366,12 @@ extern X_API int  PROTO(YAP_ThreadAttachEngine,(int));
 extern X_API int  PROTO(YAP_ThreadDetachEngine,(int));
 extern X_API int  PROTO(YAP_ThreadDestroyEngine,(int));
 
+/* matrices stuff */
+extern X_API int      PROTO(YAP_ArgsToIntArray,(YAP_Term, YAP_UInt, const YAP_Int *));
+extern X_API YAP_Term PROTO(YAP_IntArrayToArgs,(YAP_UInt, const YAP_Int *));
+extern X_API int      PROTO(YAP_ArgsToFloatArray,(YAP_Term, YAP_UInt, const YAP_Float *));
+extern X_API YAP_Term PROTO(YAP_FloatArrayToArgs,(YAP_UInt, const YAP_Float *));
+
 /*  term comparison */
 extern X_API int  PROTO(YAP_CompareTerms,(YAP_Term, YAP_Term));
 

include/yap_structs.h

@@ -43,6 +43,8 @@ typedef struct AtomEntry *YAP_Atom;
 
 typedef long int  YAP_Int;
 
+typedef unsigned long int  YAP_UInt;
+
 typedef double YAP_Float;
 
 #ifndef TRUE

misc/yap.def

@@ -92,4 +92,7 @@ YAP_ThreadAttachEngine
 YAP_ThreadDetachEngine
 YAP_ThreadDestroyEngine
 YAP_CompareTerms
-
+YAP_ArgsToIntArray
+YAP_IntArrayToArgs
+YAP_ArgsToFloatArray
+YAP_FloatArrayToArgs