tests/info.impure.lisp

   1 ;;;; tests of the INFO/globaldb system
   2 ;;;;
   3 ;;;; KLUDGE: Unlike most of the system's tests, these are not in the
   4 ;;;; problem domain, but in the implementation domain, so modification
   5 ;;;; of the system could cause these tests to fail even if the system
   6 ;;;; was still a correct implementation of ANSI Common Lisp + SBCL
   7 ;;;; extensions. Perhaps such tests should be separate from tests in
   8 ;;;; the problem domain. -- WHN 2001-02-11
   9
  10 ;;;; This software is part of the SBCL system. See the README file for
  11 ;;;; more information.
  12 ;;;;
  13 ;;;; While most of SBCL is derived from the CMU CL system, the test
  14 ;;;; files (like this one) were written from scratch after the fork
  15 ;;;; from CMU CL.
  16 ;;;;
  17 ;;;; This software is in the public domain and is provided with
  18 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
  19 ;;;; more information.
  20
  21 (in-package :cl-user)
  22
  23 (test-util:with-test (:name :no-meta-info)
  24  (assert-signal (compile nil '(lambda (x) (sb-int:info :type :nokind x)))
  25                 style-warning))
  26
  27 (defun foo (a) (list a))
  28 (let ((x 1)) (foo x))
  29
  30 (assert (eq (sb-int:info :function :where-from 'foo)
  31             :defined))
  32
  33 (defun foo (a b) (list a b))
  34 (let ((x 1)) (foo x 2))
  35
  36 (flet ((foo (a b c)
  37          (list a b c)))
  38   (foo 1 2 3))
  39
  40 ;;; FIXME: This one is commented out since it doesn't work when
  41 ;;; the DEFUN is just LOADed instead of COMPILE-FILEd, and it's
  42 ;;; not immediately obvious what's the best way to set up
  43 ;;; the COMPILE-FILE test.
  44 #||
  45 (assert
  46   (equal
  47    (format nil "~A" (sb-int:proclaimed-ftype 'foo))
  48    "#<FUN-TYPE (FUNCTION (T T) LIST)>"))
  49 ||#
  50
  51 (with-test (:name :fboundp-type-error)
  52   (assert-error (funcall (compile nil `(lambda (x) (fboundp x))) 0)
  53                  type-error)
  54   (assert-error (funcall (compile nil `(lambda (x) (fdefinition x))) 0)
  55                  type-error))
  56
  57 (in-package "SB-C")
  58
  59 (test-util:with-test (:name :globaldb-sxhashoid-discrimination)
  60   (assert (not (eql (globaldb-sxhashoid '(a b c d e))
  61                     (globaldb-sxhashoid '(a b c d mumble))))))
  62
  63 (test-util:with-test (:name :bug-458015)
  64   ;; Make sure layouts have sane source-locations
  65   (sb-c::call-with-each-globaldb-name
  66    (lambda (info-name)
  67      (when (and (symbolp info-name) (info :type :kind info-name))
  68         (let* ((classoid (find-classoid info-name nil))
  69                (layout (and classoid (classoid-layout classoid)))
  70                (srcloc (and layout (sb-kernel::layout-source-location layout))))
  71           (when (and layout)
  72             (assert (or (definition-source-location-p srcloc)
  73                         (null srcloc)))))))))
  74
  75 (test-util:with-test (:name :find-classoid-signal-error)
  76   ;; (EVAL ''SILLY) dumbs down the compiler for this test.
  77   ;; FIND-CLASSOID on a constant symbol becomes
  78   ;;  `(CLASSOID-CELL-CLASSOID ',(FIND-CLASSOID-CELL name :create t))
  79   ;; and I want just the primitive operations without muddying the water.
  80   (let ((name (eval ''silly)))
  81     (assert (not (find-classoid name nil)))
  82     (assert (typep (handler-case (find-classoid name) (error (e) e)) 'error))
  83     (find-classoid-cell name :create t) ; After this, have cell but no classoid
  84     (assert (typep (handler-case (find-classoid name) (error (e) e)) 'error))))
  85
  86 (test-util:with-test (:name :set-info-value-type-check)
  87   (loop for type-info across *info-types*
  88         when (and type-info (not (eq (meta-info-type-spec type-info) 't)))
  89         do
  90         (let ((key1 (meta-info-category type-info))
  91               (key2 (meta-info-kind type-info))
  92               (sillyval (make-string-output-stream))) ; nothing should be this
  93           ;; check the type-checker function
  94           (let ((f (compile nil
  95                             `(lambda (x)
  96                                (declare (notinline (setf info)))
  97                                (setf (info ,key1 ,key2 'grrr) x)))))
  98             (assert (typep (nth-value 1 (ignore-errors (funcall f sillyval)))
  99                            'type-error)))
 100           ;; Demonstrate that the SETF disallows the illegal value
 101           ;; even though this lambda attempts to be non-type-safe.
 102           (let ((f (compile nil `(lambda (x)
 103                                    (declare (optimize (safety 0)))
 104                                    (setf (info ,key1 ,key2 'grrr) x)))))
 105             (assert (typep (nth-value 1 (ignore-errors (funcall f sillyval)))
 106                            'type-error)))))
 107   ;; but if I *really* want, a bad value can be installed
 108   (set-info-value (gensym)
 109                   (meta-info-number (meta-info :variable :kind))
 110                   :this-is-no-good))
 111
 112 (test-util:with-test (:name :unrecognize-recognized-declaration)
 113   (proclaim '(declaration happiness))
 114   (let ((saved (copy-list *recognized-declarations*)))
 115     (assert (member 'happiness *recognized-declarations*))
 116     (proclaim '(declaration happiness))
 117     (assert (equal *recognized-declarations* saved)) ; not pushed again
 118     (setf (info :declaration :recognized 'happiness) nil)
 119     (assert (not (member 'happiness *recognized-declarations*)))))
 120
 121 (test-util:with-test (:name :recognized-decl-not-also-type)
 122   (deftype pear (x) `(cons ,x ,x))
 123   (assert (typep (nth-value 1 (ignore-errors (proclaim '(declaration pear))))
 124                  'declaration-type-conflict-error))
 125   (proclaim '(declaration nthing))
 126   (assert (typep (nth-value 1 (ignore-errors (deftype nthing (x) `(not ,x))))
 127                  'declaration-type-conflict-error)))
 128
 129 (test-util:with-test (:name :info-env-clear)
 130   (setf (info :variable :kind 'fruitbaskets) :macro
 131         (info :variable :macro-expansion 'fruitbaskets) 32)
 132   (clear-info :variable :kind 'fruitbaskets)
 133   (multiple-value-bind (data foundp)
 134       (info :variable :kind 'fruitbaskets)
 135     (assert (and (eq data :unknown) (not foundp))))
 136   (multiple-value-bind (data foundp)
 137       (info :variable :macro-expansion 'fruitbaskets)
 138     (assert (and foundp (eql data 32))))
 139   (clear-info :variable :macro-expansion 'fruitbaskets)
 140   (multiple-value-bind (data foundp)
 141       (info :variable :macro-expansion 'fruitbaskets)
 142     (assert (and (not foundp) (not data)))))
 143
 144 ;; packed info vector tests
 145
 146 (test-util:with-test (:name :globaldb-info-iterate)
 147   (let ((s (with-output-to-string (*standard-output*) (show-info '*))))
 148     (dolist (x '((:function :definition) (:function :type)
 149                  (:function :where-from) (:function :kind)
 150                  (:function :info) (:function :source-transform)
 151                  (:type :kind) (:type :builtin)
 152                  (:source-location :declaration)
 153                  (:variable :kind)
 154                  #+sb-doc (:variable :documentation)
 155                  (:variable :type) (:variable :where-from)
 156                  (:source-location :variable)
 157                  (:alien-type :kind) (:alien-type :translator)))
 158       (assert (search (format nil "~S ~S" (car x) (cadr x)) s)))))
 159
 160 (test-util:with-test (:name :find-fdefn-agreement)
 161   ;; Shows that GET-INFO-VALUE agrees with FIND-FDEFN on all symbols,
 162   ;; since they use diffent code. Something would have crashed long before here...
 163   (flet ((try (x)
 164            (assert (eq (find-fdefn x) (info :function :definition x)))))
 165     (do-all-symbols (s)
 166       (try s)
 167       (try `(setf ,s))
 168       (try `(cas ,s)))))
 169
 170 (defun shuffle (vector) ; destructive
 171   (loop for lim from (1- (length vector)) downto 0
 172         for chosen = (random (1+ lim))
 173         unless (= chosen lim)
 174         do (rotatef (aref vector chosen) (aref vector lim)))
 175   vector)
 176
 177 (test-util:with-test (:name :quick-packed-info-insert)
 178   ;; Exercise some bit patterns that touch the sign bit on 32-bit machines.
 179   (loop repeat 10
 180         do
 181     (let ((iv1 +nil-packed-infos+)
 182           (iv2 +nil-packed-infos+)
 183           (type-nums
 184            (cons 1 (subseq '(#b100000 #b110000 #b010000 #b011000
 185                              #b000100 #b000010 #b000011 #b000001)
 186                            0 (- +infos-per-word+ 2)))))
 187       ;; Randomize because maybe there's an ordering constraint more
 188       ;; complicated than fdefn always getting to be first.
 189       ;; (there isn't, but could be)
 190       (dolist (num (coerce (shuffle (coerce type-nums 'vector)) 'list))
 191         (let ((val (format nil "value for ~D" num)))
 192           (setq iv1 (quick-packed-info-insert iv1 num val)
 193                 iv2 (%packed-info-insert ; not PACKED-INFO-INSERT
 194                      iv2 +no-auxilliary-key+ num val))
 195           (assert (equalp iv1 iv2))))
 196       ;; the first and only info descriptor should be full
 197       (assert (not (info-quickly-insertable-p iv1))))))
 198
 199 (defun crossprod (a b)
 200   (mapcan (lambda (x) (mapcar (lambda (y) (cons x y)) b))
 201           a))
 202
 203 ;; The real GET-INFO-VALUE AVERs that INFO-NUMBER is legal. This one doesn't.
 204 (defun cheating-get-info-value (sym aux-key info-number)
 205   (let* ((vector (symbol-info-vector sym))
 206          (index (packed-info-value-index vector aux-key info-number)))
 207     (if index
 208         (values (svref vector index) t)
 209         (values nil nil))))
 210
 211 ;; Info vectors may be concurrently updated. If more than one thread writes
 212 ;; the same name/info-number, it's random which thread prevails, but for
 213 ;; non-colliding updates, none should be lost.
 214 ;; This is not a "reasonable" use of packed info vectors.
 215 ;; It's just a check of the response of the algorithm to heavy pounding.
 216 #+sb-thread
 217 (test-util:with-test (:name :info-vector-concurrency)
 218   (let ((s (gensym))
 219         (a (make-array 1 :element-type 'sb-ext:word)))
 220     (let* ((aux-keys '(0 a b c d e f g h nil i j k l m n o p setf q r s))
 221            (info-types (loop for i from 1 below 64 collect i))
 222            (work (shuffle (coerce (crossprod aux-keys info-types) 'vector)))
 223            (n (floor (length work) 4))
 224            (threads))
 225       (dotimes (i 4)
 226         (push
 227          (sb-thread:make-thread
 228           (lambda (work my-id)
 229             (loop for x across work
 230                   do (set-info-value (if (eq (car x) 0) s `(,(car x) ,s))
 231                                      (cdr x)
 232                                      (list (atomic-incf (aref a 0)) my-id
 233                                            (format nil "~A,~A"
 234                                                        (car x) (cdr x))))))
 235           :arguments (list (subseq work (* i n) (if (= i 3) nil (* (1+ i) n)))
 236                            i))
 237          threads))
 238       (dolist (thread threads)
 239         (sb-thread:join-thread thread))
 240       (let ((foo (make-array (aref a 0))))
 241         ;; Returning FOO is to give a rough visual indication that
 242         ;; there were in fact intermingled updates.
 243         (dolist (k aux-keys foo)
 244           (dotimes (i 64)
 245             (let ((answer (cheating-get-info-value s k i)))
 246               (if answer
 247                   (setf (aref foo (car answer)) answer))
 248               (assert (equal (third answer)
 249                              (if (= i 0) nil
 250                                  (format nil "~A,~A" k i)))))))))))
 251
 252 ;; specialized concurrent hashtable tests
 253
 254 (defun integer-range (min max)
 255   (let* ((n (1+ (- max min)))
 256          (a (make-array n)))
 257     (dotimes (j n a)
 258       (setf (aref a j) (+ j min)))))
 259
 260 (defun randomize (key random-state)
 261   (if random-state
 262       (logior (ash key 10) (random (ash 1 10) random-state))
 263       key)) ; not randomizing
 264
 265 (defun show-tally (table tally verb print)
 266   (when print
 267     (format t "Hashtable has ~D entries~%" (info-env-count table)))
 268   (let ((tot 0))
 269     (dotimes (thread-id (length tally) tot)
 270       (let ((n (aref tally thread-id)))
 271         (when print
 272           (format t "Thread ~2d ~A ~7d time~:P~%" thread-id verb n))
 273         (incf tot n)))))
 274
 275 (defun test-concurrent-incf (&key (table (make-info-hashtable))
 276                                   (n-threads 40) (n-inserts 50000)
 277                                   (print nil))
 278   (declare (optimize safety))
 279   (let ((threads)
 280         (worklists (make-array n-threads))
 281         (failures)
 282         (tries (make-array n-threads :initial-element 0)))
 283     (dotimes (i n-threads)
 284       ;; Insert the integers [-n .. -2]. Keys 0 and -1 are illegal.
 285       (setf (aref worklists i)
 286             (shuffle (integer-range (- (1+ n-inserts)) -2))))
 287     (dotimes (i n-threads)
 288       (push (sb-thread:make-thread
 289              (lambda (worklist me)
 290                (declare (simple-vector worklist))
 291                (flet ((doer (val)
 292                         (incf (aref tries me))
 293                         (1+ (or val 0))))
 294                  (declare (dynamic-extent #'doer))
 295                  ;; for each item in worklist, increment that key
 296                  (loop for key across worklist do
 297                    (info-puthash table key #'doer))
 298                  ;; again backwards just for fun
 299                  (loop for j downfrom (1- (length worklist)) to 0 do
 300                    (info-puthash table (svref worklist j) #'doer))))
 301              :name (format nil "Worker ~D" i)
 302              :arguments (list (aref worklists i) i))
 303             threads))
 304     (when print (format t "Started ~D threads doing INCF~%" n-threads))
 305     (dolist (thread threads)
 306       (sb-thread:join-thread thread))
 307     (assert (= (info-env-count table) n-inserts))
 308     (show-tally table tries "updated" print)
 309     ;; expect val[key] = 2*n-threads for all keys
 310     (info-maphash (lambda (k v)
 311                     (unless (= v (* 2 n-threads))
 312                       (push (cons k v) failures)))
 313                   table)
 314     (if failures
 315         (format t "Fail: ~S~%" failures))
 316     (assert (not failures))
 317     table))
 318
 319 (defun test-concurrent-consing (&key (table (make-info-hashtable))
 320                                 (n-threads 40) (n-inserts 100000)
 321                                 (randomize t) (print nil))
 322   (declare (optimize safety))
 323   (assert (evenp n-threads))
 324   (let ((threads)
 325         (rs (make-random-state)))
 326     ;; Under each key, the value stored will be a list of the threads
 327     ;; which pushed their ID. For any pair of even/odd numbered threads,
 328     ;; exactly one should win the race to push its ID on behalf of the pair.
 329     (dotimes (i n-threads)
 330       (push (sb-thread:make-thread
 331              (lambda (me rs)
 332                ;; Randomizing makes keys be used up in a quasi-random
 333                ;; order without having to pre-compute a shuffle.
 334                (dotimes (i n-inserts)
 335                  (info-puthash
 336                   table (randomize (1+ i) rs)
 337                   (lambda (list)
 338                     (let ((peer (logxor me 1)))
 339                       (if (member peer list) list (cons me list)))))))
 340              :name (format nil "Worker ~D" i)
 341              :arguments (list i (if randomize (make-random-state rs))))
 342             threads))
 343     (when print (format t "Started ~D threads doing CONS~%" n-threads))
 344     (dolist (thread threads)
 345       (sb-thread:join-thread thread))
 346     (assert (= (info-env-count table) n-inserts))
 347     ;; Collect the distribution of threads which inserted, for display only
 348     ;; since it not expected to be particularly "fair"
 349     (let ((tally (make-array n-threads :initial-element 0)))
 350       (info-maphash
 351        (lambda (key id-list)
 352          (let ((scoreboard (make-array (/ n-threads 2) :element-type 'bit)))
 353            (dolist (thread-id id-list)
 354              (let ((group-id (floor thread-id 2)))
 355                ;; assert no duplicate for a peer group
 356                (if (= (sbit scoreboard group-id) 1)
 357                    (error "Fail: ~S ~S~%" key id-list))
 358                (setf (sbit scoreboard group-id) 1)
 359                (incf (aref tally thread-id))))
 360            ;; the scoreboard should be full
 361            (when (find 0 scoreboard)
 362              (error "Fail: ~S -> ~S (~S)~%" key id-list scoreboard))))
 363        table)
 364       ;; There should be half as many puthash operations that succeeded
 365       ;; as the product of n-threads and n-inserts.
 366       (assert (= (show-tally table tally "inserted" print)
 367                  (* 1/2 n-threads n-inserts)))))
 368   table)
 369
 370 #+sb-thread
 371 (progn
 372   (test-util:with-test (:name :lockfree-hash-concurrent-twiddling)
 373     (test-concurrent-incf))
 374   (test-util:with-test (:name :lockfree-hash-concurrent-consing)
 375     (test-concurrent-consing)))
 376
 377 ;; classoid cells
 378
 379 (in-package "SB-IMPL")
 380
 381 (defglobal *make-classoid-cell-callcount* (make-array 1 :element-type 'sb-ext:word))
 382 (defglobal *really-make-classoid-cell* #'sb-kernel::make-classoid-cell)
 383 (without-package-locks
 384   (defun sb-kernel::make-classoid-cell (name &optional classoid)
 385     (sb-ext:atomic-incf (aref *make-classoid-cell-callcount* 0))
 386     (funcall *really-make-classoid-cell* name classoid)))
 387
 388 ;; Return a set of symbols to play around with
 389 (defun classoid-cell-test-get-lotsa-symbols ()
 390   (remove-if-not
 391    #'symbolp
 392    (package-hashtable-cells
 393     (package-internal-symbols (find-package "SB-C")))))
 394
 395 ;; Make every symbol in the test set have a classoid-cell
 396 (defun be-a-classoid-cell-writer ()
 397   (let* ((symbols (classoid-cell-test-get-lotsa-symbols))
 398          (result (make-array (length symbols) :initial-element nil)))
 399     (loop for s across symbols
 400           for i from 0
 401           do (setf (aref result i) (find-classoid-cell s :create t)))
 402     result))
 403
 404 ;; Get the classoid-cells
 405 (defun be-a-classoid-cell-reader ()
 406   (let* ((symbols (classoid-cell-test-get-lotsa-symbols))
 407          (result (make-array (length symbols) :initial-element nil)))
 408     (dotimes (iter 3)
 409       (loop for i below (length symbols)
 410             do (pushnew (find-classoid-cell (svref symbols i))
 411                         (svref result i))))
 412     ;; The thread shall have observed at most two different values
 413     ;; for FIND-CLASSOID-CELL - nil and/or a CLASSOID-CELL.
 414     ;; For each symbol, if the thread observed a classoid cell, store that.
 415     (loop for list across result
 416           for i from 0
 417           do (let ((observed-value (remove nil list)))
 418                (if (cdr observed-value)
 419                    (error "Should not happen: find-classoid-cell => ~S" list)
 420                    (setf (svref result i) (car observed-value)))))
 421     result))
 422
 423 ;; Perform some silly updates to plists, because they mess with
 424 ;; the symbol-info slot alongside globaldb writers.
 425 (defun be-a-plist-writer ()
 426   (loop for s across (classoid-cell-test-get-lotsa-symbols)
 427         do
 428        (loop (let ((old (symbol-plist s)))
 429                (when (or (member 'foo old)
 430                          (eq (cas (symbol-plist s) old (list* 'foo s old)) old))
 431                  (return))))))
 432
 433 #+sb-thread
 434 (test-util:with-test (:name :info-vector-classoid-cell)
 435   (let (readers writers more-threads results)
 436     (dotimes (i 5)
 437       (push (sb-thread:make-thread #'be-a-classoid-cell-writer) writers))
 438     (dotimes (i 5)
 439       (push (sb-thread:make-thread #'be-a-classoid-cell-reader) readers)
 440       (push (sb-thread:make-thread #'be-a-plist-writer) more-threads))
 441     (mapc #'sb-thread:join-thread more-threads)
 442     (dolist (thread (append readers writers))
 443       (push (sb-thread:join-thread thread) results))
 444     (let ((result-vect (make-array 10)))
 445       (loop for i below (length (first results))
 446             do
 447            (dotimes (thread-num 10)
 448              (setf (aref result-vect thread-num)
 449                    (aref (nth thread-num results) i)))
 450            ;; some thread should have observed a classoid-cell
 451            (let ((representative (find-if-not #'null result-vect)))
 452              ;; For each thread which observed a classoid-cell,
 453              ;; assert that the cell is EQ to the representative.
 454              (dotimes (thread-num 10)
 455                (let ((cell (aref result-vect thread-num)))
 456                  (if cell
 457                      (assert (eq cell representative))))))))
 458     ;; and make sure the property list updates also weren't lost
 459     (let ((symbols (classoid-cell-test-get-lotsa-symbols)))
 460       (loop for s across symbols
 461          do (assert (eq (get s 'foo) s)))
 462       ;; a statistic of no real merit, but verifies that
 463       ;; the lockfree logic does discard some created objects.
 464       (format t "Consed ~D classoid-cells (~D symbols)~%"
 465               (aref *make-classoid-cell-callcount* 0)
 466               (length symbols)))))
 467
 468 ;;; test %GET-INFO-VALUE-INITIALIZING using generalized function names
 469
 470 (defun be-an-fdefn-reader (names)
 471   (declare (simple-vector names))
 472   (let ((result (make-array (length names) :initial-element nil)))
 473     (dotimes (iter 3)
 474       (loop for i below (length names)
 475             do (pushnew (find-fdefn (aref names i)) (aref result i))))
 476     ;; The thread shall observe either nil or an fdefn, and at most one fdefn.
 477     (loop for list across result
 478           for i from 0
 479           do (let ((observed-value (remove nil list)))
 480                (if (cdr observed-value)
 481                    (error "Should not happen: fdefn => ~S" list)
 482                    (setf (aref result i) (car observed-value)))))
 483     result))
 484
 485 (defun be-an-fdefn-writer (names)
 486   (declare (simple-vector names))
 487   (let ((fdefn-result (make-array (length names) :initial-element nil))
 488         (random-result (make-array (length names) :initial-element nil))
 489         (n-created 0)
 490         (highest-type-num
 491          (position-if #'identity sb-c::*info-types*
 492                       :end sb-int:+fdefn-info-num+ :from-end t)))
 493     (loop for name across names
 494           for i from 0
 495           do (setf (aref fdefn-result i)
 496                    (get-info-value-initializing
 497                     :function :definition name
 498                     (progn (incf n-created) (make-fdefn name))))
 499              (dotimes (i (random 3))
 500                ;; Set random info for other names to cause CAS failures.
 501                ;; Pick an info-type number and give it a random value.
 502                ;; Store the random value so that we can assert on it later.
 503                ;; Never touch reserved type numbers 0 or 63.
 504                (let ((random-name-index (random (length names)))
 505                      (random-type (+ (random (1- highest-type-num)) 2))
 506                      (random-value (random most-positive-fixnum)))
 507                  (push (cons random-type random-value)
 508                        (aref random-result random-name-index))
 509                  (sb-c::set-info-value (aref names random-name-index)
 510                                        random-type random-value))))
 511     (values n-created fdefn-result random-result)))
 512
 513 (test-util:with-test (:name :get-info-value-initializing
 514                       :skipped-on '(not :sb-thread))
 515   ;; Precompute random generalized function names for testing, some of which
 516   ;; are "simple" (per the taxonomy of globaldb) and some hairy.
 517   (let ((work (coerce (loop repeat 10000
 518                             nconc (list `(sb-pcl::ctor ,(gensym) ,(gensym))
 519                                         `(defmacro ,(gensym)) ; simple name
 520                                          (gensym))) ; very simple name
 521                       'vector))
 522         (n-threads 10) readers writers fdefn-results random-results)
 523     (dotimes (i (ash n-threads -1))
 524       (push (sb-thread:make-thread
 525              #'be-an-fdefn-writer :arguments (list work)
 526                                   :name (write-to-string i)) writers))
 527     (dotimes (i (ash n-threads -1))
 528       (push (sb-thread:make-thread #'be-an-fdefn-reader :arguments (list work))
 529             readers))
 530     (dolist (thread readers)
 531       (push (sb-thread:join-thread thread) fdefn-results))
 532     (let ((tot 0))
 533       (dolist (thread writers)
 534         (multiple-value-bind (n-created fdefn-result random-result)
 535             (sb-thread:join-thread thread)
 536           (incf tot n-created)
 537           (format t "~5D fdefns from ~A~%" n-created
 538                   (sb-thread:thread-name thread))
 539           (push fdefn-result fdefn-results)
 540           (push random-result random-results)))
 541       (format t "~5D total~%" tot))
 542     (let ((aggregate (make-array n-threads)))
 543       (dotimes (name-index (length work))
 544         (dotimes (thread-num n-threads)
 545           (setf (aref aggregate thread-num)
 546                 (aref (nth thread-num fdefn-results) name-index)))
 547         ;; some thread should have observed an fdefn
 548         (let ((representative (find-if-not #'null aggregate)))
 549           ;; For each thread which observed an fdefn,
 550           ;; assert that the cell is EQ to the representative.
 551           (dotimes (thread-num n-threads)
 552             (awhen (aref aggregate thread-num)
 553               (assert (eq it representative)))))))
 554     ;; For each name and each info type number that some thread inserted,
 555     ;; verify that the info-value is among the set of random values.
 556     (dotimes (name-index (length work))
 557       (dotimes (type-num 64)
 558         ;; some thread says that TYPE-NUM exists for NAME-INDEX
 559         (when (some (lambda (output)
 560                       (assoc type-num (aref output name-index)))
 561                     random-results)
 562           (let ((actual (sb-c::get-info-value (aref work name-index)
 563                                               type-num)))
 564             (unless (some (lambda (output)
 565                             (some (lambda (cell)
 566                                     (and (eq (car cell) type-num)
 567                                          (eql (cdr cell) actual)))
 568                                   (aref output name-index)))
 569                           random-results)
 570               (error "Fail ~S ~S => ~S.~%Choices are ~S"
 571                      (aref work name-index) type-num actual
 572                      (mapcar (lambda (output)
 573                                (aref output name-index))
 574                              random-results)))))))))
 575
 576 ;; As explained in the comments at the top of 'info-vector.lisp',
 577 ;; it is a bad idea to use globaldb to store an atomic counter as
 578 ;; a piece of info for a name, as it is quite brutal and consy,
 579 ;; but for this test, that's precisely the goal.
 580 ;; This test conses ~5 Megabytes on 64-bit almost entirely due
 581 ;; to allocation of each immutable info storage vector.
 582 (test-util:with-test (:name :get-info-value-updating
 583                       :skipped-on '(not :sb-thread))
 584   (flet ((run (names)
 585            (declare (simple-vector names))
 586            (let* ((n (length names))
 587                   (counts (make-array n :element-type 'sb-ext:word))
 588                   (threads))
 589              (dotimes (i 15)
 590                (push (sb-thread:make-thread
 591                       (lambda ()
 592                         (dotimes (iter 1000)
 593                           ;; increment (:variable :macro-expansion)
 594                           ;; for a randomly chosen name. That particular
 595                           ;; info-type harmlessly accepts any data type.
 596                           (let* ((index (random n))
 597                                  (name (aref names index)))
 598                             (atomic-incf (aref counts index))
 599                             ;; should probably be SB-INT:
 600                             (sb-c::atomic-set-info-value
 601                              :variable :macro-expansion name
 602                              (lambda (old old-p)
 603                                (if old-p (1+ old) 1))))
 604                           ;; randomly touch an item of info
 605                           ;; for another (or the same) name.
 606                           (let* ((index (random n))
 607                                  (name (aref names index)))
 608                             ;; source-location also accepts anything :-(
 609                             (setf (info :type :source-location name) iter)))))
 610                      threads))
 611              (mapc #'sb-thread:join-thread threads)
 612              ;; assert that no updates were lost
 613              (loop for name across names
 614                    for count across counts
 615                    for val = (info :variable :macro-expansion name)
 616                    do (assert (eql (or val 0) count))))))
 617     ;; Try it when names are symbols or "simple" 2-list names
 618     (run (coerce (loop repeat 50
 619                        for sym = (gensym)
 620                        nconc (list `(setf ,sym) sym))
 621                  'vector))
 622     ;; For hairy names, the tricky piece is in the rehash algorithm,
 623     ;; but there's no way to stress-test that because *INFO-ENVIRONMENT*
 624     ;; would have to keep doubling in size. To that end, it would have to begin
 625     ;; as a tiny table again, but it can't, without destroying the Lisp runtime.
 626     ;; The :lockfree-hash-concurrent-twiddling test should give high confidence
 627     ;; that it works, by creating and testing a standalone hash-table.
 628     (run (coerce (loop repeat 50 collect `(foo ,(gensym) hair)) 'vector))))
 629
 630 ;;; success