tests/arena.impure.lisp

   1 #+(or (not system-tlabs) interpreter) (invoke-restart 'run-tests::skip-file)
   2
   3 (in-package sb-vm)
   4
   5 (defvar *many-arenas*
   6   (coerce (loop for i below 10 collect (new-arena 1048576)) 'vector))
   7
   8 (defvar *arena* (aref *many-arenas* 0))
   9 ;;; This REWIND is strictly unnecessary. It simply should not crash
  10 (rewind-arena *arena*)
  11
  12 (defun f (x y z)
  13   (with-arena (*arena*) (list x y z)))
  14
  15 (test-util:with-test (:name :arena-huge-object)
  16   ;; This arena can grow to 10 MiB.
  17   (let ((a (new-arena 1048576 1048576 9)))
  18     ;; 4 arrays of about 2MiB each should fit in the allowed space
  19     (dotimes (i 4)
  20       (test-util:opaque-identity
  21        (with-arena (a) (make-array 2097152 :element-type '(unsigned-byte 8)))))
  22     (destroy-arena a)))
  23
  24 (test-util:with-test (:name :disassembler)
  25   (let ((a (new-arena 1048576)))
  26     (with-arena (a) (sb-disassem:get-inst-space))
  27     (assert (null (c-find-heap->arena)))
  28     (destroy-arena a)))
  29
  30 (test-util:with-test (:name :no-arena-symbol-name)
  31   (let* ((a (new-arena 1048576))
  32          (symbol
  33           (sb-vm:with-arena (a)
  34             (let ((string (format nil "test~D" (random 10))))
  35               (make-symbol string)))))
  36     (assert (heap-allocated-p symbol))
  37     (assert (heap-allocated-p (symbol-name symbol)))
  38     (destroy-arena a)))
  39
  40 (test-util:with-test (:name :no-arena-symbol-property)
  41   (let* ((a (new-arena 1048576))
  42          (copy-of-foo
  43           (with-arena (a)
  44             (setf (get 'testsym 'fooprop) 9)
  45             (copy-symbol 'testsym t))))
  46     (test-util:opaque-identity copy-of-foo)
  47     (assert (not (c-find-heap->arena)))
  48     (destroy-arena a)))
  49
  50 (test-util:with-test (:name :interrupt-thread-on-arena)
  51   (let* ((a (new-arena 1048576))
  52          (sem (sb-thread:make-semaphore))
  53          (junk))
  54     (sb-vm:with-arena (a)
  55       (sb-thread:interrupt-thread
  56        sb-thread:*current-thread*
  57        (lambda ()
  58          (setf junk (cons 'foo 'bar))
  59          (sb-thread:signal-semaphore sem))))
  60     (sb-thread:wait-on-semaphore sem)
  61     (sb-vm:destroy-arena a)
  62     (assert (heap-allocated-p junk))))
  63
  64 (defun find-some-pkg () (find-package "NOSUCHPKG"))
  65
  66 (test-util:with-test (:name :find-package-1-element-cache)
  67   (let* ((cache (let ((code (fun-code-header #'find-some-pkg)))
  68                   (loop for i from code-constants-offset
  69                         below (code-header-words code)
  70                         when (and (typep (code-header-ref code i) '(cons string))
  71                                   (string= (car (code-header-ref code i))
  72                                            "NOSUCHPKG"))
  73                         return (code-header-ref code i))))
  74          (elements (cdr cache)))
  75     (assert (or (equalp (cdr cache) #(NIL NIL NIL))
  76                 (search "#<weak array [3]" (write-to-string (cdr cache)))))
  77     (let* ((a (new-arena 1048576))
  78            (pkg (with-arena (a) (find-some-pkg))))
  79       (assert (not pkg)) ; no package was found of course
  80       (assert (neq (cdr cache) elements)) ; the cache got affected
  81       (assert (not (c-find-heap->arena)))
  82       (destroy-arena a))))
  83
  84 #+nil
  85 (test-util:with-test (:name :arena-alloc-waste-reduction)
  86   (let* ((list1 (f 'foo 'bar'baz))
  87          (list1-addr (get-lisp-obj-address list1))
  88          (prev list1-addr))
  89     (dotimes (i 40)
  90       (let* ((list2 (f 'baz 'quux 'glerp))
  91              (this (get-lisp-obj-address list2)))
  92         ;; Thread should have picked up where it  left off in the arena
  93         ;; on the previous allocation.
  94         ;; The list is 3 conses.
  95         (assert (= (- this prev) (* 3 cons-size n-word-bytes)))
  96         (setq prev this)))
  97     (rewind-arena *arena*)
  98     (let* ((list3 (f 'zot nil 'bork))
  99            (this (get-lisp-obj-address list3)))
 100       (assert (= this list1-addr)))))
 101
 102 ;;;
 103
 104 (test-util:with-test (:name :copy-numbers-to-heap)
 105   (let (list1 list2)
 106     (with-arena (*arena*)
 107       (setq list1 (let ((r (ash #xf00 (+ 60 (random 10)))))
 108                     (list r
 109                           (coerce r 'double-float)
 110                           (coerce r '(complex single-float))
 111                           (coerce r '(complex double-float))
 112                           (complex 1 (1+ (random 40)))
 113                           (/ 1 r)))
 114             ;; still inside the WITH-ARENA or else the test is not useful!
 115             list2 (mapcar 'copy-number-to-heap list1)))
 116     (assert (not (heap-allocated-p list1)))
 117     (assert (notany #'heap-allocated-p list1))
 118     (assert (every #'heap-allocated-p list2))))
 119
 120 (test-util:with-test (:name :points-to-arena)
 121   (let (tests)
 122     (dotimes (i 20)
 123       (let ((randomly-arena-thing (if (evenp i)
 124                                       (with-arena (*arena*) (cons 1 2))
 125                                       (cons 3 4))))
 126         (push (make-array 1 :initial-element randomly-arena-thing) tests)))
 127     (setq tests (nreverse tests))
 128     (dolist (x tests)
 129       (let* ((arena-ref-p (points-to-arena x))
 130              (item (aref x 0)))
 131         (if (find-containing-arena (get-lisp-obj-address item))
 132             (assert arena-ref-p)
 133             (assert (not arena-ref-p)))))))
 134
 135 (defvar *foo-storage*)
 136 (test-util:with-test (:name :ctype-cache-force-to-heap)
 137   (drop-all-hash-caches)
 138   (test-util:opaque-identity
 139    (with-arena (*arena*)
 140      ;; finder-result will assert that this goes to the heap
 141      (setq *foo-storage* (sb-impl::allocate-hashset-storage 128 t))
 142      ;; for each test, the type specifier itself can not be cached because
 143      ;; it is a list in the arena. And the internal representation has to
 144      ;; take care to copy arena-allocated numbers back to dynamic space.
 145      (list (let* ((n (- (test-util:opaque-identity 0d0)))
 146                   (spec `(member ,n)))
 147              (assert (not (heap-allocated-p (second spec)))) ; -0d0 is off-heap
 148              (typep (random 2) spec))
 149            (let* ((n (+ 5.0d0 (random 10)))
 150                   (bound (list n))
 151                   (spec `(or (double-float ,bound) (integer ,(random 4)))))
 152              ;; should not cache the type specifier
 153              (typep 'foo spec)))))
 154   (dolist (symbol sb-impl::*cache-vector-symbols*)
 155     (let ((cache (symbol-value symbol)))
 156       ; (format t "~&Checking cache ~S~%" symbol)
 157       (when cache
 158         (assert (heap-allocated-p cache))
 159         (dovector (line cache)
 160           (unless (eql line 0)
 161             (unless (and (heap-allocated-p line) (not (points-to-arena line)))
 162               (hexdump line 2 nil)
 163               (error "~S has ~S" symbol line)))))))
 164   (let ((finder-result (c-find-heap->arena)))
 165     (assert (null finder-result))))
 166
 167 (defun decode-all-debug-data ()
 168   (dolist (code (sb-vm:list-allocated-objects :all :type sb-vm:code-header-widetag))
 169     (let ((info (sb-kernel:%code-debug-info code)))
 170       (when (typep info 'sb-c::compiled-debug-info)
 171         (do ((cdf (sb-c::compiled-debug-info-fun-map info)
 172                   (sb-c::compiled-debug-fun-next cdf)))
 173             ((null cdf))
 174           (test-util:opaque-identity
 175            (sb-di::debug-fun-lambda-list
 176             (sb-di::make-compiled-debug-fun cdf code))))))))
 177
 178 (test-util:with-test (:name :debug-data-force-to-heap)
 179   (let ((a (sb-vm:new-arena (* 1024 1024 1024))))
 180     (sb-vm:with-arena (a)
 181       (decode-all-debug-data))
 182     (assert (null (sb-vm:c-find-heap->arena a)))
 183     (sb-vm:destroy-arena a)))
 184
 185 (defun test-with-open-file ()
 186   ;; Force allocation of a new BUFFER containing a new SAP,
 187   ;; and thereby a new finalizer (a closure) so that the test can
 188   ;; ascertain that none of those went to the arena.
 189   (setq sb-impl::*available-buffers* nil)
 190   (with-open-file (stream *load-pathname*)
 191     (if stream
 192         (let ((pn (pathname stream)))
 193           (values pn (namestring pn) (read-line stream nil)))
 194         (values nil nil nil))))
 195
 196 (defvar *answerstring*)
 197 (test-util:with-test (:name :with-open-stream)
 198   (multiple-value-bind (pathname namestring answer)
 199       (with-arena (*arena*) (test-with-open-file))
 200     (when pathname
 201       (assert (heap-allocated-p pathname))
 202       (assert (heap-allocated-p namestring))
 203       (assert (not (points-to-arena pathname)))
 204       (assert (not (heap-allocated-p answer)))
 205       ;; 1. check that a global symbol value can be found
 206       (unwind-protect
 207            (progn
 208              (setq *answerstring* answer)
 209              ;; user's string went to the arena, and detector finds the source object
 210              (let ((finder-result (c-find-heap->arena)))
 211                (assert (equal finder-result '(*answerstring*)))))
 212         (makunbound '*answerstring*))
 213       ;; 2. check that a thread-local binding can be found
 214       (let ((*answerstring* answer))
 215         (let ((finder-result (c-find-heap->arena)))
 216           (assert (equal (first finder-result)
 217                          `(,sb-thread:*current-thread* :tls *answerstring*))))
 218         ;; 3. check that a shadowed binding can be found
 219         (let ((*answerstring* "hi"))
 220           (let ((finder-result (c-find-heap->arena)))
 221             (assert (equal (first finder-result)
 222                            `(,sb-thread:*current-thread* :binding *answerstring*)))))))))
 223
 224 ;;;
 225
 226 (defun test-vpe-heap-vector (vector count &aux grown)
 227   (with-arena (*arena*)
 228     (assert (not (heap-allocated-p (cons 1 2)))) ; assert arena is in use
 229     (dotimes (i count)
 230       (let ((old-data (%array-data vector)))
 231         (vector-push-extend i vector)
 232         (let ((new-data (%array-data vector)))
 233           (unless (eq new-data old-data)
 234             (assert (heap-allocated-p new-data))
 235             (setq grown t))))))
 236   (assert grown)) ; make sure the test proved something
 237
 238 (defun test-vpe-arena-vector (count &aux grown)
 239   (with-arena (*arena*)
 240     (let ((v (make-array 4 :fill-pointer 0 :adjustable t)))
 241       (assert (not (heap-allocated-p v)))
 242       (assert (not (heap-allocated-p (%array-data v))))
 243       (dotimes (i count)
 244         (let ((old-data (%array-data v)))
 245           (vector-push-extend i v)
 246           (let ((new-data (%array-data v)))
 247             (unless (eq new-data old-data)
 248               (assert (not (heap-allocated-p new-data)))
 249               (setq grown t)))))))
 250   (assert grown))
 251
 252 (defun test-puthash-heap-table (table count &aux grown)
 253   (assert (sb-impl::hash-table-hash-vector table)) ; require a hash vector
 254   (with-arena (*arena*)
 255     (assert (not (heap-allocated-p (cons 1 2))))
 256     (dotimes (i count)
 257       (let ((old-data (sb-impl::hash-table-pairs table)))
 258         (setf (gethash i table) i)
 259         (let ((new-data (sb-impl::hash-table-pairs table)))
 260           (unless (eq new-data old-data)
 261             (assert (heap-allocated-p new-data))
 262             (assert (heap-allocated-p (sb-impl::hash-table-hash-vector table)))
 263             (assert (heap-allocated-p (sb-impl::hash-table-index-vector table)))
 264             (assert (heap-allocated-p (sb-impl::hash-table-next-vector table)))
 265             (setq grown t))))))
 266   (assert grown))
 267
 268 (defun test-puthash-arena-table (count &aux grown)
 269   (with-arena (*arena*)
 270     (let ((table (make-hash-table :test 'equal)))
 271       (assert (sb-impl::hash-table-hash-vector table)) ; require a hash vector
 272       (assert (not (heap-allocated-p table)))
 273       (dotimes (i count)
 274         (let ((old-data (sb-impl::hash-table-pairs table)))
 275           (setf (gethash i table) i)
 276           (let ((new-data (sb-impl::hash-table-pairs table)))
 277             (unless (eq new-data old-data)
 278               (assert (not (heap-allocated-p new-data)))
 279               (assert (not (heap-allocated-p (sb-impl::hash-table-hash-vector table))))
 280               (assert (not (heap-allocated-p (sb-impl::hash-table-index-vector table))))
 281               (assert (not (heap-allocated-p (sb-impl::hash-table-next-vector table))))
 282               (setq grown t)))))))
 283   (assert grown))
 284
 285 ;;; There is a case that this doesn't assert anything about, which is that
 286 ;;; an arena-allocated table or vector which grows while *not* in the scope of
 287 ;;; a WITH-ARENA (or inside a nested WITHOUT-ARENA) will go to the dynamic space.
 288 ;;; I think that is the right behavior: you can't force an object to be arena-allocated
 289 ;;; within a dynamic controls that asks for no arena allocation.
 290 ;;; I can't see how such a situation would legitimately arise,
 291 ;;; and it's probably only through application programmer error.
 292
 293 (test-util:with-test (:name :vector-push-extend-heap-vector)
 294   (test-vpe-heap-vector (make-array 4 :fill-pointer 0 :adjustable t) 100))
 295
 296 (test-util:with-test (:name :vector-push-extend-arena-vector)
 297   (test-vpe-arena-vector 100))
 298
 299 (test-util:with-test (:name :puthash-heap-table)
 300   (test-puthash-heap-table (make-hash-table :test 'equal) 100))
 301
 302 (test-util:with-test (:name :puthash-arena-table)
 303   (test-puthash-arena-table 100))
 304
 305 (defvar arena1 (new-arena 65536))
 306 (defvar arena2 (new-arena 65536))
 307
 308 (defun f (a) (with-arena (a) (make-array 1000)))
 309 (defun g (a) (with-arena (a) (list 'x 'y 'z)))
 310
 311 (defvar ptr1 (cons (f arena1) 'foo))
 312 (defvar ptr2 (g arena2))
 313
 314 (test-util:with-test (:name :find-ptrs-all-arenas)
 315   (let ((result (c-find-heap->arena)))
 316     ;; There should be a cons pointing to ARENA1,
 317     ;; the cons which happens to be in PTR1
 318     (assert (member ptr1 result))
 319     ;; The symbol PTR2 points directly to ARENA2.
 320     (assert (member 'ptr2 result))
 321     ;; There should not be anything else
 322     (assert (= (length result) 2))))
 323
 324 (test-util:with-test (:name :find-ptrs-specific-arena)
 325   (let ((result (c-find-heap->arena arena1)))
 326     (assert (equal result (list ptr1))))
 327   (let ((result (c-find-heap->arena arena2)))
 328     (assert (equal result '(ptr2)))))
 329
 330 (defun use-up-some-space (n &aux (arenas *many-arenas*)
 331                                  (bytes-used (make-array (length arenas)
 332                                                          :initial-element 0)))
 333   (dotimes (k n)
 334     (let* ((i (mod k (length arenas)))
 335            (arena (aref arenas i)))
 336       (with-arena (arena)
 337         (let ((object (make-array (+ 100 (random 100)))))
 338           (incf (aref bytes-used i) (primitive-object-size object)))))
 339     #+nil
 340     (when (zerop (random 1000))
 341       (let ((i (random (length arenas))))
 342         (let ((arena (aref arenas i)))
 343           (format t "~&REWINDING ~D~%" (arena-index arena))
 344           (rewind-arena arena)
 345           (with-arena (arena)
 346             (test-util:opaque-identity (make-array 5)))))))
 347   bytes-used)
 348 #+nil
 349 (test-util:with-test (:name :allocator-resumption)
 350   (map nil 'rewind-arena *many-arenas*)
 351   (let ((bytes-used-per-arena (use-up-some-space 10000)))
 352     (dotimes (i (length *many-arenas*))
 353       (let* ((est (aref bytes-used-per-arena i))
 354              (act (arena-bytes-used (aref *many-arenas* i)))
 355              (delta (- act est))
 356              (frac (* 100 (/ delta act))))
 357       (format t "Used: estimate=~D actual=~D diff=~,2f%~%"
 358               est act frac)
 359       (assert (< frac 1))))))
 360
 361 (test-util:with-test (:name :thread-arena-inheritance)
 362   (with-arena (*arena*)
 363     (let ((thread
 364            (sb-thread:make-thread
 365             (lambda ()
 366               (assert (arena-p (thread-current-arena)))
 367               ;; Starting a new thread doesn't ensure that the arena savearea
 368               ;; has enough room to save the state, so we now ensure space in the
 369               ;; savearea only when switching away from the arena.
 370               (unuse-arena)))))
 371       (sb-thread:join-thread thread))))
 372
 373 ;;;; Type specifier parsing and operations
 374
 375 (defparameter *bunch-of-objects*
 376   `((foo)
 377     "astring"
 378     #*1010
 379     ,(find-package "CL")
 380     ,(pathname "/tmp/blub")
 381     ,#'open
 382     #2a((1 2) (3 4))
 383     ,(ash 1 64)
 384     ))
 385
 386 ;; These type-specs are themselves consed so that we can
 387 ;; ascertain whether there are arena pointers in internalized types.
 388 (defun get-bunch-of-type-specs ()
 389   `((integer ,(random 47) *)
 390     (and bignum (not (eql ,(random 1000))))
 391     (and bignum (not (eql ,(logior #x8000000000000001
 392                                    (ash (1+ (random #xF00)) 10)))))
 393     (member ,(complex (coerce (random 10) 'single-float)
 394                       (coerce (- (random 10)) 'single-float))
 395             (goo)
 396             #+sb-unicode
 397             #\thumbs_up_sign
 398             #-sb-unicode
 399             #\a)
 400     (or stream (member :hello
 401                        #+sb-unicode #\thumbs_down_sign
 402                        #-sb-unicode #\B))
 403     (array t (,(+ 10 (random 10))))))
 404
 405 (defun show-cache-counts ()
 406   (dolist (s sb-impl::*cache-vector-symbols*)
 407     (let ((v (symbol-value s)))
 408       (when (vectorp v)
 409         (format t "~5d  ~a~%"
 410                 (count-if (lambda (x) (not (eql x 0))) v)
 411                 s)))))
 412
 413 (defun ctype-operator-tests (arena &aux (result 0))
 414   (sb-int:drop-all-hash-caches)
 415   (flet ((try (spec)
 416            (dolist (x *bunch-of-objects*)
 417              (when (typep x spec)
 418                (incf result)))))
 419     (with-arena (arena)
 420       (let ((specs (get-bunch-of-type-specs)))
 421         (dolist (spec1 specs)
 422           (dolist (spec2 specs)
 423             (try `(and ,spec1 ,spec2))
 424             (try `(or ,spec1 ,spec2))
 425             (try `(and ,spec1 (not ,spec2)))
 426             (try `(or ,spec1 (not ,spec2))))))))
 427   (assert (not (c-find-heap->arena arena)))
 428   result)
 429 (test-util:with-test (:name :ctype-cache)
 430   (let ((arena (new-arena 1048576)))
 431     (ctype-operator-tests arena)))
 432
 433 ;;;;
 434
 435 (defvar *newpkg* (make-package "PACKAGE-GROWTH-TEST"))
 436 (defun addalottasymbols ()
 437   (with-arena (*arena*)
 438     (dotimes (i 200)
 439       (let ((str (concatenate 'string "S" (write-to-string i))))
 440         (assert (not (heap-allocated-p str)))
 441         (let ((sym (intern str *newpkg*)))
 442           (assert (heap-allocated-p sym))
 443           (assert (heap-allocated-p (symbol-name sym)))))))
 444   (assert (not (c-find-heap->arena *arena*))))
 445
 446 (test-util:with-test (:name :intern-a-bunch)
 447   (let ((old-n-cells
 448          (length (sb-impl::symtbl-cells
 449                   (sb-impl::package-internal-symbols *newpkg*)))))
 450     (addalottasymbols)
 451     (let* ((cells (sb-impl::symtbl-cells
 452                    (sb-impl::package-internal-symbols *newpkg*))))
 453       (assert (> (length cells) old-n-cells)))))
 454
 455 (defun all-arenas ()
 456   (let ((head (sb-kernel:%make-lisp-obj (extern-alien "arena_chain" unsigned))))
 457     (cond ((eql head 0) nil)
 458           (t
 459            (assert (typep (arena-link head) '(or null arena)))
 460            (collect ((output))
 461              (do ((a head (arena-link a)))
 462                  ((null a)
 463                   ;; (format t "CHAIN: ~X~%" (output))
 464                   (output))
 465                (output (get-lisp-obj-address a))))))))
 466
 467 (define-condition foo (simple-warning)
 468   ((a :initarg :a)
 469    (b :initarg :b)))
 470 (defvar *condition* (make-condition 'foo
 471                                     :format-control "hi there"
 472                                     :a '(x y) :b #P"foofile"
 473                                     :format-arguments '("Yes" "no")))
 474 (test-util:with-test (:name :arena-condition-slot-access)
 475   (assert (null (sb-kernel::condition-assigned-slots *condition*)))
 476   (let ((val (with-arena (*arena*)
 477                (slot-value *condition* 'b))))
 478     (assert (pathnamep val))
 479     (assert (not (points-to-arena *condition*)))))
 480
 481 (test-util:with-test (:name :gc-epoch-not-in-arena)
 482   (with-arena (*arena*) (gc))
 483   (assert (heap-allocated-p sb-kernel::*gc-epoch*)))
 484
 485 (defvar *thing-created-by-hook* nil)
 486 (push (lambda () (push (cons 1 2) *thing-created-by-hook*))
 487       *after-gc-hooks*)
 488 (test-util:with-test (:name :post-gc-hooks-unuse-arena)
 489   (with-arena (*arena*) (gc))
 490   (setq *after-gc-hooks* nil)
 491   (assert (heap-allocated-p *thing-created-by-hook*))
 492   (assert (heap-allocated-p (car *thing-created-by-hook*))))
 493
 494 ;;; CAUTION: tests of C-FIND-HEAP->ARENA that execute after destroy-arena and a following
 495 ;;; NEW-ARENA might spuriously fail depending on how eagerly malloc() reuses addresses.
 496 ;;; The failure goes something like this:
 497 ;;;
 498 ;;; stack -> some-cons C1 ; conservative reference
 499 ;;; heap: C1 = (#<instance-in-arena> . mumble)
 500 ;;;
 501 ;;; now rewind the arena. "instance-in-arena" is not a valid object.
 502 ;;; But: allocate more stuff in the arena, and suppose the address where instance-in-arena
 503 ;;; formerly was now holds a different primitive object, like a cons cell.
 504 ;;; The C-FIND-HEAP->ARENA function won't die, but you *will* die when trying to examine
 505 ;;; what it found.  The heap cons is conservatively live, its contents are assumed good,
 506 ;;; yet its CAR has instance-pointer-lowtag pointing to something that does not have
 507 ;;; INSTANCE-WIDETAG. The Lisp printer suffers a horrible fate and causes recursive errors.
 508 ;;; Had malloc() not reused an address, this would not happen, because the destroyed arena
 509 ;;; can not be seen, and the cons pointing to nothing will not be returned by the finder.
 510 (test-util:with-test (:name destroy-arena)
 511   (macrolet ((exit-if-no-arenas ()
 512                '(progn (incf n-deleted)
 513                        (when (zerop (extern-alien "arena_chain" unsigned)) (return)))))
 514     (let ((n-arenas (length (all-arenas)))
 515           (n-deleted 0))
 516       (loop ; until all deleted
 517         ;; 1.delete the first item
 518         (let* ((chain (all-arenas))
 519                (item (car chain))
 520                (arena (%make-lisp-obj item)))
 521           (assert (typep arena 'arena))
 522           (destroy-arena arena)
 523           (assert (equal (all-arenas) (cdr chain))))
 524         (exit-if-no-arenas)
 525         ;; 2. delete something from the middle
 526         (let* ((chain (all-arenas))
 527                (item (nth (floor (length chain) 2) chain))
 528                (arena (%make-lisp-obj item)))
 529           (assert (typep arena 'arena))
 530           (destroy-arena arena)
 531           (assert (equal (all-arenas) (delete item chain))))
 532         (exit-if-no-arenas)
 533         ;; 3. delete the last item
 534         (let* ((chain (all-arenas))
 535                (item (car (last chain)))
 536                (arena (%make-lisp-obj item)))
 537           (assert (typep arena 'arena))
 538           (destroy-arena arena)
 539           (assert (equal (all-arenas) (butlast chain))))
 540         (exit-if-no-arenas))
 541       (assert (= n-deleted n-arenas)))))
 542
 543 (defvar *another-arena* (new-arena 131072))
 544 (defun g (n) (make-array (the integer n) :initial-element #\z))
 545 (defun f (a n) (with-arena (a) (g n)))
 546
 547 (defvar *vect* (f *another-arena* 10))
 548 (setf (aref *vect* 3) "foo")
 549
 550 ;;; "Hiding" an arena asserts that no references will be made to it until
 551 ;;; unhidden and potentially rewound. So any use of it is like a use-after-free bug,
 552 ;;; except that the memory is still there so we can figure out what went wrong
 553 ;;; with user code. This might pass on #+-linux but has not been tested.
 554 (setf (extern-alien "lose_on_corruption_p" int) 0)
 555 (test-util:with-test (:name :arena-use-after-free :skipped-on (:not :linux))
 556   ;; scary messages scare me
 557   (format t "::: NOTE: Expect a \"CORRUPTION WARNING\" from this test~%")
 558   (hide-arena *another-arena*)
 559   (let (caught)
 560     (block foo
 561       (handler-bind
 562           ((sb-sys:memory-fault-error
 563              (lambda (c)
 564                (format t "~&Uh oh spaghetti-o: tried to read @ ~x~%"
 565                        (sb-sys:system-condition-address c))
 566                (setq caught t)
 567                (return-from foo))))
 568         (aref *vect* 3)))
 569     (assert caught))
 570   ;; Assert that it becomes usable again
 571   (unhide-arena *another-arena*)
 572   (rewind-arena *another-arena*)
 573   (dotimes (i 10) (f *another-arena* 1000)))
 574 (setf (extern-alien "lose_on_corruption_p" int) 1)
 575
 576 ;; #+sb-devel preserves some symbols that the test doesn't care about
 577 ;; as the associated function will never be called.
 578 (defvar *ignore* '("!EARLY-LOAD-METHOD"))
 579
 580 (test-util:with-test (:name :disassemble-pcl-stuff)
 581   (let ((stream (make-string-output-stream)))
 582     (with-package-iterator (iter "SB-PCL" :internal :external)
 583       (loop
 584         (multiple-value-bind (got symbol) (iter)
 585           (unless got (return))
 586           (when (and (fboundp symbol)
 587                      (not (member (string symbol) *ignore* :test 'string=))
 588                      (not (closurep (symbol-function symbol)))
 589                      (not (sb-pcl::generic-function-p
 590                            (symbol-function symbol))))
 591             (disassemble (sb-kernel:fun-code-header
 592                           (or (macro-function symbol)
 593                               (symbol-function symbol)))
 594                          :stream stream)
 595             (let ((lines (test-util:split-string
 596                           (get-output-stream-string stream)
 597                           #\newline)))
 598               ;; Each alloc-tramp call should be the SYS- variant
 599               (flet ((line-ok (line)
 600                        (cond ((search "LIST-ALLOC-TRAMP" line)
 601                               (search "SYS-LIST-ALLOC-TRAMP" line))
 602                              ((search "ALLOC-TRAMP" line)
 603                               (search "SYS-ALLOC-TRAMP" line))
 604                              ((search "LISTIFY-&REST" line)
 605                               (search "SYS-LISTIFY-&REST" line))
 606                              (t t))))
 607                 (unless (every #'line-ok lines)
 608                   (format *error-output* "Failure:~{~%~A~}~%" lines)
 609                   (error  "Bad result for ~S" symbol))))))))))
 610
 611 (defun collect-objects-pointing-off-heap ()
 612   (let (list)
 613     (flet ((add-to-result (obj referent)
 614              ;; If this is a code component and it points to fixups
 615              ;; which are a bignum in a random place, assume that it's an ELF core
 616              ;; and that the packed fixup locs are in a ".rodata" section
 617              (cond ((and (typep obj 'sb-kernel:code-component)
 618                          (typep referent 'bignum)
 619                          (eq referent (%code-fixups obj)))
 620                     nil)
 621                    (t
 622                     (push (cons (sb-ext:make-weak-pointer obj)
 623                                 (if (sb-ext:stack-allocated-p referent t)
 624                                     :stack
 625                                     (sb-sys:int-sap (get-lisp-obj-address referent))))
 626                           list)))))
 627       (macrolet ((visit (referent)
 628                    `(let ((r ,referent))
 629                       (when (and (is-lisp-pointer (get-lisp-obj-address r))
 630                                  (not (heap-allocated-p r))
 631                                  (add-to-result obj r))
 632                         (return-from done)))))
 633         (map-allocated-objects
 634          (lambda (obj type size)
 635            (declare (ignore type size))
 636            (block done
 637              (do-referenced-object (obj visit)
 638                (t
 639                 :extend
 640                 (case (widetag-of obj)
 641                   (#.value-cell-widetag
 642                    (visit (value-cell-ref obj)))
 643                   (t
 644                    (warn "Unknown widetag ~x" (widetag-of obj))))))))
 645          :all)))
 646     list))
 647
 648 (defun show-objects-pointing-off-heap (list)
 649   (dolist (x list)
 650     (let ((obj (weak-pointer-value (car x))))
 651       (if (typep obj '(or sb-kernel:code-component
 652                        symbol))
 653           (format t "~s -> ~s~%" obj (cdr x))
 654           (format t "~s -> ~s~%" (type-of obj) (cdr x))))))