diogo/yap-6.3
Archived
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Mega clauses

Browse Source 
Fixes to sizeof(expand_clauses) which was being overestimated
Fixes to profiling+indexing
Fixes to reallocation of memory after restoring
Make sure all clauses, even for C, end in _Ystop
Don't reuse space for Streams
Fix Stream_F on StreaNo+1


git-svn-id: https://yap.svn.sf.net/svnroot/yap/trunk@1147 b08c6af1-5177-4d33-ba66-4b1c6b8b522a
This commit is contained in:
vsc 2004-09-27 20:45:04 +00:00
parent b3c813bfee
commit 40a39a79b1
25 changed files with 6216 additions and 13796 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

645
C/absmi.c
View File

@ -10,8 +10,11 @@
* * * *
* File: absmi.c * * File: absmi.c *
* comments: Portable abstract machine interpreter * * comments: Portable abstract machine interpreter *
* Last rev: $Date: 2004-09-17 20:47:35 $,$Author: vsc $ * * Last rev: $Date: 2004-09-27 20:45:02 $,$Author: vsc $ *
* $Log: not supported by cvs2svn $ * $Log: not supported by cvs2svn $
* Revision 1.145 2004/09/17 20:47:35 vsc
* fix some overflows recorded.
*
* Revision 1.144 2004/09/17 19:34:49 vsc * Revision 1.144 2004/09/17 19:34:49 vsc
* simplify frozen/2 * simplify frozen/2
* *
@ -460,7 +463,7 @@ Yap_absmi(int inp)
#if BP_FREE #if BP_FREE
P1REG = PCBACKUP; P1REG = PCBACKUP;
#endif #endif
return (1); return 1;
ENDBOp(); ENDBOp();
BOp(Nstop, e); BOp(Nstop, e);
@ -1737,6 +1740,9 @@ Yap_absmi(int inp)
case _or_last: case _or_last:
low_level_trace(retry_or, (PredEntry *)ipc, &(B->cp_a1)); low_level_trace(retry_or, (PredEntry *)ipc, &(B->cp_a1));
break; break;
case _retry2:
case _retry3:
case _retry4:
case _trust_logical_pred: case _trust_logical_pred:
ipc = NEXTOP(ipc,l); ipc = NEXTOP(ipc,l);
go_on = TRUE; go_on = TRUE;
@ -3078,6 +3084,521 @@ Yap_absmi(int inp)
ENDD(d0); ENDD(d0);
ENDOp(); ENDOp();
Op(get_2atoms, cc);
BEGD(d0);
BEGD(d1);
/* fetch arguments */
d0 = ARG1;
BEGP(pt0);
deref_head(d0, gatom_2unk);
/* argument is nonvar */
gatom_2nonvar:
if (d0 == PREG->u.cc.c1) {
goto gatom_2b;
}
else {
FAIL();
}
deref_body(d0, pt0, gatom_2unk, gatom_2nonvar);
/* argument is a variable */
BIND(pt0, PREG->u.cc.c1, gatom_2b);
#ifdef COROUTINING
DO_TRAIL(pt0, d1);
if (pt0 < H0) Yap_WakeUp(pt0);
#endif
ENDP(pt0);
gatom_2b:
/* fetch arguments */
d0 = ARG2;
d1 = PREG->u.cc.c2;
BEGP(pt0);
deref_head(d0, gatom_2bunk);
/* argument is nonvar */
gatom_2bnonvar:
if (d0 == d1) {
PREG = NEXTOP(PREG, cc);
GONext();
}
else {
FAIL();
}
deref_body(d0, pt0, gatom_2bunk, gatom_2bnonvar);
/* argument is a variable */
PREG = NEXTOP(PREG, cc);
BIND(pt0, d1, gatom_2c);
#ifdef COROUTINING
DO_TRAIL(pt0, d1);
if (pt0 < H0) Yap_WakeUp(pt0);
gatom_2c:
#endif
GONext();
ENDP(pt0);
ENDD(d1);
ENDD(d0);
ENDOp();
Op(get_3atoms, ccc);
BEGD(d0);
BEGD(d1);
/* fetch arguments */
d0 = ARG1;
BEGP(pt0);
deref_head(d0, gatom_3unk);
/* argument is nonvar */
gatom_3nonvar:
if (d0 == PREG->u.ccc.c1) {
goto gatom_3b;
}
else {
FAIL();
}
deref_body(d0, pt0, gatom_3unk, gatom_3nonvar);
/* argument is a variable */
BIND(pt0, PREG->u.ccc.c1, gatom_3b);
#ifdef COROUTINING
DO_TRAIL(pt0, d1);
if (pt0 < H0) Yap_WakeUp(pt0);
#endif
ENDP(pt0);
gatom_3b:
/* fetch arguments */
d0 = ARG2;
BEGP(pt0);
deref_head(d0, gatom_3bunk);
/* argument is nonvar */
gatom_3bnonvar:
if (d0 == PREG->u.ccc.c2) {
goto gatom_3c;
}
else {
FAIL();
}
deref_body(d0, pt0, gatom_3bunk, gatom_3bnonvar);
/* argument is a variable */
BIND(pt0, PREG->u.ccc.c2, gatom_3c);
#ifdef COROUTINING
DO_TRAIL(pt0, d1);
if (pt0 < H0) Yap_WakeUp(pt0);
#endif
ENDP(pt0);
gatom_3c:
/* fetch arguments */
d0 = ARG3;
d1 = PREG->u.ccc.c3;
BEGP(pt0);
deref_head(d0, gatom_3cunk);
/* argument is nonvar */
gatom_3cnonvar:
if (d0 == d1) {
PREG = NEXTOP(PREG, ccc);
GONext();
}
else {
FAIL();
}
deref_body(d0, pt0, gatom_3cunk, gatom_3cnonvar);
/* argument is a variable */
PREG = NEXTOP(PREG, ccc);
BIND(pt0, d1, gatom_3d);
#ifdef COROUTINING
DO_TRAIL(pt0, d1);
if (pt0 < H0) Yap_WakeUp(pt0);
gatom_3d:
#endif
GONext();
ENDP(pt0);
ENDD(d1);
ENDD(d0);
ENDOp();
Op(get_4atoms, cccc);
BEGD(d0);
BEGD(d1);
/* fetch arguments */
d0 = ARG1;
BEGP(pt0);
deref_head(d0, gatom_4unk);
/* argument is nonvar */
gatom_4nonvar:
if (d0 == PREG->u.cccc.c1) {
goto gatom_4b;
}
else {
FAIL();
}
deref_body(d0, pt0, gatom_4unk, gatom_4nonvar);
/* argument is a variable */
BIND(pt0, PREG->u.cccc.c1, gatom_4b);
#ifdef COROUTINING
DO_TRAIL(pt0, d1);
if (pt0 < H0) Yap_WakeUp(pt0);
#endif
ENDP(pt0);
gatom_4b:
/* fetch arguments */
d0 = ARG2;
BEGP(pt0);
deref_head(d0, gatom_4bunk);
/* argument is nonvar */
gatom_4bnonvar:
if (d0 == PREG->u.cccc.c2) {
goto gatom_4c;
}
else {
FAIL();
}
deref_body(d0, pt0, gatom_4bunk, gatom_4bnonvar);
/* argument is a variable */
BIND(pt0, PREG->u.cccc.c2, gatom_4c);
#ifdef COROUTINING
DO_TRAIL(pt0, d1);
if (pt0 < H0) Yap_WakeUp(pt0);
#endif
ENDP(pt0);
gatom_4c:
/* fetch arguments */
d0 = ARG3;
BEGP(pt0);
deref_head(d0, gatom_4cunk);
/* argument is nonvar */
gatom_4cnonvar:
if (d0 == PREG->u.cccc.c3) {
goto gatom_4d;
}
else {
FAIL();
}
deref_body(d0, pt0, gatom_4cunk, gatom_4cnonvar);
/* argument is a variable */
BIND(pt0, PREG->u.cccc.c3, gatom_4d);
#ifdef COROUTINING
DO_TRAIL(pt0, d1);
if (pt0 < H0) Yap_WakeUp(pt0);
#endif
ENDP(pt0);
gatom_4d:
/* fetch arguments */
d0 = ARG4;
d1 = PREG->u.cccc.c4;
BEGP(pt0);
deref_head(d0, gatom_4dunk);
/* argument is nonvar */
gatom_4dnonvar:
if (d0 == d1) {
PREG = NEXTOP(PREG, cccc);
GONext();
}
else {
FAIL();
}
deref_body(d0, pt0, gatom_4dunk, gatom_4dnonvar);
/* argument is a variable */
PREG = NEXTOP(PREG, cccc);
BIND(pt0, d1, gatom_4e);
#ifdef COROUTINING
DO_TRAIL(pt0, d1);
if (pt0 < H0) Yap_WakeUp(pt0);
gatom_4e:
#endif
GONext();
ENDP(pt0);
ENDD(d1);
ENDD(d0);
ENDOp();
Op(get_5atoms, ccccc);
BEGD(d0);
BEGD(d1);
/* fetch arguments */
d0 = ARG1;
BEGP(pt0);
deref_head(d0, gatom_5unk);
/* argument is nonvar */
gatom_5nonvar:
if (d0 == PREG->u.ccccc.c1) {
goto gatom_5b;
}
else {
FAIL();
}
deref_body(d0, pt0, gatom_5unk, gatom_5nonvar);
/* argument is a variable */
BIND(pt0, PREG->u.ccccc.c1, gatom_5b);
#ifdef COROUTINING
DO_TRAIL(pt0, d1);
if (pt0 < H0) Yap_WakeUp(pt0);
#endif
ENDP(pt0);
gatom_5b:
/* fetch arguments */
d0 = ARG2;
BEGP(pt0);
deref_head(d0, gatom_5bunk);
/* argument is nonvar */
gatom_5bnonvar:
if (d0 == PREG->u.ccccc.c2) {
goto gatom_5c;
}
else {
FAIL();
}
deref_body(d0, pt0, gatom_5bunk, gatom_5bnonvar);
/* argument is a variable */
BIND(pt0, PREG->u.ccccc.c2, gatom_5c);
#ifdef COROUTINING
DO_TRAIL(pt0, d1);
if (pt0 < H0) Yap_WakeUp(pt0);
#endif
ENDP(pt0);
gatom_5c:
/* fetch arguments */
d0 = ARG3;
BEGP(pt0);
deref_head(d0, gatom_5cunk);
/* argument is nonvar */
gatom_5cnonvar:
if (d0 == PREG->u.ccccc.c3) {
goto gatom_5d;
}
else {
FAIL();
}
deref_body(d0, pt0, gatom_5cunk, gatom_5cnonvar);
/* argument is a variable */
BIND(pt0, PREG->u.ccccc.c3, gatom_5d);
#ifdef COROUTINING
DO_TRAIL(pt0, d1);
if (pt0 < H0) Yap_WakeUp(pt0);
#endif
ENDP(pt0);
gatom_5d:
/* fetch arguments */
d0 = ARG4;
BEGP(pt0);
deref_head(d0, gatom_5dunk);
/* argument is nonvar */
gatom_5dnonvar:
if (d0 == PREG->u.ccccc.c4) {
goto gatom_5e;
}
else {
FAIL();
}
deref_body(d0, pt0, gatom_5dunk, gatom_5dnonvar);
/* argument is a variable */
BIND(pt0, PREG->u.ccccc.c4, gatom_5e);
#ifdef COROUTINING
DO_TRAIL(pt0, d1);
if (pt0 < H0) Yap_WakeUp(pt0);
#endif
ENDP(pt0);
gatom_5e:
/* fetch arguments */
d0 = ARG5;
d1 = PREG->u.ccccc.c5;
BEGP(pt0);
deref_head(d0, gatom_5eunk);
/* argument is nonvar */
gatom_5enonvar:
if (d0 == d1) {
PREG = NEXTOP(PREG, ccccc);
GONext();
}
else {
FAIL();
}
deref_body(d0, pt0, gatom_5eunk, gatom_5enonvar);
/* argument is a variable */
PREG = NEXTOP(PREG, ccccc);
BIND(pt0, d1, gatom_5f);
#ifdef COROUTINING
DO_TRAIL(pt0, d1);
if (pt0 < H0) Yap_WakeUp(pt0);
gatom_5f:
#endif
GONext();
ENDP(pt0);
ENDD(d1);
ENDD(d0);
ENDOp();
Op(get_6atoms, cccccc);
BEGD(d0);
BEGD(d1);
/* fetch arguments */
d0 = ARG1;
BEGP(pt0);
deref_head(d0, gatom_6unk);
/* argument is nonvar */
gatom_6nonvar:
if (d0 == PREG->u.cccccc.c1) {
goto gatom_6b;
}
else {
FAIL();
}
deref_body(d0, pt0, gatom_6unk, gatom_6nonvar);
/* argument is a variable */
BIND(pt0, PREG->u.cccccc.c1, gatom_6b);
#ifdef COROUTINING
DO_TRAIL(pt0, d1);
if (pt0 < H0) Yap_WakeUp(pt0);
#endif
ENDP(pt0);
gatom_6b:
/* fetch arguments */
d0 = ARG2;
BEGP(pt0);
deref_head(d0, gatom_6bunk);
/* argument is nonvar */
gatom_6bnonvar:
if (d0 == PREG->u.cccccc.c2) {
goto gatom_6c;
}
else {
FAIL();
}
deref_body(d0, pt0, gatom_6bunk, gatom_6bnonvar);
/* argument is a variable */
BIND(pt0, PREG->u.cccccc.c2, gatom_6c);
#ifdef COROUTINING
DO_TRAIL(pt0, d1);
if (pt0 < H0) Yap_WakeUp(pt0);
#endif
ENDP(pt0);
gatom_6c:
/* fetch arguments */
d0 = ARG3;
BEGP(pt0);
deref_head(d0, gatom_6cunk);
/* argument is nonvar */
gatom_6cnonvar:
if (d0 == PREG->u.cccccc.c3) {
goto gatom_6d;
}
else {
FAIL();
}
deref_body(d0, pt0, gatom_6cunk, gatom_6cnonvar);
/* argument is a variable */
BIND(pt0, PREG->u.cccccc.c3, gatom_6d);
#ifdef COROUTINING
DO_TRAIL(pt0, d1);
if (pt0 < H0) Yap_WakeUp(pt0);
#endif
ENDP(pt0);
gatom_6d:
/* fetch arguments */
d0 = ARG4;
BEGP(pt0);
deref_head(d0, gatom_6dunk);
/* argument is nonvar */
gatom_6dnonvar:
if (d0 == PREG->u.cccccc.c4) {
goto gatom_6e;
}
else {
FAIL();
}
deref_body(d0, pt0, gatom_6dunk, gatom_6dnonvar);
/* argument is a variable */
BIND(pt0, PREG->u.cccccc.c4, gatom_6e);
#ifdef COROUTINING
DO_TRAIL(pt0, d1);
if (pt0 < H0) Yap_WakeUp(pt0);
#endif
ENDP(pt0);
gatom_6e:
/* fetch arguments */
d0 = ARG5;
BEGP(pt0);
deref_head(d0, gatom_6eunk);
/* argument is nonvar */
gatom_6enonvar:
if (d0 == PREG->u.cccccc.c5) {
goto gatom_6f;
}
else {
FAIL();
}
deref_body(d0, pt0, gatom_6eunk, gatom_6enonvar);
/* argument is a variable */
BIND(pt0, PREG->u.cccccc.c4, gatom_6f);
#ifdef COROUTINING
DO_TRAIL(pt0, d1);
if (pt0 < H0) Yap_WakeUp(pt0);
#endif
ENDP(pt0);
gatom_6f:
/* fetch arguments */
d0 = ARG6;
d1 = PREG->u.cccccc.c6;
BEGP(pt0);
deref_head(d0, gatom_6funk);
/* argument is nonvar */
gatom_6fnonvar:
if (d0 == d1) {
PREG = NEXTOP(PREG, cccccc);
GONext();
}
else {
FAIL();
}
deref_body(d0, pt0, gatom_6funk, gatom_6fnonvar);
/* argument is a variable */
PREG = NEXTOP(PREG, cccccc);
BIND(pt0, d1, gatom_6g);
#ifdef COROUTINING
DO_TRAIL(pt0, d1);
if (pt0 < H0) Yap_WakeUp(pt0);
gatom_6g:
#endif
GONext();
ENDP(pt0);
ENDD(d1);
ENDD(d0);
ENDOp();
/* The next instructions can lead to either the READ stream /* The next instructions can lead to either the READ stream
* or the write stream */ * or the write stream */
@ -6797,6 +7318,72 @@ Yap_absmi(int inp)
JMPNext(); JMPNext();
ENDBOp(); ENDBOp();
BOp(try_clause2, l);
check_trail(TR);
CACHE_Y(YREG);
/* Point AP to the code that follows this instruction */
{
register CELL x2 = ARG2;
register CELL x1 = CACHED_A1();
store_yaam_regs(NEXTOP(PREG, l), 2);
B_YREG->cp_a1 = x1;
B_YREG->cp_a2 = x2;
}
PREG = PREG->u.l.l;
set_cut(S_YREG, B);
B = B_YREG;
#ifdef YAPOR
SCH_set_load(B_YREG);
#endif /* YAPOR */
SET_BB(B_YREG);
ENDCACHE_Y();
JMPNext();
ENDBOp();
BOp(try_clause3, l);
check_trail(TR);
CACHE_Y(YREG);
/* Point AP to the code that follows this instruction */
{
store_yaam_regs(NEXTOP(PREG, l), 3);
B_YREG->cp_a1 = CACHED_A1();
B_YREG->cp_a2 = ARG2;
B_YREG->cp_a3 = ARG3;
}
PREG = PREG->u.l.l;
set_cut(S_YREG, B);
B = B_YREG;
#ifdef YAPOR
SCH_set_load(B_YREG);
#endif /* YAPOR */
SET_BB(B_YREG);
ENDCACHE_Y();
JMPNext();
ENDBOp();
BOp(try_clause4, l);
check_trail(TR);
CACHE_Y(YREG);
/* Point AP to the code that follows this instruction */
{
store_yaam_regs(NEXTOP(PREG, l), 4);
B_YREG->cp_a1 = CACHED_A1();
B_YREG->cp_a2 = ARG2;
B_YREG->cp_a3 = ARG3;
B_YREG->cp_a4 = ARG4;
}
PREG = PREG->u.l.l;
set_cut(S_YREG, B);
B = B_YREG;
#ifdef YAPOR
SCH_set_load(B_YREG);
#endif /* YAPOR */
SET_BB(B_YREG);
ENDCACHE_Y();
JMPNext();
ENDBOp();
BOp(retry, ld); BOp(retry, ld);
CACHE_Y(B); CACHE_Y(B);
restore_yaam_regs(NEXTOP(PREG, ld)); restore_yaam_regs(NEXTOP(PREG, ld));
@ -6813,6 +7400,60 @@ Yap_absmi(int inp)
JMPNext(); JMPNext();
ENDBOp(); ENDBOp();
BOp(retry2, l);
CACHE_Y(B);
restore_yaam_regs(NEXTOP(PREG, l));
PREG = PREG->u.l.l;
ARG1 = B_YREG->cp_a1;
ARG2 = B_YREG->cp_a2;
#ifdef FROZEN_STACKS
B_YREG = PROTECT_FROZEN_B(B_YREG);
set_cut(S_YREG, B->cp_b);
#else
set_cut(S_YREG, B_YREG->cp_b);
#endif /* FROZEN_STACKS */
SET_BB(B_YREG);
ENDCACHE_Y();
JMPNext();
ENDBOp();
BOp(retry3, l);
CACHE_Y(B);
restore_yaam_regs(NEXTOP(PREG, l));
PREG = PREG->u.l.l;
ARG1 = B_YREG->cp_a1;
ARG2 = B_YREG->cp_a2;
ARG3 = B_YREG->cp_a3;
#ifdef FROZEN_STACKS
B_YREG = PROTECT_FROZEN_B(B_YREG);
set_cut(S_YREG, B->cp_b);
#else
set_cut(S_YREG, B_YREG->cp_b);
#endif /* FROZEN_STACKS */
SET_BB(B_YREG);
ENDCACHE_Y();
JMPNext();
ENDBOp();
BOp(retry4, l);
CACHE_Y(B);
restore_yaam_regs(NEXTOP(PREG, l));
PREG = PREG->u.l.l;
ARG1 = B_YREG->cp_a1;
ARG2 = B_YREG->cp_a2;
ARG3 = B_YREG->cp_a3;
ARG4 = B_YREG->cp_a4;
#ifdef FROZEN_STACKS
B_YREG = PROTECT_FROZEN_B(B_YREG);
set_cut(S_YREG, B->cp_b);
#else
set_cut(S_YREG, B_YREG->cp_b);
#endif /* FROZEN_STACKS */
SET_BB(B_YREG);
ENDCACHE_Y();
JMPNext();
ENDBOp();
BOp(trust, ld); BOp(trust, ld);
CACHE_Y(B); CACHE_Y(B);
#ifdef YAPOR #ifdef YAPOR

6
C/alloc.c
View File

@ -12,7 +12,7 @@
* Last rev: * * Last rev: *
* mods: * * mods: *
* comments: allocating space * * comments: allocating space *
* version:$Id: alloc.c,v 1.57 2004-09-03 03:11:07 vsc Exp $ * * version:$Id: alloc.c,v 1.58 2004-09-27 20:45:02 vsc Exp $ *
*************************************************************************/ *************************************************************************/
#ifdef SCCS #ifdef SCCS
static char SccsId[] = "%W% %G%"; static char SccsId[] = "%W% %G%";
@ -326,10 +326,10 @@ FreeBlock(BlockHeader *b)
sp = &(b->b_size) + (b->b_size & ~InUseFlag); sp = &(b->b_size) + (b->b_size & ~InUseFlag);
if (*sp != b->b_size) { if (*sp != b->b_size) {
#if !SHORT_INTS #if !SHORT_INTS
fprintf(stderr, "** sanity check failed in FreeBlock %p %x %x\n", fprintf(stderr, "%% YAP INTERNAL ERROR: sanity check failed in FreeBlock %p %x %x\n",
b, b->b_size, Unsigned(*sp)); b, b->b_size, Unsigned(*sp));
#else #else
fprintf(stderr, "**sanity check failed in FreeBlock %p %lx %lx\n", fprintf(stderr, "%% YAP INTERNAL ERROR: sanity check failed in FreeBlock %p %lx %lx\n",
b, b->b_size, *sp); b, b->b_size, *sp);
#endif #endif
return; return;

159
C/amasm.c
View File

@ -11,8 +11,12 @@
* File: amasm.c * * File: amasm.c *
* comments: abstract machine assembler * * comments: abstract machine assembler *
* * * *
* Last rev: $Date: 2004-08-20 16:16:23 $ * * Last rev: $Date: 2004-09-27 20:45:02 $ *
* $Log: not supported by cvs2svn $ * $Log: not supported by cvs2svn $
* Revision 1.62 2004/08/20 16:16:23 vsc
* growheap was not checking some compiler instructions
* source was getting confused in reconsult
*
* Revision 1.61 2004/04/29 03:45:50 vsc * Revision 1.61 2004/04/29 03:45:50 vsc
* fix garbage collection in execute_tail * fix garbage collection in execute_tail
* *
@ -711,15 +715,93 @@ a_rf(op_numbers opcode, yamop *code_p, int pass_no, struct PSEUDO *cpc)
return code_p; return code_p;
} }
inline static yamop * static yamop *
a_rc(op_numbers opcode, yamop *code_p, int pass_no, struct PSEUDO *cpc) a_rc(op_numbers opcode, yamop *code_p, int pass_no, struct intermediates *cip)
{ {
if (pass_no) { if (cip->cpc->rnd2 == 1 &&
code_p->opc = emit_op(opcode); cip->cpc->nextInst->rnd2 == 2 &&
code_p->u.xc.x = emit_x(cpc->rnd2); (cip->cpc->nextInst->op == get_atom_op ||
code_p->u.xc.c = emit_c(cpc->rnd1); 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 ||
next->nextInst->op == get_num_op)) {
struct PSEUDO *snext = next->nextInst;
if (snext->nextInst->rnd2 == 4 &&
(snext->nextInst->op == get_atom_op ||
snext->nextInst->op == get_num_op)) {
struct PSEUDO *s2next = snext->nextInst;
if (s2next->nextInst->rnd2 == 5 &&
(s2next->nextInst->op == get_atom_op ||
s2next->nextInst->op == get_num_op)) {
struct PSEUDO *s3next = s2next->nextInst;
if (s3next->nextInst->rnd2 == 6 &&
(s3next->nextInst->op == get_atom_op ||
s3next->nextInst->op == get_num_op)) {
if (pass_no) {
code_p->opc = emit_op(_get_6atoms);
code_p->u.cccccc.c1 = emit_c(cip->cpc->rnd1);
code_p->u.cccccc.c2 = emit_c(next->rnd1);
code_p->u.cccccc.c3 = emit_c(snext->rnd1);
code_p->u.cccccc.c4 = emit_c(s2next->rnd1);
code_p->u.cccccc.c5 = emit_c(s3next->rnd1);
code_p->u.cccccc.c6 = emit_c(s3next->nextInst->rnd1);
}
cip->cpc = s3next->nextInst;
GONEXT(cccccc);
} else {
if (pass_no) {
code_p->opc = emit_op(_get_5atoms);
code_p->u.ccccc.c1 = emit_c(cip->cpc->rnd1);
code_p->u.ccccc.c2 = emit_c(next->rnd1);
code_p->u.ccccc.c3 = emit_c(snext->rnd1);
code_p->u.ccccc.c4 = emit_c(s2next->rnd1);
code_p->u.ccccc.c5 = emit_c(s3next->rnd1);
}
cip->cpc = s3next;
GONEXT(ccccc);
}
} else {
if (pass_no) {
code_p->opc = emit_op(_get_4atoms);
code_p->u.cccc.c1 = emit_c(cip->cpc->rnd1);
code_p->u.cccc.c2 = emit_c(next->rnd1);
code_p->u.cccc.c3 = emit_c(snext->rnd1);
code_p->u.cccc.c4 = emit_c(s2next->rnd1);
}
cip->cpc = s2next;
GONEXT(cccc);
}
} else {
if (pass_no) {
code_p->opc = emit_op(_get_3atoms);
code_p->u.ccc.c1 = emit_c(cip->cpc->rnd1);
code_p->u.ccc.c2 = emit_c(next->rnd1);
code_p->u.ccc.c3 = emit_c(snext->rnd1);
}
cip->cpc = snext;
GONEXT(ccc);
}
} else {
if (pass_no) {
code_p->opc = emit_op(_get_2atoms);
code_p->u.cc.c1 = emit_c(cip->cpc->rnd1);
code_p->u.cc.c2 = emit_c(next->rnd1);
}
cip->cpc = next;
GONEXT(cc);
}
} else {
if (pass_no) {
code_p->opc = emit_op(opcode);
code_p->u.xc.x = emit_x(cip->cpc->rnd2);
code_p->u.xc.c = emit_c(cip->cpc->rnd1);
}
GONEXT(xc);
} }
GONEXT(xc);
return code_p; return code_p;
} }
@ -1288,6 +1370,56 @@ a_try(op_numbers opcode, CELL lab, CELL opr, clause_info *clinfo, int nofalts, i
a_try(op_numbers opcode, CELL lab, CELL opr, clause_info *clinfo, yamop *code_p, int pass_no) a_try(op_numbers opcode, CELL lab, CELL opr, clause_info *clinfo, yamop *code_p, int pass_no)
#endif /* YAPOR */ #endif /* YAPOR */
{ {
switch (opr) {
case 2:
if (opcode == _try_clause) {
if (pass_no) {
code_p->opc = emit_op(_try_clause2);
code_p->u.l.l = emit_a(lab);
}
GONEXT(l);
return code_p;
} else if (opcode == _retry) {
if (pass_no) {
code_p->opc = emit_op(_retry2);
code_p->u.l.l = emit_a(lab);
}
GONEXT(l);
return code_p;
}
case 3:
if (opcode == _try_clause) {
if (pass_no) {
code_p->opc = emit_op(_try_clause3);
code_p->u.l.l = emit_a(lab);
}
GONEXT(l);
return code_p;
} else if (opcode == _retry) {
if (pass_no) {
code_p->opc = emit_op(_retry3);
code_p->u.l.l = emit_a(lab);
}
GONEXT(l);
return code_p;
}
case 4:
if (opcode == _try_clause) {
if (pass_no) {
code_p->opc = emit_op(_try_clause4);
code_p->u.l.l = emit_a(lab);
}
GONEXT(l);
return code_p;
} else if (opcode == _retry) {
if (pass_no) {
code_p->opc = emit_op(_retry4);
code_p->u.l.l = emit_a(lab);
}
GONEXT(l);
return code_p;
}
}
if (pass_no) { if (pass_no) {
code_p->opc = emit_op(opcode); code_p->opc = emit_op(opcode);
code_p->u.ld.d = emit_a(lab); code_p->u.ld.d = emit_a(lab);
@ -2172,7 +2304,6 @@ do_pass(int pass_no, yamop **entry_codep, int assembling, int *clause_has_blobsp
} else { } else {
/* static clause */ /* static clause */
if (pass_no) { if (pass_no) {
cl_u->sc.Id = FunctorDBRef;
cl_u->sc.ClFlags = StaticMask; cl_u->sc.ClFlags = StaticMask;
cl_u->sc.ClNext = NULL; cl_u->sc.ClNext = NULL;
cl_u->sc.ClSize = size; cl_u->sc.ClSize = size;
@ -2308,7 +2439,7 @@ do_pass(int pass_no, yamop **entry_codep, int assembling, int *clause_has_blobsp
break; break;
case get_num_op: case get_num_op:
case get_atom_op: case get_atom_op:
code_p = a_rc(_get_atom, code_p, pass_no, cip->cpc); code_p = a_rc(_get_atom, code_p, pass_no, cip);
break; break;
case get_float_op: case get_float_op:
code_p = a_rb(_get_float, clause_has_blobsp, code_p, pass_no, cip); code_p = a_rb(_get_float, clause_has_blobsp, code_p, pass_no, cip);
@ -2321,7 +2452,7 @@ do_pass(int pass_no, yamop **entry_codep, int assembling, int *clause_has_blobsp
break; break;
case put_num_op: case put_num_op:
case put_atom_op: case put_atom_op:
code_p = a_rc(_put_atom, code_p, pass_no, cip->cpc); code_p = a_rc(_put_atom, code_p, pass_no, cip);
break; break;
case put_float_op: case put_float_op:
case put_longint_op: case put_longint_op:
@ -2805,8 +2936,10 @@ Yap_assemble(int mode, Term t, PredEntry *ap, int is_fact, struct intermediates
cip->label_offset = (int *)cip->freep; cip->label_offset = (int *)cip->freep;
cip->code_addr = NULL; cip->code_addr = NULL;
code_p = do_pass(0, &entry_code, mode, &clause_has_blobs, cip, size); code_p = do_pass(0, &entry_code, mode, &clause_has_blobs, cip, size);
size = if (ap->PredFlags & DynamicPredFlag) {
(CELL)NEXTOP(NEXTOP(NEXTOP((yamop *)(((DynamicClause *)NULL)->ClCode),ld),sla),e); size =
(CELL)NEXTOP(NEXTOP(NEXTOP((yamop *)(((DynamicClause *)NULL)->ClCode),ld),sla),e);
}
if ((CELL)code_p > size) if ((CELL)code_p > size)
size = (CELL)code_p; size = (CELL)code_p;
if (mode == ASSEMBLING_CLAUSE && if (mode == ASSEMBLING_CLAUSE &&

12
C/analyst.c
View File

@ -187,6 +187,11 @@ p_show_op_counters()
print_instruction(_get_x_val); print_instruction(_get_x_val);
print_instruction(_get_y_val); print_instruction(_get_y_val);
print_instruction(_get_atom); print_instruction(_get_atom);
print_instruction(_get_2atoms);
print_instruction(_get_3atoms);
print_instruction(_get_4atoms);
print_instruction(_get_5atoms);
print_instruction(_get_6atoms);
print_instruction(_get_list); print_instruction(_get_list);
print_instruction(_get_struct); print_instruction(_get_struct);
fprintf(Yap_stderr, "\n Optimised Get Instructions\n"); fprintf(Yap_stderr, "\n Optimised Get Instructions\n");
@ -342,7 +347,12 @@ p_show_ops_by_group(void)
c_get.nyval = c_get.nyval =
Yap_opcount[_get_y_val]; Yap_opcount[_get_y_val];
c_get.ncons = c_get.ncons =
Yap_opcount[_get_atom]; Yap_opcount[_get_atom]+
Yap_opcount[_get_2atoms]+
Yap_opcount[_get_3atoms]+
Yap_opcount[_get_4atoms]+
Yap_opcount[_get_5atoms]+
Yap_opcount[_get_6atoms];
c_get.nlist = c_get.nlist =
Yap_opcount[_get_list] + Yap_opcount[_get_list] +
Yap_opcount[_glist_valx] + Yap_opcount[_glist_valx] +

46
C/attvar.c
View File

@ -31,7 +31,7 @@ static char SccsId[]="%W% %G%";
#ifdef COROUTINING #ifdef COROUTINING
STATIC_PROTO(Term InitVarTime, (void)); STATIC_PROTO(Term InitVarTime, (void));
STATIC_PROTO(Int PutAtt, (attvar_record *,Int,Term)); STATIC_PROTO(void PutAtt, (attvar_record *,Int,Term));
STATIC_PROTO(Int BuildNewAttVar, (Term,Int,Term)); STATIC_PROTO(Int BuildNewAttVar, (Term,Int,Term));
static CELL * static CELL *
@ -240,7 +240,7 @@ InitVarTime(void) {
#endif #endif
} }
static Int static void
PutAtt(attvar_record *attv, Int i, Term tatt) { PutAtt(attvar_record *attv, Int i, Term tatt) {
Int pos = i*2; Int pos = i*2;
#if FROZEN_STACKS #if FROZEN_STACKS
@ -276,7 +276,6 @@ PutAtt(attvar_record *attv, Int i, Term tatt) {
MaBind(attv->Atts+pos, tnewt); MaBind(attv->Atts+pos, tnewt);
} }
#endif #endif
return(TRUE);
} }
static Int static Int
@ -288,7 +287,8 @@ UpdateAtt(attvar_record *attv, Int i, Term tatt) {
} else { } else {
tatt = MkPairTerm(tatt, TermNil); tatt = MkPairTerm(tatt, TermNil);
} }
return PutAtt(attv, i, tatt); PutAtt(attv, i, tatt);
return TRUE;
} }
static Int static Int
@ -344,17 +344,7 @@ BuildNewAttVar(Term t, Int i, Term tatt)
attvar_record *attv = (attvar_record *)Yap_ReadTimedVar(DelayedVars); attvar_record *attv = (attvar_record *)Yap_ReadTimedVar(DelayedVars);
if (H0 - (CELL *)attv < 1024+(2*NUM_OF_ATTS)) { if (H0 - (CELL *)attv < 1024+(2*NUM_OF_ATTS)) {
H[0] = t; return FALSE;
H[1] = tatt;
H += 2;
if (!Yap_growglobal(NULL)) {
Yap_Error(SYSTEM_ERROR, t, Yap_ErrorMessage);
return FALSE;
}
H -= 2;
t = H[0];
tatt = H[1];
attv = (attvar_record *)Yap_ReadTimedVar(DelayedVars);
} }
time = InitVarTime(); time = InitVarTime();
RESET_VARIABLE(&(attv->Value)); RESET_VARIABLE(&(attv->Value));
@ -380,9 +370,10 @@ BuildNewAttVar(Term t, Int i, Term tatt)
j++; j++;
tatt = TailOfTerm(tatt); tatt = TailOfTerm(tatt);
} }
return(TRUE); return TRUE;
} else { } else {
return(PutAtt(attv, i, tatt)); PutAtt(attv, i, tatt);
return TRUE;
} }
} }
@ -476,9 +467,17 @@ p_put_att(void) {
Yap_Error(TYPE_ERROR_VARIABLE,inp,"put_attributes/2"); Yap_Error(TYPE_ERROR_VARIABLE,inp,"put_attributes/2");
return(FALSE); return(FALSE);
} }
return(PutAtt(attv, IntegerOfTerm(Deref(ARG2)), Deref(ARG3))); PutAtt(attv, IntegerOfTerm(Deref(ARG2)), Deref(ARG3));
return TRUE;
} }
return(BuildNewAttVar(inp, IntegerOfTerm(Deref(ARG2)), Deref(ARG3))); while (!BuildNewAttVar(inp, IntegerOfTerm(Deref(ARG2)), Deref(ARG3))) {
if (!Yap_growglobal(NULL)) {
Yap_Error(OUT_OF_ATTVARS_ERROR, ARG1, Yap_ErrorMessage);
return FALSE;
}
inp = Deref(ARG1);
}
return TRUE;
} else { } else {
Yap_Error(TYPE_ERROR_VARIABLE,inp,"put_attributes/2"); Yap_Error(TYPE_ERROR_VARIABLE,inp,"put_attributes/2");
return(FALSE); return(FALSE);
@ -501,7 +500,14 @@ p_update_att(void) {
} }
return(UpdateAtt(attv, IntegerOfTerm(Deref(ARG2)), Deref(ARG3))); return(UpdateAtt(attv, IntegerOfTerm(Deref(ARG2)), Deref(ARG3)));
} }
return(BuildNewAttVar(inp, IntegerOfTerm(Deref(ARG2)), MkPairTerm(Deref(ARG3),TermNil))); while (!BuildNewAttVar(inp, IntegerOfTerm(Deref(ARG2)), MkPairTerm(Deref(ARG3),TermNil))) {
if (!Yap_growglobal(NULL)) {
Yap_Error(OUT_OF_ATTVARS_ERROR, ARG1, Yap_ErrorMessage);
return FALSE;
}
inp = Deref(ARG1);
}
return TRUE;
} else { } else {
Yap_Error(TYPE_ERROR_VARIABLE,inp,"put_attributes/2"); Yap_Error(TYPE_ERROR_VARIABLE,inp,"put_attributes/2");
return(FALSE); return(FALSE);

471
C/cdmgr.c
View File

@ -1,3 +1,4 @@
/************************************************************************* /*************************************************************************
* * * *
* YAP Prolog * * YAP Prolog *
@ -11,8 +12,11 @@
* File: cdmgr.c * * File: cdmgr.c *
* comments: Code manager * * comments: Code manager *
* * * *
* Last rev: $Date: 2004-09-17 19:34:51 $,$Author: vsc $ * * Last rev: $Date: 2004-09-27 20:45:02 $,$Author: vsc $ *
* $Log: not supported by cvs2svn $ * $Log: not supported by cvs2svn $
* Revision 1.132 2004/09/17 19:34:51 vsc
* simplify frozen/2
*
* Revision 1.131 2004/09/08 17:56:45 vsc * Revision 1.131 2004/09/08 17:56:45 vsc
* source: a(X) :- true is a fact! * source: a(X) :- true is a fact!
* fix use of value after possible overflow in IPred * fix use of value after possible overflow in IPred
@ -106,6 +110,7 @@ STATIC_PROTO(void assertz_stat_clause, (PredEntry *, yamop *, int));
STATIC_PROTO(void assertz_dynam_clause, (PredEntry *, yamop *)); STATIC_PROTO(void assertz_dynam_clause, (PredEntry *, yamop *));
STATIC_PROTO(void expand_consult, (void)); STATIC_PROTO(void expand_consult, (void));
STATIC_PROTO(int not_was_reconsulted, (PredEntry *, Term, int)); STATIC_PROTO(int not_was_reconsulted, (PredEntry *, Term, int));
STATIC_PROTO(int RemoveIndexation, (PredEntry *));
#if EMACS #if EMACS
STATIC_PROTO(int last_clause_number, (PredEntry *)); STATIC_PROTO(int last_clause_number, (PredEntry *));
#endif #endif
@ -155,6 +160,72 @@ STATIC_PROTO(void kill_first_log_iblock,(LogUpdIndex *, LogUpdIndex *, PredEntr
#define IN_BLOCK(P,B,SZ) ((CODEADDR)(P) >= (CODEADDR)(B) && \ #define IN_BLOCK(P,B,SZ) ((CODEADDR)(P) >= (CODEADDR)(B) && \
(CODEADDR)(P) < (CODEADDR)(B)+(SZ)) (CODEADDR)(P) < (CODEADDR)(B)+(SZ))
static PredEntry *
PredForChoicePt(choiceptr cp) {
yamop *p_code = cp->cp_ap;
if (cp == NULL)
return NULL;
while (TRUE) {
op_numbers opnum = Yap_op_from_opcode(p_code->opc);
switch(opnum) {
case _Nstop:
return NULL;
#ifdef TABLING
case _trie_retry_var:
case _trie_trust_var:
case _trie_retry_val:
case _trie_trust_val:
case _trie_retry_atom:
case _trie_trust_atom:
case _trie_retry_list:
case _trie_trust_list:
case _trie_retry_struct:
case _trie_trust_struct:
return NULL;
case _table_completion:
case _table_answer_resolution:
return ENV_ToP(gc_B->cp_cp);
#endif
case _or_else:
if (p_code ==
#ifdef YAPOR
p_code->u.ldl.l
#else
p_code->u.sla.sla_u.l
#endif
) {
/* repeat */
Atom at = Yap_LookupAtom("repeat ");
return RepPredProp(PredPropByAtom(at, PROLOG_MODULE));
}
case _or_last:
#ifdef YAPOR
return p_code->u.ldl.p;
#else
return p_code->u.sla.p0;
#endif
break;
case _trust_logical_pred:
case _count_retry_me:
case _retry_profiled:
case _retry2:
case _retry3:
case _retry4:
p_code = NEXTOP(p_code,l);
break;
default:
return p_code->u.ld.p;
}
}
return NULL;
}
PredEntry *
Yap_PredForChoicePt(choiceptr cp) {
return PredForChoicePt(cp);
}
/****************************************************************** /******************************************************************
EXECUTING PROLOG CLAUSES EXECUTING PROLOG CLAUSES
@ -204,6 +275,141 @@ static_in_use(PredEntry *p, int check_everything)
#define is_tabled(pe) (pe->PredFlags & TabledPredFlag) #define is_tabled(pe) (pe->PredFlags & TabledPredFlag)
#endif /* TABLING */ #endif /* TABLING */
/******************************************************************
Mega Clauses
******************************************************************/
void
Yap_BuildMegaClause(PredEntry *ap)
{
StaticClause *cl;
UInt sz;
MegaClause *mcl;
yamop *ptr;
UInt required;
UInt has_blobs = 0;
if (ap->PredFlags & (DynamicPredFlag|LogUpdatePredFlag|MegaClausePredFlag
#ifdef TABLING
|TabledPredFlag
#endif
) ||
ap->cs.p_code.FirstClause == NULL ||
ap->cs.p_code.NOfClauses < 16) {
return;
}
cl =
ClauseCodeToStaticClause(ap->cs.p_code.FirstClause);
sz = cl->ClSize;
while (TRUE) {
if (!(cl->ClFlags & FactMask)) return; /* no mega clause, sorry */
if (cl->ClSize != sz) return; /* no mega clause, sorry */
if (cl->ClCode == ap->cs.p_code.LastClause)
break;
has_blobs |= (cl->ClFlags & HasBlobsMask);
cl = cl->ClNext;
}
/* ok, we got the chance for a mega clause */
if (has_blobs) {
sz -= sizeof(StaticClause);
return;
} else
sz -= (UInt)NEXTOP((yamop *)NULL,e) + sizeof(StaticClause);
required = sz*ap->cs.p_code.NOfClauses+sizeof(MegaClause)+(UInt)NEXTOP((yamop *)NULL,e);
while (!(mcl = (MegaClause *)Yap_AllocCodeSpace(required))) {
if (!Yap_growheap(FALSE, sizeof(consult_obj)*ConsultCapacity, NULL)) {
/* just fail, the system will keep on going */
return;
}
}
/* cool, it's our turn to do the conversion */
mcl->ClFlags = MegaMask | has_blobs;
mcl->ClSize = sz*ap->cs.p_code.NOfClauses;
mcl->ClPred = ap;
mcl->ClItemSize = sz;
cl =
ClauseCodeToStaticClause(ap->cs.p_code.FirstClause);
ptr = mcl->ClCode;
while (TRUE) {
memcpy((void *)ptr, (void *)cl->ClCode, sz);
ptr = (yamop *)((char *)ptr + sz);
if (cl->ClCode == ap->cs.p_code.LastClause)
break;
cl = cl->ClNext;
}
ptr->opc = Yap_opcode(_Ystop);
cl =
ClauseCodeToStaticClause(ap->cs.p_code.FirstClause);
/* recover the space spent on the original clauses */
while (TRUE) {
StaticClause *ncl;
ncl = cl->ClNext;
Yap_FreeCodeSpace((ADDR)cl);
if (cl->ClCode == ap->cs.p_code.LastClause)
break;
cl = ncl;
}
ap->cs.p_code.FirstClause =
ap->cs.p_code.LastClause =
mcl->ClCode;
ap->PredFlags |= MegaClausePredFlag;
}
static void
split_megaclause(PredEntry *ap)
{
StaticClause *start = NULL, *prev = NULL;
MegaClause *mcl;
yamop *ptr;
UInt ncls = ap->cs.p_code.NOfClauses, i;
WRITE_LOCK(ap->PRWLock);
RemoveIndexation(ap);
mcl =
ClauseCodeToMegaClause(ap->cs.p_code.FirstClause);
for (i = 0, ptr = mcl->ClCode; i < ncls; i++) {
StaticClause *new = (StaticClause *)Yap_AllocCodeSpace(sizeof(StaticClause)+mcl->ClItemSize);
if (new == NULL) {
if (!Yap_growheap(FALSE, (sizeof(StaticClause)+mcl->ClItemSize)*(ncls-i), NULL)) {
while (start) {
StaticClause *cl = start;
start = cl->ClNext;
Yap_FreeCodeSpace((char *)cl);
}
if (ap->ArityOfPE) {
Yap_Error(OUT_OF_HEAP_ERROR,TermNil,"while breaking up mega clause for %s/%d\n",RepAtom(NameOfFunctor(ap->FunctorOfPred))->StrOfAE,ap->ArityOfPE);
} else {
Yap_Error(OUT_OF_HEAP_ERROR,TermNil,"while breaking up mega clause for %s\n", RepAtom((Atom)ap->FunctorOfPred)->StrOfAE);
}
}
new->ClFlags = FactMask;
new->ClSize = mcl->ClItemSize;
new->usc.ClPred = ap;
new->ClNext = NULL;
memcpy((void *)new->ClCode, (void *)ptr, mcl->ClItemSize);
if (prev) {
prev->ClNext = new;
} else {
start = new;
}
ptr = (yamop *)((char *)ptr + mcl->ClItemSize);
prev = new;
}
}
ap->PredFlags &= ~MegaClausePredFlag;
ap->cs.p_code.FirstClause = start->ClCode;
ap->cs.p_code.LastClause = prev->ClCode;
WRITE_UNLOCK(ap->PRWLock);
}
/****************************************************************** /******************************************************************
Indexation Info Indexation Info
@ -337,6 +543,19 @@ release_wcls(yamop *cop, OPCODE ecs)
if (cop->opc == ecs) { if (cop->opc == ecs) {
cop->u.sp.s3--; cop->u.sp.s3--;
if (!cop->u.sp.s3) { if (!cop->u.sp.s3) {
LOCK(ExpandClausesListLock);
if (ExpandClausesFirst == cop)
ExpandClausesFirst = cop->u.sp.snext;
if (ExpandClausesLast == cop) {
ExpandClausesLast = cop->u.sp.sprev;
}
if (cop->u.sp.sprev) {
cop->u.sp.sprev->u.sp.snext = cop->u.sp.snext;
}
if (cop->u.sp.snext) {
cop->u.sp.snext->u.sp.sprev = cop->u.sp.sprev;
}
UNLOCK(ExpandClausesListLock);
#if DEBUG #if DEBUG
Yap_expand_clauses_sz -= (UInt)(NEXTOP((yamop *)NULL,sp)+cop->u.sp.s1*sizeof(yamop *)); Yap_expand_clauses_sz -= (UInt)(NEXTOP((yamop *)NULL,sp)+cop->u.sp.s1*sizeof(yamop *));
#endif #endif
@ -374,6 +593,17 @@ cleanup_dangling_indices(yamop *ipc, yamop *beg, yamop *end, yamop *suspend_code
case _count_retry: case _count_retry:
ipc = NEXTOP(ipc,p); ipc = NEXTOP(ipc,p);
break; break;
case _try_clause2:
case _try_clause3:
case _try_clause4:
ipc = NEXTOP(ipc,l);
break;
case _retry2:
case _retry3:
case _retry4:
decrease_ref_counter(ipc->u.l.l, beg, end, suspend_code);
ipc = NEXTOP(ipc,l);
break;
case _retry: case _retry:
case _trust: case _trust:
decrease_ref_counter(ipc->u.ld.d, beg, end, suspend_code); decrease_ref_counter(ipc->u.ld.d, beg, end, suspend_code);
@ -459,6 +689,7 @@ cleanup_dangling_indices(yamop *ipc, yamop *beg, yamop *end, yamop *suspend_code
break; break;
default: default:
Yap_Error(SYSTEM_ERROR,TermNil,"Bug in Indexing Code: opcode %d", op); Yap_Error(SYSTEM_ERROR,TermNil,"Bug in Indexing Code: opcode %d", op);
return;
} }
#if defined(YAPOR) || defined(THREADS) #if defined(YAPOR) || defined(THREADS)
ipc = (yamop *)((CELL)ipc & ~1); ipc = (yamop *)((CELL)ipc & ~1);
@ -765,6 +996,20 @@ retract_all(PredEntry *p, int in_use)
Yap_ErLogUpdCl(cl); Yap_ErLogUpdCl(cl);
cl = ncl; cl = ncl;
} while (cl != NULL); } while (cl != NULL);
} else if (p->PredFlags & MegaClausePredFlag) {
MegaClause *cl = ClauseCodeToMegaClause(q);
if (cl->ClFlags & HasBlobsMask) {
DeadClause *dcl = (DeadClause *)cl;
UInt sz = cl->ClSize;
dcl->NextCl = DeadClauses;
dcl->ClFlags = 0;
dcl->ClSize = sz;
DeadClauses = dcl;
} else {
Yap_FreeCodeSpace((char *)cl);
}
p->cs.p_code.NOfClauses = 0;
} else { } else {
StaticClause *cl = ClauseCodeToStaticClause(q); StaticClause *cl = ClauseCodeToStaticClause(q);
@ -1115,7 +1360,7 @@ static void expand_consult(void)
/* I assume it always works ;-) */ /* I assume it always works ;-) */
while ((new_cl = (consult_obj *)Yap_AllocCodeSpace(sizeof(consult_obj)*ConsultCapacity)) == NULL) { while ((new_cl = (consult_obj *)Yap_AllocCodeSpace(sizeof(consult_obj)*ConsultCapacity)) == NULL) {
if (!Yap_growheap(FALSE, sizeof(consult_obj)*ConsultCapacity, NULL)) { if (!Yap_growheap(FALSE, sizeof(consult_obj)*ConsultCapacity, NULL)) {
Yap_Error(SYSTEM_ERROR,TermNil,Yap_ErrorMessage); Yap_Error(OUT_OF_HEAP_ERROR,TermNil,Yap_ErrorMessage);
return; return;
} }
} }
@ -1258,6 +1503,10 @@ addclause(Term t, yamop *cp, int mode, int mod)
addcl_permission_error(RepAtom(at), Arity, FALSE); addcl_permission_error(RepAtom(at), Arity, FALSE);
return TermNil; return TermNil;
} }
/* we are redefining a prolog module predicate */
if (pflags & MegaClausePredFlag) {
split_megaclause(p);
}
/* The only problem we have now is when we need to throw away /* The only problem we have now is when we need to throw away
Indexing blocks Indexing blocks
*/ */
@ -1331,7 +1580,7 @@ addclause(Term t, yamop *cp, int mode, int mod)
if (pflags & LogUpdatePredFlag) { if (pflags & LogUpdatePredFlag) {
return MkDBRefTerm((DBRef)ClauseCodeToLogUpdClause(cp)); return MkDBRefTerm((DBRef)ClauseCodeToLogUpdClause(cp));
} else { } else {
return MkIntegerTerm((Int)cp); return Yap_MkStaticRefTerm((StaticClause *)cp);
} }
} }
@ -1340,6 +1589,12 @@ Yap_addclause(Term t, yamop *cp, int mode, Term mod) {
addclause(t, cp, mode, mod); addclause(t, cp, mode, mod);
} }
void
Yap_EraseMegaClause(yamop *cl,PredEntry *ap) {
/* just make it fail */
cl->opc = Yap_opcode(_op_fail);
}
void void
Yap_EraseStaticClause(StaticClause *cl, Term mod) { Yap_EraseStaticClause(StaticClause *cl, Term mod) {
PredEntry *ap; PredEntry *ap;
@ -1730,50 +1985,10 @@ p_endconsult(void)
static void static void
purge_clauses(PredEntry *pred) purge_clauses(PredEntry *pred)
{ {
yamop *q;
int in_use;
if (pred->PredFlags & IndexedPredFlag) if (pred->PredFlags & IndexedPredFlag)
RemoveIndexation(pred); RemoveIndexation(pred);
Yap_PutValue(AtomAbol, MkAtomTerm(AtomTrue)); Yap_PutValue(AtomAbol, MkAtomTerm(AtomTrue));
q = pred->cs.p_code.FirstClause; retract_all(pred, static_in_use(pred,TRUE));
in_use = static_in_use(pred,TRUE);
if (q != NULL) {
if (pred->PredFlags & LogUpdatePredFlag) {
LogUpdClause *cl = ClauseCodeToLogUpdClause(q);
do {
LogUpdClause *ncl = cl->ClNext;
Yap_ErLogUpdCl(cl);
cl = ncl;
} while (cl != NULL);
} else {
StaticClause *cl = ClauseCodeToStaticClause(q);
do {
if (cl->ClFlags & HasBlobsMask || in_use) {
DeadClause *dcl = (DeadClause *)cl;
UInt sz = cl->ClSize;
dcl->NextCl = DeadClauses;
dcl->ClFlags = 0;
dcl->ClSize = sz;
DeadClauses = dcl;
} else {
Yap_FreeCodeSpace((char *)cl);
}
if (cl->ClCode == pred->cs.p_code.LastClause) break;
cl = cl->ClNext;
} while (TRUE);
}
}
pred->cs.p_code.FirstClause = pred->cs.p_code.LastClause = NULL;
if (pred->PredFlags & (DynamicPredFlag|LogUpdatePredFlag)) {
pred->OpcodeOfPred = FAIL_OPCODE;
} else {
pred->OpcodeOfPred = UNDEF_OPCODE;
}
pred->cs.p_code.TrueCodeOfPred =
pred->CodeOfPred =
(yamop *)(&(pred->OpcodeOfPred));
pred->src.OwnerFile = AtomNil; pred->src.OwnerFile = AtomNil;
if (pred->PredFlags & MultiFileFlag) if (pred->PredFlags & MultiFileFlag)
pred->PredFlags ^= MultiFileFlag; pred->PredFlags ^= MultiFileFlag;
@ -2440,6 +2655,8 @@ search_for_static_predicate_in_use(PredEntry *p, int check_everything)
if (p == pe) return TRUE; if (p == pe) return TRUE;
} }
do { do {
PredEntry *pe;
/* check first environments that are younger than our latest choicepoint */ /* check first environments that are younger than our latest choicepoint */
if (check_everything && env_ptr) { if (check_everything && env_ptr) {
/* /*
@ -2454,58 +2671,38 @@ search_for_static_predicate_in_use(PredEntry *p, int check_everything)
} }
} }
/* now mark the choicepoint */ /* now mark the choicepoint */
if (b_ptr != NULL) {
PredEntry *pe;
op_numbers opnum = Yap_op_from_opcode(b_ptr->cp_ap->opc);
restart_cp: pe = PredForChoicePt(b_ptr);
switch(opnum) { if (pe == p) {
case _or_else: if (check_everything)
case _or_last: return TRUE;
if (!check_everything) { READ_LOCK(pe->PRWLock);
b_ptr = b_ptr->cp_b; if (p->PredFlags & IndexedPredFlag) {
continue; yamop *code_p = b_ptr->cp_ap;
} yamop *code_beg = p->cs.p_code.TrueCodeOfPred;
#ifdef YAPOR
pe = b_ptr->cp_cp->u.ldl.p;
#else
pe = b_ptr->cp_cp->u.sla.p0;
#endif /* YAPOR */
break;
case _retry_profiled:
opnum = Yap_op_from_opcode(NEXTOP(b_ptr->cp_ap,l)->opc);
goto restart_cp;
case _count_retry:
opnum = Yap_op_from_opcode(NEXTOP(b_ptr->cp_ap,l)->opc);
goto restart_cp;
default:
pe = (PredEntry *)(b_ptr->cp_ap->u.ld.p);
}
if (pe == p) {
if (check_everything)
return TRUE;
READ_LOCK(pe->PRWLock);
if (p->PredFlags & IndexedPredFlag) {
yamop *code_p = b_ptr->cp_ap;
yamop *code_beg = p->cs.p_code.TrueCodeOfPred;
if (p->PredFlags & LogUpdatePredFlag) { /* FIX ME */
LogUpdIndex *cl = ClauseCodeToLogUpdIndex(code_beg);
if (find_owner_log_index(cl, code_p)) if (p->PredFlags & LogUpdatePredFlag) {
b_ptr->cp_ap = cur_log_upd_clause(pe, b_ptr->cp_ap->u.ld.d); LogUpdIndex *cl = ClauseCodeToLogUpdIndex(code_beg);
} else { if (find_owner_log_index(cl, code_p))
/* static clause */ b_ptr->cp_ap = cur_log_upd_clause(pe, b_ptr->cp_ap->u.ld.d);
StaticIndex *cl = ClauseCodeToStaticIndex(code_beg); } else if (p->PredFlags & MegaClausePredFlag) {
if (find_owner_static_index(cl, code_p)) { StaticIndex *cl = ClauseCodeToStaticIndex(code_beg);
b_ptr->cp_ap = cur_clause(pe, b_ptr->cp_ap->u.ld.d); if (find_owner_static_index(cl, code_p))
} b_ptr->cp_ap = cur_clause(pe, b_ptr->cp_ap->u.ld.d);
} else {
/* static clause */
StaticIndex *cl = ClauseCodeToStaticIndex(code_beg);
if (find_owner_static_index(cl, code_p)) {
b_ptr->cp_ap = cur_clause(pe, b_ptr->cp_ap->u.ld.d);
} }
} }
READ_UNLOCK(pe->PRWLock);
} }
env_ptr = b_ptr->cp_env; READ_UNLOCK(pe->PRWLock);
b_ptr = b_ptr->cp_b;
} }
env_ptr = b_ptr->cp_env;
b_ptr = b_ptr->cp_b;
} while (b_ptr != NULL); } while (b_ptr != NULL);
return(FALSE); return(FALSE);
} }
@ -2547,37 +2744,11 @@ do_toggle_static_predicates_in_use(int mask)
env_ptr = (CELL *)(env_ptr[E_E]); env_ptr = (CELL *)(env_ptr[E_E]);
} }
/* now mark the choicepoint */ /* now mark the choicepoint */
{ if ((pe = PredForChoicePt(b_ptr))) {
op_numbers opnum;
restart_cp:
opnum = Yap_op_from_opcode(b_ptr->cp_ap->opc);
switch(opnum) {
case _or_else:
case _or_last:
#ifdef YAPOR
pe = b_ptr->cp_cp->u.ldl.p;
#else
pe = b_ptr->cp_cp->u.sla.p0;
#endif /* YAPOR */
break;
case _Nstop:
pe = NULL;
break;
case _retry_profiled:
opnum = Yap_op_from_opcode(NEXTOP(b_ptr->cp_ap,l)->opc);
goto restart_cp;
case _count_retry:
opnum = Yap_op_from_opcode(NEXTOP(b_ptr->cp_ap,l)->opc);
goto restart_cp;
default:
pe = (PredEntry *)(b_ptr->cp_ap->u.ld.p);
}
if (pe != NULL)
mark_pred(mask, pe); mark_pred(mask, pe);
env_ptr = b_ptr->cp_env;
b_ptr = b_ptr->cp_b;
} }
env_ptr = b_ptr->cp_env;
b_ptr = b_ptr->cp_b;
} while (b_ptr != NULL); } while (b_ptr != NULL);
/* mark or unmark all predicates */ /* mark or unmark all predicates */
STATIC_PREDICATES_MARKED = mask; STATIC_PREDICATES_MARKED = mask;
@ -2802,6 +2973,15 @@ code_in_pred(PredEntry *pp, Atom *pat, UInt *parity, yamop *codeptr) {
i++; i++;
clcode = NextDynamicClause(clcode); clcode = NextDynamicClause(clcode);
} while (TRUE); } while (TRUE);
} else if (pp->PredFlags & MegaClausePredFlag) {
MegaClause *cl;
cl = ClauseCodeToMegaClause(clcode);
if (IN_BLOCK(codeptr,cl,cl->ClSize)) {
clause_was_found(pp, pat, parity);
READ_UNLOCK(pp->PRWLock);
return 1+((char *)codeptr-(char *)cl->ClCode)/cl->ClItemSize;
}
} else { } else {
StaticClause *cl; StaticClause *cl;
@ -2864,6 +3044,8 @@ p_pred_for_code(void) {
if (IsVarTerm(t)) { if (IsVarTerm(t)) {
return FALSE; return FALSE;
} else if (IsApplTerm(t) && FunctorOfTerm(t) == FunctorStaticClause) {
codeptr = Yap_ClauseFromTerm(t)->ClCode;
} else if (IsIntegerTerm(t)) { } else if (IsIntegerTerm(t)) {
codeptr = (yamop *)IntegerOfTerm(t); codeptr = (yamop *)IntegerOfTerm(t);
} else if (IsDBRefTerm(t)) { } else if (IsDBRefTerm(t)) {
@ -3399,7 +3581,7 @@ fetch_next_lu_clause0(PredEntry *pe, yamop *i_code, Term th, Term tb, yamop *cp_
Terms[0] = th; Terms[0] = th;
Terms[1] = tb; Terms[1] = tb;
Terms[2] = TermNil; Terms[2] = TermNil;
cl = Yap_FollowIndexingCode(pe, i_code, Terms, NEXTOP(PredLogUpdClause0->CodeOfPred,ld), cp_ptr); cl = Yap_FollowIndexingCode(pe, i_code, Terms, NEXTOP(PredLogUpdClause0->CodeOfPred,l), cp_ptr);
th = Yap_GetFromSlot(slh); th = Yap_GetFromSlot(slh);
tb = Yap_GetFromSlot(slb); tb = Yap_GetFromSlot(slb);
/* don't do this!! I might have stored a choice-point and changed ASP /* don't do this!! I might have stored a choice-point and changed ASP
@ -3520,7 +3702,32 @@ fetch_next_static_clause(PredEntry *pe, yamop *i_code, Term th, Term tb, Term tr
*/ */
if (cl == NULL) if (cl == NULL)
return FALSE; return FALSE;
rtn = MkDBRefTerm((DBRef)cl); if (pe->PredFlags & MegaClausePredFlag) {
yamop *code = (yamop *)cl;
rtn = Yap_MkMegaRefTerm(pe,code);
if (!Yap_unify(tb, MkAtomTerm(AtomTrue)) ||
!Yap_unify(tr, rtn))
return FALSE;
if (pe->ArityOfPE) {
Functor f = FunctorOfTerm(th);
UInt arity = ArityOfFunctor(f), i;
CELL *pt = RepAppl(th)+1;
for (i=0; i<arity; i++) {
XREGS[i+1] = pt[i];
}
/* don't need no ENV */
if (first_time) {
CP = P;
ENV = YENV;
YENV = ASP;
YENV[E_CB] = (CELL) B;
}
P = code;
}
return TRUE;
}
rtn = Yap_MkStaticRefTerm(cl);
if (cl->ClFlags & FactMask) { if (cl->ClFlags & FactMask) {
if (!Yap_unify(tb, MkAtomTerm(AtomTrue)) || if (!Yap_unify(tb, MkAtomTerm(AtomTrue)) ||
!Yap_unify(tr, rtn)) !Yap_unify(tr, rtn))
@ -3629,7 +3836,7 @@ p_nth_clause(void)
cl = Yap_NthClause(pe, ncls); cl = Yap_NthClause(pe, ncls);
if (cl == NULL) if (cl == NULL)
return FALSE; return FALSE;
if (cl->ClFlags & LogUpdatePredFlag) { if (pe->PredFlags & LogUpdatePredFlag) {
#if defined(YAPOR) || defined(THREADS) #if defined(YAPOR) || defined(THREADS)
LOCK(cl->ClLock); LOCK(cl->ClLock);
TRAIL_CLREF(cl); /* So that fail will erase it */ TRAIL_CLREF(cl); /* So that fail will erase it */
@ -3641,8 +3848,12 @@ p_nth_clause(void)
TRAIL_CLREF(cl); /* So that fail will erase it */ TRAIL_CLREF(cl); /* So that fail will erase it */
} }
#endif #endif
return Yap_unify(MkDBRefTerm((DBRef)cl), ARG4);
} else if (pe->PredFlags & MegaClausePredFlag) {
return Yap_unify(Yap_MkMegaRefTerm(pe,(yamop *)cl), ARG4);
} else {
return Yap_unify(Yap_MkStaticRefTerm((StaticClause *)cl), ARG4);
} }
return Yap_unify(MkDBRefTerm((DBRef)cl), ARG4);
} }
static Int /* $hidden_predicate(P) */ static Int /* $hidden_predicate(P) */
@ -3771,6 +3982,16 @@ static_statistics(PredEntry *pe)
UInt sz = 0, cls = 0, isz = 0; UInt sz = 0, cls = 0, isz = 0;
StaticClause *cl = ClauseCodeToStaticClause(pe->cs.p_code.FirstClause); StaticClause *cl = ClauseCodeToStaticClause(pe->cs.p_code.FirstClause);
if (pe->cs.p_code.NOfClauses > 1 &&
pe->cs.p_code.TrueCodeOfPred != pe->cs.p_code.FirstClause) {
isz = index_ssz(ClauseCodeToStaticIndex(pe->cs.p_code.TrueCodeOfPred));
}
if (pe->PredFlags & MegaClausePredFlag) {
MegaClause *mcl = ClauseCodeToMegaClause(pe->cs.p_code.FirstClause);
return Yap_unify(ARG3, MkIntegerTerm(mcl->ClSize/mcl->ClItemSize)) &&
Yap_unify(ARG4, MkIntegerTerm(mcl->ClSize)) &&
Yap_unify(ARG5, MkIntegerTerm(isz));
}
if (pe->cs.p_code.NOfClauses) { if (pe->cs.p_code.NOfClauses) {
do { do {
cls++; cls++;
@ -3780,10 +4001,6 @@ static_statistics(PredEntry *pe)
cl = cl->ClNext; cl = cl->ClNext;
} while (TRUE); } while (TRUE);
} }
if (pe->cs.p_code.NOfClauses > 1 &&
pe->cs.p_code.TrueCodeOfPred != pe->cs.p_code.FirstClause) {
isz = index_ssz(ClauseCodeToStaticIndex(pe->cs.p_code.TrueCodeOfPred));
}
return Yap_unify(ARG3, MkIntegerTerm(cls)) && return Yap_unify(ARG3, MkIntegerTerm(cls)) &&
Yap_unify(ARG4, MkIntegerTerm(sz)) && Yap_unify(ARG4, MkIntegerTerm(sz)) &&
Yap_unify(ARG5, MkIntegerTerm(isz)); Yap_unify(ARG5, MkIntegerTerm(isz));

114
C/dbase.c
View File

@ -713,14 +713,12 @@ static CELL *MkDBTerm(register CELL *pt0, register CELL *pt0_end,
#ifdef IDB_LINK_TABLE #ifdef IDB_LINK_TABLE
dbg->lr--; dbg->lr--;
#endif #endif
if (!(dbentry->Flags & StaticMask)) { if (dbentry->Flags & LogUpdMask) {
if (dbentry->Flags & LogUpdMask) { LogUpdClause *cl = (LogUpdClause *)dbentry;
LogUpdClause *cl = (LogUpdClause *)dbentry;
cl->ClRefCount++; cl->ClRefCount++;
} else { } else {
dbentry->NOfRefsTo++; dbentry->NOfRefsTo++;
}
} }
*--dbg->tofref = dbentry; *--dbg->tofref = dbentry;
db_check_trail(dbg->lr); db_check_trail(dbg->lr);
@ -2394,8 +2392,8 @@ static int
copy_attachments(CELL *ts) copy_attachments(CELL *ts)
{ {
while (TRUE) { while (TRUE) {
attvar_record *orig = (attvar_record *)Yap_ReadTimedVar(DelayedVars); attvar_record *orig = (attvar_record *)Yap_ReadTimedVar(DelayedVars);
/* store away in case there is an overflow */ /* store away in case there is an overflow */
if (attas[IntegerOfTerm(ts[2])].term_to_op(ts[1], ts[0]) == FALSE) { if (attas[IntegerOfTerm(ts[2])].term_to_op(ts[1], ts[0]) == FALSE) {
/* oops, we did not have enough space to copy the elements */ /* oops, we did not have enough space to copy the elements */
@ -3775,44 +3773,6 @@ p_key_erased_statistics(void)
Yap_unify(ARG5,MkIntegerTerm(isz)); Yap_unify(ARG5,MkIntegerTerm(isz));
} }
static Int
p_predicate_erased_statistics(void)
{
UInt sz = 0, cls = 0;
UInt isz = 0, icls = 0;
Term twork = Deref(ARG1);
PredEntry *pe;
LogUpdClause *cl = DBErasedList;
LogUpdIndex *icl = DBErasedIList;
/* only for log upds */
if ((pe = find_lu_entry(twork)) == NULL)
return FALSE;
while (cl) {
if (cl->ClPred == pe) {
cls++;
sz += cl->ClSize;
}
cl = cl->ClNext;
}
while (icl) {
LogUpdIndex *c = icl;
while (!c->ClFlags & SwitchRootMask)
c = c->u.ParentIndex;
if (pe == c->u.pred) {
icls++;
isz += c->ClSize;
}
icl = icl->SiblingIndex;
}
return
Yap_unify(ARG2,MkIntegerTerm(cls)) &&
Yap_unify(ARG3,MkIntegerTerm(sz)) &&
Yap_unify(ARG4,MkIntegerTerm(icls)) &&
Yap_unify(ARG5,MkIntegerTerm(isz));
}
static Int static Int
p_heap_space_info(void) p_heap_space_info(void)
{ {
@ -4312,9 +4272,6 @@ EraseEntry(DBRef entryref)
if (entryref->Flags & ErasedMask) if (entryref->Flags & ErasedMask)
return; return;
if (entryref->Flags & StaticMask) {
return;
}
if (entryref->Flags & LogUpdMask && if (entryref->Flags & LogUpdMask &&
!(entryref->Flags & DBClMask)) { !(entryref->Flags & DBClMask)) {
EraseLogUpdCl((LogUpdClause *)entryref); EraseLogUpdCl((LogUpdClause *)entryref);
@ -4383,17 +4340,21 @@ p_erase_clause(void)
return (FALSE); return (FALSE);
} }
if (!IsDBRefTerm(t1)) { if (!IsDBRefTerm(t1)) {
if (IsApplTerm(t1)) {
if (FunctorOfTerm(t1) == FunctorStaticClause) {
Yap_EraseStaticClause(Yap_ClauseFromTerm(t1), Deref(ARG2));
return TRUE;
}
if (FunctorOfTerm(t1) == FunctorMegaClause) {
Yap_EraseMegaClause(Yap_MegaClauseFromTerm(t1), Yap_MegaClausePredicateFromTerm(t1));
return TRUE;
}
}
Yap_Error(TYPE_ERROR_DBREF, t1, "erase"); Yap_Error(TYPE_ERROR_DBREF, t1, "erase");
return (FALSE); return (FALSE);
} else { } else {
entryref = DBRefOfTerm(t1); entryref = DBRefOfTerm(t1);
} }
if (entryref->Flags & StaticMask) {
if (entryref->Flags & ErasedMask)
return FALSE;
Yap_EraseStaticClause((StaticClause *)entryref, Deref(ARG2));
return TRUE;
}
EraseEntry(entryref); EraseEntry(entryref);
return TRUE; return TRUE;
} }
@ -4539,6 +4500,34 @@ static_instance(StaticClause *cl)
} }
} }
static Int
mega_instance(yamop *code, PredEntry *ap)
{
if (ap->ArityOfPE == 0) {
return Yap_unify(ARG2,MkAtomTerm((Atom)ap->FunctorOfPred));
} else {
Functor f = ap->FunctorOfPred;
UInt arity = ArityOfFunctor(ap->FunctorOfPred), i;
Term t2 = Deref(ARG2);
CELL *ptr;
if (IsVarTerm(t2)) {
Yap_unify(ARG2, (t2 = Yap_MkNewApplTerm(f,arity)));
} else if (!IsApplTerm(t2) || FunctorOfTerm(t2) != f) {
return FALSE;
}
ptr = RepAppl(t2)+1;
for (i=0; i<arity; i++) {
XREGS[i+1] = ptr[i];
}
CP = P;
YENV = ASP;
YENV[E_CB] = (CELL) B;
P = code;
return TRUE;
}
}
/* instance(+Ref,?Term) */ /* instance(+Ref,?Term) */
static Int static Int
p_instance(void) p_instance(void)
@ -4547,13 +4536,19 @@ p_instance(void)
DBRef dbr; DBRef dbr;
if (IsVarTerm(t1) || !IsDBRefTerm(t1)) { if (IsVarTerm(t1) || !IsDBRefTerm(t1)) {
return (FALSE); if (IsApplTerm(t1)) {
if (FunctorOfTerm(t1) == FunctorStaticClause) {
return static_instance(Yap_ClauseFromTerm(t1));
}
if (FunctorOfTerm(t1) == FunctorMegaClause) {
return mega_instance(Yap_MegaClauseFromTerm(t1),Yap_MegaClausePredicateFromTerm(t1));
}
}
return FALSE;
} else { } else {
dbr = DBRefOfTerm(t1); dbr = DBRefOfTerm(t1);
} }
if (dbr->Flags & StaticMask) { if (dbr->Flags & LogUpdMask) {
return static_instance((StaticClause *)dbr);
} else if (dbr->Flags & LogUpdMask) {
op_numbers opc; op_numbers opc;
LogUpdClause *cl = (LogUpdClause *)dbr; LogUpdClause *cl = (LogUpdClause *)dbr;
@ -5224,7 +5219,6 @@ Yap_InitDBPreds(void)
#ifdef DEBUG #ifdef DEBUG
Yap_InitCPred("total_erased", 4, p_total_erased, SyncPredFlag); Yap_InitCPred("total_erased", 4, p_total_erased, SyncPredFlag);
Yap_InitCPred("key_erased_statistics", 5, p_key_erased_statistics, SyncPredFlag); Yap_InitCPred("key_erased_statistics", 5, p_key_erased_statistics, SyncPredFlag);
Yap_InitCPred("predicate_erased_statistics", 5, p_predicate_erased_statistics, SyncPredFlag);
Yap_InitCPred("heap_space_info", 3, p_heap_space_info, SyncPredFlag); Yap_InitCPred("heap_space_info", 3, p_heap_space_info, SyncPredFlag);
#endif #endif
Yap_InitCPred("nth_instance", 3, p_nth_instance, SyncPredFlag); Yap_InitCPred("nth_instance", 3, p_nth_instance, SyncPredFlag);

22
C/errors.c
View File

@ -137,30 +137,10 @@ DumpActiveGoals (void)
while (TRUE) while (TRUE)
{ {
PredEntry *pe; PredEntry *pe;
op_numbers opnum;
if (!ONLOCAL (b_ptr) || b_ptr->cp_b == NULL) if (!ONLOCAL (b_ptr) || b_ptr->cp_b == NULL)
break; break;
opnum = Yap_op_from_opcode(b_ptr->cp_ap->opc); pe = Yap_PredForChoicePt(b_ptr);
restart_cp:
switch(opnum) {
case _or_else:
if (b_ptr->cp_ap == (yamop *)(b_ptr->cp_ap->u.sla.sla_u.l))
{
Yap_plwrite(MkAtomTerm(Yap_LookupAtom("repeat ")), Yap_DebugPutc, 0);
}
case _or_last:
pe = b_ptr->cp_cp->u.sla.p0;
break;
case _retry_profiled:
opnum = Yap_op_from_opcode(NEXTOP(b_ptr->cp_ap,l)->opc);
goto restart_cp;
case _count_retry_me:
opnum = Yap_op_from_opcode(NEXTOP(b_ptr->cp_ap,l)->opc);
goto restart_cp;
default:
pe = (PredEntry *)(b_ptr->cp_ap->u.ld.p);
}
READ_LOCK(pe->PRWLock); READ_LOCK(pe->PRWLock);
{ {
Functor f; Functor f;

6
C/exec.c
View File

@ -1391,8 +1391,8 @@ p_clean_ifcp(void) {
static Int static Int
JumpToEnv(Term t) { JumpToEnv(Term t) {
yamop *pos = NEXTOP(PredDollarCatch->cs.p_code.TrueCodeOfPred,ld), yamop *pos = NEXTOP(PredDollarCatch->cs.p_code.TrueCodeOfPred,l),
*catchpos = NEXTOP(PredHandleThrow->cs.p_code.TrueCodeOfPred,ld); *catchpos = NEXTOP(PredHandleThrow->cs.p_code.TrueCodeOfPred,l);
CELL *env; CELL *env;
choiceptr first_func = NULL, B0 = B; choiceptr first_func = NULL, B0 = B;
@ -1434,7 +1434,7 @@ JumpToEnv(Term t) {
} while (TRUE); } while (TRUE);
/* step one environment above */ /* step one environment above */
B->cp_cp = (yamop *)env[E_CP]; B->cp_cp = (yamop *)env[E_CP];
B->cp_ap = NEXTOP(PredHandleThrow->CodeOfPred,ld); B->cp_ap = NEXTOP(PredHandleThrow->CodeOfPred,l);
B->cp_env = (CELL *)env[E_E]; B->cp_env = (CELL *)env[E_E];
/* cannot recover Heap because of copy term :-( */ /* cannot recover Heap because of copy term :-( */
B->cp_h = H; B->cp_h = H;

90
C/grow.c
View File

@ -124,32 +124,50 @@ SetHeapRegs(void)
AuxSp = PtoDelayAdjust(AuxSp); AuxSp = PtoDelayAdjust(AuxSp);
AuxTop = (ADDR)PtoDelayAdjust((CELL *)AuxTop); AuxTop = (ADDR)PtoDelayAdjust((CELL *)AuxTop);
#endif #endif
HeapLim = DelayAddrAdjust(HeapLim); if (HeapLim)
HeapLim = DelayAddrAdjust(HeapLim);
/* The registers pointing to one of the stacks */ /* The registers pointing to one of the stacks */
ENV = PtoLocAdjust(ENV); if (ENV)
ASP = PtoLocAdjust(ASP); ENV = PtoLocAdjust(ENV);
H0 = PtoGloAdjust(H0); if (ASP)
LCL0 = PtoLocAdjust(LCL0); ASP = PtoLocAdjust(ASP);
H = PtoGloAdjust(H); if (H0)
HB = PtoGloAdjust(HB); H0 = PtoGloAdjust(H0);
B = ChoicePtrAdjust(B); if (LCL0)
LCL0 = PtoLocAdjust(LCL0);
if (H)
H = PtoGloAdjust(H);
if (HB)
HB = PtoGloAdjust(HB);
if (B)
B = ChoicePtrAdjust(B);
#ifdef TABLING #ifdef TABLING
B_FZ = ChoicePtrAdjust(B_FZ); if (B_FZ)
BB = ChoicePtrAdjust(BB); B_FZ = ChoicePtrAdjust(B_FZ);
H_FZ = PtoGloAdjust(H_FZ); if (BB)
TR_FZ = PtoTRAdjust(TR_FZ); BB = ChoicePtrAdjust(BB);
if (H_FZ)
H_FZ = PtoGloAdjust(H_FZ);
if (TR_FZ)
TR_FZ = PtoTRAdjust(TR_FZ);
#endif /* TABLING */ #endif /* TABLING */
TR = PtoTRAdjust(TR); if (TR)
YENV = PtoLocAdjust(YENV); TR = PtoTRAdjust(TR);
if (YENV)
YENV = PtoLocAdjust(YENV);
if (IsOldGlobalPtr(S)) if (IsOldGlobalPtr(S))
S = PtoGloAdjust(S); S = PtoGloAdjust(S);
else if (IsOldLocalPtr(S)) else if (IsOldLocalPtr(S))
S = PtoLocAdjust(S); S = PtoLocAdjust(S);
#ifdef COROUTINING #ifdef COROUTINING
DelayedVars = AbsAppl(PtoGloAdjust(RepAppl(DelayedVars))); if (DelayedVars)
MutableList = AbsAppl(PtoGloAdjust(RepAppl(MutableList))); DelayedVars = AbsAppl(PtoGloAdjust(RepAppl(DelayedVars)));
AttsMutableList = AbsAppl(PtoGloAdjust(RepAppl(AttsMutableList))); if (MutableList)
WokenGoals = AbsAppl(PtoGloAdjust(RepAppl(WokenGoals))); MutableList = AbsAppl(PtoGloAdjust(RepAppl(MutableList)));
if (AttsMutableList)
AttsMutableList = AbsAppl(PtoGloAdjust(RepAppl(AttsMutableList)));
if (WokenGoals)
WokenGoals = AbsAppl(PtoGloAdjust(RepAppl(WokenGoals)));
#endif #endif
} }
@ -173,21 +191,33 @@ SetStackRegs(void)
Yap_LocalBase = LocalAddrAdjust(Yap_LocalBase); Yap_LocalBase = LocalAddrAdjust(Yap_LocalBase);
TR = PtoTRAdjust(TR); TR = PtoTRAdjust(TR);
/* The registers pointing to the local stack */ /* The registers pointing to the local stack */
ENV = PtoLocAdjust(ENV); if (ENV)
ASP = PtoLocAdjust(ASP); ENV = PtoLocAdjust(ENV);
LCL0 = PtoLocAdjust(LCL0); if (ASP)
B = ChoicePtrAdjust(B); ASP = PtoLocAdjust(ASP);
if (LCL0)
LCL0 = PtoLocAdjust(LCL0);
if (B)
B = ChoicePtrAdjust(B);
#ifdef TABLING #ifdef TABLING
B_FZ = ChoicePtrAdjust(B_FZ); if (B_FZ)
BB = ChoicePtrAdjust(BB); B_FZ = ChoicePtrAdjust(B_FZ);
TR_FZ = PtoTRAdjust(TR_FZ); if (BB)
BB = ChoicePtrAdjust(BB);
if (TR_FZ)
TR_FZ = PtoTRAdjust(TR_FZ);
#endif /* TABLING */ #endif /* TABLING */
YENV = PtoLocAdjust(YENV); if (YENV)
YENV = PtoLocAdjust(YENV);
#ifdef COROUTINING #ifdef COROUTINING
DelayedVars = AbsAppl(PtoGloAdjust(RepAppl(DelayedVars))); if (DelayedVars)
MutableList = AbsAppl(PtoGloAdjust(RepAppl(MutableList))); DelayedVars = AbsAppl(PtoGloAdjust(RepAppl(DelayedVars)));
AttsMutableList = AbsAppl(PtoGloAdjust(RepAppl(AttsMutableList))); if (MutableList)
WokenGoals = AbsAppl(PtoGloAdjust(RepAppl(WokenGoals))); MutableList = AbsAppl(PtoGloAdjust(RepAppl(MutableList)));
if (AttsMutableList)
AttsMutableList = AbsAppl(PtoGloAdjust(RepAppl(AttsMutableList)));
if (WokenGoals)
WokenGoals = AbsAppl(PtoGloAdjust(RepAppl(WokenGoals)));
#endif #endif
} }

127
C/heapgc.c
View File

@ -1684,65 +1684,14 @@ mark_choicepoints(register choiceptr gc_B, tr_fr_ptr saved_TR, int very_verbose)
opnum = Yap_op_from_opcode(op); opnum = Yap_op_from_opcode(op);
} }
if (very_verbose) { if (very_verbose) {
switch (opnum) { PredEntry *pe = Yap_PredForChoicePt(gc_B);
case _retry_c:
case _or_else: if (pe == NULL) {
case _or_last:
case _Nstop:
case _retry_userc:
case _trust_logical_pred:
case _retry_profiled:
case _count_retry:
{
Atom at;
UInt arity;
Term mod;
if (Yap_PredForCode(gc_B->cp_ap, &at, &arity, &mod)) {
if (arity)
fprintf(Yap_stderr,"%% %s/%ld marked %ld (%s)\n", RepAtom(at)->StrOfAE, (long int)arity, total_marked, op_names[opnum]);
else
fprintf(Yap_stderr,"%% %s marked %ld (%s)\n", RepAtom(at)->StrOfAE, total_marked, op_names[opnum]);
} else
fprintf(Yap_stderr,"%% marked %ld (%s)\n", total_marked, op_names[opnum]);
}
break;
#ifdef TABLING
case _table_completion:
case _table_answer_resolution:
{
PredEntry *pe = ENV_ToP(gc_B->cp_cp);
op_numbers caller_op = Yap_op_from_opcode(ENV_ToOp(gc_B->cp_cp));
/* first condition checks if this was a meta-call */
if ((caller_op != _call && caller_op != _fcall) || pe == NULL) {
fprintf(Yap_stderr,"%% marked %ld (%s)\n", total_marked, op_names[opnum]);
} else
fprintf(Yap_stderr,"%% %s/%d marked %ld (%s)\n", RepAtom(NameOfFunctor(pe->FunctorOfPred))->StrOfAE, pe->ArityOfPE, total_marked, op_names[opnum]);
}
break;
case _trie_retry_var:
case _trie_trust_var:
case _trie_retry_val:
case _trie_trust_val:
case _trie_retry_atom:
case _trie_trust_atom:
case _trie_retry_list:
case _trie_trust_list:
case _trie_retry_struct:
case _trie_trust_struct:
fprintf(Yap_stderr,"%% marked %ld (%s)\n", total_marked, op_names[opnum]); fprintf(Yap_stderr,"%% marked %ld (%s)\n", total_marked, op_names[opnum]);
break; } else if (pe->ArityOfPE) {
#endif fprintf(Yap_stderr,"%% %s/%d marked %ld (%s)\n", RepAtom(NameOfFunctor(pe->FunctorOfPred))->StrOfAE, pe->ArityOfPE, total_marked, op_names[opnum]);
default: } else {
{ fprintf(Yap_stderr,"%% %s marked %ld (%s)\n", RepAtom((Atom)(pe->FunctorOfPred))->StrOfAE, total_marked, op_names[opnum]);
PredEntry *pe = (PredEntry *)gc_B->cp_ap->u.ld.p;
if (pe == NULL) {
fprintf(Yap_stderr,"%% marked %ld (%s)\n", total_marked, op_names[opnum]);
} else
if (pe->ArityOfPE)
fprintf(Yap_stderr,"%% %s/%d marked %ld (%s)\n", RepAtom(NameOfFunctor(pe->FunctorOfPred))->StrOfAE, pe->ArityOfPE, total_marked, op_names[opnum]);
else
fprintf(Yap_stderr,"%% %s marked %ld (%s)\n", RepAtom((Atom)(pe->FunctorOfPred))->StrOfAE, total_marked, op_names[opnum]);
}
} }
} }
{ {
@ -1938,6 +1887,15 @@ mark_choicepoints(register choiceptr gc_B, tr_fr_ptr saved_TR, int very_verbose)
case _count_retry_and_mark: case _count_retry_and_mark:
case _retry_and_mark: case _retry_and_mark:
ClauseCodeToDynamicClause(gc_B->cp_ap)->ClFlags |= GcFoundMask; ClauseCodeToDynamicClause(gc_B->cp_ap)->ClFlags |= GcFoundMask;
case _retry2:
nargs = 2;
break;
case _retry3:
nargs = 3;
break;
case _retry4:
nargs = 4;
break;
#ifdef DEBUG #ifdef DEBUG
case _retry_me: case _retry_me:
case _trust_me: case _trust_me:
@ -2412,6 +2370,29 @@ sweep_slots(CELL *ptr)
} }
} }
static void
sweep_b(choiceptr gc_B, UInt arity)
{
register CELL_PTR saved_reg;
sweep_environments(gc_B->cp_env,
EnvSize((CELL_PTR) (gc_B->cp_cp)),
EnvBMap((CELL_PTR) (gc_B->cp_cp)));
/* for each saved register */
for (saved_reg = &gc_B->cp_a1;
saved_reg < &gc_B->cp_a1 + arity;
saved_reg++) {
CELL cp_cell = *saved_reg;
if (MARKED_PTR(saved_reg)) {
UNMARK(saved_reg);
if (HEAP_PTR(cp_cell)) {
into_relocation_chain(saved_reg, GET_NEXT(cp_cell));
}
}
}
}
/* /*
* insert cells of each choicepoint & its chain of environments which point * insert cells of each choicepoint & its chain of environments which point
@ -2648,6 +2629,15 @@ sweep_choicepoints(choiceptr gc_B)
} }
break; break;
#endif #endif
case _retry2:
sweep_b(gc_B, 2);
break;
case _retry3:
sweep_b(gc_B, 3);
break;
case _retry4:
sweep_b(gc_B, 4);
break;
case _retry_c: case _retry_c:
case _retry_userc: case _retry_userc:
{ {
@ -2668,26 +2658,7 @@ sweep_choicepoints(choiceptr gc_B)
} }
/* continue to clean environments and arguments */ /* continue to clean environments and arguments */
default: default:
{ sweep_b(gc_B,rtp->u.ld.s);
register CELL_PTR saved_reg;
sweep_environments(gc_B->cp_env,
EnvSize((CELL_PTR) (gc_B->cp_cp)),
EnvBMap((CELL_PTR) (gc_B->cp_cp)));
/* for each saved register */
for (saved_reg = &gc_B->cp_a1;
saved_reg < &gc_B->cp_a1 + rtp->u.ld.s;
saved_reg++) {
CELL cp_cell = *saved_reg;
if (MARKED_PTR(saved_reg)) {
UNMARK(saved_reg);
if (HEAP_PTR(cp_cell)) {
into_relocation_chain(saved_reg, GET_NEXT(cp_cell));
}
}
}
}
} }
/* link to prev choicepoint */ /* link to prev choicepoint */

838
C/index.c
View File

File diff suppressed because it is too large Load Diff

92
C/init.c
View File

@ -457,27 +457,52 @@ InitDebug(void)
void void
Yap_InitCPred(char *Name, unsigned long int Arity, CPredicate code, int flags) Yap_InitCPred(char *Name, unsigned long int Arity, CPredicate code, int flags)
{ {
Atom atom = Yap_FullLookupAtom(Name); Atom atom = Yap_FullLookupAtom(Name);
PredEntry *pe; PredEntry *pe;
yamop *p_code = ((StaticClause *)NULL)->ClCode; yamop *p_code = ((StaticClause *)NULL)->ClCode;
StaticClause *cl; StaticClause *cl = NULL;
if (Arity) if (Arity)
pe = RepPredProp(PredPropByFunc(Yap_MkFunctor(atom, Arity),CurrentModule)); pe = RepPredProp(PredPropByFunc(Yap_MkFunctor(atom, Arity),CurrentModule));
else else
pe = RepPredProp(PredPropByAtom(atom,CurrentModule)); pe = RepPredProp(PredPropByAtom(atom,CurrentModule));
if (pe->PredFlags & SafePredFlag) { if (pe->PredFlags & CPredFlag) {
cl = (StaticClause *)Yap_AllocCodeSpace((CELL)NEXTOP(NEXTOP(((yamop *)p_code),sla),e)); /* already exists */
} else { cl = ClauseCodeToStaticClause(pe->CodeOfPred);
cl = (StaticClause *)Yap_AllocCodeSpace((CELL)NEXTOP(NEXTOP(NEXTOP(NEXTOP(((yamop *)p_code),e),sla),e),e)); if ((flags & SafePredFlag) &&
!(pe->PredFlags & SafePredFlag)) {
Yap_FreeCodeSpace((ADDR)cl);
cl = NULL;
} else {
p_code = cl->ClCode;
}
}
while (!cl) {
UInt sz;
if (flags & SafePredFlag) {
sz = (CELL)NEXTOP(NEXTOP(NEXTOP(p_code,sla),e),e);
} else {
sz = (CELL)NEXTOP(NEXTOP(NEXTOP(NEXTOP(NEXTOP(p_code,e),sla),e),e),e);
}
cl = (StaticClause *)Yap_AllocCodeSpace(sz);
if (!cl) {
if (!Yap_growheap(FALSE, sz, NULL)) {
Yap_Error(OUT_OF_HEAP_ERROR,TermNil,"while initialising %s", Name);
return;
}
} else {
cl->ClFlags = 0;
cl->ClSize = sz-sizeof(StaticClause);
cl->usc.ClPred = pe;
p_code = cl->ClCode;
}
} }
cl->ClFlags = 0;
p_code = cl->ClCode;
pe->CodeOfPred = p_code; pe->CodeOfPred = p_code;
pe->PredFlags = flags | StandardPredFlag | CPredFlag; pe->PredFlags = flags | StandardPredFlag | CPredFlag;
pe->cs.f_code = code; pe->cs.f_code = code;
if (!(pe->PredFlags & SafePredFlag)) { if (!(flags & SafePredFlag)) {
p_code->opc = Yap_opcode(_allocate); p_code->opc = Yap_opcode(_allocate);
p_code = NEXTOP(p_code,e); p_code = NEXTOP(p_code,e);
} }
@ -489,11 +514,13 @@ Yap_InitCPred(char *Name, unsigned long int Arity, CPredicate code, int flags)
p_code->u.sla.s = -Signed(RealEnvSize); p_code->u.sla.s = -Signed(RealEnvSize);
p_code->u.sla.sla_u.p = pe; p_code->u.sla.sla_u.p = pe;
p_code = NEXTOP(p_code,sla); p_code = NEXTOP(p_code,sla);
if (!(pe->PredFlags & SafePredFlag)) { if (!(flags & SafePredFlag)) {
p_code->opc = Yap_opcode(_deallocate); p_code->opc = Yap_opcode(_deallocate);
p_code = NEXTOP(p_code,e); p_code = NEXTOP(p_code,e);
} }
p_code->opc = Yap_opcode(_procceed); p_code->opc = Yap_opcode(_procceed);
p_code = NEXTOP(p_code,e);
p_code->opc = Yap_opcode(_Ystop);
pe->OpcodeOfPred = pe->CodeOfPred->opc; pe->OpcodeOfPred = pe->CodeOfPred->opc;
pe->ModuleOfPred = CurrentModule; pe->ModuleOfPred = CurrentModule;
} }
@ -501,17 +528,37 @@ Yap_InitCPred(char *Name, unsigned long int Arity, CPredicate code, int flags)
void void
Yap_InitCmpPred(char *Name, unsigned long int Arity, CmpPredicate cmp_code, int flags) Yap_InitCmpPred(char *Name, unsigned long int Arity, CmpPredicate cmp_code, int flags)
{ {
Atom atom = Yap_LookupAtom(Name); Atom atom = Yap_LookupAtom(Name);
PredEntry *pe; PredEntry *pe;
yamop *p_code = ((StaticClause *)NULL)->ClCode; yamop *p_code = NULL;
StaticClause *cl = (StaticClause *)Yap_AllocCodeSpace((CELL)NEXTOP(NEXTOP(NEXTOP(((yamop *)p_code),llxx),e),e)); StaticClause *cl = NULL;
cl->ClFlags = 0; if (Arity) {
p_code = cl->ClCode;
if (Arity)
pe = RepPredProp(PredPropByFunc(Yap_MkFunctor(atom, Arity),CurrentModule)); pe = RepPredProp(PredPropByFunc(Yap_MkFunctor(atom, Arity),CurrentModule));
else } else {
pe = RepPredProp(PredPropByAtom(atom,CurrentModule)); pe = RepPredProp(PredPropByAtom(atom,CurrentModule));
}
if (pe->PredFlags & CPredFlag) {
p_code = pe->CodeOfPred;
/* already exists */
} else {
while (!cl) {
UInt sz = sizeof(StaticClause)+(CELL)NEXTOP(NEXTOP(NEXTOP(((yamop *)NULL),llxx),e),e);
cl = (StaticClause *)Yap_AllocCodeSpace(sz);
if (!cl) {
if (!Yap_growheap(FALSE, sz, NULL)) {
Yap_Error(OUT_OF_HEAP_ERROR,TermNil,"while initialising %s", Name);
return;
}
} else {
cl->ClSize = sz-sizeof(StaticClause);
cl->usc.ClPred = pe;
cl->ClFlags = 0;
p_code = cl->ClCode;
break;
}
}
}
pe->PredFlags = flags | StandardPredFlag | CPredFlag; pe->PredFlags = flags | StandardPredFlag | CPredFlag;
pe->CodeOfPred = p_code; pe->CodeOfPred = p_code;
pe->cs.d_code = cmp_code; pe->cs.d_code = cmp_code;
@ -739,6 +786,8 @@ InitCodes(void)
#endif /* YAPOR */ #endif /* YAPOR */
#endif /* TABLING */ #endif /* TABLING */
heap_regs->expand_op_code = Yap_opcode(_expand_index); heap_regs->expand_op_code = Yap_opcode(_expand_index);
heap_regs->expand_clauses_first = NULL;
heap_regs->expand_clauses_last = NULL;
heap_regs->failcode->opc = Yap_opcode(_op_fail); heap_regs->failcode->opc = Yap_opcode(_op_fail);
heap_regs->failcode_1 = Yap_opcode(_op_fail); heap_regs->failcode_1 = Yap_opcode(_op_fail);
heap_regs->failcode_2 = Yap_opcode(_op_fail); heap_regs->failcode_2 = Yap_opcode(_op_fail);
@ -973,6 +1022,7 @@ InitCodes(void)
heap_regs->functor_g_var = Yap_MkFunctor(AtomGVar, 1); heap_regs->functor_g_var = Yap_MkFunctor(AtomGVar, 1);
heap_regs->functor_last_execute_within = Yap_MkFunctor(Yap_FullLookupAtom("$last_execute_within"), 1); heap_regs->functor_last_execute_within = Yap_MkFunctor(Yap_FullLookupAtom("$last_execute_within"), 1);
heap_regs->functor_list = Yap_MkFunctor(Yap_LookupAtom("."), 2); heap_regs->functor_list = Yap_MkFunctor(Yap_LookupAtom("."), 2);
heap_regs->functor_mega_clause = Yap_MkFunctor (Yap_FullLookupAtom("$mega_clause"), 2);
heap_regs->functor_module = Yap_MkFunctor(Yap_LookupAtom(":"), 2); heap_regs->functor_module = Yap_MkFunctor(Yap_LookupAtom(":"), 2);
#ifdef MULTI_ASSIGNMENT_VARIABLES #ifdef MULTI_ASSIGNMENT_VARIABLES
heap_regs->functor_mutable = Yap_MkFunctor(Yap_FullLookupAtom("$mutable_variable"), heap_regs->functor_mutable = Yap_MkFunctor(Yap_FullLookupAtom("$mutable_variable"),
@ -983,6 +1033,7 @@ InitCodes(void)
heap_regs->functor_portray = Yap_MkFunctor(AtomPortray, 1); heap_regs->functor_portray = Yap_MkFunctor(AtomPortray, 1);
heap_regs->functor_query = Yap_MkFunctor(AtomQuery, 1); heap_regs->functor_query = Yap_MkFunctor(AtomQuery, 1);
heap_regs->functor_creep = Yap_MkFunctor(AtomCreep, 1); heap_regs->functor_creep = Yap_MkFunctor(AtomCreep, 1);
heap_regs->functor_static_clause = Yap_MkFunctor (Yap_FullLookupAtom("$startic_clause"), 1);
heap_regs->functor_stream = Yap_MkFunctor (AtomStream, 1); heap_regs->functor_stream = Yap_MkFunctor (AtomStream, 1);
heap_regs->functor_stream_pos = Yap_MkFunctor (AtomStreamPos, 3); heap_regs->functor_stream_pos = Yap_MkFunctor (AtomStreamPos, 3);
heap_regs->functor_stream_eOS = Yap_MkFunctor (Yap_LookupAtom("end_of_stream"), 1); heap_regs->functor_stream_eOS = Yap_MkFunctor (Yap_LookupAtom("end_of_stream"), 1);
@ -1045,6 +1096,7 @@ InitCodes(void)
heap_regs->db_erased_marker->Parent = NULL; heap_regs->db_erased_marker->Parent = NULL;
INIT_LOCK(heap_regs->db_erased_marker->lock); INIT_LOCK(heap_regs->db_erased_marker->lock);
INIT_DBREF_COUNT(heap_regs->db_erased_marker); INIT_DBREF_COUNT(heap_regs->db_erased_marker);
heap_regs->yap_streams = NULL;
#if DEBUG #if DEBUG
heap_regs->expand_clauses_sz = 0L; heap_regs->expand_clauses_sz = 0L;
#endif #endif

18
C/iopreds.c
View File

@ -2477,16 +2477,13 @@ Yap_CloseStreams (int loud)
if (loud) if (loud)
fprintf (Yap_stderr, "%% YAP Error: while closing stream: %s\n", RepAtom (Stream[sno].u.file.name)->StrOfAE); fprintf (Yap_stderr, "%% YAP Error: while closing stream: %s\n", RepAtom (Stream[sno].u.file.name)->StrOfAE);
} }
if (Yap_c_input_stream == sno) if (Yap_c_input_stream == sno) {
{ Yap_c_input_stream = StdInStream;
Yap_c_input_stream = StdInStream; } else if (Yap_c_output_stream == sno) {
} Yap_c_output_stream = StdOutStream;
else if (Yap_c_output_stream == sno) }
{ Stream[sno].status = Free_Stream_f;
Yap_c_output_stream = StdOutStream;
}
} }
Stream[sno].status = Free_Stream_f;
} }
@ -4804,7 +4801,8 @@ Yap_InitIOPreds(void)
Yap_stdin = stdin; Yap_stdin = stdin;
Yap_stdout = stdout; Yap_stdout = stdout;
Yap_stderr = stderr; Yap_stderr = stderr;
Stream = (StreamDesc *)Yap_AllocCodeSpace(sizeof(StreamDesc)*MaxStreams); if (!Stream)
Stream = (StreamDesc *)Yap_AllocCodeSpace(sizeof(StreamDesc)*MaxStreams);
/* here the Input/Output predicates */ /* here the Input/Output predicates */
Yap_InitCPred ("$check_stream", 2, p_check_stream, SafePredFlag|SyncPredFlag); Yap_InitCPred ("$check_stream", 2, p_check_stream, SafePredFlag|SyncPredFlag);
Yap_InitCPred ("$check_stream", 1, p_check_if_stream, SafePredFlag|SyncPredFlag); Yap_InitCPred ("$check_stream", 1, p_check_if_stream, SafePredFlag|SyncPredFlag);

10
C/save.c
View File

@ -1379,12 +1379,20 @@ UnmarkTrEntries(void)
Yap_ErDBE(DBStructFlagsToDBStruct(ent)); Yap_ErDBE(DBStructFlagsToDBStruct(ent));
} else { } else {
if (flags & LogUpdMask) { if (flags & LogUpdMask) {
Yap_ErLogUpdCl(ClauseFlagsToLogUpdClause(ent)); if (flags & IndexMask) {
Yap_ErLogUpdIndex(ClauseFlagsToLogUpdIndex(ent));
} else {
Yap_ErLogUpdCl(ClauseFlagsToLogUpdClause(ent));
}
} else { } else {
Yap_ErCl(ClauseFlagsToDynamicClause(ent)); Yap_ErCl(ClauseFlagsToDynamicClause(ent));
} }
} }
} }
#ifdef MULTI_ASSIGNMENT_VARIABLES
} else /* if (IsApplTerm(d1)) */ {
Entries += 2;
#endif
} }
} }
B = NULL; B = NULL;

13
H/Heap.h
View File

@ -10,7 +10,7 @@
* File: Heap.h * * File: Heap.h *
* mods: * * mods: *
* comments: Heap Init Structure * * comments: Heap Init Structure *
* version: $Id: Heap.h,v 1.65 2004-09-03 03:11:09 vsc Exp $ * * version: $Id: Heap.h,v 1.66 2004-09-27 20:45:03 vsc Exp $ *
*************************************************************************/ *************************************************************************/
/* information that can be stored in Code Space */ /* information that can be stored in Code Space */
@ -112,6 +112,10 @@ typedef struct various_codes {
yamop tableanswerresolutioncode; yamop tableanswerresolutioncode;
#endif /* TABLING */ #endif /* TABLING */
OPCODE expand_op_code; OPCODE expand_op_code;
yamop *expand_clauses_first, *expand_clauses_last;
#if defined(YAPOR) || defined(THREADS)
lockvar expand_clauses_list_lock;
#endif
yamop comma_code[5]; yamop comma_code[5];
yamop failcode[1]; yamop failcode[1];
OPCODE failcode_1; OPCODE failcode_1;
@ -317,6 +321,7 @@ typedef struct various_codes {
functor_g_var, functor_g_var,
functor_last_execute_within, functor_last_execute_within,
functor_list, functor_list,
functor_mega_clause,
functor_module, functor_module,
#ifdef MULTI_ASSIGNMENT_VARIABLES #ifdef MULTI_ASSIGNMENT_VARIABLES
functor_mutable, functor_mutable,
@ -325,6 +330,7 @@ typedef struct various_codes {
functor_or, functor_or,
functor_portray, functor_portray,
functor_query, functor_query,
functor_static_clause,
functor_stream, functor_stream,
functor_stream_pos, functor_stream_pos,
functor_stream_eOS, functor_stream_eOS,
@ -426,6 +432,9 @@ struct various_codes *heap_regs;
#define ANSWER_RESOLUTION ((yamop *)&(heap_regs->tableanswerresolutioncode )) #define ANSWER_RESOLUTION ((yamop *)&(heap_regs->tableanswerresolutioncode ))
#endif /* TABLING */ #endif /* TABLING */
#define EXPAND_OP_CODE heap_regs->expand_op_code #define EXPAND_OP_CODE heap_regs->expand_op_code
#define ExpandClausesFirst heap_regs->expand_clauses_first
#define ExpandClausesLast heap_regs->expand_clauses_last
#define ExpandClausesListLock heap_regs->expand_clauses_list_lock
#define COMMA_CODE heap_regs->comma_code #define COMMA_CODE heap_regs->comma_code
#define FAILCODE heap_regs->failcode #define FAILCODE heap_regs->failcode
#define TRUSTFAILCODE heap_regs->trustfailcode #define TRUSTFAILCODE heap_regs->trustfailcode
@ -569,6 +578,7 @@ struct various_codes *heap_regs;
#define FunctorGVar heap_regs->functor_g_var #define FunctorGVar heap_regs->functor_g_var
#define FunctorLastExecuteWithin heap_regs->functor_last_execute_within #define FunctorLastExecuteWithin heap_regs->functor_last_execute_within
#define FunctorList heap_regs->functor_list #define FunctorList heap_regs->functor_list
#define FunctorMegaClause heap_regs->functor_mega_clause
#define FunctorModule heap_regs->functor_module #define FunctorModule heap_regs->functor_module
#ifdef MULTI_ASSIGNMENT_VARIABLES #ifdef MULTI_ASSIGNMENT_VARIABLES
#define FunctorMutable heap_regs->functor_mutable #define FunctorMutable heap_regs->functor_mutable
@ -577,6 +587,7 @@ struct various_codes *heap_regs;
#define FunctorOr heap_regs->functor_or #define FunctorOr heap_regs->functor_or
#define FunctorPortray heap_regs->functor_portray #define FunctorPortray heap_regs->functor_portray
#define FunctorQuery heap_regs->functor_query #define FunctorQuery heap_regs->functor_query
#define FunctorStaticClause heap_regs->functor_static_clause
#define FunctorStream heap_regs->functor_stream #define FunctorStream heap_regs->functor_stream
#define FunctorStreamPos heap_regs->functor_stream_pos #define FunctorStreamPos heap_regs->functor_stream_pos
#define FunctorStreamEOS heap_regs->functor_stream_eOS #define FunctorStreamEOS heap_regs->functor_stream_eOS

16
H/YapOpcodes.h
View File

@ -11,8 +11,11 @@
* File: YapOpcodes.h * * File: YapOpcodes.h *
* comments: Central Table with all YAP opcodes * * comments: Central Table with all YAP opcodes *
* * * *
* Last rev: $Date: 2004-03-31 01:03:10 $ * * Last rev: $Date: 2004-09-27 20:45:04 $ *
* $Log: not supported by cvs2svn $ * $Log: not supported by cvs2svn $
* Revision 1.23 2004/03/31 01:03:10 vsc
* support expand group of clauses
*
* Revision 1.22 2004/03/19 11:35:42 vsc * Revision 1.22 2004/03/19 11:35:42 vsc
* trim_trail for default machine * trim_trail for default machine
* be more aggressive about try-retry-trust chains. * be more aggressive about try-retry-trust chains.
@ -104,6 +107,11 @@
OPCODE(get_x_val ,xx), OPCODE(get_x_val ,xx),
OPCODE(get_y_val ,yx), OPCODE(get_y_val ,yx),
OPCODE(get_atom ,xc), OPCODE(get_atom ,xc),
OPCODE(get_2atoms ,cc),
OPCODE(get_3atoms ,ccc),
OPCODE(get_4atoms ,cccc),
OPCODE(get_5atoms ,ccccc),
OPCODE(get_6atoms ,cccccc),
OPCODE(get_float ,xc), OPCODE(get_float ,xc),
OPCODE(get_longint ,xc), OPCODE(get_longint ,xc),
OPCODE(get_bigint ,xc), OPCODE(get_bigint ,xc),
@ -156,7 +164,13 @@
OPCODE(cut_t ,e), OPCODE(cut_t ,e),
OPCODE(cut_e ,sla), OPCODE(cut_e ,sla),
OPCODE(try_clause ,ld), OPCODE(try_clause ,ld),
OPCODE(try_clause2 ,l),
OPCODE(try_clause3 ,l),
OPCODE(try_clause4 ,l),
OPCODE(retry ,ld), OPCODE(retry ,ld),
OPCODE(retry2 ,l),
OPCODE(retry3 ,l),
OPCODE(retry4 ,l),
OPCODE(trust ,ld), OPCODE(trust ,ld),
OPCODE(try_in ,l), OPCODE(try_in ,l),
OPCODE(jump_if_var ,l), OPCODE(jump_if_var ,l),

5
H/Yapproto.h
View File

@ -10,7 +10,7 @@
* File: Yap.proto * * File: Yap.proto *
* mods: * * mods: *
* comments: Function declarations for YAP * * comments: Function declarations for YAP *
* version: $Id: Yapproto.h,v 1.55 2004-08-16 21:02:04 vsc Exp $ * * version: $Id: Yapproto.h,v 1.56 2004-09-27 20:45:04 vsc Exp $ *
*************************************************************************/ *************************************************************************/
/* prototype file for Yap */ /* prototype file for Yap */
@ -108,6 +108,7 @@ Int STD_PROTO(YAP_Execute,(struct pred_entry *, CPredicate));
Term STD_PROTO(Yap_all_calls,(void)); Term STD_PROTO(Yap_all_calls,(void));
Atom STD_PROTO(Yap_ConsultingFile,(void)); Atom STD_PROTO(Yap_ConsultingFile,(void));
Int STD_PROTO(Yap_PredForCode,(yamop *, Atom *, UInt *, Term *)); Int STD_PROTO(Yap_PredForCode,(yamop *, Atom *, UInt *, Term *));
struct pred_entry *STD_PROTO(Yap_PredForChoicePt,(choiceptr));
void STD_PROTO(Yap_InitCdMgr,(void)); void STD_PROTO(Yap_InitCdMgr,(void));
#if EMACS #if EMACS
int STD_PROTO(where_new_clause, (Prop, int)); int STD_PROTO(where_new_clause, (Prop, int));
@ -115,6 +116,8 @@ int STD_PROTO(where_new_clause, (Prop, int));
void STD_PROTO(Yap_init_consult,(int, char *)); void STD_PROTO(Yap_init_consult,(int, char *));
void STD_PROTO(Yap_end_consult,(void)); void STD_PROTO(Yap_end_consult,(void));
void STD_PROTO(Yap_Abolish,(struct pred_entry *)); void STD_PROTO(Yap_Abolish,(struct pred_entry *));
void STD_PROTO(Yap_BuildMegaClause,(struct pred_entry *));
void STD_PROTO(Yap_EraseMegaClause,(yamop *,struct pred_entry *));
/* cmppreds.c */ /* cmppreds.c */

2
H/alloc.h
View File

@ -57,7 +57,7 @@ typedef struct FREEB {
#define MinBlockSize (sizeof(BlockHeader)+sizeof(YAP_SEG_SIZE)) #define MinBlockSize (sizeof(BlockHeader)+sizeof(YAP_SEG_SIZE))
#define MaxBlockSize 0xffffff #define MaxBlockSize 0xffffff
#define InUseFlag 0x1000000 #define InUseFlag 0x80000000
/* the following defines are machine dependant and are used to enforce /* the following defines are machine dependant and are used to enforce
the correct alignment for allocated blocks */ the correct alignment for allocated blocks */

42
H/amidefs.h
View File

@ -11,8 +11,12 @@
* File: amidefs.h * * File: amidefs.h *
* comments: Abstract machine peculiarities * * comments: Abstract machine peculiarities *
* * * *
* Last rev: $Date: 2004-04-14 19:10:40 $ * * Last rev: $Date: 2004-09-27 20:45:04 $ *
* $Log: not supported by cvs2svn $ * $Log: not supported by cvs2svn $
* Revision 1.24 2004/04/14 19:10:40 vsc
* expand_clauses: keep a list of clauses to expand
* fix new trail scheme for multi-assignment variables
*
* Revision 1.23 2004/03/31 01:03:10 vsc * Revision 1.23 2004/03/31 01:03:10 vsc
* support expand group of clauses * support expand group of clauses
* *
@ -139,6 +143,41 @@ typedef struct yami {
CELL c; CELL c;
CELL next; CELL next;
} c; } c;
struct {
CELL c1;
CELL c2;
CELL next;
} cc;
struct {
CELL c1;
CELL c2;
CELL c3;
CELL next;
} ccc;
struct {
CELL c1;
CELL c2;
CELL c3;
CELL c4;
CELL next;
} cccc;
struct {
CELL c1;
CELL c2;
CELL c3;
CELL c4;
CELL c5;
CELL next;
} ccccc;
struct {
CELL c1;
CELL c2;
CELL c3;
CELL c4;
CELL c5;
CELL c6;
CELL next;
} cccccc;
struct { struct {
CELL c; CELL c;
struct yami *l1; struct yami *l1;
@ -366,6 +405,7 @@ typedef struct yami {
COUNT s1; COUNT s1;
COUNT s2; COUNT s2;
COUNT s3; COUNT s3;
struct yami *sprev, *snext;
struct pred_entry *p; struct pred_entry *p;
CELL next; CELL next;
} sp; } sp;

50
H/clause.h
View File

@ -109,7 +109,6 @@ typedef struct static_index {
typedef struct static_clause { typedef struct static_clause {
/* A set of flags describing info on the clause */ /* A set of flags describing info on the clause */
Functor Id;
CELL ClFlags; CELL ClFlags;
UInt ClSize; UInt ClSize;
union { union {
@ -121,6 +120,16 @@ typedef struct static_clause {
yamop ClCode[MIN_ARRAY]; yamop ClCode[MIN_ARRAY];
} StaticClause; } StaticClause;
typedef struct static_mega_clause {
/* A set of flags describing info on the clause */
CELL ClFlags;
UInt ClSize;
PredEntry *ClPred;
UInt ClItemSize;
/* The instructions, at least one of the form sl */
yamop ClCode[MIN_ARRAY];
} MegaClause;
typedef struct dead_clause { typedef struct dead_clause {
CELL ClFlags; CELL ClFlags;
#if defined(YAPOR) || defined(THREADS) #if defined(YAPOR) || defined(THREADS)
@ -137,12 +146,14 @@ typedef union clause_obj {
struct logic_upd_index lui; struct logic_upd_index lui;
struct dynamic_clause ic; struct dynamic_clause ic;
struct static_clause sc; struct static_clause sc;
struct static_mega_clause mc;
struct static_index si; struct static_index si;
} ClauseUnion; } ClauseUnion;
#define ClauseCodeToDynamicClause(p) ((DynamicClause *)((CODEADDR)(p)-(CELL)(((DynamicClause *)NULL)->ClCode))) #define ClauseCodeToDynamicClause(p) ((DynamicClause *)((CODEADDR)(p)-(CELL)(((DynamicClause *)NULL)->ClCode)))
#define ClauseCodeToStaticClause(p) ((StaticClause *)((CODEADDR)(p)-(CELL)(((StaticClause *)NULL)->ClCode))) #define ClauseCodeToStaticClause(p) ((StaticClause *)((CODEADDR)(p)-(CELL)(((StaticClause *)NULL)->ClCode)))
#define ClauseCodeToLogUpdClause(p) ((LogUpdClause *)((CODEADDR)(p)-(CELL)(((LogUpdClause *)NULL)->ClCode))) #define ClauseCodeToLogUpdClause(p) ((LogUpdClause *)((CODEADDR)(p)-(CELL)(((LogUpdClause *)NULL)->ClCode)))
#define ClauseCodeToMegaClause(p) ((MegaClause *)((CODEADDR)(p)-(CELL)(((MegaClause *)NULL)->ClCode)))
#define ClauseCodeToLogUpdIndex(p) ((LogUpdIndex *)((CODEADDR)(p)-(CELL)(((LogUpdIndex *)NULL)->ClCode))) #define ClauseCodeToLogUpdIndex(p) ((LogUpdIndex *)((CODEADDR)(p)-(CELL)(((LogUpdIndex *)NULL)->ClCode)))
#define ClauseCodeToStaticIndex(p) ((StaticIndex *)((CODEADDR)(p)-(CELL)(((StaticIndex *)NULL)->ClCode))) #define ClauseCodeToStaticIndex(p) ((StaticIndex *)((CODEADDR)(p)-(CELL)(((StaticIndex *)NULL)->ClCode)))
@ -215,6 +226,8 @@ Yap_op_from_opcode(OPCODE opc)
int j = rtable_hash_op(opc,OP_HASH_SIZE-1); int j = rtable_hash_op(opc,OP_HASH_SIZE-1);
while (OP_RTABLE[j].opc != opc) { while (OP_RTABLE[j].opc != opc) {
if (!OP_RTABLE[j].opc)
return _Nstop;
if (j == OP_HASH_SIZE-1) { if (j == OP_HASH_SIZE-1) {
j = 0; j = 0;
} else { } else {
@ -250,3 +263,38 @@ same_lu_block(yamop **paddr, yamop *p)
} }
#endif #endif
static inline Term
Yap_MkStaticRefTerm(StaticClause *cp)
{
Term t[1];
t[0] = MkIntegerTerm((Int)cp);
return Yap_MkApplTerm(FunctorStaticClause,1,t);
}
static inline StaticClause *
Yap_ClauseFromTerm(Term t)
{
return (StaticClause *)IntegerOfTerm(ArgOfTerm(1,t));
}
static inline Term
Yap_MkMegaRefTerm(PredEntry *ap,yamop *ipc)
{
Term t[2];
t[0] = MkIntegerTerm((Int)ap);
t[0] = MkIntegerTerm((Int)ipc);
return Yap_MkApplTerm(FunctorMegaClause,2,t);
}
static inline yamop *
Yap_MegaClauseFromTerm(Term t)
{
return (yamop *)IntegerOfTerm(ArgOfTerm(1,t));
}
static inline PredEntry *
Yap_MegaClausePredicateFromTerm(Term t)
{
return (PredEntry *)IntegerOfTerm(ArgOfTerm(2,t));
}

235
H/rheap.h
View File

@ -11,8 +11,12 @@
* File: rheap.h * * File: rheap.h *
* comments: walk through heap code * * comments: walk through heap code *
* * * *
* Last rev: $Date: 2004-06-05 03:37:00 $,$Author: vsc $ * * Last rev: $Date: 2004-09-27 20:45:04 $,$Author: vsc $ *
* $Log: not supported by cvs2svn $ * $Log: not supported by cvs2svn $
* Revision 1.42 2004/06/05 03:37:00 vsc
* coroutining is now a part of attvars.
* some more fixes.
*
* Revision 1.41 2004/04/29 03:45:50 vsc * Revision 1.41 2004/04/29 03:45:50 vsc
* fix garbage collection in execute_tail * fix garbage collection in execute_tail
* *
@ -46,6 +50,26 @@ static char *op_names[_std_top + 1] =
/* Now, everything on its place so you must adjust the pointers */ /* Now, everything on its place so you must adjust the pointers */
static void
do_clean_susp_clauses(yamop *ipc) {
COUNT i;
yamop **st = (yamop **)NEXTOP(ipc,sp);
ipc->opc = Yap_opcode(_expand_clauses);
ipc->u.sp.p = PtoPredAdjust(ipc->u.sp.p);
if (ipc->u.sp.sprev) {
ipc->u.sp.sprev = PtoOpAdjust(ipc->u.sp.sprev);
}
if (ipc->u.sp.snext) {
ipc->u.sp.snext = PtoOpAdjust(ipc->u.sp.snext);
}
for (i = 0; i < ipc->u.sp.s1; i++, st++) {
if (*st) {
*st = PtoOpAdjust(*st);
}
}
}
/* restore the failcodes */ /* restore the failcodes */
static void static void
restore_codes(void) restore_codes(void)
@ -67,6 +91,17 @@ restore_codes(void)
#endif /* YAPOR */ #endif /* YAPOR */
#endif /* TABLING */ #endif /* TABLING */
heap_regs->expand_op_code = Yap_opcode(_expand_index); heap_regs->expand_op_code = Yap_opcode(_expand_index);
if (heap_regs->expand_clauses_first)
heap_regs->expand_clauses_first = PtoOpAdjust(heap_regs->expand_clauses_first);
if (heap_regs->expand_clauses_last)
heap_regs->expand_clauses_last = PtoOpAdjust(heap_regs->expand_clauses_last);
{
yamop *ptr = heap_regs->expand_clauses_first;
while (ptr) {
do_clean_susp_clauses(ptr);
ptr = ptr->u.sp.snext;
}
}
heap_regs->failcode->opc = Yap_opcode(_op_fail); heap_regs->failcode->opc = Yap_opcode(_op_fail);
heap_regs->failcode_1 = Yap_opcode(_op_fail); heap_regs->failcode_1 = Yap_opcode(_op_fail);
heap_regs->failcode_2 = Yap_opcode(_op_fail); heap_regs->failcode_2 = Yap_opcode(_op_fail);
@ -297,6 +332,7 @@ restore_codes(void)
heap_regs->functor_g_var = FuncAdjust(heap_regs->functor_g_var); heap_regs->functor_g_var = FuncAdjust(heap_regs->functor_g_var);
heap_regs->functor_last_execute_within = FuncAdjust(heap_regs->functor_last_execute_within); heap_regs->functor_last_execute_within = FuncAdjust(heap_regs->functor_last_execute_within);
heap_regs->functor_list = FuncAdjust(heap_regs->functor_list); heap_regs->functor_list = FuncAdjust(heap_regs->functor_list);
heap_regs->functor_mega_clause = FuncAdjust(heap_regs->functor_mega_clause);
heap_regs->functor_module = FuncAdjust(heap_regs->functor_module); heap_regs->functor_module = FuncAdjust(heap_regs->functor_module);
#ifdef MULTI_ASSIGNMENT_VARIABLES #ifdef MULTI_ASSIGNMENT_VARIABLES
heap_regs->functor_mutable = FuncAdjust(heap_regs->functor_mutable); heap_regs->functor_mutable = FuncAdjust(heap_regs->functor_mutable);
@ -305,6 +341,7 @@ restore_codes(void)
heap_regs->functor_or = FuncAdjust(heap_regs->functor_or); heap_regs->functor_or = FuncAdjust(heap_regs->functor_or);
heap_regs->functor_portray = FuncAdjust(heap_regs->functor_portray); heap_regs->functor_portray = FuncAdjust(heap_regs->functor_portray);
heap_regs->functor_query = FuncAdjust(heap_regs->functor_query); heap_regs->functor_query = FuncAdjust(heap_regs->functor_query);
heap_regs->functor_static_clause = FuncAdjust(heap_regs->functor_static_clause);
heap_regs->functor_stream = FuncAdjust(heap_regs->functor_stream); heap_regs->functor_stream = FuncAdjust(heap_regs->functor_stream);
heap_regs->functor_stream_pos = FuncAdjust(heap_regs->functor_stream_pos); heap_regs->functor_stream_pos = FuncAdjust(heap_regs->functor_stream_pos);
heap_regs->functor_stream_eOS = FuncAdjust(heap_regs->functor_stream_eOS); heap_regs->functor_stream_eOS = FuncAdjust(heap_regs->functor_stream_eOS);
@ -617,6 +654,12 @@ restore_opcodes(yamop *pc)
case _skip: case _skip:
case _jump_if_var: case _jump_if_var:
case _try_in: case _try_in:
case _try_clause2:
case _try_clause3:
case _try_clause4:
case _retry2:
case _retry3:
case _retry4:
pc->u.l.l = PtoOpAdjust(pc->u.l.l); pc->u.l.l = PtoOpAdjust(pc->u.l.l);
pc = NEXTOP(pc,l); pc = NEXTOP(pc,l);
break; break;
@ -725,17 +768,9 @@ restore_opcodes(yamop *pc)
pc = NEXTOP(pc,xF); pc = NEXTOP(pc,xF);
break; break;
case _expand_clauses: case _expand_clauses:
pc->u.sp.p = PtoPredAdjust(pc->u.sp.p); Yap_Error(SYSTEM_ERROR, TermNil,
{ "Invalid Opcode expand_clauses at %p", pc);
COUNT i; break;
yamop **st = (yamop **)NEXTOP(pc,sp);
for (i = 0; i < pc->u.sp.s1; i++, st++) {
if (*st) {
*st = PtoOpAdjust(*st);
}
}
}
/* instructions type y */ /* instructions type y */
case _save_b_y: case _save_b_y:
case _commit_b_y: case _commit_b_y:
@ -840,6 +875,166 @@ restore_opcodes(yamop *pc)
} }
pc = NEXTOP(pc,xc); pc = NEXTOP(pc,xc);
break; break;
/* instructions type cc */
case _get_2atoms:
{
Term t = pc->u.cc.c1;
if (IsAtomTerm(t))
pc->u.cc.c1 = AtomTermAdjust(t);
else if (IsApplTerm(t))
pc->u.cc.c1 = BlobTermAdjust(t);
}
{
Term t = pc->u.cc.c2;
if (IsAtomTerm(t))
pc->u.cc.c2 = AtomTermAdjust(t);
else if (IsApplTerm(t))
pc->u.cc.c2 = BlobTermAdjust(t);
}
pc = NEXTOP(pc,cc);
break;
/* instructions type ccc */
case _get_3atoms:
{
Term t = pc->u.ccc.c1;
if (IsAtomTerm(t))
pc->u.ccc.c1 = AtomTermAdjust(t);
else if (IsApplTerm(t))
pc->u.ccc.c1 = BlobTermAdjust(t);
}
{
Term t = pc->u.ccc.c2;
if (IsAtomTerm(t))
pc->u.ccc.c2 = AtomTermAdjust(t);
else if (IsApplTerm(t))
pc->u.ccc.c2 = BlobTermAdjust(t);
}
{
Term t = pc->u.ccc.c3;
if (IsAtomTerm(t))
pc->u.ccc.c3 = AtomTermAdjust(t);
else if (IsApplTerm(t))
pc->u.ccc.c3 = BlobTermAdjust(t);
}
pc = NEXTOP(pc,ccc);
break;
/* instructions type cccc */
case _get_4atoms:
{
Term t = pc->u.cccc.c1;
if (IsAtomTerm(t))
pc->u.cccc.c1 = AtomTermAdjust(t);
else if (IsApplTerm(t))
pc->u.cccc.c1 = BlobTermAdjust(t);
}
{
Term t = pc->u.cccc.c2;
if (IsAtomTerm(t))
pc->u.cccc.c2 = AtomTermAdjust(t);
else if (IsApplTerm(t))
pc->u.cccc.c2 = BlobTermAdjust(t);
}
{
Term t = pc->u.cccc.c3;
if (IsAtomTerm(t))
pc->u.cccc.c3 = AtomTermAdjust(t);
else if (IsApplTerm(t))
pc->u.cccc.c3 = BlobTermAdjust(t);
}
{
Term t = pc->u.cccc.c4;
if (IsAtomTerm(t))
pc->u.cccc.c4 = AtomTermAdjust(t);
else if (IsApplTerm(t))
pc->u.cccc.c4 = BlobTermAdjust(t);
}
pc = NEXTOP(pc,cccc);
break;
/* instructions type ccccc */
case _get_5atoms:
{
Term t = pc->u.ccccc.c1;
if (IsAtomTerm(t))
pc->u.ccccc.c1 = AtomTermAdjust(t);
else if (IsApplTerm(t))
pc->u.ccccc.c1 = BlobTermAdjust(t);
}
{
Term t = pc->u.ccccc.c2;
if (IsAtomTerm(t))
pc->u.ccccc.c2 = AtomTermAdjust(t);
else if (IsApplTerm(t))
pc->u.ccccc.c2 = BlobTermAdjust(t);
}
{
Term t = pc->u.ccccc.c3;
if (IsAtomTerm(t))
pc->u.ccccc.c3 = AtomTermAdjust(t);
else if (IsApplTerm(t))
pc->u.ccccc.c3 = BlobTermAdjust(t);
}
{
Term t = pc->u.ccccc.c4;
if (IsAtomTerm(t))
pc->u.ccccc.c4 = AtomTermAdjust(t);
else if (IsApplTerm(t))
pc->u.ccccc.c4 = BlobTermAdjust(t);
}
{
Term t = pc->u.ccccc.c5;
if (IsAtomTerm(t))
pc->u.ccccc.c5 = AtomTermAdjust(t);
else if (IsApplTerm(t))
pc->u.ccccc.c5 = BlobTermAdjust(t);
}
pc = NEXTOP(pc,ccccc);
break;
/* instructions type cccccc */
case _get_6atoms:
{
Term t = pc->u.cccccc.c1;
if (IsAtomTerm(t))
pc->u.cccccc.c1 = AtomTermAdjust(t);
else if (IsApplTerm(t))
pc->u.cccccc.c1 = BlobTermAdjust(t);
}
{
Term t = pc->u.cccccc.c2;
if (IsAtomTerm(t))
pc->u.cccccc.c2 = AtomTermAdjust(t);
else if (IsApplTerm(t))
pc->u.cccccc.c2 = BlobTermAdjust(t);
}
{
Term t = pc->u.cccccc.c3;
if (IsAtomTerm(t))
pc->u.cccccc.c3 = AtomTermAdjust(t);
else if (IsApplTerm(t))
pc->u.cccccc.c3 = BlobTermAdjust(t);
}
{
Term t = pc->u.cccccc.c4;
if (IsAtomTerm(t))
pc->u.cccccc.c4 = AtomTermAdjust(t);
else if (IsApplTerm(t))
pc->u.cccccc.c4 = BlobTermAdjust(t);
}
{
Term t = pc->u.cccccc.c5;
if (IsAtomTerm(t))
pc->u.cccccc.c5 = AtomTermAdjust(t);
else if (IsApplTerm(t))
pc->u.cccccc.c5 = BlobTermAdjust(t);
}
{
Term t = pc->u.cccccc.c6;
if (IsAtomTerm(t))
pc->u.cccccc.c6 = AtomTermAdjust(t);
else if (IsApplTerm(t))
pc->u.cccccc.c6 = BlobTermAdjust(t);
}
pc = NEXTOP(pc,cccccc);
break;
/* instructions type xf */ /* instructions type xf */
case _get_struct: case _get_struct:
case _put_struct: case _put_struct:
@ -1334,6 +1529,18 @@ RestoreStaticClause(StaticClause *cl, PredEntry *pp)
restore_opcodes(cl->ClCode); restore_opcodes(cl->ClCode);
} }
/* Restores a prolog clause, in its compiled form */
static void
RestoreMegaClause(MegaClause *cl, PredEntry *pp)
/*
* Cl points to the start of the code, IsolFlag tells if we have a single
* clause for this predicate or not
*/
{
cl->ClPred = PtoPredAdjust(cl->ClPred);
restore_opcodes(cl->ClCode);
}
/* Restores a prolog clause, in its compiled form */ /* Restores a prolog clause, in its compiled form */
static void static void
RestoreDynamicClause(DynamicClause *cl, PredEntry *pp) RestoreDynamicClause(DynamicClause *cl, PredEntry *pp)
@ -1389,6 +1596,10 @@ CleanClauses(yamop *First, yamop *Last, PredEntry *pp)
RestoreLUClause(cl, pp); RestoreLUClause(cl, pp);
cl = cl->ClNext; cl = cl->ClNext;
} }
} else if (pp->PredFlags & MegaClausePredFlag) {
MegaClause *cl = ClauseCodeToMegaClause(First);
RestoreMegaClause(cl, pp);
} else if (pp->PredFlags & DynamicPredFlag) { } else if (pp->PredFlags & DynamicPredFlag) {
yamop *cl = First; yamop *cl = First;

16803
configure vendored
View File

File diff suppressed because it is too large Load Diff

32
distribute
View File

@ -1,8 +1,8 @@
#/bin/bash #/bin/bash
# Guess what: this code works for me! # Guess what: this code works for me!
parent=$(cd ..;pwd)
version=${PWD##$parent/}
version="Yap-4.5.3"
PATH="$PATH":~/bin/noarch
splat splat
cd C cd C
splat splat
@ -14,16 +14,26 @@ cd ../VC
splat splat
cd ../LGPL cd ../LGPL
splat splat
cd pillow cd JPL
splat
cd src
splat
cd ../java
splat
cd jpl
splat
cd fli
splat
cd ../../../../pillow
splat splat
cd examples cd examples
splat splat
cd ../../../include cd ../../../include
splat splat
/bin/cp config.h config.h.mine #/bin/cp config.h config.h.mine
/bin/cp ../../../bins/cyg/*.h . #/bin/cp ../../../bins/cyg/*.h .
/bin/mv config.h.mine config.h #/bin/mv config.h.mine config.h
cd ../../console cd ../console
splat splat
cd ../docs cd ../docs
splat splat
@ -65,11 +75,15 @@ cd ../../CHR
splat splat
cd chr cd chr
splat splat
cd ../../CLPBN
splat
cd clpbn
splat
cd examples cd examples
splat splat
cd ../../../.. cd ../../../..
if test "$1" = "--small"; then if test "$1" = "--small"; then
tar cvzf "$version"-small.tar.gz --exclude=CVS --exclude=CHR/chr/examples --exclude=CLPQR/clpqr/examples "$version"/{Artistic,INSTALL,README*,changes*,config*,install-sh,Makefile.in,.depend.in,distribute,C,H,VC,console,docs,include,library,m4,misc,pl,LGPL/README,LGPL/CVS,LGPL/pillow/[C-Z]*,LGPL/pillow/*.pl,LGPL/pillow/doc/*info*,build-distr,OPTYap,CLPQR,CHR} tar cvzf "$version"-small.tar.gz --exclude=CVS --exclude=CHR/chr/examples --exclude=CLPQR/clpqr/examples "$version"/{Artistic,INSTALL,README*,changes*,config*,install-sh,Makefile.in,.depend.in,distribute,C,H,VC,console,docs,include,library,m4,misc,pl,LGPL/README,LGPL/pillow/[C-Z]*,LGPL/pillow/*.pl,LGPL/pillow/doc/*info*,LGPL/JPL/jpl.yap,LGPL/JPL/Makefile.in,LGPL/JPL/java,LGPL/JPL/src,build-distr,OPTYap,CLPQR,CHR,CLPBN}
else else
tar cvzf "$version".tar.gz --exclude=CVS "$version"/{Artistic,INSTALL,README*,changes*,config*,install-sh,Makefile.in,.depend.in,distribute,C,H,VC,console,docs,include,library,m4,misc,pl,LGPL,build-distr,OPTYap,CLPQR,CHR,Logtalk} tar cvzf "$version".tar.gz --exclude=CVS "$version"/{Artistic,INSTALL,README*,changes*,config*,install-sh,Makefile.in,.depend.in,distribute,C,H,VC,console,docs,include,library,m4,misc,pl,LGPL/README,LGPL/pillow/[C-Z]*,LGPL/pillow/*.pl,LGPL/pillow/doc/*info*,LGPL/JPL/jpl.yap,LGPL/JPL/Makefile.in,LGPL/JPL/java,LGPL/JPL/src,build-distr,build-distr,OPTYap,CLPQR,CHR,CLPBN,Logtalk}
fi fi

4
m4/Yatom.h.m4
View File

@ -162,7 +162,8 @@ Inline(IsValProperty, PropFlags, int, flags, (flags == ValProperty) )
CodeOfPred holds the address of the correspondent C-function. CodeOfPred holds the address of the correspondent C-function.
*/ */
typedef enum { typedef enum {
ThreadLocalPredFlag=0x40000000L, /* local to a thread */ MegaClausePredFlag=0x80000000L, /* predicate is implemented as a mega-clause */
ThreadLocalPredFlag=0x40000000L, /* local to a thread */
MultiFileFlag = 0x20000000L, /* is multi-file */ MultiFileFlag = 0x20000000L, /* is multi-file */
UserCPredFlag = 0x10000000L, /* CPred defined by the user */ UserCPredFlag = 0x10000000L, /* CPred defined by the user */
LogUpdatePredFlag= 0x08000000L, /* dynamic predicate with log. upd. sem.*/ LogUpdatePredFlag= 0x08000000L, /* dynamic predicate with log. upd. sem.*/
@ -258,6 +259,7 @@ Inline(IsPredProperty, PropFlags, int, flags, (flags == PEProp) )
/* Flags for code or dbase entry */ /* Flags for code or dbase entry */
/* There are several flags for code and data base entries */ /* There are several flags for code and data base entries */
typedef enum { typedef enum {
MegaMask = 0x200000, /* informs this is a mega clause */
FactMask = 0x100000, /* informs this is a fact */ FactMask = 0x100000, /* informs this is a fact */
SwitchRootMask= 0x80000, /* informs this is the root for the index tree */ SwitchRootMask= 0x80000, /* informs this is the root for the index tree */
SwitchTableMask=0x40000, /* informs this is a switch table */ SwitchTableMask=0x40000, /* informs this is a switch table */