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 (defun test1 (wp obj root)
  30   (let ((*fred* (list (make-foo :a (list (vector #xfeefa (list obj)))))))
  31     (setq obj nil) ; so OBJ is not found as a stack reference
  32     (ecase root
  33       (:tls (sb-ext::gc-and-search-roots wp))
  34       (:bindings ; bind *FRED* again so the old value is on the binding stack
  35        (let ((*fred* 1))
  36          (sb-ext::gc-and-search-roots wp)))
  37       (:stack
  38        ; put the OBJ back on the control stack
  39        ; and also ensure that *FRED* is not a root.
  40        (setq obj *fred* *fred* nil)
  41        (sb-ext::gc-and-search-roots wp)))))
  42
  43 (let ((wp (make-weak-pointer (list 1 2 3 4))))
  44   (test1 wp (weak-pointer-value wp) :stack)
  45   (test1 wp (weak-pointer-value wp) :tls)
  46   (test1 wp (weak-pointer-value wp) :bindings)
  47   nil)
  48 EOF
  49
  50 # In a typical test run the outputs would resemble as follows.
  51 # Each group of data contains (gen, class, descriptor, wordindex) where:
  52 #  * "gen"        = generation number, or 'S' for static
  53 #  * "class"      = name of an instance or the name of the widetag
  54 #  * "descriptor" = Lisp pointer to the containing object
  55 #  * "wordindex"  = index into that object from the GC's point-of-view.
  56 #
  57 # (1) {"main thread":C stack:fun=0x1002e347db=TEST1}->(g5,cons)0x1002e76fd7[0]
  58 #      ->(g5,FOO)0x1002c623d3[1]->(g5,cons)0x1002c632a7[0]
  59 #      ->(g5,simple vector)0x1002c63bbf[3]->(g5,cons)0x1002c64077[0]->0x1002c64807.
  60 # (2) {"main thread":TLS:*FRED*}->(g5,cons)0x1002c881f7[0]
  61 #      ->(g5,FOO)0x1002c8a673[1]->(g5,cons)0x1002c8b4d7[0]
  62 #      ->(g5,simple vector)0x1002c8bc2f[3]->(g5,cons)0x1002c8c457[0]->0x1002c8c927.
  63 # (3) {"main thread":bindings:*FRED*}->(g5,cons)0x1002c80107[0]
  64 #      ->(g5,FOO)0x1002c825d3[1]->(g5,cons)0x1002c83427[0]
  65 #      ->(g5,simple vector)0x1002c83b9f[3]->(g5,cons)0x1002c84377[0]->0x1002c848c7.
  66
  67 win1=`awk '/C stack.+TEST1.+cons.+FOO.+cons.+vector.+cons/{print "win\n"}' $tmpfilename`
  68 win2=`awk '/TLS:\*FRED/{print "win\n"}' $tmpfilename`
  69 win3=`awk '/bindings:\*FRED/{print "win\n"}' $tmpfilename`
  70
  71 test z$win1 = zwin -a z$win2 = zwin -a z$win3 = zwin && exit $EXIT_TEST_WIN