tests/make-thread.pure.lisp

   1 #+cheneygc (invoke-restart 'run-tests::skip-file)
   2
   3 (shadow "ASSERT-ERROR") ; conflict between SB-KERNEL:ASSERT-ERROR, ASSERTOID:ASSERT-ERROR
   4 (use-package "SB-KERNEL")
   5 (use-package "SB-THREAD")
   6 (import 'sb-sys::(int-sap sap-int sap+ vector-sap without-gcing))
   7 (import 'sb-int::(binding* descriptor-sap))
   8
   9 ;;; Test out-of-memory (or something) that goes wrong in pthread_create
  10 #+sb-thread ; no SB-THREAD::OS-THREAD-CREATE symbol if not
  11 (test-util:with-test (:name :failed-thread-creation)
  12   ;; This test needs to ensure that nothing is in *ALL-THREADS* to begin with.
  13   (sb-thread::%dispose-thread-structs)
  14   (let ((encapsulation
  15           (compile nil
  16                    '(lambda (realfun thread stack-base)
  17                      (if (sb-thread:thread-ephemeral-p thread)
  18                          (funcall realfun thread stack-base)
  19                          nil))))
  20         (success))
  21     (sb-int:encapsulate 'sb-thread::os-thread-create 'test encapsulation)
  22     (unwind-protect
  23          (handler-case (make-thread #'list :name "thisfails")
  24            (error (e)
  25              (setq success (search "Could not create new OS thread" (write-to-string e)))))
  26       (sb-int:unencapsulate 'sb-thread::os-thread-create 'test))
  27     (assert success))
  28   (let ((threads sb-thread::*starting-threads*))
  29     (when (find-if-not #'thread-ephemeral-p threads)
  30       (error "Should not see new thread in starting list: ~S" threads)))
  31   #-gc-stress
  32   (let ((threads (remove sb-thread::*initial-thread*
  33                          (sb-thread::avltree-list sb-thread::*all-threads*))))
  34     (when (find-if-not #'thread-ephemeral-p threads)
  35       (error "Should not see new thread in running list: ~S" threads))))
  36
  37 (defun actually-get-stack-roots (current-sp
  38                                  &key allwords (print t)
  39                                  &aux (current-sp (descriptor-sap current-sp))
  40                                       (roots))
  41   (declare (type (member nil t :everything) allwords))
  42   (without-gcing
  43     (binding* ((stack-low (get-lisp-obj-address sb-vm:*control-stack-start*))
  44                (stack-high (get-lisp-obj-address sb-vm:*control-stack-end*))
  45                ((nwords copy-from direction base)
  46                 #+c-stack-is-control-stack ; growth direction is always down
  47                 (values (ash (- stack-high (sap-int current-sp)) (- sb-vm:word-shift))
  48                         current-sp #\- "sp")
  49                 #-c-stack-is-control-stack ; growth direction is always up
  50                 (values (ash (- (sap-int current-sp) stack-low) (- sb-vm:word-shift))
  51                         (int-sap stack-low) #\+ "base"))
  52                (array (make-array nwords :element-type 'sb-ext:word)))
  53       (when print
  54         (format t "SP=~a~dw (range = ~x..~x)~%" direction nwords stack-low stack-high))
  55       (alien-funcall (extern-alien "memcpy" (function void system-area-pointer
  56                                                       system-area-pointer unsigned))
  57                      (vector-sap array) copy-from (* nwords sb-vm:n-word-bytes))
  58       (loop for i downfrom (1- nwords) to 0 by 1 do
  59         (let ((word (aref array i)))
  60           (when (or (/= word sb-vm:nil-value) allwords)
  61             (let ((baseptr (alien-funcall (extern-alien "search_all_gc_spaces" (function unsigned unsigned))
  62                                           word)))
  63               (cond ((/= baseptr 0) ; an object reference
  64                      (let ((obj (sb-vm::reconstitute-object (%make-lisp-obj baseptr))))
  65                        (when (code-component-p obj)
  66                          (cond
  67                           #+(or c-stack-is-control-stack arm64 riscv)
  68                           ((= (logand word sb-vm:lowtag-mask) sb-vm:fun-pointer-lowtag)
  69                            (dotimes (i (code-n-entries obj))
  70                              (when (= (get-lisp-obj-address (%code-entry-point obj i)) word)
  71                                (return (setq obj (%code-entry-point obj i))))))
  72                           #-(or c-stack-is-control-stack arm64 riscv) ; i.e. does this backend have LRAs
  73                           ((= (logand (sb-sys:sap-ref-word (int-sap (logandc2 word sb-vm:lowtag-mask)) 0)
  74                                       sb-vm:widetag-mask) sb-vm:return-pc-widetag)
  75                            (setq obj (%make-lisp-obj word)))))
  76                        ;; interior pointers to objects that contain instructions are OK,
  77                        ;; otherwise only correctly tagged pointers.
  78                        (when (or (typep obj '(or fdefn code-component funcallable-instance))
  79                                  (= (get-lisp-obj-address obj) word))
  80                          (push obj roots)
  81                          (when print
  82                            (format t "~x = ~a[~5d] = ~16x (~A) "
  83                                    (sap-int (sap+ copy-from (ash i sb-vm:word-shift)))
  84                                    base i word
  85                                    (or (generation-of obj) #\S)) ; S is for static
  86                            (let ((*print-pretty* nil))
  87                              (cond ((consp obj) (format t "a cons"))
  88                                    #+sb-fasteval
  89                                    ((typep obj 'sb-interpreter::sexpr) (format t "a sexpr"))
  90                                    ((arrayp obj) (format t "a ~s" (type-of obj)))
  91                                    #+c-stack-is-control-stack
  92                                    ((and (code-component-p obj)
  93                                          (>= word (sap-int (code-instructions obj))))
  94                                     (format t "PC in ~a" obj))
  95                                    (t (format t "~a" obj))))
  96                            (terpri)))))
  97                     ((and print
  98                           (or (eq allwords :everything) (and allwords (/= word 0))))
  99                      (format t "~x = ~a[~5d] = ~16x~%"
 100                              (sap-int (sap+ copy-from (ash i sb-vm:word-shift)))
 101                              base i word)))))))))
 102   (if print
 103       (format t "~D roots~%" (length roots))
 104       roots))
 105 (compile 'actually-get-stack-roots)
 106 (defun get-stack-roots (&rest rest)
 107   (apply #'actually-get-stack-roots (%make-lisp-obj (sap-int (current-sp))) rest))
 108
 109 (defstruct big-structure x)
 110 (defstruct other-big-structure x)
 111 (defun make-a-closure (arg options)
 112   (lambda (&optional (z 0) y)
 113     (declare (ignore y))
 114     (test-util:opaque-identity
 115      (format nil "Ahoy-hoy! ~d~%" (+ (big-structure-x arg) z)))
 116     (apply #'get-stack-roots options)))
 117 (defun tryit (&rest options)
 118   (let ((thread
 119           (make-thread (make-a-closure (make-big-structure :x 0) options)
 120                        :arguments (list 1 (make-other-big-structure)))))
 121     ;; Sometimes the THREAD instance shows up in the list of objects
 122     ;; on the stack, sometimes it doesn't. This is annoying, but work around it.
 123     (remove thread (join-thread thread))))
 124
 125 (defun make-a-closure-nontail (arg)
 126   (lambda (&optional (z 0) y)
 127     (declare (ignore y))
 128     (get-stack-roots)
 129     (test-util:opaque-identity
 130      (format nil "Ahoy-hoy! ~d~%" (+ (big-structure-x arg) z)))
 131     1))
 132 (defun tryit-nontail ()
 133   (join-thread
 134    (make-thread (make-a-closure-nontail (make-big-structure :x 0))
 135                 :arguments (list 1 (make-other-big-structure)))))
 136
 137 ;;; Test that reusing memory from an exited thread does not point to junk.
 138 ;;; In fact, assert something stronger: there are no young objects
 139 ;;; between the current SP and end of stack.
 140 (test-util:with-test (:name :expected-gc-roots
 141                       :skipped-on (or :interpreter (not :sb-thread)
 142                                       :debug-gc-barriers))
 143   (let ((list
 144           (delete-if (lambda (x)
 145                        (or (eq x #'actually-get-stack-roots)
 146                            (eq x (sb-kernel:fun-code-header #'actually-get-stack-roots))))
 147                      (tryit :print nil))))
 148     ;; should be not many things pointed to by the stack
 149     (assert (< (length list) #+x86    38   ; more junk, I don't know why
 150                              #+x86-64 30   ; less junk, I don't know why
 151                              #-(or x86 x86-64) 44)) ; even more junk
 152     ;; Either no objects are in GC generation 0, or all are, depending on
 153     ;; whether CORE_PAGE_GENERATION has been set to 0 for testing.
 154     (let ((n-objects-in-g0 (count 0 list :key #'sb-kernel:generation-of)))
 155       (assert (or (= n-objects-in-g0 0)
 156                   (= n-objects-in-g0 (length list)))))))
 157
 158 ;; lp#1595699
 159 (test-util:with-test (:name :start-thread-in-without-gcing
 160                       :skipped-on (not :sb-thread))
 161   (assert (eq (join-thread
 162                (without-gcing
 163                    (make-thread (lambda () 'hi))))
 164               'hi)))