improve indexing on floats

fix sending large lists to DB


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

C/absmi.c

@@ -10,8 +10,12 @@
 *									 *
 * File:		absmi.c							 *
 * comments:	Portable abstract machine interpreter                    *
-* Last rev:     $Date: 2006-08-07 18:51:44 $,$Author: vsc $						 *
+* Last rev:     $Date: 2006-09-20 20:03:51 $,$Author: vsc $						 *
 * $Log: not supported by cvs2svn $
+* Revision 1.203  2006/08/07 18:51:44  vsc
+* fix garbage collector not to try to garbage collect when we ask for large
+* chunks of stack in a single go.
+*
 * Revision 1.202  2006/05/24 02:35:39  vsc
 * make chr work and other minor fixes.
 *
@@ -3819,16 +3823,16 @@ Yap_absmi(int inp)
       ENDD(d0);
       ENDOpRW();
 
-      Op(get_float, xc);
+      Op(get_float, xd);
       BEGD(d0);
-      d0 = XREG(PREG->u.xc.x);
+      d0 = XREG(PREG->u.xd.x);
       deref_head(d0, gfloat_unk);
 
     gfloat_nonvar:
       if (!IsApplTerm(d0))
 	FAIL();
       /* we have met a preexisting float */
-      START_PREFETCH(xc);
+      START_PREFETCH(xd);
       BEGP(pt0);
       pt0 = RepAppl(d0);
       /* check functor */
@@ -3836,7 +3840,8 @@ Yap_absmi(int inp)
 	FAIL();
       }
       BEGP(pt1);
-      pt1 = RepAppl(PREG->u.xc.c);
+      pt1 = PREG->u.xd.d;
+      PREG = NEXTOP(PREG, xd);
       if (
 	  pt1[1] != pt0[1]
 #if SIZEOF_DOUBLE == 2*SIZEOF_INT_P
@@ -3845,7 +3850,6 @@ Yap_absmi(int inp)
 	  ) FAIL();
       ENDP(pt1);
       ENDP(pt0);
-      PREG = NEXTOP(PREG, xc);
       /* enter read mode */
       GONext();
       END_PREFETCH();
@@ -3856,8 +3860,8 @@ Yap_absmi(int inp)
       /* set d1 to be the new structure we are going to create */
       START_PREFETCH(xc);
       BEGD(d1);
-      d1 = PREG->u.xc.c;
+      d1 = AbsAppl(PREG->u.xd.d);
-      PREG = NEXTOP(PREG, xc);
+      PREG = NEXTOP(PREG, xd);
       BIND(pt0, d1, bind_gfloat);
 #ifdef COROUTINING
       DO_TRAIL(pt0, d1);
@@ -3872,28 +3876,25 @@ Yap_absmi(int inp)
       ENDD(d0);
       ENDOp();
 
-      Op(get_longint, xc);
+      Op(get_longint, xi);
       BEGD(d0);
-      d0 = XREG(PREG->u.xc.x);
+      d0 = XREG(PREG->u.xi.x);
       deref_head(d0, glongint_unk);
 
     glongint_nonvar:
       if (!IsApplTerm(d0))
 	FAIL();
       /* we have met a preexisting longint */
-      START_PREFETCH(xc);
+      START_PREFETCH(xi);
       BEGP(pt0);
       pt0 = RepAppl(d0);
       /* check functor */
       if (*pt0 != (CELL)FunctorLongInt) {
 	FAIL();
       }
-      BEGP(pt1);
+      if (PREG->u.xi.i[1] != (CELL)pt0[1]) FAIL();
-      pt1 = RepAppl(PREG->u.xc.c);
-      if (pt1[1] != pt0[1]) FAIL();
-      ENDP(pt1);
       ENDP(pt0);
-      PREG = NEXTOP(PREG, xc);
+      PREG = NEXTOP(PREG, xi);
       /* enter read mode */
       GONext();
       END_PREFETCH();
@@ -3902,10 +3903,10 @@ Yap_absmi(int inp)
       deref_body(d0, pt0, glongint_unk, glongint_nonvar);
       /* Enter Write mode */
       /* set d1 to be the new structure we are going to create */
-      START_PREFETCH(xc);
+      START_PREFETCH(xi);
       BEGD(d1);
-      d1 = PREG->u.xc.c;
+      d1 = AbsAppl(PREG->u.xi.i);
-      PREG = NEXTOP(PREG, xc);
+      PREG = NEXTOP(PREG, xi);
       BIND(pt0, d1, bind_glongint);
 #ifdef COROUTINING
       DO_TRAIL(pt0, d1);
@@ -5653,6 +5654,18 @@ Yap_absmi(int inp)
       GONextW();
       ENDOpW();
 
+      OpW(unify_float_write, od);
+      * SREG++ = AbsAppl(PREG->u.od.d);
+      PREG = NEXTOP(PREG, od);
+      GONextW();
+      ENDOpW();
+
+      OpW(unify_longint_write, oi);
+      * SREG++ = AbsAppl(PREG->u.oi.i);
+      PREG = NEXTOP(PREG, oi);
+      GONextW();
+      ENDOpW();
+
       Op(unify_atom, oc);
       BEGD(d0);
       BEGP(pt0);
@@ -5680,6 +5693,18 @@ Yap_absmi(int inp)
       ENDD(d0);
       ENDOp();
 
+      Op(unify_l_float_write, od);
+      SREG[0] = AbsAppl(PREG->u.od.d);
+      PREG = NEXTOP(PREG, od);
+      GONext();
+      ENDOp();
+
+      Op(unify_l_longint_write, oi);
+      SREG[0] = AbsAppl(PREG->u.oi.i);
+      PREG = NEXTOP(PREG, oi);
+      GONext();
+      ENDOp();
+
       Op(unify_l_atom_write, oc);
       SREG[0] = PREG->u.oc.c;
       PREG = NEXTOP(PREG, oc);
@@ -5766,7 +5791,7 @@ Yap_absmi(int inp)
       GONext();
       ENDOp();
 
-      Op(unify_float, oc);
+      Op(unify_float, od);
       BEGD(d0);
       BEGP(pt0);
       pt0 = SREG++;
@@ -5786,8 +5811,8 @@ Yap_absmi(int inp)
       }
       ENDD(d0);
       BEGP(pt1);
-      pt1 = RepAppl(PREG->u.oc.c);
+      pt1 = PREG->u.od.d;
-      PREG = NEXTOP(PREG, oc);
+      PREG = NEXTOP(PREG, od);
       if (
 	  pt1[1] != pt0[1]
 #if SIZEOF_DOUBLE == 2*SIZEOF_INT_P
@@ -5800,8 +5825,8 @@ Yap_absmi(int inp)
 
       derefa_body(d0, pt0, ufloat_unk, ufloat_nonvar);
       BEGD(d1);
-      d1 = PREG->u.oc.c;
+      d1 = AbsAppl(PREG->u.od.d);
-      PREG = NEXTOP(PREG, oc);
+      PREG = NEXTOP(PREG, od);
       BIND_GLOBAL(pt0, d1, bind_ufloat);
 #ifdef COROUTINING
       DO_TRAIL(pt0, d1);
@@ -5814,7 +5839,7 @@ Yap_absmi(int inp)
       ENDD(d0);
       ENDOp();
 
-      Op(unify_l_float, oc);
+      Op(unify_l_float, od);
       BEGD(d0);
       CACHE_S();
       READ_IN_S();
@@ -5833,8 +5858,8 @@ Yap_absmi(int inp)
       }
       ENDD(d0);
       BEGP(pt1);
-      pt1 = RepAppl(PREG->u.oc.c);
+      pt1 = PREG->u.od.d;
-      PREG = NEXTOP(PREG, oc);
+      PREG = NEXTOP(PREG, od);
       if (
 	  pt1[1] != pt0[1]
 #if SIZEOF_DOUBLE == 2*SIZEOF_INT_P
@@ -5847,8 +5872,8 @@ Yap_absmi(int inp)
 
       derefa_body(d0, S_SREG, ulfloat_unk, ulfloat_nonvar);
       BEGD(d1);
-      d1 = PREG->u.oc.c;
+      d1 = AbsAppl(PREG->u.od.d);
-      PREG = NEXTOP(PREG, oc);
+      PREG = NEXTOP(PREG, od);
       BIND_GLOBAL(S_SREG, d1, bind_ulfloat);
 #ifdef COROUTINING
       DO_TRAIL(S_SREG, d1);
@@ -5861,7 +5886,7 @@ Yap_absmi(int inp)
       ENDD(d0);
       ENDOp();
 
-      Op(unify_longint, oc);
+      Op(unify_longint, oi);
       BEGD(d0);
       BEGP(pt0);
       pt0 = SREG++;
@@ -5881,8 +5906,8 @@ Yap_absmi(int inp)
       }
       ENDD(d0);
       BEGP(pt1);
-      pt1 = RepAppl(PREG->u.oc.c);
+      pt1 = PREG->u.oi.i;
-      PREG = NEXTOP(PREG, oc);
+      PREG = NEXTOP(PREG, oi);
       if (pt1[1] != pt0[1]) FAIL();
       ENDP(pt1);
       ENDP(pt0);
@@ -5890,8 +5915,8 @@ Yap_absmi(int inp)
 
       derefa_body(d0, pt0, ulongint_unk, ulongint_nonvar);
       BEGD(d1);
-      d1 = PREG->u.oc.c;
+      d1 = AbsAppl(PREG->u.oi.i);
-      PREG = NEXTOP(PREG, oc);
+      PREG = NEXTOP(PREG, oi);
       BIND_GLOBAL(pt0, d1, bind_ulongint);
 #ifdef COROUTINING
       DO_TRAIL(pt0, d1);
@@ -5904,7 +5929,7 @@ Yap_absmi(int inp)
       ENDD(d0);
       ENDOp();
 
-      Op(unify_l_longint, oc);
+      Op(unify_l_longint, oi);
       BEGD(d0);
       CACHE_S();
       READ_IN_S();
@@ -5923,8 +5948,8 @@ Yap_absmi(int inp)
       }
       ENDD(d0);
       BEGP(pt1);
-      pt1 = RepAppl(PREG->u.oc.c);
+      pt1 = PREG->u.oi.i;
-      PREG = NEXTOP(PREG, oc);
+      PREG = NEXTOP(PREG, oi);
       if (pt1[1] != pt0[1]) FAIL();
       ENDP(pt1);
       ENDP(pt0);
@@ -5932,8 +5957,8 @@ Yap_absmi(int inp)
 
       derefa_body(d0, S_SREG, ullongint_unk, ullongint_nonvar);
       BEGD(d1);
-      d1 = PREG->u.oc.c;
+      d1 = AbsAppl(PREG->u.oi.i);
-      PREG = NEXTOP(PREG, oc);
+      PREG = NEXTOP(PREG, oi);
       BIND_GLOBAL(S_SREG, d1, bind_ullongint);
 #ifdef COROUTINING
       DO_TRAIL(S_SREG, d1);
@@ -5975,8 +6000,8 @@ Yap_absmi(int inp)
 
       derefa_body(d0, pt0, ubigint_unk, ubigint_nonvar);
       BEGD(d1);
-      d1 = PREG->u.oc.c;
+      d1 = AbsAppl(PREG->u.oi.i);
-      PREG = NEXTOP(PREG, oc);
+      PREG = NEXTOP(PREG, oi);
       BIND_GLOBAL(pt0, d1, bind_ubigint);
 #ifdef COROUTINING
       DO_TRAIL(pt0, d1);
@@ -6420,6 +6445,24 @@ Yap_absmi(int inp)
       ENDD(d0);
       ENDOp();
 
+      Op(put_float, xd);
+      BEGD(d0);
+      d0 = AbsAppl(PREG->u.xd.d);
+      XREG(PREG->u.xd.x) = d0;
+      PREG = NEXTOP(PREG, xd);
+      GONext();
+      ENDD(d0);
+      ENDOp();
+
+      Op(put_longint, xi);
+      BEGD(d0);
+      d0 = AbsAppl(PREG->u.xi.i);
+      XREG(PREG->u.xi.x) = d0;
+      PREG = NEXTOP(PREG, xi);
+      GONext();
+      ENDD(d0);
+      ENDOp();
+
       Op(put_list, x);
       CACHE_S();
       READ_IN_S();
@@ -6596,6 +6639,24 @@ Yap_absmi(int inp)
       GONext();
       ENDOp();
 
+      Op(write_float, d);
+      BEGD(d0);
+      d0 = AbsAppl(PREG->u.d.d);
+      *SREG++ = d0;
+      ENDD(d0);
+      PREG = NEXTOP(PREG, d);
+      GONext();
+      ENDOp();
+
+      Op(write_longint, i);
+      BEGD(d0);
+      d0 = AbsAppl(PREG->u.i.i);
+      *SREG++ = d0;
+      ENDD(d0);
+      PREG = NEXTOP(PREG, i);
+      GONext();
+      ENDOp();
+
       Op(write_n_atoms, sc);
       BEGD(d0);
       BEGD(d1);
@@ -8123,7 +8184,11 @@ Yap_absmi(int inp)
       
       Op(index_blob, e);
       PREG = NEXTOP(PREG, e);
+#if SIZEOF_DOUBLE == 2*SIZEOF_LONG_INT
+      I_R = MkIntTerm(SREG[0]^SREG[1]);
+#else
       I_R = MkIntTerm(SREG[0]);
+#endif
       GONext();
       ENDOp();
       

C/amasm.c

@@ -11,8 +11,12 @@
 * File:		amasm.c							 *
 * comments:	abstract machine assembler				 *
 *									 *
-* Last rev:     $Date: 2006-03-24 17:13:41 $							 *
+* Last rev:     $Date: 2006-09-20 20:03:51 $							 *
 * $Log: not supported by cvs2svn $
+* Revision 1.87  2006/03/24 17:13:41  rslopes
+* New update to BEAM engine.
+* BEAM now uses YAP Indexing (JITI)
+*
 * Revision 1.86  2006/01/02 02:16:17  vsc
 * support new interface between YAP and GMP, so that we don't rely on our own
 * allocation routines.
@@ -808,6 +812,62 @@ a_ublob(CELL rnd1, op_numbers opcode, op_numbers opcode_w, int *clause_has_blobs
   return code_p;
 }
 
+inline static yamop *
+a_ud(op_numbers opcode, op_numbers opcode_w, yamop *code_p, int pass_no, struct PSEUDO *cpc)
+{
+  if (pass_no) {
+    code_p->opc = emit_op(opcode);
+    code_p->u.oc.opcw = emit_op(opcode_w);
+    code_p->u.od.d[0] = (CELL)FunctorDouble;
+    code_p->u.od.d[1] = RepAppl(cpc->rnd1)[1];
+#if SIZEOF_DOUBLE == 2*SIZEOF_INT_P
+    code_p->u.od.d[2] = RepAppl(cpc->rnd1)[2];
+#endif
+  }
+  GONEXT(od);
+  return code_p;
+}
+
+inline static yamop *
+a_ui(op_numbers opcode, op_numbers opcode_w, yamop *code_p, int pass_no, struct PSEUDO *cpc)
+{
+  if (pass_no) {
+    code_p->opc = emit_op(opcode);
+    code_p->u.oc.opcw = emit_op(opcode_w);
+    code_p->u.oi.i[0] = (CELL)FunctorLongInt;
+    code_p->u.oi.i[1] = RepAppl(cpc->rnd1)[1];
+  }
+  GONEXT(oi);
+  return code_p;
+}
+
+inline static yamop *
+a_wd(op_numbers opcode, yamop *code_p, int pass_no, struct PSEUDO *cpc)
+{
+  if (pass_no) {
+    code_p->opc = emit_op(opcode);
+    code_p->u.d.d[0] = (CELL)FunctorDouble;
+    code_p->u.d.d[1] = RepAppl(cpc->rnd1)[1];
+#if SIZEOF_DOUBLE == 2*SIZEOF_INT_P
+    code_p->u.d.d[2] = RepAppl(cpc->rnd1)[2];
+#endif
+  }
+  GONEXT(d);
+  return code_p;
+}
+
+inline static yamop *
+a_wi(op_numbers opcode, yamop *code_p, int pass_no, struct PSEUDO *cpc)
+{
+  if (pass_no) {
+    code_p->opc = emit_op(opcode);
+    code_p->u.i.i[0] = (CELL)FunctorLongInt;
+    code_p->u.i.i[1] = RepAppl(cpc->rnd1)[1];
+  }
+  GONEXT(i);
+  return code_p;
+}
+
 inline static yamop *
 a_nc(CELL rnd1, op_numbers opcode, int i, yamop *code_p, int pass_no)
 {
@@ -846,6 +906,35 @@ a_rf(op_numbers opcode, yamop *code_p, int pass_no, struct PSEUDO *cpc)
   return code_p;
 }
 
+inline static yamop *
+a_rd(op_numbers opcode, yamop *code_p, int pass_no, struct PSEUDO *cpc)
+{
+  if (pass_no) {
+    code_p->opc = emit_op(opcode);
+    code_p->u.xd.x = emit_x(cpc->rnd2);
+    code_p->u.xd.d[0] = (CELL)FunctorDouble;
+    code_p->u.xd.d[1] = RepAppl(cpc->rnd1)[1];
+#if SIZEOF_DOUBLE == 2*SIZEOF_INT_P
+    code_p->u.xd.d[2] = RepAppl(cpc->rnd1)[2];
+#endif
+  }
+  GONEXT(xd);
+  return code_p;
+}
+
+inline static yamop *
+a_ri(op_numbers opcode, yamop *code_p, int pass_no, struct PSEUDO *cpc)
+{
+  if (pass_no) {
+    code_p->opc = emit_op(opcode);
+    code_p->u.xi.x = emit_x(cpc->rnd2);
+    code_p->u.xi.i[0] = (CELL)FunctorLongInt;
+    code_p->u.xi.i[1] = RepAppl(cpc->rnd1)[1];
+  }
+  GONEXT(xi);
+  return code_p;
+}
+
 static yamop *
 a_rc(op_numbers opcode, yamop *code_p, int pass_no, struct intermediates *cip)
 {
@@ -854,7 +943,6 @@ a_rc(op_numbers opcode, yamop *code_p, int pass_no, struct intermediates *cip)
       (cip->cpc->nextInst->op == get_atom_op ||
        cip->cpc->nextInst->op == get_num_op)) {
     struct PSEUDO *next;
-
     next = cip->cpc->nextInst;
     if (next->nextInst->rnd2 == 3 &&
 	(next->nextInst->op == get_atom_op ||
@@ -950,6 +1038,18 @@ a_rb(op_numbers opcode, int *clause_has_blobsp, yamop *code_p, int pass_no, stru
   return code_p;
 }
 
+inline static yamop *
+a_rli(op_numbers opcode, int *clause_has_blobsp, yamop *code_p, int pass_no, struct intermediates *cip)
+{
+  if (pass_no) {
+    code_p->opc = emit_op(opcode);
+    code_p->u.xc.x = emit_x(cip->cpc->rnd2);
+    code_p->u.xc.c = AbsAppl((CELL *)(Unsigned(cip->code_addr) + cip->label_offset[cip->cpc->rnd1]));
+  }
+  GONEXT(xc);
+  return code_p;
+}
+
 inline static yamop *
 a_r(CELL arnd2, op_numbers opcode, yamop *code_p, int pass_no)
 {
@@ -2497,6 +2597,22 @@ do_pass(int pass_no, yamop **entry_codep, int assembling, int *clause_has_blobsp
 	cl_u->luc.ClRefCount = 0;
 	cl_u->luc.ClPred = cip->CurrentPred;
 	cl_u->luc.ClSize = size;
+	/*
+	  Support for timestamps, stalled for now.
+	if (cip->CurrentPred->PredFlags & ThreadLocalPredFlag) {
+	  LOCK(LocalTimeStampLock);
+	  cl_u->luc.ClTimeStart = LocalTimeStamp;
+	  LocalTimeStamp++;
+	  cl_u->luc.ClTimeEnd = LocalTimeStamp;
+	  UNLOCK(LocalTimeStampLock);
+	} else {
+	  LOCK(GlobalTimeStampLock);
+	  cl_u->luc.ClTimeStart = GlobalTimeStamp;
+	  GlobalTimeStamp++;
+	  cl_u->luc.ClTimeEnd = GlobalTimeStamp;
+	  UNLOCK(GlobalTimeStampLock);
+	}
+	*/
 	if (*clause_has_blobsp) {
 	  cl_u->luc.ClFlags |= HasBlobsMask;
 	}
@@ -2672,10 +2788,10 @@ do_pass(int pass_no, yamop **entry_codep, int assembling, int *clause_has_blobsp
       code_p = a_rc(_get_atom, code_p, pass_no, cip);
       break;
     case get_float_op:
-      code_p = a_rb(_get_float, clause_has_blobsp, code_p, pass_no, cip);
+      code_p = a_rd(_get_float, code_p, pass_no, cip->cpc);
       break;
     case get_longint_op:
-      code_p = a_rb(_get_longint, clause_has_blobsp, code_p, pass_no, cip);
+      code_p = a_ri(_get_longint, code_p, pass_no, cip->cpc);
       break;
     case get_bigint_op:
       code_p = a_rb(_get_bigint, clause_has_blobsp, code_p, pass_no, cip);
@@ -2685,7 +2801,11 @@ do_pass(int pass_no, yamop **entry_codep, int assembling, int *clause_has_blobsp
       code_p = a_rc(_put_atom, code_p, pass_no, cip);
       break;
     case put_float_op:
+      code_p = a_rd(_put_float, code_p, pass_no, cip->cpc);
+      break;
     case put_longint_op:
+      code_p = a_ri(_put_longint, code_p, pass_no, cip->cpc);
+      break;
     case put_bigint_op:
       code_p = a_rb(_put_atom, clause_has_blobsp, code_p, pass_no, cip);
       break;
@@ -2736,10 +2856,10 @@ do_pass(int pass_no, yamop **entry_codep, int assembling, int *clause_has_blobsp
       code_p = a_ucons(&do_not_optimise_uatom, unify_atom_op, code_p, pass_no, cip);
       break;
     case unify_float_op:
-      code_p = a_ublob(cip->cpc->rnd1, _unify_float, _unify_atom_write, clause_has_blobsp, code_p, pass_no, cip);
+      code_p = a_ud(_unify_float, _unify_float_write, code_p, pass_no, cip->cpc);
       break;
     case unify_longint_op:
-      code_p = a_ublob(cip->cpc->rnd1, _unify_longint, _unify_atom_write, clause_has_blobsp, code_p, pass_no, cip);
+      code_p = a_ui(_unify_longint, _unify_longint_write, code_p, pass_no, cip->cpc);
       break;
     case unify_bigint_op:
       code_p = a_ublob(cip->cpc->rnd1, _unify_bigint, _unify_atom_write, clause_has_blobsp, code_p, pass_no, cip);
@@ -2749,10 +2869,10 @@ do_pass(int pass_no, yamop **entry_codep, int assembling, int *clause_has_blobsp
       code_p = a_uc(cip->cpc->rnd1, _unify_l_atom, _unify_l_atom_write, code_p, pass_no);
       break;
     case unify_last_float_op:
-      code_p = a_ublob(cip->cpc->rnd1, _unify_l_float, _unify_l_atom_write, clause_has_blobsp, code_p, pass_no, cip);
+      code_p = a_ud(_unify_l_float, _unify_l_float_write, code_p, pass_no, cip->cpc);
       break;
     case unify_last_longint_op:
-      code_p = a_ublob(cip->cpc->rnd1, _unify_l_longint, _unify_l_atom_write, clause_has_blobsp, code_p, pass_no, cip);
+      code_p = a_ui(_unify_l_longint, _unify_l_longint_write, code_p, pass_no, cip->cpc);
       break;
     case unify_last_bigint_op:
       code_p = a_ublob(cip->cpc->rnd1, _unify_l_bigint, _unify_l_atom_write, clause_has_blobsp, code_p, pass_no, cip);
@@ -2762,7 +2882,11 @@ do_pass(int pass_no, yamop **entry_codep, int assembling, int *clause_has_blobsp
       code_p = a_ucons(&do_not_optimise_uatom, write_atom_op, code_p, pass_no, cip);
       break;
     case write_float_op:
+      code_p = a_wd(_write_float, code_p, pass_no, cip->cpc);
+      break;
     case write_longint_op:
+      code_p = a_wi(_write_longint, code_p, pass_no, cip->cpc);
+      break;
     case write_bigint_op:
       code_p = a_blob(cip->cpc->rnd1, _write_atom, clause_has_blobsp, code_p, pass_no, cip);
       break;

C/cdmgr.c

@@ -11,8 +11,12 @@
 * File:		cdmgr.c							 *
 * comments:	Code manager						 *
 *									 *
-* Last rev:     $Date: 2006-08-07 18:51:44 $,$Author: vsc $						 *
+* Last rev:     $Date: 2006-09-20 20:03:51 $,$Author: vsc $						 *
 * $Log: not supported by cvs2svn $
+* Revision 1.190  2006/08/07 18:51:44  vsc
+* fix garbage collector not to try to garbage collect when we ask for large
+* chunks of stack in a single go.
+*
 * Revision 1.189  2006/05/24 02:35:39  vsc
 * make chr work and other minor fixes.
 *
@@ -551,6 +555,10 @@ static Term BlobTermAdjust(Term t)
 
 #include "rclause.h"
 
+#ifdef DEBUG
+static UInt  total_megaclause, total_released, nof_megaclauses;
+#endif
+
 void
 Yap_BuildMegaClause(PredEntry *ap)
 {
@@ -588,6 +596,11 @@ Yap_BuildMegaClause(PredEntry *ap)
     sz -= (UInt)NEXTOP((yamop *)NULL,p) + sizeof(StaticClause);
   }
   required = sz*ap->cs.p_code.NOfClauses+sizeof(MegaClause)+(UInt)NEXTOP((yamop *)NULL,l);
+#ifdef DEBUG
+  total_megaclause += required;
+  total_released += ap->cs.p_code.NOfClauses*(sz+sizeof(StaticClause));
+  nof_megaclauses++;
+#endif
   while (!(mcl = (MegaClause *)Yap_AllocCodeSpace(required))) {
     if (!Yap_growheap(FALSE, sizeof(consult_obj)*ConsultCapacity, NULL)) {
       /* just fail, the system will keep on going */
@@ -615,7 +628,6 @@ Yap_BuildMegaClause(PredEntry *ap)
     cl = cl->ClNext;
   }
   ptr->opc = Yap_opcode(_Ystop);
-  ptr->u.l.l = mcl->ClCode;
   cl =
     ClauseCodeToStaticClause(ap->cs.p_code.FirstClause);
   /* recover the space spent on the original clauses */
@@ -3921,11 +3933,19 @@ ClauseInfoForCode(yamop *codeptr, CODEADDR *startp, CODEADDR *endp) {
     case _put_unsafe:
       pc = NEXTOP(pc,yx);
       break;
+      /* instructions type xd */
+    case _get_float:
+    case _put_float:
+      pc = NEXTOP(pc,xd);
+      break;
+      /* instructions type xi */
+    case _get_longint:
+    case _put_longint:
+      pc = NEXTOP(pc,xi);
+      break;
       /* instructions type xc */
     case _get_atom:
     case _put_atom:
-    case _get_float:
-    case _get_longint:
     case _get_bigint:
       pc = NEXTOP(pc,xc);
       break;
@@ -4023,15 +4043,24 @@ ClauseInfoForCode(yamop *codeptr, CODEADDR *startp, CODEADDR *endp) {
     case _unify_l_n_voids:
       pc = NEXTOP(pc,os);
       break;
+      /* instructions type od */
+    case _unify_float:
+    case _unify_l_float:
+    case _unify_float_write:
+    case _unify_l_float_write:
+      pc = NEXTOP(pc,od);
+      break;
+    case _unify_longint:
+    case _unify_l_longint:
+    case _unify_longint_write:
+    case _unify_l_longint_write:
+      pc = NEXTOP(pc,oi);
+      break;
       /* instructions type oc */
     case _unify_atom_write:
     case _unify_atom:
     case _unify_l_atom_write:
     case _unify_l_atom:
-    case _unify_float:
-    case _unify_l_float:
-    case _unify_longint:
-    case _unify_l_longint:
     case _unify_bigint:
     case _unify_l_bigint:
       pc = NEXTOP(pc,oc);
@@ -4063,6 +4092,14 @@ ClauseInfoForCode(yamop *codeptr, CODEADDR *startp, CODEADDR *endp) {
    case _write_atom:
       pc = NEXTOP(pc,c);
       break;
+      /* instructions type d */
+   case _write_float:
+      pc = NEXTOP(pc,d);
+      break;
+      /* instructions type i */
+   case _write_longint:
+      pc = NEXTOP(pc,i);
+      break;
       /* instructions type sc */
    case _write_n_atoms:
       pc = NEXTOP(pc,sc);

C/compiler.c

@@ -11,8 +11,11 @@
 * File:		compiler.c						 *
 * comments:	Clause compiler						 *
 *									 *
-* Last rev:     $Date: 2006-08-01 13:14:17 $,$Author: vsc $						 *
+* Last rev:     $Date: 2006-09-20 20:03:51 $,$Author: vsc $						 *
 * $Log: not supported by cvs2svn $
+* Revision 1.79  2006/08/01 13:14:17  vsc
+* fix compilation of |
+*
 * Revision 1.78  2006/07/27 19:04:56  vsc
 * fix nasty overflows in and add some very preliminary support for very large
 * clauses with lots
@@ -560,12 +563,31 @@ c_arg(Int argno, Term t, unsigned int arity, unsigned int level, compiler_struct
 	    write_atom_op), (CELL) t, Zero, &cglobs->cint);
   } else  if (IsIntegerTerm(t) || IsFloatTerm(t) || IsBigIntTerm(t)) {
     if (!IsIntTerm(t)) {
+      if (IsFloatTerm(t)) {
+	if (level == 0)
+	  Yap_emit((cglobs->onhead ? get_float_op : put_float_op), t, argno, &cglobs->cint);
+	else
+	  Yap_emit((cglobs->onhead ? (argno == (Int)arity ? unify_last_float_op
+			  : unify_float_op) :
+		write_float_op), t, Zero, &cglobs->cint);
+      } else if (IsLongIntTerm(t)) {
+	if (level == 0)
+	  Yap_emit((cglobs->onhead ? get_longint_op : put_longint_op), t, argno, &cglobs->cint);
+	else
+	  Yap_emit((cglobs->onhead ? (argno == (Int)arity ? unify_last_longint_op
+			  : unify_longint_op) :
+		write_longint_op), t, Zero, &cglobs->cint);
+      } else {
 	/* we are taking a blob, that is a binary that is supposed to be
 	 guarded in the clause itself. Possible examples include
 	 floats, long ints, bignums, bitmaps.... */
 	CELL l1 = ++cglobs->labelno;
 	CELL *src = RepAppl(t);
 	PInstr *ocpc = cglobs->cint.cpc, *OCodeStart = cglobs->cint.CodeStart;
+	Int sz = sizeof(CELL)+
+	  sizeof(MP_INT)+
+	   ((((MP_INT *)(RepAppl(t)+1))->_mp_alloc)*sizeof(mp_limb_t));
+	CELL *dest;
 
 	/* use a special list to store the blobs */
 	cglobs->cint.cpc = cglobs->cint.icpc;
@@ -573,41 +595,9 @@ c_arg(Int argno, Term t, unsigned int arity, unsigned int level, compiler_struct
 		Yap_emit(align_float_op, Zero, Zero, &cglobs->cint);
 		}*/
 	Yap_emit(label_op, l1, Zero, &cglobs->cint);
-      if (IsFloatTerm(t)) {
+	dest = 
-	/* let us do floats first */
-	CELL *dest = 
-	  Yap_emit_extra_size(blob_op,
-			  (CELL)(SIZEOF_DOUBLE/SIZEOF_LONG_INT+1),
-			  (1+SIZEOF_DOUBLE/SIZEOF_LONG_INT)*CellSize, &cglobs->cint);
-	/* copy the float bit by bit */
-	dest[0] = src[0];
-	dest[1] = src[1];
-#if SIZEOF_DOUBLE == 2*SIZEOF_LONG_INT
-	dest[2] = src[2];
-#endif
-	/* note that we don't need to copy size info, unless we wanted
-	   to garbage collect clauses ;-) */
-	cglobs->cint.icpc = cglobs->cint.cpc;
-	if (cglobs->cint.BlobsStart == NULL)
-	  cglobs->cint.BlobsStart = cglobs->cint.CodeStart;
-	cglobs->cint.cpc = ocpc;
-	cglobs->cint.CodeStart = OCodeStart;
-	/* The argument to pass to the structure is now the label for
-	   where we are storing the blob */
-	if (level == 0)
-	  Yap_emit((cglobs->onhead ? get_float_op : put_float_op), l1, argno, &cglobs->cint);
-	else
-	  Yap_emit((cglobs->onhead ? (argno == (Int)arity ? unify_last_float_op
-			  : unify_float_op) :
-		write_float_op), l1, Zero, &cglobs->cint);
-#if USE_GMP
-      } else if (IsBigIntTerm(t)) {
-	/* next, let us do bigints */
-	Int sz = sizeof(CELL)+
-	  sizeof(MP_INT)+
-	   ((((MP_INT *)(RepAppl(t)+1))->_mp_alloc)*sizeof(mp_limb_t));
-	CELL *dest = 
 	  Yap_emit_extra_size(blob_op, sz/CellSize, sz, &cglobs->cint);
+
 	/* copy the bignum */
 	memcpy(dest, src, sz);
 	/* note that we don't need to copy size info, unless we wanted
@@ -625,27 +615,6 @@ c_arg(Int argno, Term t, unsigned int arity, unsigned int level, compiler_struct
 	  Yap_emit((cglobs->onhead ? (argno == (Int)arity ? unify_last_bigint_op
 			  : unify_bigint_op) :
 		write_bigint_op), l1, Zero, &cglobs->cint);
-#endif
-      } else {
-	/* for now, it's just a long int */
-	CELL *dest = 
-	  Yap_emit_extra_size(blob_op,
-			  2,
-			  2*CellSize, &cglobs->cint);
-	/* copy the long int in one fell swoop */
-	dest[0] = src[0];
-	dest[1] = src[1];
-	cglobs->cint.icpc = cglobs->cint.cpc;
-	if (cglobs->cint.BlobsStart == NULL)
-	  cglobs->cint.BlobsStart = cglobs->cint.CodeStart;
-	cglobs->cint.cpc = ocpc;
-	cglobs->cint.CodeStart = OCodeStart;
-	if (level == 0)
-	  Yap_emit((cglobs->onhead ? get_longint_op : put_longint_op), l1, argno, &cglobs->cint);
-	else
-	  Yap_emit((cglobs->onhead ? (argno == (Int)arity ? unify_last_longint_op
-			  : unify_longint_op) :
-		write_longint_op), l1, Zero, &cglobs->cint);
       }
       /* That's it folks! */
       return;

C/computils.c

@@ -11,8 +11,14 @@
 * File:		computils.c						 *
 * comments:	some useful routines for YAP's compiler			 *
 *									 *
-* Last rev:     $Date: 2005-12-05 17:16:10 $							 *
+* Last rev:     $Date: 2006-09-20 20:03:51 $							 *
 * $Log: not supported by cvs2svn $
+* Revision 1.29  2005/12/05 17:16:10  vsc
+* write_depth/3
+* overflow handlings and garbage collection
+* Several ipdates to CLPBN
+* dif/2 could be broken in the presence of attributed variables.
+*
 * Revision 1.28  2005/09/08 22:06:44  rslopes
 * BEAM for YAP update...
 *
@@ -487,6 +493,9 @@ ShowOp (char *f, struct PSEUDO *cpc)
 	    Yap_DebugErrorPutc ('\t');
 	    Yap_DebugPlWrite (MkIntTerm (rn & 1));
 	    break;
+	  case 'w':
+	    Yap_DebugPlWrite (arg);
+	    break;
 	  case 'o':
 	    Yap_DebugPlWrite ((Term) * cptr++);
 	  case 'c':
@@ -552,11 +561,11 @@ static char *opformat[] =
   "put_atom\t%a,%r",
   "get_num\t\t%n,%r",
   "put_num\t\t%n,%r",
-  "get_float\t\t%l,%r",
+  "get_float\t\t%w,%r",
-  "put_float\t\t%l,%r",
+  "put_float\t\t%w,%r",
   "align_float",
-  "get_longint\t\t%l,%r",
+  "get_longint\t\t%w,%r",
-  "put_longint\t\t%l,%r",
+  "put_longint\t\t%w,%r",
   "get_bigint\t\t%l,%r",
   "put_bigint\t\t%l,%r",
   "get_list\t%r",
@@ -572,10 +581,10 @@ static char *opformat[] =
   "write_atom\t%a",
   "unify_num\t%n",
   "write_num\t%n",
-  "unify_float\t%l",
+  "unify_float\t%w",
-  "write_float\t%l",
+  "write_float\t%w",
-  "unify_longint\t%l",
+  "unify_longint\t%w",
-  "write_longint\t%l",
+  "write_longint\t%w",
   "unify_bigint\t%l",
   "write_bigint\t%l",
   "unify_list",
@@ -640,8 +649,8 @@ static char *opformat[] =
   "unify_last_local\t%v",
   "unify_last_atom\t%a",
   "unify_last_num\t%n",
-  "unify_last_float\t%l",
+  "unify_last_float\t%w",
-  "unify_last_longint\t%l",
+  "unify_last_longint\t%w",
   "unify_last_bigint\t%l",
   "pvar_bitmap\t%l,%b",
   "pvar_live_regs\t%l,%b",

C/dbase.c

@@ -135,7 +135,6 @@ typedef struct idb_queue
 #define LARGE_IDB_LINK_TABLE 1
 
 /* traditionally, YAP used a link table to recover IDB terms*/
-#define IDB_LINK_TABLE 1
 #if LARGE_IDB_LINK_TABLE
 typedef BITS32 link_entry; 
 #define SIZEOF_LINK_ENTRY 4
@@ -143,15 +142,11 @@ typedef BITS32 link_entry;
 typedef BITS16 link_entry; 
 #define SIZEOF_LINK_ENTRY 2
 #endif
-/* a second alternative is to just use a tag */
-/*#define IDB_USE_MBIT 1*/
 
 /* These global variables are necessary to build the data base
    structure */
 typedef struct db_globs {
-#ifdef IDB_LINK_TABLE
   link_entry  *lr, *LinkAr;
-#endif
 /* we cannot call Error directly from within recorded(). These flags are used
    to delay for a while
 */
@@ -180,12 +175,7 @@ typedef table {
 #endif
 
 STATIC_PROTO(CELL *cpcells,(CELL *,CELL*,Int));
-#ifdef IDB_LINK_TABLE
 STATIC_PROTO(void linkblk,(link_entry *,CELL *,CELL));
-#endif
-#ifdef IDB_USE_MBIT
-STATIC_PROTO(CELL *linkcells,(CELL *,Int));
-#endif
 STATIC_PROTO(Int cmpclls,(CELL *,CELL *,Int));
 STATIC_PROTO(Prop FindDBProp,(AtomEntry *, int, unsigned int, Term));
 STATIC_PROTO(CELL  CalcKey, (Term));
@@ -199,9 +189,7 @@ STATIC_PROTO(DBRef  record, (int, Term, Term, Term));
 STATIC_PROTO(DBRef  check_if_cons, (DBRef, Term));
 STATIC_PROTO(DBRef  check_if_var, (DBRef));
 STATIC_PROTO(DBRef  check_if_wvars, (DBRef, unsigned int, CELL *));
-#ifdef IDB_LINK_TABLE
 STATIC_PROTO(int  scheckcells, (int, CELL *, CELL *, link_entry *, CELL));
-#endif
 STATIC_PROTO(DBRef  check_if_nvars, (DBRef, unsigned int, CELL *, struct db_globs *));
 STATIC_PROTO(Int  p_rcda, (void));
 STATIC_PROTO(Int  p_rcdap, (void));
@@ -350,7 +338,6 @@ static void remove_from_table() {
 }
 #endif
 
-#ifdef IDB_LINK_TABLE
 inline static CELL *cpcells(CELL *to, CELL *from, Int n)
 {
 #if HAVE_MEMMOVE
@@ -374,37 +361,6 @@ static void linkblk(link_entry *r, CELL *c, CELL offs)
     c[p] = AdjustIDBPtr(t, offs);
   }
 }
-#endif
-
-#ifdef IDB_USE_MBIT
-inline static CELL *cpcells(register CELL *to, register CELL *from, Int n)
-{
-  CELL *last = to + n;
-  register CELL off = ((CELL)to)-MBIT;
-  while (to <= last) {
-    register d0 = *from++;
-    if (MARKED(d0)) 
-      *to++ = AdjustIDBPtr(d0, off);
-    else
-      *to++ = d0;
-  }
-  return(to);
-}
-
-static CELL *linkcells(register CELL *to, Int n)
-{
-  CELL *last = to + n;
-  register CELL off = ((CELL)to)-MBIT;
-  while(to <= last) {
-    register d0 = *to++;
-    if (MARKED(d0)) 
-      to[-1] = AdjustIDBPtr(d0, off);
-  }
-  return(to);
-}
-
-
-#endif
 
 static Int cmpclls(CELL *a,CELL *b,Int n)
 {
@@ -417,12 +373,7 @@ static Int cmpclls(CELL *a,CELL *b,Int n)
 #if !THREADS
 int Yap_DBTrailOverflow()
 {
-#ifdef IDB_USE_MBIT
-  return(FALSE);
-#endif
-#ifdef IDB_LINK_TABLE
   return((CELL *)s_dbg->lr > (CELL *)s_dbg->tofref - 2048);
-#endif
 }
 #endif
 
@@ -725,10 +676,8 @@ static CELL *MkDBTerm(register CELL *pt0, register CELL *pt0_end,
 	continue;
       }
 #endif
-#ifdef IDB_LINK_TABLE
       db_check_trail(dbg->lr+1);
       *dbg->lr++ = ToSmall((CELL)(StoPoint)-(CELL)(tbase));
-#endif
       f = (Functor)(*ap2);
       if (IsExtensionFunctor(f)) {
 	switch((CELL)f) {
@@ -738,9 +687,7 @@ static CELL *MkDBTerm(register CELL *pt0, register CELL *pt0_end,
 	    /* store now the correct entry */
 	    dbentry = DBRefOfTerm(d0);
 	    *StoPoint++ = d0;
-#ifdef IDB_LINK_TABLE
 	    dbg->lr--;
-#endif
 	    if (dbentry->Flags & LogUpdMask) {
 	      LogUpdClause *cl = (LogUpdClause *)dbentry;
 
@@ -755,11 +702,7 @@ static CELL *MkDBTerm(register CELL *pt0, register CELL *pt0_end,
 	    continue;
 	  }
 	case (CELL)FunctorLongInt:
-#ifdef IDB_USE_MBIT
-	  *StoPoint++ = AbsAppl(CodeMax)|MBIT;
-#else
 	  *StoPoint++ = AbsAppl(CodeMax);
-#endif
 	  CheckDBOverflow(3);
 	  CodeMax = copy_long_int(CodeMax, ap2);
 	  ++pt0;
@@ -768,11 +711,7 @@ static CELL *MkDBTerm(register CELL *pt0, register CELL *pt0_end,
 	case (CELL)FunctorBigInt:
 	  CheckDBOverflow(2+Yap_SizeOfBigInt(d0));
 	  /* first thing, store a link to the list before we move on */
-#ifdef IDB_USE_MBIT
-	  *StoPoint++ = AbsAppl(CodeMax)|MBIT;
-#else
 	  *StoPoint++ = AbsAppl(CodeMax);
-#endif
 	  CodeMax = copy_big_int(CodeMax, ap2);
 	  ++pt0;
 	  continue;
@@ -783,11 +722,7 @@ static CELL *MkDBTerm(register CELL *pt0, register CELL *pt0_end,
 
 	    CheckDBOverflow(4);
 	    /* first thing, store a link to the list before we move on */
-#ifdef IDB_USE_MBIT
-	    *StoPoint++ = AbsAppl(st)|MBIT;
-#else
 	    *StoPoint++ = AbsAppl(st);
-#endif
 	    CodeMax = copy_double(CodeMax, ap2);
 	    ++pt0;
 	    continue;
@@ -795,11 +730,7 @@ static CELL *MkDBTerm(register CELL *pt0, register CELL *pt0_end,
 	}
       }
       /* first thing, store a link to the list before we move on */
-#ifdef IDB_USE_MBIT
-      *StoPoint++ = AbsAppl(CodeMax)|MBIT;
-#else
       *StoPoint++ = AbsAppl(CodeMax);
-#endif
       /* next, postpone analysis to the rest of the current list */
 #ifdef RATIONAL_TREES
       to_visit[0] = pt0+1;
@@ -832,7 +763,6 @@ static CELL *MkDBTerm(register CELL *pt0, register CELL *pt0_end,
     }
     else if (IsPairTerm(d0)) {
       /* we will need to link afterwards */
-#ifdef RATIONAL_TREES
       CELL *ap2 = RepPair(d0);
       if (ap2 >= tbase && ap2 < StoPoint) {
 	*StoPoint++ = d0;
@@ -841,17 +771,60 @@ static CELL *MkDBTerm(register CELL *pt0, register CELL *pt0_end,
 	++pt0;
 	continue;
       }
-#endif
+      if (IsAtomOrIntTerm(Deref(ap2[0])) &&
-#ifdef IDB_LINK_TABLE
+	  IsPairTerm(Deref(ap2[1]))) {
+	/* shortcut for [1,2,3,4,5] */
+	Term tt = Deref(ap2[1]);
+	Term th = Deref(ap2[0]);
+	Int direction = RepPair(tt)-ap2;
+	CELL *OldStoPoint;
+	CELL *lp;
+
+	if (direction < 0)
+	  direction = -1;
+	else
+	  direction = 1;
 	db_check_trail(dbg->lr+1);
 	*dbg->lr++ = ToSmall((CELL)(StoPoint)-(CELL)(tbase));
-#endif
-#ifdef IDB_USE_MBIT
-      *StoPoint++ =
-	AbsPair(CodeMax)|MBIT;
-#else
 	*StoPoint++ = AbsPair(CodeMax);
-#endif
+	OldStoPoint = StoPoint;
+	do {
+	  lp =  RepPair(tt);
+	  
+	  if (lp >= tbase && lp < StoPoint) {
+	    break;
+	  }
+	  CheckDBOverflow(2);
+	  CodeMax[0] = th;
+	  db_check_trail(dbg->lr+1);
+	  *dbg->lr++ = ToSmall((CELL)(CodeMax+1)-(CELL)(tbase));
+	  CodeMax[1] = AbsPair(CodeMax+2);
+	  CodeMax+=2;
+	  th = Deref(lp[0]);
+	  tt = Deref(lp[1]);
+	} while (IsAtomOrIntTerm(th) &&
+		 IsPairTerm(tt) &&
+		 /* have same direction to avoid infinite terms X = [a|X] */
+		 (RepPair(tt)-lp)*direction > 0);
+	if (lp >= tbase && lp < StoPoint) {
+	  CodeMax[-1] = tt;
+	  break;
+	}
+	if (IsAtomOrIntTerm(th) && IsAtomOrIntTerm(tt)) {
+	  CheckDBOverflow(2);
+	  CodeMax[0] = th;
+	  CodeMax[1] = tt;
+	  CodeMax+=2;
+	  ++pt0;
+	  continue;
+	}
+	d0 = AbsPair(lp);
+	StoPoint = OldStoPoint;
+      } else {
+	 db_check_trail(dbg->lr+1);
+	*dbg->lr++ = ToSmall((CELL)(StoPoint)-(CELL)(tbase));
+	*StoPoint++ = AbsPair(CodeMax);
+      }
       /* next, postpone analysis to the rest of the current list */
 #ifdef RATIONAL_TREES
       to_visit[0] = pt0+1;
@@ -918,20 +891,12 @@ static CELL *MkDBTerm(register CELL *pt0, register CELL *pt0_end,
 #if SBA
 	/* the copy we keep will be an empty variable   */
 	*StoPoint++ = 0;
-#else
-#ifdef IDB_USE_MBIT
-	/* say we've seen the variable, and make it point to its
-	   offset */
-	/* the copy we keep will be the current displacement   */
-	*StoPoint = ((CELL)StoPoint | MBIT);
-	StoPoint++;
 #else
 	/* the copy we keep will be the current displacement   */
 	*StoPoint = (CELL)StoPoint;
 	StoPoint++;
 	db_check_trail(dbg->lr+1);
 	*dbg->lr++ = ToSmall(displacement);
-#endif
 #endif
 	/* indicate we found variables */
 	vars_found++;
@@ -960,16 +925,10 @@ static CELL *MkDBTerm(register CELL *pt0, register CELL *pt0_end,
 	continue;
       } else  {
 	/* references need to be offset at read time */
-#ifdef IDB_LINK_TABLE
 	db_check_trail(dbg->lr+1);
 	*dbg->lr++ = ToSmall(displacement);
-#endif
 	/* store the offset */
-#ifdef IDB_USE_MBIT
-	*StoPoint = d0 | MBIT;
-#else
 	*StoPoint = d0;
-#endif
 	StoPoint++;
 	continue;
       }
@@ -1192,8 +1151,6 @@ check_if_wvars(DBRef p, unsigned int NOfCells, CELL *BTptr)
   return (NIL);
 }
 
-#ifdef IDB_LINK_TABLE
-
 static int 
 scheckcells(int NOfCells, register CELL *m1, register CELL *m2, link_entry *lp, register CELL bp)
 {
@@ -1226,7 +1183,6 @@ scheckcells(int NOfCells, register CELL *m1, register CELL *m2, link_entry *lp,
   }
   return (TRUE);
 }
-#endif
 
 /*
  * the cousin of the previous, but with things a bit more sophisticated.
@@ -1244,12 +1200,7 @@ check_if_nvars(DBRef p, unsigned int NOfCells, CELL *BTptr, struct db_globs *dbg
     if (p == NIL)
       return (p);
     memptr = CellPtr(p->DBT.Contents);
-#ifdef IDB_LINK_TABLE
     if (scheckcells(NOfCells, memptr, BTptr, dbg->LinkAr, Unsigned(p->DBT.Contents-1)))
-#else
-      if (NOfCells == *memptr++
-	  && cmpclls(memptr, BTptr, NOfCells))
-#endif
 	return (p);
       else
 	p = NextDBRef(p);
@@ -1403,9 +1354,7 @@ CreateDBStruct(Term Tm, DBProp p, int InFlag, int *pstat, UInt extra_size, struc
 {
   Register Term   tt, *nar = NIL;
   SMALLUNSGN      flag;
-#ifdef IDB_LINK_TABLE
   int NOfLinks = 0;
-#endif
   /* place DBRefs in ConsultStack */
   DBRef    *TmpRefBase = (DBRef *)Yap_TrailTop;
   CELL	   *CodeAbs;	/* how much code did we find	 */
@@ -1468,9 +1417,7 @@ CreateDBStruct(Term Tm, DBProp p, int InFlag, int *pstat, UInt extra_size, struc
 	return NULL;
     }
     ntp0 = ppt0->Contents;
-#ifdef IDB_LINK_TABLE
     dbg->lr = dbg->LinkAr = (link_entry *)TR;
-#endif
 #ifdef COROUTINING
     /* attachment */ 
     if (IsVarTerm(Tm)) {
@@ -1544,10 +1491,8 @@ CreateDBStruct(Term Tm, DBProp p, int InFlag, int *pstat, UInt extra_size, struc
       return (NULL);	/* Error Situation */
     }
     NOfCells = ntp - ntp0;	/* End Of Code Info */
-#ifdef IDB_LINK_TABLE
     *dbg->lr++ = 0;
     NOfLinks = (dbg->lr - dbg->LinkAr);
-#endif
     if (vars_found || InFlag & InQueue) {
 
       /*
@@ -1555,7 +1500,6 @@ CreateDBStruct(Term Tm, DBProp p, int InFlag, int *pstat, UInt extra_size, struc
        * for the number of links 
        */
       flag = DBComplex;
-#ifdef IDB_LINK_TABLE
       CodeAbs += CellPtr(dbg->lr) - CellPtr(dbg->LinkAr);
       if ((CELL *)((char *)ntp0+(CELL)CodeAbs) > AuxSp) {
 	Yap_Error_Size = (UInt)DBLength(CodeAbs);
@@ -1563,7 +1507,6 @@ CreateDBStruct(Term Tm, DBProp p, int InFlag, int *pstat, UInt extra_size, struc
 	Yap_ReleasePreAllocCodeSpace((ADDR)pp0);
 	return(NULL);
       }
-#endif
       if ((InFlag & MkIfNot) && (dbg->found_one = check_if_wvars(p->First, NOfCells, ntp0))) {
 	Yap_ReleasePreAllocCodeSpace((ADDR)pp0);
 	return dbg->found_one;
@@ -1585,13 +1528,11 @@ CreateDBStruct(Term Tm, DBProp p, int InFlag, int *pstat, UInt extra_size, struc
       }
       flag |= DBWithRefs;
     }
-#ifdef IDB_LINK_TABLE
 #if SIZEOF_LINK_ENTRY==2
     if (Unsigned(CodeAbs) >= 0x40000) {
       Yap_ReleasePreAllocCodeSpace((ADDR)pp0);
       return generate_dberror_msg(SYSTEM_ERROR, 0, "trying to store term larger than 256KB");
     }
-#endif
 #endif
     if (p == NULL) {
       ADDR ptr = Yap_AllocCodeSpace((CELL)CodeAbs+extra_size+sizeof(DBTerm));
@@ -1614,9 +1555,7 @@ CreateDBStruct(Term Tm, DBProp p, int InFlag, int *pstat, UInt extra_size, struc
       ppt = &(pp->DBT);
     }
     if (flag & DBComplex) {
-#ifdef IDB_LINK_TABLE
       link_entry         *woar;
-#endif /* IDB_LINK_TABLE */
 
       ppt->NOfCells = NOfCells;
 #ifdef COROUTINING
@@ -1624,18 +1563,10 @@ CreateDBStruct(Term Tm, DBProp p, int InFlag, int *pstat, UInt extra_size, struc
 #endif
       if (pp0 != pp) {
 	nar = ppt->Contents;
-#ifdef IDB_LINK_TABLE
 	nar = (Term *) cpcells(CellPtr(nar), ntp0, Unsigned(NOfCells));
-#endif
-#ifdef IDB_USE_MBIT
-	memcpy((void *)nar, (const void *)ntp0,
-	       (size_t)((NOfCells+1)*sizeof(CELL)));
-	nar += NOfCells+1;
-#endif
       } else {
 	nar = ppt->Contents + Unsigned(NOfCells);
       }
-#ifdef IDB_LINK_TABLE
       woar = (link_entry *)nar;
       memcpy((void *)woar,(const void *)dbg->LinkAr,(size_t)(NOfLinks*sizeof(link_entry)));
       woar += NOfLinks;
@@ -1649,26 +1580,17 @@ CreateDBStruct(Term Tm, DBProp p, int InFlag, int *pstat, UInt extra_size, struc
 #endif
 #endif
       nar = (Term *) (woar);
-#endif
       *pstat = TRUE;
     } else if (flag & DBNoVars) {
       if (pp0 != pp) {
 	nar = (Term *) cpcells(CellPtr(ppt->Contents), ntp0, Unsigned(NOfCells));
       } else {
-#ifdef IDB_LINK_TABLE
 	nar = ppt->Contents + Unsigned(NOfCells);
-#endif
-#ifdef IDB_USE_MBIT
-	/* we still need to link */
-	nar = (Term *) linkcells(ntp0, NOfCells);
-#endif
       }
       ppt->NOfCells = NOfCells;
     }
     if (ppt != ppt0) {
-#ifdef IDB_LINK_TABLE
       linkblk(dbg->LinkAr, CellPtr(ppt->Contents-1), (CELL)ppt-(CELL)ppt0);
-#endif
       ppt->Entry = AdjustIDBPtr(tt,(CELL)ppt-(CELL)ppt0);
 #ifdef COROUTINING
       if (attachments)
@@ -2354,7 +2276,6 @@ p_still_variant(void)
       return IsVarTerm(t2);
     dbt = &(dbr->DBT);
   }
-#ifdef IDB_LINK_TABLE
   /*
     we checked the trail, so we are sure only variables in the new term
     were bound
@@ -2377,9 +2298,6 @@ p_still_variant(void)
       }
     }
   }
-#else /* IDB_LINK_TABLE */
-  not IMPLEMENTED;
-#endif
   return TRUE;
 }
 
@@ -2517,12 +2435,10 @@ GetDBTerm(DBTerm *DBSP)
     HeapPtr = cpcells(HOld, pt, NOf);
     pt += HeapPtr - HOld;
     H = HeapPtr;
-#ifdef IDB_LINK_TABLE
     {
       link_entry *lp = (link_entry *)pt;
       linkblk(lp, HOld-1, (CELL)HOld-(CELL)(DBSP->Contents));
     }
-#endif
 #ifdef COROUTINING
     if (DBSP->attachments != 0L)  {
       if (!copy_attachments((CELL *)AdjustIDBPtr(DBSP->attachments,(CELL)HOld-(CELL)(DBSP->Contents)))) {

C/globals.c

@@ -709,6 +709,7 @@ CopyTermToArena(Term t, Term arena, UInt arity, Term *newarena, Term *att_arenap
     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)) {

C/grow.c

@@ -722,17 +722,23 @@ fix_compiler_instructions(PInstr *pcpc)
     case fetch_args_vv_op:
       pcpc->rnd1 = GlobalAdjust(pcpc->rnd1);
       break;
+    case get_float_op:
+    case put_float_op:
+    case get_longint_op:
+    case put_longint_op:
+    case unify_float_op:
+    case unify_last_float_op:
+    case write_float_op:
+      /* floats might be in the global */
+      pcpc->rnd1 = AdjustAppl(pcpc->rnd1);
+      break;
       /* hopefully nothing to do */
     case nop_op:
     case get_atom_op:
     case put_atom_op:
     case get_num_op:
     case put_num_op:
-    case get_float_op:
-    case put_float_op:
     case align_float_op:
-    case get_longint_op:
-    case put_longint_op:
     case get_bigint_op:
     case put_bigint_op:
     case get_list_op:
@@ -745,9 +751,6 @@ fix_compiler_instructions(PInstr *pcpc)
     case unify_num_op:
     case unify_last_num_op:
     case write_num_op:
-    case unify_float_op:
-    case unify_last_float_op:
-    case write_float_op:
     case unify_longint_op:
     case unify_last_longint_op:
     case write_longint_op:

C/index.c

@@ -11,8 +11,13 @@
 * File:		index.c							 *
 * comments:	Indexing a Prolog predicate				 *
 *									 *
-* Last rev:     $Date: 2006-05-16 18:37:30 $,$Author: vsc $						 *
+* Last rev:     $Date: 2006-09-20 20:03:51 $,$Author: vsc $						 *
 * $Log: not supported by cvs2svn $
+* Revision 1.168  2006/05/16 18:37:30  vsc
+* WIN32 fixes
+* compiler bug fixes
+* extend interface
+*
 * Revision 1.167  2006/05/02 16:44:11  vsc
 * avoid uninitialised memory at overflow.
 *
@@ -1004,11 +1009,19 @@ has_cut(yamop *pc)
     case _put_unsafe:
       pc = NEXTOP(pc,yx);
       break;
+      /* instructions type xd */
+    case _get_float:
+    case _put_float:
+      pc = NEXTOP(pc,xd);
+      break;
+      /* instructions type xi */
+    case _get_longint:
+    case _put_longint:
+      pc = NEXTOP(pc,xi);
+      break;
       /* instructions type xc */
     case _get_atom:
     case _put_atom:
-    case _get_float:
-    case _get_longint:
     case _get_bigint:
       pc = NEXTOP(pc,xc);
       break;
@@ -1106,15 +1119,33 @@ has_cut(yamop *pc)
     case _unify_l_n_voids:
       pc = NEXTOP(pc,os);
       break;
+      /* instructions type od */
+    case _unify_float:
+    case _unify_l_float:
+    case _unify_float_write:
+    case _unify_l_float_write:
+      pc = NEXTOP(pc,od);
+      break;
+      /* instructions type d */
+    case _write_float:
+      pc = NEXTOP(pc,d);
+      break;
+      /* instructions type oi */
+    case _unify_longint:
+    case _unify_l_longint:
+    case _unify_longint_write:
+    case _unify_l_longint_write:
+      pc = NEXTOP(pc,oi);
+      break;
+      /* instructions type i */
+    case _write_longint:
+      pc = NEXTOP(pc,i);
+      break;
       /* instructions type oc */
     case _unify_atom_write:
     case _unify_atom:
     case _unify_l_atom_write:
     case _unify_l_atom:
-    case _unify_float:
-    case _unify_l_float:
-    case _unify_longint:
-    case _unify_l_longint:
     case _unify_bigint:
     case _unify_l_bigint:
       pc = NEXTOP(pc,oc);
@@ -1796,21 +1827,21 @@ add_info(ClauseDef *clause, UInt regno)
       }
       break;
     case _get_float:
-      if (regcopy_in(myregs, nofregs, cl->u.xc.x)) {
+      if (regcopy_in(myregs, nofregs, cl->u.xd.x)) {
-	clause->u.t_ptr = cl->u.xc.c;
+	clause->u.t_ptr = AbsAppl(cl->u.xd.d);
 	clause->Tag = AbsAppl((CELL *)FunctorDouble);
 	return;
       } else {
-	cl = NEXTOP(cl,xc);
+	cl = NEXTOP(cl,xd);
       }
       break;
     case _get_longint:
-      if (regcopy_in(myregs, nofregs, cl->u.xc.x)) {
+      if (regcopy_in(myregs, nofregs, cl->u.xi.x)) {
-	clause->u.t_ptr = cl->u.xc.c;
+	clause->u.t_ptr = AbsAppl(cl->u.xi.i);
 	clause->Tag = AbsAppl((CELL *)FunctorLongInt);
 	return;
       } else {
-	cl = NEXTOP(cl,xc);
+	cl = NEXTOP(cl,xi);
       }
       break;
    case _get_bigint:
@@ -1864,6 +1895,26 @@ add_info(ClauseDef *clause, UInt regno)
 	cl = NEXTOP(cl,xc);
       }
       break;
+    case _put_float:
+      if (regcopy_in(myregs, nofregs, cl->u.xd.x) &&
+	  (nofregs = delete_regcopy(myregs, nofregs, cl->u.xd.x)) == 0 &&
+	  !ycopy) {
+	clause->Tag = (CELL)NULL;
+	return;
+      } else {
+	cl = NEXTOP(cl,xd);
+      }
+      break;
+    case _put_longint:
+      if (regcopy_in(myregs, nofregs, cl->u.xi.x) &&
+	  (nofregs = delete_regcopy(myregs, nofregs, cl->u.xi.x)) == 0 &&
+	  !ycopy) {
+	clause->Tag = (CELL)NULL;
+	return;
+      } else {
+	cl = NEXTOP(cl,xi);
+      }
+      break;
     case _get_struct:
       if (regcopy_in(myregs, nofregs, cl->u.xf.x)) {
 	clause->u.WorkPC = NEXTOP(cl,xf);
@@ -2023,11 +2074,21 @@ add_info(ClauseDef *clause, UInt regno)
       break;      
     case _unify_float:
     case _unify_l_float:
-      cl = NEXTOP(cl,oc);
+    case _unify_float_write:
+    case _unify_l_float_write:
+      cl = NEXTOP(cl,od);
+      break;      
+    case _write_float:
+      cl = NEXTOP(cl,d);
       break;      
     case _unify_longint:
+    case _unify_longint_write:
     case _unify_l_longint:
-      cl = NEXTOP(cl,oc);
+    case _unify_l_longint_write:
+      cl = NEXTOP(cl,oi);
+      break;      
+    case _write_longint:
+      cl = NEXTOP(cl,i);
       break;      
     case _unify_bigint:
     case _unify_l_bigint:
@@ -2507,21 +2568,21 @@ add_head_info(ClauseDef *clause, UInt regno)
       }
       break;
     case _get_float:
-      if (cl->u.xc.x == iarg) {
+      if (cl->u.xd.x == iarg) {
-	clause->u.t_ptr = cl->u.xc.c;
+	clause->u.t_ptr = AbsAppl(cl->u.xd.d);
 	clause->Tag = AbsAppl((CELL *)FunctorDouble);
 	return;
       } else {
-	cl = NEXTOP(cl,xc);
+	cl = NEXTOP(cl,xd);
       }
       break;
     case _get_longint:
-      if (cl->u.xc.x == iarg) {
+      if (cl->u.xi.x == iarg) {
-	clause->u.t_ptr = cl->u.xc.c;
+	clause->u.t_ptr = AbsAppl(cl->u.xi.i);
 	clause->Tag = AbsAppl((CELL *)FunctorLongInt);
 	return;
       } else {
-	cl = NEXTOP(cl,xc);
+	cl = NEXTOP(cl,xi);
       }
       break;
    case _get_bigint:
@@ -2645,11 +2706,21 @@ add_head_info(ClauseDef *clause, UInt regno)
       break;      
     case _unify_float:
     case _unify_l_float:
-      cl = NEXTOP(cl,oc);
+    case _unify_float_write:
+    case _unify_l_float_write:
+      cl = NEXTOP(cl,od);
+      break;      
+    case _write_float:
+      cl = NEXTOP(cl,d);
       break;      
     case _unify_longint:
+    case _unify_longint_write:
     case _unify_l_longint:
-      cl = NEXTOP(cl,oc);
+    case _unify_l_longint_write:
+      cl = NEXTOP(cl,oi);
+      break;      
+    case _write_longint:
+      cl = NEXTOP(cl,i);
       break;      
     case _unify_bigint:
     case _unify_l_bigint:
@@ -2901,25 +2972,29 @@ add_arg_info(ClauseDef *clause, PredEntry *ap, UInt argno)
     case _unify_l_atom_write:
       cl = NEXTOP(cl,oc);
       break;      
+    case _unify_float_write:
+    case _unify_l_float_write:
+      cl = NEXTOP(cl,od);
+      break;      
     case _unify_float:
     case _unify_l_float:
       if (argno == 1) {
 	clause->Tag = AbsAppl((CELL *)FunctorDouble);
-	clause->u.t_ptr = cl->u.oc.c;
+	clause->u.t_ptr = AbsAppl(cl->u.od.d);
 	return;
       }
-      cl = NEXTOP(cl,oc);
+      cl = NEXTOP(cl,od);
       argno--;
       break;
     case _unify_longint:
     case _unify_l_longint:
       if (argno == 1) {
 	clause->Tag = AbsAppl((CELL *)FunctorLongInt);
-	clause->u.t_ptr = cl->u.oc.c;
+	clause->u.t_ptr = AbsAppl(cl->u.oi.i);
 	return;
       }
       argno--;
-      cl = NEXTOP(cl,oc);
+      cl = NEXTOP(cl,oi);
       break;
     case _unify_bigint:
     case _unify_l_bigint:
@@ -3073,6 +3148,10 @@ skip_to_arg(ClauseDef *clause, PredEntry *ap, UInt argno, int at_point)
     case _unify_l_atom_write:
       cl = NEXTOP(cl,oc);
       break;      
+    case _unify_float_write:
+    case _unify_l_float_write:
+      cl = NEXTOP(cl,od);
+      break;      
     case _unify_l_struc_write:
     case _unify_struct_write:
       cl = NEXTOP(cl,of);
@@ -3107,6 +3186,9 @@ valid_instructions(yamop *end, yamop *cl)
     case _get_atom:
       cl = NEXTOP(cl,xc);
       break;
+    case _get_float:
+      cl = NEXTOP(cl,xd);
+      break;
     case _get_2atoms:
       cl = NEXTOP(cl,cc);
       break;
@@ -3139,6 +3221,12 @@ valid_instructions(yamop *end, yamop *cl)
     case _unify_l_atom_write:
       cl = NEXTOP(cl,oc);
       break;
+    case _unify_float:
+    case _unify_l_float:
+    case _unify_float_write:
+    case _unify_l_float_write:
+      cl = NEXTOP(cl,od);
+      break;
     case _unify_struct:
     case _unify_struct_write:
     case _unify_l_struc:
@@ -4375,7 +4463,12 @@ do_blob_index(ClauseDef *min, ClauseDef* max, Term t, struct intermediates *cint
     if (cl->u.t_ptr == (CELL)NULL) { /* check whether it is a builtin */
       cl->Tag = Zero;
     } else {
-      cl->Tag = MkIntTerm(RepAppl(cl->u.t_ptr)[1]);
+      CELL *pt = RepAppl(cl->u.t_ptr);
+#if SIZEOF_DOUBLE == 2*SIZEOF_LONG_INT
+      cl->Tag = MkIntTerm(pt[1]^pt[2]);
+#else
+      cl->Tag = MkIntTerm(pt[1]);
+#endif
     }
     cl++;
   }
@@ -4582,8 +4675,15 @@ install_clause(ClauseDef *cls, PredEntry *ap, istack_entry *stack)
 	  if (f == FunctorDBRef) {
 	    if (cls->u.t_ptr != sp->extra) break;
 	  } else {
-	    Term t = MkIntTerm(RepAppl(sp->extra)[1]),
+	    CELL *pt = RepAppl(sp->extra);
-	      t1 = MkIntTerm(RepAppl(cls->u.t_ptr)[1]);
+	    CELL *pt1 = RepAppl(cls->u.t_ptr);
+#if SIZEOF_DOUBLE == 2*SIZEOF_LONG_INT
+	    Term t = MkIntTerm(pt[1]^pt[2]),
+	      t1 = MkIntTerm(pt1[1]^pt1[2]);
+#else
+	    Term t = MkIntTerm(pt[1]),
+	      t1 = MkIntTerm(pt1[1]);
+#endif
 	      if (t != t1) break;
 	  }
 	}
@@ -4735,8 +4835,15 @@ install_log_upd_clause(ClauseDef *cls, PredEntry *ap, istack_entry *stack)
 	  if (f == FunctorDBRef) {
 	    if (cls->u.t_ptr != sp->extra) break;
 	  } else {
-	    Term t = MkIntTerm(RepAppl(sp->extra)[1]),
+	    CELL *pt = RepAppl(sp->extra);
-	      t1 = MkIntTerm(RepAppl(cls->u.t_ptr)[1]);
+	    CELL *pt1 = RepAppl(cls->u.t_ptr);
+#if SIZEOF_DOUBLE == 2*SIZEOF_LONG_INT
+	    Term t = MkIntTerm(pt[1]^pt[2]),
+	      t1 = MkIntTerm(pt1[1]^pt1[2]);
+#else
+	    Term t = MkIntTerm(pt[1]),
+	      t1 = MkIntTerm(pt1[1]);
+#endif
 	    if (t != t1) break;
 	  }
 	}
@@ -5153,7 +5260,11 @@ expand_index(struct intermediates *cint) {
       ipc = NEXTOP(ipc,e);
       break;
     case _index_blob:
+#if SIZEOF_DOUBLE == 2*SIZEOF_LONG_INT
+      t = MkIntTerm(s_reg[0]^s_reg[1]);
+#else
       t = MkIntTerm(s_reg[0]);
+#endif
       sp[-1].extra = AbsAppl(s_reg-1);
       s_reg = NULL;
       ipc = NEXTOP(ipc,e);
@@ -5573,7 +5684,7 @@ ExpandIndex(PredEntry *ap, int ExtraArgs) {
 	Atom At = NameOfFunctor(f);
 	Yap_plwrite(MkAtomTerm(At), Yap_DebugPutc, 0);
 	Yap_DebugPutc(Yap_c_error_stream,'/');
-	Yap_plwrite(MkIntTerm(ArityOfFunctor(f)), Yap_DebugPutc, 0);
+	Yap_plwrite(MkIntegerTerm(ArityOfFunctor(f)), Yap_DebugPutc, 0);
       }
     } else {
       if (ap->ArityOfPE == 0) {
@@ -5584,7 +5695,7 @@ ExpandIndex(PredEntry *ap, int ExtraArgs) {
 	Atom At = NameOfFunctor(f);
 	Yap_plwrite(MkAtomTerm(At), Yap_DebugPutc, 0);
 	Yap_DebugPutc(Yap_c_error_stream,'/');
-	Yap_plwrite(MkIntTerm(ArityOfFunctor(f)), Yap_DebugPutc, 0);
+	Yap_plwrite(MkIntegerTerm(ArityOfFunctor(f)), Yap_DebugPutc, 0);
       }
     }
     Yap_DebugPutc(Yap_c_error_stream,'\n');
@@ -7317,7 +7428,14 @@ add_to_index(struct intermediates *cint, int first, path_stack_entry *sp, Clause
       ipc = NEXTOP(ipc,e);
       break;
     case _index_blob:
-      cls->Tag = MkIntTerm(RepAppl(cls->u.t_ptr)[1]);
+      {
+	CELL *pt = RepAppl(cls->u.t_ptr);
+#if SIZEOF_DOUBLE == 2*SIZEOF_LONG_INT
+	cls->Tag = MkIntTerm(pt[1]^pt[2]);
+#else
+	cls->Tag = MkIntTerm(pt[1]);
+#endif
+      }
       ipc = NEXTOP(ipc,e);
       break;
     case _switch_on_cons:
@@ -7437,7 +7555,7 @@ Yap_AddClauseToIndex(PredEntry *ap, yamop *beg, int first) {
 	Atom At = NameOfFunctor(f);
 	Yap_plwrite(MkAtomTerm(At), Yap_DebugPutc, 0);
 	Yap_DebugPutc(Yap_c_error_stream,'/');
-	Yap_plwrite(MkIntTerm(ArityOfFunctor(f)), Yap_DebugPutc, 0);
+	Yap_plwrite(MkIntegerTerm(ArityOfFunctor(f)), Yap_DebugPutc, 0);
       }
     } else {
       if (ap->ArityOfPE == 0) {
@@ -7448,7 +7566,7 @@ Yap_AddClauseToIndex(PredEntry *ap, yamop *beg, int first) {
 	Atom At = NameOfFunctor(f);
 	Yap_plwrite(MkAtomTerm(At), Yap_DebugPutc, 0);
 	Yap_DebugPutc(Yap_c_error_stream,'/');
-	Yap_plwrite(MkIntTerm(ArityOfFunctor(f)), Yap_DebugPutc, 0);
+	Yap_plwrite(MkIntegerTerm(ArityOfFunctor(f)), Yap_DebugPutc, 0);
       }
     }
     Yap_DebugPutc(Yap_c_error_stream,'\n');
@@ -7787,7 +7905,14 @@ remove_from_index(PredEntry *ap, path_stack_entry *sp, ClauseDef *cls, yamop *bg
       ipc = NEXTOP(ipc,e);
       break;
     case _index_blob:
-      cls->Tag = MkIntTerm(RepAppl(cls->u.t_ptr)[1]);
+      {
+	CELL *pt = RepAppl(cls->u.t_ptr);
+#if SIZEOF_DOUBLE == 2*SIZEOF_LONG_INT
+	cls->Tag = MkIntTerm(pt[1]^pt[2]);
+#else
+	cls->Tag = MkIntTerm(pt[1]);
+#endif
+      }
       ipc = NEXTOP(ipc,e);
       break;
     case _switch_on_cons:
@@ -7906,7 +8031,7 @@ Yap_RemoveClauseFromIndex(PredEntry *ap, yamop *beg) {
 	Atom At = NameOfFunctor(f);
 	Yap_plwrite(MkAtomTerm(At), Yap_DebugPutc, 0);
 	Yap_DebugPutc(Yap_c_error_stream,'/');
-	Yap_plwrite(MkIntTerm(ArityOfFunctor(f)), Yap_DebugPutc, 0);
+	Yap_plwrite(MkIntegerTerm(ArityOfFunctor(f)), Yap_DebugPutc, 0);
       }
     } else {
       if (ap->PredFlags & NumberDBPredFlag) {
@@ -7920,7 +8045,7 @@ Yap_RemoveClauseFromIndex(PredEntry *ap, yamop *beg) {
 	Atom At = NameOfFunctor(f);
 	Yap_plwrite(MkAtomTerm(At), Yap_DebugPutc, 0);
 	Yap_DebugPutc(Yap_c_error_stream,'/');
-	Yap_plwrite(MkIntTerm(ArityOfFunctor(f)), Yap_DebugPutc, 0);
+	Yap_plwrite(MkIntegerTerm(ArityOfFunctor(f)), Yap_DebugPutc, 0);
       }
     }
     Yap_DebugPutc(Yap_c_error_stream,'\n');
@@ -8364,7 +8489,11 @@ Yap_FollowIndexingCode(PredEntry *ap, yamop *ipc, Term Terms[3], yamop *ap_pc, y
       ipc = NEXTOP(ipc,e);
       break;
     case _index_blob:
+#if SIZEOF_DOUBLE == 2*SIZEOF_LONG_INT
+      t = MkIntTerm(s_reg[0]^s_reg[1]);
+#else
       t = MkIntTerm(s_reg[0]);
+#endif
       ipc = NEXTOP(ipc,e);
       break;
     case _switch_on_cons:
@@ -8755,7 +8884,11 @@ find_caller(PredEntry *ap, yamop *code, struct intermediates *cint) {
       ipc = NEXTOP(ipc,e);
       break;
     case _index_blob:
+#if SIZEOF_DOUBLE == 2*SIZEOF_LONG_INT
+      t = MkIntTerm(s_reg[0]^s_reg[1]);
+#else
       t = MkIntTerm(s_reg[0]);
+#endif
       sp[-1].val = t;
       s_reg = NULL;
       ipc = NEXTOP(ipc,e);

H/Heap.h

@@ -10,7 +10,7 @@
 * File:		Heap.h         						 *
 * mods:									 *
 * comments:	Heap Init Structure					 *
-* version:      $Id: Heap.h,v 1.104 2006-08-25 19:50:35 vsc Exp $	 *
+* version:      $Id: Heap.h,v 1.105 2006-09-20 20:03:51 vsc Exp $	 *
 *************************************************************************/
 
 /* information that can be stored in Code Space */
@@ -165,6 +165,10 @@ typedef struct worker_local_struct {
   struct global_entry *global_variables;
   Term global_arena;
   Term global_delay_arena;
+  UInt local_timestamp;
+#if defined(YAPOR) || defined(THREADS)
+  lockvar  local_timestamp_lock;
+#endif
   yamop trust_lu_code[3];
 } worker_local;
 
@@ -212,6 +216,10 @@ typedef struct various_codes {
   worker_local wl[MAX_WORKERS];
 #else
   worker_local wl;
+#endif
+  UInt global_timestamp;
+#if defined(YAPOR) || defined(THREADS)
+  lockvar  global_timestamp_lock;
 #endif
 #ifdef BEAM
   yamop beam_retry_code;
@@ -562,6 +570,8 @@ struct various_codes *Yap_heap_regs;
 #define  HeapMax                 Yap_heap_regs->heap_max
 #define  HeapTop                 Yap_heap_regs->heap_top
 #define  HeapLim                 Yap_heap_regs->heap_lim
+#define  GlobalTimeStamp         Yap_heap_regs->global_timestamp
+#define  GlobalTimeStampLock     Yap_heap_regs->global_timestamp_lock
 #ifdef YAPOR
 #define  SEQUENTIAL_IS_DEFAULT   Yap_heap_regs->seq_def
 #define  GETWORK		 (&(Yap_heap_regs->getwork_code))
@@ -893,6 +903,8 @@ struct various_codes *Yap_heap_regs;
 #define  GlobalVariables          Yap_heap_regs->WL.global_variables
 #define  GlobalArena              Yap_heap_regs->WL.global_arena
 #define  GlobalDelayArena         Yap_heap_regs->WL.global_delay_arena
+#define  LocalTimeStamp           Yap_heap_regs->WL.local_timestamp
+#define  LocalTimeStampLock       Yap_heap_regs->WL.local_timestamp_lock
 #define  profiling                Yap_heap_regs->compiler_profiling
 #define  call_counting            Yap_heap_regs->compiler_call_counting
 #define  compile_arrays           Yap_heap_regs->compiler_compile_arrays

H/YapOpcodes.h

@@ -11,8 +11,11 @@
 * File:		YapOpcodes.h						 *
 * comments:	Central Table with all YAP opcodes                       *
 *									 *
-* Last rev:     $Date: 2006-04-27 14:13:24 $							 *
+* Last rev:     $Date: 2006-09-20 20:03:51 $							 *
 * $Log: not supported by cvs2svn $
+* Revision 1.38  2006/04/27 14:13:24  rslopes
+* *** empty log message ***
+*
 * Revision 1.37  2006/03/24 16:34:21  rslopes
 * New update to BEAM engine.
 * BEAM now uses YAP Indexing (JITI)
@@ -172,8 +175,8 @@
     OPCODE(get_4atoms              ,cccc),	  /* peephole */
     OPCODE(get_5atoms              ,ccccc),	  /* peephole */
     OPCODE(get_6atoms              ,cccccc),	  /* peephole */
-    OPCODE(get_float               ,xc),		
+    OPCODE(get_float               ,xd),		
-    OPCODE(get_longint             ,xc),		
+    OPCODE(get_longint             ,xi),		
     OPCODE(get_bigint              ,xc),		
     OPCODE(get_list                ,x),		
     OPCODE(get_struct              ,xf),		
@@ -182,7 +185,7 @@
     OPCODE(unify_x_val             ,ox),	
     OPCODE(unify_y_val             ,oy),	
     OPCODE(unify_atom              ,oc),		
-    OPCODE(unify_float             ,oc),		
+    OPCODE(unify_float             ,od),		
     OPCODE(unify_longint           ,oc),		
     OPCODE(unify_bigint            ,oc),		
     OPCODE(unify_list              ,o),		
@@ -194,6 +197,8 @@
     OPCODE(put_unsafe              ,yx),		
     OPCODE(put_xx_val              ,xxxx), /* peephole */
     OPCODE(put_atom                ,xc),		
+    OPCODE(put_float               ,xd),		
+    OPCODE(put_longint             ,xi),		
     OPCODE(put_list                ,x),		
     OPCODE(put_struct              ,xf),		
     OPCODE(write_x_var             ,x),	
@@ -201,6 +206,8 @@
     OPCODE(write_x_val             ,x),	
     OPCODE(write_y_val             ,y),	
     OPCODE(write_atom              ,c),		
+    OPCODE(write_float             ,d),		
+    OPCODE(write_longint           ,i),		
     OPCODE(write_list              ,e),		
     OPCODE(write_struct            ,f),	
     OPCODE(pop                     ,e),		
@@ -296,8 +303,8 @@
     OPCODE(unify_l_x_val           ,ox),	
     OPCODE(unify_l_y_val           ,oy),	
     OPCODE(unify_l_atom            ,oc),	
-    OPCODE(unify_l_float           ,oc),	
+    OPCODE(unify_l_float           ,od),	
-    OPCODE(unify_l_longint         ,oc),	
+    OPCODE(unify_l_longint         ,oi),	
     OPCODE(unify_l_bigint          ,oc),	
     OPCODE(unify_l_void            ,o),	
     OPCODE(unify_l_n_voids         ,os),	
@@ -309,6 +316,8 @@
     OPCODE(unify_x_val_write       ,ox),	
     OPCODE(unify_y_val_write       ,oy),	
     OPCODE(unify_atom_write        ,oc),	
+    OPCODE(unify_float_write       ,od),	
+    OPCODE(unify_longint_write       ,oi),	
     OPCODE(unify_n_atoms_write     ,osc),
     OPCODE(unify_list_write        ,o),	
     OPCODE(unify_x_var2_write      ,oxx),	
@@ -322,6 +331,8 @@
     OPCODE(unify_l_x_val_write     ,ox),
     OPCODE(unify_l_y_val_write     ,oy),
     OPCODE(unify_l_atom_write      ,oc),	
+    OPCODE(unify_l_float_write     ,od),	
+    OPCODE(unify_l_longint_write   ,oi),	
     OPCODE(unify_l_void_write      ,o),	
     OPCODE(unify_l_n_voids_write   ,os),
     OPCODE(unify_l_x_loc_write     ,ox),	

H/amidefs.h

@@ -11,8 +11,12 @@
 * File:		amidefs.h						 *
 * comments:	Abstract machine peculiarities				 *
 *									 *
-* Last rev:     $Date: 2005-12-17 03:25:39 $							 *
+* Last rev:     $Date: 2006-09-20 20:03:51 $							 *
 * $Log: not supported by cvs2svn $
+* Revision 1.30  2005/12/17 03:25:39  vsc
+* major changes to support online event-based profiling
+* improve error discovery and restart on scanner.
+*
 * Revision 1.29  2005/07/06 15:10:15  vsc
 * improvements to compiler: merged instructions and fixes for ->
 *
@@ -211,7 +215,8 @@ typedef struct yami {
 	 CELL next;
        } clll;
        struct {
-	 CODEADDR            d;
+	 OPCODE              opcw;
+	 CELL    d[1+SIZEOF_DOUBLE/SIZEOF_INT_P];
 	 CELL next;
        } d;
        struct {
@@ -247,6 +252,11 @@ typedef struct yami {
 	 struct yami         *f;
 	 CELL next;
        } fy;
+       struct {
+	 OPCODE              opcw;
+	 CELL    i[2];
+	 CELL next;
+       } i;
        struct {
 	 struct logic_upd_index  *I;
 	 struct yami             *l1;
@@ -277,6 +287,19 @@ typedef struct yami {
 #ifdef YAPOR
          unsigned int        or_arg;
 #endif /* YAPOR */
+#ifdef TABLING
+         struct table_entry *te; /* pointer to table entry */
+#endif /* TABLING */
+	 COUNT               s;
+	 struct pred_entry  *n, *c;
+	 struct yami              *d;
+	 CELL  *owner;
+	 CELL next;
+       } lld;
+       struct {
+#ifdef YAPOR
+         unsigned int        or_arg;
+#endif /* YAPOR */
 #ifdef TABLING
          struct table_entry *te; /* pointer to table entry */
 #endif /* TABLING */
@@ -388,12 +411,22 @@ typedef struct yami {
 	 CELL                c;
 	 CELL next;
        } oc;
+       struct {
+	 OPCODE              opcw;
+	 CELL    d[1+SIZEOF_DOUBLE/SIZEOF_INT_P];
+	 CELL next;
+       } od;
        struct {
 	 OPCODE              opcw;
 	 Functor             f;
 	 Int                 a;
 	 CELL next;
        } of;
+       struct {
+	 OPCODE              opcw;
+	 CELL		     i[2];
+	 CELL next;
+       } oi;
        struct {
 	 OPCODE              opcw;
 	 COUNT               s;
@@ -484,6 +517,11 @@ typedef struct yami {
 	 CELL                c;
 	 CELL next;
        } xc;
+       struct {
+	 wamreg                x;
+	 CELL    d[1+SIZEOF_DOUBLE/SIZEOF_INT_P];
+	 CELL next;
+       } xd;
        struct {
 	 wamreg                x;
 	 Functor             f;
@@ -495,6 +533,11 @@ typedef struct yami {
 	 struct yami          *F;
 	 CELL next;
        } xF;
+       struct {
+	 wamreg                x;
+	 CELL    i[2];
+	 CELL next;
+       } xi;
        struct {
 	 wamreg                x;
 	 struct yami	       *l1;

H/clause.h

@@ -78,6 +78,10 @@ typedef struct logic_upd_clause {
   struct logic_upd_clause   *ClPrev, *ClNext;
   /* parent pointer */
   PredEntry   *ClPred;
+  /*
+    support for timers, stalled for now.
+  UInt             ClTimeStart, ClTimeEnd;
+  */
   /* The instructions, at least one of the form sl */
   yamop            ClCode[MIN_ARRAY];
 } LogUpdClause;

H/rclause.h

@@ -12,8 +12,11 @@
 * File:		rclause.h						 *
 * comments:	walk through a clause					 *
 *									 *
-* Last rev:     $Date: 2006-04-27 14:13:24 $,$Author: rslopes $						 *
+* Last rev:     $Date: 2006-09-20 20:03:51 $,$Author: vsc $						 *
 * $Log: not supported by cvs2svn $
+* Revision 1.15  2006/04/27 14:13:24  rslopes
+* *** empty log message ***
+*
 * Revision 1.14  2005/12/17 03:25:39  vsc
 * major changes to support online event-based profiling
 * improve error discovery and restart on scanner.
@@ -425,11 +428,21 @@ restore_opcodes(yamop *pc)
       pc->u.yx.y = YAdjust(pc->u.yx.y);
       pc = NEXTOP(pc,yx);
       break;
+      /* instructions type xd */
+    case _get_float:
+    case _put_float:
+      pc->u.xd.x = XAdjust(pc->u.xd.x);
+      pc = NEXTOP(pc,xd);
+      break;
+      /* instructions type xd */
+    case _get_longint:
+    case _put_longint:
+      pc->u.xi.x = XAdjust(pc->u.xi.x);
+      pc = NEXTOP(pc,xi);
+      break;
       /* instructions type xc */
     case _get_atom:
     case _put_atom:
-    case _get_float:
-    case _get_longint:
     case _get_bigint:
       pc->u.xc.x = XAdjust(pc->u.xc.x);
       {
@@ -688,15 +701,27 @@ restore_opcodes(yamop *pc)
       pc->u.os.opcw = Yap_opcode(Yap_op_from_opcode(pc->u.os.opcw));
       pc = NEXTOP(pc,os);
       break;
+      /* instructions type od */
+    case _unify_float:
+    case _unify_l_float:
+    case _unify_float_write:
+    case _unify_l_float_write:
+      pc->u.oc.opcw = Yap_opcode(Yap_op_from_opcode(pc->u.oc.opcw));
+      pc = NEXTOP(pc,od);
+      break;
+      /* instructions type oi */
+    case _unify_longint:
+    case _unify_l_longint:
+    case _unify_longint_write:
+    case _unify_l_longint_write:
+      pc->u.oc.opcw = Yap_opcode(Yap_op_from_opcode(pc->u.oc.opcw));
+      pc = NEXTOP(pc,oi);
+      break;
       /* instructions type oc */
     case _unify_atom_write:
     case _unify_atom:
     case _unify_l_atom_write:
     case _unify_l_atom:
-    case _unify_float:
-    case _unify_l_float:
-    case _unify_longint:
-    case _unify_l_longint:
     case _unify_bigint:
     case _unify_l_bigint:
       pc->u.oc.opcw = Yap_opcode(Yap_op_from_opcode(pc->u.oc.opcw));
@@ -740,6 +765,14 @@ restore_opcodes(yamop *pc)
 #endif /* TABLING */
       pc = NEXTOP(pc,s);
       break;
+      /* instructions type d */
+    case _write_float:
+      pc = NEXTOP(pc,d);
+      break;
+      /* instructions type i */
+    case _write_longint:
+      pc = NEXTOP(pc,i);
+      break;
       /* instructions type c */
    case _write_atom:
       {

changes-5.1.html

@@ -16,6 +16,8 @@
 
 <h2>Yap-5.1.2:</h2>
 <ul>
+<li> FIXED:  indexing on doubles wasn't working properly.</li> 
+<li> FIXED:  sending large lists of atomics to DB was very, very slow.</li> 
 <li> FIXED:  make library_directory/1 better protected.</li> 
 <li> FIXED:  make YAP smarter at finding libraries in WIN32.</li> 
 <li> NEW:  data structures using global variables: queues, heaps and

pl/modules.yap

@@ -435,6 +435,7 @@ source_module(Mod) :-
 '$member'(X,[X|_]) :- !.
 '$member'(X,[_|L]) :- '$member'(X,L).
 
+
 % comma has its own problems.
 :- '$install_meta_predicate'((:,:), prolog).