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