kpoeck
commented
5 years ago Test-code
(defclass test ()
((foo :initarg :foo)))
(defun blah (a)
(make-instance 'test :foo a))
#+(or)
(defparameter old-find-class #'find-cl)
#+(or)
(let ((lock (mp:make-recursive-mutex :pprint)))
(defun my-find-class (symbol &optional error-p env)
(mp::with-lock (lock)
(funcall old-find-class error-p env))))
(defun stress (n)
(let ((lock (mp:make-recursive-mutex :pprint)))
(dotimes (x n)
(let ((xl x))
(sleep (random 10))
(mp:process-run-function
(princ-to-string xl)
#'(lambda()
(let ((xll xl))
(let ((instance (blah xll)))
(mp::with-lock (lock)
(pprint `(,MP:*CURRENT-PROCESS* ,instance)))))))))))
(Defvar *all-external-cl-symbols* nil)
(defvar *hash-table* (make-hash-table :thread-safe t))
(defun init-symbols ()
(setq *all-external-cl-symbols* nil)
(do-external-symbols (var (find-package :cl))
(push var *all-external-cl-symbols*)))
(defun fill-hash-table (&key strings)
(setq *hash-table* (make-hash-table :thread-safe t))
(dolist (sym *all-external-cl-symbols*)
(setf (gethash (if strings (symbol-name sym) sym) *hash-table*)
(symbol-name sym))))
(defun stress-2 (n &key strings lock report-all)
(declare (ignore lock))
(unless *all-external-cl-symbols*
(init-symbols))
(fill-hash-table :strings strings)
(let ((mutex (mp:make-recursive-mutex :pprint)))
(dotimes (x n)
(let ((x-local x))
(mp:process-run-function
(princ-to-string x)
#'(lambda()
(let ((x1 x-local))
(sleep (random 10))
(dotimes (x2 100)
(make-array 100))
(dolist (sym *all-external-cl-symbols*)
(let ((hash (gethash (if strings (symbol-name sym) sym) *hash-table*)))
(unless (string= hash (symbol-name sym))
(mp::with-lock (mutex)
(format t "Hash Error ~s ~s ~s ~%"
sym hash (symbol-name sym)))))
(unless report-all (return)))
(mp::with-lock (mutex)
(format t "Ending ~a ~%" x1))))))
(review-hash-table mutex nil))))
(defun review-hash-table (&optional mutex report-all)
(maphash #'(lambda(key value)
(let ((hash (gethash key *hash-table*)))
(unless (equal value hash)
(if mutex
(mp::with-lock (mutex)
(format t "Maphash inconsistency ~s ~s ~s ~%" key hash (symbol-name key)))
(format t "Maphash inconsistency ~s ~s ~s ~%" key hash (symbol-name key)))
;;; only report 1 error to limit the output unless otherwise specified
(unless report-all
(return-from review-hash-table)))))
*hash-table*))
(defun count-entries ()
(let ((sum 0))
(maphash #'(lambda(key value)
(incf sum))
*hash-table*)
sum))
(defun gethash-one-key (key)
(maphash #'(lambda(key-1 value)
(when (string= (symbol-name key) (symbol-name key-1))
(return-from gethash-one-key key-1)))
*hash-table*))
(defun gethash-all-keys (key)
(let ((keys nil))
(maphash #'(lambda(key-1 value)
(when (string-equal (symbol-name key) (symbol-name key-1))
(push key-1 keys)))
*hash-table*)
keys))
(defun print-hash ()
(let ((keys nil))
(maphash #'(lambda(key value)
(push key keys)
(format t "Maphash Key: ~s Value ~s~%" key value))
*hash-table*)
keys))
(defun stress-2-one-thread (n &key strings)
(unless *all-external-cl-symbols*
(init-symbols))
(fill-hash-table :strings strings)
(dotimes (x n)
;;; do some garbage
(dotimes (x1 100)
(make-array 100))
(dolist (sym *all-external-cl-symbols*)
(let ((hash (gethash (if strings (symbol-name sym) sym) *hash-table*)))
(unless (string= hash (symbol-name sym))
(format t "Hash Error ~s ~s ~s ~%"
sym hash (symbol-name sym)))))
(format t "Ending ~a ~%" x)
(review-hash-table)
)
)
;;; (load (compile-file "~/clasp-race-find-class.lisp" :verbose t) :verbose t)
drmeister
In mps builds and multithreaded use -and only there - I am experiencing weird problems with (find-class symbol) returning nil although the class for symbol is perfectly defined.
I am strongly convinced that this stems from some gethash issues in mps/multithreaded builds. I have some test-code attached that shows the issue.
To demonstrate the issue I define a hash-table with keys all external symbols of cl (978) and their symbol-value as value.
E.g by executing (stress-2 300) I have the following: