[Sbcl-commits] CVS: sbcl/tests compiler.pure.lisp, 1.153, 1.154 hash.impure.lisp, 1.10, 1.11 stress-gc.lisp, 1.5, 1.6

[<me...@us...>]

Update of /cvsroot/sbcl/sbcl/tests
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv17667/tests

Modified Files:
	compiler.pure.lisp hash.impure.lisp stress-gc.lisp 
Log Message:
0.9.16.32: weak hash tables
  The implementation is based on cmucl's weak hash table code.

  * scav_vector defers scavenging of weak hash tables until ...

  * ... newspace scavenging at which time the deferred weak hash
    tables are scavenged according to their WEAKNESS type (this
    happens after each scan of newspace)

  * finally just before weak pointers are scanned (i.e. with the
    purpose of breaking them) the weak hash tables are scanned (i.e.
    the appropriate entries are removed) too.


Index: compiler.pure.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/tests/compiler.pure.lisp,v
retrieving revision 1.153
retrieving revision 1.154
diff -u -d -r1.153 -r1.154
--- compiler.pure.lisp	15 Sep 2006 08:23:32 -0000	1.153
+++ compiler.pure.lisp	15 Sep 2006 14:39:45 -0000	1.154
@@ -2130,12 +2130,12 @@
 
 ;;; overconfident primitive type computation leading to bogus type
 ;;; checking.
-(let* ((form1 '(lambda (x) 
-                (declare (type (and condition function) x)) 
+(let* ((form1 '(lambda (x)
+                (declare (type (and condition function) x))
                 x))
        (fun1 (compile nil form1))
-       (form2 '(lambda (x) 
-                (declare (type (and standard-object function) x)) 
+       (form2 '(lambda (x)
+                (declare (type (and standard-object function) x))
                 x))
        (fun2 (compile nil form2)))
   (assert (raises-error? (funcall fun1 (make-condition 'error))))

Index: hash.impure.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/tests/hash.impure.lisp,v
retrieving revision 1.10
retrieving revision 1.11
diff -u -d -r1.10 -r1.11
--- hash.impure.lisp	26 Aug 2005 21:09:04 -0000	1.10
+++ hash.impure.lisp	15 Sep 2006 14:39:45 -0000	1.11
@@ -11,6 +11,9 @@
 
 (in-package :cl-user)
 
+(use-package :test-util)
+(use-package :assertoid)
+
 (defstruct foo)
 (defstruct bar x y)
 
@@ -256,4 +259,135 @@
                                       (,fun x)))
                       nil))))
 
+;;; This test works reliably on non-conservative platforms and
+;;; somewhat reliably on conservative platforms with threads.
+#+(or (not (or x86 x86-64)) sb-thread)
+(progn
+
+(defparameter *ht* nil)
+
+(defvar *cons-here*)
+
+(defmacro alloc (&body body)
+  "Execute BODY and try to reduce the chance of leaking a conservative root."
+  #-sb-thread
+  `(multiple-value-prog1
+       (progn ,@body)
+     (loop repeat 20000 do (setq *cons-here* (cons nil nil)))
+     ;; KLUDGE: Clean the argument passing regs.
+     (apply #'take (loop repeat 36 collect #'cons)))
+  #+sb-thread
+  (let ((values (gensym))
+        (sem (gensym)))
+    `(let ((,sem (sb-thread::make-semaphore))
+           ,values)
+       (sb-thread:make-thread (lambda ()
+                                (setq ,values
+                                      (multiple-value-list (progn ,@body)))
+                                (sb-thread::signal-semaphore ,sem)))
+       (sb-thread::wait-on-semaphore ,sem)
+       (values-list ,values))))
+
+(with-test (:name (:hash-table :weakness :eql :numbers))
+  (flet ((random-number ()
+           (random 1000)))
+    (loop for weakness in '(nil :key :value :key-and-value :key-or-value) do
+          (let* ((ht (make-hash-table :weakness weakness))
+                 (n (alloc (loop repeat 1000
+                                 count (let ((key (random-number)))
+                                         (if (gethash key ht)
+                                             (setf (gethash key ht)
+                                                   (random-number))))))))
+            (gc :full t)
+            (gc :full t)
+            (assert (= n (hash-table-count ht)))))))
+
+(defun take (&rest args)
+  (declare (ignore args)))
+
+(defun add-removable-stuff (ht &key (n 100) (size 10))
+  (flet ((unique-object ()
+           (make-array size :fill-pointer 0)))
+    (loop for i below n do
+          (multiple-value-bind (key value)
+              (ecase (hash-table-weakness ht)
+                ((:key) (values (unique-object) i))
+                ((:value) (values i (unique-object)))
+                ((:key-and-value)
+                 (if (zerop (random 2))
+                     (values (unique-object) i)
+                     (values i (unique-object))))
+                ((:key-or-value)
+                 (values (unique-object) (unique-object))))
+            (setf (gethash key ht) value)))
+    (values)))
+
+(defun print-ht (ht &optional (stream t))
+  (format stream "Weakness: ~S~%" (sb-impl::hash-table-weakness ht))
+  (format stream "Table: ~S~%" (sb-impl::hash-table-table ht))
+  (format stream "Next: ~S~%" (sb-impl::hash-table-next-vector ht))
+  (format stream "Index: ~S~%" (sb-impl::hash-table-index-vector ht))
+  (format stream "Hash: ~S~%" (sb-impl::hash-table-hash-vector ht))
+  (force-output stream))
+
+(with-test (:name (:hash-table :weakness :removal))
+  (loop for test in '(eq eql equal equalp) do
+        (format t "test: ~A~%" test)
+        (loop for weakness in '(:key :value :key-and-value :key-or-value)
+              do
+              (format t "weakness: ~A~%" weakness)
+              (let ((ht (make-hash-table :test 'equal :weakness weakness)))
+                (alloc (add-removable-stuff ht :n 117 :size 1))
+                (loop for i upfrom 0
+                      do (format t "~A. count: ~A~%" i (hash-table-count ht))
+                      (force-output)
+                      until (zerop (hash-table-count ht))
+                      do
+                      (when (= i 10)
+                        (print-ht ht)
+                        #-(or x86 x86-64)
+                        (assert nil)
+                        ;; With conservative gc the test may not be
+                        ;; bullet-proof so it's not an outright
+                        ;; failure but a warning.
+                        #+(or x86 x86-64)
+                        (progn
+                          (warn "Weak hash removal test failed for weakness ~A"
+                                weakness)
+                          (return)))
+                      (gc :full t))))))
+
+(with-test (:name (:hash-table :weakness :string-interning))
+  (let ((ht (make-hash-table :test 'equal :weakness :key))
+        (s "a"))
+    (setf (gethash s ht) s)
+    (assert (eq (gethash s ht) s))
+    (assert (eq (gethash (copy-seq s) ht) s))))
+
+;;; see if hash_vector is not written when there is none ...
+(with-test (:name (:hash-table :weakness :eq))
+  (loop repeat 10 do
+        (let ((index (random 2000)))
+          (let ((first (+ most-positive-fixnum (mod (* index 31) 9)))
+                (n 50000))
+            (let ((hash-table (make-hash-table :weakness :key :test 'eq)))
+              (dotimes (i n)
+                (setf (gethash (+ first i) hash-table) i))
+              hash-table)))))
+
+;; used to crash in gc
+(with-test (:name (:hash-table :weakness :keep))
+  (loop repeat 2 do
+        (let ((h1 (make-hash-table :weakness :key :test #'equal))
+              (keep ()))
+          (loop for i from 0 to 1000
+                for key = i
+                for value = (make-array 10000 :fill-pointer 0)
+                do
+                (push value keep)
+                (setf (gethash key h1) value))
+          (sb-ext:gc :full t))))
+
+)
+
 ;;; success

Index: stress-gc.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/tests/stress-gc.lisp,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -d -r1.5 -r1.6
--- stress-gc.lisp	14 Jul 2005 16:30:45 -0000	1.5
+++ stress-gc.lisp	15 Sep 2006 14:39:45 -0000	1.6
@@ -29,6 +29,9 @@
 (defvar *reprs*)
 (declaim (type simple-vector *reprs*))
 
+(defun random-element (seq)
+  (elt seq (random (length seq))))
+
 (defun repr (i)
   (declare (type fixnum i))
   (let ((result (svref *reprs* (mod i (length *reprs*)))))
@@ -146,6 +149,23 @@
           |#
           hash-table))))
 
+(defun repr-weak-key-hash-table (index &optional (value nil value-p))
+  (let ((first (+ most-positive-fixnum (mod (* index 31) 9)))
+        (n 5))
+    (if value-p
+        (and (hash-table-p value)
+             (<= (hash-table-count value) n)
+             (dotimes (i n t)
+               (let ((x (gethash (+ i first) value)))
+                 (unless (or (null x) (= x i))
+                   (return nil)))))
+        (let ((hash-table (make-hash-table
+                           :weakness :key
+                           :test (random-element '(eq eql equal equalp)))))
+          (dotimes (i n)
+            (setf (gethash (+ first i) hash-table) i))
+          hash-table))))
+
 (defun repr-bignum (index &optional (value nil value-p))
   (let ((bignum (+ index 10000300020)))
     (if value-p
@@ -214,6 +234,7 @@
               #'repr-function
               #'repr-instance
               #'repr-eql-hash-table
+              #'repr-weak-key-hash-table
 #|
               #'repr-equal-hash-table
               #'repr-equalp-hash-table