mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2026-01-15 13:52:16 -08:00
Code Issues Projects Releases Packages Wiki Activity

Merge branch 'mmondor' into 'develop'

Browse source 
mmondor -> develop (with-rwlock …)

See merge request !2
This commit is contained in:
Matthew Mondor 2015-08-27 07:39:10 +00:00
commit a238c0fd92
8 changed files with 89 additions and 5 deletions
Download patch file Download diff file Expand all files Collapse all files

4
src/c/symbols_list.h
View file

@ -1564,6 +1564,7 @@ cl_symbols[] = {
{MP_ "INTERRUPT-PROCESS", MP_ORDINARY, IF_MP(mp_interrupt_process), 2, OBJNULL},
{MP_ "+LOAD-COMPILE-LOCK+", MP_CONSTANT, NULL, -1, OBJNULL},
{MP_ "WITH-LOCK", MP_CONSTANT, NULL, -1, OBJNULL},
{MP_ "WITH-RWLOCK", MP_CONSTANT, NULL, -1, OBJNULL},
{MP_ "BLOCK-SIGNALS", MP_ORDINARY, IF_MP(mp_block_signals), 0, OBJNULL},
{MP_ "RESTORE-SIGNALS", MP_ORDINARY, IF_MP(mp_restore_signals), 1, OBJNULL},
{MP_ "PROCESS-SUSPEND", MP_ORDINARY, IF_MP(mp_process_suspend), 1, OBJNULL},
@ -1584,6 +1585,7 @@ cl_symbols[] = {
{MP_ "MAKE-SEMAPHORE", MP_ORDINARY, IF_MP(mp_make_semaphore), -1, OBJNULL},
{MP_ "SIGNAL-SEMAPHORE", MP_ORDINARY, IF_MP(mp_signal_semaphore), -1, OBJNULL},
{MP_ "WAIT-ON-SEMAPHORE", MP_ORDINARY, IF_MP(mp_wait_on_semaphore), 1, OBJNULL},
{MP_ "TRY-GET-SEMAPHORE", MP_ORDINARY, IF_MP(mp_try_get_semaphore), 1, OBJNULL},
{MP_ "SEMAPHORE-COUNT", MP_ORDINARY, IF_MP(mp_semaphore_count), 1, OBJNULL},
{MP_ "SEMAPHORE-NAME", MP_ORDINARY, IF_MP(mp_semaphore_name), 1, OBJNULL},
{MP_ "SEMAPHORE-WAIT-COUNT", MP_ORDINARY, IF_MP(mp_semaphore_wait_count), 1, OBJNULL},
@ -1607,7 +1609,9 @@ cl_symbols[] = {
{MP_ "MAILBOX-COUNT", MP_ORDINARY, IF_MP(mp_mailbox_count), 1, OBJNULL},
{MP_ "MAILBOX-EMPTY-P", MP_ORDINARY, IF_MP(mp_mailbox_empty_p), 1, OBJNULL},
{MP_ "MAILBOX-READ", MP_ORDINARY, IF_MP(mp_mailbox_read), 1, OBJNULL},
{MP_ "MAILBOX-TRY-READ", MP_ORDINARY, IF_MP(mp_mailbox_try_read), 1, OBJNULL},
{MP_ "MAILBOX-SEND", MP_ORDINARY, IF_MP(mp_mailbox_send), 2, OBJNULL},
{MP_ "MAILBOX-TRY-SEND", MP_ORDINARY, IF_MP(mp_mailbox_try_send), 2, OBJNULL},
/* #endif defined(ECL_THREADS) */
{SYS_ "WHILE", SI_ORDINARY, NULL, -1, OBJNULL},

4
src/c/symbols_list2.h
View file

@ -1564,6 +1564,7 @@ cl_symbols[] = {
{MP_ "INTERRUPT-PROCESS",IF_MP("mp_interrupt_process")},
{MP_ "+LOAD-COMPILE-LOCK+",NULL},
{MP_ "WITH-LOCK",NULL},
{MP_ "WITH-RWLOCK",NULL},
{MP_ "BLOCK-SIGNALS",IF_MP("mp_block_signals")},
{MP_ "RESTORE-SIGNALS",IF_MP("mp_restore_signals")},
{MP_ "PROCESS-SUSPEND",IF_MP("mp_process_suspend")},
@ -1584,6 +1585,7 @@ cl_symbols[] = {
{MP_ "MAKE-SEMAPHORE",IF_MP("mp_make_semaphore")},
{MP_ "SIGNAL-SEMAPHORE",IF_MP("mp_signal_semaphore")},
{MP_ "WAIT-ON-SEMAPHORE",IF_MP("mp_wait_on_semaphore")},
{MP_ "TRY-GET-SEMAPHORE",IF_MP("mp_try_get_semaphore")},
{MP_ "SEMAPHORE-COUNT",IF_MP("mp_semaphore_count")},
{MP_ "SEMAPHORE-NAME",IF_MP("mp_semaphore_name")},
{MP_ "SEMAPHORE-WAIT-COUNT",IF_MP("mp_semaphore_wait_count")},
@ -1607,7 +1609,9 @@ cl_symbols[] = {
{MP_ "MAILBOX-COUNT",IF_MP("mp_mailbox_count")},
{MP_ "MAILBOX-EMPTY-P",IF_MP("mp_mailbox_empty_p")},
{MP_ "MAILBOX-READ",IF_MP("mp_mailbox_read")},
{MP_ "MAILBOX-TRY-READ",IF_MP("mp_mailbox_try_read")},
{MP_ "MAILBOX-SEND",IF_MP("mp_mailbox_send")},
{MP_ "MAILBOX-TRY-SEND",IF_MP("mp_mailbox_try_send")},
/* #endif defined(ECL_THREADS) */
{SYS_ "WHILE",NULL},

40
src/c/threads/mailbox.d
View file

@ -107,6 +107,25 @@ mp_mailbox_read(cl_object mailbox)
ecl_return1(env, output);
}
cl_object
mp_mailbox_try_read(cl_object mailbox)
{
cl_env_ptr env = ecl_process_env();
cl_fixnum ndx;
cl_object output;
unlikely_if (ecl_t_of(mailbox) != t_mailbox) {
FEerror_not_a_mailbox(mailbox);
}
output = mp_try_get_semaphore(mailbox->mailbox.reader_semaphore);
if (output != ECL_NIL) {
ndx = AO_fetch_and_add1((AO_t*)&mailbox->mailbox.read_pointer) &
mailbox->mailbox.mask;
output = mailbox->mailbox.data->vector.self.t[ndx];
mp_signal_semaphore(1, mailbox->mailbox.writer_semaphore);
}
ecl_return1(env, output);
}
cl_object
mp_mailbox_send(cl_object mailbox, cl_object msg)
{
@ -124,3 +143,24 @@ mp_mailbox_send(cl_object mailbox, cl_object msg)
mp_signal_semaphore(1, mailbox->mailbox.reader_semaphore);
ecl_return0(env);
}
cl_object
mp_mailbox_try_send(cl_object mailbox, cl_object msg)
{
cl_env_ptr env = ecl_process_env();
cl_object output;
cl_fixnum ndx;
unlikely_if (ecl_t_of(mailbox) != t_mailbox) {
FEerror_not_a_mailbox(mailbox);
}
output = mp_try_get_semaphore(mailbox->mailbox.writer_semaphore);
if (output != ECL_NIL) {
output = msg;
ndx = AO_fetch_and_add1((AO_t*)&mailbox->mailbox.write_pointer) &
mailbox->mailbox.mask;
mailbox->mailbox.data->vector.self.t[ndx] = msg;
mp_signal_semaphore(1, mailbox->mailbox.reader_semaphore);
}
ecl_return1(env, output);
}

12
src/c/threads/semaphore.d
View file

@ -127,3 +127,15 @@ mp_wait_on_semaphore(cl_object semaphore)
}
ecl_return1(env, output);
}
cl_object
mp_try_get_semaphore(cl_object semaphore)
{
cl_env_ptr env = ecl_process_env();
cl_object output;
unlikely_if (ecl_t_of(semaphore) != t_semaphore) {
FEerror_not_a_semaphore(semaphore);
}
ecl_return1(env, get_semaphore_inner(env, semaphore));
}

3
src/h/external.h
View file

@ -1734,6 +1734,7 @@ extern ECL_API cl_object mp_semaphore_count(cl_object);
extern ECL_API cl_object mp_semaphore_name(cl_object);
extern ECL_API cl_object mp_semaphore_wait_count(cl_object);
extern ECL_API cl_object mp_wait_on_semaphore(cl_object);
extern ECL_API cl_object mp_try_get_semaphore(cl_object);
extern ECL_API cl_object mp_signal_semaphore _ECL_ARGS((cl_narg, cl_object, ...));
extern ECL_API cl_object ecl_make_semaphore(cl_object name, cl_fixnum count);
@ -1754,7 +1755,9 @@ extern ECL_API cl_object mp_mailbox_name(cl_object mailbox);
extern ECL_API cl_object mp_mailbox_count(cl_object mailbox);
extern ECL_API cl_object mp_mailbox_empty_p(cl_object);
extern ECL_API cl_object mp_mailbox_read(cl_object mailbox);
extern ECL_API cl_object mp_mailbox_try_read(cl_object mailbox);
extern ECL_API cl_object mp_mailbox_send(cl_object mailbox, cl_object msg);
extern ECL_API cl_object mp_mailbox_try_send(cl_object mailbox, cl_object msg);
/* threads/atomic.c */

15
src/lsp/mp.lsp
View file

@ -133,3 +133,18 @@ by ALLOW-WITH-INTERRUPTS."
(> (the fixnum (mp:lock-count ,lock))
(the fixnum ,count))))
(mp::giveup-lock ,lock))))))))
#+ecl-read-write-lock
(defmacro with-rwlock ((lock op) &body body)
(assert (member op '(:read :write) :test #'eq))
(let ((s-lock (gensym)))
`(let ((,s-lock ,lock))
(,(if (eq :read op)
'mp:get-rwlock-read
'mp:get-rwlock-write) ,s-lock t)
(unwind-protect
(progn
,@body)
(,(if (eq :read op)
'mp:giveup-rwlock-read
'mp:giveup-rwlock-write) ,s-lock)))))

12
src/lsp/top.lsp
View file

@ -41,6 +41,7 @@
(defparameter *last-error* nil)
(defparameter *break-message* nil)
(defparameter *break-condition* nil)
(defparameter *break-readtable* nil)
(defparameter *tpl-level* -1) ; nesting level of top-level loops
@ -773,7 +774,7 @@ Use special code 0 to cancel this operation.")
(defun tpl-disassemble-command ()
(let*((*print-level* 2)
(*print-length* 4)
(*print-length* 16)
(*print-pretty* t)
(*print-escape* nil)
(*print-readably* nil)
@ -1014,7 +1015,7 @@ Use special code 0 to cancel this operation.")
(defun tpl-variables-command (&optional no-values)
(let*((*print-level* 2)
(*print-length* 4)
(*print-length* 16)
(*print-pretty* t)
(*print-escape* nil)
(*print-readably* nil))
@ -1060,7 +1061,7 @@ Use special code 0 to cancel this operation.")
(last (frs-bds (1+ *frs-top*)))
(fi *frs-base*)
(*print-level* 2)
(*print-length* 4)
(*print-length* 16)
(*print-pretty* t))
((> bi last) (values))
(do ()
@ -1134,7 +1135,7 @@ Use special code 0 to cancel this operation.")
((= k 0) (values))
(let*((j (or (sch-frs-base *frs-base* i) (1+ *frs-top*)))
(*print-level* 2)
(*print-length* 4)
(*print-length* 16)
(*print-pretty* t))
(do () ((or (> j *frs-top*) (> (frs-ihs j) i)))
(print-frs j)
@ -1429,10 +1430,11 @@ package."
(*print-readably* nil)
(*print-pretty* nil)
(*print-circle* t)
(*print-length* 2)
(*print-length* 16)
(*readtable* (or *break-readtable* *readtable*))
(*break-message* (format nil "~&Condition of type: ~A~%~A~%"
(type-of condition) condition))
(*break-condition* condition)
(*break-level* (1+ *break-level*))
(break-level *break-level*)
(*break-env* nil))

4
src/new-cmp/cmpmain.lsp
View file

@ -19,6 +19,10 @@
(defmacro with-lock ((lock) &body body)
`(progn ,@body))
#-ecl-read-write-lock
(defmacro with-rwlock ((lock op) &body body)
`(progn ,@body))
(defun safe-system (string)
(cmpnote "Invoking external command:~% ~A" string)
(let ((result (si:system string)))