0.9.18.21:

        Fix DEFUN-CACHED thread/interrupt-safety issues. It was
        possible for FOO-CACHE-ENTER to modify a region in the cache
        vector while FOO-CACHE-LOOKUP had only partially read it.

        * Instead of storing all the data in one vector, the main
          cache vector will only contain references to bucket vectors,
          which contain the real data. FOO-CACHE-ENTER will always
          allocate a new bucket, old buckets are never modified. Thus
          FOO-CACHE-LOOKUP consistently sees either a pre- or post-
          FOO-CACHE-ENTRY state.

diff --git a/NEWS b/NEWS
index bc80266..69b14a8 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -15,6 +15,9 @@ changes in sbcl-0.9.19 (1.0.0?) relative to sbcl-0.9.18:
     Lars Brinkhoff)
   * bug fix: disassemly of funcallable instances works.
   * bug fix: single stepping on PPC.
+  * bug fix: fix thread-safety problems in the type system (generally 
+    manifesting as nonsensical errors like "STRING is a bad type specifier 
+    for sequences" or "The value 1 is not of type FIXNUM")
   * Improvements to the Windows port:
     ** floating point exceptions are now reported correctly.
     ** stack exhaustion detection works partially.

diff --git a/src/code/early-extensions.lisp b/src/code/early-extensions.lisp
index 0b2b05a..4514057 100644 (file)
--- a/src/code/early-extensions.lisp
+++ b/src/code/early-extensions.lisp
@@ -423,6 +423,17 @@
 ;;; its first arg, but need not return any particular value.
 ;;; TEST-FUNCTION may be any thing that can be placed in CAR position.
 ;;;
+;;; This code used to store all the arguments / return values directly
+;;; in the cache vector. This was both interrupt- and thread-unsafe, since
+;;; it was possible that *-CACHE-ENTER would scribble over a region of the
+;;; cache vector which *-CACHE-LOOKUP had only partially processed. Instead
+;;; we now store the contents of each cache bucket as a separate array, which
+;;; is stored in the appropriate cell in the cache vector. A new bucket array
+;;; is created every time *-CACHE-ENTER is called, and the old ones are never
+;;; modified. This means that *-CACHE-LOOKUP will always work with a set
+;;; of consistent data. The overhead caused by consing new buckets seems to
+;;; be insignificant on the grand scale of things. -- JES, 2006-11-02
+;;;
 ;;; NAME is used to define these functions:
 ;;; <name>-CACHE-LOOKUP Arg*
 ;;;   See whether there is an entry for the specified ARGs in the
@@ -452,12 +463,12 @@
                                   (values 1))
   (let* ((var-name (symbolicate "*" name "-CACHE-VECTOR*"))
          (nargs (length args))
-         (entry-size (+ nargs values))
          (size (ash 1 hash-bits))
-         (total-size (* entry-size size))
          (default-values (if (and (consp default) (eq (car default) 'values))
                              (cdr default)
                              (list default)))
+         (args-and-values (gensym))
+         (args-and-values-size (+ nargs values))
          (n-index (gensym))
          (n-cache (gensym)))
 
@@ -468,14 +479,16 @@
     (collect ((inlines)
               (forms)
               (inits)
-              (tests)
               (sets)
+              (tests)
               (arg-vars)
-              (values-indices)
+              (values-refs)
               (values-names))
       (dotimes (i values)
-        (values-indices `(+ ,n-index ,(+ nargs i)))
-        (values-names (gensym)))
+        (let ((name (gensym)))
+          (values-names name)
+          (values-refs `(svref ,args-and-values (+ ,nargs ,i)))
+          (sets `(setf (svref ,args-and-values (+ ,nargs ,i)) ,name))))
       (let ((n 0))
         (dolist (arg args)
           (unless (= (length arg) 2)
@@ -483,8 +496,8 @@
           (let ((arg-name (first arg))
                 (test (second arg)))
             (arg-vars arg-name)
-            (tests `(,test (svref ,n-cache (+ ,n-index ,n)) ,arg-name))
-            (sets `(setf (svref ,n-cache (+ ,n-index ,n)) ,arg-name)))
+            (tests `(,test (svref ,args-and-values ,n) ,arg-name))
+            (sets `(setf (svref ,args-and-values ,n) ,arg-name)))
           (incf n)))
 
       (when *profile-hash-cache*
@@ -502,12 +515,12 @@
          `(defun ,fun-name ,(arg-vars)
             ,@(when *profile-hash-cache*
                 `((incf ,(symbolicate  "*" name "-CACHE-PROBES*"))))
-            (let ((,n-index (* (,hash-function ,@(arg-vars)) ,entry-size))
-                  (,n-cache ,var-name))
-              (declare (type fixnum ,n-index))
-              (cond ((and ,@(tests))
-                     (values ,@(mapcar (lambda (x) `(svref ,n-cache ,x))
-                                       (values-indices))))
+            (let* ((,n-index (,hash-function ,@(arg-vars)))
+                   (,n-cache ,var-name)
+                   (,args-and-values (svref ,n-cache ,n-index)))
+              (cond ((and ,args-and-values
+                          ,@(tests))
+                     (values ,@(values-refs)))
                     (t
                      ,@(when *profile-hash-cache*
                          `((incf ,(symbolicate  "*" name "-CACHE-MISSES*"))))
@@ -517,41 +530,26 @@
         (inlines fun-name)
         (forms
          `(defun ,fun-name (,@(arg-vars) ,@(values-names))
-            (let ((,n-index (* (,hash-function ,@(arg-vars)) ,entry-size))
-                  (,n-cache ,var-name))
-              (declare (type fixnum ,n-index))
+            (let ((,n-index (,hash-function ,@(arg-vars)))
+                  (,n-cache ,var-name)
+                  (,args-and-values (make-array ,args-and-values-size)))
               ,@(sets)
-              ,@(mapcar (lambda (i val)
-                          `(setf (svref ,n-cache ,i) ,val))
-                        (values-indices)
-                        (values-names))
-              (values)))))
+              (setf (svref ,n-cache ,n-index) ,args-and-values))
+            (values))))
 
       (let ((fun-name (symbolicate name "-CACHE-CLEAR")))
         (forms
          `(defun ,fun-name ()
-            (do ((,n-index ,(- total-size entry-size) (- ,n-index ,entry-size))
-                 (,n-cache ,var-name))
-                ((minusp ,n-index))
-              (declare (type fixnum ,n-index))
-              ,@(collect ((arg-sets))
-                  (dotimes (i nargs)
-                    (arg-sets `(setf (svref ,n-cache (+ ,n-index ,i)) nil)))
-                  (arg-sets))
-              ,@(mapcar (lambda (i val)
-                          `(setf (svref ,n-cache ,i) ,val))
-                        (values-indices)
-                        default-values))
-            (values)))
+            (fill ,var-name nil)))
         (forms `(,fun-name)))
 
       (inits `(unless (boundp ',var-name)
-                (setq ,var-name (make-array ,total-size))))
+                (setq ,var-name (make-array ,size :initial-element nil))))
       #!+sb-show (inits `(setq *hash-caches-initialized-p* t))
 
       `(progn
          (defvar ,var-name)
-         (declaim (type (simple-vector ,total-size) ,var-name))
+         (declaim (type (simple-vector ,size) ,var-name))
          #!-sb-fluid (declaim (inline ,@(inlines)))
          (,init-wrapper ,@(inits))
          ,@(forms)

diff --git a/tests/threads.impure.lisp b/tests/threads.impure.lisp
index cbebcd8..60973e0 100644 (file)
--- a/tests/threads.impure.lisp
+++ b/tests/threads.impure.lisp
@@ -765,3 +765,22 @@
             (wait-for-threads (list changer test))))))))
 
 (format t "~&funcallable-instance test done~%")
+
+(defun random-type (n)
+  `(integer ,(random n) ,(+ n (random n))))
+
+(defun subtypep-hash-cache-test ()
+  (dotimes (i 10000)
+    (let ((type1 (random-type 500))
+          (type2 (random-type 500)))
+      (let ((a (subtypep type1 type2)))
+        (dotimes (i 100)
+          (assert (eq (subtypep type1 type2) a))))))
+  (format t "ok~%")
+  (force-output))
+
+(with-test (:name '(:hash-cache :subtypep))
+  (dotimes (i 10)
+    (sb-thread:make-thread #'subtypep-hash-cache-test)))
+
+(format t "hash-cache tests done~%")

diff --git a/tests/timer.impure.lisp b/tests/timer.impure.lisp
index 220c659..8531430 100644 (file)
--- a/tests/timer.impure.lisp
+++ b/tests/timer.impure.lisp
@@ -140,3 +140,21 @@
        (assert t))))
   (sleep 6)
   (assert t))
+
+
+(defun random-type (n)
+  `(integer ,(random n) ,(+ n (random n))))
+
+(with-test (:name '(:hash-cache :interrupt))
+  (let* ((type1 (random-type 500))
+         (type2 (random-type 500))
+         (wanted (subtypep type1 type2)))
+    (dotimes (i 100)
+      (block foo
+        (sb-ext:schedule-timer (sb-ext:make-timer
+                                (lambda ()
+                                  (assert (eq wanted (subtypep type1 type2)))
+                                    (return-from foo)))
+                               0.05)
+        (loop
+           (assert (eq wanted (subtypep type1 type2))))))))

diff --git a/version.lisp-expr b/version.lisp-expr
index bb6757a..72c8229 100644 (file)
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.9.18.20"
+"0.9.18.21"