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

fix_dbload

Browse Source
This commit is contained in:
Vitor Santos Costa 2019-04-20 12:48:33 +01:00
parent d8b4d1c878
commit 1f7835c5ef
4 changed files with 16 additions and 441 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

440
C/cdmgr.c
View File

@ -202,210 +202,6 @@ restart:
return NULL;
}
/******************************************************************
Mega Clauses
******************************************************************/
#define OrArgAdjust(P)
#define TabEntryAdjust(P)
#define DoubleInCodeAdjust(D)
#define IntegerInCodeAdjust(D)
#define IntegerAdjust(D) (D)
#define PtoPredAdjust(X) (X)
#define PtoOpAdjust(X) (X)
#define PtoLUClauseAdjust(P) (P)
#define PtoLUIndexAdjust(P) (P)
#define XAdjust(X) (X)
#define YAdjust(X) (X)
#define AtomTermAdjust(X) (X)
#define CellPtoHeapAdjust(X) (X)
#define FuncAdjust(X) (X)
#define CodeAddrAdjust(X) (X)
#define CodeComposedTermAdjust(X) (X)
#define ConstantAdjust(X) (X)
#define ArityAdjust(X) (X)
#define OpcodeAdjust(X) (X)
#define ModuleAdjust(X) (X)
#define ExternalFunctionAdjust(X) (X)
#define AdjustSwitchTable(X, Y, Z)
#define DBGroundTermAdjust(X) (X)
#define rehash(A, B, C)
static Term BlobTermInCodeAdjust(Term t) {
CACHE_REGS
#if TAGS_FAST_OPS
return t - LOCAL_ClDiff;
#else
return t + LOCAL_ClDiff;
#endif
}
static Term ConstantTermAdjust(Term t) {
if (IsAtomTerm(t))
return AtomTermAdjust(t);
return t;
}
#include "rclause.h"
#ifdef DEBUG
static UInt total_megaclause, total_released, nof_megaclauses;
#endif
void Yap_BuildMegaClause(PredEntry *ap) {
CACHE_REGS
StaticClause *cl;
UInt sz;
MegaClause *mcl;
yamop *ptr;
size_t required;
UInt has_blobs = 0;
if (ap->PredFlags & (DynamicPredFlag | LogUpdatePredFlag | MegaClausePredFlag
#ifdef TABLING
| TabledPredFlag
#endif /* TABLING */
| UDIPredFlag) ||
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);
} else {
sz -= (UInt)NEXTOP((yamop *)NULL, p) + sizeof(StaticClause);
}
required = sz * ap->cs.p_code.NOfClauses + sizeof(MegaClause) +
(UInt)NEXTOP((yamop *)NULL, l);
while (!(mcl = (MegaClause *)Yap_AllocCodeSpace(required))) {
if (!Yap_growheap(FALSE, required, NULL)) {
/* just fail, the system will keep on going */
return;
}
}
#ifdef DEBUG
total_megaclause += required;
cl = ClauseCodeToStaticClause(ap->cs.p_code.FirstClause);
total_released += ap->cs.p_code.NOfClauses * cl->ClSize;
nof_megaclauses++;
#endif
Yap_ClauseSpace += required;
/* cool, it's our turn to do the conversion */
mcl->ClFlags = MegaMask | has_blobs;
mcl->ClSize = required;
mcl->ClPred = ap;
mcl->ClItemSize = sz;
mcl->ClNext = NULL;
cl = ClauseCodeToStaticClause(ap->cs.p_code.FirstClause);
mcl->ClLine = cl->usc.ClLine;
ptr = mcl->ClCode;
while (TRUE) {
memmove((void *)ptr, (void *)cl->ClCode, sz);
if (has_blobs) {
LOCAL_ClDiff = (char *)(ptr) - (char *)cl->ClCode;
restore_opcodes(ptr, NULL PASS_REGS);
}
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, *curcl = cl;
ncl = cl->ClNext;
Yap_InformOfRemoval(cl);
Yap_ClauseSpace -= cl->ClSize;
Yap_FreeCodeSpace((ADDR)cl);
if (curcl->ClCode == ap->cs.p_code.LastClause)
break;
cl = ncl;
}
ap->cs.p_code.FirstClause = ap->cs.p_code.LastClause = mcl->ClCode;
ap->PredFlags |= MegaClausePredFlag;
Yap_inform_profiler_of_clause(mcl, (char *)mcl + required, ap, GPROF_MEGA);
}
static void split_megaclause(PredEntry *ap) {
StaticClause *start = NULL, *prev = NULL;
MegaClause *mcl;
yamop *ptr;
UInt ncls = ap->cs.p_code.NOfClauses, i;
mcl = ClauseCodeToMegaClause(ap->cs.p_code.FirstClause);
if (mcl->ClFlags & ExoMask) {
Yap_Error(PERMISSION_ERROR_MODIFY_STATIC_PROCEDURE, Yap_PredicateToIndicator(ap),
"while deleting clause from exo predicate %s/%d\n",
RepAtom(NameOfFunctor(ap->FunctorOfPred))->StrOfAE,
ap->ArityOfPE);
return;
}
RemoveIndexation(ap);
for (i = 0, ptr = mcl->ClCode; i < ncls; i++) {
StaticClause *new = (StaticClause *)Yap_AllocCodeSpace(
sizeof(StaticClause) + mcl->ClItemSize +
(UInt)NEXTOP((yamop *)NULL, p));
if (new == NULL) {
if (!Yap_growheap(FALSE,
(sizeof(StaticClause) + mcl->ClItemSize) * (ncls - i),
NULL)) {
while (start) {
StaticClause *cl = start;
start = cl->ClNext;
Yap_InformOfRemoval(cl);
Yap_ClauseSpace -= cl->ClSize;
Yap_FreeCodeSpace((char *)cl);
}
if (ap->ArityOfPE) {
Yap_Error(RESOURCE_ERROR_HEAP, TermNil,
"while breaking up mega clause for %s/%d\n",
RepAtom(NameOfFunctor(ap->FunctorOfPred))->StrOfAE,
ap->ArityOfPE);
} else {
Yap_Error(RESOURCE_ERROR_HEAP, TermNil,
"while breaking up mega clause for %s\n",
RepAtom((Atom)ap->FunctorOfPred)->StrOfAE);
}
return;
}
break;
}
Yap_ClauseSpace +=
sizeof(StaticClause) + mcl->ClItemSize + (UInt)NEXTOP((yamop *)NULL, p);
new->ClFlags = StaticMask | FactMask;
new->ClSize = mcl->ClItemSize;
new->usc.ClLine = Yap_source_line_no();
new->ClNext = NULL;
memmove((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;
}
/******************************************************************
@ -1763,7 +1559,7 @@ bool Yap_addclause(Term t, yamop *cp, Term tmode, Term mod, Term *t4ref)
pflags = p->PredFlags;
/* we are redefining a prolog module predicate */
if (pflags & MegaClausePredFlag) {
split_megaclause(p);
Yap_split_megaclause(p);
}
/* The only problem we have now is when we need to throw away
Indexing blocks
@ -1929,11 +1725,11 @@ void Yap_EraseMegaClause(yamop *cl, PredEntry *ap) {
void Yap_EraseStaticClause(StaticClause *cl, PredEntry *ap, Term mod) {
/* ok, first I need to find out the parent predicate */
if (ap->PredFlags & MegaClausePredFlag) {
split_megaclause(ap);
}
if (ap->PredFlags & IndexedPredFlag)
RemoveIndexation(ap);
if (ap->PredFlags & MegaClausePredFlag) {
Yap_split_megaclause(ap);
}
ap->cs.p_code.NOfClauses--;
if (ap->cs.p_code.FirstClause == cl->ClCode) {
/* got rid of first clause */
@ -3937,224 +3733,6 @@ p_continue_static_clause(USES_REGS1) {
return fetch_next_static_clause(pe, ipc, Deref(ARG3), ARG4, ARG5, B->cp_ap,
false);
}
static UInt compute_dbcl_size(arity_t arity) {
UInt sz;
switch (arity) {
case 2:
sz = (UInt)NEXTOP((yamop *)NULL, cc);
break;
case 3:
sz = (UInt)NEXTOP((yamop *)NULL, ccc);
break;
case 4:
sz = (UInt)NEXTOP((yamop *)NULL, cccc);
break;
case 5:
sz = (UInt)NEXTOP((yamop *)NULL, ccccc);
break;
case 6:
sz = (UInt)NEXTOP((yamop *)NULL, cccccc);
break;
default:
sz = arity * (UInt)NEXTOP((yamop *)NULL, xc);
break;
}
return (UInt)NEXTOP((yamop *)sz, p);
}
#define DerefAndCheck(t, V) \
t = Deref(V); \
if (IsVarTerm(t) || !(IsAtomOrIntTerm(t))) \
Yap_Error(TYPE_ERROR_ATOM, t0, "load_db");
static int store_dbcl_size(yamop *pc, arity_t arity, Term t0, PredEntry *pe) {
Term t;
CELL *tp = RepAppl(t0) + 1;
switch (arity) {
case 2:
pc->opc = Yap_opcode(_get_2atoms);
DerefAndCheck(t, tp[0]);
pc->y_u.cc.c1 = t;
DerefAndCheck(t, tp[1]);
pc->y_u.cc.c2 = t;
pc = NEXTOP(pc, cc);
break;
case 3:
pc->opc = Yap_opcode(_get_3atoms);
DerefAndCheck(t, tp[0]);
pc->y_u.ccc.c1 = t;
DerefAndCheck(t, tp[1]);
pc->y_u.ccc.c2 = t;
DerefAndCheck(t, tp[2]);
pc->y_u.ccc.c3 = t;
pc = NEXTOP(pc, ccc);
break;
case 4:
pc->opc = Yap_opcode(_get_4atoms);
DerefAndCheck(t, tp[0]);
pc->y_u.cccc.c1 = t;
DerefAndCheck(t, tp[1]);
pc->y_u.cccc.c2 = t;
DerefAndCheck(t, tp[2]);
pc->y_u.cccc.c3 = t;
DerefAndCheck(t, tp[3]);
pc->y_u.cccc.c4 = t;
pc = NEXTOP(pc, cccc);
break;
case 5:
pc->opc = Yap_opcode(_get_5atoms);
DerefAndCheck(t, tp[0]);
pc->y_u.ccccc.c1 = t;
DerefAndCheck(t, tp[1]);
pc->y_u.ccccc.c2 = t;
DerefAndCheck(t, tp[2]);
pc->y_u.ccccc.c3 = t;
DerefAndCheck(t, tp[3]);
pc->y_u.ccccc.c4 = t;
DerefAndCheck(t, tp[4]);
pc->y_u.ccccc.c5 = t;
pc = NEXTOP(pc, ccccc);
break;
case 6:
pc->opc = Yap_opcode(_get_6atoms);
DerefAndCheck(t, tp[0]);
pc->y_u.cccccc.c1 = t;
DerefAndCheck(t, tp[1]);
pc->y_u.cccccc.c2 = t;
DerefAndCheck(t, tp[2]);
pc->y_u.cccccc.c3 = t;
DerefAndCheck(t, tp[3]);
pc->y_u.cccccc.c4 = t;
DerefAndCheck(t, tp[4]);
pc->y_u.cccccc.c5 = t;
DerefAndCheck(t, tp[5]);
pc->y_u.cccccc.c6 = t;
pc = NEXTOP(pc, cccccc);
break;
default: {
arity_t i;
for (i = 0; i < arity; i++) {
pc->opc = Yap_opcode(_get_atom);
#if PRECOMPUTE_REGADDRESS
pc->y_u.xc.x = (CELL)(XREGS + (i + 1));
#else
pc->y_u.xc.x = i + 1;
#endif
DerefAndCheck(t, tp[0]);
pc->y_u.xc.c = t;
tp++;
pc = NEXTOP(pc, xc);
}
} break;
}
pc->opc = Yap_opcode(_procceed);
pc->y_u.p.p = pe;
return TRUE;
}
static Int
p_dbload_get_space(USES_REGS1) { /* '$number_of_clauses'(Predicate,M,N) */
Term t = Deref(ARG1);
Term mod = Deref(ARG2);
Term tn = Deref(ARG3);
arity_t arity;
Prop pe;
PredEntry *ap;
UInt sz;
MegaClause *mcl;
yamop *ptr;
UInt ncls;
UInt required;
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, Yap_PredicateToIndicator(ap),
"dbload_get_space/4");
return FALSE;
}
if (IsVarTerm(tn) || !IsIntegerTerm(tn)) {
return FALSE;
}
ncls = IntegerOfTerm(tn);
if (ncls <= 1) {
return FALSE;
}
sz = compute_dbcl_size(arity);
required = sz * ncls + sizeof(MegaClause) + (UInt)NEXTOP((yamop *)NULL, l);
#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 = sz * ncls;
mcl->ClPred = ap;
mcl->ClItemSize = sz;
mcl->ClNext = 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 = INDEX_OPCODE;
}
ap->CodeOfPred = ap->cs.p_code.TrueCodeOfPred =
(yamop *)(&(ap->OpcodeOfPred));
ptr = (yamop *)((ADDR)mcl->ClCode + ncls * sz);
ptr->opc = Yap_opcode(_Ystop);
return Yap_unify(ARG4, MkIntegerTerm((Int)mcl));
}
static Int p_dbassert(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_dbcl_size((yamop *)((ADDR)mcl->ClCode + n * (mcl->ClItemSize)),
pe->ArityOfPE, Deref(ARG1), pe);
}
#define CL_PROP_ERASED 0
#define CL_PROP_PRED 1
#define CL_PROP_FILE 2
@ -4698,8 +4276,6 @@ static Int init_pred_flag_vals(USES_REGS1) {
void Yap_InitCdMgr(void) {
CACHE_REGS
Term cm = CurrentModule;
Yap_InitCPred("$init_pred_flag_vals", 2, init_pred_flag_vals, SyncPredFlag);
Yap_InitCPred("$start_consult", 3, p_startconsult,
SafePredFlag | SyncPredFlag);
@ -4792,10 +4368,6 @@ void Yap_InitCdMgr(void) {
Yap_InitCPred("instance_property", 3, instance_property,
SafePredFlag | SyncPredFlag);
Yap_InitCPred("$fetch_nth_clause", 4, p_nth_instance, SyncPredFlag);
CurrentModule = DBLOAD_MODULE;
Yap_InitCPred("dbload_get_space", 4, p_dbload_get_space, 0L);
Yap_InitCPred("dbassert", 3, p_dbassert, 0L);
CurrentModule = cm;
Yap_InitCPred("$predicate_erased_statistics", 5,
p_predicate_erased_statistics, SyncPredFlag);
Yap_InitCPred("$including", 2, including, SyncPredFlag | HiddenPredFlag);
@ -4804,3 +4376,7 @@ void Yap_InitCdMgr(void) {
Yap_InitCPred("$predicate_lu_cps", 4, p_predicate_lu_cps, 0L);
#endif
}
void Yap_InitCLoadDB(void) {
}

1
C/stdpreds.c
View File

@ -1579,6 +1579,7 @@ void Yap_InitCPreds(void) {
Yap_InitGlobals();
Yap_InitInlines();
Yap_InitIOPreds();
Yap_InitDBLoadPreds();
Yap_InitExoPreds();
Yap_InitLoadForeign();
Yap_InitModulesC();

2
H/clause.h
View File

@ -465,6 +465,8 @@ extern yap_error_descriptor_t *Yap_bug_location(yap_error_descriptor_t *t, yamop
extern yap_error_descriptor_t *Yap_pc_add_location(yap_error_descriptor_t *t, void *p, void *b_ptr, void *env);
extern yap_error_descriptor_t * Yap_env_add_location(yap_error_descriptor_t *t, void *p, void *b_ptr, void *env, YAP_Int ignore_first);
void Yap_split_megaclause(PredEntry *ap);
#if LOW_PROF
void Yap_InformOfRemoval(void *);
void Yap_dump_code_area_for_profiler(void);

14
pl/dbload.yap
View File

@ -91,7 +91,7 @@ check_dbload_stream(R, M0) :-
).
dbload_count(T0, M0) :-
gemodule(T0,M0,T,M),
'$yap_strip_module'(M0:T0,M,T),
functor(T,Na,Arity),
% dbload_check_term(T),
(
@ -105,10 +105,6 @@ dbload_count(T0, M0) :-
nb_setval(NaAr,1)
).
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), !.
@ -116,7 +112,7 @@ load_facts :-
load_facts :-
retract(dbloading(Na,Arity,M,T,NaAr,_)),
nb_getval(NaAr,Size),
dbload_get_space(T, M, Size, Handle),
prolog:'$dbload_get_space'(T, M, Size, Handle),
assertz(dbloading(Na,Arity,M,T,NaAr,Handle)),
nb_setval(NaAr,0),
fail.
@ -137,13 +133,13 @@ dbload_add_facts(R, M) :-
).
dbload_add_fact(T0, M0) :-
get_module(T0,M0,T,M),
'$yap_strip_module'(M0:T0,M,T),
functor(T,Na,Arity),
dbloading(Na,Arity,M,_,NaAr,Handle),
nb_getval(NaAr,I0),
I is I0+1,
nb_setval(NaAr,I),
dbassert(T,Handle,I0).
prolog:'$dbassert'(T,Handle,I0).
load_exofacts :-
retract(dbloading(Na,Arity,M,T,NaAr,_)),
@ -174,7 +170,7 @@ protected_exodb_add_fact(R, M) :-
).
exodb_add_fact(T0, M0) :-
get_module(T0,M0,T,M),
'$yap_strip_module'(T0,M0,T,M),
functor(T,Na,Arity),
dbloading(Na,Arity,M,_,NaAr,Handle),
nb_getval(NaAr,I0),