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

compile ground terms away.

Browse Source 
git-svn-id: https://yap.svn.sf.net/svnroot/yap/trunk@1975 b08c6af1-5177-4d33-ba66-4b1c6b8b522a
This commit is contained in:
vsc 2007-11-06 17:02:13 +00:00
parent 025dd6214f
commit a5f5f4c237
24 changed files with 855 additions and 157 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

103
C/absmi.c
View File

@ -10,8 +10,11 @@
* *
* File: absmi.c *
* comments: Portable abstract machine interpreter *
* Last rev: $Date: 2007-10-28 11:23:39 $,$Author: vsc $ *
* Last rev: $Date: 2007-11-06 17:02:08 $,$Author: vsc $ *
* $Log: not supported by cvs2svn $
* Revision 1.227 2007/10/28 11:23:39 vsc
* fix overflow
*
* Revision 1.226 2007/10/28 00:54:09 vsc
* new version of viterbi implementation
* fix all:atvars reporting bad info
@ -4311,6 +4314,42 @@ Yap_absmi(int inp)
FAIL();
#endif
ENDOp();
Op(get_dbterm, xc);
BEGD(d0);
d0 = XREG(PREG->u.xc.x);
deref_head(d0, gdbterm_unk);
gdbterm_nonvar:
BEGD(d1);
/* we have met a preexisting dbterm */
d1 = XREG(PREG->u.xc.c);
PREG = NEXTOP(PREG, xc);
UnifyBound(d0,d1);
ENDD(d1);
BEGP(pt0);
deref_body(d0, pt0, gdbterm_unk, gdbterm_nonvar);
/* Enter Write mode */
/* set d1 to be the new structure we are going to create */
START_PREFETCH(xc);
BEGD(d1);
d1 = PREG->u.xc.c;
PREG = NEXTOP(PREG, xc);
BIND(pt0, d1, bind_gdbterm);
#ifdef COROUTINING
DO_TRAIL(pt0, d1);
if (pt0 < H0) Yap_WakeUp(pt0);
bind_gdbterm:
#endif
GONext();
ENDD(d1);
END_PREFETCH();
ENDP(pt0);
ENDD(d0);
ENDOp();
/************************************************************************\
* Optimised Get List Instructions *
@ -6340,7 +6379,7 @@ Yap_absmi(int inp)
derefa_body(d0, pt0, ubigint_unk, ubigint_nonvar);
BEGD(d1);
d1 = AbsAppl(PREG->u.oi.i);
d1 = PREG->u.oc.c;
PREG = NEXTOP(PREG, oi);
BIND_GLOBAL(pt0, d1, bind_ubigint);
#ifdef COROUTINING
@ -6402,6 +6441,66 @@ Yap_absmi(int inp)
#endif
ENDOp();
Op(unify_dbterm, oc);
BEGD(d0);
BEGP(pt0);
pt0 = SREG++;
d0 = *pt0;
deref_head(d0, udbterm_unk);
udbterm_nonvar:
BEGD(d1);
/* we have met a preexisting dbterm */
d1 = XREG(PREG->u.oc.c);
PREG = NEXTOP(PREG, oc);
UnifyBound(d0,d1);
ENDD(d1);
derefa_body(d0, pt0, udbterm_unk, udbterm_nonvar);
BEGD(d1);
d1 = AbsAppl(PREG->u.oi.i);
PREG = NEXTOP(PREG, oi);
BIND_GLOBAL(pt0, d1, bind_udbterm);
#ifdef COROUTINING
DO_TRAIL(pt0, d1);
if (pt0 < H0) Yap_WakeUp(pt0);
bind_udbterm:
#endif
GONext();
ENDD(d1);
ENDP(pt0);
ENDD(d0);
ENDOp();
Op(unify_l_dbterm, oc);
BEGD(d0);
CACHE_S();
READ_IN_S();
d0 = *S_SREG;
deref_head(d0, uldbterm_unk);
uldbterm_nonvar:
BEGD(d1);
/* we have met a preexisting dbterm */
d1 = XREG(PREG->u.oc.c);
PREG = NEXTOP(PREG, oc);
UnifyBound(d0,d1);
ENDD(d1);
derefa_body(d0, S_SREG, uldbterm_unk, uldbterm_nonvar);
BEGD(d1);
d1 = PREG->u.oc.c;
PREG = NEXTOP(PREG, oc);
BIND_GLOBAL(S_SREG, d1, bind_uldbterm);
#ifdef COROUTINING
DO_TRAIL(S_SREG, d1);
if (S_SREG < H0) Yap_WakeUp(S_SREG);
bind_uldbterm:
#endif
GONext();
ENDD(d1);
ENDCACHE_S();
ENDD(d0);
ENDOp();
OpW(unify_list_write, o);
PREG = NEXTOP(PREG, o);
BEGD(d0);

70
C/adtdefs.c
View File

@ -558,7 +558,7 @@ Yap_GetExpPropHavingLock(AtomEntry *ae, unsigned int arity)
return (p0);
}
static void
static int
ExpandPredHash(void)
{
UInt new_size = PredHashTableSize+PredHashIncrement;
@ -567,7 +567,7 @@ ExpandPredHash(void)
UInt i;
if (!np) {
Yap_Error(FATAL_ERROR,TermNil,"Could not allocate space for pred table");
return FALSE;
}
for (i = 0; i < new_size; i++) {
np[i] = NULL;
@ -586,6 +586,7 @@ ExpandPredHash(void)
PredHashTableSize = new_size;
PredHash = np;
Yap_FreeAtomSpace((ADDR)oldp);
return TRUE;
}
/* fe is supposed to be locked */
@ -594,6 +595,44 @@ Yap_NewPredPropByFunctor(FunctorEntry *fe, Term cur_mod)
{
PredEntry *p = (PredEntry *) Yap_AllocAtomSpace(sizeof(*p));
if (p == NULL) {
WRITE_UNLOCK(fe->FRWLock);
return NULL;
}
if (fe->PropsOfFE) {
UInt hsh = PRED_HASH(fe, cur_mod, PredHashTableSize);
WRITE_LOCK(PredHashRWLock);
if (10*(PredsInHashTable+1) > 6*PredHashTableSize) {
if (!ExpandPredHash()) {
Yap_FreeCodeSpace((ADDR)p);
WRITE_UNLOCK(PredHashRWLock);
WRITE_UNLOCK(fe->FRWLock);
return NULL;
}
/* retry hashing */
hsh = PRED_HASH(fe, cur_mod, PredHashTableSize);
}
PredsInHashTable++;
if (p->ModuleOfPred == 0L) {
PredEntry *pe = RepPredProp(fe->PropsOfFE);
hsh = PRED_HASH(fe, pe->ModuleOfPred, PredHashTableSize);
/* should be the first one */
pe->NextOfPE = AbsPredProp(PredHash[hsh]);
PredHash[hsh] = pe;
fe->PropsOfFE = AbsPredProp(p);
} else {
p->NextOfPE = AbsPredProp(PredHash[hsh]);
PredHash[hsh] = p;
}
WRITE_UNLOCK(PredHashRWLock);
/* make sure that we have something here */
RepPredProp(fe->PropsOfFE)->NextOfPE = fe->PropsOfFE;
} else {
fe->PropsOfFE = AbsPredProp(p);
p->NextOfPE = NIL;
}
INIT_RWLOCK(p->PRWLock);
INIT_LOCK(p->PELock);
p->KindOfPE = PEProp;
@ -630,33 +669,6 @@ Yap_NewPredPropByFunctor(FunctorEntry *fe, Term cur_mod)
}
}
p->FunctorOfPred = fe;
if (fe->PropsOfFE) {
UInt hsh = PRED_HASH(fe, cur_mod, PredHashTableSize);
WRITE_LOCK(PredHashRWLock);
if (p->ModuleOfPred == 0L) {
PredEntry *pe = RepPredProp(fe->PropsOfFE);
hsh = PRED_HASH(fe, pe->ModuleOfPred, PredHashTableSize);
/* should be the first one */
pe->NextOfPE = AbsPredProp(PredHash[hsh]);
PredHash[hsh] = pe;
fe->PropsOfFE = AbsPredProp(p);
} else {
p->NextOfPE = AbsPredProp(PredHash[hsh]);
PredHash[hsh] = p;
}
PredsInHashTable++;
if (10*PredsInHashTable > 6*PredHashTableSize) {
ExpandPredHash();
}
WRITE_UNLOCK(PredHashRWLock);
/* make sure that we have something here */
RepPredProp(fe->PropsOfFE)->NextOfPE = fe->PropsOfFE;
} else {
fe->PropsOfFE = AbsPredProp(p);
p->NextOfPE = NIL;
}
WRITE_UNLOCK(fe->FRWLock);
#ifdef LOW_PROF
if (ProfilerOn &&

1
C/agc.c
View File

@ -147,6 +147,7 @@ AtomAdjust(Atom a)
#define PtoOpAdjust(P) (P)
#define PtoLUClauseAdjust(P) (P)
#define PtoLUIndexAdjust(P) (P)
#define PtoDBTLAdjust(P) (P)
#define PtoPredAdjust(P) (P)
#define PropAdjust(P) (P)
#define TrailAddrAdjust(P) (P)

113
C/amasm.c
View File

@ -11,8 +11,11 @@
* File: amasm.c *
* comments: abstract machine assembler *
* *
* Last rev: $Date: 2007-06-23 17:31:50 $ *
* Last rev: $Date: 2007-11-06 17:02:09 $ *
* $Log: not supported by cvs2svn $
* Revision 1.95 2007/06/23 17:31:50 vsc
* pin cluses with floats.
*
* Revision 1.94 2006/12/27 01:32:37 vsc
* diverse fixes
*
@ -237,7 +240,7 @@ STATIC_PROTO(yamop *a_xigl, (op_numbers, yamop *, int, struct PSEUDO *));
STATIC_PROTO(yamop *a_ucons, (int *, compiler_vm_op, yamop *, int, struct intermediates *));
STATIC_PROTO(yamop *a_uvar, (yamop *, int, struct intermediates *));
STATIC_PROTO(yamop *a_wvar, (yamop *, int, struct intermediates *));
STATIC_PROTO(yamop *do_pass, (int, yamop **, int, int *, struct intermediates *, UInt));
STATIC_PROTO(yamop *do_pass, (int, yamop **, int, int *, int *,struct intermediates *, UInt));
#ifdef DEBUG_OPCODES
STATIC_PROTO(void DumpOpCodes, (void));
#endif
@ -439,6 +442,14 @@ add_clref(CELL clause_code, int pass_no)
}
}
static void
add_to_dbtermsl(struct intermediates *cip, Term t)
{
DBTerm *dbt = TermToDBTerm(t);
dbt->ag.NextDBT = cip->dbterml->dbterms;
cip->dbterml->dbterms = dbt;
}
static yamop *
a_lucl(op_numbers opcode, yamop *code_p, int pass_no, struct intermediates *cip, clause_info *cla)
{
@ -809,6 +820,19 @@ a_blob(CELL rnd1, op_numbers opcode, int *clause_has_blobsp, yamop *code_p, int
return code_p;
}
inline static yamop *
a_wdbt(CELL rnd1, op_numbers opcode, int *clause_has_dbtermp, yamop *code_p, int pass_no, struct intermediates *cip)
{
if (pass_no) {
code_p->opc = emit_op(opcode);
code_p->u.c.c = rnd1;
add_to_dbtermsl(cip, cip->cpc->rnd1);
}
*clause_has_dbtermp = TRUE;
GONEXT(c);
return code_p;
}
inline static yamop *
a_ublob(CELL rnd1, op_numbers opcode, op_numbers opcode_w, int *clause_has_blobsp, yamop *code_p, int pass_no, struct intermediates *cip)
{
@ -824,6 +848,20 @@ a_ublob(CELL rnd1, op_numbers opcode, op_numbers opcode_w, int *clause_has_blobs
return code_p;
}
inline static yamop *
a_udbt(CELL rnd1, op_numbers opcode, op_numbers opcode_w, int *clause_has_dbtermp, yamop *code_p, int pass_no, struct intermediates *cip)
{
if (pass_no) {
code_p->opc = emit_op(opcode);
code_p->u.oc.opcw = emit_op(opcode_w);
code_p->u.oc.c = cip->cpc->rnd1;
add_to_dbtermsl(cip, cip->cpc->rnd1);
}
*clause_has_dbtermp = TRUE;
GONEXT(oc);
return code_p;
}
inline static yamop *
a_ud(op_numbers opcode, op_numbers opcode_w, yamop *code_p, int pass_no, struct PSEUDO *cpc)
{
@ -1050,6 +1088,20 @@ a_rb(op_numbers opcode, int *clause_has_blobsp, yamop *code_p, int pass_no, stru
return code_p;
}
inline static yamop *
a_dbt(op_numbers opcode, int *clause_has_dbtermp, yamop *code_p, int pass_no, struct intermediates *cip)
{
if (pass_no) {
code_p->opc = emit_op(opcode);
code_p->u.xc.x = emit_x(cip->cpc->rnd2);
code_p->u.xc.c = cip->cpc->rnd1;
add_to_dbtermsl(cip, cip->cpc->rnd1);
}
*clause_has_dbtermp = TRUE;
GONEXT(xc);
return code_p;
}
inline static yamop *
a_rli(op_numbers opcode, int *clause_has_blobsp, yamop *code_p, int pass_no, struct intermediates *cip)
{
@ -2631,7 +2683,7 @@ a_f2(int var, cmp_op_info *cmp_info, yamop *code_p, int pass_no, struct intermed
#endif /* YAPOR */
static yamop *
do_pass(int pass_no, yamop **entry_codep, int assembling, int *clause_has_blobsp, struct intermediates *cip, UInt size)
do_pass(int pass_no, yamop **entry_codep, int assembling, int *clause_has_blobsp, int *clause_has_dbtermp, struct intermediates *cip, UInt size)
{
#ifdef YAPOR
#define EITHER_INST 50
@ -2687,6 +2739,9 @@ do_pass(int pass_no, yamop **entry_codep, int assembling, int *clause_has_blobsp
if (*clause_has_blobsp) {
cl_u->luc.ClFlags |= HasBlobsMask;
}
if (*clause_has_dbtermp) {
cl_u->luc.ClFlags |= HasDBTMask;
}
cl_u->luc.ClExt = NULL;
cl_u->luc.ClPrev = cl_u->luc.ClNext = NULL;
#if defined(YAPOR) || defined(THREADS)
@ -2701,6 +2756,9 @@ do_pass(int pass_no, yamop **entry_codep, int assembling, int *clause_has_blobsp
if (*clause_has_blobsp) {
cl_u->ic.ClFlags |= HasBlobsMask;
}
if (*clause_has_dbtermp) {
cl_u->ic.ClFlags |= HasDBTMask;
}
cl_u->ic.ClSize = size;
cl_u->ic.ClRefCount = 0;
#if defined(YAPOR) || defined(THREADS)
@ -2719,6 +2777,9 @@ do_pass(int pass_no, yamop **entry_codep, int assembling, int *clause_has_blobsp
if (*clause_has_blobsp) {
cl_u->sc.ClFlags |= HasBlobsMask;
}
if (*clause_has_dbtermp) {
cl_u->sc.ClFlags |= HasDBTMask;
}
}
code_p = cl_u->sc.ClCode;
}
@ -2869,6 +2930,9 @@ do_pass(int pass_no, yamop **entry_codep, int assembling, int *clause_has_blobsp
case get_bigint_op:
code_p = a_rb(_get_bigint, clause_has_blobsp, code_p, pass_no, cip);
break;
case get_dbterm_op:
code_p = a_dbt(_get_dbterm, clause_has_dbtermp, code_p, pass_no, cip);
break;
case put_num_op:
case put_atom_op:
code_p = a_rc(_put_atom, code_p, pass_no, cip);
@ -2884,6 +2948,9 @@ do_pass(int pass_no, yamop **entry_codep, int assembling, int *clause_has_blobsp
case put_bigint_op:
code_p = a_rb(_put_atom, clause_has_blobsp, code_p, pass_no, cip);
break;
case put_dbterm_op:
code_p = a_dbt(_put_atom, clause_has_dbtermp, code_p, pass_no, cip);
break;
case get_list_op:
code_p = a_glist(&do_not_optimise_uatom, code_p, pass_no, cip);
break;
@ -2941,6 +3008,9 @@ do_pass(int pass_no, yamop **entry_codep, int assembling, int *clause_has_blobsp
case unify_bigint_op:
code_p = a_ublob(cip->cpc->rnd1, _unify_bigint, _unify_atom_write, clause_has_blobsp, code_p, pass_no, cip);
break;
case unify_dbterm_op:
code_p = a_udbt(cip->cpc->rnd1, _unify_dbterm, _unify_atom_write, clause_has_dbtermp, code_p, pass_no, cip);
break;
case unify_last_num_op:
case unify_last_atom_op:
code_p = a_uc(cip->cpc->rnd1, _unify_l_atom, _unify_l_atom_write, code_p, pass_no);
@ -2956,6 +3026,9 @@ do_pass(int pass_no, yamop **entry_codep, int assembling, int *clause_has_blobsp
case unify_last_bigint_op:
code_p = a_ublob(cip->cpc->rnd1, _unify_l_bigint, _unify_l_atom_write, clause_has_blobsp, code_p, pass_no, cip);
break;
case unify_last_dbterm_op:
code_p = a_udbt(cip->cpc->rnd1, _unify_l_dbterm, _unify_l_atom_write, clause_has_dbtermp, code_p, pass_no, cip);
break;
case write_num_op:
case write_atom_op:
code_p = a_ucons(&do_not_optimise_uatom, write_atom_op, code_p, pass_no, cip);
@ -2971,6 +3044,9 @@ do_pass(int pass_no, yamop **entry_codep, int assembling, int *clause_has_blobsp
case write_bigint_op:
code_p = a_blob(cip->cpc->rnd1, _write_atom, clause_has_blobsp, code_p, pass_no, cip);
break;
case write_dbterm_op:
code_p = a_wdbt(cip->cpc->rnd1, _write_atom, clause_has_dbtermp, code_p, pass_no, cip);
break;
case unify_list_op:
code_p = a_ue(_unify_list, _unify_list_write, code_p, pass_no);
break;
@ -3026,7 +3102,7 @@ do_pass(int pass_no, yamop **entry_codep, int assembling, int *clause_has_blobsp
case cutexit_op:
code_p = a_cut(&clinfo, code_p, pass_no, cip);
if (cip->CurrentPred->PredFlags & LogUpdatePredFlag &&
*clause_has_blobsp &&
(*clause_has_blobsp || *clause_has_dbtermp) &&
!clinfo.alloc_found)
code_p = a_cle(_alloc_for_logical_pred, code_p, pass_no, cip);
#if THREADS
@ -3129,7 +3205,7 @@ do_pass(int pass_no, yamop **entry_codep, int assembling, int *clause_has_blobsp
break;
case procceed_op:
if (cip->CurrentPred->PredFlags & LogUpdatePredFlag &&
*clause_has_blobsp &&
(*clause_has_blobsp || *clause_has_dbtermp) &&
!clinfo.alloc_found)
code_p = a_cle(_alloc_for_logical_pred, code_p, pass_no, cip);
#if THREADS
@ -3425,6 +3501,23 @@ fetch_clause_space(Term* tp, UInt size, struct intermediates *cip, UInt *osizep)
return x;
}
static DBTermList *
init_dbterms_list(yamop *code_p, PredEntry *ap)
{
DBTermList *new;
if ((new = (DBTermList *)Yap_AllocCodeSpace(sizeof(DBTermList))) == NULL) {
return NULL;
}
new->dbterms = NULL;
new->clause_code = code_p;
new->p = ap;
LOCK(DBTermsListLock);
new->next_dbl = DBTermsList;
DBTermsList = new;
UNLOCK(DBTermsListLock);
return new;
}
yamop *
Yap_assemble(int mode, Term t, PredEntry *ap, int is_fact, struct intermediates *cip)
@ -3438,10 +3531,14 @@ Yap_assemble(int mode, Term t, PredEntry *ap, int is_fact, struct intermediates
yamop *entry_code;
yamop *code_p;
int clause_has_blobs = FALSE;
int clause_has_dbterm = FALSE;
cip->label_offset = (int *)cip->freep;
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, &clause_has_dbterm, cip, size);
if (clause_has_dbterm) {
cip->dbterml = init_dbterms_list(code_p, ap);
}
if (ap->PredFlags & DynamicPredFlag) {
size =
(CELL)NEXTOP(NEXTOP(NEXTOP((yamop *)(((DynamicClause *)NULL)->ClCode),ld),sla),e);
@ -3475,7 +3572,7 @@ Yap_assemble(int mode, Term t, PredEntry *ap, int is_fact, struct intermediates
}
cl = (StaticClause *)((CODEADDR)x-(UInt)size);
cip->code_addr = (yamop *)cl;
code_p = do_pass(1, &entry_code, mode, &clause_has_blobs, cip, size);
code_p = do_pass(1, &entry_code, mode, &clause_has_blobs, &clause_has_dbterm, cip, size);
/* make sure we copy after second pass */
cl->usc.ClSource = x;
cl->ClSize = osize;
@ -3502,7 +3599,7 @@ Yap_assemble(int mode, Term t, PredEntry *ap, int is_fact, struct intermediates
Yap_IndexSpace_Tree += size;
}
}
code_p = do_pass(1, &entry_code, mode, &clause_has_blobs, cip, size);
code_p = do_pass(1, &entry_code, mode, &clause_has_blobs, &clause_has_dbterm, cip, size);
ProfEnd=code_p;
#ifdef LOW_PROF
if (ProfilerOn &&

13
C/cdmgr.c
View File

@ -11,8 +11,11 @@
* File: cdmgr.c *
* comments: Code manager *
* *
* Last rev: $Date: 2007-11-01 10:01:35 $,$Author: vsc $ *
* Last rev: $Date: 2007-11-06 17:02:11 $,$Author: vsc $ *
* $Log: not supported by cvs2svn $
* Revision 1.208 2007/11/01 10:01:35 vsc
* fix uninitalised lock and reconsult test.
*
* Revision 1.207 2007/10/29 22:48:54 vsc
* small fixes
*
@ -619,6 +622,11 @@ static Term BlobTermAdjust(Term t)
#endif
}
static void
RestoreDBTerm(DBTerm *dbr)
{
}
#include "rclause.h"
#ifdef DEBUG
@ -4048,6 +4056,7 @@ ClauseInfoForCode(yamop *codeptr, CODEADDR *startp, CODEADDR *endp) {
case _get_atom:
case _put_atom:
case _get_bigint:
case _get_dbterm:
pc = NEXTOP(pc,xc);
break;
/* instructions type cc */
@ -4164,6 +4173,8 @@ ClauseInfoForCode(yamop *codeptr, CODEADDR *startp, CODEADDR *endp) {
case _unify_l_atom:
case _unify_bigint:
case _unify_l_bigint:
case _unify_dbterm:
case _unify_l_dbterm:
pc = NEXTOP(pc,oc);
break;
/* instructions type osc */

223
C/compiler.c
View File

@ -11,8 +11,11 @@
* File: compiler.c *
* comments: Clause compiler *
* *
* Last rev: $Date: 2007-03-27 13:48:51 $,$Author: vsc $ *
* Last rev: $Date: 2007-11-06 17:02:11 $,$Author: vsc $ *
* $Log: not supported by cvs2svn $
* Revision 1.84 2007/03/27 13:48:51 vsc
* fix number of overflows (comments by Bart Demoen).
*
* Revision 1.83 2007/03/26 15:18:43 vsc
* debugging and clause/3 over tabled predicates would kill YAP.
*
@ -481,8 +484,9 @@ optimize_ce(Term t, unsigned int arity, unsigned int level, compiler_struct *cgl
return (p->VarOfCE);
}
/* first occurrence */
if (cglobs->onbranch || level > 1)
if (cglobs->onbranch || level > 1) {
return t;
}
++(cglobs->n_common_exps);
p = (CExpEntry *) Yap_AllocCMem(sizeof(CExpEntry), &cglobs->cint);
@ -491,7 +495,7 @@ optimize_ce(Term t, unsigned int arity, unsigned int level, compiler_struct *cgl
if (H >= (CELL *)cglobs->cint.freep0) {
/* oops, too many new variables */
save_machine_regs();
longjmp(cglobs->cint.CompilerBotch,4);
longjmp(cglobs->cint.CompilerBotch,OUT_OF_TEMPS_BOTCH);
}
p->NextCE = cglobs->common_exps;
cglobs->common_exps = p;
@ -526,7 +530,7 @@ compile_sf_term(Term t, int argno, int level)
Yap_Error_Term = TermNil;
Yap_ErrorMessage = "illegal argument of soft functor";
save_machine_regs();
longjmp(cglobs->cint.CompilerBotch, 2);
longjmp(cglobs->cint.CompilerBotch, OUT_OF_HEAP_BOTCH);
}
else
c_var(t, -argno, arity, level, cglobs);
@ -553,7 +557,7 @@ c_args(Term app, unsigned int level, compiler_struct *cglobs)
Yap_Error_Term = TermNil;
Yap_ErrorMessage = "exceed maximum arity of compiled goal";
save_machine_regs();
longjmp(cglobs->cint.CompilerBotch, 2);
longjmp(cglobs->cint.CompilerBotch, OUT_OF_HEAP_BOTCH);
}
if (Arity > cglobs->max_args)
cglobs->max_args = Arity;
@ -562,6 +566,52 @@ c_args(Term app, unsigned int level, compiler_struct *cglobs)
c_arg(i, ArgOfTerm(i, app), Arity, level, cglobs);
}
static int
try_store_as_dbterm(Term t, Int argno, unsigned int arity, int level, compiler_struct *cglobs)
{
DBTerm *dbt;
int g;
CELL *h0 = H;
while ((g=Yap_SizeGroundTerm(t,TRUE)) < 0) {
/* oops, too deep a term */
save_machine_regs();
Yap_Error_Size = 0;
longjmp(cglobs->cint.CompilerBotch, OUT_OF_AUX_BOTCH);
}
if (g < 16)
return FALSE;
/* store ground term away */
H = CellPtr(cglobs->cint.freep);
if ((dbt = Yap_StoreTermInDB(t, -1)) == NULL) {
H = h0;
switch(Yap_Error_TYPE) {
case OUT_OF_STACK_ERROR:
Yap_Error_TYPE = YAP_NO_ERROR;
longjmp(cglobs->cint.CompilerBotch,OUT_OF_STACK_BOTCH);
case OUT_OF_TRAIL_ERROR:
Yap_Error_TYPE = YAP_NO_ERROR;
longjmp(cglobs->cint.CompilerBotch,OUT_OF_TRAIL_BOTCH);
case OUT_OF_HEAP_ERROR:
Yap_Error_TYPE = YAP_NO_ERROR;
longjmp(cglobs->cint.CompilerBotch,OUT_OF_HEAP_BOTCH);
case OUT_OF_AUXSPACE_ERROR:
Yap_Error_TYPE = YAP_NO_ERROR;
longjmp(cglobs->cint.CompilerBotch,OUT_OF_AUX_BOTCH);
default:
longjmp(cglobs->cint.CompilerBotch,COMPILER_ERR_BOTCH);
}
}
H = h0;
if (level == 0)
Yap_emit((cglobs->onhead ? get_dbterm_op : put_dbterm_op), dbt->Entry, argno, &cglobs->cint);
else
Yap_emit((cglobs->onhead ? (argno == (Int)arity ? unify_last_dbterm_op
: unify_dbterm_op) :
write_dbterm_op), dbt->Entry, Zero, &cglobs->cint);
return TRUE;
}
static void
c_arg(Int argno, Term t, unsigned int arity, unsigned int level, compiler_struct *cglobs)
{
@ -641,6 +691,12 @@ c_arg(Int argno, Term t, unsigned int arity, unsigned int level, compiler_struct
write_num_op), (CELL) t, Zero, &cglobs->cint);
} else if (IsPairTerm(t)) {
if (optimizer_on && level < 6) {
if (!(cglobs->cint.CurrentPred->PredFlags & (DynamicPredFlag|LogUpdatePredFlag))) {
if (try_store_as_dbterm(t, argno, arity, level, cglobs))
return;
}
if (try_store_as_dbterm(t, argno, arity, level, cglobs))
return;
t = optimize_ce(t, arity, level, cglobs);
if (IsVarTerm(t)) {
c_var(t, argno, arity, level, cglobs);
@ -656,7 +712,7 @@ c_arg(Int argno, Term t, unsigned int arity, unsigned int level, compiler_struct
++level;
c_arg(1, HeadOfTerm(t), 2, level, cglobs);
if (argno == (Int)arity) {
/* optimise for tail recursion */
/* optimise for tail recursion */
t = TailOfTerm(t);
goto restart;
}
@ -690,11 +746,14 @@ c_arg(Int argno, Term t, unsigned int arity, unsigned int level, compiler_struct
#endif
if (optimizer_on) {
if (!(cglobs->cint.CurrentPred->PredFlags & (DynamicPredFlag|LogUpdatePredFlag))) {
if (try_store_as_dbterm(t, argno, arity, level, cglobs))
return;
}
t = optimize_ce(t, arity, level, cglobs);
if (IsVarTerm(t)) {
c_var(t, argno, arity, level, cglobs);
return;
}
}
if (level == 0)
@ -803,7 +862,7 @@ c_test(Int Op, Term t1, compiler_struct *cglobs) {
Yap_bip_name(Op, s);
sprintf(Yap_ErrorMessage, "when compiling %s/1", s);
save_machine_regs();
longjmp(cglobs->cint.CompilerBotch, 1);
longjmp(cglobs->cint.CompilerBotch, COMPILER_ERR_BOTCH);
}
if (IsNewVar(t)) {
/* in this case, var trivially succeeds and the others trivially fail */
@ -858,7 +917,7 @@ c_bifun(Int Op, Term t1, Term t2, Term t3, Term Goal, int mod, compiler_struct *
Yap_bip_name(Op, s);
sprintf(Yap_ErrorMessage, "when compiling %s/2", s);
save_machine_regs();
longjmp(cglobs->cint.CompilerBotch, 1);
longjmp(cglobs->cint.CompilerBotch, COMPILER_ERR_BOTCH);
} else if (IsVarTerm(t2)) {
if (IsNewVar(t2)) {
char s[32];
@ -869,7 +928,7 @@ c_bifun(Int Op, Term t1, Term t2, Term t3, Term Goal, int mod, compiler_struct *
Yap_bip_name(Op, s);
sprintf(Yap_ErrorMessage, "when compiling %s/2", s);
save_machine_regs();
longjmp(cglobs->cint.CompilerBotch, 1);
longjmp(cglobs->cint.CompilerBotch, COMPILER_ERR_BOTCH);
} else {
/* first temp */
Int v1 = --cglobs->tmpreg;
@ -987,7 +1046,7 @@ c_bifun(Int Op, Term t1, Term t2, Term t3, Term Goal, int mod, compiler_struct *
if (H+2 >= (CELL *)cglobs->cint.freep0) {
/* oops, too many new variables */
save_machine_regs();
longjmp(cglobs->cint.CompilerBotch,4);
longjmp(cglobs->cint.CompilerBotch,OUT_OF_TEMPS_BOTCH);
}
RESET_VARIABLE(H);
RESET_VARIABLE(H+1);
@ -999,7 +1058,7 @@ c_bifun(Int Op, Term t1, Term t2, Term t3, Term Goal, int mod, compiler_struct *
if (H >= (CELL *)cglobs->cint.freep0) {
/* oops, too many new variables */
save_machine_regs();
longjmp(cglobs->cint.CompilerBotch,4);
longjmp(cglobs->cint.CompilerBotch,OUT_OF_TEMPS_BOTCH);
}
RESET_VARIABLE(H);
H++;
@ -1128,7 +1187,7 @@ c_bifun(Int Op, Term t1, Term t2, Term t3, Term Goal, int mod, compiler_struct *
if (H+1+arity >= (CELL *)cglobs->cint.freep0) {
/* oops, too many new variables */
save_machine_regs();
longjmp(cglobs->cint.CompilerBotch,4);
longjmp(cglobs->cint.CompilerBotch,OUT_OF_TEMPS_BOTCH);
}
tnew = AbsAppl(H);
*H++ = (CELL)Yap_MkFunctor(AtomOfTerm(t1),arity);
@ -1177,7 +1236,7 @@ c_bifun(Int Op, Term t1, Term t2, Term t3, Term Goal, int mod, compiler_struct *
if (H == (CELL *)cglobs->cint.freep0) {
/* oops, too many new variables */
save_machine_regs();
longjmp(cglobs->cint.CompilerBotch,4);
longjmp(cglobs->cint.CompilerBotch,OUT_OF_TEMPS_BOTCH);
}
c_var(tmpvar,f_flag,(unsigned int)Op, 0, cglobs);
c_eq(tmpvar,t3, cglobs);
@ -1204,7 +1263,7 @@ c_bifun(Int Op, Term t1, Term t2, Term t3, Term Goal, int mod, compiler_struct *
if (H == (CELL *)cglobs->cint.freep0) {
/* oops, too many new variables */
save_machine_regs();
longjmp(cglobs->cint.CompilerBotch,4);
longjmp(cglobs->cint.CompilerBotch,OUT_OF_TEMPS_BOTCH);
}
c_var(tmpvar,f_flag,(unsigned int)Op, 0, cglobs);
/* I have to dit here, before I do the unification */
@ -1298,7 +1357,7 @@ c_goal(Term Goal, int mod, compiler_struct *cglobs)
Yap_Error_Term = M;
Yap_ErrorMessage = "in module name";
save_machine_regs();
longjmp(cglobs->cint.CompilerBotch, 1);
longjmp(cglobs->cint.CompilerBotch, COMPILER_ERR_BOTCH);
}
Goal = ArgOfTerm(2, Goal);
mod = M;
@ -1495,7 +1554,7 @@ c_goal(Term Goal, int mod, compiler_struct *cglobs)
if (H == (CELL *)cglobs->cint.freep0) {
/* oops, too many new variables */
save_machine_regs();
longjmp(cglobs->cint.CompilerBotch,4);
longjmp(cglobs->cint.CompilerBotch,OUT_OF_TEMPS_BOTCH);
}
savecpc = cglobs->cint.cpc;
savencpc = FirstP->nextInst;
@ -1574,7 +1633,7 @@ c_goal(Term Goal, int mod, compiler_struct *cglobs)
if (H == (CELL *)cglobs->cint.freep0) {
/* oops, too many new variables */
save_machine_regs();
longjmp(cglobs->cint.CompilerBotch,4);
longjmp(cglobs->cint.CompilerBotch,OUT_OF_TEMPS_BOTCH);
}
push_branch(cglobs->onbranch, commitvar, cglobs);
++cglobs->curbranch;
@ -1609,7 +1668,7 @@ c_goal(Term Goal, int mod, compiler_struct *cglobs)
if (H == (CELL *)cglobs->cint.freep0) {
/* oops, too many new variables */
save_machine_regs();
longjmp(cglobs->cint.CompilerBotch,4);
longjmp(cglobs->cint.CompilerBotch,OUT_OF_TEMPS_BOTCH);
}
cglobs->onlast = FALSE;
c_var(commitvar, save_b_flag, 1, 0, cglobs);
@ -1723,7 +1782,7 @@ c_goal(Term Goal, int mod, compiler_struct *cglobs)
if (H == (CELL *)cglobs->cint.freep0) {
/* oops, too many new variables */
save_machine_regs();
longjmp(cglobs->cint.CompilerBotch,4);
longjmp(cglobs->cint.CompilerBotch,OUT_OF_TEMPS_BOTCH);
}
c_eq(t2, a2, cglobs);
c_var(a1, bt1_flag, 2, 0, cglobs);
@ -1736,7 +1795,7 @@ c_goal(Term Goal, int mod, compiler_struct *cglobs)
if (H == (CELL *)cglobs->cint.freep0) {
/* oops, too many new variables */
save_machine_regs();
longjmp(cglobs->cint.CompilerBotch,4);
longjmp(cglobs->cint.CompilerBotch,OUT_OF_TEMPS_BOTCH);
}
c_eq(t1, a1, cglobs);
@ -1750,7 +1809,7 @@ c_goal(Term Goal, int mod, compiler_struct *cglobs)
if (H == (CELL *)cglobs->cint.freep0) {
/* oops, too many new variables */
save_machine_regs();
longjmp(cglobs->cint.CompilerBotch,4);
longjmp(cglobs->cint.CompilerBotch,OUT_OF_TEMPS_BOTCH);
}
c_eq(t2, a2, cglobs);
c_var(t1, bt1_flag, 2, 0, cglobs);
@ -2110,7 +2169,7 @@ clear_bvarray(int var, CELL *bvarray
Yap_Error_Term = TermNil;
Yap_ErrorMessage = "compiler internal error: variable initialised twice";
save_machine_regs();
longjmp(cglobs->cint.CompilerBotch, 2);
longjmp(cglobs->cint.CompilerBotch, OUT_OF_HEAP_BOTCH);
}
cglobs->pbvars++;
#endif
@ -2151,7 +2210,7 @@ push_bvmap(int label, PInstr *pcpc, compiler_struct *cglobs)
Yap_Error_Term = TermNil;
Yap_ErrorMessage = "Too many embedded disjunctions";
save_machine_regs();
longjmp(cglobs->cint.CompilerBotch, 2);
longjmp(cglobs->cint.CompilerBotch, OUT_OF_HEAP_BOTCH);
}
/* the label instruction */
bvstack[bvindex].lab = label;
@ -2174,7 +2233,7 @@ reset_bvmap(CELL *bvarray, int nperm, compiler_struct *cglobs)
Yap_Error_Term = TermNil;
Yap_ErrorMessage = "No embedding in disjunctions";
save_machine_regs();
longjmp(cglobs->cint.CompilerBotch, 2);
longjmp(cglobs->cint.CompilerBotch, OUT_OF_HEAP_BOTCH);
}
env_size = (bvstack[bvindex-1].pc)->rnd1;
size = env_size/(8*sizeof(CELL));
@ -2194,7 +2253,7 @@ pop_bvmap(CELL *bvarray, int nperm, compiler_struct *cglobs)
Yap_Error_Term = TermNil;
Yap_ErrorMessage = "Too few embedded disjunctions";
/* save_machine_regs();
longjmp(cglobs->cint.CompilerBotch, 2); */
longjmp(cglobs->cint.CompilerBotch, OUT_OF_HEAP_BOTCH); */
}
reset_bvmap(bvarray, nperm, cglobs);
bvindex--;
@ -2462,7 +2521,7 @@ checktemp(Int arg, Int rn, compiler_vm_op ic, compiler_struct *cglobs)
Yap_Error_Term = TermNil;
Yap_ErrorMessage = "too many temporaries";
save_machine_regs();
longjmp(cglobs->cint.CompilerBotch, 1);
longjmp(cglobs->cint.CompilerBotch, COMPILER_ERR_BOTCH);
}
v->NoOfVE = cglobs->vadr = vadr = TempVar | target1;
v->KindOfVE = TempVar;
@ -2591,7 +2650,7 @@ c_layout(compiler_struct *cglobs)
Yap_Error_Term = TermNil;
Yap_ErrorMessage = "wrong number of variables found in bitmap";
save_machine_regs();
longjmp(cglobs->cint.CompilerBotch, 2);
longjmp(cglobs->cint.CompilerBotch, OUT_OF_HEAP_BOTCH);
}
#endif
}
@ -3034,56 +3093,91 @@ Yap_cclause(volatile Term inp_clause, int NOfArgs, int mod, volatile Term src)
int botch_why;
/* may botch while doing a different module */
/* first, initialise cglobs->cint.CompilerBotch to handle all cases of interruptions */
compiler_struct cglobs;
compiler_struct cglobs;
/* make sure we know there was no error yet */
Yap_ErrorMessage = NULL;
if ((botch_why = setjmp(cglobs.cint.CompilerBotch)) == 3) {
/* out of local stack, just duplicate the stack */
/* make sure we know there was no error yet */
Yap_ErrorMessage = NULL;
if ((botch_why = setjmp(cglobs.cint.CompilerBotch))) {
restore_machine_regs();
reset_vars(cglobs.vtable);
{
Int osize = 2*sizeof(CELL)*(ASP-H);
ARG1 = inp_clause;
ARG3 = src;
switch(botch_why) {
case OUT_OF_STACK_BOTCH:
/* out of local stack, just duplicate the stack */
{
Int osize = 2*sizeof(CELL)*(ASP-H);
ARG1 = inp_clause;
ARG3 = src;
YAPLeaveCriticalSection();
if (!Yap_gcl(Yap_Error_Size, NOfArgs, ENV, P)) {
Yap_Error_TYPE = OUT_OF_STACK_ERROR;
Yap_Error_Term = inp_clause;
}
if (osize > ASP-H) {
if (!Yap_growstack(2*sizeof(CELL)*(ASP-H))) {
YAPLeaveCriticalSection();
if (!Yap_gcl(Yap_Error_Size, NOfArgs, ENV, P)) {
Yap_Error_TYPE = OUT_OF_STACK_ERROR;
Yap_Error_Term = inp_clause;
}
if (osize > ASP-H) {
if (!Yap_growstack(2*sizeof(CELL)*(ASP-H))) {
Yap_Error_TYPE = OUT_OF_STACK_ERROR;
Yap_Error_Term = inp_clause;
}
}
YAPEnterCriticalSection();
src = ARG3;
inp_clause = ARG1;
}
break;
case OUT_OF_AUX_BOTCH:
/* out of local stack, just duplicate the stack */
YAPLeaveCriticalSection();
ARG1 = inp_clause;
ARG3 = src;
if (!Yap_ExpandPreAllocCodeSpace(Yap_Error_Size, NULL)) {
Yap_Error_TYPE = OUT_OF_AUXSPACE_ERROR;
Yap_Error_Term = inp_clause;
}
YAPEnterCriticalSection();
src = ARG3;
inp_clause = ARG1;
break;
case OUT_OF_TEMPS_BOTCH:
/* out of temporary cells */
if (maxvnum < 16*1024) {
maxvnum *= 2;
} else {
maxvnum += 4096;
}
break;
case OUT_OF_HEAP_BOTCH:
/* not enough heap */
ARG1 = inp_clause;
ARG3 = src;
YAPLeaveCriticalSection();
if (!Yap_growheap(FALSE, Yap_Error_Size, NULL)) {
Yap_Error_TYPE = OUT_OF_HEAP_ERROR;
Yap_Error_Term = inp_clause;
return NULL;
}
YAPEnterCriticalSection();
src = ARG3;
inp_clause = ARG1;
break;
case OUT_OF_TRAIL_BOTCH:
/* not enough trail */
ARG1 = inp_clause;
ARG3 = src;
YAPLeaveCriticalSection();
if (!Yap_growtrail(0L, FALSE)) {
Yap_Error_TYPE = OUT_OF_TRAIL_ERROR;
Yap_Error_Term = inp_clause;
return NULL;
}
YAPEnterCriticalSection();
src = ARG3;
inp_clause = ARG1;
break;
default:
return NULL;
}
} else if (botch_why == 4) {
/* out of temporary cells */
restore_machine_regs();
reset_vars(cglobs.vtable);
if (maxvnum < 16*1024) {
maxvnum *= 2;
} else {
maxvnum += 4096;
}
} else if (botch_why == 2) {
/* not enough heap */
restore_machine_regs();
reset_vars(cglobs.vtable);
Yap_Error_TYPE = OUT_OF_HEAP_ERROR;
Yap_Error_Term = TermNil;
return 0;
}
my_clause = inp_clause;
if (Yap_ErrorMessage) {
reset_vars(cglobs.vtable);
return (0);
}
HB = H;
Yap_ErrorMessage = NULL;
Yap_Error_Size = 0;
@ -3092,6 +3186,7 @@ Yap_cclause(volatile Term inp_clause, int NOfArgs, int mod, volatile Term src)
cglobs.cint.CodeStart = cglobs.cint.cpc = NULL;
cglobs.cint.BlobsStart = cglobs.cint.icpc = NULL;
cglobs.cint.dbterml = NULL;
cglobs.cint.freep =
cglobs.cint.freep0 =
(char *) (H + maxvnum+(sizeof(Int)/sizeof(CELL))*MaxTemps+MaxTemps);

13
C/computils.c
View File

@ -11,8 +11,12 @@
* File: computils.c *
* comments: some useful routines for YAP's compiler *
* *
* Last rev: $Date: 2006-09-20 20:03:51 $ *
* Last rev: $Date: 2007-11-06 17:02:12 $ *
* $Log: not supported by cvs2svn $
* Revision 1.30 2006/09/20 20:03:51 vsc
* improve indexing on floats
* fix sending large lists to DB
*
* Revision 1.29 2005/12/05 17:16:10 vsc
* write_depth/3
* overflow handlings and garbage collection
@ -89,7 +93,7 @@ AllocCMem (int size, struct intermediates *cip)
if (ASP <= CellPtr (cip->freep) + 256) {
Yap_Error_Size = 256+((char *)cip->freep - (char *)H);
save_machine_regs();
longjmp(cip->CompilerBotch,3);
longjmp(cip->CompilerBotch, OUT_OF_STACK_BOTCH);
}
return (p);
}
@ -563,6 +567,8 @@ static char *opformat[] =
"put_num\t\t%n,%r",
"get_float\t\t%w,%r",
"put_float\t\t%w,%r",
"get_dbterm\t%w,%r",
"put_dbterm\t%w,%r",
"align_float",
"get_longint\t\t%w,%r",
"put_longint\t\t%w,%r",
@ -583,6 +589,8 @@ static char *opformat[] =
"write_num\t%n",
"unify_float\t%w",
"write_float\t%w",
"unify_dbterm\t%w",
"write_dbterm\t%w",
"unify_longint\t%w",
"write_longint\t%w",
"unify_bigint\t%l",
@ -650,6 +658,7 @@ static char *opformat[] =
"unify_last_atom\t%a",
"unify_last_num\t%n",
"unify_last_float\t%w",
"unify_last_dbterm\t%w",
"unify_last_longint\t%w",
"unify_last_bigint\t%l",
"pvar_bitmap\t%l,%b",

30
C/dbase.c
View File

@ -1258,7 +1258,7 @@ CreateDBWithDBRef(Term Tm, DBProp p, struct db_globs *dbg)
ppt->Contents[1] = (CELL)dbr;
ppt->DBRefs = (DBRef *)(ppt->Contents+2);
#ifdef COROUTINING
ppt->attachments = 0L;
ppt->ag.attachments = 0L;
#endif
return pp;
}
@ -1278,7 +1278,7 @@ CreateDBTermForAtom(Term Tm, UInt extra_size, struct db_globs *dbg) {
ppt->NOfCells = 0;
ppt->DBRefs = NULL;
#ifdef COROUTINING
ppt->attachments = 0;
ppt->ag.attachments = 0;
#endif
ppt->DBRefs = NULL;
ppt->Entry = Tm;
@ -1301,7 +1301,7 @@ CreateDBTermForVar(UInt extra_size, struct db_globs *dbg)
ppt->NOfCells = 0;
ppt->DBRefs = NULL;
#ifdef COROUTINING
ppt->attachments = 0;
ppt->ag.attachments = 0;
#endif
ppt->DBRefs = NULL;
ppt->Entry = (CELL)(&(ppt->Entry));
@ -1331,7 +1331,7 @@ CreateDBRefForAtom(Term Tm, DBProp p, int InFlag, struct db_globs *dbg) {
pp->DBT.DBRefs = NULL;
pp->DBT.NOfCells = 0;
#ifdef COROUTINING
pp->DBT.attachments = 0;
pp->DBT.ag.attachments = 0;
#endif
return(pp);
}
@ -1355,7 +1355,7 @@ CreateDBRefForVar(Term Tm, DBProp p, int InFlag, struct db_globs *dbg) {
pp->DBT.NOfCells = 0;
pp->DBT.DBRefs = NULL;
#ifdef COROUTINING
pp->DBT.attachments = 0;
pp->DBT.ag.attachments = 0;
#endif
INIT_LOCK(pp->lock);
INIT_DBREF_COUNT(pp);
@ -1582,7 +1582,7 @@ CreateDBStruct(Term Tm, DBProp p, int InFlag, int *pstat, UInt extra_size, struc
ppt->NOfCells = NOfCells;
#ifdef COROUTINING
ppt->attachments = attachments;
ppt->ag.attachments = attachments;
#endif
if (pp0 != pp) {
nar = ppt->Contents;
@ -1617,14 +1617,14 @@ CreateDBStruct(Term Tm, DBProp p, int InFlag, int *pstat, UInt extra_size, struc
ppt->Entry = AdjustIDBPtr(tt,(CELL)ppt-(CELL)ppt0);
#ifdef COROUTINING
if (attachments)
ppt->attachments = AdjustIDBPtr(attachments,(CELL)ppt-(CELL)ppt0);
ppt->ag.attachments = AdjustIDBPtr(attachments,(CELL)ppt-(CELL)ppt0);
else
ppt->attachments = 0L;
ppt->ag.attachments = 0L;
#endif
} else {
ppt->Entry = tt;
#ifdef COROUTINING
ppt->attachments = attachments;
ppt->ag.attachments = attachments;
#endif
}
if (flag & DBWithRefs) {
@ -2440,7 +2440,7 @@ GetDBTerm(DBTerm *DBSP)
if (IsVarTerm(t)
#if COROUTINING
&& !DBSP->attachments
&& !DBSP->ag.attachments
#endif
) {
return MkVarTerm();
@ -2475,8 +2475,8 @@ GetDBTerm(DBTerm *DBSP)
linkblk(lp, HOld-1, (CELL)HOld-(CELL)(DBSP->Contents));
}
#ifdef COROUTINING
if (DBSP->attachments != 0L) {
if (!copy_attachments((CELL *)AdjustIDBPtr(DBSP->attachments,(CELL)HOld-(CELL)(DBSP->Contents)))) {
if (DBSP->ag.attachments != 0L) {
if (!copy_attachments((CELL *)AdjustIDBPtr(DBSP->ag.attachments,(CELL)HOld-(CELL)(DBSP->Contents)))) {
H = HOld;
Yap_Error_TYPE = OUT_OF_ATTVARS_ERROR;
Yap_Error_Size = 0;
@ -4949,16 +4949,18 @@ StoreTermInDB(Term t, int nargs)
InQueue, &needs_vars, 0, &dbg)) == NULL) {
if (Yap_Error_TYPE == YAP_NO_ERROR) {
break;
} else if (nargs == -1) {
return NULL;
} else {
XREGS[nargs+1] = t;
if (recover_from_record_error(nargs+1)) {
t = Deref(XREGS[nargs+1]);
} else {
return FALSE;
return NULL;
}
}
}
return(x);
return x;
}
DBTerm *

5
C/grow.c
View File

@ -891,6 +891,8 @@ fix_compiler_instructions(PInstr *pcpc)
case align_float_op:
case get_bigint_op:
case put_bigint_op:
case get_dbterm_op:
case put_dbterm_op:
case get_list_op:
case put_list_op:
case get_struct_op:
@ -906,7 +908,10 @@ fix_compiler_instructions(PInstr *pcpc)
case write_longint_op:
case unify_bigint_op:
case unify_last_bigint_op:
case unify_dbterm_op:
case unify_last_dbterm_op:
case write_bigint_op:
case write_dbterm_op:
case unify_list_op:
case write_list_op:
case unify_struct_op:

29
C/index.c
View File

@ -11,8 +11,11 @@
* File: index.c *
* comments: Indexing a Prolog predicate *
* *
* Last rev: $Date: 2007-10-28 11:23:40 $,$Author: vsc $ *
* Last rev: $Date: 2007-11-06 17:02:12 $,$Author: vsc $ *
* $Log: not supported by cvs2svn $
* Revision 1.188 2007/10/28 11:23:40 vsc
* fix overflow
*
* Revision 1.187 2007/09/22 08:38:05 vsc
* nb_ extra stuff plus an indexing overflow fix.
*
@ -1093,6 +1096,7 @@ has_cut(yamop *pc)
case _get_atom:
case _put_atom:
case _get_bigint:
case _get_dbterm:
pc = NEXTOP(pc,xc);
break;
/* instructions type cc */
@ -1218,6 +1222,8 @@ has_cut(yamop *pc)
case _unify_l_atom:
case _unify_bigint:
case _unify_l_bigint:
case _unify_dbterm:
case _unify_l_dbterm:
pc = NEXTOP(pc,oc);
break;
/* instructions type osc */
@ -1947,6 +1953,9 @@ add_info(ClauseDef *clause, UInt regno)
}
break;
*/
case _get_dbterm:
clause->Tag = (CELL)NULL;
return;
case _copy_idb_term:
case _unify_idb_term:
if (regno == 2) {
@ -2180,6 +2189,10 @@ add_info(ClauseDef *clause, UInt regno)
case _unify_l_bigint:
cl = NEXTOP(cl,oc);
break;
case _unify_dbterm:
case _unify_l_dbterm:
cl = NEXTOP(cl,oc);
break;
case _unify_n_atoms_write:
case _unify_n_atoms:
cl = NEXTOP(cl,osc);
@ -2817,6 +2830,10 @@ add_head_info(ClauseDef *clause, UInt regno)
case _unify_l_bigint:
cl = NEXTOP(cl,oc);
break;
case _unify_dbterm:
case _unify_l_dbterm:
cl = NEXTOP(cl,oc);
break;
case _unify_n_atoms_write:
case _unify_n_atoms:
cl = NEXTOP(cl,osc);
@ -2827,6 +2844,9 @@ add_head_info(ClauseDef *clause, UInt regno)
case _unify_l_struc:
cl = NEXTOP(cl,of);
break;
case _get_dbterm:
clause->Tag = (CELL)NULL;
return;
case _unify_idb_term:
case _copy_idb_term:
if (regno != 2) {
@ -3100,6 +3120,10 @@ add_arg_info(ClauseDef *clause, PredEntry *ap, UInt argno)
}
argno--;
break;
case _unify_dbterm:
case _unify_l_dbterm:
clause->Tag = (CELL)NULL;
return;
case _unify_n_atoms:
if (argno <= cl->u.osc.s) {
clause->Tag = cl->u.osc.c;
@ -3133,8 +3157,11 @@ add_arg_info(ClauseDef *clause, PredEntry *ap, UInt argno)
cl = NEXTOP(cl,os);
break;
#endif
case _get_dbterm:
case _unify_idb_term:
case _copy_idb_term:
clause->Tag = (CELL)NULL;
return;
{
Term t = clause->u.c_sreg[argno];

25
C/stdpreds.c
View File

@ -11,8 +11,11 @@
* File: stdpreds.c *
* comments: General-purpose C implemented system predicates *
* *
* Last rev: $Date: 2007-10-18 08:24:16 $,$Author: vsc $ *
* Last rev: $Date: 2007-11-06 17:02:12 $,$Author: vsc $ *
* $Log: not supported by cvs2svn $
* Revision 1.122 2007/10/18 08:24:16 vsc
* fix global variables
*
* Revision 1.121 2007/10/10 09:44:24 vsc
* some more fixes to make YAP swi compatible
* fix absolute_file_name (again)
@ -2884,10 +2887,24 @@ p_flags(void)
if (IsVarTerm(t1))
return (FALSE);
if (IsAtomTerm(t1)) {
pe = RepPredProp(PredPropByAtom(AtomOfTerm(t1), mod));
while ((pe = RepPredProp(PredPropByAtom(AtomOfTerm(t1), mod)))== NULL) {
if (!Yap_growheap(FALSE, 0, NULL)) {
Yap_Error(OUT_OF_HEAP_ERROR, ARG1, "while generating new predicate");
return FALSE;
}
t1 = Deref(ARG1);
mod = Deref(ARG2);
}
} else if (IsApplTerm(t1)) {
Functor funt = FunctorOfTerm(t1);
pe = RepPredProp(PredPropByFunc(funt, mod));
while ((pe = RepPredProp(PredPropByFunc(funt, mod)))== NULL) {
if (!Yap_growheap(FALSE, 0, NULL)) {
Yap_Error(OUT_OF_HEAP_ERROR, ARG1, "while generating new predicate");
return FALSE;
}
t1 = Deref(ARG1);
mod = Deref(ARG2);
}
} else
return (FALSE);
if (EndOfPAEntr(pe))
@ -3858,7 +3875,7 @@ Yap_InitCPreds(void)
Yap_InitCPred("$debug", 1, p_debug, SafePredFlag|SyncPredFlag|HiddenPredFlag);
#endif
/* Accessing and changing the flags for a predicate */
Yap_InitCPred("$flags", 4, p_flags, SafePredFlag|SyncPredFlag|HiddenPredFlag);
Yap_InitCPred("$flags", 4, p_flags, SyncPredFlag|HiddenPredFlag);
/* hiding and unhiding some predicates */
Yap_InitCPred("hide", 1, p_hide, SafePredFlag|SyncPredFlag);
Yap_InitCPred("unhide", 1, p_unhide, SafePredFlag|SyncPredFlag);

170
C/utilpreds.c
View File

@ -1044,7 +1044,7 @@ p_ground(void) /* ground(+T) */
Functor fun = FunctorOfTerm(t);
if (IsExtensionFunctor(fun))
return(TRUE);
return TRUE;
else if ((out = ground_complex_term(RepAppl(t),
RepAppl(t)+
ArityOfFunctor(fun))) >= 0) {
@ -1060,6 +1060,174 @@ p_ground(void) /* ground(+T) */
}
}
static int
SizeOfExtension(Term t)
{
Functor f = FunctorOfTerm(t);
if (f== FunctorDouble) {
return 2 + sizeof(Float)/sizeof(CELL);
}
if (f== FunctorLongInt) {
return 2 + sizeof(Float)/sizeof(CELL);
}
if (f== FunctorDBRef) {
return 0;
}
if (f== FunctorBigInt) {
CELL *pt = RepAppl(t)+1;
return 2+sizeof(MP_INT)+(((MP_INT *)(pt+1))->_mp_alloc*sizeof(mp_limb_t));
}
return 0;
}
static Int sz_ground_complex_term(register CELL *pt0, register CELL *pt0_end, int ground)
{
register CELL **to_visit0, **to_visit = (CELL **)Yap_PreAllocCodeSpace();
Int sz = 0;
to_visit0 = to_visit;
loop:
while (pt0 < pt0_end) {
register CELL d0;
register CELL *ptd0;
++pt0;
ptd0 = pt0;
d0 = *ptd0;
deref_head(d0, vars_in_term_unk);
vars_in_term_nvar:
{
if (IsPairTerm(d0)) {
sz += 2;
if (to_visit + 1024 >= (CELL **)AuxSp) {
goto aux_overflow;
}
#ifdef RATIONAL_TREES
to_visit[0] = pt0;
to_visit[1] = pt0_end;
to_visit[2] = (CELL *)*pt0;
to_visit += 3;
*pt0 = TermNil;
#else
if (pt0 < pt0_end) {
to_visit[0] = pt0;
to_visit[1] = pt0_end;
to_visit += 2;
}
#endif
pt0 = RepPair(d0) - 1;
pt0_end = RepPair(d0) + 1;
} else if (IsApplTerm(d0)) {
register Functor f;
register CELL *ap2;
/* store the terms to visit */
ap2 = RepAppl(d0);
f = (Functor)(*ap2);
if (IsExtensionFunctor(f)) {
sz += SizeOfExtension(d0);
continue;
}
if (to_visit + 1024 >= (CELL **)AuxSp) {
goto aux_overflow;
}
#ifdef RATIONAL_TREES
to_visit[0] = pt0;
to_visit[1] = pt0_end;
to_visit[2] = (CELL *)*pt0;
to_visit += 3;
*pt0 = TermNil;
#else
/* store the terms to visit */
if (pt0 < pt0_end) {
to_visit[0] = pt0;
to_visit[1] = pt0_end;
to_visit += 2;
}
#endif
d0 = ArityOfFunctor(f);
sz += (1+d0);
pt0 = ap2;
pt0_end = ap2 + d0;
}
continue;
}
derefa_body(d0, ptd0, vars_in_term_unk, vars_in_term_nvar);
if (!ground)
continue;
#ifdef RATIONAL_TREES
while (to_visit > to_visit0) {
to_visit -= 3;
pt0 = to_visit[0];
pt0_end = to_visit[1];
*pt0 = (CELL)to_visit[2];
}
#endif
return 0;
}
/* Do we still have compound terms to visit */
if (to_visit > to_visit0) {
#ifdef RATIONAL_TREES
to_visit -= 3;
pt0 = to_visit[0];
pt0_end = to_visit[1];
*pt0 = (CELL)to_visit[2];
#else
to_visit -= 2;
pt0 = to_visit[0];
pt0_end = to_visit[1];
#endif
goto loop;
}
return sz;
aux_overflow:
/* unwind stack */
#ifdef RATIONAL_TREES
while (to_visit > to_visit0) {
to_visit -= 3;
pt0 = to_visit[0];
*pt0 = (CELL)to_visit[2];
}
#endif
return -1;
}
int
Yap_SizeGroundTerm(Term t, int ground)
{
if (IsVarTerm(t)) {
if (!ground)
return 1;
return 0;
} else if (IsPrimitiveTerm(t)) {
return 1;
} else if (IsPairTerm(t)) {
int sz = sz_ground_complex_term(RepPair(t)-1, RepPair(t)+1, ground);
if (sz <= 0)
return sz;
return sz+2;
} else {
int sz = 0;
Functor fun = FunctorOfTerm(t);
if (IsExtensionFunctor(fun))
return 1+ SizeOfExtension(t);
sz = sz_ground_complex_term(RepAppl(t),
RepAppl(t)+
ArityOfFunctor(fun),
ground);
if (sz <= 0)
return sz;
return 1+ArityOfFunctor(fun)+sz;
}
}
static Int var_in_complex_term(register CELL *pt0,
register CELL *pt0_end,
Term v)

6
H/Heap.h
View File

@ -10,7 +10,7 @@
* File: Heap.h *
* mods: *
* comments: Heap Init Structure *
* version: $Id: Heap.h,v 1.118 2007-10-10 09:44:24 vsc Exp $ *
* version: $Id: Heap.h,v 1.119 2007-11-06 17:02:12 vsc Exp $ *
*************************************************************************/
/* information that can be stored in Code Space */
@ -338,6 +338,7 @@ typedef struct various_codes {
lockvar dead_static_clauses_lock; /* protect DeadStaticClauses */
lockvar dead_mega_clauses_lock; /* protect DeadMegaClauses */
lockvar dead_static_indices_lock; /* protect DeadStaticIndices */
lockvar dbterms_list_lock; /* protect DBTermList */
int heap_top_owner;
#ifdef LOW_LEVEL_TRACER
lockvar low_level_trace_lock;
@ -349,6 +350,7 @@ typedef struct various_codes {
struct static_clause *dead_static_clauses;
struct static_mega_clause *dead_mega_clauses;
struct static_index *dead_static_indices;
struct dbterm_list *dbterms_list;
Atom
atom_abol,
atom_alarm,
@ -945,6 +947,7 @@ struct various_codes *Yap_heap_regs;
#define ParserErrorStyle Yap_heap_regs->parser_error_style
#define DeadStaticClauses Yap_heap_regs->dead_static_clauses
#define DeadMegaClauses Yap_heap_regs->dead_mega_clauses
#define DBTermsList Yap_heap_regs->dbterms_list
#define DeadStaticIndices Yap_heap_regs->dead_static_indices
#define SizeOfOverflow Yap_heap_regs->size_of_overflow
#define LastWtimePtr Yap_heap_regs->last_wtime
@ -959,6 +962,7 @@ struct various_codes *Yap_heap_regs;
#define ThreadsTotalTime Yap_heap_regs->threads_total_time
#define DeadStaticClausesLock Yap_heap_regs->dead_static_clauses_lock
#define DeadMegaClausesLock Yap_heap_regs->dead_mega_clauses_lock
#define DBTermsListLock Yap_heap_regs->dbterms_list_lock
#define DeadStaticIndicesLock Yap_heap_regs->dead_static_indices_lock
#define ModulesLock Yap_heap_regs->modules_lock
#endif

8
H/YapOpcodes.h
View File

@ -11,8 +11,11 @@
* File: YapOpcodes.h *
* comments: Central Table with all YAP opcodes *
* *
* Last rev: $Date: 2006-10-10 14:08:17 $ *
* Last rev: $Date: 2007-11-06 17:02:12 $ *
* $Log: not supported by cvs2svn $
* Revision 1.40 2006/10/10 14:08:17 vsc
* small fixes on threaded implementation.
*
* Revision 1.39 2006/09/20 20:03:51 vsc
* improve indexing on floats
* fix sending large lists to DB
@ -182,6 +185,7 @@
OPCODE(get_float ,xd),
OPCODE(get_longint ,xi),
OPCODE(get_bigint ,xc),
OPCODE(get_dbterm ,xc),
OPCODE(get_list ,x),
OPCODE(get_struct ,xf),
OPCODE(unify_x_var ,ox),
@ -192,6 +196,7 @@
OPCODE(unify_float ,od),
OPCODE(unify_longint ,oc),
OPCODE(unify_bigint ,oc),
OPCODE(unify_dbterm ,oc),
OPCODE(unify_list ,o),
OPCODE(unify_struct ,of),
OPCODE(put_x_var ,xx),
@ -318,6 +323,7 @@
OPCODE(unify_l_float ,od),
OPCODE(unify_l_longint ,oi),
OPCODE(unify_l_bigint ,oc),
OPCODE(unify_l_dbterm ,oc),
OPCODE(unify_l_void ,o),
OPCODE(unify_l_n_voids ,os),
OPCODE(unify_l_x_loc ,ox),

3
H/Yapproto.h
View File

@ -10,7 +10,7 @@
* File: Yap.proto *
* mods: *
* comments: Function declarations for YAP *
* version: $Id: Yapproto.h,v 1.80 2007-10-18 08:24:16 vsc Exp $ *
* version: $Id: Yapproto.h,v 1.81 2007-11-06 17:02:12 vsc Exp $ *
*************************************************************************/
/* prototype file for Yap */
@ -325,6 +325,7 @@ void STD_PROTO(Yap_InitUserBacks,(void));
/* utilpreds.c */
Term STD_PROTO(Yap_CopyTerm,(Term));
int STD_PROTO(Yap_SizeGroundTerm,(Term, int));
void STD_PROTO(Yap_InitUtilCPreds,(void));
/* yap.c */

18
H/Yatom.h
View File

@ -798,6 +798,7 @@ IsPredProperty (int flags)
/* There are several flags for code and data base entries */
typedef enum
{
HasDBTMask = 0x400000, /* includes a pointer to a DBTerm */
MegaMask = 0x200000, /* mega clause */
FactMask = 0x100000, /* a fact */
SwitchRootMask = 0x80000, /* root for the index tree */
@ -821,7 +822,10 @@ typedef enum
typedef struct DB_TERM
{
#ifdef COROUTINING
CELL attachments; /* attached terms */
union {
CELL attachments; /* attached terms */
struct DB_TERM *NextDBT;
} ag;
#endif
struct DB_STRUCT **DBRefs; /* pointer to other references */
CELL NOfCells; /* Size of Term */
@ -829,6 +833,18 @@ typedef struct DB_TERM
Term Contents[MIN_ARRAY]; /* stored term */
} DBTerm;
inline EXTERN DBTerm *TermToDBTerm(Term);
inline EXTERN DBTerm *TermToDBTerm(Term X)
{
if (IsPairTerm(X)) {
return(DBTerm *)((char *)RepPair(X) - (CELL) &(((DBTerm *) NULL)->Contents));
} else {
return(DBTerm *)((char *)RepAppl(X) - (CELL) &(((DBTerm *) NULL)->Contents));
}
}
/* The ordering of the first 3 fields should be compatible with lu_clauses */
typedef struct DB_STRUCT
{

8
H/clause.h
View File

@ -158,6 +158,14 @@ typedef union clause_ptr {
struct static_index *si;
} ClausePointer;
typedef struct dbterm_list {
/* a list of dbterms associated with a clause */
DBTerm *dbterms;
yamop *clause_code;
PredEntry *p;
struct dbterm_list *next_dbl;
} DBTermList;
#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)))

13
H/compile.h
View File

@ -30,6 +30,8 @@ typedef enum compiler_op {
put_num_op,
get_float_op,
put_float_op,
get_dbterm_op,
put_dbterm_op,
align_float_op,
get_longint_op,
put_longint_op,
@ -50,6 +52,8 @@ typedef enum compiler_op {
write_num_op,
unify_float_op,
write_float_op,
unify_dbterm_op,
write_dbterm_op,
unify_longint_op,
write_longint_op,
unify_bigint_op,
@ -117,6 +121,7 @@ typedef enum compiler_op {
unify_last_atom_op,
unify_last_num_op,
unify_last_float_op,
unify_last_dbterm_op,
unify_last_longint_op,
unify_last_bigint_op,
mark_initialised_pvars_op,
@ -231,6 +236,13 @@ typedef struct CEXPENTRY {
struct CEXPENTRY *NextCE;
} CExpEntry;
#define COMPILER_ERR_BOTCH 1
#define OUT_OF_HEAP_BOTCH 2
#define OUT_OF_STACK_BOTCH 3
#define OUT_OF_TEMPS_BOTCH 4
#define OUT_OF_AUX_BOTCH 5
#define OUT_OF_TRAIL_BOTCH 6
typedef struct intermediates {
char *freep;
@ -239,6 +251,7 @@ typedef struct intermediates {
struct PSEUDO *CodeStart;
struct PSEUDO *icpc;
struct PSEUDO *BlobsStart;
struct dbterm_list *dbterml;
int *label_offset;
Int *uses;
Term *contents;

9
H/rclause.h
View File

@ -12,8 +12,11 @@
* File: rclause.h *
* comments: walk through a clause *
* *
* Last rev: $Date: 2006-11-27 17:42:03 $,$Author: vsc $ *
* Last rev: $Date: 2007-11-06 17:02:12 $,$Author: vsc $ *
* $Log: not supported by cvs2svn $
* Revision 1.18 2006/11/27 17:42:03 vsc
* support for UNICODE, and other bug fixes.
*
* Revision 1.17 2006/10/10 14:08:17 vsc
* small fixes on threaded implementation.
*
@ -464,6 +467,7 @@ restore_opcodes(yamop *pc)
case _get_atom:
case _put_atom:
case _get_bigint:
case _get_dbterm:
pc->u.xc.x = XAdjust(pc->u.xc.x);
{
Term t = pc->u.xc.c;
@ -474,7 +478,6 @@ restore_opcodes(yamop *pc)
}
pc = NEXTOP(pc,xc);
break;
/* instructions type cc */
case _get_2atoms:
{
Term t = pc->u.cc.c1;
@ -744,6 +747,8 @@ restore_opcodes(yamop *pc)
case _unify_l_atom:
case _unify_bigint:
case _unify_l_bigint:
case _unify_dbterm:
case _unify_l_dbterm:
pc->u.oc.opcw = Yap_opcode(Yap_op_from_opcode(pc->u.oc.opcw));
{
Term t = pc->u.oc.c;

69
H/rheap.h
View File

@ -11,8 +11,13 @@
* File: rheap.h *
* comments: walk through heap code *
* *
* Last rev: $Date: 2007-10-10 09:44:24 $,$Author: vsc $ *
* Last rev: $Date: 2007-11-06 17:02:12 $,$Author: vsc $ *
* $Log: not supported by cvs2svn $
* Revision 1.77 2007/10/10 09:44:24 vsc
* some more fixes to make YAP swi compatible
* fix absolute_file_name (again)
* fix setarg
*
* Revision 1.76 2007/09/28 23:18:17 vsc
* handle learning from interpretations.
*
@ -188,8 +193,6 @@ do_clean_susp_clauses(yamop *ipc) {
#include "rclause.h"
/* Restoring the heap */
/* adjusts terms stored in the data base, when they have no variables */
static Term
AdjustDBTerm(Term trm, Term *p_base)
@ -232,12 +235,16 @@ AdjustDBTerm(Term trm, Term *p_base)
}
static void
RestoreDBTerm(DBTerm *dbr)
RestoreDBTerm(DBTerm *dbr, int attachments)
{
if (attachments) {
#ifdef COROUTINING
if (dbr->attachments)
dbr->attachments = AdjustDBTerm(dbr->attachments, dbr->Contents);
if (dbr->ag.attachments)
dbr->ag.attachments = AdjustDBTerm(dbr->ag.attachments, dbr->Contents);
#endif
} else {
dbr->ag.NextDBT = DBTermAdjust(dbr->ag.NextDBT);
}
if (dbr->DBRefs != NULL) {
DBRef *cp;
DBRef tm;
@ -250,6 +257,8 @@ RestoreDBTerm(DBTerm *dbr)
dbr->Entry = AdjustDBTerm(dbr->Entry, dbr->Contents);
}
/* Restoring the heap */
/* Restores a prolog clause, in its compiled form */
static void
RestoreStaticClause(StaticClause *cl)
@ -313,7 +322,7 @@ RestoreLUClause(LogUpdClause *cl, PredEntry *pp)
}
if (cl->ClSource) {
cl->ClSource = DBTermAdjust(cl->ClSource);
RestoreDBTerm(cl->ClSource);
RestoreDBTerm(cl->ClSource, TRUE);
}
if (cl->ClPrev) {
cl->ClPrev = PtoLUCAdjust(cl->ClPrev);
@ -325,6 +334,20 @@ RestoreLUClause(LogUpdClause *cl, PredEntry *pp)
restore_opcodes(cl->ClCode);
}
static void
RestoreDBTermEntry(struct dbterm_list *dbl) {
DBTerm *dbt;
dbl->dbterms = DBTermAdjust(dbl->dbterms);
dbl->clause_code = PtoOpAdjust(dbl->clause_code);
dbl->next_dbl = PtoDBTLAdjust(dbl->next_dbl);
dbl->p = PredEntryAdjust(dbl->p);
while (dbt) {
RestoreDBTerm(dbt, FALSE);
dbt = dbt->ag.NextDBT;
}
}
static void
CleanLUIndex(LogUpdIndex *idx)
{
@ -503,6 +526,14 @@ restore_codes(void)
mc = mc->ClNext;
}
}
if (Yap_heap_regs->dbterms_list) {
struct dbterm_list *dbl = PtoDBTLAdjust(Yap_heap_regs->dbterms_list);
Yap_heap_regs->dbterms_list = dbl;
while (dbl) {
RestoreDBTermEntry(dbl);
dbl = dbl->next_dbl;
}
}
if (Yap_heap_regs->dead_static_indices) {
StaticIndex *si = (StaticIndex *)AddrAdjust((ADDR)(Yap_heap_regs->dead_static_indices));
Yap_heap_regs->dead_static_indices = si;
@ -705,23 +736,23 @@ restore_codes(void)
Yap_heap_regs->yap_lib_dir =
(char *)AddrAdjust((ADDR)Yap_heap_regs->yap_lib_dir);
Yap_heap_regs->pred_goal_expansion =
(PredEntry *)AddrAdjust((ADDR)Yap_heap_regs->pred_goal_expansion);
PredEntryAdjust(Yap_heap_regs->pred_goal_expansion);
Yap_heap_regs->pred_meta_call =
(PredEntry *)AddrAdjust((ADDR)Yap_heap_regs->pred_meta_call);
PredEntryAdjust(Yap_heap_regs->pred_meta_call);
Yap_heap_regs->pred_dollar_catch =
(PredEntry *)AddrAdjust((ADDR)Yap_heap_regs->pred_dollar_catch);
PredEntryAdjust(Yap_heap_regs->pred_dollar_catch);
Yap_heap_regs->pred_recorded_with_key =
(PredEntry *)AddrAdjust((ADDR)Yap_heap_regs->pred_recorded_with_key);
PredEntryAdjust(Yap_heap_regs->pred_recorded_with_key);
Yap_heap_regs->pred_log_upd_clause =
(PredEntry *)AddrAdjust((ADDR)Yap_heap_regs->pred_log_upd_clause);
PredEntryAdjust(Yap_heap_regs->pred_log_upd_clause);
Yap_heap_regs->pred_log_upd_clause0 =
(PredEntry *)AddrAdjust((ADDR)Yap_heap_regs->pred_log_upd_clause0);
PredEntryAdjust(Yap_heap_regs->pred_log_upd_clause0);
Yap_heap_regs->pred_static_clause =
(PredEntry *)AddrAdjust((ADDR)Yap_heap_regs->pred_static_clause);
PredEntryAdjust(Yap_heap_regs->pred_static_clause);
Yap_heap_regs->pred_throw =
(PredEntry *)AddrAdjust((ADDR)Yap_heap_regs->pred_throw);
PredEntryAdjust(Yap_heap_regs->pred_throw);
Yap_heap_regs->pred_handle_throw =
(PredEntry *)AddrAdjust((ADDR)Yap_heap_regs->pred_handle_throw);
PredEntryAdjust(Yap_heap_regs->pred_handle_throw);
#if DEBUG
if (Yap_heap_regs->db_erased_list) {
Yap_heap_regs->db_erased_list =
@ -816,7 +847,7 @@ RestoreDBEntry(DBRef dbr)
else
fprintf(stderr, " a var\n");
#endif
RestoreDBTerm(&(dbr->DBT));
RestoreDBTerm(&(dbr->DBT), TRUE);
if (dbr->Parent) {
dbr->Parent = (DBProp)AddrAdjust((ADDR)(dbr->Parent));
}
@ -1029,7 +1060,7 @@ restore_static_array(StaticArrayEntry *ae)
} else {
DBTerm *db = (DBTerm *)RepAppl(reg);
db = DBTermAdjust(db);
RestoreDBTerm(db);
RestoreDBTerm(db, TRUE);
base->tstore = AbsAppl((CELL *)db);
}
}
@ -1048,7 +1079,7 @@ restore_static_array(StaticArrayEntry *ae)
base++;
} else {
*base++ = reg = DBTermAdjust(reg);
RestoreDBTerm(reg);
RestoreDBTerm(reg, TRUE);
}
}
}

9
H/sshift.h
View File

@ -568,6 +568,15 @@ PtoStCAdjust (struct static_clause *ptr)
}
inline EXTERN struct dbterm_list *PtoDBTLAdjust (struct dbterm_list *);
inline EXTERN struct dbterm_list *
PtoDBTLAdjust (struct dbterm_list * addr)
{
return (struct dbterm_list *) ((ADDR) (CharP (addr) + HDiff));
}
#if PRECOMPUTE_REGADDRESS
inline EXTERN wamreg XAdjust (wamreg);

4
changes-5.1.html
View File

@ -17,6 +17,10 @@
<h2>Yap-5.1.3:</h2>
<ul>
<li> FIXED: predicate table could not enough room while overflowing
(obs from Bernd Gutmann).</li>
<li> FIXED: compile large ground terms outside clauses (obs from Bernd
Gutmann).</li>
<li> FIXED: YAP_LeaveGoal should always backtrack, if asked for, for
deterministic computations (obs from Trevor Walker).</li>
<li> FIXED: in_this_file_before should check predicate module, not

60
docs/yap.tex
View File

@ -1,4 +1,4 @@
\input texinfo @c -*- mode: texinfo; coding: latin-1; -*-
a\input texinfo @c -*- mode: texinfo; coding: latin-1; -*-
@c %**start of header
@setfilename yap.info
@ -1594,6 +1594,64 @@ will consult @code{file1} @code{file4} and reconsult @code{file2} and
@noindent
In YAP, the same as @code{reconsult/1}.
@item load_files(@var{+Files}, @var{+Options})
@findex load_files/2
@syindex load_files/2
@cnindex load_files/2
@noindent
General implementation of @code{consult}. Execution is controlled by the
following flags:
@table @code
@item autoload(+@var{Autoload})
SWI-compatible option where if @var{Autoload} is @code{true} predicates
are loaded on first call. Currently
not supported.
@item derived_from(+@var{File})
SWI-compatible option to control make. Currently
not supported.
@item encoding(+@var{Encoding})
Character encoding used in consulting files. Please @pxref{Encoding} for
supported encodings.
@item expand(+@var{Bool})
Not yet implemented. In SWI-Prolog, if @code{true}, run the
filenames through @code{expand_file_name/2} and load the returned
files. Default is false, except for @code{consult/1} which is
intended for interactive use.
@item if(+@var{Condition})
Load the file only if the specified @var{Condition} is
satisfied. The value @code{true} the file unconditionally,
@code{changed} loads the file if it was not loaded before, or has
been modified since it was loaded the last time, @code{not_loaded}
loads the file if it was not loaded before.
@item imports(+@var{ListOrAll})
If @code{all} and the file is a module file, import all public
predicates. Otherwise import only the named predicates. Each
predicate is referred to as @code{<name>/<arity>}. This option has
no effect if the file is not a module file.
@item must_be_module(+@var{Bool})
If true, raise an error if the file is not a module file. Used by
@code{use_module/[1,2]}.
@c qcompile(Bool)
@c If this call appears in a directive of a file that is compiled into Quick Load Format using qcompile/1 and this flag is true, the contents of the argument files are included in the .qlf file instead of the loading directive.
@item silent(+@var{Bool})
If true, load the file without printing a message. The specified value is the default for all files loaded as a result of loading the specified files.
@item stream(+@var{Input})
This SWI-Prolog extension compiles the data from the stream
@var{Input}. If this option is used, @var{Files} must be a single
atom which is used to identify the source-location of the loaded
clauses as well as remove all clauses if the data is re-consulted.
This option is added to allow compiling from non-file locations such as databases, the web, the user (see consult/1) or other servers.
@end table
@item ensure_loaded(@var{+F}) [ISO]
@findex ensure_loaded/1
@syindex compile/1

8
pl/consult.yap
View File

@ -19,14 +19,14 @@
% SWI options
% autoload(true,false)
% derived_from(File) -> make
% encoding(Encoding)
% encoding(Encoding) => implemented
% expand({true,false)
% if(changed,true,not_loaded)
% imports(all,List)
% if(changed,true,not_loaded) => implemented
% imports(all,List) => implemented
% qcompile(true,false)
% silent(true,false) => implemented
% stream(Stream) => implemented
% consult(consult,reconsult)
% consult(consult,reconsult) => implemented
%
load_files(Files,Opts) :-
'$load_files'(Files,Opts,load_files(Files,Opts)).