tests/traceroot.test.sh

   1 #!/bin/sh
   2
   3 # tests related to 'traceroot'
   4
   5 # This software is part of the SBCL system. See the README file for
   6 # more information.
   7 #
   8 # While most of SBCL is derived from the CMU CL system, the test
   9 # files (like this one) were written from scratch after the fork
  10 # from CMU CL.
  11 #
  12 # This software is in the public domain and is provided with
  13 # absolutely no warranty. See the COPYING and CREDITS files for
  14 # more information.
  15
  16 . ./subr.sh
  17
  18 use_test_subdirectory
  19
  20 run_sbcl --eval "(sb-ext:exit :code (or #+(and sb-thread sb-traceroot) 0 7))"
  21 test $? = 7 && exit $EXIT_TEST_WIN # Pass if feature is absent or not fully working
  22
  23 tmpfilename="$TEST_FILESTEM.out"
  24
  25 run_sbcl <<EOF >$tmpfilename
  26 (setq sb-ext:*evaluator-mode* :compile)
  27 (defvar *fred*)
  28 (defstruct foo a)
  29 ;; CLEARSTUFF zeroes out a bunch of words below the stack pointer,
  30 ;; in case OBJ was spilled to a stack slot that randomly is left untouched
  31 ;; afterward, thereby making the test spuriously fail.
  32 (defun clearstuff () (sb-int:dx-let ((b (make-array 20))) (eval b)))
  33 (defun test1 (wp obj root)
  34   (let ((*fred* (list (make-foo :a (list (vector #xfeefa (list obj)))))))
  35     (setq obj nil) ; so OBJ is not found as a stack reference
  36     (ecase root
  37       (:tls
  38        (clearstuff)
  39        (sb-ext::gc-and-search-roots wp))
  40       (:bindings ; bind *FRED* again so the old value is on the binding stack
  41        (let ((*fred* 1))
  42          (clearstuff)
  43          (sb-ext::gc-and-search-roots wp)))
  44       (:stack
  45        ; put the OBJ back on the control stack
  46        ; and also ensure that *FRED* is not a root.
  47        (setq obj *fred* *fred* nil)
  48        (clearstuff)
  49        (sb-ext::gc-and-search-roots wp)))))
  50
  51 (let ((wp (make-weak-pointer (list 1 2 3 4))))
  52   (test1 wp (weak-pointer-value wp) :stack)
  53   (test1 wp (weak-pointer-value wp) :tls)
  54   (test1 wp (weak-pointer-value wp) :bindings)
  55   nil)
  56 EOF
  57
  58 # In a typical test run the outputs would resemble as follows.
  59 # Each group of data contains (gen, class, descriptor, wordindex) where:
  60 #  * "gen"        = generation number, or 'S' for static
  61 #  * "class"      = name of an instance or the name of the widetag
  62 #  * "descriptor" = Lisp pointer to the containing object
  63 #  * "wordindex"  = index into that object from the GC's point-of-view.
  64 #
  65 # (1) {"main thread":C stack:fun=0x1002e347db=TEST1}->(g5,cons)0x1002e76fd7[0]
  66 #      ->(g5,FOO)0x1002c623d3[1]->(g5,cons)0x1002c632a7[0]
  67 #      ->(g5,simple vector)0x1002c63bbf[3]->(g5,cons)0x1002c64077[0]->0x1002c64807.
  68 # (2) {"main thread":TLS:*FRED*}->(g5,cons)0x1002c881f7[0]
  69 #      ->(g5,FOO)0x1002c8a673[1]->(g5,cons)0x1002c8b4d7[0]
  70 #      ->(g5,simple vector)0x1002c8bc2f[3]->(g5,cons)0x1002c8c457[0]->0x1002c8c927.
  71 # (3) {"main thread":bindings:*FRED*}->(g5,cons)0x1002c80107[0]
  72 #      ->(g5,FOO)0x1002c825d3[1]->(g5,cons)0x1002c83427[0]
  73 #      ->(g5,simple vector)0x1002c83b9f[3]->(g5,cons)0x1002c84377[0]->0x1002c848c7.
  74
  75 # Should be able to identify a specific Lisp thread
  76 # May or may not work for other than x86-64
  77 thread=`run_sbcl --eval '(or #+(and sb-thread x86-64) (princ "\"main thread\":"))' --quit`
  78
  79 win1=`awk '/C stack.+TEST1.+cons.+FOO.+cons.+vector.+cons/{print "win\n"}' $tmpfilename`
  80 win2=`awk '/'"${thread}"'TLS:\*FRED/{print "win\n"}' $tmpfilename`
  81 win3=`awk '/bindings:\*FRED/{print "win\n"}' $tmpfilename`
  82
  83 test z$win1 = zwin -a z$win2 = zwin -a z$win3 = zwin && exit $EXIT_TEST_WIN