This repository has been archived on 2023-08-20. You can view files and clone it, but cannot push or open issues or pull requests.
yap-6.3/C/dbload.c

460 lines
12 KiB
C
Raw Normal View History

2019-04-20 13:27:37 +01:00
/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: cdmgr.c *
* comments: Code manager *
* *
* Last rev: $Date: 2008-07-22 23:34:44 $,$Author: vsc $ 8
*************************************************************************/
#include "Yap.h"
#include "YapEval.h"
#include "clause.h"
#include "tracer.h"
#include "yapio.h"
#include <Yatom.h>
#include <assert.h>
#include <heapgc.h>
#include <iopreds.h>
#ifdef DEBUG
static UInt total_megaclause, total_released, nof_megaclauses;
#endif
/******************************************************************
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"
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);
}
void Yap_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;
}
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;
}
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);
}
void Yap_InitDBLoadPreds(void) {
CACHE_REGS
//CurrentModule = DBLOAD_MODULE;
Yap_InitCPred("$dbload_get_space", 4, p_dbload_get_space, 0L);
Yap_InitCPred("$dbassert", 3, p_dbassert, 0L);
//CurrentModule = cm;
}