Ticket #993: lock-free-hash-table-test.lisp

File lock-free-hash-table-test.lisp, 1.3 KB (added by uchida, 22 months ago)
Line 
1;;;; Lisp     : ccl-1.8 lx86cl (32bit)
2;;;; Guest OS : Xubuntu 11.10 64bit (VirtualBox 2CPU 1024MB)
3;;;; Host OS  : Mac OS X 10.6.8
4;;;; Hardware : MacBook Core2Duo 2GHz 4GB
5
6(defpackage :lock-free-hashtable-test
7  (:use :cl :ccl))
8
9(in-package :lock-free-hashtable-test)
10
11;;(defvar *tbl* (make-hash-table :test 'equal :lock-free nil)) ;; this seems to fix the problem.
12(defvar *tbl* (make-hash-table :test 'equal))
13(defvar *lck* (make-lock))
14
15(defun run-test ()
16  (background-memory-traffic)
17  (dotimes (i 100)
18    (dotimes (i 100)
19      (print (run1 (format nil "~A" i))))))
20
21(defun run1 (key)
22  (with-lock-grabbed (*lck*)
23    (setf (gethash key *tbl*) 0)
24    (incf (gethash key *tbl*))) ;; error: GETHASH returns NIL on rare occasions.
25  (run-program "/bin/echo" ()
26               :wait nil
27               :status-hook #'(lambda (p)
28                                (declare (ignore p))
29                                (with-lock-grabbed (*lck*)
30                                  (remhash key *tbl*)))))
31
32(defun background-memory-traffic ()
33  (process-run-function "background-memory-traffic"
34                        #'(lambda ()
35                            (loop
36                               (loop for i from 1 to 15000000
37                                  collect i)
38                               (gc)
39                               (sleep 0.5)))))
40
41(run-test)