diogo/yap-6.3
Archived
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

use arrays to implement catch and throw instead of record

Browse Source 
cleanup queues at top-level and at catch-throw.


git-svn-id: https://yap.svn.sf.net/svnroot/yap/trunk@69 b08c6af1-5177-4d33-ba66-4b1c6b8b522a
This commit is contained in:
vsc 2001-06-08 19:10:43 +00:00
parent 08ebcf94be
commit 97d882c1a7
8 changed files with 194 additions and 119 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

87
C/arrays.c
View File

@ -771,6 +771,36 @@ p_create_static_array(void)
}
}
/* has a static array associated (+Name) */
static Int
p_has_static_array(void)
{
Term t = Deref(ARG1);
if (IsVarTerm(t)) {
return (FALSE);
}
else if (IsAtomTerm(t)) {
/* Create a named array */
AtomEntry *ae = RepAtom(AtomOfTerm(t));
StaticArrayEntry *pp;
READ_LOCK(ae->ARWLock);
pp = RepStaticArrayProp(ae->PropOfAE);
while (!EndOfPAEntr(pp) && pp->KindOfPE != ArrayProperty)
pp = RepStaticArrayProp(pp->NextOfPE);
if (EndOfPAEntr(pp) || pp->ValueOfVE.ints == NULL) {
READ_UNLOCK(ae->ARWLock);
return (FALSE);
} else {
READ_UNLOCK(ae->ARWLock);
return(TRUE);
}
} else {
return (FALSE);
}
}
/* resize a static array (+Name, + Size, +Props) */
/* does not work for mmap arrays yet */
static Int
@ -1369,7 +1399,7 @@ p_assign_static(void)
Error(INSTANTIATION_ERROR,t3,"assign_static");
return (FALSE);
}
if (indx < 0 || indx >= - ptr->ArrayEArity) {
if (indx < 0 || indx >= - ptr->ArrayEArity) {
WRITE_UNLOCK(ptr->ArRWLock);
Error(DOMAIN_ERROR_ARRAY_OVERFLOW,t2,"assign_static");
}
@ -1543,6 +1573,60 @@ p_sync_mmapped_arrays(void)
return(TRUE);
}
/*
This is a hack, to steal the first element of a key.
It first fetches the first element in the chain, and then erases it
through its reference.
Be careful when using this routine. It is especially evil because if
the term is ground it should be copied to the stack, as space for
the entry may be deleted. For the moment, the terms I want are just
integers, so no problemo, amigo.
*/
static Term
StealFirstFromDB(DBRef ref)
{
Term TermDB, out;
if ((TermDB = FetchTermFromDB(ref,3)) == (CELL)0) {
/* oops, we are in trouble, not enough stack space */
return(TermNil);
}
if (IsVarTerm(TermDB) || !IsApplTerm(TermDB))
/* it's not a wonderful world afterall */
return(TermNil);
out = ArgOfTerm(1,TermDB);
/* now, return what once was there, only nevermore */
return(out);
}
Int
SetDBForThrow(Term Message)
{
Term cut_pt_term;
Atom a = FullLookupAtom("$catch_queue");
AtomEntry *ae = RepAtom(a);
StaticArrayEntry *ptr;
DBRef ref;
READ_LOCK(ae->ARWLock);
ptr = RepStaticArrayProp(ae->PropOfAE);
while (!EndOfPAEntr(ptr) && ptr->KindOfPE != ArrayProperty)
ptr = RepStaticArrayProp(ptr->NextOfPE);
READ_UNLOCK(ae->ARWLock);
ref = ptr->ValueOfVE.terms[0];
cut_pt_term = StealFirstFromDB(ref);
if (IsVarTerm(cut_pt_term) || !IsIntegerTerm(cut_pt_term)) {
/* ooops, babe we are in trouble */
return(-1);
}
/* OK, we've got the place to cut to, next store the new throw */
ptr->ValueOfVE.terms[1] = StoreTermInDB(Message,3);
return(IntegerOfTerm(cut_pt_term));
}
void
InitArrayPreds(void)
{
@ -1558,5 +1642,6 @@ InitArrayPreds(void)
InitCPred("$sync_mmapped_arrays", 0, p_sync_mmapped_arrays, SafePredFlag);
InitCPred("$compile_array_refs", 0, p_compile_array_refs, SafePredFlag);
InitCPred("$array_refs_compiled", 0, p_array_refs_compiled, SafePredFlag);
InitCPred("$has_static_array", 1, p_has_static_array, TestPredFlag|SafePredFlag);
}

133
C/dbase.c
View File

@ -114,7 +114,7 @@ typedef struct {
} SFKeep;
#endif
typedef struct
typedef struct idb_queue
{
Functor id; /* identify this as being pointed to by a DBRef */
Term EntryTerm; /* cell bound to itself */
@ -123,6 +123,8 @@ typedef struct
rwlock_t QRWLock; /* a simple lock to protect this entry */
#endif
DBRef FirstInQueue, LastInQueue;
Int age; /* the number of catches when we created the queue */
struct idb_queue *next, *prev;
} db_queue;
#define HashFieldMask ((CELL)0xffL)
@ -263,7 +265,6 @@ STATIC_PROTO(Int p_dequeue, (void));
STATIC_PROTO(Int p_first_age, (void));
STATIC_PROTO(Int p_db_nb_to_ref, (void));
STATIC_PROTO(Int p_last_age, (void));
STATIC_PROTO(Term StealFirstFromDB, (Atom, Int));
#if OS_HANDLES_TR_OVERFLOW
#define check_trail(x)
@ -3451,24 +3452,6 @@ p_erase(void)
return (TRUE);
}
/* erase(+Ref) */
static Int
p_smash(void)
{
Term t1 = Deref(ARG1);
if (IsVarTerm(t1)) {
Error(INSTANTIATION_ERROR, t1, "erase");
return (FALSE);
}
if (!IsDBRefTerm(t1)) {
Error(TYPE_ERROR_DBREF, t1, "erase");
return (FALSE);
}
EraseEntry(DBRefOfTerm(t1));
return (TRUE);
}
/* eraseall(+Key) */
static Int
p_eraseall(void)
@ -3799,7 +3782,7 @@ p_init_queue(void)
db_queue *dbq;
Term t;
while ((dbq = (db_queue *)AllocDBSpace(sizeof(db_queue))) == NIL) {
while ((dbq = (db_queue *)AllocDBSpace(sizeof(db_queue))) == NULL) {
if (!growheap(FALSE)) {
Abort("[ SYSTEM ERROR: YAP failed to reserve space in growheap ]\n");
return(FALSE);
@ -3808,12 +3791,17 @@ p_init_queue(void)
dbq->id = FunctorDBRef;
dbq->EntryTerm = MkAtomTerm(AbsAtom((AtomEntry *)dbq));
dbq->Flags = DBClMask;
dbq->FirstInQueue = dbq->LastInQueue = NIL;
dbq->FirstInQueue = dbq->LastInQueue = NULL;
dbq->next = DBQueues;
dbq->prev = NULL;
DBQueues = dbq;
dbq->age = IntOfTerm(GetValue(AtomCatch));
INIT_RWLOCK(dbq->QRWLock);
t = MkDBRefTerm((DBRef)dbq);
return(unify(ARG1, t));
}
static Int
p_enqueue(void)
{
@ -3887,6 +3875,12 @@ p_dequeue(void)
WRITE_LOCK(father_key->QRWLock);
if ((cur_instance = father_key->FirstInQueue) == NIL) {
/* an empty queue automatically goes away */
if (father_key == DBQueues)
DBQueues = father_key->next;
else
father_key->prev->next = father_key->next;
if (father_key->next != NULL)
father_key->next->prev = father_key->prev;
WRITE_UNLOCK(father_key->QRWLock);
FreeDBSpace((char *) father_key);
return(FALSE);
@ -3907,77 +3901,34 @@ p_dequeue(void)
}
}
/*
This is a hack, to steal the first element of a key.
It first fetches the first element in the chain, and then erases it
through its reference.
Be careful when using this routine. It is especially evil because if
the term is ground it should be copied to the stack, as space for
the entry may be deleted. For the moment, the terms I want are just
integers, so no problemo, amigo.
*/
static Term
StealFirstFromDB(Atom key, Int arity)
static Int
p_clean_queues(void)
{
Prop AtProp;
Register DBRef ref;
Term TermDB;
Term out;
Int myage = IntOfTerm(ARG1);
db_queue *ptr;
YAPEnterCriticalSection();
ptr = DBQueues;
while (ptr) {
if (ptr->age >= myage) {
DBRef cur_instance;
db_queue *optr = ptr;
/* get the DB property */
if ((AtProp = FindDBProp(RepAtom(key), 0, arity)) == NIL) {
return(TermNil);
while ((cur_instance = ptr->FirstInQueue)) {
/* release space for cur_instance */
ptr->FirstInQueue = (DBRef)(cur_instance->Parent);
ErasePendingRefs(cur_instance);
FreeDBSpace((char *) cur_instance);
}
ptr = ptr->next;
FreeDBSpace((char *) optr);
} else
break;
}
/* get the first entry */
#ifdef KEEP_OLD_ENTRIES_HANGING_ABOUT
ref = RepDBProp(AtProp)->FirstNEr;
#else
ref = RepDBProp(AtProp)->First;
#endif
/* is there anyone home ? */
while (ref != NIL
&& (ref->Flags & (DBCode | ErasedMask)))
ref = NextDBRef(ref);
if (ref == NIL) {
return(TermNil);
}
/* get our fine term */
if ((TermDB = GetDBTerm(ref)) == (CELL)0) {
/* oops, we are in trouble, not enough stack space */
return(TermNil);
}
if (IsVarTerm(TermDB) || !IsApplTerm(TermDB))
/* it's not a wonderful world afterall */
return(TermNil);
out = ArgOfTerm(1,TermDB);
/* next, make it disappear from the DB */
EraseEntry(ref);
/* now, return what once was there, only nevermore */
return(out);
}
Int
SetDBForThrow(Term Message)
{
Term cut_pt_term;
/* who's gonna catch us? */
DBModule = 0;
cut_pt_term = StealFirstFromDB(AtomCatch, 0);
if (IsVarTerm(cut_pt_term) || !IsIntegerTerm(cut_pt_term)) {
/* ooops, babe we are in trouble */
return(-1);
}
/* OK, we've got the place to cut to, next store the new throw */
if (record(MkFirst, MkAtomTerm(AtomThrow), Message, TermNil) == NIL)
return (-1);
else
/* off we go, to see the wizard of Oz */
return(IntegerOfTerm(cut_pt_term));
if (ptr)
ptr->prev = NULL;
DBQueues = ptr;
YAPLeaveCriticalSection();
return(TRUE);
}
/* given a key, find the clock number for the first entry */
@ -4187,7 +4138,6 @@ InitDBPreds(void)
InitCPred("$recordzp", 4, p_drcdzp, SafePredFlag|SyncPredFlag);
InitCPred("$recordaifnot", 3, p_rcdaifnot, SafePredFlag|SyncPredFlag);
InitCPred("$recordzifnot", 3, p_rcdzifnot, SafePredFlag|SyncPredFlag);
InitCPred("$db_smash", 1, p_smash, SafePredFlag|SyncPredFlag);
InitCPred("erase", 1, p_erase, SafePredFlag|SyncPredFlag);
InitCPred("erased", 1, p_erased, TestPredFlag | SafePredFlag|SyncPredFlag);
InitCPred("instance", 2, p_instance, SyncPredFlag);
@ -4199,6 +4149,7 @@ InitDBPreds(void)
InitCPred("$db_key", 2, p_db_key, 0);
InitCPred("$db_enqueue", 2, p_enqueue, SyncPredFlag);
InitCPred("$db_dequeue", 2, p_dequeue, SyncPredFlag);
InitCPred("$db_clean_queues", 1, p_clean_queues, SyncPredFlag);
InitCPred("$db_first_age", 2, p_first_age, TestPredFlag|SafePredFlag|SyncPredFlag);
InitCPred("$db_nb_to_ref", 3, p_db_nb_to_ref, TestPredFlag|SafePredFlag);
InitCPred("$db_last_age", 2, p_last_age, TestPredFlag|SafePredFlag|SyncPredFlag);

1
C/init.c
View File

@ -820,6 +820,7 @@ InitCodes(void)
heap_regs->no_of_modules = 1;
heap_regs->primitives_module = 0;
heap_regs->user_module = 1;
heap_regs->db_queues = NULL;
heap_regs->atom_abol = LookupAtom("$abol");
AtomAltNot = LookupAtom("not");
heap_regs->atom_append = LookupAtom ("append");

4
C/save.c
View File

@ -944,6 +944,10 @@ restore_codes(void)
heap_regs->dead_clauses = (Clause *)
AddrAdjust((ADDR)(heap_regs->dead_clauses));
}
if (heap_regs->db_queues != NULL) {
heap_regs->db_queues = (struct idb_queue *)
AddrAdjust((ADDR)(heap_regs->db_queues));
}
heap_regs->retry_recorded_code =
PtoOpAdjust(heap_regs->retry_recorded_code);
heap_regs->retry_recorded_k_code =

2
C/sysbits.c
View File

@ -1099,7 +1099,7 @@ ProcessSIGINT(void)
if (in_readline) {
/* readline must eat a newline, otherwise we will
have to wait before we do the Abort() */
} else {
} else if (!(PrologMode & CritMode)) {
#endif
#if defined(__MINGW32__) || _MSC_VER
/* we can't do a direct abort, so ask the system to do it for us */

4
H/Heap.h
View File

@ -10,7 +10,7 @@
* File: Heap.h *
* mods: *
* comments: Heap Init Structure *
* version: $Id: Heap.h,v 1.4 2001-06-08 13:38:42 vsc Exp $ *
* version: $Id: Heap.h,v 1.5 2001-06-08 19:10:43 vsc Exp $ *
*************************************************************************/
/* information that can be stored in Code Space */
@ -133,6 +133,7 @@ typedef struct various_codes {
#endif
int primitives_module;
int user_module;
struct idb_queue *db_queues;
Atom
atom_abol,
atom_alarm,
@ -316,6 +317,7 @@ typedef struct various_codes {
#define ModuleName heap_regs->module_name
#define PrimitivesModule heap_regs->primitives_module
#define UserModule heap_regs->user_module
#define DBQueues heap_regs->db_queues
#define NoOfModules heap_regs->no_of_modules
#define AtomAbol heap_regs->atom_abol
#define AtomAlarm heap_regs->atom_alarm

1
changes4.3.html
View File

@ -16,6 +16,7 @@
<h2>Yap-4.3.19:</h2>
<ul>
<li>FIXED: change catch and throw to use arrays.</li>
<li>CLEANUP: split TRAIL_REF.</li>
<li>FIXED: give correct type to FreeBlocks.</li>
<li>FIXED: give correct type to alias list.</li>

81
pl/boot.yap
View File

@ -43,6 +43,7 @@ true :- true. % otherwise, $$compile will ignore this clause.
),
'$set_yap_flags'(10,0),
'$set_value'('$gc',on),
'$init_catch',
prompt(' ?- '),
(
'$get_value'('$break',0)
@ -61,13 +62,25 @@ true :- true. % otherwise, $$compile will ignore this clause.
( exists('~/prolog.ini') -> [-'~/prolog.ini'] ; true )
),
'$clean_catch_and_throw',
'$db_clean_queues'(0),
'$startup_reconsult',
'$startup_goals'
;
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.
%
'$cut_by'(X) :- '$$cut_by'(X).
@ -1122,9 +1135,9 @@ catch(G,C,A) :-
'$catch'(G,C,A).
'$catch'(G,C,A) :-
'$get_value'('$catch_counter', I),
'$get_value'('$catch', I),
I1 is I+1,
'$set_value'('$catch_counter', I1),
'$set_value'('$catch', I1),
'$current_module'(M),
'$catch'(G,C,A,I,M).
@ -1134,23 +1147,35 @@ catch(G,C,A) :-
'$catch_call'(X,G,I).
% someone sent us a throw.
'$catch'(_,C,A,_,M) :-
('$recorded'('$throw',X,R)->true),
erase(R),
array_element('$catch_queue', 1, X), X \= '$',
update_array('$catch_queue', 1, '$'),
array_element('$catch_queue', 0, catch(_,Lev,Q)),
update_array('$catch_queue', 0, Q),
'$db_clean_queues'(Lev),
( C=X -> '$current_module'(_,M), '$execute'(A) ; throw(X)).
% normal exit: make sure we only erase what we should erase!
'$catch'(_,_,_,I,_) :-
'$recorded'('$catch','$catch'(_,J),R), J >= I,
erase(R), fail.
array_element('$catch_queue', 0, OldCatch),
'$erase_catch_elements'(OldCatch, I, Catch),
update_array('$catch_queue', 0, Catch),
fail.
'$erase_catch_elements'(catch(X, J, P), I, Catch) :-
J >= I, !,
'$erase_catch_elements'(P, I, Catch).
'$erase_catch_elements'(Catch, _, Catch).
'$catch_call'(X,G,I) :-
'$recorda'('$catch','$catch'(X,I),_),
array_element('$catch_queue', 0, OldCatch),
update_array('$catch_queue', 0, catch(X,I,OldCatch)),
'$execute'(G),
( % on exit remove the catch
('$recorded'('$catch','$catch'(X,I),R)->true),
erase(R)
array_element('$catch_queue', 0, catch(X,I,Catch)),
update_array('$catch_queue', 0, Catch)
;
% on backtracking reinstate the catch before backtracking to G
'$recorda'('$catch','$catch'(X,I),_),
array_element('$catch_queue', 0, Catch),
update_array('$catch_queue', 0, catch(X,I,Catch)),
fail
).
@ -1161,9 +1186,9 @@ catch(G,C,A) :-
% also avoids module preprocessing and goal_expansion
%
'$system_catch'(G,C,A) :-
'$get_value'('$catch_counter', I),
'$get_value'('$catch', I),
I1 is I+1,
'$set_value'('$catch_counter', I1),
'$set_value'('$catch', I1),
'$current_module'(M),
'$system_catch'(G,C,A,I,M).
@ -1173,8 +1198,11 @@ catch(G,C,A) :-
'$system_catch_call'(X,G,I).
% someone sent us a throw.
'$system_catch'(_,C,A,_,M0) :-
('$recorded'('$throw',X,R)->true),
erase(R),
array_element('$catch_queue', 1, X), X \= '$',
update_array('$catch_queue', 1, '$'),
array_element('$catch_queue', 0, catch(_,Lev,Q)),
'$db_clean_queues'(Lev),
update_array('$catch_queue', 0, Q),
( C=X ->
'$current_module'(_,M0),
(A = M:G -> '$mod_switch'(M,G) ; '$mod_switch'(M0,A))
@ -1183,27 +1211,30 @@ catch(G,C,A) :-
).
% normal exit: make sure we only erase what we should erase!
'$system_catch'(_,_,_,I,_) :-
'$recorded'('$catch','$catch'(_,J),R), J >= I,
erase(R), fail.
array_element('$catch_queue', 0, OldCatch),
'$erase_catch_elements'(OldCatch, I, Catch),
update_array('$catch_queue', 0, Catch),
fail.
'$system_catch_call'(X,G,I) :-
'$recorda'('$catch','$catch'(X,I),_),
array_element('$catch_queue', 0, OldCatch),
update_array('$catch_queue', 0, catch(X,I,OldCatch)),
'$execute0'(G),
( % on exit remove the catch
('$recorded'('$catch','$catch'(X,I),R)->true),
erase(R)
array_element('$catch_queue', 0, catch(X,I,Catch)),
update_array('$catch_queue', 0, Catch)
;
% on backtracking reinstate the catch before backtracking to G
'$recorda'('$catch','$catch'(X,I),_),
array_element('$catch_queue', 0, Catch),
update_array('$catch_queue', 0, catch(X,I,Catch)),
fail
).
throw(A) :-
% fetch the point to jump to
'$recorded'('$catch','$catch'(X,_),R), !,
erase(R),
array_element('$catch_queue', 0, catch(X,_,_)), !,
% now explain why we are jumping.
'$recordz'('$throw',A,_),
update_array('$catch_queue', 1, A),
'$$cut_by'(X),
fail.
throw(G) :-
@ -1218,7 +1249,7 @@ throw(G) :-
throw(error(type_error(list,S),T)).
'$clean_catch_and_throw' :-
'$set_value'('$catch_counter', 0),
'$set_value'('$catch', 0),
fail.
'$clean_catch_and_throw' :-
'$recorded'('$catch',_,R),