mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2026-04-18 08:00:27 -07:00
Code Issues Projects Releases Packages Wiki Activity

Added a new test form that ensures no processes are left behind

Browse source
This commit is contained in:
Juan Jose Garcia Ripoll 2012-04-15 10:18:59 +02:00
parent 868f666533
commit 1141033a25
4 changed files with 70 additions and 49 deletions
Download patch file Download diff file Expand all files Collapse all files

9
src/tests/bugs/doit.lsp
View file

@ -42,11 +42,12 @@
(load "ffi-001.lsp")
#+threads
(load "mp-001.lsp")
#+threads
(load "mutex-001.lsp")
(progn
(load "mp-tools.lsp")
(load "mp-001.lsp")
(load "mutex-001.lsp"))
#+unicode
#+(or) ;unicode
(progn
;; In Windows SYSTEM does not fail with a nonzero code when it
;; fails to execute a command. Hence in that case we assume

39
src/tests/bugs/mp-001.lsp
View file

@ -14,32 +14,31 @@
;;; the resulting lock and an error is signaled.
;;;
(deftest mp-0001-with-lock
(progn
(defparameter *mp-0001-with-lock-a* t)
(defparameter *mp-0001-with-lock-b* (mp:make-lock))
(mp:with-lock (*mp-0001-with-lock-b*)
(def-mp-test mp-0001-with-lock
(let ((flag t)
(lock (mp:make-lock :name "mp-0001-with-lock" :recursive nil)))
(mp:with-lock (lock)
(let ((background-process
(mp:process-run-function
'mp-0001-with-lock
(coerce '(lambda ()
(handler-case
(progn
(setf *mp-0001-with-lock-a* 1)
(mp:with-lock (*mp-0001-with-lock-b*)
(setf *mp-0001-with-lock-a* 1)))
(error (c)
(princ c)(terpri)
(setf *mp-0001-with-lock-a* c)))
(setf *mp-0001-with-lock-a* 2))
'function))))
"mp-0001-with-lock"
#'(lambda ()
(handler-case
(progn
(setf flag 1)
(mp:with-lock (lock)
(setf flag 2)))
(error (c)
(princ c)(terpri)
(setf flag c)))
(setf flag 2)))))
;; The background process should not be able to get
;; the lock, and will simply wait. Now we interrupt it
;; and the process should gracefully quit, without
;; signalling any serious condition
(and (sleep 1)
(mp:process-kill background-process)
(and (progn (sleep 1)
(mp:process-kill background-process))
(progn (sleep 1)
(not (mp:process-active-p background-process)))
(eq *mp-0001-with-lock-a* 1)))))
(eq flag 1)
t))))
t)

38
src/tests/bugs/mp-tools.lsp Normal file
View file

@ -0,0 +1,38 @@
;-*- Mode: Lisp -*-
;;;; Author: Juan Jose Garcia-Ripoll
;;;; Created: Fri Apr 14 CEST 2012
;;;; Contains: Supporting routines for multithreaded tests
(in-package :cl-test)
(defun kill-and-wait (process-list &optional original wait)
"Kills a list of processes, which may be the difference between two lists,
waiting for all processes to finish. Currently it has no timeout, meaning
it may block hard the lisp image."
(let ((process-list (set-difference process-list original)))
(when (member mp:*current-process* process-list)
(error "Found myself in the kill list"))
(mapc #'mp:process-kill process-list)
(when wait
(loop for i in process-list
do (mp:process-join i)))
process-list))
(defun mp-test-run (closure)
(let* ((all-processes (mp:all-processes))
(output (multiple-value-list (funcall closure)))
(leftovers (kill-and-wait (mp:all-processes) all-processes)))
(cond (leftovers
(format t "~%;;; Stray processes: ~A" leftovers))
(t
(values-list output)))))
(defmacro def-mp-test (name body expected-value)
"Runs some test code and only returns the output when the code exited without
creating stray processes."
(let ((all-processes (gensym))
(output (gensym))
(leftover (gensym)))
`(deftest ,name
(mp-test-run #'(lambda () ,body))
,expected-value)))

33
src/tests/bugs/mutex-001.lsp
View file

@ -1,22 +1,10 @@
;-*- Mode: Lisp -*-
;;;; Author: Juan Jose Garcia-Ripoll
;;;; Created: Fri Apr 14 11:13:17 CEST 2006
;;;; Contains: Multithreading API regression tests
;;;; Created: Fri Apr 12 CEST 2012
;;;; Contains: Mutex tests
(in-package :cl-test)
(defun kill-and-wait (process-list &optional original)
"Kills a list of processes, which may be the difference between two lists,
waiting for all processes to finish. Currently it has no timeout, meaning
it may block hard the lisp image."
(let ((process-list (set-difference process-list original)))
(when (member mp:*current-process* process-list)
(error "Found myself in the kill list"))
(mapc #'mp:process-kill process-list)
(loop for i in process-list
do (mp:process-join i))
process-list))
;;; Date: 12/04/2012
;;; Non-recursive mutexes should signal an error when they
;;; cannot be relocked.
@ -57,9 +45,8 @@ it may block hard the lisp image."
;;; When multiple threads compete for a mutex, they should
;;; all get the same chance of accessing the resource
;;;
(deftest mutex-003-fairness
(let* ((zero-processes (mp:all-processes))
(mutex (mp:make-lock :name 'mutex-001-fairness))
(def-mp-test mutex-003-fairness
(let* ((mutex (mp:make-lock :name 'mutex-001-fairness))
(nthreads 10)
(count 10)
(counter (* nthreads count))
@ -86,9 +73,8 @@ it may block hard the lisp image."
;; the same share of counts.
(loop for p in all-processes
do (mp:process-join p))
(and (loop for i from 0 below nthreads
always (= (aref array i) count))
(null (kill-and-wait (mp:all-processes) zero-processes))))))
(loop for i from 0 below nthreads
always (= (aref array i) count)))))
t)
;;; Date: 12/04/2012
@ -97,9 +83,8 @@ it may block hard the lisp image."
;;; do anything. These processes are then killed, resulting in the others
;;; doing their job.
;;;
(deftest mutex-004-interruptible
(let* ((zero-processes (mp:all-processes))
(mutex (mp:make-lock :name "mutex-003-fairness"))
(def-mp-test mutex-004-interruptible
(let* ((mutex (mp:make-lock :name "mutex-003-fairness"))
(nprocesses 20)
(counter 0))
(flet ((normal-thread ()
@ -119,8 +104,6 @@ it may block hard the lisp image."
(and (zerop counter) ; No proces works because the first one is a zombie
(kill-and-wait zombies)
(progn (sleep 0.2) (= counter (/ nprocesses 2)))
(null (kill-and-wait (mp:all-processes) zero-processes))
(not (mp:lock-owner mutex))
(zerop (mp:lock-count mutex))
t))))
t)