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

Merge branch 'master' of ssh://git.dcc.fc.up.pt/yap-6.3

Browse Source 
Conflicts:
	C/threads.c
	JIT/HPP/EnvironmentInit.h
	packages/ProbLog/simplecudd_lfi/problogbdd_lfi.c
	pl/preds.yap
This commit is contained in:
Vitor Santos Costa 2014-11-25 16:53:35 +00:00
commit afc6c5d04e
29 changed files with 2005 additions and 1513 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
C/absmi.c
View File

@ -951,7 +951,7 @@ interrupt_execute( USES_REGS1 )
} }
if (PP) UNLOCKPE(1,PP); if (PP) UNLOCKPE(1,PP);
PP = P->y_u.pp.p0; PP = P->y_u.pp.p0;
if ((PP->ExtraPredFlags & (NoTracePredFlag|HiddenPredFlag)) && Yap_only_has_signal(YAP_CREEP_SIGNAL)) { if ((PP->PredFlags & (NoTracePredFlag|HiddenPredFlag)) && Yap_only_has_signal(YAP_CREEP_SIGNAL)) {
return 2; return 2;
} }
SET_ASP(YENV, E_CB*sizeof(CELL)); SET_ASP(YENV, E_CB*sizeof(CELL));
@ -979,7 +979,7 @@ interrupt_call( USES_REGS1 )
if (PP) UNLOCKPE(1,PP); if (PP) UNLOCKPE(1,PP);
PP = P->y_u.Osbpp.p0; PP = P->y_u.Osbpp.p0;
if (Yap_only_has_signal(YAP_CREEP_SIGNAL) && if (Yap_only_has_signal(YAP_CREEP_SIGNAL) &&
(PP->ExtraPredFlags & (NoTracePredFlag|HiddenPredFlag)) ) { (PP->PredFlags & (NoTracePredFlag|HiddenPredFlag)) ) {
return 2; return 2;
} }
SET_ASP(YENV, P->y_u.Osbpp.s); SET_ASP(YENV, P->y_u.Osbpp.s);
@ -1238,7 +1238,7 @@ interrupt_dexecute( USES_REGS1 )
if (PP) UNLOCKPE(1,PP); if (PP) UNLOCKPE(1,PP);
PP = P->y_u.pp.p0; PP = P->y_u.pp.p0;
pe = P->y_u.pp.p; pe = P->y_u.pp.p;
if ((PP->ExtraPredFlags & (NoTracePredFlag|HiddenPredFlag)) && Yap_only_has_signal(YAP_CREEP_SIGNAL)) { if ((PP->PredFlags & (NoTracePredFlag|HiddenPredFlag)) && Yap_only_has_signal(YAP_CREEP_SIGNAL)) {
return 2; return 2;
} }
/* set S for next instructions */ /* set S for next instructions */
@ -7830,8 +7830,7 @@ Yap_absmi(int inp)
BOp(call_cpred, Osbpp); BOp(call_cpred, Osbpp);
check_trail(TR); check_trail(TR);
if (!(PREG->y_u.Osbpp.p->PredFlags & (SafePredFlag)) && if (!(PREG->y_u.Osbpp.p->PredFlags & (SafePredFlag|NoTracePredFlag|HiddenPredFlag))) {
!(PREG->y_u.Osbpp.p0->ExtraPredFlags & (NoTracePredFlag|HiddenPredFlag))) {
CACHE_Y_AS_ENV(YREG); CACHE_Y_AS_ENV(YREG);
check_stack(NoStackCCall, HR); check_stack(NoStackCCall, HR);
ENDCACHE_Y_AS_ENV(); ENDCACHE_Y_AS_ENV();

6
C/adtdefs.c
View File

@ -848,7 +848,7 @@ Yap_NewPredPropByFunctor(FunctorEntry *fe, Term cur_mod)
} }
} }
if (LOCAL_PL_local_data_p== NULL || !truePrologFlag(PLFLAG_DEBUGINFO)) { if (LOCAL_PL_local_data_p== NULL || !truePrologFlag(PLFLAG_DEBUGINFO)) {
p->ExtraPredFlags |= NoTracePredFlag; p->PredFlags |= NoTracePredFlag;
} }
p->FunctorOfPred = fe; p->FunctorOfPred = fe;
if (fe->PropsOfFE) { if (fe->PropsOfFE) {
@ -937,7 +937,7 @@ Yap_NewThreadPred(PredEntry *ap USES_REGS)
p->FunctorOfPred = ap->FunctorOfPred; p->FunctorOfPred = ap->FunctorOfPred;
Yap_inform_profiler_of_clause(&(p->OpcodeOfPred), &(p->OpcodeOfPred)+1, p, GPROF_NEW_PRED_THREAD); Yap_inform_profiler_of_clause(&(p->OpcodeOfPred), &(p->OpcodeOfPred)+1, p, GPROF_NEW_PRED_THREAD);
if (LOCAL_PL_local_data_p== NULL || !truePrologFlag(PLFLAG_DEBUGINFO)) { if (LOCAL_PL_local_data_p== NULL || !truePrologFlag(PLFLAG_DEBUGINFO)) {
p->ExtraPredFlags |= (NoSpyPredFlag|NoTracePredFlag); p->PredFlags |= (NoSpyPredFlag|NoTracePredFlag);
} }
if (!(p->PredFlags & (CPredFlag|AsmPredFlag))) { if (!(p->PredFlags & (CPredFlag|AsmPredFlag))) {
Yap_inform_profiler_of_clause(&(p->cs.p_code.ExpandCode), &(p->cs.p_code.ExpandCode)+1, p, GPROF_NEW_PRED_THREAD); Yap_inform_profiler_of_clause(&(p->cs.p_code.ExpandCode), &(p->cs.p_code.ExpandCode)+1, p, GPROF_NEW_PRED_THREAD);
@ -1008,7 +1008,7 @@ Yap_NewPredPropByAtom(AtomEntry *ae, Term cur_mod)
p0 = AbsPredProp(p); p0 = AbsPredProp(p);
p->FunctorOfPred = (Functor)AbsAtom(ae); p->FunctorOfPred = (Functor)AbsAtom(ae);
if (LOCAL_PL_local_data_p== NULL || !truePrologFlag(PLFLAG_DEBUGINFO)) { if (LOCAL_PL_local_data_p== NULL || !truePrologFlag(PLFLAG_DEBUGINFO)) {
p->ExtraPredFlags |= (NoTracePredFlag|NoSpyPredFlag); p->PredFlags |= (NoTracePredFlag|NoSpyPredFlag);
} }
WRITE_UNLOCK(ae->ARWLock); WRITE_UNLOCK(ae->ARWLock);
{ {

16
C/cdmgr.c
View File

@ -2136,7 +2136,7 @@ Yap_discontiguous( PredEntry *ap USES_REGS )
{ {
register consult_obj *fp; register consult_obj *fp;
if (ap->ExtraPredFlags & (DiscontiguousPredFlag|MultiFileFlag)) if (ap->PredFlags & (DiscontiguousPredFlag|MultiFileFlag))
return FALSE; return FALSE;
if (!LOCAL_ConsultSp) { if (!LOCAL_ConsultSp) {
return FALSE; return FALSE;
@ -2339,7 +2339,7 @@ addclause(Term t, yamop *cp, int mode, Term mod, Term *t4ref)
PELOCK(20,p); PELOCK(20,p);
pflags = p->PredFlags; pflags = p->PredFlags;
/* we are redefining a prolog module predicate */ /* we are redefining a prolog module predicate */
if (((p->ExtraPredFlags & SysExportPredFlag) == (UInt)0) && if (((p->PredFlags & SysExportPredFlag) == (UInt)0) &&
( (
(pflags & (UserCPredFlag|CArgsPredFlag|NumberDBPredFlag|AtomDBPredFlag|TestPredFlag|AsmPredFlag|CPredFlag|BinaryPredFlag)) || (pflags & (UserCPredFlag|CArgsPredFlag|NumberDBPredFlag|AtomDBPredFlag|TestPredFlag|AsmPredFlag|CPredFlag|BinaryPredFlag)) ||
(p->ModuleOfPred == PROLOG_MODULE && (p->ModuleOfPred == PROLOG_MODULE &&
@ -2847,7 +2847,7 @@ p_sys_export( USES_REGS1 )
return (FALSE); return (FALSE);
} }
PELOCK(100,pred); PELOCK(100,pred);
pred->ExtraPredFlags |= SysExportPredFlag; pred->PredFlags |= SysExportPredFlag;
UNLOCKPE(100,pred); UNLOCKPE(100,pred);
return TRUE; return TRUE;
} }
@ -2868,7 +2868,7 @@ p_is_no_trace( USES_REGS1 )
if (EndOfPAEntr(pe)) if (EndOfPAEntr(pe))
return TRUE; return TRUE;
PELOCK(36,pe); PELOCK(36,pe);
if (pe->ExtraPredFlags & NoTracePredFlag) { if (pe->PredFlags & NoTracePredFlag) {
UNLOCKPE(57,pe); UNLOCKPE(57,pe);
return TRUE; return TRUE;
} }
@ -2886,7 +2886,7 @@ p_set_no_trace( USES_REGS1 )
if (EndOfPAEntr(pe)) if (EndOfPAEntr(pe))
return FALSE; return FALSE;
PELOCK(36,pe); PELOCK(36,pe);
pe->ExtraPredFlags |= NoTracePredFlag; pe->PredFlags |= NoTracePredFlag;
UNLOCKPE(57,pe); UNLOCKPE(57,pe);
return TRUE; return TRUE;
} }
@ -2904,7 +2904,7 @@ Yap_SetNoTrace(char *name, UInt arity, Term tmod)
if (EndOfPAEntr(pe)) if (EndOfPAEntr(pe))
return FALSE; return FALSE;
PELOCK(36,pe); PELOCK(36,pe);
pe->ExtraPredFlags |= NoTracePredFlag; pe->PredFlags |= NoTracePredFlag;
UNLOCKPE(57,pe); UNLOCKPE(57,pe);
return TRUE; return TRUE;
} }
@ -3164,7 +3164,7 @@ p_new_discontiguous( USES_REGS1 )
else else
pe = RepPredProp(PredPropByFunc(Yap_MkFunctor(at, arity),mod)); pe = RepPredProp(PredPropByFunc(Yap_MkFunctor(at, arity),mod));
PELOCK(26,pe); PELOCK(26,pe);
pe->ExtraPredFlags |= DiscontiguousPredFlag; pe->PredFlags |= DiscontiguousPredFlag;
/* mutifile-predicates are weird, they do not seat really on the default module */ /* mutifile-predicates are weird, they do not seat really on the default module */
if (pe->ModuleOfPred == PROLOG_MODULE) if (pe->ModuleOfPred == PROLOG_MODULE)
pe->ModuleOfPred = TermProlog; pe->ModuleOfPred = TermProlog;
@ -3183,7 +3183,7 @@ p_is_discontiguous( USES_REGS1 )
if (EndOfPAEntr(pe)) if (EndOfPAEntr(pe))
return FALSE; return FALSE;
PELOCK(27,pe); PELOCK(27,pe);
out = (pe->ExtraPredFlags & DiscontiguousPredFlag); out = (pe->PredFlags & DiscontiguousPredFlag);
UNLOCKPE(44,pe); UNLOCKPE(44,pe);
return(out); return(out);
} }

4
C/exec.c
View File

@ -1991,8 +1991,8 @@ Yap_InitExecFs(void)
#ifdef DEPTH_LIMIT #ifdef DEPTH_LIMIT
Yap_InitCPred("$execute_under_depth_limit", 2, p_execute_depth_limit, 0); Yap_InitCPred("$execute_under_depth_limit", 2, p_execute_depth_limit, 0);
#endif #endif
Yap_InitCPred("$execute0", 2, p_execute0, 0); Yap_InitCPred("$execute0", 2, p_execute0, NoTracePredFlag);
Yap_InitCPred("$execute_nonstop", 2, p_execute_nonstop, 0); Yap_InitCPred("$execute_nonstop", 2, p_execute_nonstop,NoTracePredFlag );
Yap_InitCPred("$execute_clause", 4, p_execute_clause, 0); Yap_InitCPred("$execute_clause", 4, p_execute_clause, 0);
Yap_InitCPred("$current_choice_point", 1, p_save_cp, 0); Yap_InitCPred("$current_choice_point", 1, p_save_cp, 0);
Yap_InitCPred("$current_choicepoint", 1, p_save_cp, 0); Yap_InitCPred("$current_choicepoint", 1, p_save_cp, 0);

192
C/modules.c
View File

@ -26,9 +26,9 @@ static char SccsId[] = "%W% %G%";
static Int p_current_module(USES_REGS1); static Int p_current_module(USES_REGS1);
static Int p_current_module1(USES_REGS1); static Int p_current_module1(USES_REGS1);
static ModEntry *LookupModule(Term a); static ModEntry *LookupModule(Term a);
static Term Yap_YapStripModule(Term t, Term *modp);
inline static ModEntry * inline static ModEntry *FetchModuleEntry(Atom at)
FetchModuleEntry(Atom at)
/* get predicate entry for ap/arity; create it if neccessary. */ /* get predicate entry for ap/arity; create it if neccessary. */
{ {
Prop p0; Prop p0;
@ -38,8 +38,7 @@ FetchModuleEntry(Atom at)
p0 = ae->PropsOfAE; p0 = ae->PropsOfAE;
while (p0) { while (p0) {
ModEntry *me = RepModProp(p0); ModEntry *me = RepModProp(p0);
if ( me->KindOfPE == ModProperty if (me->KindOfPE == ModProperty) {
) {
READ_UNLOCK(ae->ARWLock); READ_UNLOCK(ae->ARWLock);
return me; return me;
} }
@ -49,20 +48,17 @@ FetchModuleEntry(Atom at)
return NULL; return NULL;
} }
inline static ModEntry * inline static ModEntry *GetModuleEntry(Atom at)
GetModuleEntry(Atom at)
/* get predicate entry for ap/arity; create it if neccessary. */ /* get predicate entry for ap/arity; create it if neccessary. */
{ {
Prop p0; Prop p0;
AtomEntry *ae = RepAtom(at); AtomEntry *ae = RepAtom(at);
ModEntry *new; ModEntry *new;
p0 = ae->PropsOfAE; p0 = ae->PropsOfAE;
while (p0) { while (p0) {
ModEntry *me = RepModProp(p0); ModEntry *me = RepModProp(p0);
if ( me->KindOfPE == ModProperty if (me->KindOfPE == ModProperty) {
) {
return me; return me;
} }
p0 = me->NextOfPE; p0 = me->NextOfPE;
@ -85,20 +81,16 @@ GetModuleEntry(Atom at)
return new; return new;
} }
unsigned int unsigned int getUnknownModule(ModEntry *m) {
getUnknownModule(ModEntry * m) {
if (m && m->flags & UNKNOWN_MASK) if (m && m->flags & UNKNOWN_MASK)
return m->flags & UNKNOWN_MASK; return m->flags & UNKNOWN_MASK;
else { else {
return GetModuleEntry(AtomUser)->flags & UNKNOWN_MASK; return GetModuleEntry(AtomUser)->flags & UNKNOWN_MASK;
} }
} }
#define ByteAdr(X) ((char *)&(X)) #define ByteAdr(X) ((char *)&(X))
Term Term Yap_Module_Name(PredEntry *ap) {
Yap_Module_Name(PredEntry *ap)
{
CACHE_REGS CACHE_REGS
Term mod; Term mod;
if (!ap->ModuleOfPred) if (!ap->ModuleOfPred)
@ -113,59 +105,49 @@ Yap_Module_Name(PredEntry *ap)
else { else {
mod = ap->ModuleOfPred; mod = ap->ModuleOfPred;
} }
if (mod) return mod; if (mod)
return mod;
return TermProlog; return TermProlog;
} }
static ModEntry * static ModEntry *LookupModule(Term a) {
LookupModule(Term a )
{
Atom at; Atom at;
ModEntry *me; ModEntry *me;
/* prolog module */ /* prolog module */
if (a == 0) { if (a == 0) {
return GetModuleEntry(AtomUser); return GetModuleEntry(AtomProlog);
} }
at = AtomOfTerm(a); at = AtomOfTerm(a);
me = GetModuleEntry(at); me = GetModuleEntry(at);
return me; return me;
} }
Term Term Yap_Module(Term tmod) {
Yap_Module(Term tmod)
{
LookupModule(tmod); LookupModule(tmod);
return tmod; return tmod;
} }
ModEntry * ModEntry *Yap_GetModuleEntry(Term mod) {
Yap_GetModuleEntry(Term mod)
{
ModEntry *me; ModEntry *me;
if (!(me = LookupModule(mod))) if (!(me = LookupModule(mod)))
return NULL; return NULL;
return me; return me;
} }
Term Term Yap_GetModuleFromEntry(ModEntry *me) {
Yap_GetModuleFromEntry(ModEntry *me) return MkAtomTerm(me->AtomOfME);
{ ;
return MkAtomTerm(me->AtomOfME);;
} }
struct pred_entry * struct pred_entry *Yap_ModulePred(Term mod) {
Yap_ModulePred(Term mod)
{
ModEntry *me; ModEntry *me;
if (!(me = LookupModule(mod))) if (!(me = LookupModule(mod)))
return NULL; return NULL;
return me->PredForME; return me->PredForME;
} }
void void Yap_NewModulePred(Term mod, struct pred_entry *ap) {
Yap_NewModulePred(Term mod, struct pred_entry *ap)
{
ModEntry *me; ModEntry *me;
if (!(me = LookupModule(mod))) if (!(me = LookupModule(mod)))
@ -177,8 +159,7 @@ Yap_NewModulePred(Term mod, struct pred_entry *ap)
} }
static Int static Int
p_current_module( USES_REGS1 ) p_current_module(USES_REGS1) { /* $current_module(Old,New) */
{ /* $current_module(Old,New) */
Term t; Term t;
if (CurrentModule) { if (CurrentModule) {
@ -201,17 +182,14 @@ p_current_module( USES_REGS1 )
return TRUE; return TRUE;
} }
static Int static Int p_current_module1(USES_REGS1) { /* $current_module(Old)
p_current_module1( USES_REGS1 ) */
{ /* $current_module(Old) */
if (CurrentModule) if (CurrentModule)
return Yap_unify_constant(ARG1, CurrentModule); return Yap_unify_constant(ARG1, CurrentModule);
return Yap_unify_constant(ARG1, TermProlog); return Yap_unify_constant(ARG1, TermProlog);
} }
static Int static Int p_change_module(USES_REGS1) { /* $change_module(New) */
p_change_module( USES_REGS1 )
{ /* $change_module(New) */
Term mod = Deref(ARG1); Term mod = Deref(ARG1);
LookupModule(mod); LookupModule(mod);
CurrentModule = mod; CurrentModule = mod;
@ -219,10 +197,8 @@ p_change_module( USES_REGS1 )
return TRUE; return TRUE;
} }
static Int static Int cont_current_module(USES_REGS1) {
cont_current_module( USES_REGS1 ) ModEntry *imod = AddressOfTerm(EXTRA_CBACK_ARG(1, 1)), *next;
{
ModEntry *imod = (ModEntry *)IntegerOfTerm(EXTRA_CBACK_ARG(1,1)), *next;
Term t = MkAtomTerm(imod->AtomOfME); Term t = MkAtomTerm(imod->AtomOfME);
next = imod->NextME; next = imod->NextME;
@ -230,13 +206,12 @@ cont_current_module( USES_REGS1 )
Yap_unify(ARG1, t); Yap_unify(ARG1, t);
if (!next) if (!next)
cut_succeed(); cut_succeed();
EXTRA_CBACK_ARG(1,1) = MkIntegerTerm((Int)next); EXTRA_CBACK_ARG(1, 1) = MkAddressTerm(next);
return TRUE; return TRUE;
} }
static Int static Int init_current_module(
init_current_module( USES_REGS1 ) USES_REGS1) { /* current_module(?ModuleName) */
{ /* current_module(?ModuleName) */
Term t = Deref(ARG1); Term t = Deref(ARG1);
if (!IsVarTerm(t)) { if (!IsVarTerm(t)) {
if (!IsAtomTerm(t)) { if (!IsAtomTerm(t)) {
@ -251,9 +226,52 @@ init_current_module( USES_REGS1 )
return cont_current_module(PASS_REGS1); return cont_current_module(PASS_REGS1);
} }
static Int static Int cont_ground_module(USES_REGS1) {
p_strip_module( USES_REGS1 ) ModEntry *imod = AddressOfTerm(EXTRA_CBACK_ARG(3, 1)), *next;
{ Term t2 = MkAtomTerm(imod->AtomOfME);
next = imod->NextME;
/* ARG2 is unbound */
if (!next)
cut_succeed();
EXTRA_CBACK_ARG(3, 1) = MkAddressTerm(next);
return Yap_unify(ARG2, t2);
}
static Int init_ground_module(USES_REGS1) {
/* current_module(?ModuleName) */
Term t1 = Deref(ARG1), tmod = CurrentModule, t3;
if (tmod == PROLOG_MODULE) {
tmod = TermProlog;
}
t3 = Yap_YapStripModule(t1, &tmod);
if (!t3) {
Yap_Error(TYPE_ERROR_CALLABLE, t1, "trying to obtain module");
return FALSE;
}
if (!IsVarTerm(tmod)) {
if (!IsAtomTerm(tmod)) {
Yap_Error(TYPE_ERROR_ATOM, tmod, "module name must be an atom");
cut_fail();
}
if (FetchModuleEntry(AtomOfTerm(tmod)) != NULL && Yap_unify(tmod, ARG2) &&
Yap_unify(t3, ARG3)) {
cut_succeed();
}
cut_fail();
}
if (!Yap_unify(ARG2, tmod) ||
!Yap_unify(ARG3, t3) ) {
cut_fail();
}
// make sure we keep the binding
B->cp_tr = TR;
B->cp_h = HR;
EXTRA_CBACK_ARG(3, 1) = MkAddressTerm(CurrentModules);
return cont_ground_module(PASS_REGS1);
}
static Int p_strip_module(USES_REGS1) {
Term t1 = Deref(ARG1), tmod = CurrentModule; Term t1 = Deref(ARG1), tmod = CurrentModule;
if (tmod == PROLOG_MODULE) { if (tmod == PROLOG_MODULE) {
tmod = TermProlog; tmod = TermProlog;
@ -263,13 +281,10 @@ p_strip_module( USES_REGS1 )
Yap_Error(TYPE_ERROR_CALLABLE, t1, "trying to obtain module"); Yap_Error(TYPE_ERROR_CALLABLE, t1, "trying to obtain module");
return FALSE; return FALSE;
} }
return Yap_unify(ARG3, t1) && return Yap_unify(ARG3, t1) && Yap_unify(ARG2, tmod);
Yap_unify(ARG2, tmod);
} }
static Term static Term Yap_YapStripModule(Term t, Term *modp) {
Yap_YapStripModule(Term t, Term *modp)
{
CACHE_REGS CACHE_REGS
Term tmod; Term tmod;
@ -304,12 +319,7 @@ Yap_YapStripModule(Term t, Term *modp)
return 0L; return 0L;
} }
static Int p_yap_strip_module(USES_REGS1) {
static Int
p_yap_strip_module( USES_REGS1 )
{
Term t1 = Deref(ARG1), tmod = CurrentModule; Term t1 = Deref(ARG1), tmod = CurrentModule;
if (tmod == PROLOG_MODULE) { if (tmod == PROLOG_MODULE) {
tmod = TermProlog; tmod = TermProlog;
@ -319,25 +329,20 @@ p_yap_strip_module( USES_REGS1 )
Yap_Error(TYPE_ERROR_CALLABLE, t1, "trying to obtain module"); Yap_Error(TYPE_ERROR_CALLABLE, t1, "trying to obtain module");
return FALSE; return FALSE;
} }
return Yap_unify(ARG3, t1) && return Yap_unify(ARG3, t1) && Yap_unify(ARG2, tmod);
Yap_unify(ARG2, tmod);
} }
static Int static Int p_context_module(USES_REGS1) {
p_context_module( USES_REGS1 )
{
yamop *parentcp = P; yamop *parentcp = P;
CELL *yenv; CELL *yenv;
PredEntry *ap = EnvPreg(parentcp); PredEntry *ap = EnvPreg(parentcp);
if (ap->ModuleOfPred && if (ap->ModuleOfPred && !(ap->PredFlags & MetaPredFlag))
!(ap->PredFlags & MetaPredFlag))
return Yap_unify(ARG1, ap->ModuleOfPred); return Yap_unify(ARG1, ap->ModuleOfPred);
parentcp = CP; parentcp = CP;
yenv = ENV; yenv = ENV;
do { do {
ap = EnvPreg(parentcp); ap = EnvPreg(parentcp);
if (ap->ModuleOfPred && if (ap->ModuleOfPred && !(ap->PredFlags & MetaPredFlag))
!(ap->PredFlags & MetaPredFlag))
return Yap_unify(ARG1, ap->ModuleOfPred); return Yap_unify(ARG1, ap->ModuleOfPred);
parentcp = (yamop *)yenv[E_CP]; parentcp = (yamop *)yenv[E_CP];
yenv = (CELL *)yenv[E_E]; yenv = (CELL *)yenv[E_E];
@ -345,9 +350,7 @@ p_context_module( USES_REGS1 )
return Yap_unify(ARG1, CurrentModule); return Yap_unify(ARG1, CurrentModule);
} }
Term Term Yap_StripModule(Term t, Term *modp) {
Yap_StripModule(Term t, Term *modp)
{
CACHE_REGS CACHE_REGS
Term tmod; Term tmod;
@ -386,25 +389,26 @@ Yap_StripModule(Term t, Term *modp)
return 0L; return 0L;
} }
void Yap_InitModulesC(void) {
Yap_InitCPred("$current_module", 2, p_current_module,
void
Yap_InitModulesC(void)
{
Yap_InitCPred("$current_module", 2, p_current_module, SafePredFlag|SyncPredFlag);
Yap_InitCPred("$current_module", 1, p_current_module1, SafePredFlag|SyncPredFlag);
Yap_InitCPred("$change_module", 1, p_change_module, SafePredFlag|SyncPredFlag);
Yap_InitCPred("strip_module", 3, p_strip_module, SafePredFlag|SyncPredFlag);
Yap_InitCPred("$yap_strip_module", 3, p_yap_strip_module, SafePredFlag|SyncPredFlag);
Yap_InitCPred("context_module", 1, p_context_module, 0);
Yap_InitCPredBack("$all_current_modules", 1, 1, init_current_module, cont_current_module,
SafePredFlag | SyncPredFlag); SafePredFlag | SyncPredFlag);
Yap_InitCPred("$current_module", 1, p_current_module1,
SafePredFlag | SyncPredFlag);
Yap_InitCPred("$change_module", 1, p_change_module,
SafePredFlag | SyncPredFlag);
Yap_InitCPred("strip_module", 3, p_strip_module, SafePredFlag | SyncPredFlag);
Yap_InitCPred("$yap_strip_module", 3, p_yap_strip_module,
SafePredFlag | SyncPredFlag);
Yap_InitCPred("context_module", 1, p_context_module, 0);
Yap_InitCPredBack("$all_current_modules", 1, 1, init_current_module,
cont_current_module, SafePredFlag | SyncPredFlag);
Yap_InitCPredBack("$all_current_modules", 1, 1, init_current_module,
cont_current_module, SafePredFlag | SyncPredFlag);
Yap_InitCPredBack("$ground_module", 3, 1, init_ground_module,
cont_ground_module, SafePredFlag | SyncPredFlag);
} }
void Yap_InitModules(void) {
void
Yap_InitModules(void)
{
CACHE_REGS CACHE_REGS
LookupModule(MkAtomTerm(AtomProlog)); LookupModule(MkAtomTerm(AtomProlog));
LOCAL_SourceModule = MkAtomTerm(AtomProlog); LOCAL_SourceModule = MkAtomTerm(AtomProlog);

798
C/stdpreds.c
View File

File diff suppressed because it is too large Load Diff

9
C/sysbits.c
View File

@ -205,7 +205,7 @@ Yap_dir_separator (int ch)
return dir_separator (ch); return dir_separator (ch);
} }
#if _MSC_VER || defined(__MINGW32__) #if __WINDOWS__
#include <psapi.h> #include <psapi.h>
char *libdir = NULL; char *libdir = NULL;
@ -217,9 +217,8 @@ initSysPath(Term tlib, Term tcommons) {
int len; int len;
int dir_done = FALSE; int dir_done = FALSE;
int commons_done = FALSE; int commons_done = FALSE;
Int rcl, rcc;
#if _MSC_VER || defined(__MINGW32__) || defined(__MSYS__) #if __WINDOWS__
{ {
char *dir; char *dir;
if ((dir = Yap_RegistryGetString("library")) && if ((dir = Yap_RegistryGetString("library")) &&
@ -236,7 +235,7 @@ initSysPath(Term tlib, Term tcommons) {
} }
} }
if (dir_done && commons_done) if (dir_done && commons_done)
return rcl && rcc; return TRUE;
#endif #endif
strncpy(LOCAL_FileNameBuf, YAP_SHAREDIR, YAP_FILENAME_MAX); strncpy(LOCAL_FileNameBuf, YAP_SHAREDIR, YAP_FILENAME_MAX);
strncat(LOCAL_FileNameBuf,"/", YAP_FILENAME_MAX); strncat(LOCAL_FileNameBuf,"/", YAP_FILENAME_MAX);
@ -260,7 +259,7 @@ initSysPath(Term tlib, Term tcommons) {
} }
} }
if (dir_done && commons_done) if (dir_done && commons_done)
return rcl && rcc; return TRUE;
#if __WINDOWS__ #if __WINDOWS__
{ {

401
C/threads.c
View File

@ -356,6 +356,8 @@ kill_thread_engine (int wid, int always_die)
} }
if (REMOTE_ScratchPad(wid).ptr) if (REMOTE_ScratchPad(wid).ptr)
free(REMOTE_ScratchPad(wid).ptr); free(REMOTE_ScratchPad(wid).ptr);
// if (REMOTE_TmpPred(wid).ptr)
// free(REMOTE_TmpPred(wid).ptr);
REMOTE_PL_local_data_p(wid)->reg_cache = REMOTE_PL_local_data_p(wid)->reg_cache =
REMOTE_ThreadHandle(wid).current_yaam_regs = NULL; REMOTE_ThreadHandle(wid).current_yaam_regs = NULL;
if (REMOTE_ThreadHandle(wid).start_of_timesp) if (REMOTE_ThreadHandle(wid).start_of_timesp)
@ -878,6 +880,18 @@ typedef struct swi_mutex {
pthread_mutex_t m; pthread_mutex_t m;
} SWIMutex; } SWIMutex;
static SWIMutex *MutexOfTerm(Term t)
{
Term t1 = Deref(t);
SWIMutex *mut = NULL;
if (IsVarTerm(t1)) {
} else if (IsAtomTerm(t1)) {
} else {
mut = AddressOfTerm(t1);
}
return mut;
}
static Int static Int
p_new_mutex( USES_REGS1 ) p_new_mutex( USES_REGS1 )
{ {
@ -1111,6 +1125,244 @@ p_mbox_create( USES_REGS1 )
mboxp = mboxp->next; mboxp = mboxp->next;
if (mboxp) { if (mboxp) {
UNLOCK(GLOBAL_mboxq_lock); UNLOCK(GLOBAL_mboxq_lock);
=======
return Yap_unify(ARG1, MkAddressTerm(mutp));
}
static Int
p_destroy_mutex( USES_REGS1 )
{
Term t1 = Deref(ARG1);
SWIMutex *mut;
if (IsVarTerm(t1)) {
} else if (IsAtomTerm(t1)) {
} else {
mut = AddressOfTerm(Deref(ARG1));
if (pthread_mutex_destroy(&mut->m) < 0)
return FALSE;
Yap_FreeCodeSpace((void *)mut);
}
return TRUE;
}
static Int
p_lock_mutex( USES_REGS1 )
{
SWIMutex *mut = MutexOfTerm( ARG1 );
#if DEBUG_LOCKS
MUTEX_LOCK(&mut->m);
#else
if (MUTEX_LOCK(&mut->m) < 0)
return FALSE;
#endif
mut->owners++;
mut->tid_own = worker_id;
return TRUE;
}
static Int
p_trylock_mutex( USES_REGS1 )
{
SWIMutex *mut = MutexOfTerm( ARG1 );
if (MUTEX_TRYLOCK(&mut->m) == EBUSY)
return FALSE;
mut->owners++;
mut->tid_own = worker_id;
return TRUE;
}
static Int
p_unlock_mutex( USES_REGS1 )
{
SWIMutex *mut = MutexOfTerm( ARG1 );
#if DEBUG_LOCKS
MUTEX_UNLOCK(&mut->m);
#else
if (MUTEX_UNLOCK(&mut->m) < 0)
return FALSE;
#endif
mut->owners--;
return TRUE;
}
static Int
p_with_mutex( USES_REGS1 )
{
SWIMutex *mut;
Term t1 = Deref(ARG1), excep;
Int rc = FALSE;
Int creeping = Yap_get_signal(YAP_CREEP_SIGNAL);
PredEntry *pe;
Term tm = CurrentModule;
Term tg = Deref(ARG2);
if (IsVarTerm(t1)) {
p_new_mutex( PASS_REGS1 );
t1 = Deref(ARG1);
}
if (IsAtomTerm(t1)) {
} else {
mut = AddressOfTerm(Deref(ARG1));
if (FALSE && !p_lock_mutex( PASS_REGS1 )) {
return FALSE;
}
}
tg = Yap_StripModule(tg, &tm);
if (IsVarTerm(tg)) {
Yap_Error(INSTANTIATION_ERROR, ARG2, "with_mutex/2");
goto end;
} else if (IsApplTerm(tg)) {
register Functor f = FunctorOfTerm(tg);
register CELL *pt;
size_t i, arity;
f = FunctorOfTerm(tg);
if (IsExtensionFunctor(f)) {
Yap_Error(TYPE_ERROR_CALLABLE, tg, "with_mutex/2");
goto end;
}
arity = ArityOfFunctor(f);
if (arity > MaxTemps) {
Yap_Error(TYPE_ERROR_CALLABLE, tg, "with_mutex/2");
goto end;
}
pe = RepPredProp(PredPropByFunc(f, tm));
pt = RepAppl(tg)+1;
for (i= 0; i < arity; i++ )
XREGS[i+1] = pt[i];
} else if (IsAtomTerm(tg)) {
pe = RepPredProp(PredPropByAtom(AtomOfTerm(tg), tm));
} else if (IsPairTerm(tg)) {
register CELL *pt;
Functor f;
f = FunctorDot;
pe = RepPredProp(PredPropByFunc(f, tm));
pt = RepPair(tg);
XREGS[1] = pt[0];
XREGS[2] = pt[1];
} else {
Yap_Error(TYPE_ERROR_CALLABLE, tg, "with_mutex/2");
goto end;
}
if (
pe->OpcodeOfPred != FAIL_OPCODE &&
Yap_execute_pred(pe, NULL PASS_REGS) ) {
rc = TRUE;
}
end:
ARG1 = MkIntegerTerm((Int)mut);
excep = Yap_GetException();
if (FALSE) p_unlock_mutex( PASS_REGS1 );
if (creeping) {
Yap_signal( YAP_CREEP_SIGNAL );
} else if ( excep != 0) {
return Yap_JumpToEnv(excep);
}
return rc;
}
static Int
p_with_with_mutex( USES_REGS1 )
{
if (GLOBAL_WithMutex == NULL) {
p_new_mutex( PASS_REGS1 );
GLOBAL_WithMutex = (SWIMutex*)IntegerOfTerm(Deref(ARG1));
} else {
ARG1 = MkIntegerTerm((Int)GLOBAL_WithMutex);
}
return p_lock_mutex( PASS_REGS1 );
}
static Int
p_unlock_with_mutex( USES_REGS1 )
{
ARG1 = MkIntegerTerm((Int)GLOBAL_WithMutex);
return p_unlock_mutex( PASS_REGS1 );
}
static Int
p_mutex_info( USES_REGS1 )
{
SWIMutex *mut = (SWIMutex*)IntegerOfTerm(Deref(ARG1));
return Yap_unify(ARG2, MkIntegerTerm(mut->owners)) &&
Yap_unify(ARG3, MkIntegerTerm(mut->tid_own));
return TRUE;
}
static Int
p_cond_create( USES_REGS1 )
{
pthread_cond_t* condp;
condp = (pthread_cond_t *)Yap_AllocCodeSpace(sizeof(pthread_cond_t));
if (condp == NULL) {
return FALSE;
}
pthread_cond_init(condp, NULL);
return Yap_unify(ARG1, MkIntegerTerm((Int)condp));
}
typedef struct {
UInt indx;
mbox_t mbox;
} counted_mbox;
static Int
p_mbox_create( USES_REGS1 )
{
Term namet = Deref(ARG1);
mbox_t* mboxp = GLOBAL_named_mboxes;
if (IsVarTerm(namet)) {
AtomEntry *ae;
int new;
mbox_t mbox;
ae = Yap_lookupBlob(&mbox, sizeof(mbox), &PL_Message_Queue, &new);
namet = MkAtomTerm(RepAtom(ae));
mboxp = (mbox_t *)(ae->rep.blob[0].data);
Yap_unify(ARG1, namet);
LOCK(GLOBAL_mboxq_lock);
} else if (IsAtomTerm(namet)) {
LOCK(GLOBAL_mboxq_lock);
while( mboxp && mboxp->name != namet)
mboxp = mboxp->next;
if (mboxp) {
UNLOCK(GLOBAL_mboxq_lock);
return FALSE;
}
mboxp = (mbox_t *)Yap_AllocCodeSpace(sizeof(mbox_t));
if (mboxp == NULL) {
UNLOCK(GLOBAL_mboxq_lock);
return FALSE;
}
// global mbox, for now we'll just insert in list
mboxp->next = GLOBAL_named_mboxes;
GLOBAL_named_mboxes = mboxp;
}
bool rc = mboxCreate( namet, mboxp PASS_REGS );
UNLOCK(GLOBAL_mboxq_lock);
return rc;
}
static Int
p_mbox_destroy( USES_REGS1 )
{
Term namet = Deref(ARG1);
mbox_t* mboxp = GLOBAL_named_mboxes, *prevp;
if (IsVarTerm(namet) )
return FALSE; return FALSE;
} }
mboxp = (mbox_t *)Yap_AllocCodeSpace(sizeof(mbox_t)); mboxp = (mbox_t *)Yap_AllocCodeSpace(sizeof(mbox_t));
@ -1156,6 +1408,155 @@ p_mbox_destroy( USES_REGS1 )
UNLOCK(GLOBAL_mboxq_lock); UNLOCK(GLOBAL_mboxq_lock);
mboxDestroy(mboxp PASS_REGS); mboxDestroy(mboxp PASS_REGS);
Yap_FreeCodeSpace( (char *)mboxp ); Yap_FreeCodeSpace( (char *)mboxp );
=======
}
LOCK(GLOBAL_mboxq_lock);
prevp = NULL;
while( mboxp && mboxp->name != namet) {
prevp = mboxp;
mboxp = mboxp->next;
}
if (!mboxp) {
UNLOCK(GLOBAL_mboxq_lock);
return FALSE;
}
if (mboxp == GLOBAL_named_mboxes) {
GLOBAL_named_mboxes = mboxp->next;
} else {
prevp->next = mboxp->next;
}
UNLOCK(GLOBAL_mboxq_lock);
mboxDestroy(mboxp PASS_REGS);
Yap_FreeCodeSpace( (char *)mboxp );
return TRUE;
}
static mbox_t*
getMbox(Term t)
{
mbox_t* mboxp;
if (IsAtomTerm(t=Deref(t))) {
Atom at = AtomOfTerm(t);
LOCK(GLOBAL_mboxq_lock);
if (IsBlob(at)) {
mboxp = (mbox_t *)(RepAtom(at)->rep.blob[0].data);
} else {
mboxp = GLOBAL_named_mboxes;
while( mboxp && mboxp->name != t) {
mboxp = mboxp->next;
}
}
if (!mboxp->open)
mboxp = NULL;
if (mboxp) {
pthread_mutex_lock(& mboxp->mutex);
}
UNLOCK(GLOBAL_mboxq_lock);
} else if (IsIntTerm(t)) {
int wid = IntOfTerm(t);
if (REMOTE(wid) &&
(REMOTE_ThreadHandle(wid).in_use || REMOTE_ThreadHandle(wid).zombie))
{
return &REMOTE_ThreadHandle(wid).mbox_handle;
} else {
return NULL;
}
if (!mboxp->open)
mboxp = NULL;
if (mboxp) {
pthread_mutex_lock(& mboxp->mutex);
}
} else {
return NULL;
}
return mboxp;
}
static Int
p_mbox_send( USES_REGS1 )
{
Term namet = Deref(ARG1);
mbox_t* mboxp = getMbox(namet) ;
if (!mboxp)
return FALSE;
return mboxSend(mboxp, Deref(ARG2) PASS_REGS);
}
static Int
p_mbox_size( USES_REGS1 )
{
Term namet = Deref(ARG1);
mbox_t* mboxp = getMbox(namet) ;
if (!mboxp)
return FALSE;
return Yap_unify( ARG2, MkIntTerm(mboxp->nmsgs));
}
static Int
p_mbox_receive( USES_REGS1 )
{
Term namet = Deref(ARG1);
mbox_t* mboxp = getMbox(namet) ;
if (!mboxp)
return FALSE;
return mboxReceive(mboxp, Deref(ARG2) PASS_REGS);
}
static Int
p_mbox_peek( USES_REGS1 )
{
Term namet = Deref(ARG1);
mbox_t* mboxp = getMbox(namet) ;
if (!mboxp)
return FALSE;
return mboxPeek(mboxp, Deref(ARG2) PASS_REGS);
}
static Int
p_cond_destroy( USES_REGS1 )
{
pthread_cond_t *condp = (pthread_cond_t *)IntegerOfTerm(Deref(ARG1));
if (pthread_cond_destroy(condp) < 0)
return FALSE;
Yap_FreeCodeSpace((void *)condp);
return TRUE;
}
static Int
p_cond_signal( USES_REGS1 )
{
pthread_cond_t *condp = (pthread_cond_t *)IntegerOfTerm(Deref(ARG1));
if (pthread_cond_signal(condp) < 0)
return FALSE;
return TRUE;
}
static Int
p_cond_broadcast( USES_REGS1 )
{
pthread_cond_t *condp = (pthread_cond_t *)IntegerOfTerm(Deref(ARG1));
if (pthread_cond_broadcast(condp) < 0)
return FALSE;
return TRUE;
}
static Int
p_cond_wait( USES_REGS1 )
{
pthread_cond_t *condp = (pthread_cond_t *)IntegerOfTerm(Deref(ARG1));
SWIMutex *mut = (SWIMutex*)IntegerOfTerm(Deref(ARG2));
pthread_cond_wait(condp, &mut->m);
return TRUE; return TRUE;
} }

28
H/YapTags.h
View File

@ -394,6 +394,34 @@ IntegerOfTerm (Term t)
return (Int) (IsIntTerm (t) ? IntOfTerm (t) : LongIntOfTerm (t)); return (Int) (IsIntTerm (t) ? IntOfTerm (t) : LongIntOfTerm (t));
} }
#define MkAddressTerm(i) __MkAddressTerm(i PASS_REGS)
INLINE_ONLY inline EXTERN Term __MkAddressTerm (void * USES_REGS);
INLINE_ONLY inline EXTERN Term
__MkAddressTerm (void * n USES_REGS)
{
return __MkIntegerTerm((Int)n PASS_REGS);
}
INLINE_ONLY inline EXTERN bool IsAddressTerm (Term);
INLINE_ONLY inline EXTERN bool
IsAddressTerm (Term t)
{
return (bool) IsIntegerTerm (t);
}
INLINE_ONLY inline EXTERN void * AddressOfTerm (Term);
INLINE_ONLY inline EXTERN void *
AddressOfTerm (Term t)
{
return (void *) (IsIntTerm (t) ? IntOfTerm (t) : LongIntOfTerm (t));
}
#ifndef YAP_H #ifndef YAP_H
#endif #endif

90
H/Yatom.h
View File

@ -403,6 +403,7 @@ AbsModProp (ModEntry * p)
return (Prop) (p); return (Prop) (p);
} }
#define ModToTerm(m) (m == PROLOG_MODULE ? TermProlog : m )
#endif #endif
@ -651,55 +652,55 @@ IsValProperty (int flags)
C_Preds are things write, read, ... implemented in C. In this case C_Preds are things write, read, ... implemented in C. In this case
CodeOfPred holds the address of the correspondent C-function. CodeOfPred holds the address of the correspondent C-function.
don;t forget to also add in qly.h don't forget to also add in qly.h
*/ */
typedef enum typedef enum
{ {
DiscontiguousPredFlag = ((UInt)0x00000010 << EXTRA_FLAG_BASE), /* predicates whose clauses may be all-over the place.. */ DiscontiguousPredFlag = ((uint64_t)((uint64_t)0x1000000000)), /* predicates whose clauses may be all-over the place.. */
SysExportPredFlag = ((UInt)0x00000008 << EXTRA_FLAG_BASE), /* reuse export list to prolog module. */ SysExportPredFlag = ((uint64_t)0x800000000), /* reuse export list to prolog module. */
NoTracePredFlag = ((UInt)0x00000004 << EXTRA_FLAG_BASE), /* cannot trace this predicate */ NoTracePredFlag = ((uint64_t)0x400000000), /* cannot trace this predicate */
NoSpyPredFlag = ((UInt)0x00000002 << EXTRA_FLAG_BASE), /* cannot spy this predicate */ NoSpyPredFlag = ((uint64_t)0x200000000), /* cannot spy this predicate */
QuasiQuotationPredFlag = ((UInt)0x00000001 << EXTRA_FLAG_BASE), /* SWI-like quasi quotations */ QuasiQuotationPredFlag = ((uint64_t)0x100000000), /* SWI-like quasi quotations */
MegaClausePredFlag = (UInt)0x80000000, /* predicate is implemented as a mega-clause */ MegaClausePredFlag = (uint64_t)0x80000000, /* predicate is implemented as a mega-clause */
ThreadLocalPredFlag = (UInt)0x40000000, /* local to a thread */ ThreadLocalPredFlag = (uint64_t)0x40000000, /* local to a thread */
MultiFileFlag = (UInt)0x20000000, /* is multi-file */ MultiFileFlag = (uint64_t)0x20000000, /* is multi-file */
UserCPredFlag = (UInt)0x10000000, /* CPred defined by the user */ UserCPredFlag = (uint64_t)0x10000000, /* CPred defined by the user */
LogUpdatePredFlag = (UInt)0x08000000, /* dynamic predicate with log. upd. sem. */ LogUpdatePredFlag = (uint64_t)0x08000000, /* dynamic predicate with log. upd. sem. */
InUsePredFlag = (UInt)0x04000000, /* count calls to pred */ InUsePredFlag = (uint64_t)0x04000000, /* count calls to pred */
CountPredFlag = (UInt)0x02000000, /* count calls to pred */ CountPredFlag = (uint64_t)0x02000000, /* count calls to pred */
HiddenPredFlag = (UInt)0x01000000, /* invisible predicate */ HiddenPredFlag = (uint64_t)0x01000000, /* invisible predicate */
CArgsPredFlag = (UInt)0x00800000, /* SWI-like C-interface pred. */ CArgsPredFlag = (uint64_t)0x00800000, /* SWI-like C-interface pred. */
SourcePredFlag = (UInt)0x00400000, /* static predicate with source declaration */ SourcePredFlag = (uint64_t)0x00400000, /* static predicate with source declaration */
MetaPredFlag = (UInt)0x00200000, /* predicate subject to a meta declaration */ MetaPredFlag = (uint64_t)0x00200000, /* predicate subject to a meta declaration */
SyncPredFlag = (UInt)0x00100000, /* has to synch before it can execute */ SyncPredFlag = (uint64_t)0x00100000, /* has to synch before it can execute */
NumberDBPredFlag = (UInt)0x00080000, /* entry for a number key */ NumberDBPredFlag = (uint64_t)0x00080000, /* entry for a number key */
AtomDBPredFlag = (UInt)0x00040000, /* entry for an atom key */ AtomDBPredFlag = (uint64_t)0x00040000, /* entry for an atom key */
GoalExPredFlag = (UInt)0x00020000, /* predicate that is called by goal_expand */ GoalExPredFlag = (uint64_t)0x00020000, /* predicate that is called by goal_expand */
TestPredFlag = (UInt)0x00010000, /* is a test (optim. comit) */ TestPredFlag = (uint64_t)0x00010000, /* is a test (optim. comit) */
AsmPredFlag = (UInt)0x00008000, /* inline */ AsmPredFlag = (uint64_t)0x00008000, /* inline */
StandardPredFlag = (UInt)0x00004000, /* system predicate */ StandardPredFlag = (uint64_t)0x00004000, /* system predicate */
DynamicPredFlag = (UInt)0x00002000, /* dynamic predicate */ DynamicPredFlag = (uint64_t)0x00002000, /* dynamic predicate */
CPredFlag = (UInt)0x00001000, /* written in C */ CPredFlag = (uint64_t)0x00001000, /* written in C */
SafePredFlag = (UInt)0x00000800, /* does not alter arguments */ SafePredFlag = (uint64_t)0x00000800, /* does not alter arguments */
CompiledPredFlag = (UInt)0x00000400, /* is static */ CompiledPredFlag = (uint64_t)0x00000400, /* is static */
IndexedPredFlag = (UInt)0x00000200, /* has indexing code */ IndexedPredFlag = (uint64_t)0x00000200, /* has indexing code */
SpiedPredFlag = (UInt)0x00000100, /* is a spy point */ SpiedPredFlag = (uint64_t)0x00000100, /* is a spy point */
BinaryPredFlag = (UInt)0x00000080, /* test predicate */ BinaryPredFlag = (uint64_t)0x00000080, /* test predicate */
TabledPredFlag = (UInt)0x00000040, /* is tabled */ TabledPredFlag = (uint64_t)0x00000040, /* is tabled */
SequentialPredFlag = (UInt)0x00000020, /* may not create parallel choice points! */ SequentialPredFlag = (uint64_t)0x00000020, /* may not create parallel choice points! */
ProfiledPredFlag = (UInt)0x00000010, /* pred is being profiled */ ProfiledPredFlag = (uint64_t)0x00000010, /* pred is being profiled */
BackCPredFlag = (UInt)0x00000008, /* Myddas Imported pred */ BackCPredFlag = (uint64_t)0x00000008, /* Myddas Imported pred */
ModuleTransparentPredFlag = (UInt)0x00000004, /* ModuleTransparent pred */ ModuleTransparentPredFlag = (uint64_t)0x00000004, /* ModuleTransparent pred */
SWIEnvPredFlag = (UInt)0x00000002, /* new SWI interface */ SWIEnvPredFlag = (uint64_t)0x00000002, /* new SWI interface */
UDIPredFlag = (UInt)0x00000001 /* User Defined Indexing */ UDIPredFlag = (uint64_t)0x00000001 /* User Defined Indexing */
} pred_flag; } pred_flag;
/* profile data */ /* profile data */
typedef struct typedef struct
{ {
YAP_ULONG_LONG NOfEntries; /* nbr of times head unification succeeded */ uint64_t NOfEntries; /* nbr of times head unification succeeded */
YAP_ULONG_LONG NOfHeadSuccesses; /* nbr of times head unification succeeded */ uint64_t NOfHeadSuccesses; /* nbr of times head unification succeeded */
YAP_ULONG_LONG NOfRetries; /* nbr of times a clause for the pred uint64_t NOfRetries; /* nbr of times a clause for the pred
was retried */ was retried */
#if defined(YAPOR) || defined(THREADS) #if defined(YAPOR) || defined(THREADS)
lockvar lock; /* a simple lock to protect this entry */ lockvar lock; /* a simple lock to protect this entry */
@ -721,12 +722,7 @@ typedef struct pred_entry
PropFlags KindOfPE; /* kind of property */ PropFlags KindOfPE; /* kind of property */
struct yami *CodeOfPred; struct yami *CodeOfPred;
OPCODE OpcodeOfPred; /* undefcode, indexcode, spycode, .... */ OPCODE OpcodeOfPred; /* undefcode, indexcode, spycode, .... */
#if SIZEOF_INT_P==4 uint64_t PredFlags;
CELL PredFlags, ExtraPredFlags;
#else
CELL PredFlags;
#define ExtraPredFlags PredFlags
#endif
UInt ArityOfPE; /* arity of property */ UInt ArityOfPE; /* arity of property */
union union
{ {

68
library/lineutils.yap
View File

@ -4,6 +4,9 @@
search_for/3, search_for/3,
scan_natural/3, scan_natural/3,
scan_integer/3, scan_integer/3,
natural/3,
integer/3,
blank/3,
split/2, split/2,
split/3, split/3,
fields/2, fields/2,
@ -66,6 +69,19 @@ scan_integer(N) -->
scan_integer(N) --> scan_integer(N) -->
scan_natural(0, N). scan_natural(0, N).
/** @pred integer(? _Int_,+ _Line_,+ _RestOfLine_)
Scan the list of codes _Line_ for an integer _Nat_, either a
positive, zero, or negative integer, and unify _RestOfLine_ with
the remainder of the line.
*/
integer(N) -->
"-", !,
natural(0, N0),
N is -N0.
integer(N) -->
natural(0, N).
/** @pred scan_natural(? _Nat_,+ _Line_,+ _RestOfLine_) /** @pred scan_natural(? _Nat_,+ _Line_,+ _RestOfLine_)
Scan the list of codes _Line_ for a natural number _Nat_, zero Scan the list of codes _Line_ for a natural number _Nat_, zero
@ -82,6 +98,49 @@ scan_natural(N0,N) -->
get_natural(N1,N). get_natural(N1,N).
scan_natural(N,N) --> []. scan_natural(N,N) --> [].
/** @pred natural(? _Nat_,+ _Line_,+ _RestOfLine_)
Scan the list of codes _Line_ for a natural number _Nat_, zero
or a positive integer, and unify _RestOfLine_ with the remainder
of the line.
*/
natural(N) -->
natural(0, N).
natural(N0,N) -->
[C],
{C >= 0'0, C =< 0'9 }, !,
{ N1 is N0*10+(C-0'0) }, %'
get_natural(N1,N).
natural(N,N) --> [].
/** @pred skip_whitespace(+ _Line_,+ _RestOfLine_)
Scan the list of codes _Line_ for white space, namely for tabbing and space characters.
*/
skip_whitespace([0' |Blanks]) -->
" ",
skip_whitespace( Blanks ).
skip_whitespace([0' |Blanks]) -->
" ",
skip_whitespace( Blanks ).
skip_whitespace( [] ) -->
!.
/** @pred blank(+ _Line_,+ _RestOfLine_)
The list of codes _Line_ is formed by white space, namely by tabbing and space characters.
*/
blank([0' |Blanks]) -->
" ",
blank( Blanks ).
blank([0' |Blanks]) -->
" ",
blank( Blanks ).
blank( [] ) -->
[].
/** @pred split(+ _Line_,- _Split_) /** @pred split(+ _Line_,- _Split_)
Unify _Words_ with a set of strings obtained from _Line_ by Unify _Words_ with a set of strings obtained from _Line_ by
@ -243,9 +302,12 @@ process(StreamInp, Command) :-
For every line _LineIn_ in file _FileIn_, execute For every line _LineIn_ in file _FileIn_, execute
`call(Goal,LineIn,LineOut)`, and output _LineOut_ to file `call(Goal,LineIn,LineOut)`, and output _LineOut_ to file
_FileOut_. _FileOut_.
The input stream is accessible through the alias `filter_input`, and the output
stream is accessible through `filter_output`.
*/ */
file_filter(Inp, Out, Command) :- file_filter(Inp, Out, Command) :-
open(Inp, read, StreamInp), open(Inp, read, StreamInp, [alias(filter_input)]),
open(Out, write, StreamOut), open(Out, write, StreamOut),
filter(StreamInp, StreamOut, Command), filter(StreamInp, StreamOut, Command),
close(StreamInp), close(StreamInp),
@ -258,8 +320,8 @@ Same as file_filter/3, but before starting the filter execute
_Arguments_. _Arguments_.
*/ */
file_filter_with_initialization(Inp, Out, Command, FormatString, Parameters) :- file_filter_with_initialization(Inp, Out, Command, FormatString, Parameters) :-
open(Inp, read, StreamInp), open(Inp, read, StreamInp, [alias(filter_input)]),
open(Out, write, StreamOut), open(Out, write, StreamOut, [alias(filter_output)]),
format(StreamOut, FormatString, Parameters), format(StreamOut, FormatString, Parameters),
filter(StreamInp, StreamOut, Command), filter(StreamInp, StreamOut, Command),
close(StreamInp), close(StreamInp),

6
library/tries/base_dbtries.c
View File

@ -238,9 +238,11 @@ YAP_Term trie_depth_breadth(TrEntry trie, TrEntry db_trie, YAP_Int opt_level, YA
set_depth_breadth_reduction_current_data(NULL); set_depth_breadth_reduction_current_data(NULL);
/* We only need to simplify the trie once! */ /* We only need to simplify the trie once! */
/* This can be a 10% overhead for sld cases :-( */ /* This can be a 10% overhead for sld cases :-( */
// printf("simplification\n"); trie_print(trie);
if (TrNode_child(TrEntry_trie(trie))) if (TrNode_child(TrEntry_trie(trie)))
simplification_reduction(trie); simplification_reduction(trie);
while (TrNode_child(TrEntry_trie(trie))) { while (TrNode_child(TrEntry_trie(trie))) {
// printf("depth\n"); trie_print(trie);
nested_trie = depth_reduction(trie, depth_node, opt_level); nested_trie = depth_reduction(trie, depth_node, opt_level);
if (nested_trie) { if (nested_trie) {
set_depth_breadth_reduction_current_data(get_data_from_trie_node(nested_trie)); set_depth_breadth_reduction_current_data(get_data_from_trie_node(nested_trie));
@ -248,6 +250,7 @@ YAP_Term trie_depth_breadth(TrEntry trie, TrEntry db_trie, YAP_Int opt_level, YA
*end_counter = core_get_label_counter(); *end_counter = core_get_label_counter();
return YAP_MkApplTerm((YAP_Functor)(~ApplTag & TrNode_entry(TrNode_parent(nested_trie))), 1, &TrNode_entry(nested_trie)); return YAP_MkApplTerm((YAP_Functor)(~ApplTag & TrNode_entry(TrNode_parent(nested_trie))), 1, &TrNode_entry(nested_trie));
} }
// printf("breadth\n"); trie_print(trie);
nested_trie = breadth_reduction(trie, breadth_node, opt_level); nested_trie = breadth_reduction(trie, breadth_node, opt_level);
if (nested_trie) { if (nested_trie) {
set_depth_breadth_reduction_current_data(get_data_from_trie_node(nested_trie)); set_depth_breadth_reduction_current_data(get_data_from_trie_node(nested_trie));
@ -276,7 +279,8 @@ TrData trie_get_depth_breadth_reduction_current_data(void) {
void trie_replace_nested_trie(TrEntry trie, YAP_Int nested_trie_id, YAP_Term new_term) { void trie_replace_nested_trie(TrEntry trie, YAP_Int nested_trie_id, YAP_Term new_term) {
core_depth_breadth_trie_replace_nested_trie(TrNode_child(TrEntry_trie(trie)), nested_trie_id, new_term); CURRENT_TRIE = trie;
core_depth_breadth_trie_replace_nested_trie(TrNode_child(TrEntry_trie(trie)), nested_trie_id, new_term, &trie_data_construct, &trie_data_destruct);
return; return;
} }

33
library/tries/base_tries.c
View File

@ -74,8 +74,23 @@ void trie_data_destruct(TrNode node) {
data = (TrData) GET_DATA_FROM_LEAF_TRIE_NODE(node); data = (TrData) GET_DATA_FROM_LEAF_TRIE_NODE(node);
trie = TrData_trie(data); trie = TrData_trie(data);
if (data == TrEntry_traverse_data(trie)) if (data == TrEntry_traverse_data(trie)) {
if (CURRENT_TRAVERSE_MODE == TRAVERSE_MODE_FORWARD) {
TrEntry_traverse_data(trie) = TrData_previous(data); TrEntry_traverse_data(trie) = TrData_previous(data);
} else {
if (TrData_next(data)) {
TrEntry_traverse_data(trie) = TrData_next(data);
} else {
TrData special;
new_struct(special, TYPE_TR_DATA, SIZEOF_TR_DATA);
TrData_next(special) = NULL;
TrData_previous(special) = TrData_previous(data);
TrData_trie(special) = NULL;
TrData_leaf(special) = NULL;
TrEntry_traverse_data(trie) = special; /* This special data is necessery to allow proper backwards traverse when the last entry is removed this is freed only if the trie is kept traversing */
}
}
}
if (TrData_next(data)) { if (TrData_next(data)) {
TrData_previous(TrData_next(data)) = TrData_previous(data); TrData_previous(TrData_next(data)) = TrData_previous(data);
TrData_next(TrData_previous(data)) = TrData_next(data); TrData_next(TrData_previous(data)) = TrData_next(data);
@ -211,10 +226,19 @@ TrData trie_traverse_init(TrEntry trie, TrData init_data) {
TrData trie_traverse_cont(TrEntry trie) { TrData trie_traverse_cont(TrEntry trie) {
TrData data; TrData data, temp = NULL;
data = TrEntry_traverse_data(trie); data = TrEntry_traverse_data(trie);
if (data) { if (data) {
if (!TrData_trie(data)) {
if (TrEntry_first_data(trie)) {
temp = data;
} else {
free_trie_data(data);
data = NULL;
TrEntry_traverse_data(trie) = NULL;
return NULL;
}
}
if (CURRENT_TRAVERSE_MODE == TRAVERSE_MODE_FORWARD) if (CURRENT_TRAVERSE_MODE == TRAVERSE_MODE_FORWARD)
data = TrData_next(data); data = TrData_next(data);
else { else {
@ -223,6 +247,8 @@ TrData trie_traverse_cont(TrEntry trie) {
data = NULL; data = NULL;
} }
TrEntry_traverse_data(trie) = data; TrEntry_traverse_data(trie) = data;
if (temp)
free_trie_data(temp);
} }
return data; return data;
} }
@ -325,7 +351,6 @@ void trie_print(TrEntry trie) {
void trie_data_construct(TrNode node) { void trie_data_construct(TrNode node) {
TrData data; TrData data;
new_trie_data(data, CURRENT_TRIE, node); new_trie_data(data, CURRENT_TRIE, node);
PUT_DATA_IN_LEAF_TRIE_NODE(node, data); PUT_DATA_IN_LEAF_TRIE_NODE(node, data);
return; return;

108
library/tries/core_dbtries.c
View File

@ -210,9 +210,9 @@ int traverse_get_counter(TrNode node);
YAP_Term generate_label(YAP_Int Index); YAP_Term generate_label(YAP_Int Index);
YAP_Term update_depth_breadth_trie(TrEngine engine, TrNode root, YAP_Int opt_level, void (*construct_function)(TrNode), void (*destruct_function)(TrNode), void (*copy_function)(TrNode, TrNode), void (*correct_order_function)(void)); YAP_Term update_depth_breadth_trie(TrEngine engine, TrNode root, YAP_Int opt_level, void (*construct_function)(TrNode), void (*destruct_function)(TrNode), void (*copy_function)(TrNode, TrNode), void (*correct_order_function)(void));
YAP_Term get_return_node_term(TrNode node); YAP_Term get_return_node_term(TrNode node);
void traverse_and_replace_nested_trie(TrNode node, YAP_Int nested_trie_id, YAP_Term new_term); void traverse_and_replace_nested_trie(TrNode node, YAP_Int nested_trie_id, YAP_Term new_term, void (*construct_function)(TrNode), void (*destruct_function)(TrNode));
TrNode replace_nested_trie(TrNode node, TrNode child, YAP_Term new_term); TrNode replace_nested_trie(TrNode node, TrNode child, YAP_Term new_term, void (*construct_function)(TrNode), void (*destruct_function)(TrNode));
void check_attach_childs(TrNode search_child, TrNode existing_child); void check_attach_childs(TrNode parent, TrNode search_child, TrNode existing_child, void (*construct_function)(TrNode), void (*destruct_function)(TrNode));
TrNode get_simplification_sibling(TrNode node); TrNode get_simplification_sibling(TrNode node);
TrNode check_parent_first(TrNode node); TrNode check_parent_first(TrNode node);
TrNode TrNode_myparent(TrNode node); TrNode TrNode_myparent(TrNode node);
@ -257,18 +257,18 @@ void core_set_trie_db_opt_min_prefix(YAP_Int min_prefix) {
void core_depth_breadth_trie_replace_nested_trie(TrNode node, YAP_Int nested_trie_id, YAP_Term new_term) { void core_depth_breadth_trie_replace_nested_trie(TrNode node, YAP_Int nested_trie_id, YAP_Term new_term, void (*construct_function)(TrNode), void (*destruct_function)(TrNode)) {
traverse_and_replace_nested_trie(node, nested_trie_id, new_term); traverse_and_replace_nested_trie(node, nested_trie_id, new_term, construct_function, destruct_function);
return; return;
} }
inline inline
void traverse_and_replace_nested_trie(TrNode node, YAP_Int nested_trie_id, YAP_Term new_term) { void traverse_and_replace_nested_trie(TrNode node, YAP_Int nested_trie_id, YAP_Term new_term, void (*construct_function)(TrNode), void (*destruct_function)(TrNode)) {
TrNode child, temp; TrNode child, temp;
if (TrNode_entry(node) == PairEndTag) { if (TrNode_entry(node) == PairEndTag) {
if (TrNode_next(node)) if (TrNode_next(node))
traverse_and_replace_nested_trie(TrNode_next(node), nested_trie_id, new_term); traverse_and_replace_nested_trie(TrNode_next(node), nested_trie_id, new_term, construct_function, destruct_function);
return; return;
} else if (IS_HASH_NODE(node)) { } else if (IS_HASH_NODE(node)) {
printf("HASH NODE ERROR: db_tries do not support hash nodes.\n"); printf("HASH NODE ERROR: db_tries do not support hash nodes.\n");
@ -280,7 +280,7 @@ void traverse_and_replace_nested_trie(TrNode node, YAP_Int nested_trie_id, YAP_T
do { do {
if ((node = *--bucket)) { if ((node = *--bucket)) {
do { do {
traverse_and_replace_nested_trie(node, nested_trie_id, new_term); traverse_and_replace_nested_trie(node, nested_trie_id, new_term, construct_function, destruct_function);
node = TrNode_next(node); node = TrNode_next(node);
} while(node); } while(node);
} }
@ -303,13 +303,13 @@ void traverse_and_replace_nested_trie(TrNode node, YAP_Int nested_trie_id, YAP_T
do { do {
if (YAP_IntOfTerm(TrNode_entry(child)) == nested_trie_id) { if (YAP_IntOfTerm(TrNode_entry(child)) == nested_trie_id) {
temp = TrNode_previous(node); temp = TrNode_previous(node);
node = replace_nested_trie(node, child, new_term); node = replace_nested_trie(node, child, new_term, construct_function, destruct_function);
if (temp) { if (temp) {
temp = TrNode_next(node); temp = TrNode_next(node);
if (temp) if (temp)
node = temp; node = temp;
} else { } else {
traverse_and_replace_nested_trie(TrNode_child(node), nested_trie_id, new_term); traverse_and_replace_nested_trie(TrNode_child(node), nested_trie_id, new_term, construct_function, destruct_function);
return; return;
} }
} }
@ -322,10 +322,10 @@ void traverse_and_replace_nested_trie(TrNode node, YAP_Int nested_trie_id, YAP_T
do { do {
if (YAP_IntOfTerm(TrNode_entry(child)) == nested_trie_id) { if (YAP_IntOfTerm(TrNode_entry(child)) == nested_trie_id) {
temp = TrNode_next(node); temp = TrNode_next(node);
node = replace_nested_trie(node, child, new_term); node = replace_nested_trie(node, child, new_term, construct_function, destruct_function);
traverse_and_replace_nested_trie(TrNode_child(node), nested_trie_id, new_term); traverse_and_replace_nested_trie(TrNode_child(node), nested_trie_id, new_term, construct_function, destruct_function);
if(temp) if(temp)
traverse_and_replace_nested_trie(temp, nested_trie_id, new_term); traverse_and_replace_nested_trie(temp, nested_trie_id, new_term, construct_function, destruct_function);
return; return;
} }
child = TrNode_next(child); child = TrNode_next(child);
@ -333,17 +333,16 @@ void traverse_and_replace_nested_trie(TrNode node, YAP_Int nested_trie_id, YAP_T
} }
} }
} }
traverse_and_replace_nested_trie(TrNode_child(node), nested_trie_id, new_term); traverse_and_replace_nested_trie(TrNode_child(node), nested_trie_id, new_term, construct_function, destruct_function);
if (TrNode_next(node)) if (TrNode_next(node))
traverse_and_replace_nested_trie(TrNode_next(node), nested_trie_id, new_term); traverse_and_replace_nested_trie(TrNode_next(node), nested_trie_id, new_term, construct_function, destruct_function);
} }
return; return;
} }
/* fixmeeee */ /* fixmeeee */
TrNode replace_nested_trie(TrNode node, TrNode child, YAP_Term new_term) { TrNode replace_nested_trie(TrNode node, TrNode child, YAP_Term new_term, void (*construct_function)(TrNode), void (*destruct_function)(TrNode)) {
TrNode newnode, temp, newnodef = NULL; TrNode newnode, temp, newnodef = NULL;
YAP_Term term_search = (YAP_Term) NULL;
if (YAP_IsApplTerm(new_term)) { if (YAP_IsApplTerm(new_term)) {
YAP_Term new_term_functor = ApplTag | ((YAP_Term) YAP_FunctorOfTerm(new_term)); YAP_Term new_term_functor = ApplTag | ((YAP_Term) YAP_FunctorOfTerm(new_term));
YAP_Int arity = YAP_ArityOfFunctor(YAP_FunctorOfTerm(new_term)); YAP_Int arity = YAP_ArityOfFunctor(YAP_FunctorOfTerm(new_term));
@ -369,27 +368,19 @@ TrNode replace_nested_trie(TrNode node, TrNode child, YAP_Term new_term) {
TrNode_previous(TrNode_child(newnodef)) = newnode; TrNode_previous(TrNode_child(newnodef)) = newnode;
TrNode_child(newnodef) = newnode; TrNode_child(newnodef) = newnode;
} else { } else {
// Rewind to first uncle node /* Check if one of the node siblings have new_term */
temp = TrNode_parent(node); temp = node;
if (IS_FUNCTOR_NODE(temp))
term_search = TrNode_entry(temp);
while (TrNode_previous(temp)) while (TrNode_previous(temp))
temp = TrNode_previous(temp); temp = TrNode_previous(temp);
// Handles cases like not(t(?)) but doesn't handle case like not(not(...)
if (term_search) {
while (temp && TrNode_entry(temp) != term_search)
temp = TrNode_next(temp);
if (temp)
temp = TrNode_child(temp);
}
while (temp && TrNode_entry(temp) != new_term) while (temp && TrNode_entry(temp) != new_term)
temp = TrNode_next(temp); temp = TrNode_next(temp);
if (temp) { // Found a node we can reuse if (temp) {
newnode = temp; newnode = temp;
// Check if the childs of node/child exist already otherwise attach them // Check if the childs of node/child exist already otherwise attach them
check_attach_childs(TrNode_child(child), TrNode_child(newnode)); check_attach_childs(newnode, TrNode_child(child), TrNode_child(newnode), construct_function, destruct_function);
//DATA_DESTRUCT_FUNCTION = destruct_function; DATA_DESTRUCT_FUNCTION = destruct_function;
remove_child_nodes(TrNode_child(child)); remove_child_nodes(TrNode_child(child));
TrNode_child(child) = NULL;
remove_entry(child); remove_entry(child);
return newnode; return newnode;
} else { // Make a new node } else { // Make a new node
@ -426,20 +417,56 @@ TrNode replace_nested_trie(TrNode node, TrNode child, YAP_Term new_term) {
} }
void check_attach_childs(TrNode search_child, TrNode existing_child) { void check_attach_childs(TrNode parent, TrNode search_child, TrNode existing_child, void (*construct_function)(TrNode), void (*destruct_function)(TrNode)) {
TrNode newnode;
// Check if the childs of node/child exist already otherwise attach them // Check if the childs of node/child exist already otherwise attach them
do { do {
while(existing_child && (TrNode_entry(existing_child) != TrNode_entry(search_child))) while(existing_child && (TrNode_entry(existing_child) != PairEndTag) && (TrNode_entry(existing_child) != TrNode_entry(search_child)))
existing_child = TrNode_next(existing_child); existing_child = TrNode_next(existing_child);
if (existing_child) { if (existing_child) {
if (TrNode_entry(existing_child) != PairEndTag) { if (TrNode_entry(existing_child) != PairEndTag)
check_attach_childs(TrNode_child(search_child), TrNode_child(existing_child)); check_attach_childs(existing_child, TrNode_child(search_child), TrNode_child(existing_child), construct_function, destruct_function);
} existing_child = TrNode_child(parent);
} else {
printf("Need to attach child!\n");
abort();
}
search_child = TrNode_next(search_child); search_child = TrNode_next(search_child);
} else if (TrNode_entry(search_child) == PairEndTag) {
newnode = parent;
DATA_DESTRUCT_FUNCTION = destruct_function;
remove_child_nodes(TrNode_child(newnode));
TrNode_child(newnode) = NULL;
newnode = trie_node_check_insert(newnode, PairEndTag);
INCREMENT_ENTRIES(CURRENT_TRIE_ENGINE);
(*construct_function)(newnode);
return;
} else {
existing_child = search_child;
search_child = TrNode_next(search_child);
if(TrNode_child(TrNode_parent(existing_child)) == existing_child) {
if(TrNode_next(existing_child)) {
TrNode_child(TrNode_parent(existing_child)) = TrNode_next(existing_child);
} else {
newnode = TrNode_parent(existing_child);
// DATA_DESTRUCT_FUNCTION = destruct_function;
// remove_child_nodes(TrNode_child(newnode));
TrNode_child(newnode) = NULL;
newnode = trie_node_check_insert(newnode, PairEndTag);
INCREMENT_ENTRIES(CURRENT_TRIE_ENGINE);
(*construct_function)(newnode);
}
}
if (TrNode_next(existing_child))
TrNode_previous(TrNode_next(existing_child)) = TrNode_previous(existing_child);
if (TrNode_previous(existing_child))
TrNode_next(TrNode_previous(existing_child)) = TrNode_next(existing_child);
TrNode_parent(existing_child) = parent;
TrNode_previous(existing_child) = NULL;
TrNode_next(existing_child) = TrNode_child(parent);
TrNode_previous(TrNode_child(parent)) = existing_child;
TrNode_child(parent) = existing_child;
existing_child = TrNode_child(parent);
}
} while(search_child); } while(search_child);
} }
@ -729,7 +756,6 @@ TrNode core_breadth_reduction(TrEngine engine, TrNode node, TrNode breadth_node,
/* nested trie: stop procedure and return nested trie node */ /* nested trie: stop procedure and return nested trie node */
if (IS_FUNCTOR_NODE(TrNode_parent(child)) && (strcmp(YAP_AtomName(YAP_NameOfFunctor((YAP_Functor)(~ApplTag & TrNode_entry(TrNode_parent(child))))), NESTED_TRIE_TERM) == 0)) if (IS_FUNCTOR_NODE(TrNode_parent(child)) && (strcmp(YAP_AtomName(YAP_NameOfFunctor((YAP_Functor)(~ApplTag & TrNode_entry(TrNode_parent(child))))), NESTED_TRIE_TERM) == 0))
return child; return child;
PUSH_DOWN(stack_args, TrNode_entry(child), stack_top); PUSH_DOWN(stack_args, TrNode_entry(child), stack_top);
count++; count++;
if (IS_FUNCTOR_NODE(TrNode_parent(child))) { if (IS_FUNCTOR_NODE(TrNode_parent(child))) {

2
library/tries/core_dbtries.h
View File

@ -225,6 +225,6 @@ TrNode core_breadth_reduction(TrEngine engine, TrNode node, TrNode breadth_no
YAP_Term core_get_trie_db_return_term(void); YAP_Term core_get_trie_db_return_term(void);
void core_set_trie_db_return_term(YAP_Term return_value); void core_set_trie_db_return_term(YAP_Term return_value);
YAP_Int core_db_trie_get_optimization_level_count(YAP_Int opt_level); YAP_Int core_db_trie_get_optimization_level_count(YAP_Int opt_level);
void core_depth_breadth_trie_replace_nested_trie(TrNode node, YAP_Int nested_trie_id, YAP_Term new_term); void core_depth_breadth_trie_replace_nested_trie(TrNode node, YAP_Int nested_trie_id, YAP_Term new_term, void (*construct_function)(TrNode), void (*destruct_function)(TrNode));
YAP_Int core_get_trie_db_opt_min_prefix(void); YAP_Int core_get_trie_db_opt_min_prefix(void);
void core_set_trie_db_opt_min_prefix(YAP_Int min_prefix); void core_set_trie_db_opt_min_prefix(YAP_Int min_prefix);

4
library/tries/core_tries.c
View File

@ -971,9 +971,9 @@ void remove_child_nodes(TrNode node) {
} }
if (TrNode_next(node)) if (TrNode_next(node))
remove_child_nodes(TrNode_next(node)); remove_child_nodes(TrNode_next(node));
if (!IS_LEAF_TRIE_NODE(node)) if (!IS_LEAF_TRIE_NODE(node)) {
remove_child_nodes(TrNode_child(node)); remove_child_nodes(TrNode_child(node));
else { } else {
if (DATA_DESTRUCT_FUNCTION) if (DATA_DESTRUCT_FUNCTION)
(*DATA_DESTRUCT_FUNCTION)(node); (*DATA_DESTRUCT_FUNCTION)(node);
DECREMENT_ENTRIES(CURRENT_TRIE_ENGINE); DECREMENT_ENTRIES(CURRENT_TRIE_ENGINE);

2
misc/LOCALS
View File

@ -54,6 +54,8 @@ Int DepthArenas =0
int ArithError =FALSE int ArithError =FALSE
struct pred_entry* LastAssertedPred =NULL struct pred_entry* LastAssertedPred =NULL
struct pred_entry* TmpPred =NULL
struct pred_entry* LastAssertedPred =NULL
char* ScannerStack =NULL char* ScannerStack =NULL
struct scanner_extra_alloc* ScannerExtraBlocks =NULL struct scanner_extra_alloc* ScannerExtraBlocks =NULL
struct DB_TERM* BallTerm =NULL RestoreBallTerm(wid) struct DB_TERM* BallTerm =NULL RestoreBallTerm(wid)

5
packages/ProbLog/simplecudd_lfi/problogbdd_lfi.c
View File

@ -192,6 +192,8 @@
#include <stdarg.h> #include <stdarg.h>
#define VERSION "2.0.0" #define VERSION "2.0.0"
int all_loaded_for_deterministic_variables(namedvars varmap, int disp);
typedef struct _parameters { typedef struct _parameters {
int loadfile; int loadfile;
int savedfile; int savedfile;
@ -721,7 +723,7 @@ void myexpand(extmanager MyManager, DdNode *Current) {
} }
} }
/* Angelicas Algorithm */ /* Angelika's Algorithm */
double CalcProbability(extmanager MyManager, DdNode *Current) { double CalcProbability(extmanager MyManager, DdNode *Current) {
DdNode *h, *l; DdNode *h, *l;
@ -729,6 +731,7 @@ double CalcProbability(extmanager MyManager, DdNode *Current) {
char *curnode; //, *dynvalue; char *curnode; //, *dynvalue;
double lvalue, hvalue, tvalue; double lvalue, hvalue, tvalue;
// density_integral dynvalue_parsed; // density_integral dynvalue_parsed;
if (params.debug) { if (params.debug) {
curnode = GetNodeVarNameDisp(MyManager.manager, MyManager.varmap, Current); curnode = GetNodeVarNameDisp(MyManager.manager, MyManager.varmap, Current);
fprintf(stderr, "%s\n", curnode); fprintf(stderr, "%s\n", curnode);

1
packages/ProbLog/simplecudd_lfi/problogmath.h
View File

@ -161,6 +161,7 @@ typedef struct _density_integral {
double sigmoid(double x, double slope); double sigmoid(double x, double slope);
double normal(double x, double mu,double sigma);
double Phi(double x); double Phi(double x);
double cumulative_normal(double low, double high, double sigma, double mu); double cumulative_normal(double low, double high, double sigma, double mu);
double cumulative_normal_dmu(double low, double high,double mu,double sigma); double cumulative_normal_dmu(double low, double high,double mu,double sigma);

14
packages/ProbLog/simplecudd_lfi/simplecudd.c
View File

@ -188,6 +188,9 @@
#include <errno.h> #include <errno.h>
#include "simplecudd.h" #include "simplecudd.h"
int my_index_calc(int varstart, DdNode *node);
int all_loaded_for_deterministic_variables(namedvars varmap, int disp);
/* BDD manager initialization */ /* BDD manager initialization */
int _debug = 0; int _debug = 0;
@ -1717,8 +1720,7 @@ int GetParam(char *inputline, int iParam) {
void onlinetraverse(DdManager *manager, namedvars varmap, hisqueue *HisQueue, DdNode *bdd) { void onlinetraverse(DdManager *manager, namedvars varmap, hisqueue *HisQueue, DdNode *bdd) {
char buf, *inputline; char buf, *inputline;
int icur, maxlinesize, iline, index, iloop, ivalue, iQsize, i, inQ, iRoot; int icur, maxlinesize, iline, index, iloop, iQsize, i, inQ, iRoot;
double dvalue;
DdNode **Q, **Q2, *h_node, *l_node, *curnode; DdNode **Q, **Q2, *h_node, *l_node, *curnode;
hisqueue *his; hisqueue *his;
hisnode *hnode; hisnode *hnode;
@ -1756,10 +1758,10 @@ void onlinetraverse(DdManager *manager, namedvars varmap, hisqueue *HisQueue, Dd
inQ = 0; inQ = 0;
for(i = 0; (i < iQsize / 2) && (inQ < 3); i++) for(i = 0; (i < iQsize / 2) && (inQ < 3); i++)
inQ = (Q[i] == l_node) || (Q[iQsize - i] == l_node) + 2 * (Q[i] == h_node) || (Q[iQsize - i] == h_node); inQ = (Q[i] == l_node) || (Q[iQsize - i] == l_node) + 2 * (Q[i] == h_node) || (Q[iQsize - i] == h_node);
if (inQ & 1 == 0) inQ = inQ + (GetNode(his, varmap.varstart, l_node) != NULL); if ((inQ & 1) == 0) inQ = inQ + (GetNode(his, varmap.varstart, l_node) != NULL);
if (inQ & 2 == 0) inQ = inQ + 2 * (GetNode(his, varmap.varstart, h_node) != NULL); if ((inQ & 2) == 0) inQ = inQ + 2 * (GetNode(his, varmap.varstart, h_node) != NULL);
if (inQ & 1 == 1) inQ = inQ - (l_node == HIGH(manager) || l_node == LOW(manager)); if ((inQ & 1) == 1) inQ = inQ - (l_node == HIGH(manager) || l_node == LOW(manager));
if (inQ & 2 == 2) inQ = inQ - 2 * (h_node == HIGH(manager) || h_node == LOW(manager)); if ((inQ & 2) == 2) inQ = inQ - 2 * (h_node == HIGH(manager) || h_node == LOW(manager));
inQ = 0; inQ = 0;
switch(inQ) { switch(inQ) {
case 0: case 0:

7
pl/consult.yap
View File

@ -63,7 +63,7 @@
'$convert_for_export'/7, '$convert_for_export'/7,
'$extend_exports'/3]). '$extend_exports'/3]).
:- use_system_module( '$_preds', ['$current_predicate_no_modules'/3]). :- use_system_module( '$_preds', ['$current_predicate'/4]).
/** /**
@ -890,7 +890,7 @@ source_file(FileName) :-
source_file(Mod:Pred, FileName) :- source_file(Mod:Pred, FileName) :-
current_module(Mod), current_module(Mod),
Mod \= prolog, Mod \= prolog,
'$current_predicate_no_modules'(Mod,_,Pred), '$current_predicate'(_,Mod,Pred,_),
'$owned_by'(Pred, Mod, FileName). '$owned_by'(Pred, Mod, FileName).
'$owned_by'(T, Mod, FileName) :- '$owned_by'(T, Mod, FileName) :-
@ -1173,7 +1173,8 @@ unload_file( F0 ) :-
% eliminate multi-files; % eliminate multi-files;
% get rid of file-only predicataes. % get rid of file-only predicataes.
'$unload_file'( FileName, _F0 ) :- '$unload_file'( FileName, _F0 ) :-
'$current_predicate_var'(_A,Mod,P), current_module(Mod),
'$current_predicate'(_A,Mod,P,_),
'$owner_file'(P,Mod,FileName), '$owner_file'(P,Mod,FileName),
\+ '$is_multifile'(P,Mod), \+ '$is_multifile'(P,Mod),
functor( P, Na, Ar), functor( P, Na, Ar),

7
pl/debug.yap
View File

@ -182,8 +182,8 @@ mode and the existing spy-points, when the debugger is on.
'$pred_being_spied'(G, M) :- '$pred_being_spied'(G, M) :-
recorded('$spy','$spy'(G,M),_), !. recorded('$spy','$spy'(G,M),_), !.
/** @pred spy( + _P_ ). /**
@pred spy( + _P_ ).
Sets spy-points on all the predicates represented by Sets spy-points on all the predicates represented by
_P_. _P_ can either be a single specification or a list of _P_. _P_ can either be a single specification or a list of
@ -1323,6 +1323,3 @@ be lost.
yap_hacks:choicepoint(CP,_,prolog,'$loop_spy2',5,(_;_),_), !, yap_hacks:choicepoint(CP,_,prolog,'$loop_spy2',5,(_;_),_), !,
'$debugger_skip_loop_spy2'(CPs,CPs1). '$debugger_skip_loop_spy2'(CPs,CPs1).
'$debugger_skip_loop_spy2'(CPs,CPs). '$debugger_skip_loop_spy2'(CPs,CPs).

7
pl/hacks.yap
View File

@ -222,11 +222,8 @@ beautify_hidden_goal('$call'(G,_CP,?,M),prolog) -->
[call(M:G)]. [call(M:G)].
beautify_hidden_goal('$call'(_G,_CP,G0,M),prolog) --> beautify_hidden_goal('$call'(_G,_CP,G0,M),prolog) -->
[call(M:G0)]. [call(M:G0)].
beautify_hidden_goal('$current_predicate'(M,Na,Ar),prolog) --> beautify_hidden_goal('$current_predicate'(Na,M,S,_),prolog) -->
[current_predicate(M,Na/Ar)]. [current_predicate(Na,M:S)].
beautify_hidden_goal('$current_predicate_for_atom'(Name,M,Ar),prolog) -->
{ functor(P, Name, Ar) },
[current_predicate(Name,M:P)].
beautify_hidden_goal('$list_clauses'(Stream,M,Pred),prolog) --> beautify_hidden_goal('$list_clauses'(Stream,M,Pred),prolog) -->
[listing(Stream,M:Pred)]. [listing(Stream,M:Pred)].

4
pl/listing.yap
View File

@ -23,7 +23,7 @@
:- use_system_module( '$_errors', ['$do_error'/2]). :- use_system_module( '$_errors', ['$do_error'/2]).
:- use_system_module( '$_preds', ['$clause'/4, :- use_system_module( '$_preds', ['$clause'/4,
'$current_predicate_no_modules'/3]). '$current_predicate'/4]).
/* listing : Listing clauses in the database /* listing : Listing clauses in the database
@ -62,7 +62,7 @@ listing :-
Mod \= prolog, Mod \= prolog,
Mod \= system, Mod \= system,
\+ '$hidden'( Mod ), \+ '$hidden'( Mod ),
'$current_predicate_no_modules'(Mod,_,Pred), '$current_predicate'(_,Mod,Pred, _),
'$undefined'(Pred, prolog), % skip predicates exported from prolog. '$undefined'(Pred, prolog), % skip predicates exported from prolog.
functor(Pred,Name,Arity), functor(Pred,Name,Arity),
\+ atom_concat('$', _, Name), \+ atom_concat('$', _, Name),

13
pl/modules.yap
View File

@ -831,21 +831,25 @@ expand_goal(G, G).
'$exit_undefp', '$exit_undefp',
fail. fail.
% This predicate should be bidirectional: both
% a consumer and a generator.
'$get_undefined_pred'(G, ImportingMod, G0, ExportingMod) :- '$get_undefined_pred'(G, ImportingMod, G0, ExportingMod) :-
recorded('$import','$import'(ExportingModI,ImportingMod,G0I,G,_,_),_), recorded('$import','$import'(ExportingModI,ImportingMod,G0I,G,_,_),_),
'$continue_imported'(ExportingMod, ExportingModI, G0, G0I), !. '$continue_imported'(ExportingMod, ExportingModI, G0, G0I).
% SWI builtin % SWI builtin
'$get_undefined_pred'(G, _ImportingMod, G0, ExportingMod) :- '$get_undefined_pred'(G, _ImportingMod, G0, ExportingMod) :-
recorded('$dialect',Dialect,_), recorded('$dialect',Dialect,_),
Dialect \= yap, Dialect \= yap,
functor(G, Name, Arity), functor(G, Name, Arity),
call(Dialect:index(Name,Arity,ExportingModI,_)), !, call(Dialect:index(Name,Arity,ExportingModI,_)), !,
'$continue_imported'(ExportingMod, ExportingModI, G0, G), !. '$continue_imported'(ExportingMod, ExportingModI, G0, G).
% autoload
'$get_undefined_pred'(G, _ImportingMod, G0, ExportingMod) :- '$get_undefined_pred'(G, _ImportingMod, G0, ExportingMod) :-
yap_flag(autoload, V), yap_flag(autoload, V),
V = true, V = true,
'$autoloader_find_predicate'(G,ExportingModI), !, '$autoloader_find_predicate'(G,ExportingModI),
'$continue_imported'(ExportingMod, ExportingModI, G0, G). '$continue_imported'(ExportingMod, ExportingModI, G0, G).
% parent module mechanism
'$get_undefined_pred'(G, ImportingMod, G0, ExportingMod) :- '$get_undefined_pred'(G, ImportingMod, G0, ExportingMod) :-
prolog:'$parent_module'(ImportingMod,ExportingModI), prolog:'$parent_module'(ImportingMod,ExportingModI),
'$continue_imported'(ExportingMod, ExportingModI, G0, G). '$continue_imported'(ExportingMod, ExportingModI, G0, G).
@ -1203,7 +1207,8 @@ abolish_module(Mod) :-
recorded('$import','$import'(Mod,_,_,_,_,_),R), erase(R), recorded('$import','$import'(Mod,_,_,_,_,_),R), erase(R),
fail. fail.
abolish_module(Mod) :- abolish_module(Mod) :-
'$current_predicate'(Mod,Na,Ar), '$current_predicate'(Na,Mod,S,_),
functor(S, Na, Ar),
abolish(Mod:Na/Ar), abolish(Mod:Na/Ar),
fail. fail.
abolish_module(_). abolish_module(_).

159
pl/preds.yap
View File

@ -71,7 +71,7 @@ and therefore he should try to avoid them whenever possible.
unknown/2], ['$assert_static'/5, unknown/2], ['$assert_static'/5,
'$assertz_dynamic'/4, '$assertz_dynamic'/4,
'$clause'/4, '$clause'/4,
'$current_predicate_no_modules'/3, '$current_predicate'/4,
'$init_preds'/0, '$init_preds'/0,
'$noprofile'/2, '$noprofile'/2,
'$public'/2, '$public'/2,
@ -788,13 +788,15 @@ abolish(X) :-
'$do_error'(type_error(predicate_indicator,T),abolish(M:T)). '$do_error'(type_error(predicate_indicator,T),abolish(M:T)).
'$abolish_all'(M) :- '$abolish_all'(M) :-
'$current_predicate'(M,Na,Ar), '$current_predicate'(Na, M, S, _),
functor(S, Na, Ar),
'$new_abolish'(Na/Ar, M), '$new_abolish'(Na/Ar, M),
fail. fail.
'$abolish_all'(_). '$abolish_all'(_).
'$abolish_all_atoms'(Na, M) :- '$abolish_all_atoms'(Na, M) :-
'$current_predicate_for_atom'(Na,M,Ar), '$current_predicate'(Na,M,S,_),
functor(S, Na, Ar),
'$new_abolish'(Na/Ar, M), '$new_abolish'(Na/Ar, M),
fail. fail.
'$abolish_all_atoms'(_,_). '$abolish_all_atoms'(_,_).
@ -858,13 +860,15 @@ abolish(X) :-
'$do_error'(type_error(predicate_indicator,T),abolish(M:T)). '$do_error'(type_error(predicate_indicator,T),abolish(M:T)).
'$abolish_all_old'(M) :- '$abolish_all_old'(M) :-
'$current_predicate'(M, Na, Ar), '$current_predicate'(Na, M, S, _),
functor( S, Na, Ar ),
'$abolish'(Na, Ar, M), '$abolish'(Na, Ar, M),
fail. fail.
'$abolish_all_old'(_). '$abolish_all_old'(_).
'$abolish_all_atoms_old'(Na, M) :- '$abolish_all_atoms_old'(Na, M) :-
'$current_predicate_for_atom'(Na, M, Ar), '$current_predicate'(Na, M, S, _),
functor(S, Na, Ar),
'$abolish'(Na, Ar, M), '$abolish'(Na, Ar, M),
fail. fail.
'$abolish_all_atoms_old'(_,_). '$abolish_all_atoms_old'(_,_).
@ -1071,7 +1075,8 @@ predicate_property(Pred,Prop) :-
). ).
'$generate_all_preds_from_mod'(Pred, M, M) :- '$generate_all_preds_from_mod'(Pred, M, M) :-
'$current_predicate'(M,Na,Ar), '$current_predicate'(Na,M,S,_),
functor(S,Na,Ar),
'$ifunctor'(Pred,Na,Ar). '$ifunctor'(Pred,Na,Ar).
'$generate_all_preds_from_mod'(Pred, SourceMod, Mod) :- '$generate_all_preds_from_mod'(Pred, SourceMod, Mod) :-
recorded('$import','$import'(SourceMod, Mod, Orig, Pred,_,_),_), recorded('$import','$import'(SourceMod, Mod, Orig, Pred,_,_),_),
@ -1163,82 +1168,39 @@ predicate_erased_statistics(P,NCls,Sz,ISz) :-
/** @pred current_predicate( _A_, _P_) /** @pred current_predicate( _A_, _P_)
Defines the relation: _P_ is a currently defined predicate whose Defines the relation: _P_ is a currently defined predicate whose name is the atom _A_.
name is the atom _A_.
*/ */
current_predicate(A,T) :- current_predicate(A,T) :-
var(T), !, % only for the predicate '$ground_module'(T, M, T0),
'$current_module'(M), (
'$current_predicate_no_modules'(M,A,T). '$current_predicate'(A, M, T0, _)
current_predicate(A,M:T) :- % module unspecified ;
var(M), !, '$imported_predicate'(A, M, A/_Arity, T0, _)
'$current_predicate_var'(A,M,T). ).
current_predicate(A,M:T) :- % module specified
nonvar(T),
!,
functor(T,A,_),
'$pred_exists'(T,M).
current_predicate(A,M:T) :- % module specified
!,
'$current_predicate_no_modules'(M,A,T).
current_predicate(A,T) :- % only for the predicate
'$current_module'(M),
'$current_predicate_no_modules'(M,A,T).
'$current_predicate_var'(A,M,T) :-
var(T), !,
current_module(M),
M \= prolog,
'$current_predicate_no_modules'(M,A,T).
'$current_predicate_var'(A,M,T) :-
functor(T,A,_),
current_module(M),
M \= prolog,
'$pred_exists'(T,M).
/** @pred system_predicate( _A_, _P_) /** @pred system_predicate( _A_, _P_)
Defines the relation: _P_ is a built-in predicate whose name Defines the relation: _P_ is a built-in predicate whose name
is the atom _A_. is the atom _A_.
Notice that this predicatae always reports alll built-ins that are available to a module.
Also, it is possible to enumerate over all modules by allowing the module to be unbound:
~~~~~~
?- system_predicate(A,M:P).
~~~~~~
will report all built-in predicates _P_ in the system, independently of their module _M_.
*/ */
system_predicate( A, P ) :- system_predicate(A,T) :-
strip_module(P, M, P0), '$ground_module'(T, M, T0),
( atom(A) ->
( (
atom( M ) -> '$current_predicate'(A, M, T0, Flags)
( '$current_system_predicate_for_atom'( M, A, P0 )
; ;
'$imported_system_predicate'( M, A, P0 ) '$current_predicate'(A, prolog, T0, Flags)
) ),
; Flags /\ 0x00004000 =\= 0,
'$current_system_predicate_for_atom'( M , A , P0 ) \+ '$hidden'(A).
)
;
atom( M ) ->
( '$current_system_predicate'( M, A, P )
;
'$imported_system_predicate'( M, A, P )
)
;
/* var(M) */
'$current_system_predicate'( M , A , P )
).
/** @pred system_predicate( ?_P_ )
Defines the relation: _P_ is a currently defined system predicate.
*/
system_predicate(P) :- system_predicate(P) :-
'$current_module'(M), system_predicate(_, P).
'$system_predicate'(P,M).
'$current_predicate_no_modules'(M,A,T) :-
'$current_predicate'(M,A,Arity),
'$ifunctor'(T,A,Arity),
'$pred_exists'(T,M).
/** @pred current_predicate( _F_) is iso /** @pred current_predicate( _F_) is iso
@ -1246,52 +1208,22 @@ system_predicate( A, P ) :-
_F_ is the predicate indicator for a currently defined user or _F_ is the predicate indicator for a currently defined user or
library predicate. _F_ is of the form _Na/Ar_, where the atom library predicate. _F_ is of the form _Na/Ar_, where the atom
_Na_ is the name of the predicate, and _Ar_ its arity. _Na_ is the name of the predicate, and _Ar_ its arity.
*/ */
current_predicate(F0) :- current_predicate(F0) :-
'$yap_strip_module'(F0, M, F), '$ground_module'(F0, M, F),
'$$current_predicate'(F, M).
'$$current_predicate'(F, M) :-
( var(M) -> % only for the predicate
'$all_current_modules'(M)
; true),
M \= prolog,
'$current_predicate3'(F,M).
'$current_predicate3'(A/Arity,M) :-
nonvar(A), nonvar(Arity), !,
( '$ifunctor'(T,A,Arity),
'$pred_exists'(T,M)
->
true
;
% '$current_predicate'(prolog,A,Arity)
% ->
% functor(T,A,Arity),
% '$pred_exists'(T,M)
% ;
recorded('$import','$import'(NM,M,G,T,A,Arity),_)
->
'$pred_exists'(G,NM)
).
'$current_predicate3'(A/Arity,M) :- !,
( (
'$current_predicate'(M,A,Arity), '$current_predicate'(N, M, S, _),
'$ifunctor'(T,A,Arity), functor( S, N, Ar),
'$pred_exists'(T,M) F = N/Ar
; ;
% '$current_predicate'(prolog,A,Arity), '$imported_predicate'(_Name, M, F, _S, _)
% functor(T,A,Arity),
% '$pred_exists'(T,M)
% ;
recorded('$import','$import'(NM,M,G,T,A,Arity),_),
functor(T,A,Arity),
'$pred_exists'(G,NM)
). ).
'$current_predicate3'(BadSpec,M) :- % only for the predicate
'$do_error'(type_error(predicate_indicator,BadSpec),current_predicate(M:BadSpec)). '$imported_predicate'(A, ImportingMod, A/Arity, G, Flags) :-
'$get_undefined_pred'(G, ImportingMod, G0, ExportingMod),
functor(G, A, Arity),
'$pred_exists'(G, ExportingMod),
'$flags'(G0, ExportingMod, Flags, Flags).
/** @pred current_key(? _A_,? _K_) /** @pred current_key(? _A_,? _K_)
@ -1299,12 +1231,9 @@ current_predicate(F0) :-
Defines the relation: _K_ is a currently defined database key whose Defines the relation: _K_ is a currently defined database key whose
name is the atom _A_. It can be used to generate all the keys for name is the atom _A_. It can be used to generate all the keys for
the internal data-base. the internal data-base.
*/ */
current_key(A,K) :- current_key(A,K) :-
'$current_predicate'(idb,A,Arity), '$current_predicate'(A,idb,K,_).
'$ifunctor'(K,A,Arity).
% do nothing for now. % do nothing for now.
'$noprofile'(_, _). '$noprofile'(_, _).
@ -1328,10 +1257,6 @@ calls to assert/1 or retract/1 on the named predicates
raise a permission error. This predicate is designed to deal with parts raise a permission error. This predicate is designed to deal with parts
of the program that is generated at runtime but does not change during of the program that is generated at runtime but does not change during
the remainder of the program execution. the remainder of the program execution.
*/ */
compile_predicates(Ps) :- compile_predicates(Ps) :-
'$current_module'(Mod), '$current_module'(Mod),

5
pl/profile.yap
View File

@ -126,8 +126,8 @@ profile_data(P, Parm, Data) :-
'$profile_say'(Stats, Parm, Data). '$profile_say'(Stats, Parm, Data).
'$profile_data_for_var'(Name/Arity, Parm, Data, M) :- '$profile_data_for_var'(Name/Arity, Parm, Data, M) :-
'$current_predicate'(M,Name,Arity),
functor(P,Name,Arity), functor(P,Name,Arity),
'$current_predicate'(Name,M,P,_),
\+ '$hidden'(Name), % don't show hidden predicates. \+ '$hidden'(Name), % don't show hidden predicates.
'$profile_info'(M, P, Stats), '$profile_info'(M, P, Stats),
'$profile_say'(Stats, Parm, Data). '$profile_say'(Stats, Parm, Data).
@ -137,8 +137,7 @@ profile_data(P, Parm, Data) :-
profile_reset :- profile_reset :-
current_module(M), current_module(M),
'$current_predicate'(M,Na,Ar), '$current_predicate'(_Na,M,P,_),
functor(P,Na,Ar),
'$profile_reset'(M, P), '$profile_reset'(M, P),
fail. fail.
profile_reset. profile_reset.

3
pl/protect.yap
View File

@ -30,8 +30,7 @@
'$protect'. '$protect'.
'$hide_predicates'(Name) :- '$hide_predicates'(Name) :-
'$current_predicate_for_atom'(Name, prolog, Ar), '$current_predicate'(Name, prolog, P, _),
functor(P, Name, Ar),
'$hide_predicate'(P,prolog), '$hide_predicate'(P,prolog),
fail. fail.
'$hide_predicates'(_). '$hide_predicates'(_).

3
pl/signals.yap
View File

@ -227,7 +227,8 @@ order of dispatch.
'$execute_nonstop'(G, M), '$execute_nonstop'(G, M),
'$$save_by'(CP2), '$$save_by'(CP2),
'$disable_debugging', '$disable_debugging',
(CP == CP2 -> ! ; ( true ; '$enable_debugging', fail ) ) (CP == CP2 -> ! ; ( true ; '$enable_debugging', fail ) ),
'$enable_debugging'
; ;
'$disable_debugging', '$disable_debugging',
fail fail