From 35bfc07cbd9aa8029e9cc42f1a3fab27f1a673f4 Mon Sep 17 00:00:00 2001 From: Juho Snellman Date: Thu, 2 Nov 2006 11:17:56 +0000 Subject: [PATCH] 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. --- NEWS | 3 ++ src/code/early-extensions.lisp | 72 +++++++++++++++++++--------------------- tests/threads.impure.lisp | 19 +++++++++++ tests/timer.impure.lisp | 18 ++++++++++ version.lisp-expr | 2 +- 5 files changed, 76 insertions(+), 38 deletions(-) diff --git a/NEWS b/NEWS index bc80266..69b14a8 100644 --- 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 --- 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: ;;; -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 --- 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 --- 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 --- 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" -- 1.7.10.4