From 0dc508eda00ac5a7fafeb130c0af7de61ab28f35 Mon Sep 17 00:00:00 2001 From: vsc Date: Sat, 22 Sep 2007 08:38:05 +0000 Subject: [PATCH] nb_ extra stuff plus an indexing overflow fix. git-svn-id: https://yap.svn.sf.net/svnroot/yap/trunk@1933 b08c6af1-5177-4d33-ba66-4b1c6b8b522a --- C/globals.c | 307 +++++++++++++++++------------------------------ C/index.c | 32 +++-- changes-5.1.html | 2 + docs/yap.tex | 55 ++++++++- 4 files changed, 186 insertions(+), 210 deletions(-) diff --git a/C/globals.c b/C/globals.c index f74387a91..39c03cd47 100644 --- a/C/globals.c +++ b/C/globals.c @@ -908,197 +908,6 @@ CopyTermToArena(Term t, Term arena, int share, UInt arity, Term *newarena, Term goto restart; } -static Term -AddTermToArena(Term t, Term arena, UInt arity, Term *newarena, Term *att_arenap, UInt min_grow) -{ - UInt old_size = ArenaSz(arena); - CELL *oldH = H; - CELL *oldHB = HB; - CELL *oldASP = ASP; - int res; -#if COROUTINING - Term old_delay_arena; -#endif - - restart: -#if COROUTINING - old_delay_arena = *att_arenap; -#endif - t = Deref(t); - if (IsVarTerm(t)) { - ASP = ArenaLimit(arena); - H = HB = ArenaPt(arena); -#if COROUTINING - if (IsAttachedTerm(t)) { - return 0; - } -#endif - Term tn = MkVarTerm(); - if (H > ASP - 128) { - res = -1; - goto error_handler; - } - CloseArena(oldH, oldHB, oldASP, newarena, old_size); - return tn; - } else if (IsAtomOrIntTerm(t)) { - return t; - } else if (IsPairTerm(t)) { - Term tf; - CELL *ap; - CELL *Hi; - - H = HB = ArenaPt(arena); - ASP = ArenaLimit(arena); - ap = RepPair(t); - if (H > ASP - (128+2)) { - res = -1; - goto error_handler; - } - Hi = H; - tf = AbsPair(H); - H[0] = ap[0]; - H[1] = ap[1]; - H += 2; - CloseArena(oldH, oldHB, oldASP, newarena, old_size); - return tf; - } else { - Functor f; - Term tf; - CELL *HB0; - CELL *ap; - - H = HB = ArenaPt(arena); - ASP = ArenaLimit(arena); - f = FunctorOfTerm(t); - HB0 = H; - ap = RepAppl(t); - tf = AbsAppl(H); - H[0] = (CELL)f; - if (IsExtensionFunctor(f)) { - switch((CELL)f) { - case (CELL)FunctorDBRef: - CloseArena(oldH, oldHB, oldASP, newarena, old_size); - return t; - case (CELL)FunctorLongInt: - if (H > ASP - (128+3)) { - res = -1; - goto error_handler; - } - H[1] = ap[1]; - H[2] = EndSpecials; - H += 3; - break; - case (CELL)FunctorDouble: - if (H > ASP - (128+(2+SIZEOF_DOUBLE/sizeof(CELL)))) { - res = -1; - goto error_handler; - } - H[1] = ap[1]; -#if SIZEOF_DOUBLE == 2*SIZEOF_LONG_INT - H[2] = ap[2]; - H[3] = EndSpecials; - H += 4; -#else - H[2] = EndSpecials; - H += 3; -#endif - break; - default: - { - UInt sz = ArenaSz(t), i; - - if (H > ASP - (128+sz)) { - res = -1; - goto error_handler; - } - for (i = 1; i < sz; i++) { - H[i] = ap[i]; - } - H += sz; - } - } - } else { - UInt i; - - if (H+(1+ArityOfFunctor(f)) > ASP-128) { - res = -1; - goto error_handler; - } - for (i=0; i<=ArityOfFunctor(f);i++) - *H++ = *ap++; - } - CloseArena(oldH, oldHB, oldASP, newarena, old_size); - return tf; - } - error_handler: - H = HB; - CloseArena(oldH, oldHB, oldASP, newarena, old_size); -#if COROUTINING - if (old_delay_arena != MkIntTerm(0)) - ResetDelayArena(old_delay_arena, att_arenap); -#endif - XREGS[arity+1] = t; - XREGS[arity+2] = arena; - XREGS[arity+3] = (CELL)newarena; - XREGS[arity+4] = (CELL)att_arenap; - { - CELL *old_top = ArenaLimit(*newarena); - ASP = oldASP; - H = oldH; - HB = oldHB; - switch (res) { - case -1: - if (arena == GlobalArena) - GlobalArenaOverflows++; - /* handle arena overflow */ - /* first, take care of useless stuff */ - if (!Yap_gc(arity+4, ENV, P)) { - Yap_Error(OUT_OF_STACK_ERROR,TermNil,Yap_ErrorMessage); - return 0L; - } - arena = XREGS[arity+2]; - old_top = ArenaLimit(*newarena); - if (!GrowArena(arena, old_top, old_size, min_grow, arity+4)) { - Yap_Error(OUT_OF_STACK_ERROR, TermNil, Yap_ErrorMessage); - return 0L; - } - break; -#if COROUTINING - case -3: - /* handle delay arena overflow */ - old_size = DelayArenaSz(*att_arenap); - - if (!GrowDelayArena(att_arenap, old_size, 0L, arity+4)) { - Yap_Error(OUT_OF_STACK_ERROR, TermNil, Yap_ErrorMessage); - return 0L; - } - break; -#endif - case -4: - /* handle trail overflow */ - if(!Yap_growtrail (sizeof(CELL) * 16 * 1024L, FALSE)) { - Yap_Error(OUT_OF_TRAIL_ERROR, TermNil, Yap_ErrorMessage); - return 0L; - } - break; - default: /* temporary space overflow */ - if (!Yap_ExpandPreAllocCodeSpace(0,NULL)) { - Yap_Error(OUT_OF_AUXSPACE_ERROR, TermNil, Yap_ErrorMessage); - return 0L; - } - } - } - oldH = H; - oldHB = HB; - oldASP = ASP; - att_arenap = (Term *)XREGS[arity+4]; - newarena = (CELL *)XREGS[arity+3]; - arena = Deref(XREGS[arity+2]); - t = XREGS[arity+1]; - old_size = ArenaSz(arena); - goto restart; -} - inline static GlobalEntry * FindGlobalEntry(Atom at) /* get predicate entry for ap/arity; create it if neccessary. */ @@ -1174,22 +983,119 @@ garena_overflow_size(CELL *arena) } static Int -p_nb_copyterm(void) +p_nb_setarg(void) { - Term to = CopyTermToArena(ARG1, GlobalArena, TRUE, 2, &GlobalArena, &GlobalDelayArena, garena_overflow_size(ArenaPt(GlobalArena))); + Term wheret = Deref(ARG1); + Term dest = Deref(ARG2); + Term to; + UInt arity, pos; + CELL *destp; + + if (IsVarTerm(wheret)) { + Yap_Error(INSTANTIATION_ERROR,wheret,"nb_setarg"); + return FALSE; + } + if (!IsIntegerTerm(wheret)) { + Yap_Error(TYPE_ERROR_INTEGER,wheret,"nb_setarg"); + return FALSE; + } + pos = IntegerOfTerm(wheret); + if (IsVarTerm(dest)) { + Yap_Error(INSTANTIATION_ERROR,dest,"nb_setarg"); + return FALSE; + } else if (IsPrimitiveTerm(dest)) { + arity = 0; + destp = NULL; + } else if (IsPairTerm(dest)) { + arity = 2; + destp = RepPair(dest)-1; + } else { + arity = ArityOfFunctor(FunctorOfTerm(dest)); + destp = RepAppl(dest); + } + if (pos < 1 || pos > arity) + return FALSE; + to = CopyTermToArena(ARG3, GlobalArena, FALSE, 2, &GlobalArena, &GlobalDelayArena, garena_overflow_size(ArenaPt(GlobalArena))); if (to == 0L) return FALSE; - return Yap_unify(ARG2,to); + destp[pos] = to; + return TRUE; } static Int -p_nb_maketerm(void) +p_nb_set_shared_arg(void) { - Term to = Deref(ARG1); - to = AddTermToArena(ARG1, GlobalArena, 2, &GlobalArena, &GlobalDelayArena, garena_overflow_size(ArenaPt(GlobalArena))); + Term wheret = Deref(ARG1); + Term dest = Deref(ARG2); + Term to; + UInt arity, pos; + CELL *destp; + + if (IsVarTerm(wheret)) { + Yap_Error(INSTANTIATION_ERROR,wheret,"nb_setarg"); + return FALSE; + } + if (!IsIntegerTerm(wheret)) { + Yap_Error(TYPE_ERROR_INTEGER,wheret,"nb_setarg"); + return FALSE; + } + pos = IntegerOfTerm(wheret); + if (IsVarTerm(dest)) { + Yap_Error(INSTANTIATION_ERROR,dest,"nb_setarg"); + return FALSE; + } else if (IsPrimitiveTerm(dest)) { + arity = 0; + destp = NULL; + } else if (IsPairTerm(dest)) { + arity = 2; + destp = RepPair(dest)-1; + } else { + arity = ArityOfFunctor(FunctorOfTerm(dest)); + destp = RepAppl(dest); + } + if (pos < 1 || pos > arity) + return FALSE; + to = CopyTermToArena(ARG3, GlobalArena, TRUE, 2, &GlobalArena, &GlobalDelayArena, garena_overflow_size(ArenaPt(GlobalArena))); if (to == 0L) return FALSE; - return Yap_unify(ARG2,to); + destp[pos] = to; + return TRUE; +} + +static Int +p_nb_linkarg(void) +{ + Term wheret = Deref(ARG1); + Term dest = Deref(ARG2); + UInt arity, pos; + CELL *destp; + + if (IsVarTerm(wheret)) { + Yap_Error(INSTANTIATION_ERROR,wheret,"nb_setarg"); + return FALSE; + } + if (!IsIntegerTerm(wheret)) { + Yap_Error(TYPE_ERROR_INTEGER,wheret,"nb_setarg"); + return FALSE; + } + pos = IntegerOfTerm(wheret); + if (IsVarTerm(dest)) { + Yap_Error(INSTANTIATION_ERROR,dest,"nb_setarg"); + return FALSE; + } else if (IsPrimitiveTerm(dest)) { + arity = 0; + destp = NULL; + } else if (IsPairTerm(dest)) { + arity = 2; + destp = RepPair(dest)-1; + } else { + arity = ArityOfFunctor(FunctorOfTerm(dest)); + destp = RepAppl(dest); + } + if (pos < 1 || pos > arity) + return FALSE; + destp[pos] = Deref(ARG3); + return TRUE; } static Int @@ -2480,12 +2386,13 @@ void Yap_InitGlobals(void) Yap_InitCPred("arena_size", 1, p_default_arena_size, 0); Yap_InitCPred("b_setval", 2, p_b_setval, SafePredFlag); Yap_InitCPred("b_getval", 2, p_nb_getval, SafePredFlag); - Yap_InitCPred("nb_copy_term", 2, p_nb_copyterm, 0L); - Yap_InitCPred("nb_make_term", 2, p_nb_maketerm, 0L); Yap_InitCPred("nb_setval", 2, p_nb_setval, 0L); Yap_InitCPred("nb_set_shared_val", 2, p_nb_set_shared_val, 0L); Yap_InitCPred("nb_linkval", 2, p_nb_linkval, 0L); Yap_InitCPred("nb_getval", 2, p_nb_getval, SafePredFlag); + Yap_InitCPred("nb_setarg", 3, p_nb_setarg, 0L); + Yap_InitCPred("nb_set_shared_arg", 3, p_nb_set_shared_arg, 0L); + Yap_InitCPred("nb_linkarg", 3, p_nb_linkarg, 0L); Yap_InitCPred("nb_delete", 1, p_nb_delete, 0L); Yap_InitCPredBack("$nb_current", 1, 1, init_current_nb, cont_current_nb, SafePredFlag); CurrentModule = GLOBALS_MODULE; diff --git a/C/index.c b/C/index.c index 6aeff6f8a..e01363ef8 100644 --- a/C/index.c +++ b/C/index.c @@ -11,8 +11,11 @@ * File: index.c * * comments: Indexing a Prolog predicate * * * -* Last rev: $Date: 2007-06-20 13:48:45 $,$Author: vsc $ * +* Last rev: $Date: 2007-09-22 08:38:05 $,$Author: vsc $ * * $Log: not supported by cvs2svn $ +* Revision 1.186 2007/06/20 13:48:45 vsc +* fix bug in index emulator +* * Revision 1.185 2007/05/02 11:01:37 vsc * get rid of type punning warnings. * @@ -3338,7 +3341,7 @@ valid_instructions(yamop *end, yamop *cl) } static UInt -groups_in(ClauseDef *min, ClauseDef *max, GroupDef *grp) +groups_in(ClauseDef *min, ClauseDef *max, GroupDef *grp, struct intermediates *cint) { UInt groups = 0; @@ -3392,6 +3395,21 @@ groups_in(ClauseDef *min, ClauseDef *max, GroupDef *grp) } groups++; grp++; + while (grp+16 > (GroupDef *)Yap_TrailTop) { + UInt sz = (groups+16)*sizeof(GroupDef); +#if USE_SYSTEM_MALLOC + Yap_Error_Size = sz; + /* grow stack */ + save_machine_regs(); + longjmp(cint->CompilerBotch,4); +#else + if (!Yap_growtrail(sz, TRUE)) { + save_machine_regs(); + longjmp(cint->CompilerBotch,4); + return 0; + } +#endif + } } return groups; } @@ -4365,7 +4383,7 @@ do_index(ClauseDef *min, ClauseDef* max, struct intermediates *cint, UInt argno, } else { found_pvar = cls_info(min, max, argno); } - ngroups = groups_in(min, max, group); + ngroups = groups_in(min, max, group, cint); if (IsVarTerm(t)) { lablx = new_label(cint); Yap_emit(label_op, lablx, Zero, cint); @@ -4390,7 +4408,7 @@ do_index(ClauseDef *min, ClauseDef* max, struct intermediates *cint, UInt argno, } else { found_pvar = cls_info(min, max, argno); } - ngroups = groups_in(min, max, group); + ngroups = groups_in(min, max, group, cint); } labl0 = labl = new_label(cint); } else { @@ -4527,7 +4545,7 @@ do_compound_index(ClauseDef *min0, ClauseDef* max0, Term* sreg, struct intermedi cl++; } group = (GroupDef *)top; - ngroups = groups_in(min, max, group); + ngroups = groups_in(min, max, group, cint); if (ngroups == 1 && group->VarClauses == 0) { /* ok, we are doing a sub-argument */ /* process group */ @@ -4566,7 +4584,7 @@ do_dbref_index(ClauseDef *min, ClauseDef* max, Term t, struct intermediates *cin cl->Tag = cl->u.t_ptr; cl++; } - ngroups = groups_in(min, max, group); + ngroups = groups_in(min, max, group, cint); if (ngroups > 1 || group->VarClauses) { return do_index(min, max, cint, argno+1, fail_l, first, clleft, top); } else { @@ -4603,7 +4621,7 @@ do_blob_index(ClauseDef *min, ClauseDef* max, Term t, struct intermediates *cint } cl++; } - ngroups = groups_in(min, max, group); + ngroups = groups_in(min, max, group, cint); if (ngroups > 1 || group->VarClauses) { return do_index(min, max, cint, argno+1, fail_l, first, clleft, top); } else { diff --git a/changes-5.1.html b/changes-5.1.html index 0a671d4f8..69d670b40 100644 --- a/changes-5.1.html +++ b/changes-5.1.html @@ -16,6 +16,8 @@

Yap-5.1.3: