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