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