diff --git a/C/absmi.c b/C/absmi.c index 59957ae58..0063013c4 100644 --- a/C/absmi.c +++ b/C/absmi.c @@ -1139,7 +1139,7 @@ Yap_absmi(int inp) UNLOCK(cl->ClLock); } #else - if (B->cp_tr[-1] == CLREF_TO_TRENTRY(cl) && + if (TrailTerm(B->cp_tr-1) == CLREF_TO_TRENTRY(cl) && B->cp_tr > B->cp_b->cp_tr) { cl->ClFlags &= ~InUseMask; TR = --B->cp_tr; @@ -1419,7 +1419,14 @@ Yap_absmi(int inp) /* trust_fail */ BOp(trust_fail, e); +#ifdef YAPOR + CUT_prune_to((choiceptr) d0); +#else B = B->cp_b; +#endif /* YAPOR */ +#ifdef TABLING + abolish_incomplete_subgoals(B); +#endif /* TABLING */ goto fail; ENDBOp(); @@ -1601,7 +1608,6 @@ Yap_absmi(int inp) if ((ADDR) pt1 >= Yap_TrailBase) #endif /* SBA */ { - pt1 = (tr_fr_ptr) pt1; goto failloop; } #endif /* FROZEN_STACKS */ diff --git a/C/amasm.c b/C/amasm.c index 5c432b91e..31fd97045 100644 --- a/C/amasm.c +++ b/C/amasm.c @@ -1245,6 +1245,9 @@ a_try(op_numbers opcode, CELL lab, CELL opr) code_p->u.ld.d = emit_a(lab); code_p->u.ld.s = emit_count(opr); code_p->u.ld.p = CurrentPred; +#ifdef TABLING + code_p->u.ld.te = CurrentPred->TableOfPred; +#endif #ifdef YAPOR INIT_YAMOP_LTT(code_p, nofalts); if (hascut) @@ -2016,9 +2019,11 @@ a_f2(int var) #define TRYOP(G,P) (IPredArity<5 ? (op_numbers)((int)(P)+(IPredArity*3)) : (G)) #ifdef YAPOR -#define TRYCODE(G,P) a_try(TRYOP(G,P), Unsigned(code_addr) + label_offset[cpc->rnd1], IPredArity, cpc->rnd2 >> 1, cpc->rnd2 & 1); +#define TRYCODE(G,P) a_try(TRYOP(G,P), Unsigned(code_addr) + label_offset[cpc->rnd1], IPredArity, cpc->rnd2 >> 1, cpc->rnd2 & 1) +#define TABLE_TRYCODE(G) a_try(G, (CELL)emit_ilabel(cpc->rnd1), IPredArity, cpc->rnd2 >> 1, cpc->rnd2 & 1) #else -#define TRYCODE(G,P) a_try(TRYOP(G,P), Unsigned(code_addr) + label_offset[cpc->rnd1], IPredArity); +#define TRYCODE(G,P) a_try(TRYOP(G,P), Unsigned(code_addr) + label_offset[cpc->rnd1], IPredArity) +#define TABLE_TRYCODE(G) a_try(G, (CELL)emit_ilabel(cpc->rnd1), IPredArity) #endif /* YAPOR */ static yamop * @@ -2032,6 +2037,9 @@ do_pass(void) #endif /* YAPOR */ int log_update; int dynamic; +#ifdef TABLING + int tabled; +#endif int ystop_found = FALSE; union clause_obj *cl_u; @@ -2043,6 +2051,9 @@ do_pass(void) /* Space while for the clause flags */ log_update = CurrentPred->PredFlags & LogUpdatePredFlag; dynamic = CurrentPred->PredFlags & DynamicPredFlag; +#ifdef TABLING + tabled = CurrentPred->PredFlags & TabledPredFlag; +#endif if (assembling != ASSEMBLING_INDEX) { if (log_update) { if (pass_no) { @@ -2128,6 +2139,9 @@ do_pass(void) case table_new_answer_op: a_n(_table_new_answer, (int) cpc->rnd2); break; + case table_try_single_op: + a_gl(_table_try_single); + break; #endif /* TABLING */ #ifdef TABLING_INNER_CUTS case clause_with_cut_op: @@ -2359,35 +2373,65 @@ do_pass(void) a_deallocate(); break; case tryme_op: - TRYCODE(_try_me, _try_me0); +#ifdef TABLING + if (tabled) + TABLE_TRYCODE(_table_try_me); + else +#endif + TRYCODE(_try_me, _try_me0); break; case retryme_op: - TRYCODE(_retry_me, _retry_me0); +#ifdef TABLING + if (tabled) + TABLE_TRYCODE(_table_retry_me); + else +#endif + TRYCODE(_retry_me, _retry_me0); break; case trustme_op: if (log_update && assembling == ASSEMBLING_INDEX) { - a_cl(_trust_logical_pred); + a_gl(_trust_logical_pred); } - TRYCODE(_trust_me, _trust_me0); +#ifdef TABLING + if (tabled) + TABLE_TRYCODE(_table_trust_me); + else +#endif + TRYCODE(_trust_me, _trust_me0); break; case enter_lu_op: a_lucl(_enter_lu_pred); break; case try_op: - a_gl(_try_clause); +#ifdef TABLING + if (tabled) + a_gl(_table_try); + else +#endif + a_gl(_try_clause); break; case retry_op: if (log_update) { add_clref(cpc->rnd1); } - a_gl(_retry); +#ifdef TABLING + if (tabled) + a_gl(_table_retry); + else +#endif + a_gl(_retry); break; case trust_op: if (log_update) { add_clref(cpc->rnd1); a_cl(_trust_logical_pred); } - a_gl(_trust); +#ifdef TABLING + if (tabled) + a_gl(_table_trust); + else +#endif + a_gl(_trust); break; case try_in_op: a_il(_try_in); diff --git a/C/cdmgr.c b/C/cdmgr.c index c2fe619e5..1fb2a1ed0 100644 --- a/C/cdmgr.c +++ b/C/cdmgr.c @@ -151,13 +151,6 @@ IPred(PredEntry *ap) { yamop *BaseAddr; -#ifdef TABLING - if (is_tabled(ap)) { - ap->CodeOfPred = ap->cs.p_code.TrueCodeOfPred; - ap->OpcodeOfPred = ap->CodeOfPred->opc; - return; - } -#endif /* TABLING */ #ifdef DEBUG if (Yap_Option['i' - 'a' + 1]) { Term tmod = ModuleName[ap->ModuleOfPred]; @@ -235,7 +228,11 @@ RemoveMainIndex(PredEntry *ap) if (First != NULL && spied) { ap->OpcodeOfPred = Yap_opcode(_spy_pred); ap->cs.p_code.TrueCodeOfPred = ap->CodeOfPred = (yamop *)(&(ap->OpcodeOfPred)); - } else if (ap->cs.p_code.NOfClauses > 1) { + } else if (ap->cs.p_code.NOfClauses > 1 +#ifdef TABLING + ||ap->PredFlags & TabledPredFlag +#endif + ) { ap->OpcodeOfPred = INDEX_OPCODE; ap->CodeOfPred = ap->cs.p_code.TrueCodeOfPred = (yamop *)(&(ap->OpcodeOfPred)); } else { @@ -657,10 +654,9 @@ add_first_static(PredEntry *p, yamop *cp, int spy_flag) #endif /* YAPOR */ #ifdef TABLING if (is_tabled(p)) { - pt->u.ld.te = p->TableOfPred; XXXXX - pt->opc = Yap_opcode(_table_try_me_single); + p->OpcodeOfPred = INDEX_OPCODE; + p->cs.p_code.TrueCodeOfPred = p->CodeOfPred = (yamop *)(&(p->OpcodeOfPred)); } - else #endif /* TABLING */ } p->cs.p_code.TrueCodeOfPred = pt; @@ -800,11 +796,6 @@ asserta_stat_clause(PredEntry *p, yamop *q, int spy_flag) #ifdef YAPOR PUT_YAMOP_LTT(q, YAMOP_LTT((yamop *)(p->cs.p_code.FirstClause)) + 1); #endif /* YAPOR */ -#ifdef TABLING - if (is_tabled(p)) XXX - q->opc = Yap_opcode(_table_try_me); - else -#endif /* TABLING */ p->cs.p_code.FirstClause = q; p->cs.p_code.TrueCodeOfPred = q; if (p->PredFlags & SpiedPredFlag) { diff --git a/C/computils.c b/C/computils.c index 080acab90..b2ab6910b 100644 --- a/C/computils.c +++ b/C/computils.c @@ -624,6 +624,7 @@ static char *opformat[] = #endif /* YAPOR */ #ifdef TABLING "table_new_answer", + "table_try_single\t%g\t%x", #endif /* TABLING */ #ifdef TABLING_INNER_CUTS "clause_with_cut", diff --git a/C/dbase.c b/C/dbase.c index bc6134562..9f297a738 100644 --- a/C/dbase.c +++ b/C/dbase.c @@ -1789,10 +1789,8 @@ record_lu(PredEntry *pe, Term t, int position) LogUpdClause *cl; int needs_vars = FALSE; - WRITE_LOCK(pe->PRWLock); ipc = NEXTOP(((LogUpdClause *)NULL)->ClCode,e); if ((x = (DBTerm *)CreateDBStruct(t, NULL, 0, &needs_vars, (UInt)ipc)) == NULL) { - WRITE_UNLOCK(pe->PRWLock); return NULL; /* crash */ } cl = (LogUpdClause *)((ADDR)x-(UInt)ipc); @@ -1812,6 +1810,7 @@ record_lu(PredEntry *pe, Term t, int position) ipc->opc = Yap_opcode(_copy_idb_term); else ipc->opc = Yap_opcode(_unify_idb_term); + WRITE_LOCK(pe->PRWLock); Yap_add_logupd_clause(pe, cl, (position == MkFirst ? 2 : 0)); WRITE_UNLOCK(pe->PRWLock); return cl; @@ -1829,7 +1828,6 @@ p_rcda(void) if (!IsVarTerm(Deref(ARG3))) return (FALSE); pe = find_lu_entry(t1); - WRITE_LOCK(pe->PRWLock); restart_record: Yap_Error_Size = 0; if (pe) { @@ -4366,7 +4364,12 @@ p_instance_module(void) Term t1 = Deref(ARG1); DBRef dbr; - if (IsVarTerm(t1) || !IsDBRefTerm(t1)) { + if (IsVarTerm(t1)) { + return FALSE; + } + if (IsDBRefTerm(t1)) { + dbr = DBRefOfTerm(t1); + } else { if (IsIntegerTerm(t1)) dbr = (DBRef)IntegerOfTerm(t1); else @@ -4375,8 +4378,6 @@ p_instance_module(void) if (dbr > (DBRef)Yap_HeapBase && dbr < (DBRef)HeapTop && dbr->id != FunctorDBRef) { return FALSE; } - } else { - dbr = DBRefOfTerm(t1); } if (dbr->Flags & LogUpdMask) { LogUpdClause *cl = (LogUpdClause *)dbr; diff --git a/C/heapgc.c b/C/heapgc.c index 66bf462ef..ba13cf1bf 100644 --- a/C/heapgc.c +++ b/C/heapgc.c @@ -1490,9 +1490,9 @@ mark_choicepoints(register choiceptr gc_B, tr_fr_ptr saved_TR, int very_verbose) op_numbers caller_op = Yap_op_from_opcode(ENV_ToOp(gc_B->cp_cp)); /* first condition checks if this was a meta-call */ if ((caller_op != _call && caller_op != _fcall) || pe == NULL) { - fprintf(Yap_stderr,"[GC] marked %d (%s)\n", total_marked, op_names[opnum]); + fprintf(Yap_stderr,"[GC] marked %ld (%s)\n", total_marked, op_names[opnum]); } else - fprintf(Yap_stderr,"[GC] %s/%d marked %d (%s)\n", RepAtom(NameOfFunctor(pe->FunctorOfPred))->StrOfAE, pe->ArityOfPE, total_marked, op_names[opnum]); + fprintf(Yap_stderr,"[GC] %s/%d marked %ld (%s)\n", RepAtom(NameOfFunctor(pe->FunctorOfPred))->StrOfAE, pe->ArityOfPE, total_marked, op_names[opnum]); } break; case _trie_retry_var: @@ -1505,7 +1505,7 @@ mark_choicepoints(register choiceptr gc_B, tr_fr_ptr saved_TR, int very_verbose) case _trie_trust_list: case _trie_retry_struct: case _trie_trust_struct: - fprintf(Yap_stderr,"[GC] marked %d (%s)\n", total_marked, op_names[opnum]); + fprintf(Yap_stderr,"[GC] marked %ld (%s)\n", total_marked, op_names[opnum]); break; #endif default: @@ -1640,6 +1640,8 @@ mark_choicepoints(register choiceptr gc_B, tr_fr_ptr saved_TR, int very_verbose) break; case _table_retry_me: case _table_trust_me: + case _table_retry: + case _table_trust: { register gen_cp_ptr gcp = GEN_CP(gc_B); int nargs = rtp->u.ld.s; @@ -2312,6 +2314,8 @@ sweep_choicepoints(choiceptr gc_B) break; case _table_retry_me: case _table_trust_me: + case _table_retry: + case _table_trust: { register gen_cp_ptr gcp = GEN_CP(gc_B); int nargs; diff --git a/C/index.c b/C/index.c index e16af5117..35f88fc15 100644 --- a/C/index.c +++ b/C/index.c @@ -1550,10 +1550,13 @@ add_info(ClauseDef *clause, UInt regno) case _sync: #endif #ifdef TABLING - case _table_try_me_single: + case _table_try_single: case _table_try_me: case _table_retry_me: case _table_trust_me: + case _table_try: + case _table_retry: + case _table_trust: case _table_answer_resolution: case _table_completion: #endif @@ -1597,6 +1600,7 @@ add_info(ClauseDef *clause, UInt regno) case _getwork_first_time: #endif #ifdef TABLING + case _table_new_answer: case _trie_do_var: case _trie_trust_var: case _trie_try_var: @@ -2335,7 +2339,7 @@ emit_retry(ClauseDef *cl, PredEntry *ap, int clauses) } static compiler_vm_op -emit_optry(int var_group, int first, int clauses, int clleft) +emit_optry(int var_group, int first, int clauses, int clleft, PredEntry *ap) { /* var group */ if (var_group || clauses == 0) { @@ -2347,8 +2351,13 @@ emit_optry(int var_group, int first, int clauses, int clleft) return trust_op; } } else if (clleft == 0) { - /* last group */ - return try_op; + if (ap->PredFlags & TabledPredFlag && !first) { + /* we never actually get to remove the last choice-point in this case */ + return retry_op; + } else { + /* last group */ + return try_op; + } } else { /* nonvar group */ return try_in_op; @@ -2359,7 +2368,7 @@ emit_optry(int var_group, int first, int clauses, int clleft) static void emit_try(ClauseDef *cl, PredEntry *ap, int var_group, int first, int clauses, int clleft, UInt nxtlbl) { - compiler_vm_op comp_op = emit_optry(var_group, first, clauses, clleft); + compiler_vm_op comp_op = emit_optry(var_group, first, clauses, clleft, ap); Yap_emit(comp_op, (CELL)(cl->CurrentCode), ((clauses+clleft) << 1) | has_cut(cl->CurrentCode) ); } @@ -2635,6 +2644,25 @@ count_funcs(GroupDef *grp) static UInt emit_single_switch_case(ClauseDef *min, PredEntry *ap, int first, int clleft, UInt nxtlbl) { +#ifdef TABLING + if (ap->PredFlags & TabledPredFlag) { + /* we have two differences with tabling: + 1. we cannot allow straight jumps to clauses, otherwise thetabled + would never get to be created. + 2. we don't clean trust at the very end of computation. + */ + if (clleft == 0) { + UInt lbl = new_label(); + Yap_emit(label_op, lbl, Zero); + if (first) { + Yap_emit(table_try_single_op, (UInt)(min->CurrentCode), has_cut(cl->CurrentCode)); + } else { + Yap_emit(trust_op, (UInt)(min->CurrentCode), has_cut(cl->CurrentCode)); + } + return lbl; + } + } +#endif return (UInt)(min->CurrentCode); } @@ -2834,6 +2862,13 @@ emit_protection_choicepoint(int first, int clleft, UInt nxtlbl, PredEntry *ap) /* !first */ if (clleft) { Yap_emit(retryme_op, nxtlbl, (clleft << 1)); + } else if ((ap->PredFlags & TabledPredFlag)) { + /* + we cannot get rid of the choice-point for tabled predicates, all + kinds of hell would follow, so we just keep it around: not nice, + but should work. + */ + Yap_emit(retryme_op, (CELL)TRUSTFAILCODE, 0); } else { Yap_emit(trustme_op, 0, 0); } @@ -6178,7 +6213,7 @@ Yap_FollowIndexingCode(PredEntry *ap, yamop *ipc, Term t1, Term tb, Term tr, yam UNLOCK(cl->ClLock); } #else - if (B->cp_tr[-1] == CLREF_TO_TRENTRY(cl) && + if (TrailTerm(B->cp_tr-1) == CLREF_TO_TRENTRY(cl) && B->cp_tr > B->cp_b->cp_tr) { cl->ClFlags &= ~InUseMask; /* clear the entry from the trail */ diff --git a/C/init.c b/C/init.c index ac44f6683..5e3b05e09 100644 --- a/C/init.c +++ b/C/init.c @@ -1140,9 +1140,12 @@ Yap_InitStacks(int Heap, aux_delayed_release_load); #else /* Yap */ Yap_InitMemory (Trail, Heap, Stack); +#endif /* YAPOR || TABLING */ AtomHashTableSize = MaxHash; HashChain = (AtomHashEntry *)Yap_AllocAtomSpace(sizeof(AtomHashEntry) * MaxHash); -#endif /* YAPOR || TABLING */ + if (HashChain == NULL) { + Yap_Error(FATAL_ERROR,MkIntTerm(0),"allocating initial atom table"); + } for (i = 0; i < MaxHash; ++i) { INIT_RWLOCK(HashChain[i].AERWLock); HashChain[i].Entry = NIL; diff --git a/C/tracer.c b/C/tracer.c index b726df93b..4d18a711c 100644 --- a/C/tracer.c +++ b/C/tracer.c @@ -115,10 +115,6 @@ low_level_trace(yap_low_level_port port, PredEntry *pred, CELL *args) /* extern int gc_calls; */ vsc_count++; - if (vsc_count == 716559119LL) - vsc_xstop=1; - if (vsc_count < 716558000LL) - return; #ifdef COMMENTED if (port != enter_pred || !pred || diff --git a/H/YapOpcodes.h b/H/YapOpcodes.h index d7fe68613..994805fee 100644 --- a/H/YapOpcodes.h +++ b/H/YapOpcodes.h @@ -29,10 +29,13 @@ OPCODE(sync ,ld), #endif /* YAPOR */ #ifdef TABLING - OPCODE(table_try_me_single ,ld), OPCODE(table_try_me ,ld), OPCODE(table_retry_me ,ld), OPCODE(table_trust_me ,ld), + OPCODE(table_try_single ,ld), + OPCODE(table_try ,ld), + OPCODE(table_retry ,ld), + OPCODE(table_trust ,ld), OPCODE(table_new_answer ,s), OPCODE(table_answer_resolution ,ld), OPCODE(table_completion ,ld), diff --git a/H/compile.h b/H/compile.h index bb4968609..33eb05967 100644 --- a/H/compile.h +++ b/H/compile.h @@ -138,6 +138,7 @@ typedef enum compiler_op { #endif /* YAPOR */ #ifdef TABLING table_new_answer_op, + table_try_single_op, #endif /* TABLING */ #ifdef TABLING_INNER_CUTS clause_with_cut_op, diff --git a/H/rheap.h b/H/rheap.h index a173d1868..c2463bd06 100644 --- a/H/rheap.h +++ b/H/rheap.h @@ -648,10 +648,13 @@ RestoreClause(yamop *pc, PredEntry *pp, int mode) case _sync: #endif #ifdef TABLING - case _table_try_me_single: + case _table_try_single: case _table_try_me: case _table_retry_me: case _table_trust_me: + case _table_try: + case _table_retry: + case _table_trust: case _table_answer_resolution: case _table_completion: #endif /* TABLING */ diff --git a/OPTYap/tab.insts.i b/OPTYap/tab.insts.i index 6fe0cc722..17c2147fa 100644 --- a/OPTYap/tab.insts.i +++ b/OPTYap/tab.insts.i @@ -189,7 +189,7 @@ - PBOp(table_try_me_single, ld) + PBOp(table_try_single, ld) tab_ent_ptr tab_ent; sg_node_ptr sg_node; sg_fr_ptr sg_fr; @@ -221,7 +221,7 @@ #endif /* TABLE_LOCK_LEVEL */ LOCAL_top_sg_fr = sg_fr; store_generator_node(YENV, PREG->u.ld.s, COMPLETION, sg_fr); - PREG = NEXTOP(PREG, ld); + PREG = PREG->u.ld.d; PREFETCH_OP(PREG); allocate_environment(YENV); GONext(); @@ -386,6 +386,115 @@ ENDPBOp(); + PBOp(table_try, ld) + tab_ent_ptr tab_ent; + sg_node_ptr sg_node; + sg_fr_ptr sg_fr; + CELL *Yaddr; + + Yaddr = YENV; + check_trail(); + tab_ent = PREG->u.ld.te; +#ifdef TABLE_LOCK_AT_ENTRY_LEVEL + LOCK(TabEnt_lock(tab_ent)); +#endif /* TABLE_LOCK_LEVEL */ + sg_node = subgoal_search(tab_ent, PREG->u.ld.s, &Yaddr); + YENV = Yaddr; +#if defined(TABLE_LOCK_AT_NODE_LEVEL) + LOCK(TrNode_lock(sg_node)); +#elif defined(TABLE_LOCK_AT_WRITE_LEVEL) + LOCK_TABLE(sg_node); +#endif /* TABLE_LOCK_LEVEL */ + if (TrNode_sg_fr(sg_node) == NULL) { + /* new tabled subgoal */ + new_subgoal_frame(sg_fr, sg_node, PREG->u.ld.s, LOCAL_top_sg_fr); + TrNode_sg_fr(sg_node) = (sg_node_ptr) sg_fr; +#if defined(TABLE_LOCK_AT_ENTRY_LEVEL) + UNLOCK(TabEnt_lock(tab_ent)); +#elif defined(TABLE_LOCK_AT_NODE_LEVEL) + UNLOCK(TrNode_lock(sg_node)); +#elif defined(TABLE_LOCK_AT_WRITE_LEVEL) + UNLOCK_TABLE(sg_node); +#endif /* TABLE_LOCK_LEVEL */ + LOCAL_top_sg_fr = sg_fr; + store_generator_node(YENV, PREG->u.ld.s, NEXTOP(PREG,ld), sg_fr); + PREG = PREG->u.ld.d; + PREFETCH_OP(PREG); + allocate_environment(YENV); + GONext(); + } else { + /* tabled subgoal not new */ +#if defined(TABLE_LOCK_AT_ENTRY_LEVEL) + UNLOCK(TabEnt_lock(tab_ent)); +#elif defined(TABLE_LOCK_AT_NODE_LEVEL) + UNLOCK(TrNode_lock(sg_node)); +#elif defined(TABLE_LOCK_AT_WRITE_LEVEL) + UNLOCK_TABLE(sg_node); +#endif /* TABLE_LOCK_LEVEL */ + sg_fr = (sg_fr_ptr) TrNode_sg_fr(sg_node); + LOCK(SgFr_lock(sg_fr)); + if (SgFr_state(sg_fr)) { + /* subgoal completed */ + if (SgFr_state(sg_fr) == complete) + update_answer_trie(sg_fr); + UNLOCK(SgFr_lock(sg_fr)); + if (SgFr_first_answer(sg_fr) == NULL) { + /* no answers --> fail */ + goto fail; + } else if (SgFr_first_answer(sg_fr) == SgFr_answer_trie(sg_fr)) { + /* yes answer --> procceed */ + PREG = (yamop *) CPREG; + PREFETCH_OP(PREG); + YENV = ENV; + GONext(); + } else { + /* answers -> load first answer */ + PREG = (yamop *) TrNode_child(SgFr_answer_trie(sg_fr)); + PREFETCH_OP(PREG); + *--YENV = 0; /* vars_arity */ + *--YENV = 0; /* heap_arity */ + GONext(); + } + } else { + /* subgoal not completed */ + choiceptr leader_cp; + int leader_dep_on_stack; + find_dependency_node(sg_fr, leader_cp, leader_dep_on_stack); + UNLOCK(SgFr_lock(sg_fr)); + find_leader_node(leader_cp, leader_dep_on_stack); + store_consumer_node(YENV, sg_fr, leader_cp, leader_dep_on_stack); +#ifdef OPTYAP_ERRORS + if (PARALLEL_EXECUTION_MODE) { + choiceptr aux_cp; + aux_cp = B; + while (YOUNGER_CP(aux_cp, LOCAL_top_cp_on_stack)) + aux_cp = aux_cp->cp_b; + if (aux_cp->cp_or_fr != DepFr_top_or_fr(LOCAL_top_dep_fr)) + OPTYAP_ERROR_MESSAGE("Error on DepFr_top_or_fr (table_try_me)"); + aux_cp = B; + while (YOUNGER_CP(aux_cp, DepFr_leader_cp(LOCAL_top_dep_fr))) + aux_cp = aux_cp->cp_b; + if (aux_cp != DepFr_leader_cp(LOCAL_top_dep_fr)) + OPTYAP_ERROR_MESSAGE("Error on DepFr_leader_cp (table_try_me)"); + } +#endif /* OPTYAP_ERRORS */ + goto answer_resolution; + } + } + ENDPBOp(); + + + + Op(table_retry, ld) + restore_generator_node(B, PREG->u.ld.s, NEXTOP(PREG,ld)); + YENV = (CELL *) PROTECT_FROZEN_B(B); + set_cut(YENV, B->cp_b); + SET_BB(NORM_CP(YENV)); + allocate_environment(YENV); + PREG = PREG->u.ld.d; + GONext(); + ENDOp(); + Op(table_retry_me, ld) restore_generator_node(B, PREG->u.ld.s, PREG->u.ld.d); @@ -409,6 +518,15 @@ GONext(); ENDOp(); + Op(table_trust, ld) + restore_generator_node(B, PREG->u.ld.s, COMPLETION); + YENV = (CELL *) PROTECT_FROZEN_B(B); + set_cut(YENV, B->cp_b); + SET_BB(NORM_CP(YENV)); + allocate_environment(YENV); + PREG = PREG->u.ld.d; + GONext(); + ENDOp(); PBOp(table_new_answer, s) diff --git a/docs/yap.tex b/docs/yap.tex index db7c435c6..74d747376 100644 --- a/docs/yap.tex +++ b/docs/yap.tex @@ -4863,6 +4863,9 @@ true if the predicate is exported in the current module. @item public true if the predicate is public; note that all dynamic predicates are public. +@item tabled +true if the predicate is tabled; note that only static predicates can +be tabled in YAP. @item source true if source for the predicate is available. @item number_of_clauses(@var{ClauseCount}) diff --git a/pl/init.yap b/pl/init.yap index c0391ad45..19cb1d294 100644 --- a/pl/init.yap +++ b/pl/init.yap @@ -131,6 +131,8 @@ system_mode(verbose,off) :- set_value('$verbose',off). :- module(user). +:- current_module(X), write(X). + :- multifile goal_expansion/3. :- dynamic_predicate(goal_expansion/3, logical). @@ -157,5 +159,3 @@ library_directory(D) :- :- get_value(system_library_directory,D), assert(library_directory(D)). - - diff --git a/pl/modules.yap b/pl/modules.yap index 759231953..a01d378de 100644 --- a/pl/modules.yap +++ b/pl/modules.yap @@ -180,10 +180,7 @@ module(N) :- '$current_module'(_,N), get_value('$consulting_file',F), ( recordzifnot('$module','$module'(N),_) -> true; true), - ( recorded('$module','$module'(F,N,[]),_) -> - true ; - recorda('$module','$module'(F,N,[]),_) - ). + ( recordaifnot('$module','$module'(F,N,[]),_) -> true, true). module(N) :- '$do_error'(type_error(atom,N),module(N)). diff --git a/pl/preds.yap b/pl/preds.yap index 0e53445f8..46ee75e19 100644 --- a/pl/preds.yap +++ b/pl/preds.yap @@ -809,7 +809,10 @@ predicate_property(Pred,Prop) :- '$system_predicate'(P,M), !. '$predicate_property'(P,M,_,source) :- '$flags'(G,M,F,F), - ( F /\ 0x00400000 =\= 0 -> true ; false). + F /\ 0x00400000 =\= 0. +'$predicate_property'(P,M,_,tabled) :- + '$flags'(G,M,F,F), + F /\ 0x00000040 =\= 0. '$predicate_property'(P,M,_,dynamic) :- '$is_dynamic'(P,M). '$predicate_property'(P,M,_,static) :- diff --git a/pl/tabling.yap b/pl/tabling.yap index a279581be..b515535af 100644 --- a/pl/tabling.yap +++ b/pl/tabling.yap @@ -20,7 +20,7 @@ table(M:X) :- !, '$table'(X, M). table(X) :- - current_module(M), + '$current_module'(M), '$table'(X, M). '$table'(X, _) :- var(X), !, @@ -30,17 +30,24 @@ table(X) :- '$table'(M:A, _) :- !, '$table'(A, M). '$table'((A,B), M) :- !, '$table'(A, M), '$table'(B, M). '$table'(A/N, M) :- integer(N), atom(A), !, - functor(T,A,N), '$flags'(T,M,F,F), - ( - X is F /\ 0x1991F880, X =:= 0, !, '$do_table'(T, M) - ; - '$do_error'(permission_error(modify,static_procedure,A/N),tabled(Mod:A/N)) - ). + functor(P, A, N), + '$declare_tabled'(P, M). '$table'(X, _) :- write(user_error, '[ Error: '), - write(user_error, X), - write(user_error, ' is an invalid argument to table/1 ]'), - nl(user_error), - fail. + write(user_error, X), + write(user_error, ' is an invalid argument to table/1 ]'), + nl(user_error), + fail. + +'$declare_tabled'(P, M) :- + '$undefined'(P, M), !, + '$do_table'(P, M). +'$declare_tabled'(P, M) :- + '$flags'(P,M,F,F), + X is F /\ 0x1991F880, X =:= 0, !, + '$do_table'(P, M). +'$declare_tabled'(P, M) :- + functor(P, A, N), + '$do_error'(permission_error(modify,static_procedure,A/N),tabled(Mod:A/N)). abolish_trie(M:X) :- !, '$abolish_trie'(X, M).