tests/debug.pure.lisp

   1
   2 (defun foo (x) (values 'fo x))
   3 (compile 'foo)
   4 (defmacro with-messed-up-foo (&body body)
   5   `(let ((f #'foo))
   6      (sb-sys:with-pinned-objects (f)
   7        (let* ((sap (sb-sys:sap+ (sb-sys:int-sap (sb-kernel:get-lisp-obj-address f))
   8                                 (- sb-vm:fun-pointer-lowtag)))
   9               (good (sb-sys:sap-ref-word sap 0)))
  10          (setf (ldb (byte 24 sb-vm:n-widetag-bits) (sb-sys:sap-ref-word sap 0)) 0)
  11          ;;(sb-vm:hexdump sap 2)
  12          ,@body
  13          (setf (sb-sys:sap-ref-word sap 0) good)))))
  14
  15 (with-test (:name :fun-code-header-bogus
  16                   :skipped-on :darwin-jit)
  17   ;; This "should" tests two things:
  18   ;; (1) that FUN-CODE-HEADER returns NIL if the simple-fun lacks a backpointer
  19   ;;     (expressed as a nonzero word count) to its containing code object.
  20   ;; (2) that GC doesn't crash in that situation.
  21   ;; Unfortunately the immobile-space GC *does* crash on it,
  22   ;; so I can't really test the second thing. But can it ever occur?
  23   ;; Specifically, why do all the variations of FUN-CODE-HEADER check for 0 ?
  24   (with-messed-up-foo
  25       (assert (null (sb-kernel:fun-code-header #'foo)))))
  26
  27 ;;; Cross-check the C and lisp implementations of varint decoding
  28 ;;; the compiled debug fun locations.
  29 (with-test (:name :c-decode-compiled-debug-fun-locs)
  30   (let ((ok t))
  31     (with-alien ((df-decode-locs (function int unsigned (* int) (* int))
  32                                  :extern)
  33                  (offset int)
  34                  (elsewhere-pc int))
  35       (dolist (code (sb-vm::list-allocated-objects
  36                      :all :type sb-vm:code-header-widetag))
  37         (when (typep (sb-kernel:%code-debug-info code)
  38                      'sb-c::compiled-debug-info)
  39           (do ((cdf (sb-c::compiled-debug-info-fun-map
  40                      (sb-kernel:%code-debug-info code))
  41                     (sb-c::compiled-debug-fun-next cdf)))
  42               ((null cdf))
  43             (let* ((locs (sb-c::compiled-debug-fun-encoded-locs cdf))
  44                    (res (sb-sys:with-pinned-objects (locs)
  45                           (alien-funcall df-decode-locs (sb-kernel:get-lisp-obj-address locs)
  46                                          (addr offset) (addr elsewhere-pc)))))
  47               (assert (= res 1))
  48               (multiple-value-bind (start-pc expect-elsewhere-pc expect-offset)
  49                   (sb-c::cdf-decode-locs cdf)
  50                 (declare (ignore start-pc))
  51                 (unless (and (= offset expect-offset)
  52                              (= elsewhere-pc expect-elsewhere-pc))
  53                   (setq ok nil)
  54                   (format t "Fail: ~X ~S ~S ~S ~S~%"
  55                           (sb-kernel:get-lisp-obj-address cdf)
  56                           offset expect-offset
  57                           elsewhere-pc expect-elsewhere-pc))))))))
  58     (assert ok)))
  59
  60 ;;; Check that valid_tagged_pointer_p is correct for all pure boxed objects
  61 ;;; using the super quick check of header validity.
  62 (defun randomly-probe-pure-boxed-objects ()
  63   (let (list)
  64     (sb-vm:map-allocated-objects
  65      (lambda (obj widetag size)
  66        (declare (ignore widetag))
  67        (let* ((index
  68                (sb-vm::find-page-index (sb-kernel:get-lisp-obj-address obj)))
  69               (type (sb-alien:slot (sb-alien:deref sb-vm::page-table index)
  70                                    'sb-vm::flags)))
  71          ;; mask off the SINGLE_OBJECT and OPEN_REGION bits
  72          (when (and (eq (logand type 7) 2) ; PAGE_TYPE_BOXED
  73                     ;; Cons cells on boxed pags are page filler
  74                     (not (listp obj)))
  75            (push (cons obj size) list))))
  76      :dynamic)
  77     (dolist (cell list)
  78       (let ((obj (car cell)) (size (cdr cell)))
  79         (sb-sys:with-pinned-objects (obj)
  80           ;; Check a random selection of pointers in between the untagged
  81           ;; base address up to the last byte in the object.
  82           ;; Exactly 1 should be OK.
  83           (let* ((taggedptr (sb-kernel:get-lisp-obj-address obj))
  84                  (base (logandc2 taggedptr sb-vm:lowtag-mask)))
  85             (dotimes (i 40)
  86               (let* ((ptr (+ base (random size)))
  87                      (valid (sb-di::valid-tagged-pointer-p (sb-sys:int-sap ptr))))
  88                 (if (= ptr taggedptr)
  89                     (assert (= valid 1))
  90                     (assert (= valid 0)))))))))))
  91 (compile 'randomly-probe-pure-boxed-objects)
  92 (with-test (:name :fast-valid-tagged-pointer-p
  93                   :broken-on :mark-region-gc)
  94   (randomly-probe-pure-boxed-objects))