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