tests/traceroot.impure.lisp

   1 ;;;; tests related to 'traceroot'
   2 ;;;;
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; While most of SBCL is derived from the CMU CL system, the test
   7 ;;;; files (like this one) were written from scratch after the fork
   8 ;;;; from CMU CL.
   9 ;;;;
  10 ;;;; This software is in the public domain and is provided with
  11 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
  12 ;;;; more information.
  13
  14 ;;;; These tests should pass for all platforms, but they're not
  15 ;;;; and I don't care too much why, since the functionality still works.
  16 ;;;; It's just that sometimes we get :PINNED as a root instead of
  17 ;;;; the expected reference to the one and only thread.
  18 ;;;; And also sb-safepoint gets a crash in C.
  19 #-(and (or arm64 ppc64 x86-64) sb-thread (not sb-safepoint) (not gc-stress))
  20 (invoke-restart 'run-tests::skip-file)
  21
  22 (setq sb-ext:*evaluator-mode* :compile)
  23 (defvar *fred*)
  24 (defstruct foo a)
  25
  26 (defun scrubstack ()
  27   (sb-int:dx-let ((b (make-array 20))) (eval b))
  28   (sb-sys:scrub-control-stack))
  29
  30 (defun test1 (wp obj root)
  31   (let ((*fred* (list (make-foo :a (list (vector #xfeefa (list obj)))))))
  32     (setq obj nil) ; so OBJ is not found as a stack reference
  33     (let ((paths
  34            (ecase root
  35              (:tls
  36               (scrubstack)
  37               (sb-ext:search-roots wp :criterion :oldest :print nil))
  38              (:bindings ; bind *FRED* again so the old value is on the binding stack
  39               (let ((*fred* 1))
  40                 (scrubstack)
  41                 (sb-ext:search-roots wp :criterion :oldest :print nil)))
  42              (:stack
  43               ; put the OBJ back on the control stack
  44               ; and also ensure that *FRED* is not a root.
  45               (setq obj *fred* *fred* nil)
  46               (scrubstack)
  47               (sb-ext:search-roots wp :criterion :oldest :print nil)))))
  48       (assert paths)
  49       (let* ((path (cdar paths))
  50              (root (car path)))
  51         (assert (stringp (car root)))
  52         (case root
  53           (:stack
  54            (assert (typep (cdr root) '(cons system-area-pointer))))
  55           (:tls
  56            (assert (typep (cdr root) '(cons (eql *fred*) (cons t)))))
  57           (:bindings
  58            (assert (typep (cdr path) '(cons (eql *fred*) (cons nil))))))))))
  59
  60 (with-test (:name (sb-ext:search-roots :stack-indirect)
  61             :fails-on :mark-region-gc
  62             :fails-on :sunos)
  63   (let ((wp (make-weak-pointer (list 1 2 3 4))))
  64     (test1 wp (weak-pointer-value wp) :stack)
  65     (test1 wp (weak-pointer-value wp) :tls)
  66     (test1 wp (weak-pointer-value wp) :bindings)
  67     nil))
  68
  69 (defun f0 ()
  70   (let* ((c (cons 1 2))
  71          (wp (make-weak-pointer c)))
  72     (let ((paths (sb-ext:search-roots wp :criterion :static :print nil)))
  73       (assert paths)
  74       (let* ((path (car paths))
  75              (nodes (cdr path)))
  76         (assert (and (sb-int:singleton-p nodes)
  77                      (string= "main thread" (caar nodes))))))
  78     c))
  79 (with-test (:name (sb-ext:search-roots :stack-direct)
  80             :fails-on :sunos)
  81   (f0))
  82
  83 ;;; Employ circumlocution so the file loader doesn't hold on to a string "hi"
  84 (defvar *string-hi*)
  85 (defstruct s1 foo)
  86 ;;; Ensure that *STRING-HI* does not get smashed before we ever got to both
  87 ;;; DEFVARS (if GC executed in between the two) but that we don't hold a reference
  88 ;;; from the stack. (which we can't really guarantee though)
  89 (defparameter *top*
  90   (let ((s (concatenate 'string "h" "i")))
  91     (setq *string-hi* (make-weak-pointer s))
  92     `(p q r w x y ,(make-s1 :foo `#((a b c ,s d))) z)))
  93
  94 ;;; Sample output:
  95 ;;; Path to "hi":
  96 ;;;  6       1000209AB3 [   1] a symbol-table
  97 ;;;  1       10048F145F [  29] a (simple-vector 37)
  98 ;;;  1         503B403F [   2] COMMON-LISP-USER::*TOP*
  99 ;;;  0       1004B885B7 [   6] a cons = (P Q R ...) ; = (NTHCDR 6 object)
 100 ;;;  0       1004B88617 [   0] a cons = (# Z)
 101 ;;;  0       1004C1AA53 [   1] a s1
 102 ;;;  0       1004CBB93F [   2] a (simple-vector 1)
 103 ;;;  0       1004D28AE7 [   3] a cons = (A B C ...) ; = (NTHCDR 3 object)
 104 ;;;  0       1004D28B17 [   0] a cons = ("hi" D)
 105 (with-test (:name :traceroot-collapse-lists
 106                   :fails-on :mark-region-gc
 107                   :skipped-on :gc-stress)
 108   (let* ((string (with-output-to-string (*standard-output*)
 109                    (search-roots *string-hi* :print :verbose)))
 110          (lines (split-string string #\newline)))
 111     (assert
 112      (loop for line in lines
 113              thereis (search "[   6] a cons = (P Q R ...)" line)))
 114     (assert
 115      (loop for line in lines
 116              thereis (search "[   3] a cons = (A B C ...)" line)))))
 117
 118 (defun something ()
 119   (let ((a (make-symbol "x")))
 120     (gc) ; cause the symbol to be pinned
 121     (make-weak-pointer a)))
 122
 123 (with-test (:name :traceroot-old-pin-no-crash)
 124   (let ((wp (something)))
 125     (search-roots wp)
 126     (something)))
 127
 128 (defvar *foo*)
 129 (with-test (:name (sb-ext:search-roots :simple-fun)
 130                   :fails-on (and :mark-region-gc :darwin :arm64))
 131   ;; Tracing a path to a simple fun wasn't working at some point
 132   ;; because of failure to employ fun_code_header in the right place.
 133   (setq *foo* (compile nil '(lambda () 42)))
 134   (let ((wp (sb-ext:make-weak-pointer *foo*)))
 135     (assert (sb-ext:search-roots wp :criterion :oldest :print nil))))
 136
 137 (with-test (:name (sb-ext:search-roots :ignore-immediate))
 138   (sb-ext:search-roots (make-weak-pointer 48) :print nil))