diff --git a/C/cdmgr.c b/C/cdmgr.c index 9c727a948..3dd7a82ed 100644 --- a/C/cdmgr.c +++ b/C/cdmgr.c @@ -2995,7 +2995,7 @@ fetch_next_lu_clause(PredEntry *pe, yamop *i_code, Term th, Term tb, Term tr, ya LogUpdClause *cl; Term rtn; - cl = Yap_follow_indexing_code(pe, i_code, th, tb, tr, NEXTOP(PredLogUpdClause->CodeOfPred,ld), cp_ptr); + cl = Yap_FollowIndexingCode(pe, i_code, th, tb, tr, NEXTOP(PredLogUpdClause->CodeOfPred,ld), cp_ptr); if (cl == NULL) { WRITE_UNLOCK(pe->PRWLock); return FALSE; @@ -3069,6 +3069,16 @@ p_log_update_clause(void) if (pe == NULL || EndOfPAEntr(pe)) return FALSE; WRITE_LOCK(pe->PRWLock); + if (pe->ModuleOfPred != 2 && + pe->ArityOfPE) { + UInt i; + CELL *tar = RepAppl(t1); + + /* makes no sense for IDB, as ArityOfPE means nothing */ + for (i = 1; i <= pe->ArityOfPE; i++) { + XREGS[i] = tar[i]; + } + } if(pe->OpcodeOfPred == INDEX_OPCODE) { IPred(pe); } @@ -3090,7 +3100,7 @@ fetch_next_lu_clause0(PredEntry *pe, yamop *i_code, Term th, Term tb, yamop *cp_ { LogUpdClause *cl; - cl = Yap_follow_indexing_code(pe, i_code, th, tb, TermNil, NEXTOP(PredLogUpdClause0->CodeOfPred,ld), cp_ptr); + cl = Yap_FollowIndexingCode(pe, i_code, th, tb, TermNil, NEXTOP(PredLogUpdClause0->CodeOfPred,ld), cp_ptr); WRITE_UNLOCK(pe->PRWLock); if (cl == NULL) { return FALSE; @@ -3149,6 +3159,16 @@ p_log_update_clause0(void) if (pe == NULL || EndOfPAEntr(pe)) return FALSE; WRITE_LOCK(pe->PRWLock); + if (pe->ModuleOfPred != 2 &&\ + pe->ArityOfPE) { + UInt i; + CELL *tar = RepAppl(t1); + + /* makes no sense for IDB, as ArityOfPE means nothing */ + for (i = 1; i <= pe->ArityOfPE; i++) { + XREGS[i] = tar[i]; + } + } if(pe->OpcodeOfPred == INDEX_OPCODE) { IPred(pe); } @@ -3171,7 +3191,7 @@ fetch_next_static_clause(PredEntry *pe, yamop *i_code, Term th, Term tb, Term tr StaticClause *cl; Term rtn; - cl = (StaticClause *)Yap_follow_indexing_code(pe, i_code, th, tb, tr, NEXTOP(PredStaticClause->CodeOfPred,ld), cp_ptr); + cl = (StaticClause *)Yap_FollowIndexingCode(pe, i_code, th, tb, tr, NEXTOP(PredStaticClause->CodeOfPred,ld), cp_ptr); WRITE_UNLOCK(pe->PRWLock); if (cl == NULL) return FALSE; @@ -3231,12 +3251,73 @@ p_static_clause(void) if (pe == NULL || EndOfPAEntr(pe)) return FALSE; WRITE_LOCK(pe->PRWLock); + if (pe->ArityOfPE && + pe->ArityOfPE) { + UInt i; + CELL *tar = RepAppl(t1); + + for (i = 1; i <= pe->ArityOfPE; i++) { + XREGS[i] = tar[i]; + } + } if(pe->OpcodeOfPred == INDEX_OPCODE) { IPred(pe); } return fetch_next_static_clause(pe, pe->cs.p_code.TrueCodeOfPred, t1, ARG3, ARG4, P, TRUE); } +static Int /* $hidden_predicate(P) */ +p_nth_clause(void) +{ + PredEntry *pe; + Term t1 = Deref(ARG1); + Term tn = Deref(ARG3); + LogUpdClause *cl; + Int ncls; + + if (!IsIntegerTerm(tn)) + return FALSE; + ncls = IntegerOfTerm(tn); + pe = get_pred(t1, Deref(ARG2), "clause/3"); + if (pe == NULL || EndOfPAEntr(pe)) + return FALSE; + WRITE_LOCK(pe->PRWLock); + if (!(pe->PredFlags & (SourcePredFlag|LogUpdatePredFlag))) { + WRITE_UNLOCK(pe->PRWLock); + return FALSE; + } + /* in case we have to index or to expand code */ + if (pe->ModuleOfPred != 2) { + UInt i; + + for (i = 1; i <= pe->ArityOfPE; i++) { + XREGS[i] = MkVarTerm(); + } + } else { + XREGS[2] = MkVarTerm(); + } + if(pe->OpcodeOfPred == INDEX_OPCODE) { + IPred(pe); + } + cl = Yap_NthClause(pe, ncls); + if (cl == NULL) + return FALSE; + if (cl->ClFlags & LogUpdatePredFlag) { +#if defined(YAPOR) || defined(THREADS) + LOCK(cl->ClLock); + TRAIL_CLREF(cl); /* So that fail will erase it */ + INC_DBREF_COUNT(cl); + UNLOCK(cl->ClLock); +#else + if (!(cl->ClFlags & InUseMask)) { + cl->ClFlags |= InUseMask; + TRAIL_CLREF(cl); /* So that fail will erase it */ + } +#endif + } + return Yap_unify(MkDBRefTerm((DBRef)cl), ARG4); +} + static Int /* $hidden_predicate(P) */ p_continue_static_clause(void) { @@ -3461,5 +3542,6 @@ Yap_InitCdMgr(void) Yap_InitCPred("$static_clause", 4, p_static_clause, SyncPredFlag); Yap_InitCPred("$continue_static_clause", 5, p_continue_static_clause, SafePredFlag|SyncPredFlag); Yap_InitCPred("$static_pred_statistics", 5, p_static_pred_statistics, SyncPredFlag); + Yap_InitCPred("$p_nth_clause", 4, p_nth_clause, SyncPredFlag); } diff --git a/C/index.c b/C/index.c index ffcf2986e..612e20997 100644 --- a/C/index.c +++ b/C/index.c @@ -6050,11 +6050,18 @@ update_clause_choice_point(yamop *ipc, yamop *ap_pc) B->cp_ap = ap_pc; } -LogUpdClause * -Yap_follow_indexing_code(PredEntry *ap, yamop *ipc, Term t1, Term tb, Term tr, yamop *ap_pc, yamop *cp_pc) +static LogUpdClause * +to_clause(yamop *ipc, PredEntry *ap) +{ + if (ap->PredFlags & LogUpdatePredFlag) + return lu_clause(ipc); + else + return static_clause(ipc); +} + +LogUpdClause * +Yap_FollowIndexingCode(PredEntry *ap, yamop *ipc, Term t1, Term tb, Term tr, yamop *ap_pc, yamop *cp_pc) { - CELL *tar = RepAppl(t1); - UInt i; CELL *s_reg = NULL; Term t = TermNil; yamop *start_pc = ipc; @@ -6062,12 +6069,6 @@ Yap_follow_indexing_code(PredEntry *ap, yamop *ipc, Term t1, Term tb, Term tr, y yamop **jlbl = NULL; int lu_pred = ap->PredFlags & LogUpdatePredFlag; - if (ap->ModuleOfPred != 2) { - /* makes no sense for IDB, as ArityOfPE means nothing */ - for (i = 1; i <= ap->ArityOfPE; i++) { - XREGS[i] = tar[i]; - } - } /* try to refine the interval using the indexing code */ while (ipc != NULL) { op_numbers op = Yap_op_from_opcode(ipc->opc); @@ -6075,7 +6076,10 @@ Yap_follow_indexing_code(PredEntry *ap, yamop *ipc, Term t1, Term tb, Term tr, y switch(op) { case _try_in: update_clause_choice_point(NEXTOP(ipc,l), ap_pc); - ipc = ipc->u.l.l; + if (lu_pred) + return lu_clause(ipc->u.ld.d); + else + return static_clause(ipc->u.ld.d); break; case _try_clause: if (b0 == NULL) @@ -6097,10 +6101,12 @@ Yap_follow_indexing_code(PredEntry *ap, yamop *ipc, Term t1, Term tb, Term tr, y update_clause_choice_point(ipc->u.ld.d, ap_pc); ipc = NEXTOP(ipc,ld); break; - case _retry: - case _retry_killed: case _retry_profiled: case _count_retry: + ipc = NEXTOP(ipc,p); + break; + case _retry: + case _retry_killed: update_clause_choice_point(NEXTOP(ipc,ld),ap_pc); if (lu_pred) return lu_clause(ipc->u.ld.d); @@ -6392,6 +6398,149 @@ Yap_follow_indexing_code(PredEntry *ap, yamop *ipc, Term t1, Term tb, Term tr, y return NULL; } +LogUpdClause * +Yap_NthClause(PredEntry *ap, Int ncls) +{ + yamop + *ipc = ap->cs.p_code.TrueCodeOfPred, + *alt = NULL; + yamop **jlbl = NULL; + + /* search every clause */ + if (ncls == 1) + return to_clause(ap->cs.p_code.FirstClause,ap); + else if (ncls == ap->cs.p_code.NOfClauses) + return to_clause(ap->cs.p_code.LastClause,ap); + else if (ncls > ap->cs.p_code.NOfClauses) + return NULL; + else if (ncls < 0) + return NULL; + + while (TRUE) { + op_numbers op = Yap_op_from_opcode(ipc->opc); + + switch(op) { + case _try_in: + if (ncls == 1) + return to_clause(ipc->u.l.l, ap); + ncls--; + ipc = NEXTOP(ipc,l); + break; + case _retry_profiled: + case _count_retry: + ipc = NEXTOP(ipc,p); + case _try_clause: + case _retry: + if (ncls == 1) + return to_clause(ipc->u.ld.d, ap); + else if (alt == NULL) { + ncls -= 2; + /* get there in a fell swoop */ + if (ap->PredFlags & ProfiledPredFlag) { + if (ap->PredFlags & CountPredFlag) { + ipc = (yamop *)((char *)ipc+ncls*(UInt)NEXTOP(NEXTOP(NEXTOP((yamop *)NULL,ld),p),p)); + } else { + ipc = (yamop *)((char *)ipc+ncls*(UInt)NEXTOP(NEXTOP((yamop *)NULL,ld),p)); + } + } else if (ap->PredFlags & CountPredFlag) { + ipc = (yamop *)((char *)ipc+ncls*(UInt)NEXTOP(NEXTOP((yamop *)NULL,ld),p)); + } else { + ipc = (yamop *)((char *)ipc+ncls*(UInt)NEXTOP((yamop *)NULL,ld)); + } + ncls = 1; + } else { + ncls--; + } + ipc = NEXTOP(ipc,ld); + break; + case _trust: + if (ncls == 1) + return to_clause(ipc->u.l.l,ap); + ncls--; + ipc = alt; + break; + case _try_me: + case _try_me1: + case _try_me2: + case _try_me3: + case _try_me4: + case _retry_me: + case _retry_me1: + case _retry_me2: + case _retry_me3: + case _retry_me4: + alt = ipc->u.ld.d; + ipc = NEXTOP(ipc,ld); + break; + case _profiled_trust_me: + case _trust_me: + case _count_trust_me: + case _trust_me1: + case _trust_me2: + case _trust_me3: + case _trust_me4: + alt = NULL; + ipc = NEXTOP(ipc,ld); + break; + case _trust_logical_pred: + ipc = NEXTOP(ipc,l); + case _stale_lu_index: + ipc = clean_up_index(ipc->u.Ill.I, jlbl, ap); + break; + case _enter_lu_pred: + ipc = ipc->u.Ill.l1; + break; + case _jump: + jlbl = &(ipc->u.l.l); + ipc = ipc->u.l.l; + break; + case _jump_if_var: + jlbl = &(ipc->u.l.l); + ipc = ipc->u.l.l; + break; + case _jump_if_nonvar: + ipc = NEXTOP(ipc,xl); + break; + /* instructions type e */ + case _switch_on_type: + jlbl = &(ipc->u.llll.l4); + ipc = ipc->u.llll.l4; + break; + case _switch_list_nl: + jlbl = &(ipc->u.ollll.l4); + ipc = ipc->u.ollll.l4; + break; + case _switch_on_arg_type: + jlbl = &(ipc->u.xllll.l4); + ipc = ipc->u.xllll.l4; + break; + case _switch_on_sub_arg_type: + jlbl = &(ipc->u.sllll.l4); + ipc = ipc->u.sllll.l4; + break; + case _if_not_then: + jlbl = &(ipc->u.clll.l3); + ipc = ipc->u.clll.l3; + break; + case _expand_index: + ipc = ExpandIndex(ap); + break; + case _op_fail: + ipc = alt; + break; + case _undef_p: + return NULL; + case _index_pred: + case _spy_pred: + Yap_IPred(ap); + ipc = ap->cs.p_code.TrueCodeOfPred; + break; + default: + return NULL; + } + } +} + static yamop ** find_caller(PredEntry *ap, yamop *code) { /* first clause */ diff --git a/H/clause.h b/H/clause.h index 9a18f268b..187faa79f 100644 --- a/H/clause.h +++ b/H/clause.h @@ -188,7 +188,8 @@ yamop *STD_PROTO(Yap_ExpandIndex,(PredEntry *)); yamop *STD_PROTO(Yap_CleanUpIndex,(struct logic_upd_index *)); void STD_PROTO(Yap_AddClauseToIndex,(PredEntry *,yamop *,int)); void STD_PROTO(Yap_RemoveClauseFromIndex,(PredEntry *,yamop *)); -LogUpdClause *STD_PROTO(Yap_follow_indexing_code,(PredEntry *,yamop *,Term,Term,Term, yamop *,yamop *)); +LogUpdClause *STD_PROTO(Yap_NthClause,(PredEntry *,Int)); +LogUpdClause *STD_PROTO(Yap_FollowIndexingCode,(PredEntry *,yamop *,Term,Term,Term, yamop *,yamop *)); #if LOW_PROF /* profiling */ diff --git a/docs/yap.tex b/docs/yap.tex index b27cac2e4..c5c883856 100644 --- a/docs/yap.tex +++ b/docs/yap.tex @@ -4720,8 +4720,8 @@ available has undefined results. @end table -The following predicate can be used for dynamic predicates and for static -predicates, but only if source mode was on when they were compiled: +The following predicates can be used for dynamic predicates and for +static predicates, if source mode was on when they were compiled: @table @code diff --git a/pl/debug.yap b/pl/debug.yap index aa4cda5ba..da14f5740 100644 --- a/pl/debug.yap +++ b/pl/debug.yap @@ -326,7 +326,7 @@ debugging :- '$loop_spy_event'('$fail_spy'(GoalNumber), _, _, _, _) :- !, throw('$fail_spy'(GoalNumber)). '$loop_spy_event'(abort, _, _, _, _) :- !, - '$throw'(abort). + throw(abort). '$loop_spy_event'(Event, GoalNumber, G, Module, _) :- !, '$trace'(exception,G,Module,GoalNumber), fail. diff --git a/pl/preds.yap b/pl/preds.yap index b94c94073..16e9c9425 100644 --- a/pl/preds.yap +++ b/pl/preds.yap @@ -355,6 +355,8 @@ clause(V,Q,R) :- nth_clause(P,I,R) :- nonvar(R), !, '$nth_instancep'(P,I,R). +nth_clause(V,I,R) :- var(V), !, + '$do_error'(instantiation_error,M:nth_clause(V,I,R)). nth_clause(M:V,I,R) :- !, '$nth_clause'(V,M,I,R). nth_clause(V,I,R) :- @@ -371,11 +373,14 @@ nth_clause(V,I,R) :- '$nth_clause'(M:P,_,I,R) :- !, '$nth_clause'(P,M,I,R). '$nth_clause'(P,M,I,R) :- - '$some_recordedp'(M:P), !, + ( '$is_log_updatable'(P,M) ; '$is_source'(P,M) ), !, + '$p_nth_clause'(P,M,I,R). +'$nth_clause'(P,M,I,R) :- + '$is_dynamic'(H,M), !, '$nth_instancep'(M:P,I,R). '$nth_clause'(P,M,I,R) :- ( '$system_predicate'(P,M) -> true ; - '$number_of_nth_clauses'(P,M,N), N > 0 ), + '$number_of_clauses'(P,M,N), N > 0 ), functor(P,Name,Arity), '$do_error'(permission_error(access,private_procedure,Name/Arity), nth_clause(M:P,I,R)).