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 #+gencgc 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
  57 (defun f0 ()
  58   (let* ((c (cons 1 2))
  59          (wp (make-weak-pointer c)))
  60     (sb-ext::gc-and-search-roots wp :static)
  61     c))
  62 (f0)
  63 EOF
  64
  65 # In a typical test run the outputs would resemble as follows.
  66 # Each group of data contains (gen, class, descriptor, wordindex) where:
  67 #  * "gen"        = generation number, or 'S' for static
  68 #  * "class"      = name of an instance or the name of the widetag
  69 #  * "descriptor" = Lisp pointer to the containing object
  70 #  * "wordindex"  = index into that object from the GC's point-of-view.
  71 #
  72 # (1) {"main thread":C stack:fun=0x1002e347db=TEST1}->(g5,cons)0x1002e76fd7[0]
  73 #      ->(g5,FOO)0x1002c623d3[1]->(g5,cons)0x1002c632a7[0]
  74 #      ->(g5,simple vector)0x1002c63bbf[3]->(g5,cons)0x1002c64077[0]->0x1002c64807.
  75 # (2) {"main thread":TLS:*FRED*}->(g5,cons)0x1002c881f7[0]
  76 #      ->(g5,FOO)0x1002c8a673[1]->(g5,cons)0x1002c8b4d7[0]
  77 #      ->(g5,simple vector)0x1002c8bc2f[3]->(g5,cons)0x1002c8c457[0]->0x1002c8c927.
  78 # (3) {"main thread":bindings:*FRED*}->(g5,cons)0x1002c80107[0]
  79 #      ->(g5,FOO)0x1002c825d3[1]->(g5,cons)0x1002c83427[0]
  80 #      ->(g5,simple vector)0x1002c83b9f[3]->(g5,cons)0x1002c84377[0]->0x1002c848c7.
  81
  82 # Can find the function name only for x86
  83 func=`run_sbcl --eval '(princ (or #+(or x86 x86-64) "TEST1" ""))' --quit`
  84
  85 # Should be able to identify a specific Lisp thread
  86 thread=`run_sbcl --eval '(princ (or #+sb-thread "\"main thread\":TLS:"
  87                                     "COMMON-LISP-USER::"))' --quit`
  88
  89 t1=`awk 'NR==1 && /C stack.+'"${func}"'.+cons.+FOO.+cons.+vector.+cons/{print "PASS\n"}' $tmpfilename`
  90 t2=`awk 'NR==2 && /'"${thread}"'\*FRED/{print "PASS\n"}' $tmpfilename`
  91 t3=`awk 'NR==3 && /bindings:\*FRED/{print "PASS\n"}' $tmpfilename`
  92 t4=`awk 'NR==4 && /C stack.+->#x[^0]/{print "PASS\n"}' $tmpfilename`
  93
  94 test z$t1 = zPASS -a z$t2 = zPASS -a z$t3 = zPASS -a z$t4 = zPASS && exit $EXIT_TEST_WIN