From 7b77c87b94c96fb5b27564856330e9589db412f4 Mon Sep 17 00:00:00 2001 From: vsc Date: Mon, 17 Dec 2001 18:31:11 +0000 Subject: [PATCH] store constraints in DB git-svn-id: https://yap.svn.sf.net/svnroot/yap/trunk@233 b08c6af1-5177-4d33-ba66-4b1c6b8b522a --- C/absmi.c | 4 +- C/arith0.c | 11 ++++ C/attvar.c | 45 +++++++++++++++ C/corout.c | 53 +++++++++++++++++ C/dbase.c | 136 +++++++++++++++++++++++++++++++++++++------- C/init.c | 1 + C/save.c | 33 +++++++---- C/tracer.c | 2 +- H/Heap.h | 4 +- m4/TermExt.h.m4 | 5 +- m4/Yap.h.m4 | 4 +- m4/Yatom.h.m4 | 3 + pl/boot.yap | 66 +++++++++++++++++---- pl/corout.yap | 3 +- pl/load_foreign.yap | 2 +- 15 files changed, 320 insertions(+), 52 deletions(-) diff --git a/C/absmi.c b/C/absmi.c index 3906c791d..a10d8b86d 100644 --- a/C/absmi.c +++ b/C/absmi.c @@ -1790,8 +1790,8 @@ absmi(int inp) /* find something to fool S */ if (CFREG == Unsigned(LCL0) && ReadTimedVar(WokenGoals) != TermNil) { SREG = (CELL *)RepPredProp(GetPredPropByFunc(MkFunctor(AtomRestoreRegs,2),0)); - PREG = NEXTOP(PREG,x); XREGS[0] = XREG(PREG->u.y.y); + PREG = NEXTOP(PREG,y); goto creep_either; } /* don't do debugging and friends here */ @@ -1802,7 +1802,6 @@ absmi(int inp) /* find something to fool S */ if (CFREG == Unsigned(LCL0) && ReadTimedVar(WokenGoals) != TermNil) { SREG = (CELL *)RepPredProp(GetPredPropByFunc(MkFunctor(AtomRestoreRegs,2),0)); - PREG = NEXTOP(PREG,x); #if USE_THREADED_CODE if (PREG->opc == (OPCODE)OpAddress[_fcall]) #else @@ -1819,6 +1818,7 @@ absmi(int inp) ENDCACHE_Y_AS_ENV(); } XREGS[0] = XREG(PREG->u.x.x); + PREG = NEXTOP(PREG,x); goto creep_either; } /* don't do debugging and friends here */ diff --git a/C/arith0.c b/C/arith0.c index d1f897a1f..d4dda1664 100644 --- a/C/arith0.c +++ b/C/arith0.c @@ -143,6 +143,16 @@ p_b(E_ARGS) #endif } +static E_FUNC +p_env(E_ARGS) +{ +#if SBA + RINT((Int)YENV); +#else + RINT(YENV - (CELL *)B); +#endif +} + static E_FUNC p_globalsp(E_ARGS) { @@ -178,6 +188,7 @@ static InitConstEntry InitConstTab[] = { {"local_sp", p_localsp}, {"global_sp", p_globalsp}, {"$last_choice_pt", p_b}, + {"$env", p_env}, {"stackfree", p_stackfree}, }; diff --git a/C/attvar.c b/C/attvar.c index a0c8789a3..790df693d 100644 --- a/C/attvar.c +++ b/C/attvar.c @@ -31,6 +31,8 @@ static char SccsId[]="%W% %G%"; #endif STATIC_PROTO(Term InitVarTime, (void)); +STATIC_PROTO(Int PutAtt, (attvar_record *,Int,Term)); +STATIC_PROTO(Int BuildNewAttVar, (Term,Int,Term)); static CELL * AddToQueue(attvar_record *attv) @@ -137,6 +139,47 @@ CopyAttVar(CELL *orig, CELL ***to_visit_ptr, CELL *res) return(TRUE); } +static Term +AttVarToTerm(CELL *orig) +{ + register attvar_record *attv = (attvar_record *)orig; + Term list = TermNil; + int j; + for (j = 0; j < NUM_OF_ATTS; j++) { + Term t = attv->Atts[2*(NUM_OF_ATTS-j-1)+1]; + if (IsVarTerm(t)) + list = MkPairTerm(MkVarTerm(),list); + else + list = MkPairTerm(t,list); + } + return(list); +} + +static int +TermToAttVar(Term attvar, Term to) +{ + int i = 0; + int open = FALSE; + + while (IsPairTerm(attvar)) { + Term t = HeadOfTerm(attvar); + if (!IsVarTerm(t)) { + if (open) { + attvar_record *attv = (attvar_record *)VarOfTerm(Deref(to)); + if (!PutAtt(attv, i, t)) + return(FALSE); + } else { + if (!BuildNewAttVar(to, i, t)) + return(FALSE); + open = TRUE; + } + } + i++; + attvar = TailOfTerm(attvar); + } + return(TRUE); +} + static void WakeAttVar(CELL* pt1, CELL reg2) { @@ -578,6 +621,8 @@ void InitAttVarPreds(void) { attas[attvars_ext].bind_op = WakeAttVar; attas[attvars_ext].copy_term_op = CopyAttVar; + attas[attvars_ext].to_term_op = AttVarToTerm; + attas[attvars_ext].term_to_op = TermToAttVar; #ifndef FIXED_STACKS attas[attvars_ext].mark_op = mark_attvar; #endif diff --git a/C/corout.c b/C/corout.c index 30dab7c55..47ed1ad71 100644 --- a/C/corout.c +++ b/C/corout.c @@ -342,6 +342,57 @@ CopySuspendedVar(CELL *orig, CELL ***to_visit_ptr, CELL *res) return(TRUE); } +static Term +mk_sus_var_list(sus_record *sr, sus_record *osr) +{ + if (sr == osr) + return(TermNil); + return(MkPairTerm(sr->SG, mk_sus_var_list(sr->NR, sr))); +} + +static Term +SuspendedVarToTerm(CELL *orig) +{ + register sus_tag *sreg = (sus_tag *)orig; + + return(MkPairTerm(sreg->SG->SG, mk_sus_var_list(sreg->SG->NR, sreg->SG))); +} + +static sus_record * +terms_to_suspended_goals(Term gl) +{ + sus_record *gf; + gf = (sus_record *)H; + H += sizeof(sus_record)/sizeof(CELL); +#ifdef MULTI_ASSIGNMENT_VARIABLES + gf->NS = UpdateSVarList(gf); +#endif + gf->SG = HeadOfTerm(gl); + gl = TailOfTerm(gl); + if (gl == TermNil) { + gf->NR = (sus_record *)&(gf->NR); + } else { + gf->NR = terms_to_suspended_goals(gl); + } + return(gf); +} + +static int +TermToSuspendedVar(Term gs, Term var) +{ + register sus_tag *vs; + /* add a new suspension */ + vs = (sus_tag *)ReadTimedVar(DelayedVars); + if (H0 - (CELL *)vs < 1024) + return(FALSE); + RESET_VARIABLE(&(vs->ActiveSus)); + vs->sus_id = susp_ext; + vs->SG = terms_to_suspended_goals(gs); + unify(var,(CELL)&(vs->ActiveSus)); + UpdateTimedVar(DelayedVars, (CELL)(vs+1)); + return(TRUE); +} + #ifndef FIXED_STACKS @@ -1155,6 +1206,8 @@ void InitCoroutPreds(void) attas[susp_ext].bind_op = Wake; attas[susp_ext].copy_term_op = CopySuspendedVar; + attas[susp_ext].to_term_op = SuspendedVarToTerm; + attas[susp_ext].term_to_op = TermToSuspendedVar; #ifndef FIXED_STACKS attas[susp_ext].mark_op = mark_suspended_goal; #endif /* FIXED_STACKS */ diff --git a/C/dbase.c b/C/dbase.c index 8ea2c8599..8ba945e07 100644 --- a/C/dbase.c +++ b/C/dbase.c @@ -57,7 +57,6 @@ static char SccsId[] = "%W% %G%"; */ - #ifdef KEEP_ENTRY_AGE #define DISCONNECT_OLD_ENTRIES 1 #else @@ -199,7 +198,11 @@ STATIC_PROTO(CELL *linkcells,(CELL *,Int)); STATIC_PROTO(Int cmpclls,(CELL *,CELL *,Int)); STATIC_PROTO(Prop FindDBProp,(AtomEntry *, int, unsigned int, SMALLUNSGN)); STATIC_PROTO(CELL CalcKey, (Term)); +#ifdef COROUTINING +STATIC_PROTO(CELL *MkDBTerm, (CELL *, CELL *, CELL *, CELL *, CELL *, CELL *,int *)); +#else STATIC_PROTO(CELL *MkDBTerm, (CELL *, CELL *, CELL *, CELL *, CELL *, int *)); +#endif STATIC_PROTO(DBRef CreateDBStruct, (Term, DBProp, int)); STATIC_PROTO(DBRef new_lu_index, (LogUpdDBProp)); STATIC_PROTO(void clean_lu_index, (DBRef)); @@ -450,7 +453,10 @@ CELL EvalMasks(register Term tm, CELL *keyp) { - if (IsApplTerm(tm)) { + if (IsVarTerm(tm)) { + *keyp = 0L; + return(0L); + } else if (IsApplTerm(tm)) { Functor fun = FunctorOfTerm(tm); if (IsExtensionFunctor(fun)) { @@ -583,6 +589,9 @@ typedef struct { static CELL *MkDBTerm(register CELL *pt0, register CELL *pt0_end, register CELL *StoPoint, CELL *CodeMax, CELL *tbase, +#ifdef COROUTINING + CELL *attachmentsp, +#endif int *vars_foundp) { @@ -592,6 +601,10 @@ static CELL *MkDBTerm(register CELL *pt0, register CELL *pt0_end, CELL **to_visit_base = to_visit; /* where we are going to add a new pair */ int vars_found = 0; +#ifdef COROUTINING + Term ConstraintsTerm = TermNil; + CELL *ConstraintsBottom = NULL; +#endif loop: while (pt0 <= pt0_end) { @@ -794,19 +807,20 @@ static CELL *MkDBTerm(register CELL *pt0, register CELL *pt0_end, /* the code to dereference a variable */ deref_var: - if (!MARKED(d0)) - { + if (!MARKED(d0)) { + if ( #if SBA - if (d0 != 0) { + d0 != 0 #else - if (d0 != (CELL)ptd0) { + d0 != (CELL)ptd0 #endif - ptd0 = (Term *) d0; - d0 = *ptd0; - goto restart; /* continue dereferencing */ - } - /* else just drop to found_var */ + ) { + ptd0 = (Term *) d0; + d0 = *ptd0; + goto restart; /* continue dereferencing */ } + /* else just drop to found_var */ + } /* else just drop to found_var */ { CELL displacement = (CELL)(StoPoint)-(CELL)(tbase); @@ -822,7 +836,7 @@ static CELL *MkDBTerm(register CELL *pt0, register CELL *pt0_end, /* variables need to be offset at read time */ *ptd0 = (displacement | MBIT); #if SBA - /* the copy we keep will be an empty vaiable */ + /* the copy we keep will be an empty variable */ *StoPoint++ = 0; #else #ifdef IDB_USE_MBIT @@ -839,6 +853,30 @@ static CELL *MkDBTerm(register CELL *pt0, register CELL *pt0_end, #endif /* indicate we found variables */ vars_found++; +#ifdef COROUTINING + if (IsAttachedTerm((CELL)ptd0)) { + Term t[4]; + int sz = to_visit-to_visit_base; + + H = (CELL *)to_visit; + /* store the constraint away for now */ + t[0] = (CELL)ptd0; + t[1] = attas[ExtFromCell(ptd0)].to_term_op(ptd0); + t[2] = MkIntegerTerm(ExtFromCell(ptd0)); + t[3] = TermNil; + if (ConstraintsBottom == NULL) { + ConstraintsTerm = MkApplTerm(FunctorClist, 4, t); + ConstraintsBottom = RepAppl(ConstraintsTerm)+4; + } else { + Term new = MkApplTerm(FunctorClist, 4, t); + *ConstraintsBottom = new; + ConstraintsBottom = RepAppl(new)+4; + } + memcpy((void *)(H), (void *)(to_visit_base), sz*sizeof(CELL *)); + to_visit_base = (CELL **)H; + to_visit = to_visit_base+sz; + } +#endif continue; } else { /* references need to be offset at read time */ @@ -861,7 +899,7 @@ static CELL *MkDBTerm(register CELL *pt0, register CELL *pt0_end, } /* Do we still have compound terms to visit */ - if (to_visit > (CELL **)to_visit_base) { + if (to_visit > to_visit_base) { #ifdef RATIONAL_TREES to_visit -= 4; pt0 = to_visit[0]; @@ -877,6 +915,18 @@ static CELL *MkDBTerm(register CELL *pt0, register CELL *pt0_end, goto loop; } +#ifdef COROUTINING + /* we still may have constraints to do */ + if (ConstraintsTerm != TermNil) { + *attachmentsp = (CELL)(CodeMax)-(CELL)(tbase); + pt0 = RepAppl(ConstraintsTerm)+1; + pt0_end = RepAppl(ConstraintsTerm)+4; + ConstraintsTerm = TermNil; + StoPoint = CodeMax; + CodeMax += 4; + goto loop; + } +#endif /* we're done */ *vars_foundp = vars_found; UNWIND_CUNIF(); @@ -886,7 +936,7 @@ static CELL *MkDBTerm(register CELL *pt0, register CELL *pt0_end, DBErrorFlag = OVF_ERROR_IN_DB; *vars_foundp = vars_found; #ifdef RATIONAL_TREES - while (to_visit > (CELL **)to_visit_base) { + while (to_visit > to_visit_base) { to_visit -= 4; pt0 = to_visit[0]; pt0_end = to_visit[1]; @@ -901,7 +951,7 @@ static CELL *MkDBTerm(register CELL *pt0, register CELL *pt0_end, DBErrorFlag = SOVF_ERROR_IN_DB; *vars_foundp = vars_found; #ifdef RATIONAL_TREES - while (to_visit > (CELL **)to_visit_base) { + while (to_visit > to_visit_base) { to_visit -= 4; pt0 = to_visit[0]; pt0_end = to_visit[1]; @@ -917,7 +967,7 @@ static CELL *MkDBTerm(register CELL *pt0, register CELL *pt0_end, DBErrorFlag = TOVF_ERROR_IN_DB; \ *vars_foundp = vars_found; #ifdef RATIONAL_TREES - while (to_visit > (CELL **)to_visit_base) { + while (to_visit > to_visit_base) { to_visit -= 4; pt0 = to_visit[0]; pt0_end = to_visit[1]; @@ -1123,10 +1173,17 @@ CreateDBStruct(Term Tm, DBProp p, int InFlag) DBRef *TmpRefBase = (DBRef *)ConsultSp; CELL *CodeAbs; /* how much code did we find */ int vars_found; +#ifdef COROUTINING + CELL attachments = 0; +#endif DBErrorFlag = NO_ERROR_IN_DB; - if (IsVarTerm(Tm)) { + if (IsVarTerm(Tm) +#ifdef COROUTINING + && !IsAttachedTerm(Tm) +#endif + ) { Register DBRef pp; tt = Tm; @@ -1185,11 +1242,26 @@ CreateDBStruct(Term Tm, DBProp p, int InFlag) ntp0 = pp0->Contents; #ifdef IDB_LINK_TABLE lr = LinkAr = (link_entry *)TR; +#endif +#ifdef COROUTINING + /* attachment */ + if (IsVarTerm(Tm)) { + tt = sizeof(CELL); + ntp = MkDBTerm(VarOfTerm(Tm), VarOfTerm(Tm), ntp0, ntp0+1, ntp0-1, + &attachments, + &vars_found); + if (ntp == NULL) + return(NULL); + } else #endif if (IsPairTerm(Tm)) { /* avoid null pointers!! */ tt = AbsPair((CELL *)sizeof(CELL)); - ntp = MkDBTerm(RepPair(Tm), RepPair(Tm)+1, ntp0, ntp0+2, ntp0-1, &vars_found); + ntp = MkDBTerm(RepPair(Tm), RepPair(Tm)+1, ntp0, ntp0+2, ntp0-1, +#ifdef COROUTINING + &attachments, +#endif + &vars_found); if (ntp == NULL) { return(NULL); } @@ -1273,8 +1345,12 @@ CreateDBStruct(Term Tm, DBProp p, int InFlag) } else { arity = ArityOfFunctor(fun); ntp = MkDBTerm(RepAppl(Tm)+1, - RepAppl(Tm)+arity, - ntp0+1, ntp0+1+arity, ntp0-1, &vars_found); + RepAppl(Tm)+arity, + ntp0+1, ntp0+1+arity, ntp0-1, +#ifdef COROUTINING + &attachments, +#endif + &vars_found); if (ntp == NULL) return(NULL); } @@ -1359,6 +1435,9 @@ CreateDBStruct(Term Tm, DBProp p, int InFlag) #endif /* IDB_LINK_TABLE */ pp->NOfCells = NOfCells; +#ifdef COROUTINING + pp->attachments = attachments; +#endif if (pp0 != pp) { nar = pp->Contents; #ifdef IDB_LINK_TABLE @@ -1918,6 +1997,18 @@ p_rcdzifnot(void) goto restart_record; } +#ifdef COROUTINING +static void +copy_attachments(CELL *ts) +{ + while (TRUE) { + attas[IntegerOfTerm(ts[2])].term_to_op(ts[1], ts[0]); + if (ts[3] == TermNil) return; + ts = RepAppl(ts[3])+1; + } +} +#endif + static Term GetDBTerm(DBRef DBSP) { @@ -1942,6 +2033,11 @@ GetDBTerm(DBRef DBSP) link_entry *lp = (link_entry *)pt; linkblk(lp, HOld-1); } +#endif +#ifdef COROUTINING + if (DBSP->attachments != 0L) { + copy_attachments((CELL *)AdjustIDBPtr(DBSP->attachments,(CELL)(HOld-1))); + } #endif return (AdjustIDBPtr((Term)(DBSP->Entry),Unsigned(HOld)-sizeof(CELL))); } diff --git a/C/init.c b/C/init.c index 9d8894a9d..092f5fa1c 100644 --- a/C/init.c +++ b/C/init.c @@ -955,6 +955,7 @@ InitCodes(void) heap_regs->functor_braces = MkFunctor(AtomBraces, 1); heap_regs->functor_call = MkFunctor(AtomCall, 1); heap_regs->functor_cut_by = MkFunctor(AtomCutBy, 1); + heap_regs->functor_clist = MkFunctor(LookupAtom("$when"), 4); heap_regs->functor_comma = MkFunctor(AtomComma, 2); heap_regs->functor_csult = MkFunctor(AtomCsult, 1); heap_regs->functor_eq = MkFunctor(AtomEq, 2); diff --git a/C/save.c b/C/save.c index 9bc6e00ec..2a4ec6a28 100644 --- a/C/save.c +++ b/C/save.c @@ -493,10 +493,14 @@ save_stacks(int mode) tr_fr_ptr tr_ptr = TR; while (tr_ptr != (tr_fr_ptr)TrailBase) { CELL val = TrailTerm(tr_ptr-1); - if (!IsVarTerm(val) && IsPairTerm(val)) { + if (IsVarTerm(val)) { + CELL *d1 = VarOfTerm(val); + if (d1 < (CELL *)HeapTop) + putout(val); + } else if (IsPairTerm(val)) { CELL *d1 = RepPair(val); if (d1 < (CELL *)HeapTop) - putcellptr(d1); + putout(val); } tr_ptr--; } @@ -2898,17 +2902,22 @@ UnmarkTrEntries(void) B--; B->cp_ap = (yamop *)NOCODE; Entries = (CELL *)TrailBase; - while ((CODEADDR)(entry = *Entries++) != NULL) { - register CELL flags; + while ((entry = *Entries++) != (CELL)NULL) { + if (IsVarTerm(entry)) { + RESET_VARIABLE((CELL *)entry); + } else if (IsPairTerm(entry)) { + CODEADDR ent = (CODEADDR)RepPair(entry); + register CELL flags; - flags = Flags(entry); - ResetFlag(InUseMask, flags); - Flags(entry) = flags; - if (FlagOn(ErasedMask, flags)) { - if (FlagOn(DBClMask, flags)) { - ErDBE((DBRef) (entry - (CELL) &(((DBRef) NIL)->Flags))); - } else { - ErCl(ClauseFlagsToClause(entry)); + flags = Flags(ent); + ResetFlag(InUseMask, flags); + Flags(ent) = flags; + if (FlagOn(ErasedMask, flags)) { + if (FlagOn(DBClMask, flags)) { + ErDBE((DBRef) (ent - (CELL) &(((DBRef) NIL)->Flags))); + } else { + ErCl(ClauseFlagsToClause(ent)); + } } } } diff --git a/C/tracer.c b/C/tracer.c index e38dbadad..324fe383b 100644 --- a/C/tracer.c +++ b/C/tracer.c @@ -114,7 +114,7 @@ low_level_trace(yap_low_level_port port, PredEntry *pred, CELL *args) extern int gc_calls; vsc_count++; - /* if (vsc_count < 13198050) return; */ + /* if (vsc_count < 1025) return; */ /* if (vsc_count > 500000) exit(0); */ /* if (gc_calls < 1) return;*/ YP_fprintf(YP_stderr,"%lu (%x) ", vsc_count, CreepFlag); diff --git a/H/Heap.h b/H/Heap.h index 365577948..dbf0ee55c 100644 --- a/H/Heap.h +++ b/H/Heap.h @@ -10,7 +10,7 @@ * File: Heap.h * * mods: * * comments: Heap Init Structure * -* version: $Id: Heap.h,v 1.14 2001-11-26 12:33:05 vsc Exp $ * +* version: $Id: Heap.h,v 1.15 2001-12-17 18:31:10 vsc Exp $ * *************************************************************************/ /* information that can be stored in Code Space */ @@ -223,6 +223,7 @@ typedef struct various_codes { #endif functor_braces, functor_call, + functor_clist, functor_comma, functor_csult, functor_cut_by, @@ -411,6 +412,7 @@ typedef struct various_codes { #endif #define FunctorBraces heap_regs->functor_braces #define FunctorCall heap_regs->functor_call +#define FunctorClist heap_regs->functor_clist #define FunctorComma heap_regs->functor_comma #define FunctorCsult heap_regs->functor_csult #define FunctorCutBy heap_regs->functor_cut_by diff --git a/m4/TermExt.h.m4 b/m4/TermExt.h.m4 index e35623e48..1d6d408b4 100644 --- a/m4/TermExt.h.m4 +++ b/m4/TermExt.h.m4 @@ -10,7 +10,7 @@ * File: TermExt.h * * mods: * * comments: Extensions to standard terms for YAP * -* version: $Id: TermExt.h.m4,v 1.4 2001-12-11 03:34:03 vsc Exp $ * +* version: $Id: TermExt.h.m4,v 1.5 2001-12-17 18:31:11 vsc Exp $ * *************************************************************************/ #if USE_OFFSETS @@ -71,6 +71,9 @@ typedef struct { void (*bind_op)(Term *, Term); /* what to do if someone wants to copy our constraint */ int (*copy_term_op)(CELL *, CELL ***, CELL *); + /* copy the constraint into a term and back */ + Term (*to_term_op)(CELL *); + int (*term_to_op)(Term, Term); /* op called to do marking in GC */ void (*mark_op)(CELL *); } ext_op; diff --git a/m4/Yap.h.m4 b/m4/Yap.h.m4 index 48a4f5cb8..e9c5f2d8e 100644 --- a/m4/Yap.h.m4 +++ b/m4/Yap.h.m4 @@ -10,7 +10,7 @@ * File: Yap.h.m4 * * mods: * * comments: main header file for YAP * -* version: $Id: Yap.h.m4,v 1.12 2001-09-24 18:07:16 vsc Exp $ * +* version: $Id: Yap.h.m4,v 1.13 2001-12-17 18:31:11 vsc Exp $ * *************************************************************************/ #include "config.h" @@ -567,7 +567,7 @@ and RefOfTerm(t) : Term -> DBRef = ... incompatible with the high tag scheme. Linux-ELF also does not like if you place things in the lower addresses (power to the libc people). */ -#if (defined(_AIX) || defined(_WIN32) || defined(sparc) || defined(__sparc) || defined(mips) || defined(__FreeBSD__) || defined(_POWER) || defined(IN_SECOND_QUADRANT)) && !defined(TABLING) +#if (defined(_AIX) || defined(_WIN32) || defined(sparc) || defined(__sparc) || defined(mips) || defined(__FreeBSD__) || defined(_POWER) || defined(__linux__) || defined(IN_SECOND_QUADRANT)) && !defined(TABLING) #define USE_LOW32_TAGS 1 #endif diff --git a/m4/Yatom.h.m4 b/m4/Yatom.h.m4 index 933f05a04..46e11ac66 100644 --- a/m4/Yatom.h.m4 +++ b/m4/Yatom.h.m4 @@ -287,6 +287,9 @@ typedef struct DB_STRUCT { Int age; /* entry's age, negative if from recorda, positive if it was recordz */ #endif /* KEEP_ENTRY_AGE */ +#ifdef COROUTINING + CELL attachments; /* attached terms */ +#endif CELL Mask; /* parts that should be cleared */ CELL Key; /* A mask that can be used to check before you unify */ diff --git a/pl/boot.yap b/pl/boot.yap index 9d76323b7..3def87d10 100644 --- a/pl/boot.yap +++ b/pl/boot.yap @@ -43,6 +43,7 @@ true :- true. % otherwise, $$compile will ignore this clause. '$set_yap_flags'(10,0), '$set_value'('$gc',on), '$init_catch', +% '$init_newcatch', commented out for now prompt(' ?- '), ( '$get_value'('$break',0) @@ -68,17 +69,6 @@ true :- true. % otherwise, $$compile will ignore this clause. true ). -'$init_catch' :- - % initialise access to the catch queue - ( '$has_static_array'('$catch_queue') -> - true - ; - static_array('$catch_queue',2, term) - ), - update_array('$catch_queue', 0, '$'), - update_array('$catch_queue', 1, '$'). - - % % encapsulate $cut_by because of co-routining. % @@ -1125,9 +1115,51 @@ expand_term(Term,Expanded) :- '$expand_term_modules'(A,A,A,_). + %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % catch/throw implementation +/* new design, not working for now: + +% at each catch point I need to know: +% what is ball; +% where was the previous catch +newcatch(G, C, A) :- + array_element('$catch', 0, OldEnv), + Env is '$env', + update_array('$catch', 0, Env), + '$execute'(G), + update_array('$catch', 0, Env), + array_element('$catch', 1, V), + (var(V) -> + true + ; + !, '$handle_throw'(C, A) + ). + +'$handle_throw'(C, A) :- + % reset info + array_element('$catch', 1, _), + array_element('$catch', 2, Ball), + (C = Ball -> + '$execute'(A) + ; + throw(Ball) + ). + +newthrow(Ball) :- + % say we are throwing something. + array_element('$catch', 1, []), + update_array('$catch', 2, Ball), + array_element('$catch', 0, Env), + '$jump_env'(Env). + +'$init_newcatch' :- + '$create_array'('$catch', 3). + + +*/ + catch(G,C,A) :- var(G), !, throw(error(instantiation_error,catch(G,C,A))). catch(G,C,A) :- number(G), !, @@ -1252,6 +1284,18 @@ throw(G) :- '$format'(user_error,"system_error_at(~w)",[G]), abort. + +'$init_catch' :- + % initialise access to the catch queue + ( '$has_static_array'('$catch_queue') -> + true + ; + static_array('$catch_queue',2, term) + ), + update_array('$catch_queue', 0, '$'), + update_array('$catch_queue', 1, '$'). + + '$check_list'(V, _) :- var(V), !. '$check_list'([], _) :- !. '$check_list'([_|B], T) :- !, diff --git a/pl/corout.yap b/pl/corout.yap index 76000d05d..82933305c 100644 --- a/pl/corout.yap +++ b/pl/corout.yap @@ -619,7 +619,8 @@ call_residue(Goal,Residue) :- ; '$pick_vars_for_project'(LIV,NLIV), '$project_module'(LMods,NLIV,LAV), - '$all_attvars'(NLAV), + '$all_attvars'(NLAV0), + sort(NLAV0, NLAV), '$convert_att_vars'(NLAV, LIV, Gs, Gs0) ). diff --git a/pl/load_foreign.yap b/pl/load_foreign.yap index 6f94e334c..b0b060279 100644 --- a/pl/load_foreign.yap +++ b/pl/load_foreign.yap @@ -17,7 +17,7 @@ load_foreign_files(Objs,Libs,Entry) :- '$check_objs_for_load_foreign_files'(Objs,NewObjs,load_foreign_files(Objs,Libs,Entry)), - '$check_lib_for_load_foreign_files'(Libs,load_foreign_files(Objs,Libs,Entry)), + '$check_libs_for_load_foreign_files'(Libs,load_foreign_files(Objs,Libs,Entry)), '$check_entry_for_load_foreign_files'(Entry,load_foreign_files(Objs,Libs,Entry)), '$load_foreign_files'(NewObjs,Libs,Entry).