From 3d10482cc7b225a3e07d3e26428d69e60b446cff Mon Sep 17 00:00:00 2001 From: Vitor Santos Costa Date: Wed, 10 Mar 2010 14:06:07 +0000 Subject: [PATCH] more upgrades to new coroutining code. --- C/attvar.c | 69 ++++++++++++++++++++++++++++++++++++++++++++++++--- C/heapgc.c | 44 ++++++++++++++++++++++---------- C/utilpreds.c | 43 ++++++++++++++------------------ pl/corout.yap | 56 ++++++++++++++++++++++++++++++----------- 4 files changed, 157 insertions(+), 55 deletions(-) diff --git a/C/attvar.c b/C/attvar.c index 7c48d50f9..e64073917 100644 --- a/C/attvar.c +++ b/C/attvar.c @@ -79,7 +79,6 @@ BuildNewAttVar(void) RESET_VARIABLE(&(newv->Value)); RESET_VARIABLE(&(newv->Done)); RESET_VARIABLE(&(newv->Atts)); - HB = PROTECT_FROZEN_H(B); return newv; } @@ -104,7 +103,6 @@ CopyAttVar(CELL *orig, struct cp_frame **to_visit_ptr, CELL *res) to_visit->to = &(newv->Atts); } to_visit->oldv = vt[-1]; - /* you're coming from a variable */ to_visit->ground = FALSE; *to_visit_ptr = to_visit+1; *res = (CELL)&(newv->Done); @@ -879,10 +877,75 @@ p_swi_all_atts(void) { } } + +static Term +AllAttVars(void) { + CELL *pt = H0; + CELL *myH = H; + + while (pt < H) { + switch(*pt) { + case (CELL)FunctorAttVar: + if (IsUnboundVar(pt+1)) { + if (ASP - myH < 1024) { + Yap_Error_Size = (ASP-H)*sizeof(CELL); + return 0L; + } + if (myH != H) { + myH[-1] = AbsPair(myH); + } + myH[0] = AbsAttVar((attvar_record *)pt); + myH += 2; + } + pt += (1+ATT_RECORD_ARITY); + break; + case (CELL)FunctorDouble: +#if SIZEOF_DOUBLE == 2*SIZEOF_LONG_INT + pt += 4; +#else + pt += 3; +#endif + break; + case (CELL)FunctorBigInt: + { + Int sz = 3 + + (sizeof(MP_INT)+ + (((MP_INT *)(pt+2))->_mp_alloc*sizeof(mp_limb_t)))/sizeof(CELL); + pt += sz; + } + break; + case (CELL)FunctorLongInt: + pt += 3; + break; + default: + pt++; + } + } + if (myH != H) { + Term out = AbsPair(H); + myH[-1] = TermNil; + H = myH; + return out; + } else { + return TermNil; + } +} + static Int p_all_attvars(void) { - return Yap_unify(ARG1,TermNil); + do { + Term out; + + if (!(out = AllAttVars())) { + if (!Yap_gcl(Yap_Error_Size, 1, ENV, gc_P(P,CP))) { + Yap_Error(OUT_OF_STACK_ERROR, TermNil, Yap_ErrorMessage); + return FALSE; + } + } else { + return Yap_unify(ARG1,out); + } + } while (TRUE); } static Int diff --git a/C/heapgc.c b/C/heapgc.c index 8beccde02..d7c62b97f 100644 --- a/C/heapgc.c +++ b/C/heapgc.c @@ -1150,6 +1150,33 @@ check_global(void) { /* mark a heap object and all heap objects accessible from it */ +static void +mark_variable(CELL_PTR current); + +static void +mark_att_var(CELL *hp) +{ + if (!MARKED_PTR(hp-1)) { + MARK(hp-1); + PUSH_POINTER(hp-1); + total_marked++; + if (hp < HGEN) { + total_oldies++; + } + } + if (!MARKED_PTR(hp)) { + MARK(hp); + PUSH_POINTER(hp); + total_marked++; + if (hp < HGEN) { + total_oldies++; + } + } + mark_variable(hp+1); + mark_variable(hp+2); +} + + static void mark_variable(CELL_PTR current) { @@ -1173,7 +1200,10 @@ mark_variable(CELL_PTR current) next = GET_NEXT(ccur); if (IsVarTerm(ccur)) { - if (ONHEAP(next)) { + if (IsAttVar(current) && current==next) { + mark_att_var(current); + POP_CONTINUATION(); + } else if (ONHEAP(next)) { #ifdef EASY_SHUNTING CELL cnext; /* do variable shunting between variables in the global */ @@ -1576,18 +1606,6 @@ mark_environments(CELL_PTR gc_ENV, OPREG size, CELL *pvbmap) } } -static void -mark_att_var(CELL *hp) -{ - attvar_record *attv = RepAttVar(hp); - Functor *cptr = &(attv->AttFunc); - mark_external_reference2(CellPtr(cptr)); - mark_external_reference2(&attv->Done); - mark_external_reference2(&attv->Value); - mark_external_reference2(&attv->Atts); -} - - /* Cleaning the trail should be quick and simple, right? Well, not really :-(. The problem is that the trail includes a dumping ground diff --git a/C/utilpreds.c b/C/utilpreds.c index f478822f8..3d81fbc47 100644 --- a/C/utilpreds.c +++ b/C/utilpreds.c @@ -69,8 +69,11 @@ clean_dirty_tr(tr_fr_ptr TR0) { RESET_VARIABLE(p); } else { /* copy downwards */ +#ifdef FROZEN_STACKS +#else TrailTerm(TR0+1) = TrailTerm(pt); TrailTerm(TR0) = TrailTerm(TR0+2) = p; +#endif pt+=2; TR0 += 3; } @@ -89,7 +92,7 @@ copy_complex_term(CELL *pt0, CELL *pt0_end, int share, int newattvs, CELL *ptf, tr_fr_ptr TR0 = TR; int ground = TRUE; #ifdef COROUTINING - CELL *dvars = NULL; + CELL *dvarsmin = NULL, *dvarsmax=NULL; #endif HB = HLow; @@ -251,32 +254,25 @@ copy_complex_term(CELL *pt0, CELL *pt0_end, int share, int newattvs, CELL *ptf, #if COROUTINING if (newattvs && IsAttachedTerm((CELL)ptd0)) { /* if unbound, call the standard copy term routine */ - struct cp_frame *bp[1]; + struct cp_frame *bp; - if (dvars == NULL) { - dvars = H0; - } - if (ptd0 < dvars) { + if (IN_BETWEEN(dvarsmin, ptd0, dvarsmax)) { *ptf++ = (CELL) ptd0; } else { - tr_fr_ptr CurTR; + CELL new; - CurTR = TR; - bp[0] = to_visit; - HB = HB0; - if (!attas[ExtFromCell(ptd0)].copy_term_op(ptd0, bp, ptf)) { + bp = to_visit; + if (!attas[ExtFromCell(ptd0)].copy_term_op(ptd0, &bp, ptf)) { goto overflow; } - to_visit = bp[0]; - HB = HLow; - ptf++; - if (TR > (tr_fr_ptr)Yap_TrailTop - 256) { - /* Trail overflow */ - if (!Yap_growtrail((TR-TR0)*sizeof(tr_fr_ptr *), TRUE)) { - goto trail_overflow; - } + to_visit = bp; + new = *ptf; + Bind(ptd0, new); + if (dvarsmin == NULL) { + dvarsmin = CellPtr(new); } - Bind(ptd0, ptf[-1]); + dvarsmax = CellPtr(new)+1; + ptf++; } } else { #endif @@ -288,8 +284,7 @@ copy_complex_term(CELL *pt0, CELL *pt0_end, int share, int newattvs, CELL *ptf, goto trail_overflow; } } - Bind(ptd0, (CELL)ptf); - ptf++; + Bind(ptd0, (CELL)ptf++); #ifdef COROUTINING } #endif @@ -320,8 +315,8 @@ copy_complex_term(CELL *pt0, CELL *pt0_end, int share, int newattvs, CELL *ptf, } /* restore our nice, friendly, term to its original state */ - HB = HB0; clean_dirty_tr(TR0); + HB = HB0; return ground; overflow: @@ -521,7 +516,7 @@ Yap_CopyTermNoShare(Term inp) { static Int p_copy_term(void) /* copy term t to a new instance */ { - Term t = CopyTerm(ARG1, 2, TRUE, TRUE); +v Term t = CopyTerm(ARG1, 2, TRUE, TRUE); if (t == 0L) return FALSE; /* be careful, there may be a stack shift here */ diff --git a/pl/corout.yap b/pl/corout.yap index d5d8b0521..21509fcea 100644 --- a/pl/corout.yap +++ b/pl/corout.yap @@ -37,27 +37,17 @@ '$show_frozen_goals'(Level))). '$project_and_delayed_goals'(G,LGs) :- - '$att_vars'(G, LAV), + attributes:all_attvars(LAV), LAV = [_|_], !, % SICStus compatible step, % just try to simplify store by projecting constraints % over query variables. '$project_attributes'(LAV, G), % now get a list of frozen goals. - '$att_vars'(G, NLAV), + attributes:all_attvars(NLAV), '$get_goalist_from_attvars'(NLAV, LGs). '$project_and_delayed_goals'(_,[]). -'$att_vars'(Term, LAV) :- - term_variables(Term, TVars), - '$select_atts'(TVars, LAV). - -'$select_atts'([], []). -'$select_atts'(V.TVars, V.LAV) :- - attvar(V), !, - '$select_atts'(TVars, LAV). -'$select_atts'(V.TVars, LAV) :- - '$select_atts'(TVars, LAV). % % wake_up_goal is called by the system whenever a suspended goal @@ -563,8 +553,7 @@ frozen(V, LG) :- '$fetch_same_done_goals'(G0, D0, LV, GF). -/* -call_residue_vars(Goal,Vars) :- +call_residue_vars(Goal,Residue) :- attributes:all_attvars(Vs0), call(Goal), attributes:all_attvars(Vs), @@ -586,13 +575,50 @@ call_residue_vars(Goal,Vars) :- ; '$ord_remove'([V1|Vss], Vs0s, Residue) ). -*/ copy_term(Term, Copy, Goals) :- term_variables(Term, TVars), '$get_goalist_from_attvars'(TVars, Goals0), copy_term_nat([Term|Goals0], [Copy|Goals]). +call_residue(Goal,Residue) :- + var(Goal), !, + '$do_error'(instantiation_error,call_residue(Goal,Residue)). +call_residue(Module:Goal,Residue) :- + atom(Module), !, + '$call_residue'(Goal,Module,Residue). +call_residue(Goal,Residue) :- + '$current_module'(Module), + '$call_residue'(Goal,Module,Residue). + +'$call_residue'(Goal,Module,Residue) :- + '$read_svar_list'(OldAttsList), + copy_term_nat(Goal, NGoal), + ( '$set_svar_list'(CurrentAttsList), + '$system_catch'(NGoal,Module,Error,'$residue_catch_trap'(Error,OldAttsList)), + '$project_and_delayed_goals'(NGoal,Residue0), + '$add_vs_to_vlist'(Residue0, Residue), + ( '$set_svar_list'(OldAttsList), + copy_term_nat(NGoal+NResidue, Goal+Residue) + ; + '$set_svar_list'(CurrentAttsList), fail + ) + ; + '$set_svar_list'(OldAttsList), fail + ). + +'$add_vs_to_vlist'([], []). +'$add_vs_to_vlist'([G|Residue0], [Vs-G|Residue]) :- + term_variables(G, TVs), + '$pick_att_vars'(TVs, Vs), + '$add_vs_to_vlist'(Residue0, Residue). + + +% make sure we set the suspended goal list to its previous state! +'$residue_catch_trap'(Error,OldAttsList) :- + '$set_svar_list'(OldAttsList), + throw(Error). + % make sure we have installed a SICStus like constraint solver. '$project_attributes'(_, _) :- '$undefined'(modules_with_attributes(_),attributes), !.