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 *
* 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 $
* Revision 1.145 2004/09/17 20:47:35 vsc
* fix some overflows recorded.
*
* Revision 1.144 2004/09/17 19:34:49 vsc
* simplify frozen/2
*
@ -460,7 +463,7 @@ Yap_absmi(int inp)
#if BP_FREE
P1REG = PCBACKUP;
#endif
return (1);
return 1;
ENDBOp();
BOp(Nstop, e);
@ -1737,6 +1740,9 @@ Yap_absmi(int inp)
case _or_last:
low_level_trace(retry_or, (PredEntry *)ipc, &(B->cp_a1));
break;
case _retry2:
case _retry3:
case _retry4:
case _trust_logical_pred:
ipc = NEXTOP(ipc,l);
go_on = TRUE;
@ -3078,6 +3084,521 @@ Yap_absmi(int inp)
ENDD(d0);
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
* or the write stream */
@ -6797,6 +7318,72 @@ Yap_absmi(int inp)
JMPNext();
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);
CACHE_Y(B);
restore_yaam_regs(NEXTOP(PREG, ld));
@ -6813,6 +7400,60 @@ Yap_absmi(int inp)
JMPNext();
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);
CACHE_Y(B);
#ifdef YAPOR

6
C/alloc.c
View File

@ -12,7 +12,7 @@
* Last rev: *
* mods: *
* 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
static char SccsId[] = "%W% %G%";
@ -326,10 +326,10 @@ FreeBlock(BlockHeader *b)
sp = &(b->b_size) + (b->b_size & ~InUseFlag);
if (*sp != b->b_size) {
#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));
#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);
#endif
return;

159
C/amasm.c
View File

@ -11,8 +11,12 @@
* File: amasm.c *
* 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 $
* 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
* 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;
}
inline static yamop *
a_rc(op_numbers opcode, yamop *code_p, int pass_no, struct PSEUDO *cpc)
static yamop *
a_rc(op_numbers opcode, yamop *code_p, int pass_no, struct intermediates *cip)
{
if (pass_no) {
code_p->opc = emit_op(opcode);
code_p->u.xc.x = emit_x(cpc->rnd2);
code_p->u.xc.c = emit_c(cpc->rnd1);
if (cip->cpc->rnd2 == 1 &&
cip->cpc->nextInst->rnd2 == 2 &&
(cip->cpc->nextInst->op == get_atom_op ||
cip->cpc->nextInst->op == get_num_op)) {
struct PSEUDO *next;
next = cip->cpc->nextInst;
if (next->nextInst->rnd2 == 3 &&
(next->nextInst->op == get_atom_op ||
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;
}
@ -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)
#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) {
code_p->opc = emit_op(opcode);
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 {
/* static clause */
if (pass_no) {
cl_u->sc.Id = FunctorDBRef;
cl_u->sc.ClFlags = StaticMask;
cl_u->sc.ClNext = NULL;
cl_u->sc.ClSize = size;
@ -2308,7 +2439,7 @@ do_pass(int pass_no, yamop **entry_codep, int assembling, int *clause_has_blobsp
break;
case get_num_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;
case get_float_op:
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;
case put_num_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;
case put_float_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->code_addr = NULL;
code_p = do_pass(0, &entry_code, mode, &clause_has_blobs, cip, size);
size =
(CELL)NEXTOP(NEXTOP(NEXTOP((yamop *)(((DynamicClause *)NULL)->ClCode),ld),sla),e);
if (ap->PredFlags & DynamicPredFlag) {
size =
(CELL)NEXTOP(NEXTOP(NEXTOP((yamop *)(((DynamicClause *)NULL)->ClCode),ld),sla),e);
}
if ((CELL)code_p > size)
size = (CELL)code_p;
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_y_val);
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_struct);
fprintf(Yap_stderr, "\n Optimised Get Instructions\n");
@ -342,7 +347,12 @@ p_show_ops_by_group(void)
c_get.nyval =
Yap_opcount[_get_y_val];
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 =
Yap_opcount[_get_list] +
Yap_opcount[_glist_valx] +

46
C/attvar.c
View File

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

473
C/cdmgr.c
View File

@ -1,3 +1,4 @@
/*************************************************************************
* *
* YAP Prolog *
@ -11,8 +12,11 @@
* File: cdmgr.c *
* 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 $
* Revision 1.132 2004/09/17 19:34:51 vsc
* simplify frozen/2
*
* Revision 1.131 2004/09/08 17:56:45 vsc
* source: a(X) :- true is a fact!
* 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 expand_consult, (void));
STATIC_PROTO(int not_was_reconsulted, (PredEntry *, Term, int));
STATIC_PROTO(int RemoveIndexation, (PredEntry *));
#if EMACS
STATIC_PROTO(int last_clause_number, (PredEntry *));
#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) && \
(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
@ -204,6 +275,141 @@ static_in_use(PredEntry *p, int check_everything)
#define is_tabled(pe) (pe->PredFlags & TabledPredFlag)
#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
@ -337,6 +543,19 @@ release_wcls(yamop *cop, OPCODE ecs)
if (cop->opc == ecs) {
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
Yap_expand_clauses_sz -= (UInt)(NEXTOP((yamop *)NULL,sp)+cop->u.sp.s1*sizeof(yamop *));
#endif
@ -374,6 +593,17 @@ cleanup_dangling_indices(yamop *ipc, yamop *beg, yamop *end, yamop *suspend_code
case _count_retry:
ipc = NEXTOP(ipc,p);
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 _trust:
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;
default:
Yap_Error(SYSTEM_ERROR,TermNil,"Bug in Indexing Code: opcode %d", op);
return;
}
#if defined(YAPOR) || defined(THREADS)
ipc = (yamop *)((CELL)ipc & ~1);
@ -765,6 +996,20 @@ retract_all(PredEntry *p, int in_use)
Yap_ErLogUpdCl(cl);
cl = ncl;
} 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 {
StaticClause *cl = ClauseCodeToStaticClause(q);
@ -1115,7 +1360,7 @@ static void expand_consult(void)
/* I assume it always works ;-) */
while ((new_cl = (consult_obj *)Yap_AllocCodeSpace(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;
}
}
@ -1258,6 +1503,10 @@ addclause(Term t, yamop *cp, int mode, int mod)
addcl_permission_error(RepAtom(at), Arity, FALSE);
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
Indexing blocks
*/
@ -1331,7 +1580,7 @@ addclause(Term t, yamop *cp, int mode, int mod)
if (pflags & LogUpdatePredFlag) {
return MkDBRefTerm((DBRef)ClauseCodeToLogUpdClause(cp));
} 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);
}
void
Yap_EraseMegaClause(yamop *cl,PredEntry *ap) {
/* just make it fail */
cl->opc = Yap_opcode(_op_fail);
}
void
Yap_EraseStaticClause(StaticClause *cl, Term mod) {
PredEntry *ap;
@ -1730,50 +1985,10 @@ p_endconsult(void)
static void
purge_clauses(PredEntry *pred)
{
yamop *q;
int in_use;
if (pred->PredFlags & IndexedPredFlag)
RemoveIndexation(pred);
Yap_PutValue(AtomAbol, MkAtomTerm(AtomTrue));
q = pred->cs.p_code.FirstClause;
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));
retract_all(pred, static_in_use(pred,TRUE));
pred->src.OwnerFile = AtomNil;
if (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;
}
do {
PredEntry *pe;
/* check first environments that are younger than our latest choicepoint */
if (check_everything && env_ptr) {
/*
@ -2454,58 +2671,38 @@ search_for_static_predicate_in_use(PredEntry *p, int check_everything)
}
}
/* now mark the choicepoint */
if (b_ptr != NULL) {
PredEntry *pe;
op_numbers opnum = Yap_op_from_opcode(b_ptr->cp_ap->opc);
restart_cp:
switch(opnum) {
case _or_else:
case _or_last:
if (!check_everything) {
b_ptr = b_ptr->cp_b;
continue;
}
#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;
pe = PredForChoicePt(b_ptr);
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) {
LogUpdIndex *cl = ClauseCodeToLogUpdIndex(code_beg);
if (find_owner_log_index(cl, code_p))
b_ptr->cp_ap = cur_log_upd_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);
}
/* FIX ME */
if (p->PredFlags & LogUpdatePredFlag) {
LogUpdIndex *cl = ClauseCodeToLogUpdIndex(code_beg);
if (find_owner_log_index(cl, code_p))
b_ptr->cp_ap = cur_log_upd_clause(pe, b_ptr->cp_ap->u.ld.d);
} else if (p->PredFlags & MegaClausePredFlag) {
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);
} 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;
b_ptr = b_ptr->cp_b;
READ_UNLOCK(pe->PRWLock);
}
env_ptr = b_ptr->cp_env;
b_ptr = b_ptr->cp_b;
} while (b_ptr != NULL);
return(FALSE);
}
@ -2547,37 +2744,11 @@ do_toggle_static_predicates_in_use(int mask)
env_ptr = (CELL *)(env_ptr[E_E]);
}
/* now mark the choicepoint */
{
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)
if ((pe = PredForChoicePt(b_ptr))) {
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);
/* mark or unmark all predicates */
STATIC_PREDICATES_MARKED = mask;
@ -2802,6 +2973,15 @@ code_in_pred(PredEntry *pp, Atom *pat, UInt *parity, yamop *codeptr) {
i++;
clcode = NextDynamicClause(clcode);
} 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 {
StaticClause *cl;
@ -2864,6 +3044,8 @@ p_pred_for_code(void) {
if (IsVarTerm(t)) {
return FALSE;
} else if (IsApplTerm(t) && FunctorOfTerm(t) == FunctorStaticClause) {
codeptr = Yap_ClauseFromTerm(t)->ClCode;
} else if (IsIntegerTerm(t)) {
codeptr = (yamop *)IntegerOfTerm(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[1] = tb;
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);
tb = Yap_GetFromSlot(slb);
/* 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)
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 (!Yap_unify(tb, MkAtomTerm(AtomTrue)) ||
!Yap_unify(tr, rtn))
@ -3629,7 +3836,7 @@ p_nth_clause(void)
cl = Yap_NthClause(pe, ncls);
if (cl == NULL)
return FALSE;
if (cl->ClFlags & LogUpdatePredFlag) {
if (pe->PredFlags & LogUpdatePredFlag) {
#if defined(YAPOR) || defined(THREADS)
LOCK(cl->ClLock);
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 */
}
#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) */
@ -3771,6 +3982,16 @@ static_statistics(PredEntry *pe)
UInt sz = 0, cls = 0, isz = 0;
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) {
do {
cls++;
@ -3780,10 +4001,6 @@ static_statistics(PredEntry *pe)
cl = cl->ClNext;
} 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)) &&
Yap_unify(ARG4, MkIntegerTerm(sz)) &&
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
dbg->lr--;
#endif
if (!(dbentry->Flags & StaticMask)) {
if (dbentry->Flags & LogUpdMask) {
LogUpdClause *cl = (LogUpdClause *)dbentry;
if (dbentry->Flags & LogUpdMask) {
LogUpdClause *cl = (LogUpdClause *)dbentry;
cl->ClRefCount++;
} else {
dbentry->NOfRefsTo++;
}
cl->ClRefCount++;
} else {
dbentry->NOfRefsTo++;
}
*--dbg->tofref = dbentry;
db_check_trail(dbg->lr);
@ -2394,8 +2392,8 @@ static int
copy_attachments(CELL *ts)
{
while (TRUE) {
attvar_record *orig = (attvar_record *)Yap_ReadTimedVar(DelayedVars);
/* store away in case there is an overflow */
if (attas[IntegerOfTerm(ts[2])].term_to_op(ts[1], ts[0]) == FALSE) {
/* 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));
}
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
p_heap_space_info(void)
{
@ -4312,9 +4272,6 @@ EraseEntry(DBRef entryref)
if (entryref->Flags & ErasedMask)
return;
if (entryref->Flags & StaticMask) {
return;
}
if (entryref->Flags & LogUpdMask &&
!(entryref->Flags & DBClMask)) {
EraseLogUpdCl((LogUpdClause *)entryref);
@ -4383,17 +4340,21 @@ p_erase_clause(void)
return (FALSE);
}
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");
return (FALSE);
} else {
entryref = DBRefOfTerm(t1);
}
if (entryref->Flags & StaticMask) {
if (entryref->Flags & ErasedMask)
return FALSE;
Yap_EraseStaticClause((StaticClause *)entryref, Deref(ARG2));
return TRUE;
}
EraseEntry(entryref);
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) */
static Int
p_instance(void)
@ -4547,13 +4536,19 @@ p_instance(void)
DBRef dbr;
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 {
dbr = DBRefOfTerm(t1);
}
if (dbr->Flags & StaticMask) {
return static_instance((StaticClause *)dbr);
} else if (dbr->Flags & LogUpdMask) {
if (dbr->Flags & LogUpdMask) {
op_numbers opc;
LogUpdClause *cl = (LogUpdClause *)dbr;
@ -5224,7 +5219,6 @@ Yap_InitDBPreds(void)
#ifdef DEBUG
Yap_InitCPred("total_erased", 4, p_total_erased, 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);
#endif
Yap_InitCPred("nth_instance", 3, p_nth_instance, SyncPredFlag);

22
C/errors.c
View File

@ -137,30 +137,10 @@ DumpActiveGoals (void)
while (TRUE)
{
PredEntry *pe;
op_numbers opnum;
if (!ONLOCAL (b_ptr) || b_ptr->cp_b == NULL)
break;
opnum = Yap_op_from_opcode(b_ptr->cp_ap->opc);
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);
}
pe = Yap_PredForChoicePt(b_ptr);
READ_LOCK(pe->PRWLock);
{
Functor f;

6
C/exec.c
View File

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

90
C/grow.c
View File

@ -124,32 +124,50 @@ SetHeapRegs(void)
AuxSp = PtoDelayAdjust(AuxSp);
AuxTop = (ADDR)PtoDelayAdjust((CELL *)AuxTop);
#endif
HeapLim = DelayAddrAdjust(HeapLim);
if (HeapLim)
HeapLim = DelayAddrAdjust(HeapLim);
/* The registers pointing to one of the stacks */
ENV = PtoLocAdjust(ENV);
ASP = PtoLocAdjust(ASP);
H0 = PtoGloAdjust(H0);
LCL0 = PtoLocAdjust(LCL0);
H = PtoGloAdjust(H);
HB = PtoGloAdjust(HB);
B = ChoicePtrAdjust(B);
if (ENV)
ENV = PtoLocAdjust(ENV);
if (ASP)
ASP = PtoLocAdjust(ASP);
if (H0)
H0 = PtoGloAdjust(H0);
if (LCL0)
LCL0 = PtoLocAdjust(LCL0);
if (H)
H = PtoGloAdjust(H);
if (HB)
HB = PtoGloAdjust(HB);
if (B)
B = ChoicePtrAdjust(B);
#ifdef TABLING
B_FZ = ChoicePtrAdjust(B_FZ);
BB = ChoicePtrAdjust(BB);
H_FZ = PtoGloAdjust(H_FZ);
TR_FZ = PtoTRAdjust(TR_FZ);
if (B_FZ)
B_FZ = ChoicePtrAdjust(B_FZ);
if (BB)
BB = ChoicePtrAdjust(BB);
if (H_FZ)
H_FZ = PtoGloAdjust(H_FZ);
if (TR_FZ)
TR_FZ = PtoTRAdjust(TR_FZ);
#endif /* TABLING */
TR = PtoTRAdjust(TR);
YENV = PtoLocAdjust(YENV);
if (TR)
TR = PtoTRAdjust(TR);
if (YENV)
YENV = PtoLocAdjust(YENV);
if (IsOldGlobalPtr(S))
S = PtoGloAdjust(S);
else if (IsOldLocalPtr(S))
S = PtoLocAdjust(S);
#ifdef COROUTINING
DelayedVars = AbsAppl(PtoGloAdjust(RepAppl(DelayedVars)));
MutableList = AbsAppl(PtoGloAdjust(RepAppl(MutableList)));
AttsMutableList = AbsAppl(PtoGloAdjust(RepAppl(AttsMutableList)));
WokenGoals = AbsAppl(PtoGloAdjust(RepAppl(WokenGoals)));
if (DelayedVars)
DelayedVars = AbsAppl(PtoGloAdjust(RepAppl(DelayedVars)));
if (MutableList)
MutableList = AbsAppl(PtoGloAdjust(RepAppl(MutableList)));
if (AttsMutableList)
AttsMutableList = AbsAppl(PtoGloAdjust(RepAppl(AttsMutableList)));
if (WokenGoals)
WokenGoals = AbsAppl(PtoGloAdjust(RepAppl(WokenGoals)));
#endif
}
@ -173,21 +191,33 @@ SetStackRegs(void)
Yap_LocalBase = LocalAddrAdjust(Yap_LocalBase);
TR = PtoTRAdjust(TR);
/* The registers pointing to the local stack */
ENV = PtoLocAdjust(ENV);
ASP = PtoLocAdjust(ASP);
LCL0 = PtoLocAdjust(LCL0);
B = ChoicePtrAdjust(B);
if (ENV)
ENV = PtoLocAdjust(ENV);
if (ASP)
ASP = PtoLocAdjust(ASP);
if (LCL0)
LCL0 = PtoLocAdjust(LCL0);
if (B)
B = ChoicePtrAdjust(B);
#ifdef TABLING
B_FZ = ChoicePtrAdjust(B_FZ);
BB = ChoicePtrAdjust(BB);
TR_FZ = PtoTRAdjust(TR_FZ);
if (B_FZ)
B_FZ = ChoicePtrAdjust(B_FZ);
if (BB)
BB = ChoicePtrAdjust(BB);
if (TR_FZ)
TR_FZ = PtoTRAdjust(TR_FZ);
#endif /* TABLING */
YENV = PtoLocAdjust(YENV);
if (YENV)
YENV = PtoLocAdjust(YENV);
#ifdef COROUTINING
DelayedVars = AbsAppl(PtoGloAdjust(RepAppl(DelayedVars)));
MutableList = AbsAppl(PtoGloAdjust(RepAppl(MutableList)));
AttsMutableList = AbsAppl(PtoGloAdjust(RepAppl(AttsMutableList)));
WokenGoals = AbsAppl(PtoGloAdjust(RepAppl(WokenGoals)));
if (DelayedVars)
DelayedVars = AbsAppl(PtoGloAdjust(RepAppl(DelayedVars)));
if (MutableList)
MutableList = AbsAppl(PtoGloAdjust(RepAppl(MutableList)));
if (AttsMutableList)
AttsMutableList = AbsAppl(PtoGloAdjust(RepAppl(AttsMutableList)));
if (WokenGoals)
WokenGoals = AbsAppl(PtoGloAdjust(RepAppl(WokenGoals)));
#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);
}
if (very_verbose) {
switch (opnum) {
case _retry_c:
case _or_else:
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:
PredEntry *pe = Yap_PredForChoicePt(gc_B);
if (pe == NULL) {
fprintf(Yap_stderr,"%% marked %ld (%s)\n", total_marked, op_names[opnum]);
break;
#endif
default:
{
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]);
}
} 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 _retry_and_mark:
ClauseCodeToDynamicClause(gc_B->cp_ap)->ClFlags |= GcFoundMask;
case _retry2:
nargs = 2;
break;
case _retry3:
nargs = 3;
break;
case _retry4:
nargs = 4;
break;
#ifdef DEBUG
case _retry_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
@ -2648,6 +2629,15 @@ sweep_choicepoints(choiceptr gc_B)
}
break;
#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_userc:
{
@ -2668,26 +2658,7 @@ sweep_choicepoints(choiceptr gc_B)
}
/* continue to clean environments and arguments */
default:
{
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));
}
}
}
}
sweep_b(gc_B,rtp->u.ld.s);
}
/* link to prev choicepoint */

842
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
Yap_InitCPred(char *Name, unsigned long int Arity, CPredicate code, int flags)
{
Atom atom = Yap_FullLookupAtom(Name);
PredEntry *pe;
yamop *p_code = ((StaticClause *)NULL)->ClCode;
StaticClause *cl;
Atom atom = Yap_FullLookupAtom(Name);
PredEntry *pe;
yamop *p_code = ((StaticClause *)NULL)->ClCode;
StaticClause *cl = NULL;
if (Arity)
pe = RepPredProp(PredPropByFunc(Yap_MkFunctor(atom, Arity),CurrentModule));
else
pe = RepPredProp(PredPropByAtom(atom,CurrentModule));
if (pe->PredFlags & SafePredFlag) {
cl = (StaticClause *)Yap_AllocCodeSpace((CELL)NEXTOP(NEXTOP(((yamop *)p_code),sla),e));
} else {
cl = (StaticClause *)Yap_AllocCodeSpace((CELL)NEXTOP(NEXTOP(NEXTOP(NEXTOP(((yamop *)p_code),e),sla),e),e));
if (pe->PredFlags & CPredFlag) {
/* already exists */
cl = ClauseCodeToStaticClause(pe->CodeOfPred);
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->PredFlags = flags | StandardPredFlag | CPredFlag;
pe->cs.f_code = code;
if (!(pe->PredFlags & SafePredFlag)) {
if (!(flags & SafePredFlag)) {
p_code->opc = Yap_opcode(_allocate);
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.sla_u.p = pe;
p_code = NEXTOP(p_code,sla);
if (!(pe->PredFlags & SafePredFlag)) {
if (!(flags & SafePredFlag)) {
p_code->opc = Yap_opcode(_deallocate);
p_code = NEXTOP(p_code,e);
}
p_code->opc = Yap_opcode(_procceed);
p_code = NEXTOP(p_code,e);
p_code->opc = Yap_opcode(_Ystop);
pe->OpcodeOfPred = pe->CodeOfPred->opc;
pe->ModuleOfPred = CurrentModule;
}
@ -501,17 +528,37 @@ Yap_InitCPred(char *Name, unsigned long int Arity, CPredicate code, int flags)
void
Yap_InitCmpPred(char *Name, unsigned long int Arity, CmpPredicate cmp_code, int flags)
{
Atom atom = Yap_LookupAtom(Name);
PredEntry *pe;
yamop *p_code = ((StaticClause *)NULL)->ClCode;
StaticClause *cl = (StaticClause *)Yap_AllocCodeSpace((CELL)NEXTOP(NEXTOP(NEXTOP(((yamop *)p_code),llxx),e),e));
Atom atom = Yap_LookupAtom(Name);
PredEntry *pe;
yamop *p_code = NULL;
StaticClause *cl = NULL;
cl->ClFlags = 0;
p_code = cl->ClCode;
if (Arity)
if (Arity) {
pe = RepPredProp(PredPropByFunc(Yap_MkFunctor(atom, Arity),CurrentModule));
else
} else {
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->CodeOfPred = p_code;
pe->cs.d_code = cmp_code;
@ -739,6 +786,8 @@ InitCodes(void)
#endif /* YAPOR */
#endif /* TABLING */
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_1 = 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_last_execute_within = Yap_MkFunctor(Yap_FullLookupAtom("$last_execute_within"), 1);
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);
#ifdef MULTI_ASSIGNMENT_VARIABLES
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_query = Yap_MkFunctor(AtomQuery, 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_pos = Yap_MkFunctor (AtomStreamPos, 3);
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;
INIT_LOCK(heap_regs->db_erased_marker->lock);
INIT_DBREF_COUNT(heap_regs->db_erased_marker);
heap_regs->yap_streams = NULL;
#if DEBUG
heap_regs->expand_clauses_sz = 0L;
#endif

18
C/iopreds.c
View File

@ -2477,16 +2477,13 @@ Yap_CloseStreams (int loud)
if (loud)
fprintf (Yap_stderr, "%% YAP Error: while closing stream: %s\n", RepAtom (Stream[sno].u.file.name)->StrOfAE);
}
if (Yap_c_input_stream == sno)
{
Yap_c_input_stream = StdInStream;
}
else if (Yap_c_output_stream == sno)
{
Yap_c_output_stream = StdOutStream;
}
if (Yap_c_input_stream == sno) {
Yap_c_input_stream = StdInStream;
} else if (Yap_c_output_stream == sno) {
Yap_c_output_stream = StdOutStream;
}
Stream[sno].status = Free_Stream_f;
}
Stream[sno].status = Free_Stream_f;
}
@ -4804,7 +4801,8 @@ Yap_InitIOPreds(void)
Yap_stdin = stdin;
Yap_stdout = stdout;
Yap_stderr = stderr;
Stream = (StreamDesc *)Yap_AllocCodeSpace(sizeof(StreamDesc)*MaxStreams);
if (!Stream)
Stream = (StreamDesc *)Yap_AllocCodeSpace(sizeof(StreamDesc)*MaxStreams);
/* here the Input/Output predicates */
Yap_InitCPred ("$check_stream", 2, p_check_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));
} else {
if (flags & LogUpdMask) {
Yap_ErLogUpdCl(ClauseFlagsToLogUpdClause(ent));
if (flags & IndexMask) {
Yap_ErLogUpdIndex(ClauseFlagsToLogUpdIndex(ent));
} else {
Yap_ErLogUpdCl(ClauseFlagsToLogUpdClause(ent));
}
} else {
Yap_ErCl(ClauseFlagsToDynamicClause(ent));
}
}
}
#ifdef MULTI_ASSIGNMENT_VARIABLES
} else /* if (IsApplTerm(d1)) */ {
Entries += 2;
#endif
}
}
B = NULL;

13
H/Heap.h
View File

@ -10,7 +10,7 @@
* File: Heap.h *
* mods: *
* 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 */
@ -112,6 +112,10 @@ typedef struct various_codes {
yamop tableanswerresolutioncode;
#endif /* TABLING */
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 failcode[1];
OPCODE failcode_1;
@ -317,6 +321,7 @@ typedef struct various_codes {
functor_g_var,
functor_last_execute_within,
functor_list,
functor_mega_clause,
functor_module,
#ifdef MULTI_ASSIGNMENT_VARIABLES
functor_mutable,
@ -325,6 +330,7 @@ typedef struct various_codes {
functor_or,
functor_portray,
functor_query,
functor_static_clause,
functor_stream,
functor_stream_pos,
functor_stream_eOS,
@ -426,6 +432,9 @@ struct various_codes *heap_regs;
#define ANSWER_RESOLUTION ((yamop *)&(heap_regs->tableanswerresolutioncode ))
#endif /* TABLING */
#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 FAILCODE heap_regs->failcode
#define TRUSTFAILCODE heap_regs->trustfailcode
@ -569,6 +578,7 @@ struct various_codes *heap_regs;
#define FunctorGVar heap_regs->functor_g_var
#define FunctorLastExecuteWithin heap_regs->functor_last_execute_within
#define FunctorList heap_regs->functor_list
#define FunctorMegaClause heap_regs->functor_mega_clause
#define FunctorModule heap_regs->functor_module
#ifdef MULTI_ASSIGNMENT_VARIABLES
#define FunctorMutable heap_regs->functor_mutable
@ -577,6 +587,7 @@ struct various_codes *heap_regs;
#define FunctorOr heap_regs->functor_or
#define FunctorPortray heap_regs->functor_portray
#define FunctorQuery heap_regs->functor_query
#define FunctorStaticClause heap_regs->functor_static_clause
#define FunctorStream heap_regs->functor_stream
#define FunctorStreamPos heap_regs->functor_stream_pos
#define FunctorStreamEOS heap_regs->functor_stream_eOS

16
H/YapOpcodes.h
View File

@ -11,8 +11,11 @@
* File: YapOpcodes.h *
* 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 $
* 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
* trim_trail for default machine
* be more aggressive about try-retry-trust chains.
@ -104,6 +107,11 @@
OPCODE(get_x_val ,xx),
OPCODE(get_y_val ,yx),
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_longint ,xc),
OPCODE(get_bigint ,xc),
@ -156,7 +164,13 @@
OPCODE(cut_t ,e),
OPCODE(cut_e ,sla),
OPCODE(try_clause ,ld),
OPCODE(try_clause2 ,l),
OPCODE(try_clause3 ,l),
OPCODE(try_clause4 ,l),
OPCODE(retry ,ld),
OPCODE(retry2 ,l),
OPCODE(retry3 ,l),
OPCODE(retry4 ,l),
OPCODE(trust ,ld),
OPCODE(try_in ,l),
OPCODE(jump_if_var ,l),

5
H/Yapproto.h
View File

@ -10,7 +10,7 @@
* File: Yap.proto *
* mods: *
* 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 */
@ -108,6 +108,7 @@ Int STD_PROTO(YAP_Execute,(struct pred_entry *, CPredicate));
Term STD_PROTO(Yap_all_calls,(void));
Atom STD_PROTO(Yap_ConsultingFile,(void));
Int STD_PROTO(Yap_PredForCode,(yamop *, Atom *, UInt *, Term *));
struct pred_entry *STD_PROTO(Yap_PredForChoicePt,(choiceptr));
void STD_PROTO(Yap_InitCdMgr,(void));
#if EMACS
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_end_consult,(void));
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 */

2
H/alloc.h
View File

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

42
H/amidefs.h
View File

@ -11,8 +11,12 @@
* File: amidefs.h *
* 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 $
* 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
* support expand group of clauses
*
@ -139,6 +143,41 @@ typedef struct yami {
CELL c;
CELL next;
} 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 {
CELL c;
struct yami *l1;
@ -366,6 +405,7 @@ typedef struct yami {
COUNT s1;
COUNT s2;
COUNT s3;
struct yami *sprev, *snext;
struct pred_entry *p;
CELL next;
} sp;

50
H/clause.h
View File

@ -109,7 +109,6 @@ typedef struct static_index {
typedef struct static_clause {
/* A set of flags describing info on the clause */
Functor Id;
CELL ClFlags;
UInt ClSize;
union {
@ -121,6 +120,16 @@ typedef struct static_clause {
yamop ClCode[MIN_ARRAY];
} 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 {
CELL ClFlags;
#if defined(YAPOR) || defined(THREADS)
@ -137,12 +146,14 @@ typedef union clause_obj {
struct logic_upd_index lui;
struct dynamic_clause ic;
struct static_clause sc;
struct static_mega_clause mc;
struct static_index si;
} ClauseUnion;
#define ClauseCodeToDynamicClause(p) ((DynamicClause *)((CODEADDR)(p)-(CELL)(((DynamicClause *)NULL)->ClCode)))
#define ClauseCodeToStaticClause(p) ((StaticClause *)((CODEADDR)(p)-(CELL)(((StaticClause *)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 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);
while (OP_RTABLE[j].opc != opc) {
if (!OP_RTABLE[j].opc)
return _Nstop;
if (j == OP_HASH_SIZE-1) {
j = 0;
} else {
@ -250,3 +263,38 @@ same_lu_block(yamop **paddr, yamop *p)
}
#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 *
* 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 $
* 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
* 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 */
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 */
static void
restore_codes(void)
@ -67,6 +91,17 @@ restore_codes(void)
#endif /* YAPOR */
#endif /* TABLING */
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_1 = 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_last_execute_within = FuncAdjust(heap_regs->functor_last_execute_within);
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);
#ifdef MULTI_ASSIGNMENT_VARIABLES
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_portray = FuncAdjust(heap_regs->functor_portray);
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_pos = FuncAdjust(heap_regs->functor_stream_pos);
heap_regs->functor_stream_eOS = FuncAdjust(heap_regs->functor_stream_eOS);
@ -617,6 +654,12 @@ restore_opcodes(yamop *pc)
case _skip:
case _jump_if_var:
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 = NEXTOP(pc,l);
break;
@ -725,17 +768,9 @@ restore_opcodes(yamop *pc)
pc = NEXTOP(pc,xF);
break;
case _expand_clauses:
pc->u.sp.p = PtoPredAdjust(pc->u.sp.p);
{
COUNT i;
yamop **st = (yamop **)NEXTOP(pc,sp);
for (i = 0; i < pc->u.sp.s1; i++, st++) {
if (*st) {
*st = PtoOpAdjust(*st);
}
}
}
Yap_Error(SYSTEM_ERROR, TermNil,
"Invalid Opcode expand_clauses at %p", pc);
break;
/* instructions type y */
case _save_b_y:
case _commit_b_y:
@ -840,6 +875,166 @@ restore_opcodes(yamop *pc)
}
pc = NEXTOP(pc,xc);
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 */
case _get_struct:
case _put_struct:
@ -1334,6 +1529,18 @@ RestoreStaticClause(StaticClause *cl, PredEntry *pp)
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 */
static void
RestoreDynamicClause(DynamicClause *cl, PredEntry *pp)
@ -1389,6 +1596,10 @@ CleanClauses(yamop *First, yamop *Last, PredEntry *pp)
RestoreLUClause(cl, pp);
cl = cl->ClNext;
}
} else if (pp->PredFlags & MegaClausePredFlag) {
MegaClause *cl = ClauseCodeToMegaClause(First);
RestoreMegaClause(cl, pp);
} else if (pp->PredFlags & DynamicPredFlag) {
yamop *cl = First;

16951
configure vendored
View File

File diff suppressed because it is too large Load Diff

32
distribute
View File

@ -1,8 +1,8 @@
#/bin/bash
# Guess what: this code works for me!
parent=$(cd ..;pwd)
version=${PWD##$parent/}
version="Yap-4.5.3"
PATH="$PATH":~/bin/noarch
splat
cd C
splat
@ -14,16 +14,26 @@ cd ../VC
splat
cd ../LGPL
splat
cd pillow
cd JPL
splat
cd src
splat
cd ../java
splat
cd jpl
splat
cd fli
splat
cd ../../../../pillow
splat
cd examples
splat
cd ../../../include
splat
/bin/cp config.h config.h.mine
/bin/cp ../../../bins/cyg/*.h .
/bin/mv config.h.mine config.h
cd ../../console
#/bin/cp config.h config.h.mine
#/bin/cp ../../../bins/cyg/*.h .
#/bin/mv config.h.mine config.h
cd ../console
splat
cd ../docs
splat
@ -65,11 +75,15 @@ cd ../../CHR
splat
cd chr
splat
cd ../../CLPBN
splat
cd clpbn
splat
cd examples
splat
cd ../../../..
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
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

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.
*/
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 */
UserCPredFlag = 0x10000000L, /* CPred defined by the user */
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 */
/* There are several flags for code and data base entries */
typedef enum {
MegaMask = 0x200000, /* informs this is a mega clause */
FactMask = 0x100000, /* informs this is a fact */
SwitchRootMask= 0x80000, /* informs this is the root for the index tree */
SwitchTableMask=0x40000, /* informs this is a switch table */