sfos/ecl
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Merge branch 'mp-timedwait2' into 'develop'

Browse source 
Mp timedwait2

Closes #588

See merge request embeddable-common-lisp/ecl!217
This commit is contained in:
Marius Gerbershagen 2020-06-20 14:58:19 +00:00
commit c1b5aee6de
19 changed files with 233 additions and 87 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

3
CHANGELOG
View file

@ -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,

31
contrib/serve-event/event-test-async.lisp Normal file
View file

@ -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)

24
contrib/serve-event/event-test.lisp
View file

@ -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)

81
contrib/serve-event/serve-event.lisp
View file

@ -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 <errno.h>"
@ -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))

6
src/c/error.d
View file

@ -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 *
*************/

4
src/c/ffi.d
View file

@ -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;

2
src/c/symbols_list.h
View file

@ -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},

2
src/c/symbols_list2.h
View file

@ -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},

5
src/c/threads/condition_variable.d
View file

@ -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);
}

30
src/c/threads/queue.d
View file

@ -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
}

8
src/clos/conditions.lsp
View file

@ -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

10
src/cmp/cmpspecial.lsp
View file

@ -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)))))

14
src/cmp/proclamations.lsp
View file

@ -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))

76
src/doc/help.lsp
View file

@ -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)) ""))
#||
;;; ----------------------------------------------------------------------

2
src/doc/manual/extensions/mp_ref_sem.txi
View file

@ -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, ...);

1
src/h/external.h
View file

@ -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)

4
src/h/internal.h
View file

@ -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);

8
src/lsp/evalmacros.lsp
View file

@ -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

9
src/tests/stress-tests/multiprocessing.lsp
View file

@ -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)