diff --git a/C/errors.c b/C/errors.c index 19066f857..89cf3f69e 100755 --- a/C/errors.c +++ b/C/errors.c @@ -1075,6 +1075,20 @@ Yap_Error(yap_error_number type, Term where, char *format,...) serious = TRUE; } break; + case EXISTENCE_ERROR_MUTEX: + { + int i; + Term ti[2]; + + i = strlen(tmpbuf); + ti[0] = MkAtomTerm(AtomMutex); + ti[1] = where; + nt[0] = Yap_MkApplTerm(FunctorExistenceError, 2, ti); + psize -= i; + fun = FunctorError; + serious = TRUE; + } + break; case EXISTENCE_ERROR_VARIABLE: { int i; diff --git a/C/threads.c b/C/threads.c index 9af49f747..7cdccd8f6 100644 --- a/C/threads.c +++ b/C/threads.c @@ -877,7 +877,11 @@ p_valid_thread( USES_REGS1 ) typedef struct swi_mutex { UInt owners; Int tid_own; + MutexEntry *alias; pthread_mutex_t m; + UInt timestamp; + struct swi_mutex *backbone; // chain of all mutexes + struct swi_mutex *prev, *next; // chain of locked mutexes } SWIMutex; static SWIMutex *NewMutex(void) { @@ -887,21 +891,42 @@ static SWIMutex *NewMutex(void) { extern int pthread_mutexattr_setkind_np(pthread_mutexattr_t *attr, int kind); #endif - mutp = (SWIMutex *)Yap_AllocCodeSpace(sizeof(SWIMutex)); - if (mutp == NULL) { - return FALSE; + LOCK(GLOBAL_MUT_ACCESS); + mutp = GLOBAL_FreeMutexes; + while (mutp) { + if ((Int)(mutp->owners) < 0) { + // just making sure + break; + } + mutp = mutp->next; } - pthread_mutexattr_init(&mat); + if (mutp == NULL) { + mutp = (SWIMutex *)Yap_AllocCodeSpace(sizeof(SWIMutex)); + if (mutp == NULL) { + UNLOCK(GLOBAL_MUT_ACCESS); + return NULL; + } else { + pthread_mutexattr_init(&mat); + mutp->timestamp = 0; #if defined(HAVE_PTHREAD_MUTEXATTR_SETKIND_NP) && !defined(__MINGW32__) - pthread_mutexattr_setkind_np(&mat, PTHREAD_MUTEX_RECURSIVE_NP); + pthread_mutexattr_setkind_np(&mat, PTHREAD_MUTEX_RECURSIVE_NP); #else #ifdef HAVE_PTHREAD_MUTEXATTR_SETTYPE - pthread_mutexattr_settype(&mat, PTHREAD_MUTEX_RECURSIVE); + pthread_mutexattr_settype(&mat, PTHREAD_MUTEX_RECURSIVE); #endif #endif - pthread_mutex_init(&mutp->m, &mat); + pthread_mutex_init(&mutp->m, &mat); + } + mutp->backbone = GLOBAL_mutex_backbone; + GLOBAL_mutex_backbone = mutp; + } else { + // reuse existing mutex + mutp->timestamp++; + } mutp->owners = 0; - mutp->tid_own = 0; + mutp->tid_own = 0; + mutp->alias = NIL; + UNLOCK(GLOBAL_MUT_ACCESS); return mutp; } @@ -912,10 +937,15 @@ static SWIMutex *MutexOfTerm__(Term t USES_REGS){ SWIMutex *mut = NULL; if (IsVarTerm(t1)) { - mut = NewMutex(); - Yap_unify(MkAddressTerm(mut), ARG1); - } else if (IsIntegerTerm(t1)) { - mut = AddressOfTerm(t1); + Yap_Error(INSTANTIATION_ERROR, t1, "mutex operation"); + return NULL; + } else if (IsApplTerm(t1) && FunctorOfTerm(t1) == FunctorMutex) { + mut = AddressOfTerm(ArgOfTerm(1,t1)); + if ((Int)(mut->owners) < 0 || + IntegerOfTerm(ArgOfTerm(2,t1)) != mut->timestamp) { + Yap_Error(EXISTENCE_ERROR_MUTEX, t1, "mutex access"); + return NULL; + } } else if (IsAtomTerm(t1)) { mut = Yap_GetMutexFromProp(AtomOfTerm(t1)); if (!mut) { @@ -933,35 +963,53 @@ p_new_mutex( USES_REGS1 ){ SWIMutex* mutp; Term t1; if (IsVarTerm((t1 = Deref(ARG1)))) { + Term ts[2]; + if (!(mutp = NewMutex())) return FALSE; - return Yap_unify(ARG1, MkAddressTerm(mutp)); + ts[0] = MkAddressTerm(mutp); + ts[1] = MkIntegerTerm(mutp->timestamp); + if (Yap_unify(ARG1, Yap_MkApplTerm(FunctorMutex, 2, ts) ) ) { + return TRUE; + } + Yap_Error(UNINSTANTIATION_ERROR, t1, "mutex_create on an existing mutex"); + return FALSE; } else if(IsAtomTerm(t1)) { if (!(mutp = NewMutex())) return FALSE; return Yap_PutAtomMutex( AtomOfTerm(t1), mutp ); - } else if (IsAddressTerm(t1)) { - - - - - - - - + } else if (IsApplTerm(t1) && FunctorOfTerm(t1) == FunctorMutex) { + Yap_Error(UNINSTANTIATION_ERROR, t1, "mutex_create on an existing mutex"); return FALSE; } return FALSE; } - static Int p_destroy_mutex( USES_REGS1 ) +/** @pred mutex_destroy(+ _MutexId_) + + Destroy a mutex. After this call, _MutexId_ becomes invalid and + further references yield an `existence_error` exception. +*/ +static Int p_destroy_mutex( USES_REGS1 ) { SWIMutex *mut = MutexOfTerm(Deref(ARG1)); if (!mut) return FALSE; if (pthread_mutex_destroy(&mut->m) < 0) - return FALSE; - Yap_FreeCodeSpace((void *)mut); + return FALSE; + if (mut->alias) { + mut->alias->Mutex = NULL; + } + mut->owners = -1; + mut->tid_own = -1; + LOCK(GLOBAL_MUT_ACCESS); + if (GLOBAL_FreeMutexes) + mut->prev = GLOBAL_FreeMutexes->prev; + else + mut->prev = NULL; + mut->next = GLOBAL_FreeMutexes; + GLOBAL_FreeMutexes = mut; + UNLOCK(GLOBAL_MUT_ACCESS); return TRUE; } @@ -976,11 +1024,17 @@ LockMutex( SWIMutex *mut USES_REGS) #endif mut->owners++; mut->tid_own = worker_id; + if (LOCAL_Mutexes) + mut->prev = LOCAL_Mutexes->prev; + else + mut->prev = NULL; + mut->next = LOCAL_Mutexes; + LOCAL_Mutexes = NULL; return true; } static bool -UnLockMutex( SWIMutex *mut ) +UnLockMutex( SWIMutex *mut USES_REGS) { #if DEBUG_LOCKS MUTEX_UNLOCK(&mut->m); @@ -989,9 +1043,39 @@ UnLockMutex( SWIMutex *mut ) return FALSE; #endif mut->owners--; + if (mut->prev) { + mut->prev->next = mut->next; + } else { + LOCAL_Mutexes = mut->next; + if (mut->next) + mut->next->prev = NULL; + } + if (mut->next) + mut->next->prev = mut->prev; return true; } +/** @pred mutex_lock(+ _MutexId_) + + + Lock the mutex. Prolog mutexes are recursive mutexes: they + can be locked multiple times by the same thread. Only after unlocking + it as many times as it is locked, the mutex becomes available for + locking by other threads. If another thread has locked the mutex the + calling thread is suspended until to mutex is unlocked. + + If _MutexId_ is an atom, and there is no current mutex with that + name, the mutex is created automatically using mutex_create/1. This + implies named mutexes need not be declared explicitly. + + Please note that locking and unlocking mutexes should be paired + carefully. Especially make sure to unlock mutexes even if the protected + code fails or raises an exception. For most common cases use + with_mutex/2, which provides a safer way for handling Prolog-level + mutexes. + + +*/ static Int p_lock_mutex( USES_REGS1 ) { @@ -1001,6 +1085,14 @@ p_lock_mutex( USES_REGS1 ) return TRUE; } +/** @pred mutex_trylock(+ _MutexId_) + + + As mutex_lock/1, but if the mutex is held by another thread, this + predicates fails immediately. + + +*/ static Int p_trylock_mutex( USES_REGS1 ) { @@ -1015,15 +1107,40 @@ p_trylock_mutex( USES_REGS1 ) return TRUE; } +/** @pred mutex_unlock(+ _MutexId_) + + + Unlock the mutex. This can only be called if the mutex is held by the + calling thread. If this is not the case, a `permission_error` + exception is raised. + + +*/ static Int p_unlock_mutex( USES_REGS1 ) { SWIMutex *mut = MutexOfTerm(Deref(ARG1)); - if (!mut || !UnLockMutex( mut )) + if (!mut || !UnLockMutex( mut PASS_REGS)) return FALSE; return TRUE; } +/** @pred with_mutex(+ _MutexId_, : _Goal_) + + + Execute _Goal_ while holding _MutexId_. If _Goal_ leaves + choicepoints, these are destroyed (as in once/1). The mutex is unlocked + regardless of whether _Goal_ succeeds, fails or raises an exception. + An exception thrown by _Goal_ is re-thrown after the mutex has been + successfully unlocked. See also `mutex_create/2`. + + Although described in the thread-section, this predicate is also + available in the single-threaded version, where it behaves simply as + once/1. + + +*/ + static Int p_with_mutex( USES_REGS1 ) { @@ -1084,7 +1201,7 @@ p_with_mutex( USES_REGS1 ) } end: excep = Yap_GetException(); - if ( !UnLockMutex(mut) ) { + if ( !UnLockMutex(mut PASS_REGS) ) { return FALSE; } if (creeping) { @@ -1559,11 +1676,11 @@ void Yap_InitThreadPreds(void) */ Yap_InitCPred("$valid_thread", 1, p_valid_thread, 0); Yap_InitCPred("mutex_create", 1, p_new_mutex, SafePredFlag); - Yap_InitCPred("$destroy_mutex", 1, p_destroy_mutex, SafePredFlag); - Yap_InitCPred("$lock_mutex", 1, p_lock_mutex, SafePredFlag); - Yap_InitCPred("$trylock_mutex", 1, p_trylock_mutex, SafePredFlag); - Yap_InitCPred("$unlock_mutex", 1, p_unlock_mutex, SafePredFlag); - Yap_InitCPred("$with_mutex", 2, p_with_mutex, MetaPredFlag); + Yap_InitCPred("mutex_destroy", 1, p_destroy_mutex, SafePredFlag); + Yap_InitCPred("mutex_lock", 1, p_lock_mutex, SafePredFlag); + Yap_InitCPred("mutex_trylock", 1, p_trylock_mutex, SafePredFlag); + Yap_InitCPred("mutex_unlock", 1, p_unlock_mutex, SafePredFlag); + Yap_InitCPred("with_mutex", 2, p_with_mutex, MetaPredFlag); Yap_InitCPred("$with_with_mutex", 1, p_with_with_mutex, 0); Yap_InitCPred("$unlock_with_mutex", 1, p_unlock_with_mutex, 0); Yap_InitCPred("$mutex_info", 3, p_mutex_info, SafePredFlag); diff --git a/H/Yatom.h b/H/Yatom.h index e58ccd0d1..fde5413ee 100755 --- a/H/Yatom.h +++ b/H/Yatom.h @@ -1346,7 +1346,7 @@ IsTranslationProperty (int flags) p = RepMutexProp(p0 = p->NextOfPE); READ_UNLOCK(ae->ARWLock); if (p0 == NIL) return NULL; - return p; + return p->Mutex; } INLINE_ONLY inline EXTERN PropFlags IsMutexProperty (int); diff --git a/H/dglobals.h b/H/dglobals.h index 4b0f9fb27..8e9db9c00 100644 --- a/H/dglobals.h +++ b/H/dglobals.h @@ -125,3 +125,9 @@ #define GLOBAL_FPreds Yap_global->FPreds_ #endif /* LOW_PROF */ +#if THREADS +#define GLOBAL_FreeMutexes Yap_global->FreeMutexes_ +#define GLOBAL_mutex_backbone Yap_global->mutex_backbone_ +#define GLOBAL_MUT_ACCESS Yap_global->MUT_ACCESS_ +#endif + diff --git a/H/dlocals.h b/H/dlocals.h index b736dca66..7ee85a0b1 100644 --- a/H/dlocals.h +++ b/H/dlocals.h @@ -91,6 +91,8 @@ #define REMOTE_ArithError(wid) REMOTE(wid)->ArithError_ #define LOCAL_LastAssertedPred LOCAL->LastAssertedPred_ #define REMOTE_LastAssertedPred(wid) REMOTE(wid)->LastAssertedPred_ +#define LOCAL_TmpPred LOCAL->TmpPred_ +#define REMOTE_TmpPred(wid) REMOTE(wid)->TmpPred_ #define LOCAL_ScannerStack LOCAL->ScannerStack_ #define REMOTE_ScannerStack(wid) REMOTE(wid)->ScannerStack_ #define LOCAL_ScannerExtraBlocks LOCAL->ScannerExtraBlocks_ @@ -424,6 +426,9 @@ #define LOCAL_CurSlot LOCAL->CurSlot_ #define REMOTE_CurSlot(wid) REMOTE(wid)->CurSlot_ + +#define LOCAL_Mutexes LOCAL->Mutexes_ +#define REMOTE_Mutexes(wid) REMOTE(wid)->Mutexes_ #define LOCAL_SourceModule LOCAL->SourceModule_ #define REMOTE_SourceModule(wid) REMOTE(wid)->SourceModule_ #define LOCAL_MAX_SIZE LOCAL->MAX_SIZE_ diff --git a/H/hglobals.h b/H/hglobals.h index b4488d49f..4b026a72b 100644 --- a/H/hglobals.h +++ b/H/hglobals.h @@ -124,4 +124,10 @@ typedef struct global_data { FILE* FProf_; FILE* FPreds_; #endif /* LOW_PROF */ + +#if THREADS + struct swi_mutex* FreeMutexes_; + struct swi_mutex* mutex_backbone_; + lockvar MUT_ACCESS_; +#endif } w_shared; diff --git a/H/hlocals.h b/H/hlocals.h index 2155f3561..97e46b782 100644 --- a/H/hlocals.h +++ b/H/hlocals.h @@ -52,6 +52,7 @@ typedef struct worker_local { Int DepthArenas_; int ArithError_; struct pred_entry* LastAssertedPred_; + struct pred_entry* TmpPred_; char* ScannerStack_; struct scanner_extra_alloc* ScannerExtraBlocks_; struct DB_TERM* BallTerm_; @@ -239,6 +240,8 @@ typedef struct worker_local { struct scan_atoms* search_atoms_; yhandle_t CurSlot_; + + struct swi_mutex* Mutexes_; Term SourceModule_; size_t MAX_SIZE_; } w_local; diff --git a/H/iatoms.h b/H/iatoms.h index c6261dee7..b4cf99d55 100644 --- a/H/iatoms.h +++ b/H/iatoms.h @@ -189,6 +189,7 @@ AtomMultiple = Yap_FullLookupAtom("multiple"); AtomMutable = Yap_LookupAtom("mutable"); AtomMutableVariable = Yap_FullLookupAtom("$mutable_variable"); + AtomMutex = Yap_LookupAtom("mutex"); AtomMyddasDB = Yap_FullLookupAtom("$myddas_db"); AtomMyddasGoal = Yap_FullLookupAtom("$myddas_goal"); AtomMyddasHost = Yap_FullLookupAtom("$myddas_host"); @@ -435,6 +436,7 @@ FunctorModule = Yap_MkFunctor(AtomColomn,2); FunctorMultiFileClause = Yap_MkFunctor(AtomMfClause,5); FunctorMutable = Yap_MkFunctor(AtomMutableVariable,(sizeof(timed_var)/sizeof(CELL))); + FunctorMutex = Yap_MkFunctor(AtomMutex,2); FunctorNotImplemented = Yap_MkFunctor(AtomNotImplemented,2); FunctorNBQueue = Yap_MkFunctor(AtomQueue,4); FunctorNot = Yap_MkFunctor(AtomNot,1); diff --git a/H/iglobals.h b/H/iglobals.h index c2b3192c1..55be20c76 100644 --- a/H/iglobals.h +++ b/H/iglobals.h @@ -124,4 +124,10 @@ static void InitGlobal(void) { GLOBAL_FProf = NULL; GLOBAL_FPreds = NULL; #endif /* LOW_PROF */ + +#if THREADS + GLOBAL_FreeMutexes = NULL; + GLOBAL_mutex_backbone = NULL; + INIT_LOCK(GLOBAL_MUT_ACCESS); +#endif } diff --git a/H/ilocals.h b/H/ilocals.h index de533238e..be24afb59 100755 --- a/H/ilocals.h +++ b/H/ilocals.h @@ -52,6 +52,7 @@ static void InitWorker(int wid) { REMOTE_DepthArenas(wid) = 0; REMOTE_ArithError(wid) = FALSE; REMOTE_LastAssertedPred(wid) = NULL; + REMOTE_TmpPred(wid) = NULL; REMOTE_ScannerStack(wid) = NULL; REMOTE_ScannerExtraBlocks(wid) = NULL; REMOTE_BallTerm(wid) = NULL; @@ -239,6 +240,8 @@ static void InitWorker(int wid) { REMOTE_CurSlot(wid) = 0; + + REMOTE_Mutexes(wid) = NULL; REMOTE_SourceModule(wid) = 0; REMOTE_MAX_SIZE(wid) = 1024L; } diff --git a/H/ratoms.h b/H/ratoms.h index a051e3e78..d8558bcbc 100644 --- a/H/ratoms.h +++ b/H/ratoms.h @@ -189,6 +189,7 @@ AtomMultiple = AtomAdjust(AtomMultiple); AtomMutable = AtomAdjust(AtomMutable); AtomMutableVariable = AtomAdjust(AtomMutableVariable); + AtomMutex = AtomAdjust(AtomMutex); AtomMyddasDB = AtomAdjust(AtomMyddasDB); AtomMyddasGoal = AtomAdjust(AtomMyddasGoal); AtomMyddasHost = AtomAdjust(AtomMyddasHost); @@ -435,6 +436,7 @@ FunctorModule = FuncAdjust(FunctorModule); FunctorMultiFileClause = FuncAdjust(FunctorMultiFileClause); FunctorMutable = FuncAdjust(FunctorMutable); + FunctorMutex = FuncAdjust(FunctorMutex); FunctorNotImplemented = FuncAdjust(FunctorNotImplemented); FunctorNBQueue = FuncAdjust(FunctorNBQueue); FunctorNot = FuncAdjust(FunctorNot); diff --git a/H/rglobals.h b/H/rglobals.h index 3f7d2cdd4..aee512d84 100644 --- a/H/rglobals.h +++ b/H/rglobals.h @@ -124,4 +124,10 @@ static void RestoreGlobal(void) { #endif /* LOW_PROF */ + +#if THREADS + + + REINIT_LOCK(GLOBAL_MUT_ACCESS); +#endif } diff --git a/H/rlocals.h b/H/rlocals.h index 20c129762..e8183562f 100644 --- a/H/rlocals.h +++ b/H/rlocals.h @@ -54,6 +54,7 @@ static void RestoreWorker(int wid USES_REGS) { + RestoreBallTerm(wid); @@ -241,4 +242,6 @@ static void RestoreWorker(int wid USES_REGS) { + + } diff --git a/H/tatoms.h b/H/tatoms.h index c03abd665..ce1e0c8cc 100644 --- a/H/tatoms.h +++ b/H/tatoms.h @@ -376,6 +376,8 @@ #define AtomMutable Yap_heap_regs->AtomMutable_ Atom AtomMutableVariable_; #define AtomMutableVariable Yap_heap_regs->AtomMutableVariable_ + Atom AtomMutex_; +#define AtomMutex Yap_heap_regs->AtomMutex_ Atom AtomMyddasDB_; #define AtomMyddasDB Yap_heap_regs->AtomMyddasDB_ Atom AtomMyddasGoal_; @@ -868,6 +870,8 @@ #define FunctorMultiFileClause Yap_heap_regs->FunctorMultiFileClause_ Functor FunctorMutable_; #define FunctorMutable Yap_heap_regs->FunctorMutable_ + Functor FunctorMutex_; +#define FunctorMutex Yap_heap_regs->FunctorMutex_ Functor FunctorNotImplemented_; #define FunctorNotImplemented Yap_heap_regs->FunctorNotImplemented_ Functor FunctorNBQueue_; diff --git a/include/YapError.h b/include/YapError.h index 750b797f1..735f73e91 100644 --- a/include/YapError.h +++ b/include/YapError.h @@ -54,7 +54,8 @@ typedef enum EVALUATION_ERROR_UNDERFLOW, EVALUATION_ERROR_ZERO_DIVISOR, EXISTENCE_ERROR_ARRAY, - EXISTENCE_ERROR_KEY, + EXISTENCE_ERROR_KEY, + EXISTENCE_ERROR_MUTEX, EXISTENCE_ERROR_SOURCE_SINK, EXISTENCE_ERROR_STREAM, EXISTENCE_ERROR_VARIABLE, @@ -121,6 +122,7 @@ typedef enum TYPE_ERROR_UBYTE, TYPE_ERROR_UCHAR, TYPE_ERROR_VARIABLE, + UNINSTANTIATION_ERROR, UNKNOWN_ERROR } yap_error_number; diff --git a/misc/ATOMS b/misc/ATOMS index eb3645874..9da0be411 100644 --- a/misc/ATOMS +++ b/misc/ATOMS @@ -194,6 +194,7 @@ A MultiFile F "$mf" A Multiple F "multiple" A Mutable N "mutable" A MutableVariable F "$mutable_variable" +A Mutex N "mutex" A MyddasDB F "$myddas_db" A MyddasGoal F "$myddas_goal" A MyddasHost F "$myddas_host" @@ -440,6 +441,7 @@ F Minus Minus 2 F Module Colomn 2 F MultiFileClause MfClause 5 F Mutable MutableVariable (sizeof(timed_var)/sizeof(CELL)) +F Mutex Mutex 2 F NotImplemented NotImplemented 2 F NBQueue Queue 4 F Not Not 1 diff --git a/misc/GLOBALS b/misc/GLOBALS index 3401821f4..4782d203c 100755 --- a/misc/GLOBALS +++ b/misc/GLOBALS @@ -146,6 +146,12 @@ FILE* FProf =NULL FILE* FPreds =NULL #endif /* LOW_PROF */ +// Mutexes +#if THREADS +struct swi_mutex* FreeMutexes =NULL +struct swi_mutex* mutex_backbone =NULL +lockvar MUT_ACCESS MkLock +#endif END_GLOBAL_DATA diff --git a/misc/LOCALS b/misc/LOCALS index 5d4e498ac..7e7b00dde 100755 --- a/misc/LOCALS +++ b/misc/LOCALS @@ -55,7 +55,6 @@ Int DepthArenas =0 int ArithError =FALSE struct pred_entry* LastAssertedPred =NULL struct pred_entry* TmpPred =NULL -struct pred_entry* LastAssertedPred =NULL char* ScannerStack =NULL struct scanner_extra_alloc* ScannerExtraBlocks =NULL struct DB_TERM* BallTerm =NULL RestoreBallTerm(wid) @@ -276,6 +275,8 @@ struct scan_atoms* search_atoms void // Slots yhandle_t CurSlot =0 +// Mutexes +struct swi_mutex* Mutexes =NULL Term SourceModule =0 diff --git a/packages/yap-lbfgs/lbfgs.pl b/packages/yap-lbfgs/lbfgs.pl index b363002ec..dc8705250 100644 --- a/packages/yap-lbfgs/lbfgs.pl +++ b/packages/yap-lbfgs/lbfgs.pl @@ -163,6 +163,11 @@ optimizer_initialize(1,evaluate,progress) */ optimizer_initialize(N,Call_Evaluate,Call_Progress) :- optimizer_initialize(N,user,Call_Evaluate,Call_Progress). + +optimizer_initialize(N,Module,Call_Evaluate,Call_Progress) :- + optimizer_finalize, + !, + optimizer_initialize(N,Module,Call_Evaluate,Call_Progress). optimizer_initialize(N,Module,Call_Evaluate,Call_Progress) :- \+ initialized, diff --git a/pl/errors.yap b/pl/errors.yap index ae80e1c07..0fea2509d 100644 --- a/pl/errors.yap +++ b/pl/errors.yap @@ -342,8 +342,8 @@ print_message(_, Term) :- current_prolog_flag(verbose, silent), !. '$print_system_message'(Term, Level, Lines) :- ( Level == error -> Term \= error(syntax_error(_), _) ; Level == warning ), - '$messages':prefix(Level, LinePrefix, Stream, LinesF, Lines2), - '$messages':file_location(Lines2, Lines), !, + '$messages':prefix(Level, LinePrefix, Stream, Lines2, Lines), + '$messages':file_location(LinesF, Lines2), !, flush_output(user_output), flush_output(user_error), print_message_lines(Stream, LinePrefix, [nl|LinesF]). diff --git a/pl/messages.yap b/pl/messages.yap index 61adb879b..c70a6fcd5 100644 --- a/pl/messages.yap +++ b/pl/messages.yap @@ -68,13 +68,12 @@ handling in YAP: file_location --> { source_location(FileName, LN) }, - file_position(FileName,LN), - [ nl ]. + file_position(FileName,LN). file_position(user_input,LN) --> - [ 'at line ~d in user_input,' - [LN] ]. + [ 'user_input:~d:0: ' - [LN] ]. file_position(FileName,LN) --> - [ 'at line ~d in ~a,' - [LN,FileName] ]. + [ '~a:~d:0: ' - [FileName,LN] ]. translate_message(Term) --> generate_message(Term), !. @@ -125,7 +124,7 @@ generate_message(debug) --> !, generate_message(trace) --> !, [ trace ]. generate_message(error(Error,Context)) --> - { Error = existence_error(procedure,_) }, !, + { Error = existence_error(procedure,_) }, !, system_message(error(Error,Context)), stack_dump(error(Error,Context)). generate_message(error(Error,context(Cause,Extra))) --> @@ -146,7 +145,7 @@ stack_dump(_) --> []. prolog_message(X,Y,Z) :- system_message(X,Y,Z). -%message(loaded(Past,AbsoluteFileName,user,Msec,Bytes), Prefix, Suffix) :- !, + %message(loaded(Past,AbsoluteFileName,user,Msec,Bytes), Prefix, Suffix) :- !, system_message(query(_QueryResult,_)) --> []. system_message(format(Msg, Args)) --> [Msg - Args]. @@ -238,6 +237,8 @@ system_message(error(existence_error(directory,Key), Where)) --> [ 'EXISTENCE ERROR- ~w: ~w not an existing directory' - [Where,Key] ]. system_message(error(existence_error(key,Key), Where)) --> [ 'EXISTENCE ERROR- ~w: ~w not an existing key' - [Where,Key] ]. +system_message(error(existence_error(mutex,Key), Where)) --> + [ 'EXISTENCE ERROR- ~w: ~w is an erased mutex' - [Where,Key] ]. system_message(existence_error(prolog_flag,F)) --> [ 'Prolog Flag ~w: new Prolog flags must be created using create_prolog_flag/3.' - [F] ]. system_message(error(existence_error(prolog_flag,P), Where)) --> !, @@ -624,33 +625,33 @@ print_message_line(S, [Fmt|T0], T) :- prefix(help, '', user_error) --> []. prefix(query, '', user_error) --> []. prefix(debug, '', user_output) --> []. -prefix(warning, '% ', user_error) --> +prefix(warning, '', user_error) --> { thread_self(Id) }, ( { Id == main } - -> [ 'Warning: ', nl ] + -> [ 'warning: ', nl ] ; { atom(Id) } - -> ['Warning: [Thread ~a ]' - [Id], nl ] - ; ['Warning: [Thread ~d ]' - [Id], nl ] + -> ['warning: [Thread ~a ]' - [Id], nl ] + ; ['warning: [Thread ~d ]' - [Id], nl ] ). -prefix(error, ' ', user_error) --> +prefix(error, '', user_error) --> { recorded(sp_info,local_sp(P,_,_,_),_) }, { thread_self(Id) }, ( { Id == main } - -> [ 'ERROR at ' ] + -> [ 'error at ' ] ; { atom(Id) } - -> [ 'ERROR [ Thread ~a ] at ' - [Id] ] - ; [ 'ERROR [ Thread ~d ] at ' - [Id] ] + -> [ 'error [ Thread ~a ] at ' - [Id] ] + ; [ 'error [ Thread ~d ] at ' - [Id] ] ), '$hacks':display_pc(P), !, [' !!', nl]. -prefix(error, ' ', user_error) --> +prefix(error, '', user_error) --> { thread_self(Id) }, ( { Id == main } - -> [ 'ERROR!!', nl ] + -> [ 'error!!', nl ] ; { atom(Id) } - -> [ 'ERROR!! [ Thread ~a ]' - [Id], nl ] - ; [ 'ERROR!! [ Thread ~d ]' - [Id], nl ] + -> [ 'error!! [ Thread ~a ]' - [Id], nl ] + ; [ 'error!! [ Thread ~d ]' - [Id], nl ] ). prefix(banner, '', user_error) --> []. prefix(informational, '~*|% '-[LC], user_error) --> diff --git a/pl/threads.yap b/pl/threads.yap index a9dca3495..ad1964697 100644 --- a/pl/threads.yap +++ b/pl/threads.yap @@ -4,7 +4,7 @@ * * * Yap Prolog was developed at NCCUP - Universidade do Porto * * * -* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 * + * Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 * * * ************************************************************************** * * @@ -628,15 +628,10 @@ current_thread(Id, Status) :- '$thread_id_alias'(Id, Alias) :- - recorded('$thread_alias', [Id|Alias], _), !. + recorded('$thread_alias', [Id|Alias], _), !. '$thread_id_alias'(Id, Id). -'$mutex_id_alias'(Id, Alias) :- - recorded('$mutex_alias', [Id|Alias], _), !. -'$mutex_id_alias'(Id, Id). - - thread_property(Prop) :- '$check_thread_property'(Prop, thread_property(Prop)), @@ -872,11 +867,11 @@ change_address(Id, Address) :- /** @pred mutex_create(? _MutexId_) -Create a mutex. if _MutexId_ is an atom, a named mutex is -created. If it is a variable, an anonymous mutex reference is returned. -There is no limit to the number of mutexes that can be created. + Create a mutex. if _MutexId_ is an atom, a named mutex is + created. If it is a variable, an anonymous mutex reference is returned. + There is no limit to the number of mutexes that can be created. - + */ mutex_create(Id, Options) :- nonvar(Id), !, @@ -910,117 +905,6 @@ mutex_create(Id, Options) :- '$mutex_option'(Option, _, Goal) :- '$do_error'(domain_error(mutex_option, Option), Goal). -/* -mutex_create(V) :- - var(V), !, - '$new_mutex'(V), - recorda('$mutex_alias',[V|V],_). -mutex_create(A) :- - atom(A), - recorded('$mutex_alias',[_|A],_), !, - '$do_error'(permission_error(create,mutex,A),mutex_create(A)). -mutex_create(A) :- - atom(A), !, - '$new_mutex'(Id), - recorda('$mutex_alias',[Id|A],_). -mutex_create(V) :- - '$do_error'(type_error(atom,V),mutex_create(V)). -*/ - -/** @pred mutex_destroy(+ _MutexId_) - - -Destroy a mutex. After this call, _MutexId_ becomes invalid and -further references yield an `existence_error` exception. - - -*/ -mutex_destroy(Mutex) :- - '$check_mutex_or_alias'(Mutex, mutex_destroy(Mutex)), - '$mutex_id_alias'(Id, Mutex), - '$destroy_mutex'(Id), - '$erase_mutex_info'(Id). - -'$erase_mutex_info'(Id) :- - recorded('$mutex_alias',[Id|_],R), - erase(R), - fail. -'$erase_mutex_info'(_). - - -/** @pred mutex_lock(+ _MutexId_) - - -Lock the mutex. Prolog mutexes are recursive mutexes: they -can be locked multiple times by the same thread. Only after unlocking -it as many times as it is locked, the mutex becomes available for -locking by other threads. If another thread has locked the mutex the -calling thread is suspended until to mutex is unlocked. - -If _MutexId_ is an atom, and there is no current mutex with that -name, the mutex is created automatically using mutex_create/1. This -implies named mutexes need not be declared explicitly. - -Please note that locking and unlocking mutexes should be paired -carefully. Especially make sure to unlock mutexes even if the protected -code fails or raises an exception. For most common cases use -with_mutex/2, which provides a safer way for handling Prolog-level -mutexes. - - -*/ -mutex_lock(V) :- - var(V), !, - '$do_error'(instantiation_error,mutex_lock(V)). -mutex_lock(A) :- - recorded('$mutex_alias',[Id|A],_), !, - '$lock_mutex'(Id). -mutex_lock(A) :- - atom(A), !, - mutex_create(A), - mutex_lock(A). -mutex_lock(V) :- - '$do_error'(type_error(mutex,V),mutex_lock(V)). - -/** @pred mutex_trylock(+ _MutexId_) - - -As mutex_lock/1, but if the mutex is held by another thread, this -predicates fails immediately. - - -*/ -mutex_trylock(V) :- - var(V), !, - '$do_error'(instantiation_error,mutex_trylock(V)). -mutex_trylock(A) :- - recorded('$mutex_alias',[Id|A],_), !, - '$trylock_mutex'(Id). -mutex_trylock(A) :- - atom(A), !, - mutex_create(A), - mutex_trylock(A). -mutex_trylock(V) :- - '$do_error'(type_error(mutex,V),mutex_trylock(V)). - -/** @pred mutex_unlock(+ _MutexId_) - - -Unlock the mutex. This can only be called if the mutex is held by the -calling thread. If this is not the case, a `permission_error` -exception is raised. - - -*/ -mutex_unlock(Mutex) :- - '$check_mutex_or_alias'(Mutex, mutex_unlock(Mutex)), - '$mutex_id_alias'(Id, Mutex), - ( '$unlock_mutex'(Id) -> - true - ; - '$do_error'(permission_error(unlock,mutex,Mutex),mutex_unlock(Mutex)) - ). - /** @pred mutex_unlock_all @@ -1048,54 +932,6 @@ mutex_unlock_all :- '$unlock_mutex'(Id), '$mutex_unlock_all'(Id). -/** @pred with_mutex(+ _MutexId_, : _Goal_) - - -Execute _Goal_ while holding _MutexId_. If _Goal_ leaves -choicepoints, these are destroyed (as in once/1). The mutex is unlocked -regardless of whether _Goal_ succeeds, fails or raises an exception. -An exception thrown by _Goal_ is re-thrown after the mutex has been -successfully unlocked. See also `mutex_create/2`. - -Although described in the thread-section, this predicate is also -available in the single-threaded version, where it behaves simply as -once/1. - - -*/ - -with_mutex(M, G) :- - ( recorded('$mutex_alias',[Id|M],_) -> - '$with_mutex'(Id, G ) - ; - atom(M ) -> - mutex_create(Id, [alias(M)]), - '$with_mutex'(M, G ) - ; - integer(M) -> - '$with_mutex'(M, G ) - ; - '$do_error'(type_error(mutex,M), with_mutex(M, G)) - ), nonvar(G). % preserve env. - - -/* -with_mutex(M, G) :- - ( '$no_threads' -> - once(G) - ; - mutex_lock(M), - var(G) -> mutex_unlock(M), '$do_error'(instantiation_error,with_mutex(M, G)) - ; - \+ callable(G) -> - mutex_unlock(M), '$do_error'(type_error(callable,G),with_mutex(M, G)) - ; - catch('$execute'(G), E, (mutex_unlock(M), throw(E))) -> - mutex_unlock(M) - ; mutex_unlock(M), - fail - ). -*/ /** @pred current_mutex(? _MutexId_, ? _ThreadId_, ? _Count_)