common-lisp/sbcl.sbcl
1
0
Fork 0
mirror of git://git.code.sf.net/p/sbcl/sbcl synced 2026-09-10 07:26:40 -04:00
Code Issues Actions 8 Packages Projects Releases Wiki Activity

Speed up MAKE-THREAD for x86[-64] on linux

Browse source 
* Remove the create_thread_lock and thread setup semaphore. The start function
  is handed off in a GC-safe way and the creating thread is allowed to continue
  as soon as pthread_create() returns.

* Retain the memory from up to 2 exited threads for reuse by new threads.
  This is not shared with the FOREIGN-THREAD memory pool, but perhaps could be.

While this adds more conditionalization to both C and Lisp, it should be
adaptable to OS_THREAD_STACK so that ultimately we can have only one way
of performing post-mortem freeing instead of three.

Benchmarks show about 6x to 7x faster lisp thread creation.

Incidentally this fixes lp#1595699.
This commit is contained in:
Douglas Katzman 2020-07-20 21:42:35 -04:00
parent 0dfedfcfea
commit 88b98e2d20
16 changed files with 787 additions and 64 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

6
contrib/sb-posix/interface.lisp
View file

@ -344,7 +344,13 @@ not supported."
(let ()
#+sb-thread
(sb-impl::finalizer-thread-stop)
;; Acquiring sb-thread::*make-thread-lock* prevents creation
;; of new threads.
(sb-thread::with-system-mutex (sb-thread::*make-thread-lock*)
;; Dead threads aren't pruned from *ALL-THREADS* until the Pthread join.
;; Do that now so that the forked process has only the main thread
;; in *ALL-THREADS* and nothing in *JOINABLE-THREADS*.
#+pauseless-threadstart (sb-thread::join-pthread-joinables #'identity)
(when (let ((avltree sb-thread::*all-threads*))
(or (sb-thread::avlnode-left avltree)
(sb-thread::avlnode-right avltree)))

143
doc/internals-notes/make-thread-bench Normal file
View file

@ -0,0 +1,143 @@
(defglobal *counter* 0)
(declaim (fixnum *counter*))
;; how many threads to make, not all at once, of course
(defparameter howmany-threads 20000)
(defun thread-lambda ()
(atomic-incf *counter*))
(defun test1 (&optional (n howmany-threads))
(setq *counter* 0)
(dotimes (i n)
(sb-thread:join-thread (sb-thread:make-thread #'thread-lambda)))
(assert (= *counter* n)))
(defun test2 (&optional (n howmany-threads))
(setq *counter* 0)
(let (prev-thread)
(dotimes (i n)
;; while starting the new thread, join the previously made.
(let ((new-thread (sb-thread:make-thread #'thread-lambda)))
(when prev-thread
(sb-thread:join-thread prev-thread))
(setq prev-thread new-thread)))
(sb-thread:join-thread prev-thread))
(assert (= *counter* n)))
(defun test3 (&optional (n howmany-threads))
(setq *counter* 0)
;; try making 10 at a time and waiting for those 10 before making more
(dotimes (i (/ n 10))
(let ((threads))
(dotimes (i 10)
(push (sb-thread:make-thread #'thread-lambda) threads))
(dolist (thread threads)
(sb-thread:join-thread thread))))
(assert (= *counter* n)))
Without :pauseless-threadstart
-------------------------------
$ perf stat ... --eval '(test1)' --quit
6,435.72 msec task-clock:u # 1.103 CPUs utilized
0 context-switches:u # 0.000 K/sec
0 cpu-migrations:u # 0.000 K/sec
219,735 page-faults:u # 0.034 M/sec
1,484,016,696 cycles:u # 0.231 GHz
17,008,247,359 stalled-cycles-frontend:u # 1146.10% frontend cycles idle
525,232,002 instructions:u # 0.35 insn per cycle
# 32.38 stalled cycles per insn
145,098,224 branches:u # 22.546 M/sec
4,045,481 branch-misses:u # 2.79% of all branches
5.834005191 seconds time elapsed
0.684522000 seconds user
6.391622000 seconds sys
$ perf stat ... --eval '(test2)' --quit
6,383.26 msec task-clock:u # 1.182 CPUs utilized
0 context-switches:u # 0.000 K/sec
0 cpu-migrations:u # 0.000 K/sec
220,625 page-faults:u # 0.035 M/sec
1,435,852,231 cycles:u # 0.225 GHz
16,839,228,290 stalled-cycles-frontend:u # 1172.77% frontend cycles idle
524,776,029 instructions:u # 0.37 insn per cycle
# 32.09 stalled cycles per insn
144,951,979 branches:u # 22.708 M/sec
4,018,908 branch-misses:u # 2.77% of all branches
5.401308431 seconds time elapsed
0.773771000 seconds user
6.235207000 seconds sys
$ perf stat ... --eval '(test3)' --quit
7,813.04 msec task-clock:u # 1.133 CPUs utilized
0 context-switches:u # 0.000 K/sec
0 cpu-migrations:u # 0.000 K/sec
131,699 page-faults:u # 0.017 M/sec
1,477,424,012 cycles:u # 0.189 GHz
20,769,787,623 stalled-cycles-frontend:u # 1405.81% frontend cycles idle
525,748,318 instructions:u # 0.36 insn per cycle
# 39.51 stalled cycles per insn
145,134,345 branches:u # 18.576 M/sec
4,412,369 branch-misses:u # 3.04% of all branches
6.894458409 seconds time elapsed
0.641120000 seconds user
7.864134000 seconds sys
Conclusion: approximately 300 microseconds to start a thread
With :pauseless-threadstart
----------------------------
$ perf stat ... --eval '(test1)' --quit
1,541.91 msec task-clock:u # 1.068 CPUs utilized
0 context-switches:u # 0.000 K/sec
0 cpu-migrations:u # 0.000 K/sec
633 page-faults:u # 0.411 K/sec
801,317,853 cycles:u # 0.520 GHz
3,751,130,586 stalled-cycles-frontend:u # 468.12% frontend cycles idle
352,170,311 instructions:u # 0.44 insn per cycle
# 10.65 stalled cycles per insn
81,884,155 branches:u # 53.106 M/sec
1,334,916 branch-misses:u # 1.63% of all branches
1.443664147 seconds time elapsed
0.425407000 seconds user
1.471034000 seconds sys
$ perf stat ... --eval '(test2)' --quit
1,249.01 msec task-clock:u # 1.550 CPUs utilized
0 context-switches:u # 0.000 K/sec
0 cpu-migrations:u # 0.000 K/sec
573 page-faults:u # 0.459 K/sec
668,480,325 cycles:u # 0.535 GHz
3,086,418,550 stalled-cycles-frontend:u # 461.71% frontend cycles idle
376,966,208 instructions:u # 0.56 insn per cycle
# 8.19 stalled cycles per insn
95,790,671 branches:u # 76.694 M/sec
918,120 branch-misses:u # 0.96% of all branches
0.805563424 seconds time elapsed
0.325539000 seconds user
1.162641000 seconds sys
$ perf stat ... --eval '(test3)' --quit
1,308.09 msec task-clock:u # 1.455 CPUs utilized
0 context-switches:u # 0.000 K/sec
0 cpu-migrations:u # 0.000 K/sec
4,838 page-faults:u # 0.004 M/sec
660,514,151 cycles:u # 0.505 GHz
3,230,465,234 stalled-cycles-frontend:u # 489.08% frontend cycles idle
364,307,811 instructions:u # 0.55 insn per cycle
# 8.87 stalled cycles per insn
92,966,084 branches:u # 71.070 M/sec
730,714 branch-misses:u # 0.79% of all branches
0.899161220 seconds time elapsed
0.339090000 seconds user
1.227741000 seconds sys
Conclusion: 40 to 100 microseconds to start a thread

13
src/code/alien-callback.lisp
View file

@ -312,5 +312,16 @@ the alien callback for that function with the given alien type."
(alien-funcall (extern-alien "release_all_threads_lock"
(function void)))
thread)))
#+pauseless-threadstart
(dx-let ((startup-info (vector nil ; trampoline is n/a
nil ; cell in *STARTING-THREADS* is n/a
#'sb-alien::enter-alien-callback
(list index return arguments)
nil nil))) ; sigmask + fpu state bits
(copy-primitive-thread-fields thread)
(setf (thread-startup-info thread) startup-info)
(update-all-threads (get-lisp-obj-address sb-vm:*control-stack-start*) thread)
(run))
#-pauseless-threadstart
(dx-let ((args (list index return arguments)))
(new-lisp-thread-trampoline thread nil #'sb-alien::enter-alien-callback args))))
(run thread nil #'sb-alien::enter-alien-callback args))))

12
src/code/avltree.lisp
View file

@ -153,6 +153,7 @@
(t tree)))
result)))
(export 'avltree-list)
(defun avltree-list (tree &optional (transducer #'avlnode-data))
(let (result)
(named-let recurse ((node tree))
@ -162,6 +163,17 @@
(recurse (avlnode-right node))))
result))
(defun avltree-filter (predicate tree)
(let (result)
(named-let recurse ((node tree))
(when node
(let ((value (funcall predicate node)))
(when value
(push value result)))
(recurse (avlnode-left node))
(recurse (avlnode-right node))))
result))
(defmethod print-object ((self avlnode) stream)
(write-string "#<avltree " stream)
(let ((ct (avl-count self)))

2
src/code/final.lisp
View file

@ -242,6 +242,8 @@ Examples:
(let ((cell (hash-table-culled-values hashtable)))
;; This is like atomic-pop, but its obtains the first cons cell
;; in the list, not the car of the first cons.
;; Possible TODO: when no other work remains, free the *JOINABLE-THREADS*,
;; though MAKE-THREAD and JOIN-THREAD do that also, so there's no memory leak.
(loop (unless cell (return-from scan-finalizers))
(let ((actual (cas (hash-table-culled-values hashtable)
cell (cdr cell))))

2
src/code/target-signal.lisp
View file

@ -130,7 +130,7 @@
(context (sap-ref-sap args sb-vm:n-word-bytes)))
(dx-flet ((callback ()
(funcall run-handler signal info context)))
(sb-thread::new-lisp-thread-trampoline thread nil #'callback nil))))
(sb-thread::run thread nil #'callback nil))))
;;;; default LISP signal handlers

408
src/code/target-thread.lisp
View file

@ -231,6 +231,18 @@ an error in that case."
;;; Keep an AVL tree of threads ordered by stack base address. NIL is the empty tree.
(sb-ext:define-load-time-global *all-threads* ())
;;; Ensure that THREAD is in *ALL-THREADS*.
(defmacro update-all-threads (stack-base thread)
`(let ((addr ,stack-base))
(barrier (:read))
(let ((old *all-threads*))
(loop
;; If ADDR exists, then we have a bug in the thread exit handler.
;; The workaround here would be to delete the old thread first,
;; but I'd rather find out about the bug than bury it.
(aver (not (avl-find addr old)))
(let ((new (avl-insert old addr ,thread)))
(when (eq old (setq old (sb-ext:cas *all-threads* old new))) (return)))))))
(defvar *default-alloc-signal* nil)
;;; *ALLOC-SIGNAL* is in PER-THREAD-C-INTERFACE-SYMBOLS. Hence it doesn't require
@ -247,7 +259,11 @@ created and old ones may exit at any time."
;; Of course by the time we're done collecting nodes, the tree can have
;; been replaced by a different tree.
(barrier (:read))
(avltree-list *all-threads*))
(avltree-filter (lambda (node)
(let ((thread (avlnode-data node)))
(when (= (thread-%visible thread) 1)
thread)))
*all-threads*))
;;; used by debug-int.lisp to access interrupt contexts
@ -366,6 +382,12 @@ See also: RETURN-FROM-THREAD and SB-EXT:EXIT."
;;;; Aliens, low level stuff
;;; *STARTING-THREADS* receives special treatment by the garbage collector.
;;; The contents of it are pinned (in that respect it is like *PINNED-OBJECTS*)
;;; but also the STARTUP-INFO of each thread is pinned.
(sb-ext:define-load-time-global *starting-threads* nil)
(declaim (list *starting-threads*)) ; list of threads
#+(or sb-safepoint sb-thruption)
(define-alien-routine "wake_thread"
int
@ -373,9 +395,6 @@ See also: RETURN-FROM-THREAD and SB-EXT:EXIT."
#+sb-thread
(progn
(define-alien-routine ("create_thread" %create-thread)
unsigned (lisp-fun-address unsigned))
(declaim (inline %block-deferrable-signals))
(define-alien-routine ("block_deferrable_signals" %block-deferrable-signals)
void
@ -1367,7 +1386,7 @@ on this semaphore, then N of them is woken up."
(setf *session* (new-session *current-thread*))
(/show0 "Exiting INIT-JOB-CONTROL"))
(defun %delete-thread-from-session (thread session)
(defun %delete-thread-from-session (thread &aux (session *session*))
(with-session-lock (session)
;; One of two things about THREAD must be true, either:
;; - it was transferred from SESSION-NEW-ENROLLEES to SESSION-THREADS
@ -1386,7 +1405,7 @@ on this semaphore, then N of them is woken up."
(condition-broadcast (session-interactive-threads-queue session))))))
(defun call-with-new-session (fn)
(%delete-thread-from-session *current-thread* *session*)
(%delete-thread-from-session *current-thread*)
(let ((*session* (new-session *current-thread*)))
(funcall fn)))
@ -1400,10 +1419,11 @@ on this semaphore, then N of them is woken up."
`(with-system-mutex ((thread-interruptions-lock ,thread))
,@body))
#+sb-thread
(progn
;;; Remove thread from its session, if it has one, and from *all-threads*.
;;; Also clobber the pointer to the primitive thread
;;; which makes THREAD-ALIVE-P return false hereafter.
#+sb-thread
(defmacro handle-thread-exit ()
'(progn
(/show0 "HANDLING THREAD EXIT")
@ -1411,7 +1431,16 @@ on this semaphore, then N of them is woken up."
(%exit))
;; Lisp-side cleanup
(let ((thread *current-thread*))
;; This AVER failed when I messed up deletion from *STARTING-THREADS*.
;; That in turn caused a failure in GC because a fixnum is not a legal value
;; for the startup info when observed by GC.
#+pauseless-threadstart (aver (not (memq thread *starting-threads*)))
;; Stash the primitive thread SAP for reuse, but clobber the slot.
;; This makes ALIVE-P return NIL.
(with-interruptions-lock (thread)
(when (thread-result-lock thread) ; ordinary lisp thread, not FOREIGN-THREAD
(setf (thread-startup-info thread) ; use the "funny fixnum" representation
(%make-lisp-obj (thread-primitive-thread thread))))
;; The memory range can exist without a pthread running yet, but the pthread
;; can't exist without the memory range. By clobbering this SAP here,
;; it is safe to manipulate the memory and/or the pthread from another thread
@ -1422,14 +1451,34 @@ on this semaphore, then N of them is woken up."
;; we'd just waste time moving the thread into SESSION-THREADS (if it wasn't there)
;; only to remove it right away.
(when *session*
(%delete-thread-from-session thread *session*))
(barrier (:read))
(let ((old *all-threads*))
(loop
(let ((new (avl-delete (get-lisp-obj-address sb-vm:*control-stack-start*)
old)))
(when (eq old (setq old (sb-ext:cas *all-threads* old new)))
(return))))))))
(%delete-thread-from-session thread))
(cond
#+pauseless-threadstart ; If possible, logically remove from *ALL-THREADS*
((thread-result-lock thread)
;; Tree pruning is the responsibility of thread creators, not dying threads.
;; Creators have to manipulate the tree anyway, and they need access to the old
;; structure to grab the memory.
(let ((old (sb-ext:cas (thread-%visible thread) 1 -1)))
;; now (LIST-ALL-THREADS) won't see it
(aver (eql old 1)))
(sb-ext:atomic-push thread *joinable-threads*))
(t ; otherwise, physically remove from *ALL-THREADS*
;; With #+pauseless-threadstart, this occurs for FOREIGN-THREAD because
;; the memory allocation/deallocation is handled in C.
;; I would like to combine the recycle bin for foreign and lisp threads though.
(delete-from-all-threads
(get-lisp-obj-address sb-vm:*control-stack-start*)))))))
;;; The "funny fixnum" address format would do no good - AVL-FIND and AVL-DELETE
;;; expect normal happy lisp integers, even if a bignum.
(defun delete-from-all-threads (addr)
(barrier (:read))
(let ((old *all-threads*))
(loop
(aver (avl-find addr old))
(let ((new (avl-delete addr old)))
(when (eq old (setq old (sb-ext:cas *all-threads* old new)))
(return)))))))
(defvar sb-ext:*invoke-debugger-hook* nil
"This is either NIL or a designator for a function of two arguments,
@ -1610,26 +1659,179 @@ session."
;;;; The beef
#+pauseless-threadstart ; new way
(progn
;;; Return T if the thread was created
(defun pthread-create (thread stack-base)
(aver (memq thread *starting-threads*))
(let ((attr (foreign-symbol-sap "new_lisp_thread_attr" t)))
(and (= 0 (alien-funcall
(extern-alien "pthread_attr_setstack"
(function int system-area-pointer unsigned unsigned))
attr stack-base (extern-alien "thread_control_stack_size" unsigned)))
(with-pinned-objects (thread)
(= 0 (alien-funcall
(extern-alien "pthread_create"
(function int system-area-pointer system-area-pointer
system-area-pointer unsigned))
(struct-slot-sap thread thread os-thread)
attr
(foreign-symbol-sap "new_thread_trampoline")
(logandc2 (get-lisp-obj-address thread) sb-vm:lowtag-mask)))))))
(defmacro free-thread-struct (memory)
`(alien-funcall (extern-alien "free_thread_struct" (function void system-area-pointer))
,memory))
(defun primitive-join (thread dispose)
;; It's safe to read from the other thread's memory, because the current thread
;; has ownership of that memory now. And we can't call this on a FOREIGN-THREAD.
(let ((c-thread (descriptor-sap (thread-startup-info thread))))
(setf (thread-startup-info thread) 0)
;; Clean up *ALL-THREADS*
(delete-from-all-threads
(sap-ref-word c-thread (ash sb-vm::thread-control-stack-start-slot sb-vm:word-shift)))
;; Free the pthread resources
(let ((posix-thread (thread-os-thread thread)))
(alien-funcall (extern-alien "pthread_join" (function int unsigned unsigned))
posix-thread 0) ; no result pointer
(setf (thread-os-thread thread) 0))
(cond (dispose
(free-thread-struct c-thread)
nil)
(t ; Return the originally mapped address
(sap-ref-sap c-thread (ash sb-vm::thread-os-address-slot sb-vm:word-shift))))))
;;; *JOINABLE-THREADS* is a list of THREAD instances used only if #+pauseless-threadstart
;;; I had attempted to construct the list using the thread's memory to create cons
;;; cells but that turned out to be flawed- the cells must be freshly heap-allocated,
;;; because ATOMIC-POP is vulnerable to the A/B/A problem if cells are reused.
;;; Example: initial state: *JOINABLE-THREADS* -> node1 -> node2 -> node3.
;;; After reading *JOINABLE-THREADS* we want to CAS it to node2.
;;; If, after reading the variable, all of node1, node2, and node3 are popped
;;; by another thread, and then node1 is reused, and made to point to node4,
;;; then the new state is: *JOINABLE-THREADS* -> node1 -> node4
;;; which looks like CAS(*joinable-threads*, node1, node2) should succeed,
;;; but it should not. The LL/SC model would detect that, but CAS can not.
;;;
;;; A thread is pushed into *JOINABLE-THREADS* while still using its lisp stack.
;;; This is fine, because the C code will perform a join, which will effectively
;;; wait until the lisp thread is off its stack. It won't have to wait long,
;;; because pushing into *JOINABLE-THREADS* is the last thing to happen in lisp.
;;; In theory we could support some mode of keeping the memory while joining
;;; the pthread, but we currently do not.
(sb-ext:define-load-time-global *joinable-threads* nil)
(declaim (list *joinable-threads*)) ; list of threads
;;; Helper for SB-POSIX:FORK so that the child starts with no joinable threads.
;;; It might work to just set *JOINABLE-THREADS* to NIL in the child, but it's better to prune
;;; the *ALL-THREADS* tree as well. Must be called with the *MAKE-THREAD-LOCK* held
;;; or interrupts inhibited or both.
;;; Heuristic decides when to stop trying to free. Passing in #'IDENTITY means that
;;; all joinables should be processed. Passing in #'CDR or #'CDDR returns early if there
;;; are not at least 1 or 2 threads respectively that could be joined.
(export 'join-pthread-joinables)
(defun join-pthread-joinables (heuristic)
(loop (unless (funcall heuristic *joinable-threads*) (return))
(let ((item (sb-ext:atomic-pop *joinable-threads*)))
(if item (primitive-join item t) (return)))))
;;; Allocate lisp thread memory, attempting first to join any exited
;;; threads, freeing their memory. Possibly reuse the memory from one of
;;; the exited threads,
;;; Why do it this way instead of having JOIN-THREAD just defer to pthread_join() ?
;;; Because the interface would be less lispy. e.g. what happens if you don't join
;;; a thread - do you leak the memory?; That's bad. GC doesn't clean up threads.
;;; It could if we used finalizers, but finalizers have an additional problem:
;;; if the user does call JOIN-THREAD then the finalizer should do nothing.
;;; But there's no "atomic pthread_join + cancel-finalization", short of blocking
;;; signals around the join perhaps.
;;; One more thing- it's illegal to pthread_join() a thread more than once,
;;; but we allow JOIN-THREAD more than one. I think that's a bug.
;;; Ours has the meaning of "get result if done, otherwise wait"
;;; which is not the same as deallocation of the thread's OS resources.
(defun allocate-thread-memory ()
(let ((reuse (let ((corpse (sb-ext:atomic-pop *joinable-threads*)))
(when corpse (primitive-join corpse nil)))))
;; If there is more than 1 more joinable, join all but 1.
;; Two threads could both find > 1 thread to join, and both do
;; a join, leaving 0 to join. That's ok.
(join-pthread-joinables #'cdr)
(let ((thread-sap (alien-funcall (extern-alien "alloc_thread_struct"
(function system-area-pointer
system-area-pointer unsigned))
(or reuse (int-sap 0))
sb-vm:no-tls-value-marker-widetag)))
(when (and (not reuse) (/= (sap-int thread-sap) 0))
;; these would have been done already if reusing the memory
;; of a completed thread.
(macrolet ((prot (fun)
`(alien-funcall (extern-alien ,fun (function void int
system-area-pointer))
1 thread-sap)))
(prot "protect_control_stack_guard_page")
(prot "protect_binding_stack_guard_page")
(prot "protect_alien_stack_guard_page")))
(unless (= (sap-int thread-sap) 0) thread-sap))))
(defun pthread-sigmask (how new old)
(alien-funcall (extern-alien "pthread_sigmask"
(function void int system-area-pointer system-area-pointer))
how
(cond ((system-area-pointer-p new) new)
(new (vector-sap new))
(t (int-sap 0)))
(if old (vector-sap old) (int-sap 0))))
(defmacro thread-trampoline-defining-macro (&body body) ; NEW WAY
`(defun run ()
(macrolet ((apply-real-function ()
'(apply (svref (thread-startup-info *current-thread*) 2)
(prog1 (svref (thread-startup-info *current-thread*) 3)
(setf (thread-startup-info *current-thread*) 0)))))
(flet ((unmask-signals ()
(let ((mask (svref (thread-startup-info *current-thread*) 4)))
(if mask
;; If the original mask (at thread creation time) was provided,
;; then restore exactly that mask.
(with-pinned-objects (mask)
(pthread-sigmask sb-unix::SIG_SETMASK mask nil))
;; Otherwise just do the usual thing
(sb-unix::unblock-deferrable-signals)))))
;; notinline keeps array off the call stack by getting it out of the curent frame
(declare (notinline unmask-signals))
(sb-ext:atomic-push *current-thread* (session-new-enrollees *session*))
;; Signals other than stop-for-GC are masked. The WITH/WITHOUT noise is
;; pure cargo-cultism. I have no idea how or why any of it works, but it's
;; basically the body of CALL-WITH-MUTEX, minus the actual GRAB-MUTEX which
;; has been done by the creating thread on behalf of the created thread,
;; unless the current thread is a FOREIGN-THREAD.
(without-interrupts
(unwind-protect (with-local-interrupts ,@body)
(let ((mutex (thread-result-lock *current-thread*)))
(when mutex (release-mutex mutex)))))))))
) ; end PROGN
#-pauseless-threadstart
(defmacro thread-trampoline-defining-macro (&body body) ; OLD WAY
`(defun run (thread setup-sem function arguments)
(macrolet ((unmask-signals () '(sb-unix::unblock-deferrable-signals))
(apply-real-function () '(apply function arguments)))
(copy-primitive-thread-fields thread)
(update-all-threads (get-lisp-obj-address sb-vm:*control-stack-start*) thread)
(sb-ext:atomic-push thread (session-new-enrollees *session*))
(when setup-sem
(signal-semaphore setup-sem)
;; setup-sem was dx-allocated, set it to NIL so that the
;; backtrace doesn't get confused
(setf setup-sem nil))
,@body)))
;;; All threads other than the initial thread start via this function.
#+sb-thread
(defun new-lisp-thread-trampoline (thread setup-sem real-function arguments)
(copy-primitive-thread-fields thread)
(let ((old *all-threads*))
(loop
(let ((addr (get-lisp-obj-address sb-vm:*control-stack-start*)))
;; If ADDR exists, then we have a bug in the thread exit handler.
;; The workaround here would be to delete the old thread first,
;; but I'd rather find out about the bug than bury it.
(aver (not (avl-find addr old)))
(let ((new (avl-insert old addr thread)))
(when (eq old (setq old (sb-ext:cas *all-threads* old new))) (return))))))
(sb-ext:atomic-push thread (session-new-enrollees *session*))
(when setup-sem
(signal-semaphore setup-sem)
;; setup-sem was dx-allocated, set it to NIL so that the
;; backtrace doesn't get confused
(setf setup-sem nil))
(thread-trampoline-defining-macro
;; Using handling-end-of-the-world would be a bit tricky
;; due to other catches and interrupts, so we essentially
;; re-implement it here. Once and only once more.
@ -1646,19 +1848,18 @@ session."
(without-interrupts
(unwind-protect
(with-local-interrupts
(sb-unix::unblock-deferrable-signals)
(setf (thread-result thread)
(prog1
(multiple-value-list
(unmask-signals)
(let ((list
(multiple-value-list
(unwind-protect
(catch '%return-from-thread
(sb-c::inspect-unwinding
(apply real-function arguments)
(apply-real-function)
#'sb-di::catch-runaway-unwind))
(when *exit-in-process*
(sb-impl::call-exit-hooks))))
#+sb-safepoint
(sb-kernel::gc-safepoint))))
(sb-impl::call-exit-hooks))))))
#+sb-safepoint (sb-kernel::gc-safepoint)
(setf (thread-result *current-thread*) list)))
;; we're going down, can't handle interrupts
;; sanely anymore. gc remains enabled.
(block-deferrable-signals)
@ -1692,20 +1893,20 @@ See also: RETURN-FROM-THREAD, ABORT-THREAD."
(arguments)
"Argument passed to ~S, ~S, is an improper list."
'make-thread arguments)
(run-thread (%make-thread name nil)
(coerce function 'function)
(ensure-list arguments))))
(start-thread (%make-thread name nil)
(coerce function 'function)
(ensure-list arguments))))
;;; System-internal use only
#+sb-thread
(defun make-ephemeral-thread (name function arguments)
(run-thread (%make-thread name t) function arguments))
(start-thread (%make-thread name t) function arguments))
;;; The purpose of splitting out RUN-THREAD from MAKE-THREAD is that when
;;; The purpose of splitting out START-THREAD from MAKE-THREAD is that when
;;; starting the finalizer thread, we might be able to do:
;;; (let ((thread (%make-thread "finalizer" t)))
;;; (when (cas *finalizer-thread* nil thread)
;;; (run-thread thread ...)
;;; (start-thread thread ...)
;;; which is possibly an improvement in two ways:
;;; (1) it ensures that there is no hidden state in the transition diagram
@ -1714,7 +1915,7 @@ See also: RETURN-FROM-THREAD, ABORT-THREAD."
;;; thread object published or not - and no "maybe starting" state.
;;; (2) imagine two threads, each of which actually GC'd - so the 'gc_happened'
;;; flag in gc-common.c is T for both - and each wants to start the finalizer.
;;; They both get all the way into NEW-LISP-THREAD-TRAMPOLINE, only for one
;;; They both get all the way into RUN only for one
;;; to lose the CAS on *FINALIZER-THREAD*. It's a lot of overhead to start
;;; a thread that does nothing and then exits.
;;;
@ -1722,8 +1923,102 @@ See also: RETURN-FROM-THREAD, ABORT-THREAD."
;;; get FINALIZER-THREAD-STOP _not_ to attempt to join a thread that has not
;;; yet sprung into being as an OS-level thread.
#+sb-thread
(defun run-thread (thread function arguments)
;;; This is the faster variant of RUN-THREAD that does not wait for the new
;;; thread to start executing before returning.
;;; Also the create_thread_lock is not used in C.
#+pauseless-threadstart
(defun start-thread (thread function arguments)
(let* ((trampoline
(lambda (arg)
;; If an error occurs prior to getting the thread into a consistent lisp state,
;; there's no chance of debugging anything anyway.
(declare (optimize (safety 0)))
(let ((new-thread
(%make-lisp-obj (logior (get-lisp-obj-address arg)
sb-vm:instance-pointer-lowtag))))
;; Now that this thread is known to GC, NEW-THREAD is either implicitly
;; pinned (on conservative gc) or movable. It can hance be deleted from
;; *STARTING-THREADS* list which occurs lazily on the next MAKE-THREAD.
;; To avoid unnecessary GC work meanwhile, smash the cell in *STARTING-THREADS*
;; that points to NEW-THREAD. That cell is pointed to by the startup-info.
(rplaca (svref (thread-startup-info new-thread) 1) 0)
(init-thread-local-storage new-thread) ; assign *CURRENT-THREAD*
;; Expose this thread in *ALL-THREADS*.
;; Why not set this before calling pthread_create() ? If it fails there should
;; be no transient effect on the list of all threads. But it's indeterminate
;; whether the creating or created thread will make progress first,
;; so they both do this assignment.
(sb-ext:cas (thread-%visible new-thread) 0 1))
(run)))
(saved-sigmask (make-array (* sb-unix::sizeof-sigset_t sb-vm:n-byte-bits)
:element-type 'bit :initial-element 0))
(created))
(declare (truly-dynamic-extent saved-sigmask))
;; Block deferrables to ensure that the new thread is unaffected by signals
;; before the various interrupt-related special vars are set up.
(with-pinned-objects (saved-sigmask)
(pthread-sigmask sb-unix::SIG_BLOCK (foreign-symbol-sap "deferrable_sigset" t)
saved-sigmask))
(binding* ((thread-sap (allocate-thread-memory) :EXIT-IF-NULL)
(stack-base
(sap-ref-word thread-sap
(ash sb-vm::thread-control-stack-start-slot sb-vm:word-shift)))
(sigmask
(if (position 1 saved-sigmask) ; if there are any signals masked
(copy-seq saved-sigmask) ; heap-allocate to pass to the new thread
nil)) ; otherwise, don't pass the saved mask
(cell (list thread))
(startup-info
(vector trampoline cell function arguments sigmask
#+darwin ; pass fp modes, clearing the accrued exception bits
(dpb 0 sb-vm:float-sticky-bits (sb-vm:floating-point-modes))
#-darwin 0))) ; otherwise, don't need to do that
(setf (thread-primitive-thread thread) (sap-int thread-sap)
(thread-startup-info thread) startup-info)
;; Grant ownership of THREAD's result lock to it now so that a THREAD-JOIN
;; right away can't prevent the kid from acquiring its own result lock.
;; (N.B.: Giving away mutex ownership is not something the public API allows)
(let ((m (thread-result-lock thread)))
#+sb-futex (setf (mutex-state m) 1)
(setf (mutex-%owner m) thread))
;; Add new thread to *ALL-THREADS* now so that if the creator asserts
;; something about "all" threads, it can find the new thread.
;; But there is a slight ploy involved: the thread does not appear in
;; (LIST-ALL-THREADS) until a POSIX thread is successfully started.
(setf (thread-%visible thread) 0)
(update-all-threads stack-base thread)
;; Absence of the startup semaphore notwithstanding, creation is synchronized
;; so that we can prevent new threads from starting, typically in SB-POSIX:FORK
;; or SAVE-LISP-AND-DIE.
;; The locks also guards access to *STARTING-THREADS* - a lockfree list wouldn't
;; improve concurrency, as long as creation is synchronized anyway.
(with-system-mutex (*make-thread-lock*)
;; Consing THREAD into *STARTING-THREADS* pins it as well as some elements
;; of startup-info. Consequently those objects can be safely manipulated
;; from C before inserting the thread into 'all_threads'.
;; Assuming that new threads are scheduled by the OS as fast as we can create
;; them, there should usually be only one item to delete from *STARTING-THREADS*.
(let ((old (delete 0 *starting-threads*)))
(setf *starting-threads* (rplacd cell old))
(setq created (pthread-create thread stack-base))
(cond (created ; Still holding the MAKE-THREAD-LOCK, expose thread in (LIST-ALL-THREADS).
;; On CPUs where CAS can spuriously fail, this probably needs to loop and retry.
;; It's ok if the thread changed 0 -> {1 | -1}, then failure here is correct.
(sb-ext:cas (thread-%visible thread) 0 1))
(t ; unlikely. Out of memory perhaps?
(setq *starting-threads* old)))))
(unless created ; Remove side-effects of trying to create
(delete-from-all-threads stack-base)
(free-thread-struct thread-sap)))
(with-pinned-objects (saved-sigmask)
(pthread-sigmask sb-unix::SIG_SETMASK saved-sigmask nil))
(if created thread (error "Could not create new OS thread."))))
#+(and sb-thread (not pauseless-threadstart))
(progn
(define-alien-routine ("create_thread" %create-thread)
unsigned (lisp-fun-address unsigned))
(defun start-thread (thread function arguments)
(declare (inline make-semaphore
make-waitqueue
make-mutex))
@ -1740,8 +2035,7 @@ See also: RETURN-FROM-THREAD, ABORT-THREAD."
;; ready to run GC. Be careful.
(init-thread-local-storage thread)
(with-mutex ((thread-result-lock thread))
(new-lisp-thread-trampoline thread setup-sem
function arguments))))
(run thread setup-sem function arguments))))
;; Holding mutexes or waiting on sempahores inside WITHOUT-GCING will lock up
(aver (not *gc-inhibit*))
;; Keep INITIAL-FUNCTION in the dynamic extent until the child
@ -1755,6 +2049,7 @@ See also: RETURN-FROM-THREAD, ABORT-THREAD."
(setf thread nil)
(wait-on-semaphore setup-sem)))))
(or thread (error "Could not create a new thread.")))
) ; end PROGN
(defun join-thread (thread &key (default nil defaultp) timeout)
"Suspend current thread until THREAD exits. Return the result values
@ -1782,6 +2077,15 @@ subject to change."
(when (eq thread *current-thread*)
(error 'join-thread-error :thread thread :problem :self-join))
#+pauseless-threadstart
(when (cddr *joinable-threads*) ; if strictly > 2 are joinable,
;; release C structures of previously exited threads. We could pthread_join()
;; all joinables while retaining the memory for a few, but I didn't want to
;; deal separately with the memory and the pthread - it's both or none.
;; And the pthread overhead is negligible in comparison to the 4MB
;; allocation that we make per thread.
(without-interrupts (join-pthread-joinables #'cddr)))
(let ((lock (thread-result-lock thread))
(got-it nil)
(problem :timeout))

8
src/code/thread-structs.lisp
View file

@ -72,6 +72,14 @@ in future versions."
;; Usually this is a fixed amount below PRIMITIVE-THREAD, but the exact offset
;; varies by build configuration, and if #+win32 it is not related in any way.
(stack-end 0 :type sb-vm:word)
;; At the beginning of the thread's life, this is a vector of data required
;; to start the user code. At the end, is it pointer to the 'struct thread'
;; so that it can be either freed or reused.
(startup-info 0 :type (or fixnum (simple-vector 6)))
;; Whether this thread should be returned in LIST-ALL-THREADS.
;; This is almost-but-not-quite the same as what formerly
;; might have been known as the %ALIVE-P flag.
(%visible 1 :type fixnum)
(interruptions nil :type list)
;; On succesful execution of the thread's lambda a list of values.
(result 0)

8
src/cold/shared.lisp
View file

@ -243,6 +243,12 @@
(gc (find-if (lambda (x) (member x '(:cheneygc :gencgc)))
target-feature-list))
(arch (target-platform-keyword target-feature-list)))
(let ((*readtable* *xc-readtable*)
(sb-xc:*features* target-feature-list))
(when (featurep '(:and :linux (:or :x86 :x86-64) :sb-thread
(:not (:or :sb-safepoint :sb-thruption))))
(format t "~&Adding :PAUSELESS-THREADSTART feature~%")
(push :pauseless-threadstart target-feature-list)))
(when (and (member :x86 target-feature-list)
(member :int4-breakpoints target-feature-list))
;; 0xCE is a perfectly good 32-bit instruction,
@ -287,6 +293,8 @@
(let ((feature-compatibility-tests
'(("(and sb-thread (not gencgc))"
":SB-THREAD requires :GENCGC")
("(and pauseless-threadstart (not sb-thread))"
":PAUSELESS-THREADSTART requires :SB-THREAD")
("(and sb-thread (not (or riscv ppc ppc64 x86 x86-64 arm64)))"
":SB-THREAD not supported on selected architecture")
("(and gencgc cheneygc)"

2
src/compiler/generic/parms.lisp
View file

@ -208,7 +208,7 @@
#-sb-thread *stepping*
;; threading support
#+sb-thread *free-tls-index*
#+sb-thread ,@'(sb-thread::*starting-threads* *free-tls-index*)
;; dynamic runtime linking support
#+linkage-table +required-foreign-symbols+

34
src/runtime/gencgc.c
View file

@ -3514,6 +3514,40 @@ garbage_collect_generation(generation_index_t generation, int raise)
}
#endif
// Thread creation optionally no longer synchronizes the creating and
// created thread. When synchronized, the parent thread is responsible
// for pinning the start function for handoff to the created thread.
// When not synchronized, The startup parameters are pinned via this list
// which will always be NIL if the feature is not enabled.
#ifdef STARTING_THREADS
lispobj pin_list = SYMBOL(STARTING_THREADS)->value;
for ( ; pin_list != NIL ; pin_list = CONS(pin_list)->cdr ) {
lispobj lispthread = CONS(pin_list)->car;
// It would be tempting to say that only the SB-THREAD:THREAD instance
// requires pinning - because right after we access it to extract the
// primitive thread, we link into all_threads - but it may be that the code
// emitted by the C compiler in new_thread_trampoline computes untagged pointers
// when accessing the vector and the start function, so those would not be
// seen as valid lisp pointers by the implicit pinning logic.
// And the precisely GC'd platforms would not pin anything from C code.
// The tests in 'threads.impure.lisp' are good at detecting omissions here.
if (lispthread) {
gc_assert(instancep(lispthread));
pin_exact_root(lispthread);
lispobj info = ((struct thread_instance*)
(lispthread-INSTANCE_POINTER_LOWTAG))->startup_info;
if (info) {
gc_assert(simple_vector_p(info));
gc_assert(VECTOR(info)->length >= make_fixnum(1));
lispobj fun = VECTOR(info)->data[0];
gc_assert(functionp(fun));
pin_exact_root(info);
pin_exact_root(fun);
}
}
}
#endif
if (gencgc_verbose > 1)
show_pinnedobj_count();

69
src/runtime/thread.c
View file

@ -61,7 +61,7 @@
#if defined(LISP_FEATURE_WIN32) || defined(OS_THREAD_STACK)
# define IMMEDIATE_POST_MORTEM
#else
static struct thread *postmortem_thread;
static __attribute__((unused)) struct thread *postmortem_thread;
#endif
#endif
@ -72,7 +72,7 @@ struct thread *all_threads;
#ifdef LISP_FEATURE_SB_THREAD
pthread_mutex_t all_threads_lock = PTHREAD_MUTEX_INITIALIZER;
static pthread_mutex_t create_thread_lock = PTHREAD_MUTEX_INITIALIZER;
static __attribute__((unused)) pthread_mutex_t create_thread_lock = PTHREAD_MUTEX_INITIALIZER;
#ifdef LISP_FEATURE_GCC_TLS
__thread struct thread *current_thread;
@ -198,11 +198,20 @@ static int sb_GetTID() { return syscall(SYS_gettid); }
#define sb_GetTID() 0
#endif
static struct thread *alloc_thread_struct(void*,lispobj);
// Only a single 'attributes' object is used if #+pauseless-threadstart.
// This is ok because creation is synchronized by *MAKE-THREAD-LOCK*.
#ifdef LISP_FEATURE_SB_THREAD
pthread_attr_t new_lisp_thread_attr;
#define init_shared_attr_object() (pthread_attr_init(&new_lisp_thread_attr)==0)
#else
#define init_shared_attr_object() (1)
#endif
struct thread *alloc_thread_struct(void*,lispobj);
void create_main_lisp_thread(lispobj function) {
struct thread *th = alloc_thread_struct(0, NO_TLS_VALUE_MARKER_WIDETAG);
if(!th || arch_os_thread_init(th)==0) lose("can't create initial thread");
if (!th || arch_os_thread_init(th)==0 || !init_shared_attr_object())
lose("can't create initial thread");
#if defined(LISP_FEATURE_SB_THREAD) && !defined(LISP_FEATURE_GCC_TLS)
pthread_key_create(&specials, 0);
#endif
@ -260,7 +269,7 @@ void create_main_lisp_thread(lispobj function) {
* not anymore, now that we properly call pthread_attr_destroy before
* freeing the stack. */
static void free_thread_struct(struct thread *th)
void free_thread_struct(struct thread *th)
{
#if defined(LISP_FEATURE_WIN32)
os_invalidate_free((os_vm_address_t) th->os_address, THREAD_STRUCT_SIZE);
@ -282,7 +291,7 @@ schedule_thread_post_mortem(struct thread *corpse)
free_thread_struct(corpse);
}
# else
# elif !defined LISP_FEATURE_PAUSELESS_THREADSTART
static void
perform_thread_post_mortem(struct thread *post_mortem)
@ -507,6 +516,37 @@ undo_init_new_thread(struct thread *th,
*/
void* new_thread_trampoline(void* arg)
{
#ifdef LISP_FEATURE_PAUSELESS_THREADSTART
// 'arg' is an untagged pointer to an instance of SB-THREAD:THREAD
// which is currently pinned via *STARTING-THREADS*
// In that structure, the STARTUP-INFO slot holds a simple-vector
// which is pinned, and element 0 of the vector is also pinned.
struct thread_instance *lispthread = arg;
struct thread* th = (void*)lispthread->primitive_thread; // Pinned
struct vector* startup_info = VECTOR(lispthread->startup_info); // Pinned
gc_assert(header_widetag(startup_info->header) == SIMPLE_VECTOR_WIDETAG);
lispobj startfun = startup_info->data[0]; // Pinned
gc_assert(functionp(startfun));
// Nothing at a higher address than &arg needs to be scanned for ambiguous roots.
// For x86 + linux this optimization skips over about 800 words in the stack scan,
// and for x86-64 it skip about 550 words as observed via:
// fprintf(stderr, "%d non-lisp stack words\n",
// (int)((lispobj*)th->control_stack_end - (lispobj*)&arg));
th->control_stack_end = (lispobj*)&arg;
lispthread->stack_end = (lispobj)th->control_stack_end;
th->os_kernel_tid = sb_GetTID();
init_new_thread(th, 0, 0, 0);
// Passing the untagged pointer ensures 2 things:
// - that the pinning mechanism works as designed, and not just by accident.
// - that the initial stack does not contain a lisp pointer after it is not needed.
// (a regression test asserts that not even a THREAD instance is on the stack)
long result = funcall1(startfun, (lispobj)lispthread);
// Close the GC region and unlink from all_threads
undo_init_new_thread(th, 0);
#else // !PAUSELESS_THREADSTART
struct thread *th = (struct thread *)arg;
th->os_kernel_tid = sb_GetTID();
int result;
@ -528,6 +568,7 @@ void* new_thread_trampoline(void* arg)
#ifndef OS_THREAD_STACK
schedule_thread_post_mortem(th);
#endif
#endif
FSHOW((stderr,"/exiting thread %p\n", thread_self()));
@ -797,7 +838,7 @@ void release_all_threads_lock()
* On sb-safepoint builds one page before the thread base is used for the foreign calls safepoint.
*/
static struct thread *
struct thread *
alloc_thread_struct(void* spaces, lispobj start_routine) {
#if defined(LISP_FEATURE_SB_THREAD) || defined(LISP_FEATURE_WIN32)
unsigned int i;
@ -997,6 +1038,8 @@ extern int pthread_attr_setstack (pthread_attr_t *__attr, void *__stackaddr,
size_t __stacksize);
#endif
#ifndef LISP_FEATURE_PAUSELESS_THREADSTART
/* Call pthread_create() and return 1 for success, 0 for failure */
boolean create_os_thread(struct thread *th,os_thread_t *kid_tid)
{
@ -1075,6 +1118,8 @@ os_thread_t create_thread(lispobj start_routine) {
return kid_tid;
}
#endif
/* stopping the world is a two-stage process. From this thread we signal
* all the others with SIG_STOP_FOR_GC. The handler for this signal does
* the usual pseudo-atomic checks (we don't want to stop a thread while
@ -1092,12 +1137,19 @@ void gc_stop_the_world()
{
struct thread *p,*th=arch_os_get_current_thread();
int status, lock_ret;
// There is no create_thread lock if pauseless start is enabled.
// And wouldn't the right fix for FreeBSD be to inhibit the stop-for-GC signal
// rather than acquire a lock? And why exactly there a deadlock ?
// That we don't endeavor to find these things out leads to never-ending
// accretion of dubious code that we'll not know when to remove.
#ifndef LISP_FEATURE_PAUSELESS_THREADSTART
/* KLUDGE: Stopping the thread during pthread_create() causes deadlock
* on FreeBSD. */
FSHOW_SIGNAL((stderr,"/gc_stop_the_world:waiting on create_thread_lock\n"));
lock_ret = pthread_mutex_lock(&create_thread_lock);
gc_assert(lock_ret == 0);
FSHOW_SIGNAL((stderr,"/gc_stop_the_world:got create_thread_lock\n"));
#endif
FSHOW_SIGNAL((stderr,"/gc_stop_the_world:waiting on lock\n"));
/* keep threads from starting while the world is stopped. */
lock_ret = pthread_mutex_lock(&all_threads_lock);
@ -1167,9 +1219,10 @@ void gc_start_the_world()
lock_ret = pthread_mutex_unlock(&all_threads_lock);
gc_assert(lock_ret == 0);
#ifndef LISP_FEATURE_PAUSELESS_THREADSTART
lock_ret = pthread_mutex_unlock(&create_thread_lock);
gc_assert(lock_ret == 0);
#endif
FSHOW_SIGNAL((stderr,"/gc_start_the_world:end\n"));
}

1
src/runtime/thread.h
View file

@ -18,6 +18,7 @@
#include "genesis/static-symbols.h"
#include "genesis/thread.h"
#include "genesis/thread-instance.h"
#include "genesis/fdefn.h"
#include "genesis/vector.h"
#include "interrupt.h"

9
tests/deadlock.impure.lisp
View file

@ -51,7 +51,14 @@
(let ((born 0)
(running 0)
(died 0))
(setq running (sb-thread::avl-count tree))
#-pauseless-thread-start (setq running (sb-thread::avl-count tree))
#+pauseless-thread-start
(sb-int:dx-flet ((mapfun (node)
(ecase (sb-thread::thread-%visible (sb-thread::avlnode-data node))
(0 (incf born)) ; "can't happen" ?
(1 (incf running))
(-1 (incf died)))))
(avl-maptree #'mapfun tree))
(let ((total (+ born running died)))
(macrolet ((max-into (global mine)
`(let ((old ,global))

130
tests/make-thread.impure.lisp Normal file
View file

@ -0,0 +1,130 @@
(in-package "SB-THREAD")
;;; Test out-of-memory (or something) that goes wrong in pthread_create
#+pauseless-threadstart ; no SB-THREAD::PTHREAD-CREATE symbol if not
(test-util:with-test (:name :failed-thread-creation)
(let ((encapsulation
(compile nil
'(lambda (realfun thread stack-base)
(if (string= (sb-thread:thread-name thread) "finalizer")
(funcall realfun thread stack-base)
nil))))
(success))
(assert (null sb-thread::*starting-threads*))
(unwind-protect
(progn (sb-int:encapsulate 'sb-thread::pthread-create 'test encapsulation)
(handler-case (sb-thread:make-thread #'list :name "thisfails")
(error (e)
(setq success (string= (write-to-string e)
"Could not create new OS thread.")))))
(sb-int:unencapsulate 'sb-thread::pthread-create 'test))
(assert (equal sb-thread::*starting-threads* nil))
(assert (equal (sb-thread::avltree-list sb-thread::*all-threads*)
(list sb-thread::*initial-thread*)))))
(defun actually-get-stack-roots (current-sp
&key allwords (print t)
&aux (current-sp (descriptor-sap current-sp))
(roots))
(declare (type (member nil t :everything) allwords))
(without-gcing
(let* ((stack-low (get-lisp-obj-address sb-vm:*control-stack-start*))
(stack-high (get-lisp-obj-address sb-vm:*control-stack-end*))
(nwords (ash (- stack-high (sap-int current-sp)) (- sb-vm:word-shift)))
(array (make-array nwords :element-type 'sb-ext:word)))
(when print
(format t "SP=end-~dw (range = ~x..~x)~%" nwords stack-low stack-high))
(alien-funcall (extern-alien "memcpy" (function void system-area-pointer
system-area-pointer unsigned))
(vector-sap array) current-sp (* nwords sb-vm:n-word-bytes))
(loop for i downfrom (1- nwords) to 0 by 1 do
(let ((word (aref array i)))
(when (or (/= word sb-vm:nil-value) allwords)
(let ((baseptr (alien-funcall (extern-alien "search_all_gc_spaces" (function unsigned unsigned))
word)))
(cond ((/= baseptr 0) ; an object reference
(let ((obj (sb-vm::reconstitute-object (%make-lisp-obj baseptr))))
(when (and (code-component-p obj)
(= (logand word sb-vm:lowtag-mask) sb-vm:fun-pointer-lowtag))
(dotimes (i (code-n-entries obj))
(when (= (get-lisp-obj-address (%code-entry-point obj i)) word)
(return (setq obj (%code-entry-point obj i))))))
;; interior pointers to objects that contain instructions are OK,
;; otherwise only correctly tagged pointers.
(when (or (typep obj '(or fdefn code-component funcallable-instance))
(= (get-lisp-obj-address obj) word))
(push obj roots)
(when print
(format t "~x = sp[~5d] = ~16x (~A) "
(sap-int (sap+ current-sp (ash i sb-vm:word-shift)))
i
word
(or (generation-of obj) #\S)) ; S is for static
(let ((*print-pretty* nil))
(cond ((consp obj) (format t "a cons"))
#+sb-fasteval
((typep obj 'sb-interpreter::sexpr) (format t "a sexpr"))
((arrayp obj) (format t "a ~s" (type-of obj)))
((and (code-component-p obj)
(>= word (sap-int (code-instructions obj))))
(format t "PC in ~a" obj))
(t (format t "~a" obj))))
(terpri)))))
((and print
(or (eq allwords :everything) (and allwords (/= word 0))))
(format t "~x = sp[~5d] = ~16x~%"
(sap-int (sap+ current-sp (ash i sb-vm:word-shift)))
i word)))))))))
(if print
(format t "~D roots~%" (length roots))
roots))
(defun get-stack-roots (&rest rest)
(apply #'actually-get-stack-roots (%make-lisp-obj (sap-int (current-sp))) rest))
(defstruct big-structure x)
(defstruct other-big-structure x)
(defun make-a-closure (arg options)
(lambda (&optional (z 0) y)
(declare (ignore y))
(test-util:opaque-identity
(format nil "Ahoy-hoy! ~d~%" (+ (big-structure-x arg) z)))
(apply #'get-stack-roots options)))
(defun tryit (&rest options)
(join-thread
(make-thread (make-a-closure (make-big-structure :x 0) options)
:arguments (list 1 (make-other-big-structure)))))
(defun make-a-closure-nontail (arg)
(lambda (&optional (z 0) y)
(declare (ignore y))
(get-stack-roots)
(test-util:opaque-identity
(format nil "Ahoy-hoy! ~d~%" (+ (big-structure-x arg) z)))
1))
(defun tryit-nontail ()
(join-thread
(make-thread (make-a-closure-nontail (make-big-structure :x 0))
:arguments (list 1 (make-other-big-structure)))))
;;; Test that reusing memory from an exited thread does not point to junk.
;;; In fact, assert something stronger: there are no young objects
;;; between the current SP and end of stack.
(test-util:with-test (:name :expected-gc-roots
:skipped-on (or :interpreter (not :pauseless-threadstart)))
(let ((list (tryit :print nil)))
;; should be not many things pointed to by the stack
(assert (< (length list) #+x86 35 ; more junk, I don't know why
#+x86-64 30)) ; less junk, I don't know why
;; Either no objects are in GC generation 0, or all are, depending on
;; whether CORE_PAGE_GENERATION has been set to 0 for testing.
(let ((n-objects-in-g0 (count 0 list :key #'sb-kernel:generation-of)))
(assert (or (= n-objects-in-g0 0)
(= n-objects-in-g0 (length list)))))))
;; lp#1595699
(test-util:with-test (:name :start-thread-in-without-gcing
:skipped-on (not :pauseless-threadstart))
(assert (eq (sb-thread:join-thread
(sb-sys:without-gcing
(sb-thread:make-thread (lambda () 'hi))))
'hi)))

4
tools-for-build/grovel-headers.c
View file

@ -262,6 +262,10 @@ main(int argc, char __attribute__((unused)) *argv[])
printf("\n");
printf(";;; signals\n");
defconstant("sizeof-sigset_t", sizeof (sigset_t));
defconstant("sig_block", SIG_BLOCK);
defconstant("sig_unblock", SIG_UNBLOCK);
defconstant("sig_setmask", SIG_SETMASK);
defsignal("sigalrm", SIGALRM);
defsignal("sigbus", SIGBUS);
defsignal("sigchld", SIGCHLD);