mirror of
git://git.code.sf.net/p/sbcl/sbcl
synced 2026-09-10 07:26:40 -04:00
161 lines
6.2 KiB
Common Lisp
161 lines
6.2 KiB
Common Lisp
;;;; tests related to 'traceroot'
|
|
;;;;
|
|
;;;; This software is part of the SBCL system. See the README file for
|
|
;;;; more information.
|
|
;;;;
|
|
;;;; While most of SBCL is derived from the CMU CL system, the test
|
|
;;;; files (like this one) were written from scratch after the fork
|
|
;;;; from CMU CL.
|
|
;;;;
|
|
;;;; This software is in the public domain and is provided with
|
|
;;;; absolutely no warranty. See the COPYING and CREDITS files for
|
|
;;;; more information.
|
|
|
|
;;;; These tests should pass for all platforms, but they're not
|
|
;;;; and I don't care too much why, since the functionality still works.
|
|
;;;; It's just that sometimes we get :PINNED as a root instead of
|
|
;;;; the expected reference to the one and only thread.
|
|
;;;; And also sb-safepoint gets a crash in C.
|
|
#-(and (or arm64 ppc64 x86-64) sb-thread (not sb-safepoint) (not gc-stress))
|
|
(invoke-restart 'run-tests::skip-file)
|
|
|
|
(setq sb-ext:*evaluator-mode* :compile)
|
|
(defvar *fred*)
|
|
(defstruct foo a)
|
|
|
|
(defun scrubstack ()
|
|
(sb-int:dx-let ((b (make-array 20))) (eval b))
|
|
(sb-sys:scrub-control-stack))
|
|
|
|
(defun test1 (wp obj root)
|
|
(let ((*fred* (list (make-foo :a (list (vector #xfeefa (list obj)))))))
|
|
(setq obj nil) ; so OBJ is not found as a stack reference
|
|
(let ((paths
|
|
(ecase root
|
|
(:tls
|
|
(scrubstack)
|
|
(sb-ext:search-roots wp :criterion :oldest :print nil))
|
|
(:bindings ; bind *FRED* again so the old value is on the binding stack
|
|
(let ((*fred* 1))
|
|
(scrubstack)
|
|
(sb-ext:search-roots wp :criterion :oldest :print nil)))
|
|
(:stack
|
|
; put the OBJ back on the control stack
|
|
; and also ensure that *FRED* is not a root.
|
|
(setq obj *fred* *fred* nil)
|
|
(scrubstack)
|
|
(sb-ext:search-roots wp :criterion :oldest :print nil)))))
|
|
(assert paths)
|
|
(let* ((path (cdar paths))
|
|
(root (car path)))
|
|
(assert (stringp (car root)))
|
|
(case root
|
|
(:stack
|
|
(assert (typep (cdr root) '(cons system-area-pointer))))
|
|
(:tls
|
|
(assert (typep (cdr root) '(cons (eql *fred*) (cons t)))))
|
|
(:bindings
|
|
(assert (typep (cdr path) '(cons (eql *fred*) (cons nil))))))))))
|
|
|
|
(with-test (:name (sb-ext:search-roots :stack-indirect)
|
|
:fails-on :mark-region-gc
|
|
:fails-on :sunos)
|
|
(let ((wp (make-weak-pointer (list 1 2 3 4))))
|
|
(test1 wp (weak-pointer-value wp) :stack)
|
|
(test1 wp (weak-pointer-value wp) :tls)
|
|
(test1 wp (weak-pointer-value wp) :bindings)
|
|
nil))
|
|
|
|
(defun f0 ()
|
|
(let* ((c (cons 1 2))
|
|
(wp (make-weak-pointer c)))
|
|
(let ((paths (sb-ext:search-roots wp :criterion :static :print nil)))
|
|
(assert paths)
|
|
(let* ((path (car paths))
|
|
(nodes (cdr path)))
|
|
(assert (and (sb-int:singleton-p nodes)
|
|
(string= "main thread" (caar nodes))))))
|
|
c))
|
|
(with-test (:name (sb-ext:search-roots :stack-direct)
|
|
:fails-on :sunos)
|
|
(f0))
|
|
|
|
;;; Employ circumlocution so the file loader doesn't hold on to a string "hi"
|
|
(defvar *string-hi*)
|
|
(defstruct s1 foo)
|
|
;;; Ensure that *STRING-HI* does not get smashed before we ever got to both
|
|
;;; DEFVARS (if GC executed in between the two) but that we don't hold a reference
|
|
;;; from the stack. (which we can't really guarantee though)
|
|
(defparameter *top*
|
|
(let ((s (concatenate 'string "h" "i")))
|
|
(setq *string-hi* (make-weak-pointer s))
|
|
`(p q r w x y ,(make-s1 :foo `#((a b c ,s d))) z)))
|
|
|
|
;;; Sample output:
|
|
;;; Path to "hi":
|
|
;;; 6 1000209AB3 [ 1] a symbol-table
|
|
;;; 1 10048F145F [ 29] a (simple-vector 37)
|
|
;;; 1 503B403F [ 2] COMMON-LISP-USER::*TOP*
|
|
;;; 0 1004B885B7 [ 6] a cons = (P Q R ...) ; = (NTHCDR 6 object)
|
|
;;; 0 1004B88617 [ 0] a cons = (# Z)
|
|
;;; 0 1004C1AA53 [ 1] a s1
|
|
;;; 0 1004CBB93F [ 2] a (simple-vector 1)
|
|
;;; 0 1004D28AE7 [ 3] a cons = (A B C ...) ; = (NTHCDR 3 object)
|
|
;;; 0 1004D28B17 [ 0] a cons = ("hi" D)
|
|
(with-test (:name :traceroot-collapse-lists
|
|
:fails-on :mark-region-gc
|
|
:skipped-on :gc-stress)
|
|
(let* ((string (with-output-to-string (*standard-output*)
|
|
(search-roots *string-hi* :print :verbose)))
|
|
(lines (split-string string #\newline)))
|
|
(assert
|
|
(loop for line in lines
|
|
thereis (search "[ 6] a cons = (P Q R ...)" line)))
|
|
(assert
|
|
(loop for line in lines
|
|
thereis (search "[ 3] a cons = (A B C ...)" line)))))
|
|
|
|
(defun something ()
|
|
(let ((a (make-symbol "x")))
|
|
(gc) ; cause the symbol to be pinned
|
|
(make-weak-pointer a)))
|
|
|
|
(with-test (:name :traceroot-old-pin-no-crash)
|
|
(let ((wp (something)))
|
|
(search-roots wp)
|
|
(something)))
|
|
|
|
(defvar *foo*)
|
|
(with-test (:name (sb-ext:search-roots :simple-fun)
|
|
:fails-on (and :mark-region-gc :arm64))
|
|
;; Tracing a path to a simple fun wasn't working at some point
|
|
;; because of failure to employ fun_code_header in the right place.
|
|
(setq *foo* (compile nil '(lambda () 42)))
|
|
(let ((wp (sb-ext:make-weak-pointer *foo*)))
|
|
(assert (sb-ext:search-roots wp :criterion :oldest :print nil))))
|
|
|
|
(with-test (:name (sb-ext:search-roots :ignore-immediate))
|
|
(sb-ext:search-roots (make-weak-pointer 48) :print nil))
|
|
|
|
;;; Try very hard to make a string reachable only through the name of a symbol.
|
|
;;; To achieve that, the symbol has to be in a different package from *PACKAGE*.
|
|
;;; And it has to be interned because if it isn't, then its package ID bits are 0
|
|
;;; so it doesn't constitute a good test of decoding the name field.
|
|
(defvar *stringweakptr*
|
|
#+sb-thread
|
|
(sb-thread:join-thread
|
|
(sb-thread:make-thread
|
|
(lambda ()
|
|
(let* ((p (make-package "DERP"))
|
|
(*package* p))
|
|
(make-weak-pointer (symbol-name (read-from-string "FOOLZ"))))))))
|
|
|
|
(with-test (:name :search-for-symbol-name
|
|
:fails-on :mark-region-gc)
|
|
(when (boundp '*stringweakptr*)
|
|
(let ((path
|
|
(with-output-to-string (*standard-output*)
|
|
(search-roots *stringweakptr*))))
|
|
;; firstly it just shouldn't crash, secondly we should find an answer
|
|
(assert (search "SB-IMPL::SYMBOL-TABLE" path)))))
|