From e7355ac1fc90159aa25cd4d6b73e20487f0bbe9b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Mon, 4 May 2020 17:28:55 +0200 Subject: [PATCH 01/11] doc: mp: sem: fix a type with a function index --- src/doc/manual/extensions/mp_ref_sem.txi | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/doc/manual/extensions/mp_ref_sem.txi b/src/doc/manual/extensions/mp_ref_sem.txi index 7ca12cfd4..cedc4303d 100644 --- a/src/doc/manual/extensions/mp_ref_sem.txi +++ b/src/doc/manual/extensions/mp_ref_sem.txi @@ -85,7 +85,7 @@ was acquired. @end defun -@lspdef mp_signal_semaphore +@cppdef mp_signal_semaphore @lspdef mp:signal-semaphore @deftypefun cl_object mp_signal_semaphore (cl_narg n, cl_object sem, ...); From 0ab85fc9d5681954509ee4ec46dc77694ab4f318 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Mon, 4 May 2020 19:24:17 +0200 Subject: [PATCH 02/11] conditions: add an ext:timeout serious condition --- src/c/error.d | 6 ++++++ src/c/symbols_list.h | 2 +- src/c/symbols_list2.h | 2 +- src/clos/conditions.lsp | 8 ++++++++ src/h/external.h | 1 + 5 files changed, 17 insertions(+), 2 deletions(-) diff --git a/src/c/error.d b/src/c/error.d index 851f69ded..20c0f4b4b 100644 --- a/src/c/error.d +++ b/src/c/error.d @@ -386,6 +386,12 @@ FEprint_not_readable(cl_object x) cl_error(3, @'print-not-readable', @':object', x); } +void +FEtimeout() +{ + cl_error(1, @'ext::timeout'); +} + /************* * Shortcuts * *************/ diff --git a/src/c/symbols_list.h b/src/c/symbols_list.h index 2c762e7ca..16147c015 100755 --- a/src/c/symbols_list.h +++ b/src/c/symbols_list.h @@ -1562,7 +1562,7 @@ cl_symbols[] = { {SYS_ "ROOM-REPORT", SI_ORDINARY, si_room_report, -1, OBJNULL}, {SYS_ "RESET-GC-COUNT", SI_ORDINARY, si_reset_gc_count, -1, OBJNULL}, #endif /* !GBC_BOEHM */ - +{EXT_ "TIMEOUT", EXT_ORDINARY, NULL, -1, OBJNULL}, /* #ifdef ECL_THREADS */ {MP_ "PROCESS", MP_ORDINARY, NULL, -1, OBJNULL}, {MP_ "LOCK", MP_ORDINARY, NULL, -1, OBJNULL}, diff --git a/src/c/symbols_list2.h b/src/c/symbols_list2.h index a28cfbe8e..f2614b93e 100644 --- a/src/c/symbols_list2.h +++ b/src/c/symbols_list2.h @@ -1562,7 +1562,7 @@ cl_symbols[] = { {SYS_ "ROOM-REPORT","si_room_report",-1}, {SYS_ "RESET-GC-COUNT","si_reset_gc_count",-1}, #endif /* !GBC_BOEHM */ - +{EXT_ "TIMEOUT",NULL,-1}, /* #ifdef ECL_THREADS */ {MP_ "PROCESS",NULL,-1}, {MP_ "LOCK",NULL,-1}, diff --git a/src/clos/conditions.lsp b/src/clos/conditions.lsp index 254d585ae..fcab17e41 100644 --- a/src/clos/conditions.lsp +++ b/src/clos/conditions.lsp @@ -541,6 +541,14 @@ memory limits before executing the program again.")) () (:REPORT "Illegal instruction.")) +(define-condition ext:timeout (serious-condition) + ((value :initarg :value :initform nil)) + (:report (lambda (condition stream) + (format stream "Timeout occurred~@[ after ~A second~:P~]." + (slot-value condition 'value)))) + (:documentation + "Signaled when an operation does not complete within an allotted time budget.")) + (define-condition ext:unix-signal-received () ((code :type fixnum :initform 0 diff --git a/src/h/external.h b/src/h/external.h index e84e1d742..5f5fdcfa3 100755 --- a/src/h/external.h +++ b/src/h/external.h @@ -594,6 +594,7 @@ extern ECL_API void FEundefined_function(cl_object fname) ecl_attr_noreturn; extern ECL_API void FEinvalid_function(cl_object obj) ecl_attr_noreturn; extern ECL_API void FEinvalid_function_name(cl_object obj) ecl_attr_noreturn; extern ECL_API void FEprint_not_readable(cl_object obj) ecl_attr_noreturn; +extern ECL_API void FEtimeout() ecl_attr_noreturn; extern ECL_API cl_object CEerror(cl_object c, const char *err_str, int narg, ...); extern ECL_API void FElibc_error(const char *msg, int narg, ...) ecl_attr_noreturn; #if defined(ECL_MS_WINDOWS_HOST) || defined(cygwin) From a059991c12602793b1fde6b0368464af9142f89a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Tue, 12 May 2020 12:47:19 +0200 Subject: [PATCH 03/11] stress tests: use a new timeout condition --- src/tests/stress-tests/multiprocessing.lsp | 9 ++------- 1 file changed, 2 insertions(+), 7 deletions(-) diff --git a/src/tests/stress-tests/multiprocessing.lsp b/src/tests/stress-tests/multiprocessing.lsp index 6e0d58933..6d441a3f5 100644 --- a/src/tests/stress-tests/multiprocessing.lsp +++ b/src/tests/stress-tests/multiprocessing.lsp @@ -162,11 +162,6 @@ ;; Interrupts -(define-condition timeout (serious-condition) - ((value :initarg :value :reader timeout-value)) - (:report (lambda (c s) - (format s "timeout at ~a seconds" (timeout-value c))))) - ;;; simplified version of with-timeout from bordeaux-threads (defmacro with-timeout ((timeout) &body body) `(let (sleeper) @@ -184,7 +179,7 @@ (ignore-errors (throw 'timeout nil))))))) (throw 'exit (progn ,@body)))) - (error 'timeout :value ,timeout)) + (error 'ext:timeout :value ,timeout)) (when (mp:process-active-p sleeper) (ignore-errors (mp:process-kill sleeper)))))) @@ -202,7 +197,7 @@ (let ((timeout-value (log-random 1e-8 1e-2))) (handler-case (with-timeout (timeout-value) (sleep (* timeout-value 10))) - (timeout (c))))))) + (ext:timeout (c))))))) ;; interrupt safety of binding special variables (defvar *test-var* 0) From 6322e344151ae5b6a332b298b4c858e4f4c4b18a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Mon, 4 May 2020 19:26:33 +0200 Subject: [PATCH 04/11] mp: queue: use less cryptic names - variable name "o" is replaced with "mp_object" - typedef "mp_wait_test" to "cl_object(*c)(cl_env_ptr,cl_object)" --- src/c/threads/queue.d | 30 +++++++++++++++--------------- src/h/internal.h | 4 +++- 2 files changed, 18 insertions(+), 16 deletions(-) diff --git a/src/c/threads/queue.d b/src/c/threads/queue.d index 81ee4337d..09237c583 100755 --- a/src/c/threads/queue.d +++ b/src/c/threads/queue.d @@ -25,9 +25,9 @@ ecl_process_yield() #elif defined(HAVE_SCHED_H) sched_yield(); #else - ecl_musleep(0.0, 1);*/ + ecl_musleep(0.0, 1); #endif - } +} void ECL_INLINE ecl_get_spinlock(cl_env_ptr the_env, cl_object *lock) @@ -126,7 +126,7 @@ waiting_time(cl_index iteration, struct ecl_timeval *start) } static cl_object -ecl_wait_on_timed(cl_env_ptr env, cl_object (*condition)(cl_env_ptr, cl_object), cl_object o) +ecl_wait_on_timed(cl_env_ptr env, mp_wait_test condition, cl_object mp_object) { volatile const cl_env_ptr the_env = env; volatile cl_object own_process = the_env->own_process; @@ -149,16 +149,16 @@ ecl_wait_on_timed(cl_env_ptr env, cl_object (*condition)(cl_env_ptr, cl_object), ECL_UNWIND_PROTECT_BEGIN(the_env) { /* 2) Now we add ourselves to the queue. In order to * avoid a call to the GC, we try to reuse records. */ - print_lock("adding to queue", o); + print_lock("adding to queue", mp_object); own_process->process.woken_up = ECL_NIL; - wait_queue_nconc(the_env, o, record); + wait_queue_nconc(the_env, mp_object, record); ecl_bds_bind(the_env, @'ext::*interrupts-enabled*', ECL_T); ecl_check_pending_interrupts(the_env); /* This spinlock is here because the default path (fair) is * too slow */ for (iteration = 0; iteration < 10; iteration++) { - if (!Null(output = condition(the_env,o))) + if (!Null(output = condition(the_env, mp_object))) break; } @@ -170,14 +170,14 @@ ecl_wait_on_timed(cl_env_ptr env, cl_object (*condition)(cl_env_ptr, cl_object), * condition periodically. */ while (Null(output)) { ecl_musleep(waiting_time(iteration++, &start), 1); - output = condition(the_env, o); + output = condition(the_env, mp_object); } ecl_bds_unwind1(the_env); } ECL_UNWIND_PROTECT_EXIT { /* 4) At this point we wrap up. We remove ourselves * from the queue and unblock the lisp interrupt * signal. Note that we recover the cons for later use.*/ - wait_queue_delete(the_env, o, own_process); + wait_queue_delete(the_env, mp_object, own_process); own_process->process.queue_record = record; ECL_RPLACD(record, ECL_NIL); @@ -189,7 +189,7 @@ ecl_wait_on_timed(cl_env_ptr env, cl_object (*condition)(cl_env_ptr, cl_object), * semaphores, where the condition may be satisfied * more than once. */ if (Null(output)) { - ecl_wakeup_waiters(the_env, o, ECL_WAKEUP_ONE); + ecl_wakeup_waiters(the_env, mp_object, ECL_WAKEUP_ONE); } } ECL_UNWIND_PROTECT_END; ecl_bds_unwind1(the_env); @@ -227,7 +227,7 @@ ecl_wait_on_timed(cl_env_ptr env, cl_object (*condition)(cl_env_ptr, cl_object), */ cl_object -ecl_wait_on(cl_env_ptr env, cl_object (*condition)(cl_env_ptr, cl_object), cl_object o) +ecl_wait_on(cl_env_ptr env, mp_wait_test condition, cl_object mp_object) { #if defined(HAVE_SIGPROCMASK) volatile const cl_env_ptr the_env = env; @@ -257,14 +257,14 @@ ecl_wait_on(cl_env_ptr env, cl_object (*condition)(cl_env_ptr, cl_object), cl_ob /* 2) Now we add ourselves to the queue. */ own_process->process.woken_up = ECL_NIL; - wait_queue_nconc(the_env, o, record); + wait_queue_nconc(the_env, mp_object, record); ECL_UNWIND_PROTECT_BEGIN(the_env) { /* 3) At this point we may receive signals, but we * might have missed a wakeup event if that happened * between 0) and 2), which is why we start with the * check*/ - while (Null(output = condition(the_env, o))) + while (Null(output = condition(the_env, mp_object))) { /* This will wait until we get a signal that * demands some code being executed. Note that @@ -279,7 +279,7 @@ ecl_wait_on(cl_env_ptr env, cl_object (*condition)(cl_env_ptr, cl_object), cl_ob /* 4) At this point we wrap up. We remove ourselves * from the queue and unblock the lisp interrupt * signal. Note that we recover the cons for later use.*/ - wait_queue_delete(the_env, o, own_process); + wait_queue_delete(the_env, mp_object, own_process); own_process->process.queue_record = record; ECL_RPLACD(record, ECL_NIL); @@ -291,7 +291,7 @@ ecl_wait_on(cl_env_ptr env, cl_object (*condition)(cl_env_ptr, cl_object), cl_ob * semaphores, where the condition may be satisfied * more than once. */ if (Null(output)) { - ecl_wakeup_waiters(the_env, o, ECL_WAKEUP_ONE); + ecl_wakeup_waiters(the_env, mp_object, ECL_WAKEUP_ONE); } /* 6) Restoring signals is done last, to ensure that @@ -300,7 +300,7 @@ ecl_wait_on(cl_env_ptr env, cl_object (*condition)(cl_env_ptr, cl_object), cl_ob } ECL_UNWIND_PROTECT_END; return output; #else - return ecl_wait_on_timed(env, condition, o); + return ecl_wait_on_timed(env, condition, mp_object); #endif } diff --git a/src/h/internal.h b/src/h/internal.h index 5637cd3f3..4019daccd 100755 --- a/src/h/internal.h +++ b/src/h/internal.h @@ -469,12 +469,14 @@ extern cl_fixnum ecl_runtime(void); /* threads/mutex.d */ #ifdef ECL_THREADS +typedef cl_object (*mp_wait_test)(cl_env_ptr, cl_object); + extern void ecl_process_yield(void); extern void print_lock(char *s, cl_object lock, ...); #define print_lock(...) ((void)0) extern void ecl_get_spinlock(cl_env_ptr env, cl_object *lock); extern void ecl_giveup_spinlock(cl_object *lock); -extern cl_object ecl_wait_on(cl_env_ptr env, cl_object (*condition)(cl_env_ptr, cl_object), cl_object o); +extern cl_object ecl_wait_on(cl_env_ptr env, mp_wait_test test, cl_object object); extern void ecl_wakeup_waiters(cl_env_ptr the_env, cl_object o, int flags); extern void ecl_wakeup_process(cl_object process); extern cl_object ecl_waiter_pop(cl_env_ptr the_env, cl_object q); From 7dd6609e21203e45323a2f34114816568204609b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Mon, 4 May 2020 19:34:23 +0200 Subject: [PATCH 05/11] mp: condition variable: fix invalid test for recursiveness Recursive locks may be determined from the object header while reading the counter is wrong, because at a time of testing with the CV counter may be exactly 1 despite the fact that the lock is recursive. --- src/c/threads/condition_variable.d | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/src/c/threads/condition_variable.d b/src/c/threads/condition_variable.d index d515e2aaf..d1dc0cda3 100644 --- a/src/c/threads/condition_variable.d +++ b/src/c/threads/condition_variable.d @@ -55,8 +55,7 @@ mp_condition_variable_wait(cl_object cv, cl_object lock) @[mp::lock]); } unlikely_if (cv->condition_variable.lock != ECL_NIL && - cv->condition_variable.lock != lock) - { + cv->condition_variable.lock != lock) { FEerror("Attempt to associate lock ~A~%with condition variable ~A," "~%which is already associated to lock ~A", 2, lock, cv, cv->condition_variable.lock); @@ -65,7 +64,7 @@ mp_condition_variable_wait(cl_object cv, cl_object lock) FEerror("Attempt to wait on a condition variable using lock~%~S" "~%which is not owned by process~%~S", 2, lock, own_process); } - unlikely_if (lock->lock.counter > 1) { + unlikely_if (lock->lock.recursive) { FEerror("mp:condition-variable-wait can not be used with recursive" " locks:~%~S", 1, lock); } From 0bd6bd6573f8b865fd2d851866173ef568c2ebe3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Mon, 4 May 2020 19:35:38 +0200 Subject: [PATCH 06/11] cosmetic: cmp: proclamations: add missing periods --- src/cmp/proclamations.lsp | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/src/cmp/proclamations.lsp b/src/cmp/proclamations.lsp index 54839d2ad..51b99305a 100644 --- a/src/cmp/proclamations.lsp +++ b/src/cmp/proclamations.lsp @@ -85,15 +85,15 @@ (deftype external-file-format () '(or symbol list)) (deftype declaration-specifier () - "Element that can appear in a DECLARE form" + "Element that can appear in a DECLARE form." 'list) (deftype digit-weight () '(integer 0 35)) (deftype environment () - "Environment used by compiler and interpreter" + "Environment used by compiler and interpreter." 'list) (deftype form () - "Valid lisp form" + "Valid lisp form." t) (deftype format-control () "Format control for FORMAT. It can be a string or a function returned by FORMATTER." @@ -102,16 +102,16 @@ "An object that denotes a function and which can be a symbol or a function." '(or symbol function)) (deftype function-name () - "Valid name of a function, typically a symbol or (SETF symbol)" + "Valid name of a function, typically a symbol or (SETF symbol)." '(or list symbol)) (deftype gen-bool () - "Generalized boolean type" + "Generalized boolean type." 't) (deftype integer-length () - "A type that fits maximum number of bits that an integer may have in this system" + "A type that fits maximum number of bits that an integer may have in this system." 'ext:array-index) (deftype natural () - "Non-negative number" + "Non-negative integer." '(integer 0 *)) (deftype package-designator () '(or string-designator package)) From 97411478746fb9317288139101f8b150c357aa4d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Mon, 4 May 2020 19:52:10 +0200 Subject: [PATCH 07/11] doc: add few annotations for multiprocessing primitives Mailboxes, barriers and rwlocks are still missing. This is important if we want to have hints in SLIME for arglists. --- src/doc/help.lsp | 76 +++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 75 insertions(+), 1 deletion(-) diff --git a/src/doc/help.lsp b/src/doc/help.lsp index 89e16185e..39b0d0aa3 100644 --- a/src/doc/help.lsp +++ b/src/doc/help.lsp @@ -3349,6 +3349,55 @@ Equivalent to creating a process with MP:MAKE-PROCESS, presetting it with MP:PROCESS-PRESET and starting with MP:PROCESS-ENABLE. Returns created process.") + ;; Mutexes + (docfun mp:make-lock function (&key name (recursive nil)) " +Creates a lock named NAME. If RECURSIVE is T then lock is reentrant.") + + (docfun mp:recursive-lock-p function (lock) " +Returns T if LOCK is reentrant, NIL otherwise.") + + (docfun mp:holding-lock-p function (lock) " +Returns T if the current thread holds LOCK, NIL otherwise.") + + (docfun mp:lock-name function (lock) " +Returns the name of LOCK.") + + (docfun mp:lock-owner function (lock) " +Returns the process owning LOCK. If the lock is not grabbed then +returns NIL. For testing whether the current thread is holding the +lock use MP:HOLDING-LOCK-P.") + + (docfun mp:lock-count function (lock) " +Returns number of processes waiting for LOCK.") + + (docfun mp:get-lock function (lock &optional (waitp t)) " +Tries to acquire LOCK. If WAITP is T (a default value), function +blocks until the lock may be acquired, otherwise it returns +immedietely. Returns T when the operation is successful, NIL +otherwise.") + + (docfun mp:giveup-lock function (lock) " +Releases LOCK.") + + ;; Condition variable interface + (docfun mp:make-condition-variable function () " +Creates a condition variable.") + + (docfun mp:condition-variable-wait function (cv lock) " +Release LOCK and suspend thread until condition +MP:CONDITION-VARIABLE-SIGNAL is called on CV. When thread resumes, +re-acquire LOCK.") + + (docfun mp:condition-variable-timedwait function (cv lock timeout) " +Same as MP:CONDITION-VARIABLE-WAIT but with TIMEOUT. If operation is +not complete before TIMEOUT seconds signals EXT:TIMEOUT.") + + (docfun mp:condition-variable-signal function (cv) " +Signal CV (wakes up only one waiter).") + + (docfun mp:condition-variable-broadcast function (cv) " +Signal CV (wakes up all waiters).") + ;; Semaphore interface (docfun mp:make-semaphore function (&key name count) " Creates a counting semaphore NAME with a resource count COUNT.") @@ -3368,7 +3417,32 @@ Tries to get a SEMAPHORE (non-blocking). If there is no resource left returns NIL, otherwise returns resource count before semaphore was acquired.") (docfun mp:signal-semaphore function (semaphore &optional (count 1)) " -Releases COUNT units of a resource on SEMAPHORE.")) +Releases COUNT units of a resource on SEMAPHORE.") + + ;; Mailboxes + (docfun mp:make-mailbox function (&key name (count 128)) "") + (docfun mp:mailbox-name function (mailbox) "") + (docfun mp:mailbox-empty-p function (mailbox) "") + (docfun mp:mailbox-read function (mailbox) "") + (docfun mp:mailbox-try-read function (mailbox) "") + (docfun mp:mailbox-send function (mailbox) "") + (docfun mp:mailbox-try-send function (mailbox) "") + + ;; Barriers + (docfun mp:make-barrier function (count &key name) "") + (docfun mp:barrier-name function (barrier) "") + (docfun mp:barrier-count function (barrier) "") + (docfun mp:barrier-arrivers-count function (barrier) "") + (docfun mp:barrier-wait function (barrier) "") + (docfun mp:barrier-unblock function (barrier &key reset-count disable kill-waiting) "") + + ;; RW-locks + (docfun mp:make-rwlock function (&key name) "") + (docfun mp:rwlock-name function (&key name) "") + (docfun mp:giveup-rwlock-read function (lock) "") + (docfun mp:giveup-rwlock-write function (lock) "") + (docfun mp:get-rwlock-read function (lock &optional (waitp t)) "") + (docfun mp:get-rwlock-write function (lock &optional (waitp t)) "")) #|| ;;; ---------------------------------------------------------------------- From 4d9b72a88b3ba37bd2a3461a23acc9aca3846b3d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Mon, 4 May 2020 19:54:56 +0200 Subject: [PATCH 08/11] ffi: use mp_get_lock_wait instead of mp_get_lock The former has a fixed number of arguments and is more low-level. --- src/c/ffi.d | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/c/ffi.d b/src/c/ffi.d index 289611910..f6b3ff17b 100644 --- a/src/c/ffi.d +++ b/src/c/ffi.d @@ -769,7 +769,7 @@ si_load_foreign_module(cl_object filename) cl_object output; # ifdef ECL_THREADS - mp_get_lock(1, ecl_symbol_value(@'mp::+load-compile-lock+')); + mp_get_lock_wait(ecl_symbol_value(@'mp::+load-compile-lock+')); ECL_UNWIND_PROTECT_BEGIN(ecl_process_env()) { # endif output = ecl_library_open(filename, 0); @@ -806,7 +806,7 @@ si_unload_foreign_module(cl_object module) 1, module); } # ifdef ECL_THREADS - mp_get_lock(1, ecl_symbol_value(@'mp::+load-compile-lock+')); + mp_get_lock_wait(ecl_symbol_value(@'mp::+load-compile-lock+')); ECL_UNWIND_PROTECT_BEGIN(ecl_process_env()) { # endif if (ecl_likely(ecl_library_close(module))) output = ECL_T; From f9db80dcbf929bf99e78e83a140aec3d22374477 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Tue, 5 May 2020 19:40:41 +0200 Subject: [PATCH 09/11] cmp: for LAMBDA use an associated function-block-name That makes lambda with a declaration si:function-block-name behave consistently with ext:lambda-block (and in eval-macros ext:lambda-block expands to have this declaration too to behave in turn consistently with how the compiler treats ext:lambda-block). --- src/cmp/cmpspecial.lsp | 10 +++++++--- src/lsp/evalmacros.lsp | 8 +++++--- 2 files changed, 12 insertions(+), 6 deletions(-) diff --git a/src/cmp/cmpspecial.lsp b/src/cmp/cmpspecial.lsp index 7dc2f3d10..82d2441c2 100644 --- a/src/cmp/cmpspecial.lsp +++ b/src/cmp/cmpspecial.lsp @@ -85,9 +85,13 @@ (cmpck (endp (cdr fun)) "The lambda expression ~s is illegal." fun) (let (name body) - (if (eq (first fun) 'EXT::LAMBDA) - (setf name (gensym) body (rest fun)) - (setf name (second fun) body (cddr fun))) + (if (eq (first fun) 'lambda) + (let ((decl (si::process-declarations (cddr fun)))) + (setf name (or (function-block-name-declaration decl) + (gensym "LAMBDA")) + body (rest fun))) + (setf name (second fun) + body (cddr fun))) (c1expr `(flet ((,name ,@body)) #',name)))) (t (cmperr "The function ~s is illegal." fun))))) diff --git a/src/lsp/evalmacros.lsp b/src/lsp/evalmacros.lsp index 1e17bab1b..98b2453b6 100644 --- a/src/lsp/evalmacros.lsp +++ b/src/lsp/evalmacros.lsp @@ -162,9 +162,11 @@ terminated by a non-local exit." (defmacro lambda-block (name lambda-list &rest lambda-body) (multiple-value-bind (decl body doc) (si::process-declarations lambda-body) - (when decl (setq decl (list (cons 'declare decl)))) - `(lambda ,lambda-list ,@doc ,@decl - (block ,(si::function-block-name name) ,@body)))) + (let ((decl (and decl (list (cons 'declare decl)))) + (block-name (si:function-block-name name))) + `(lambda ,lambda-list ,@doc ,@decl + (declare (si::function-block-name ,block-name)) + (block ,block-name ,@body))))) ; assignment From 44299c7221ab96befa427764cd3be97421799b3d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Mon, 11 May 2020 18:16:56 +0200 Subject: [PATCH 10/11] contrib: serve-event: make serve-event multithreading save Only call handlers established in the current thread and use atomic operations to update *descriptor-handlers*. Closes #588. Additionally: - improve the test code - add a test for the leak - provide internet machine link for the tutorial --- contrib/serve-event/event-test-async.lisp | 31 +++++++++ contrib/serve-event/event-test.lisp | 24 ++++--- contrib/serve-event/serve-event.lisp | 81 ++++++++++++++--------- 3 files changed, 94 insertions(+), 42 deletions(-) create mode 100644 contrib/serve-event/event-test-async.lisp diff --git a/contrib/serve-event/event-test-async.lisp b/contrib/serve-event/event-test-async.lisp new file mode 100644 index 000000000..5c13eadea --- /dev/null +++ b/contrib/serve-event/event-test-async.lisp @@ -0,0 +1,31 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Test that serve-event doesn't leak its handlers to other threads +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(require 'serve-event) + +(defun test-leak (&aux exit) + (let ((out *standard-output*)) + (print "Press enter." out) + (let* ((p1 (mp:process-run-function + 'stdin-2 + (lambda () + (serve-event:with-fd-handler + (0 :input #'(lambda (fd) + (declare (ignore fd)) + (format out "WRONG!~%"))) + (sleep most-positive-fixnum))))) + (p2 (mp:process-run-function + 'stdin-1 + (lambda () + (serve-event:with-fd-handler + (0 :input #'(lambda (fd) + (declare (ignore fd)) + (format out"GOOD!~%"))) + (unwind-protect (serve-event:serve-event) + (mp:interrupt-process p1 (lambda () + (mp:exit-process))))))))) + (mp:process-join p1) + (mp:process-join p2)))) + +(test-leak) diff --git a/contrib/serve-event/event-test.lisp b/contrib/serve-event/event-test.lisp index d80261f12..e1c7bfb61 100644 --- a/contrib/serve-event/event-test.lisp +++ b/contrib/serve-event/event-test.lisp @@ -4,16 +4,20 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (require 'serve-event) -(in-package "SERVE-EVENT") -(defun test-stdin () - (format t "DOING STDIN~%") - (with-fd-handler (0 :input #'(lambda (fd) (declare (ignore fd)) - (format t "Got data~%") - (read-char))) - (loop ;; FIXME: End condition - (format t "Entering serve-all-events...~%")(force-output) - (serve-all-events 5) - (format t "Events served~%")))) +(defun test-stdin (&aux exit) + (format t "DOING STDIN. Type Q to exit.~%") + (serve-event:with-fd-handler + (0 :input #'(lambda (fd) + (declare (ignore fd)) + (let ((ch (read-char))) + (format t "Got data ~s~%" ch) + (when (char= ch #\Q) + (setf exit t))))) + (loop until exit + do (format t "Entering serve-all-events...~%") + (force-output) + (serve-event:serve-all-events 5) + (format t "Events served~%")))) (test-stdin) diff --git a/contrib/serve-event/serve-event.lisp b/contrib/serve-event/serve-event.lisp index 204b5d684..528daad09 100644 --- a/contrib/serve-event/serve-event.lisp +++ b/contrib/serve-event/serve-event.lisp @@ -1,11 +1,10 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; -;; This file provides a port the SBCL/CMUCL 'serve-event' -;; functionality to ecl. serve-event provides a lispy abstraction of -;; unix select(2) non-blocking IO (and potentially other variants such as -;; epoll). It works with Unix-level file-descriptors, which can be -;; retrieved from the sockets module using the socket-file-descriptor -;; slot. +;; This file provides a port of the SBCL/CMUCL 'serve-event' extension +;; to ECL. serve-event provides a lispy abstraction of unix select(2) +;; non-blocking IO (and potentially other variants such as epoll). It +;; works with Unix-level file-descriptors, which can be retrieved from +;; the sockets module using the socket-file-descriptor slot. ;; ;; As this file is based on SBCL's serve-event module it is being ;; released under the same (non) license as SBCL (i.e. public-domain). @@ -16,29 +15,33 @@ ;; Test Example ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; -;; (defun test-stdin () -;; (format t "DOING STDIN~%") -;; (with-fd-handler (0 :input #'(lambda (fd) (declare (ignore fd)) -;; (format t "Got data~%") -;; (read-char))) -;; (loop ;; FIXME: End condition -;; (format t "Entering serve-all-events...~%")(force-output) -;; (serve-all-events 5) -;; (format t "Events served~%")))) +;; (defun test-stdin (&aux exit) +;; (format t "DOING STDIN. Type Q to exit.~%") +;; (serve-event:with-fd-handler +;; (0 :input #'(lambda (fd) +;; (declare (ignore fd)) +;; (let ((ch (read-char))) +;; (format t "Got data ~s~%" ch) +;; (when (char= ch #\Q) +;; (setf exit t))))) +;; (loop until exit +;; do (format t "Entering serve-all-events...~%") +;; (force-output) +;; (serve-event:serve-all-events 5) +;; (format t "Events served~%")))) ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; A more advanced example using sockets is available here: ;; -;; http://haltcondition.net/?p=2232 +;; https://web.archive.org/web/20161203154152/http://haltcondition.net/?p=2232 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defpackage "SERVE-EVENT" - (:use "CL" "FFI") - (:export "WITH-FD-HANDLER" "ADD-FD-HANDLER" "REMOVE-FD-HANDLER" - "SERVE-EVENT" "SERVE-ALL-EVENTS")) -(in-package "SERVE-EVENT") +(defpackage #:serve-event + (:use #:cl #:ffi) + (:export #:with-fd-handler #:add-fd-handler #:remove-fd-handler + #:serve-event #:serve-all-events)) +(in-package #:serve-event) (clines "#include " @@ -65,11 +68,12 @@ ;; FIXME: Should be based on FD_SETSIZE (descriptor 0) ;; Function to call. - (function nil :type function)) - + (function nil :type function) + ;; thread in which the handler was established + #+threads + (thread mp:*current-process*)) (defvar *descriptor-handlers* nil - #!+sb-doc "List of all the currently active handlers for file descriptors") (defun coerce-to-descriptor (stream-or-fd direction) @@ -85,6 +89,16 @@ #+clos-streams (stream (gray::stream-file-descriptor stream-or-fd direction)))) + +;;; serve-event calls only handlers which are established in the current thread +(defmacro do-handlers ((handler-symbol handler-list) &body body) + `(dolist (,handler-symbol ,handler-list) + #+threads + (when (eq mp:*current-process* (handler-thread ,handler-symbol)) + ,@body) + #-threads + ,@body)) + ;;; Add a new handler to *descriptor-handlers*. (defun add-fd-handler (stream-or-fd direction function) "Arrange to call FUNCTION whenever the fd designated by STREAM-OR-FD @@ -101,15 +115,18 @@ (let ((handler (make-handler (coerce-to-descriptor stream-or-fd direction) direction function))) - (push handler *descriptor-handlers*) + #+threads (mp:atomic-push handler *descriptor-handlers*) + #-threads (push handler *descriptor-handlers*) handler)) ;;; Remove an old handler from *descriptor-handlers*. (defun remove-fd-handler (handler) - #!+sb-doc "Removes HANDLER from the list of active handlers." - (setf *descriptor-handlers* - (delete handler *descriptor-handlers*))) + #+threads (mp:atomic-update *descriptor-handlers* + #'(lambda (all-handlers) + (remove handler all-handlers))) + #-threads (setf *descriptor-handlers* + (delete handler *descriptor-handlers*))) ;;; Add the handler to *descriptor-handlers* for the duration of BODY. (defmacro with-fd-handler ((fd direction function) &rest body) @@ -166,13 +183,13 @@ (let ((maxfd 0)) ;; Load the descriptors into the relevant set - (dolist (handler *descriptor-handlers*) + (do-handlers (handler *descriptor-handlers*) (let ((fd (handler-descriptor handler))) (ecase (handler-direction handler) (:input (fd-set fd rfd)) (:output (fd-set fd wfd))) (when (> fd maxfd) - (setf maxfd fd)))) + (setf maxfd fd)))) (multiple-value-bind (retval errno) (if (null seconds) @@ -207,7 +224,7 @@ ;; otherwise error (error "Error during select"))) ((plusp retval) - (dolist (handler *descriptor-handlers*) + (do-handlers (handler *descriptor-handlers*) (let ((fd (handler-descriptor handler))) (if (plusp (ecase (handler-direction handler) (:input (fd-isset fd rfd)) From 4b9d6d2b346cd24adbc9b9280be9e7a089965bd7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Tue, 12 May 2020 11:51:12 +0200 Subject: [PATCH 11/11] cosmetic: add noteworthy changes to the changelog --- CHANGELOG | 3 +++ 1 file changed, 3 insertions(+) diff --git a/CHANGELOG b/CHANGELOG index 1ec995843..70cf4ca4c 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -30,12 +30,15 @@ * Pending changes since 20.4.24 ** Announcement ** Enhancements +- less cryptic names in backtraces of C-compiled functions ** Issues fixed - The generational and precise garbage collector modes work again - ECL can now use precompiled headers to speed up compilation. Use ~(setq c::*use-precompiled-headers* nil)~ to disable this feature ** Issues fixed +- ~serve-event~ extension may be used simultaneously from different threads now ** API changes +- a condition ~ext:timeout~ is defined * 20.4.24 changes since 16.1.3 ** Announcement Dear Community,