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

exo first step.

Browse Source
This commit is contained in:
Vítor Santos Costa 2013-01-07 09:47:14 +00:00
parent 3565a01f1e
commit f063a2bd52
12 changed files with 657 additions and 8 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

123
C/absmi.c
View File

@ -960,6 +960,96 @@ Yap_absmi(int inp)
GONext();
ENDOp();
/*****************************************************************
* EXO try - retry instructions *
*****************************************************************/
/* try_exo Pred,Label */
BOp(enter_exo, e);
{
yamop *pt;
saveregs();
pt = Yap_ExoLookup(PredFromExpandCode(PREG));
setregs();
PREG = pt;
}
JMPNext();
ENDBOp();
/* check if enough space between trail and codespace */
/* try_exo Pred,Label */
Op(try_exo, lp);
/* check if enough space between trail and codespace */
check_trail(TR);
/* I use YREG =to go through the choicepoint. Usually YREG =is in a
* register, but sometimes (X86) not. In this case, have a
* new register to point at YREG =*/
CACHE_Y(YREG);
S_YREG[-1] = (CELL)SREG;
S_YREG--;
/* store arguments for procedure */
store_at_least_one_arg(PREG->u.lp.p->ArityOfPE);
/* store abstract machine registers */
store_yaam_regs(NEXTOP(PREG,lp), 0);
/* On a try_me, set cut to point at previous choicepoint,
* that is, to the B before the cut.
*/
set_cut(S_YREG, B);
/* now, install the new YREG =*/
B = B_YREG;
#ifdef YAPOR
SCH_set_load(B_YREG);
#endif /* YAPOR */
PREG = NEXTOP(PREG, lp);
SET_BB(B_YREG);
ENDCACHE_Y();
GONext();
ENDOp();
/* retry_exo Pred */
Op(retry_exo, lp);
BEGD(d0);
CACHE_Y(B);
d0 = Yap_NextExo(B_YREG, (struct index_t *)PREG->u.lp.l);
if (d0) {
/* After retry, cut should be pointing at the parent
* choicepoint for the current B */
restore_yaam_regs(PREG);
restore_at_least_one_arg(PREG->u.lp.p->ArityOfPE);
#ifdef FROZEN_STACKS
S_YREG = (CELL *) 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);
} else {
#ifdef YAPOR
if (SCH_top_shared_cp(B)) {
SCH_last_alternative(PREG, B_YREG);
restore_at_least_one_arg(PREG->u.Otapl.s);
#ifdef FROZEN_STACKS
S_YREG = (CELL *) PROTECT_FROZEN_B(B_YREG);
#endif /* FROZEN_STACKS */
set_cut(S_YREG, B->cp_b);
} else
#endif /* YAPOR */
{
pop_yaam_regs();
pop_at_least_one_arg(PREG->u.Otapl.s);
/* After trust, cut should be pointing at the new top
* choicepoint */
#ifdef FROZEN_STACKS
S_YREG = (CELL *) PROTECT_FROZEN_B(B_YREG);
#endif /* FROZEN_STACKS */
set_cut(S_YREG, B);
}
}
PREG = NEXTOP(PREG, lp);
ENDCACHE_Y();
ENDD(D0);
GONext();
ENDOp();
/*****************************************************************
* Profiled try - retry - trust instructions *
*****************************************************************/
@ -3228,7 +3318,7 @@ Yap_absmi(int inp)
ENDOp();
Op(run_eam, os);
if (inp==-9000) { /* usar a indexação para saber quais as alternativas validas */
if (inp==-9000) { /* use indexing to find out valid alternatives */
extern CELL *beam_ALTERNATIVES;
*beam_ALTERNATIVES= (CELL *) PREG->u.os.opcw;
beam_ALTERNATIVES++;
@ -3277,6 +3367,8 @@ Yap_absmi(int inp)
#endif
/************************************************************************\
* Get Instructions *
\************************************************************************/
@ -3470,6 +3562,35 @@ Yap_absmi(int inp)
ENDD(d0);
ENDOp();
Op(get_atom_exo, x);
BEGD(d0);
BEGD(d1);
/* fetch arguments */
d0 = XREG(PREG->u.xc.x);
d1 = *SREG++;
BEGP(pt0);
deref_head(d0, gatom_exo_unk);
/* argument is nonvar */
gatom_exo_nonvar:
if (d0 == d1) {
PREG = NEXTOP(PREG, x);
GONext();
}
else {
FAIL();
}
deref_body(d0, pt0, gatom_exo_unk, gatom_exo_nonvar);
/* argument is a variable */
PREG = NEXTOP(PREG, x);
Bind(pt0, d1);
GONext();
ENDP(pt0);
ENDD(d1);
ENDD(d0);
ENDOp();
Op(get_2atoms, cc);
BEGD(d0);
BEGD(d1);

453
C/exo.c Normal file
View File

@ -0,0 +1,453 @@
/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: exo.c *
* comments: Exo compilation *
* *
* Last rev: $Date: 2008-07-22 23:34:44 $,$Author: vsc $ * *
* $Log: not supported by cvs2svn $ *
* *
* *
*************************************************************************/
#include "Yap.h"
#include "clause.h"
#include "yapio.h"
#include "eval.h"
#include "tracer.h"
#ifdef YAPOR
#include "or.macros.h"
#endif /* YAPOR */
#ifdef TABLING
#include "tab.macros.h"
#endif /* TABLING */
#if HAVE_STRING_H
#include <string.h>
#endif
#define NEXTOP(V,TYPE) ((yamop *)(&((V)->u.TYPE.next)))
#define MAX_ARITY 256
/* Simple hash function */
static UInt
HASH(UInt j, CELL *cl, struct index_t *it)
{
return (cl[j] >> 3) % it->nels + j*(7*it->nels)/11;
}
/* search for matching elements */
static int
MATCH(CELL *clp,CELL *kvp, UInt j, UInt bnds[])
{
do {
if ( bnds[j] && *clp == *kvp)
return FALSE;
clp--;
kvp--;
j--;
} while (j != 0);
return TRUE;
}
static void
ADD_TO_TRY_CHAIN(CELL *kvp, CELL *cl, struct index_t *it)
{
UInt new = (kvp-it->cls)/it->arity;
UInt old = (cl-it->cls)/it->arity;
UInt *links = it->links;
UInt tmp = links[old]; /* points to the end of the chain */
if (!tmp) {
links[old] = links[new] = new;
} else {
links[new] = links[tmp];
links[tmp] = new;
links[old] = new;
}
}
static UInt
NEXT(UInt hash, struct index_t *it, UInt j)
{
return (j+1) % it->nels;
}
/* This is the critical routine, it builds the hash table *
* each HT field stores a key pointer which is actually
* a pointer to the point in the clause where one can find the element.
*
* The cls table indexes all elements that can be reached using that key.
*
* Insert:
* j = first
* not match cij -> insert, open new chain
* match ci..j ck..j -> find j = minarg(cij \= c2j),
* else j = +inf -> c2+ci
* Lookup:
* j= first
* not match cij -> fail
* match ci..j ck..j -> find j = minarg(cij \= c2j)
* else
*/
static void
INSERT(CELL *cl, struct index_t *it, UInt arity, UInt base, UInt bnds[])
{
UInt j = base;
CELL *kvp;
UInt hash;
/* skip over argument */
while (!bnds[j]) {
j++;
}
/* j is the firs bound element */
/* check if we match */
hash = HASH(j, cl, it);
next:
/* loop to insert element */
kvp = it->key[hash];
if (kvp == NULL) {
/* simple case, new entry */
it->key[hash] = cl+j;
return;
} else if (MATCH(cl+j, kvp, j, bnds)) {
/* collision */
UInt k;
CELL *target;
for (k =j, target = kvp; k < arity; k++,target++ ) {
if (bnds[k]) {
if (*target != cl[k]) {
/* found a new forking point */
INSERT(cl, it, arity, j, bnds);
return;
}
}
}
ADD_TO_TRY_CHAIN(kvp-base, cl, it);
return;
} else {
j = NEXT(hash, it, j);
goto next;
}
}
static yamop *
LOOKUP(struct index_t *it, UInt arity, UInt bnds[])
{
UInt j = 0;
CELL *kvp;
UInt hash;
/* skip over argument */
while (!bnds[j]) {
j++;
}
/* j is the firs bound element */
/* check if we match */
hash:
hash = HASH(j, XREGS+1, it);
next:
/* loop to insert element */
kvp = it->key[hash];
if (kvp == NULL) {
/* simple case, no element */
return FAILCODE;
} else if (MATCH(XREGS+(j+1), kvp, j, bnds)) {
/* found element */
UInt k;
CELL *target;
for (k =j, target = kvp; k < arity; k++,target++ ) {
if (bnds[k]) {
if (*target != XREGS[k+1]) {
goto hash;
}
}
}
S = target-arity;
return it->code;
} else {
/* collision */
j = NEXT(hash, it, j);
goto next;
}
}
static void
fill_hash(UInt bmap, UInt bnds[], struct index_t *it)
{
UInt i;
UInt arity = it->arity;
CELL *cl = it->cls;
for (i=0; i < it->nels; i++) {
INSERT(cl, it, arity, 0, bnds);
cl += arity;
}
for (i=0; i < it->nels*2; i++) {
if (it->key[i]) {
UInt offset = (it->key[i]-it->cls)/arity;
UInt last = it->links[offset];
/* the chain used to point straight to the last, and the last back to the origibal first */
it->links[offset] = it->links[last];
it->links[last] = 0;
}
}
}
static struct index_t *
add_index(struct index_t *i0, UInt bmap, UInt bndsf[], PredEntry *ap)
{
UInt ncls = ap->cs.p_code.NOfClauses, j;
CELL *base;
struct index_t *i;
size_t sz;
yamop *ptr;
if (!(base = (CELL *)Yap_AllocCodeSpace(3*sizeof(CELL)*ncls))) {
CACHE_REGS
save_machine_regs();
LOCAL_Error_Size = 3*ncls*sizeof(CELL);
LOCAL_ErrorMessage = "not enough space to index";
Yap_Error(OUT_OF_HEAP_ERROR, TermNil, LOCAL_ErrorMessage);
return NULL;
}
sz = (CELL)NEXTOP(NEXTOP((yamop*)NULL,lp),lp)+ap->ArityOfPE*(CELL)NEXTOP((yamop *)NULL,x) +(CELL)NEXTOP(NEXTOP((yamop *)NULL,p),l);
if (!(i = (struct index_t *)Yap_AllocCodeSpace(sizeof(struct index_t)+sz))) {
CACHE_REGS
save_machine_regs();
LOCAL_Error_Size = 3*ncls*sizeof(CELL);
LOCAL_ErrorMessage = "not enough space to index";
Yap_Error(OUT_OF_HEAP_ERROR, TermNil, LOCAL_ErrorMessage);
return NULL;
}
bzero(base, 3*sizeof(CELL)*ncls);
i->next = i0->next;
i->prev = i0;
i->nels = ncls;
i->arity = ap->ArityOfPE;
i->ap = ap;
i->bmap = bmap;
i->is_key = FALSE;
i->hsize = 2*ncls;
i->key = (CELL **)base;
i->links = (CELL *)(base+2*ncls);
i->cls = (CELL *)((ADDR)ap->cs.p_code.FirstClause+2*sizeof(struct index_t *));
i0->next = i;
fill_hash(bmap, base, i);
ptr = (yamop *)(i+1);
i->code = ptr;
ptr->opc = Yap_opcode(_try_exo);
ptr->u.lp.l = (yamop *)i;
ptr->u.lp.p = ap;
ptr = NEXTOP(ptr, lp);
ptr->opc = Yap_opcode(_retry_exo);
ptr->u.lp.p = ap;
ptr->u.lp.l = (yamop *)i;
ptr = NEXTOP(ptr, lp);
for (j = 0; j < i->arity; j++) {
ptr->opc = Yap_opcode(_get_atom_exo);
#if PRECOMPUTE_REGADDRESS
ptr->u.x.x = (CELL) (XREGS + (j+1));
#else
ptr->u.x.x = j+1;
#endif
ptr = NEXTOP(ptr, x);
}
ptr->opc = Yap_opcode(_procceed);
ptr->u.p.p = ap;
ptr = NEXTOP(ptr, p);
ptr->opc = Yap_opcode(_Ystop);
ptr->u.l.l = i->code;
return i;
}
yamop *
Yap_ExoLookup(PredEntry *ap)
{
UInt arity = ap->ArityOfPE;
UInt bmap = 0L, bit = 1, count = 0, j;
struct index_t *i = *(struct index_t **)(ap->cs.p_code.FirstClause);
UInt bnds[MAX_ARITY];
for (j=0; j< arity; j++, bit<<=1) {
Term t = Deref(XREGS[j+1]);
if (!IsVarTerm(t)) {
bmap += bit;
bnds[j] = TRUE;
count++;
}
XREGS[j+1] = t;
}
while (i) {
if (i->is_key) {
if ((i->bmap & bmap) == i->bmap) {
break;
}
} else {
if (i->bmap == bmap) {
break;
}
}
}
if (!i) {
i = add_index(i, bmap, bnds, ap);
}
return LOOKUP(i, arity, bnds);
}
CELL
Yap_NextExo(choiceptr cptr, struct index_t *it)
{
CELL offset = ((CELL *)(B+1))[it->arity];
CELL next = it->links[offset];
((CELL *)(B+1))[it->arity] = next;
S = it->cls+it->arity*offset;
return next;
}
static Int
p_exodb_get_space( USES_REGS1 )
{ /* '$number_of_clauses'(Predicate,M,N) */
Term t = Deref(ARG1);
Term mod = Deref(ARG2);
Term tn = Deref(ARG3);
UInt arity;
Prop pe;
PredEntry *ap;
MegaClause *mcl;
UInt ncls;
UInt required;
struct index_t **li;
if (IsVarTerm(mod) || !IsAtomTerm(mod)) {
return(FALSE);
}
if (IsAtomTerm(t)) {
Atom a = AtomOfTerm(t);
arity = 0;
pe = PredPropByAtom(a, mod);
} else if (IsApplTerm(t)) {
register Functor f = FunctorOfTerm(t);
arity = ArityOfFunctor(f);
pe = PredPropByFunc(f, mod);
} else {
return FALSE;
}
if (EndOfPAEntr(pe))
return FALSE;
ap = RepPredProp(pe);
if (ap->PredFlags & (DynamicPredFlag|LogUpdatePredFlag
#ifdef TABLING
|TabledPredFlag
#endif /* TABLING */
)) {
Yap_Error(PERMISSION_ERROR_MODIFY_STATIC_PROCEDURE,t,"dbload_get_space/4");
return FALSE;
}
if (IsVarTerm(tn) || !IsIntegerTerm(tn)) {
return FALSE;
}
ncls = IntegerOfTerm(tn);
if (ncls <= 1) {
return FALSE;
}
required = ncls*sizeof(CELL)+sizeof(MegaClause)+2*sizeof(struct index_t *);
#ifdef DEBUG
total_megaclause += required;
nof_megaclauses++;
#endif
while (!(mcl = (MegaClause *)Yap_AllocCodeSpace(required))) {
if (!Yap_growheap(FALSE, required, NULL)) {
/* just fail, the system will keep on going */
return FALSE;
}
}
Yap_ClauseSpace += required;
/* cool, it's our turn to do the conversion */
mcl->ClFlags = MegaMask;
mcl->ClSize = required-sizeof(MegaClause);
mcl->ClPred = ap;
mcl->ClItemSize = arity*sizeof(CELL);
mcl->ClNext = NULL;
li = (struct index_t **)(mcl->ClCode);
li[0] = li[1] = NULL;
ap->cs.p_code.FirstClause =
ap->cs.p_code.LastClause =
mcl->ClCode;
ap->PredFlags |= MegaClausePredFlag;
ap->cs.p_code.NOfClauses = ncls;
if (ap->PredFlags & (SpiedPredFlag|CountPredFlag|ProfiledPredFlag)) {
ap->OpcodeOfPred = Yap_opcode(_spy_pred);
} else {
ap->OpcodeOfPred = Yap_opcode(_enter_exo);
}
ap->CodeOfPred = ap->cs.p_code.TrueCodeOfPred = (yamop *)(&(ap->OpcodeOfPred));
return Yap_unify(ARG4, MkIntegerTerm((Int)mcl));
}
#define DerefAndCheck(t, V) \
t = Deref(V); if(IsVarTerm(t) || !(IsAtomOrIntTerm(t))) Yap_Error(TYPE_ERROR_ATOM, t0, "load_db");
static int
store_exo(yamop *pc, UInt arity, Term t0)
{
Term t;
CELL *tp = RepAppl(t0)+1,
*cpc = (CELL *)pc;
UInt i;
for (i = 0; i< arity; i++) {
DerefAndCheck(t, tp[0]);
*cpc = t;
tp++;
cpc++;
}
return TRUE;
}
static Int
p_exoassert( USES_REGS1 )
{ /* '$number_of_clauses'(Predicate,M,N) */
Term thandle = Deref(ARG2);
Term tn = Deref(ARG3);
PredEntry *pe;
MegaClause *mcl;
Int n;
if (IsVarTerm(thandle) || !IsIntegerTerm(thandle)) {
return FALSE;
}
mcl = (MegaClause *)IntegerOfTerm(thandle);
if (IsVarTerm(tn) || !IsIntegerTerm(tn)) {
return FALSE;
}
n = IntegerOfTerm(tn);
pe = mcl->ClPred;
return store_exo((yamop *)((ADDR)mcl->ClCode+2*sizeof(struct index_t *)+n*(mcl->ClItemSize)),pe->ArityOfPE, Deref(ARG1));
}
void
Yap_InitExoPreds(void)
{
CACHE_REGS
Term cm = CurrentModule;
CurrentModule = DBLOAD_MODULE;
Yap_InitCPred("exo_db_get_space", 4, p_exodb_get_space, 0L);
Yap_InitCPred("exoassert", 3, p_exoassert, 0L);
CurrentModule = cm;
}

1
C/stdpreds.c
View File

@ -4486,6 +4486,7 @@ Yap_InitCPreds(void)
Yap_InitGlobals();
Yap_InitInlines();
Yap_InitIOPreds();
Yap_InitExoPreds();
Yap_InitLoadForeign();
Yap_InitModulesC();
Yap_InitSavePreds();

4
H/YapOpcodes.h
View File

@ -7,6 +7,9 @@
OPCODE(try_me ,Otapl),
OPCODE(retry_me ,Otapl),
OPCODE(trust_me ,Otapl),
OPCODE(enter_exo ,e),
OPCODE(try_exo ,lp),
OPCODE(retry_exo ,lp),
OPCODE(enter_profiling ,p),
OPCODE(retry_profiled ,p),
OPCODE(profiled_retry_me ,Otapl),
@ -58,6 +61,7 @@
OPCODE(get_x_val ,xx),
OPCODE(get_y_val ,yx),
OPCODE(get_atom ,xc),
OPCODE(get_atom_exo ,x),
OPCODE(get_2atoms ,cc),
OPCODE(get_3atoms ,ccc),
OPCODE(get_4atoms ,cccc),

3
H/Yapproto.h
View File

@ -183,6 +183,9 @@ Int STD_PROTO(Yap_exec_absmi,(int));
void STD_PROTO(Yap_trust_last,(void));
Term STD_PROTO(Yap_GetException,(void));
/* exo.c */
void STD_PROTO(Yap_InitExoPreds,(void));
/* gprof.c */
void STD_PROTO(Yap_InitLowProf,(void));
#if LOW_PROF

19
H/clause.h
View File

@ -159,6 +159,21 @@ typedef union clause_ptr {
struct static_index *si;
} ClausePointer;
typedef struct index_t {
struct index_t *next, *prev;
UInt nels;
UInt arity;
PredEntry *ap;
CELL bmap;
int is_key;
UInt hsize;
CELL **key;
CELL *cls;
CELL *links;
yamop *code;
} Index_t;
typedef struct dbterm_list {
/* a list of dbterms associated with a clause */
DBTerm *dbterms;
@ -228,6 +243,10 @@ void STD_PROTO(Yap_RemoveClauseFromIndex,(PredEntry *,yamop *));
LogUpdClause *STD_PROTO(Yap_NthClause,(PredEntry *,Int));
LogUpdClause *STD_PROTO(Yap_FollowIndexingCode,(PredEntry *,yamop *, Term *, yamop *,yamop *));
/* exo.c */
yamop *Yap_ExoLookup(PredEntry *ap);
CELL Yap_NextExo(choiceptr cpt, struct index_t *it);
#if USE_THREADED_CODE
#define OP_HASH_SIZE 2048

4
H/rclause.h
View File

@ -218,6 +218,7 @@ restore_opcodes(yamop *pc, yamop *max USES_REGS)
case _Nstop:
case _allocate:
case _copy_idb_term:
case _enter_exo:
case _expand_index:
case _index_blob:
case _index_dbref:
@ -285,6 +286,8 @@ restore_opcodes(yamop *pc, yamop *max USES_REGS)
pc = NEXTOP(pc,llll);
break;
/* instructions type lp */
case _retry_exo:
case _try_exo:
case _user_switch:
pc->u.lp.l = PtoOpAdjust(pc->u.lp.l);
pc->u.lp.p = PtoPredAdjust(pc->u.lp.p);
@ -537,6 +540,7 @@ restore_opcodes(yamop *pc, yamop *max USES_REGS)
pc = NEXTOP(pc,sssllp);
break;
/* instructions type x */
case _get_atom_exo:
case _get_list:
case _put_list:
case _save_b_x:

4
H/saveclause.h
View File

@ -236,6 +236,7 @@
case _Nstop:
case _allocate:
case _copy_idb_term:
case _enter_exo:
case _expand_index:
case _index_blob:
case _index_dbref:
@ -302,6 +303,8 @@
pc = NEXTOP(pc,llll);
break;
/* instructions type lp */
case _retry_exo:
case _try_exo:
case _user_switch:
CHECK(save_PtoOp(stream, pc->u.lp.l));
CHECK(save_PtoPred(stream, pc->u.lp.p));
@ -553,6 +556,7 @@
pc = NEXTOP(pc,sssllp);
break;
/* instructions type x */
case _get_atom_exo:
case _get_list:
case _put_list:
case _save_b_x:

4
H/walkclause.h
View File

@ -165,6 +165,7 @@
case _unify_idb_term:
return found_idb_clause(pc, startp, endp);
case _allocate:
case _enter_exo:
case _index_blob:
case _index_dbref:
case _index_long:
@ -215,6 +216,8 @@
pc = NEXTOP(pc,llll);
break;
/* instructions type lp */
case _retry_exo:
case _try_exo:
case _user_switch:
pc = NEXTOP(pc,lp);
break;
@ -405,6 +408,7 @@
pc = NEXTOP(pc,sssllp);
break;
/* instructions type x */
case _get_atom_exo:
case _get_list:
case _put_list:
case _save_b_x:

3
Makefile.in
View File

@ -243,6 +243,7 @@ C_SOURCES= \
$(srcdir)/C/corout.c $(srcdir)/C/dbase.c $(srcdir)/C/dlmalloc.c \
$(srcdir)/C/errors.c \
$(srcdir)/C/eval.c $(srcdir)/C/exec.c \
$(srcdir)/C/exo.c \
$(srcdir)/C/globals.c $(srcdir)/C/gmp_support.c \
$(srcdir)/C/gprof.c $(srcdir)/C/grow.c \
$(srcdir)/C/heapgc.c $(srcdir)/C/index.c \
@ -361,7 +362,7 @@ ENGINE_OBJECTS = \
bignum.o bb.o \
cdmgr.o cmppreds.o compiler.o computils.o \
corout.o cut_c.o dbase.o dlmalloc.o errors.o eval.o \
exec.o globals.o gmp_support.o gprof.o grow.o \
exec.o exo.o globals.o gmp_support.o gprof.o grow.o \
heapgc.o index.o init.o inlines.o \
iopreds.o depth_bound.o mavar.o \
myddas_mysql.o myddas_odbc.o myddas_shared.o myddas_initialization.o \

1
misc/buildops
View File

@ -139,6 +139,7 @@ file(I,W,C,L,F,H, S) :-
output_save_clause(S).
grep_opcode(W, Line) :-
%format('~s~n', [Line]),
split(Line," ,();",[OP,Name,Type]),
Name \= "or_last",
check_op(OP),

46
pl/dbload.yap
View File

@ -31,11 +31,11 @@ prolog:load_db(Fs) :-
dbload(Fs, _, G) :-
var(Fs),
'$do_error'(instantiation_error,G).
dbload([], _, _).
dbload([F|Fs], M0, G) :-
dbload([], _, _) :- !.
dbload([F|Fs], M0, G) :- !,
dbload(F, M0, G),
dbload(Fs, M0, G).
dbload(M:F, _M0, G) :-
dbload(M:F, _M0, G) :- !,
dbload(F, M, G).
dbload(F, M0, G) :-
atom(F), !,
@ -76,8 +76,11 @@ dbload_count(T0, M0) :-
get_module(M1:T0,_,T,M) :- !,
get_module(T0, M1, T , M).
get_module(T,M,T,M).
load_facts :-
yap_flag(exo_compilation, on), !.
load_exofacts.
load_facts :-
retract(dbloading(Na,Arity,M,T,NaAr,_)),
nb_getval(NaAr,Size),
@ -104,13 +107,44 @@ dbload_add_facts(R, M) :-
dbload_add_fact(T0, M0) :-
get_module(T0,M0,T,M),
functor(T,Na,Arity),
Na \= gene_product,
dbloading(Na,Arity,M,_,NaAr,Handle),
nb_getval(NaAr,I0),
I is I0+1,
nb_setval(NaAr,I),
dbassert(T,Handle,I0).
load_exofacts :-
retract(dbloading(Na,Arity,M,T,NaAr,_)),
nb_getval(NaAr,Size),
exo_db_get_space(T, M, Size, Handle),
assertz(dbloading(Na,Arity,M,T,NaAr,Handle)),
nb_setval(NaAr,0),
fail.
load_rxofacts :-
dbprocess(F, M),
open(F, read, R),
exodb_add_facts(R, M),
close(R),
fail.
load_facts.
exodb_add_facts(R, M) :-
repeat,
read(R,T),
( T = end_of_file -> !;
exodb_add_fact(T, M),
fail
).
exodb_add_fact(T0, M0) :-
get_module(T0,M0,T,M),
functor(T,Na,Arity),
dbloading(Na,Arity,M,_,NaAr,Handle),
nb_getval(NaAr,I0),
I is I0+1,
nb_setval(NaAr,I),
exoassert(T,Handle,I0).
clean_up :-
retractall(dbloading(_,_,_,_,_,_)),
retractall(dbprocess(_,_)),