tests/heapwalk.impure.lisp

   1
   2 (defun mul (x y) (declare (sb-vm:signed-word x y)) (* x y))
   3 (compile 'mul)
   4
   5 (defun manymul (n &aux res)
   6   (dotimes (i n res)
   7     (setq res (mul (floor (- (expt 2 (- sb-vm:n-word-bits 2))) 1000)
   8                    (+ i 1000)))))
   9 (compile 'manymul)
  10
  11 (defun walk ()
  12   (let ((v (make-array 1000))
  13         (ct 0))
  14     (sb-vm:map-allocated-objects
  15      (lambda (obj type size)
  16        (declare (ignore size))
  17        (when (and (= type sb-vm:list-pointer-lowtag)
  18                   (= (sb-kernel:generation-of obj) 0)
  19                   (< ct 1000))
  20          (setf (aref v ct) obj)
  21          (incf ct)))
  22      :dynamic)
  23     (let ((*print-level* 2)
  24           (*print-length* 4)
  25           (*standard-output* (make-broadcast-stream)))
  26       (dotimes (i ct)
  27         (princ (aref v i))))))
  28 (compile 'walk)
  29
  30 ;;; As a precondition to asserting that heap walking did not
  31 ;;; visit an alleged cons that is a filler object,
  32 ;;; assert that there is the telltale pattern (if applicable).
  33 ;;; x86-64 no longer leaves a stray 0xFF..FFF word in the heap.
  34 ;;; That bit pattern came from signed integer multiplication where the final result
  35 ;;; was a bignum having 1 payload word, but the intermediate result was a bignum
  36 ;;; whose trailing word was all 1s. Being a redundant copy of the sign bit from the
  37 ;;; prior word, the bignum gets shortened. Only arm64 overallocates the bignum now.
  38 #+arm64
  39 (let ((product (manymul 1)))
  40   (sb-sys:with-pinned-objects (product)
  41     (let ((word (sb-sys:sap-ref-word
  42                  (sb-sys:int-sap (sb-kernel:get-lisp-obj-address product))
  43                  (- (ash 2 sb-vm:word-shift) sb-vm:other-pointer-lowtag))))
  44       (assert (= word sb-ext:most-positive-word)))))
  45
  46 (manymul 100)
  47
  48 ;;; Granted it's not a great idea to assume that anything in the heap
  49 ;;; can be printed, but this test was a fairly easy way to get
  50 ;;;  "Unhandled memory fault at #xFFFFFFFFFFFFFFF0."
  51 ;;; The should print approximately one cons (for GC epoch)
  52 (with-test (:name :heapwalk-safety)
  53   (progn (gc :gen 1) (manymul 100) (walk)))