[Sbcl-devel] Thread-safety patch for defun-cached forms

[Christopher N. <cjn...@cn...>]

Up to and including today's CVS checkout, I've been getting some weird
crashes under gensym in a multi-threaded program, make-sequence was
complaining that it was asked to build a sequence of a certain type found
in CLIM, but the call stack said that it was supposed to be building a
simple-string.  I traced the likely source to the fact that the cached
lookup of types is not thread-safe.  I've built with this patch locally,
and have been unable to reproduce the earlier crash over a time interval
when I would have expected to see it at least a few times.

Somebody please verify this, I'm not confident that it will work correctly
if compiled without sb-threads.

Basically, this creates a new mutex object to protect the cache vector, and
acquires that mutex at the entry point of all three functions that
manipulate the cache vector.


Thank you.


Index: src/code/early-extensions.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/early-extensions.lisp,v
retrieving revision 1.79
diff -d -u -r1.79 early-extensions.lisp
--- src/code/early-extensions.lisp      13 Sep 2006 15:59:32 -0000      1.79
+++ src/code/early-extensions.lisp      2 Oct 2006 01:44:10 -0000
@@ -451,6 +451,7 @@
                                   (init-wrapper 'progn)
                                   (values 1))
   (let* ((var-name (symbolicate "*" name "-CACHE-VECTOR*"))
+         (mutex-name (symbolicate "*" name "-CACHE-VECTOR-LOCK*"))
          (nargs (length args))
          (entry-size (+ nargs values))
          (size (ash 1 hash-bits))
@@ -502,6 +503,7 @@
          `(defun ,fun-name ,(arg-vars)
             ,@(when *profile-hash-cache*
                 `((incf ,(symbolicate  "*" name "-CACHE-PROBES*"))))
+           (sb!thread:with-mutex (,mutex-name)
             (let ((,n-index (* (,hash-function ,@(arg-vars)) ,entry-size))
                   (,n-cache ,var-name))
               (declare (type fixnum ,n-index))
@@ -511,12 +513,13 @@
                     (t
                      ,@(when *profile-hash-cache*
                          `((incf ,(symbolicate  "*" name "-CACHE-MISSES*"))))
-                     ,default))))))
+                     ,default)))))))

       (let ((fun-name (symbolicate name "-CACHE-ENTER")))
         (inlines fun-name)
         (forms
          `(defun ,fun-name (,@(arg-vars) ,@(values-names))
+           (sb!thread:with-mutex (,mutex-name)
             (let ((,n-index (* (,hash-function ,@(arg-vars)) ,entry-size))
                   (,n-cache ,var-name))
               (declare (type fixnum ,n-index))
@@ -525,11 +528,12 @@
                           `(setf (svref ,n-cache ,i) ,val))
                         (values-indices)
                         (values-names))
-              (values)))))
+              (values))))))

       (let ((fun-name (symbolicate name "-CACHE-CLEAR")))
         (forms
          `(defun ,fun-name ()
+           (sb!thread:with-mutex (,mutex-name)
             (do ((,n-index ,(- total-size entry-size) (- ,n-index ,entry-size))
                  (,n-cache ,var-name))
                 ((minusp ,n-index))
@@ -542,14 +546,17 @@
                           `(setf (svref ,n-cache ,i) ,val))
                         (values-indices)
                         default-values))
-            (values)))
+            (values))))
         (forms `(,fun-name)))

+      (inits `(unless (boundp ',mutex-name)
+                (setq ,mutex-name (sb!thread:make-mutex))))
       (inits `(unless (boundp ',var-name)
                 (setq ,var-name (make-array ,total-size))))
       #!+sb-show (inits `(setq *hash-caches-initialized-p* t))

       `(progn
+        (defvar ,mutex-name)
          (defvar ,var-name)
          (declaim (type (simple-vector ,total-size) ,var-name))
          #!-sb-fluid (declaim (inline ,@(inlines)))


-- 
 Christopher Neufeld
 Home page:  http://www.cneufeld.ca/neufeld
 "Don't edit reality for the sake of simplicity"