; :high-security
; :high-security-support
- ;; multiprocessing support
+ ;; low-level thread primitives support
;;
- ;; This is not maintained or tested in current SBCL. I haven't gone out
- ;; of my way to break it, but since it's derived from an old version of
- ;; CMU CL where multiprocessing was pretty shaky, it's likely to be very
- ;; flaky now.
- ;; :MP enables multiprocessing
- ;; :MP-I486 is used, only within the multiprocessing code, to control
- ;; what seems to control processor-version-specific code. It's
- ;; probably for 486 or later, i.e. could be set as long as
- ;; you know you're not running on a 386, but it doesn't seem
- ;; to be documented anywhere, so that's just a guess.
- ; :mp
- ; :mp-i486
-
+ ;; As of SBCL 0.8, this is only supposed to work in x86 Linux, on which
+ ;; system it's implemented using clone(2) and the %fs segment register.
+ ;; Note that no consistent effort to audit the SBCL library code for
+ ;; thread safety has been performed, so caveat executor
+ ; :sb-thread
+
;; This affects the definition of a lot of things in bignum.lisp. It
;; doesn't seem to be documented anywhere what systems it might apply
;; to. It doesn't seem to be needed for X86 systems anyway.
+<!-- -*- mode: SGML; sgml-parent-document: ("user-manual.sgml" "BOOK") -*- -->
<chapter id="beyond-ansi"><title>Beyond The &ANSI; Standard</>
<para>&SBCL; is mostly an implementation of the &ANSI; standard for
</sect2>
+<sect2><title>Threading (a.k.a Multiprocessing)</>
+
+<para>&SBCL; (as of version 0.x.y, on Linux x86 only) supports a
+fairly low-level threading interface that maps onto the host operating
+system's concept of threads or lightweight processes.
+
+<sect3><title>Lisp-level view</title>
+
+<para>A rudimentary interface to creating and managing multiple threads
+can be found in the <literal>sb-thread</literal> package. This is
+intended for public consumption, so look at the exported symbols and
+their documentation strings.
+
+<para>Dynamic bindings to symbols are per-thread. Signal handlers
+are per-thread.
+
+<para><function>sb-ext:quit</function> exits the current thread, not
+necessarily the whole environment. The environment will be shut down
+when the last thread exits.
+
+<para>Threads arbitrate between themselves for the user's attention.
+A thread may be in one of three notional states: foreground,
+background, or stopped. When a background process attempts to print a
+repl prompt or to enter the debugger, it will stop and print a message
+saying that it has stopped. The user at his leisure may switch to
+that thread to find out what it needs. If a background thread enters
+the debugger, selecting any restart will put it back into the
+background before it resumes.
+
+<para>If the user has multiple views onto the same Lisp image (for
+example, using multiple terminals, or a windowing system, or network
+access) they are typically set up as multiple `sessions' such that each
+view has its own collection of foreground/background/stopped threads.
+<function>sb-thread:make-listener-thread</function> can be used to
+start a new thread in its own `session'.
+
+<para>Mutexes and condition variables are available for
+managing access to shared data: see
+
+<itemizedlist>
+<listitem>
+<programlisting>(apropos "mutex" :sb-thread)</programlisting>
+<listitem>
+<programlisting>(apropos "condition" :sb-thread)</programlisting>
+<listitem> <para>and the <structname>waitqueue</structname> structure
+</para>
+</listitem>
+</itemizedlist>
+
+and poke around in their documentation strings.
+
+<sect3><title>Implementation (Linux x86)</title>
+
+<para>On Linux x86, this is implemented using
+<function>clone()</function> and does not involve pthreads. This is
+not because there is anything wrong with pthreads <emphasis>per
+se</emphasis>, but there is plenty wrong (from our perspective) with
+LinuxThreads. &SBCL; threads are mapped 1:1 onto Linux tasks which
+share a VM but nothing else - each has its own process id and can be
+seen in e.g. <command>ps</command> output.
+
+<para>Per-thread local bindings for special variables is achieved
+using the %fs segment register to point to a per-thread storage area.
+This may cause interesting results if you link to foreign code that
+expects threading or creates new threads, and the thread library in
+question uses %fs in an incompatible way.
+
+<para>Threads waiting on queues (e.g. for locks or condition
+variables) are put to sleep using <function>sigtimedwait()</function>
+and woken with SIGCONT.
+
+<para>&SBCL; at present will alway have at least two tasks running as
+seen from Linux: when the first process has done startup
+initialization (mapping files in place, installing signal handlers
+etc) it creates a new thread to run the Lisp startup and initial listener.
+The original thread is then used to run GC and to reap dead subthreads
+when they exit.
+
+<para>Garbage collection is done with the existing Conservative
+Generational GC. Allocation is done in small (typically 8k) regions :
+each thread has its own region so this involves no stopping. However,
+when a region fills, a lock must be obtained while another is
+allocated, and when a collection is required, all processes are
+stopped. This is achieved using <function>ptrace()</function>, so you
+should be very careful if you wish to examine an &SBCL; worker thread
+using <command>strace</command>, <command>truss</command>,
+<command>gdb</command> or similar. It may be prudent to disable GC
+before doing so.
+
+<para>Large amounts of the &SBCL; library have not been inspected for
+thread-safety. Some of the obviously unsafe areas have large locks
+around them, so compilation and fasl loading, for example, cannot be
+parallelized. Work is ongoing in this area.
+
+<para>A new thread by default is created in the same POSIX process
+group and session as the thread it was created by. This has an impact
+on keyboard interrupt handling: pressing your terminal's intr key
+(typically Control-C) will interrupt all processes in the foreground
+process group, including Lisp threads that &SBCL; considers to be
+notionally `background'. This is undesirable, so background threads
+are set to ignore the SIGINT signal. Arbitration for the input stream
+is managed by locking on sb-thread::*session-lock*
+
+<para>A thread can be created in a new Lisp 'session' (new terminal or
+window) using <function>sb-thread:make-listener-thread</function>.
+These sessions map directly onto POSIX sessions, so that pressing
+Control-C in the wrong window will not interrupt them - this has been
+found to be embarrassing.
+
<sect2><title>Support For Unix</>
<para>The UNIX command line can be read from the variable
"%ARRAY-TYPEP" "%SET-SAP-REF-DESCRIPTOR"))
#s(sb-cold:package-data
+ :name "SB!THREAD"
+ :use ("CL" "SB!ALIEN")
+ :doc "public (but low-level): native thread support"
+ :export ("MAKE-THREAD"
+ "MAKE-LISTENER-THREAD" "DESTROY-THREAD" "WITH-RECURSIVE-LOCK"
+ "MUTEX" "MAKE-MUTEX" "GET-MUTEX" "RELEASE-MUTEX" "WITH-MUTEX"
+ "WAITQUEUE" "MAKE-WAITQUEUE" "CONDITION-WAIT" "CONDITION-NOTIFY"
+ "WITH-RECURSIVE-LOCK" "RELEASE-FOREGROUND" "CURRENT-THREAD-ID"))
+
+ #s(sb-cold:package-data
:name "SB!LOOP"
:doc "private: implementation details of LOOP"
:use ("CL")
;;; When a *periodic-polling-function* is defined the server will not
;;; block for more than the maximum event timeout and will call the
-;;; polling function if it does time out. One important use of this
-;;; is to periodically call process-yield.
+;;; polling function if it does time out.
(declaim (type (or null function) *periodic-polling-function*))
(defvar *periodic-polling-function* nil)
(declaim (type (unsigned-byte 29) *max-event-to-sec* *max-event-to-usec*))
--- /dev/null
+(in-package "SB!THREAD")
+
+(sb!alien::define-alien-routine ("create_thread" %create-thread)
+ sb!alien:unsigned-long
+ (lisp-fun-address sb!alien:unsigned-long))
+
+(defun make-thread (function)
+ (let ((real-function (coerce function 'function)))
+ (%create-thread
+ (sb!kernel:get-lisp-obj-address
+ (lambda ()
+ ;; in time we'll move some of the binding presently done in C
+ ;; here too
+ (let ((sb!kernel::*restart-clusters* nil)
+ (sb!impl::*descriptor-handlers* nil); serve-event
+ (sb!impl::*available-buffers* nil)) ;for fd-stream
+ ;; can't use handling-end-of-the-world, because that flushes
+ ;; output streams, and we don't necessarily have any (or we
+ ;; could be sharing them)
+ (sb!sys:enable-interrupt :sigint :ignore)
+ (sb!unix:unix-exit
+ (catch 'sb!impl::%end-of-the-world
+ (with-simple-restart
+ (destroy-thread
+ (format nil "~~@<Destroy this thread (~A)~~@:>"
+ (current-thread-id)))
+ (funcall real-function))
+ 0))))))))
+
+(defun destroy-thread (thread-id)
+ (sb!unix:unix-kill thread-id :sigterm)
+ ;; may have been stopped for some reason, so now wake it up to
+ ;; deliver the TERM
+ (sb!unix:unix-kill thread-id :sigcont))
+
+;; Conventional wisdom says that it's a bad idea to use these unless
+;; you really need to. Use a lock or a waitqueue instead
+(defun suspend-thread (thread-id)
+ (sb!unix:unix-kill thread-id :sigstop))
+(defun resume-thread (thread-id)
+ (sb!unix:unix-kill thread-id :sigcont))
+
+(defun current-thread-id ()
+ (sb!sys:sap-int
+ (sb!vm::current-thread-offset-sap sb!vm::thread-pid-slot)))
+
+;;;; iterate over the in-memory threads
+
+(defun mapcar-threads (function)
+ "Call FUNCTION once for each known thread, giving it the thread structure as argument"
+ (let ((function (coerce function 'function)))
+ (loop for thread = (alien-sap (extern-alien "all_threads" (* t)))
+ then (sb!sys:sap-ref-sap thread (* 4 sb!vm::thread-next-slot))
+ until (sb!sys:sap= thread (sb!sys:int-sap 0))
+ collect (funcall function thread))))
+
+;;;; queues, locks
+
+;; spinlocks use 0 as "free" value: higher-level locks use NIL
+(defun get-spinlock (lock offset new-value)
+ (declare (optimize (speed 3) (safety 0)))
+ (loop until
+ (eql (sb!vm::%instance-set-conditional lock offset 0 new-value) 0)))
+
+(defmacro with-spinlock ((queue) &body body)
+ (let ((pid (gensym "PID")))
+ `(unwind-protect
+ (let ((,pid (current-thread-id)))
+ (get-spinlock ,queue 2 ,pid)
+ ,@body)
+ (setf (waitqueue-lock ,queue) 0))))
+
+;;;; the higher-level locking operations are based on waitqueues
+
+(defstruct waitqueue
+ (name nil :type (or null simple-base-string))
+ (lock 0)
+ (data nil))
+
+(defstruct (mutex (:include waitqueue))
+ (value nil))
+
+(sb!alien:define-alien-routine "block_sigcont" void)
+(sb!alien:define-alien-routine "unblock_sigcont_and_sleep" void)
+
+(defun wait-on-queue (queue &optional lock)
+ (let ((pid (current-thread-id)))
+ ;; FIXME what should happen if we get interrupted when we've blocked
+ ;; the sigcont? For that matter, can we get interrupted?
+ (block-sigcont)
+ (when lock (release-mutex lock))
+ (get-spinlock queue 2 pid)
+ (pushnew pid (waitqueue-data queue))
+ (setf (waitqueue-lock queue) 0)
+ (unblock-sigcont-and-sleep)))
+
+(defun dequeue (queue)
+ (let ((pid (current-thread-id)))
+ (get-spinlock queue 2 pid)
+ (setf (waitqueue-data queue)
+ (delete pid (waitqueue-data queue)))
+ (setf (waitqueue-lock queue) 0)))
+
+(defun signal-queue-head (queue)
+ (let ((pid (current-thread-id)))
+ (get-spinlock queue 2 pid)
+ (let ((h (car (waitqueue-data queue))))
+ (setf (waitqueue-lock queue) 0)
+ (when h
+ (sb!unix:unix-kill h :sigcont)))))
+
+;;;; mutex
+
+(defun get-mutex (lock &optional new-value (wait-p t))
+ (declare (type mutex lock))
+ (let ((pid (current-thread-id)))
+ (unless new-value (setf new-value pid))
+ (assert (not (eql new-value (mutex-value lock))))
+ (loop
+ (unless
+ ;; args are object slot-num old-value new-value
+ (sb!vm::%instance-set-conditional lock 4 nil new-value)
+ (dequeue lock)
+ (return t))
+ (unless wait-p (return nil))
+ (wait-on-queue lock nil))))
+
+(defun release-mutex (lock &optional (new-value nil))
+ (declare (type mutex lock))
+ (let ((old-value (mutex-value lock))
+ (t1 nil))
+ (loop
+ (unless
+ ;; args are object slot-num old-value new-value
+ (eql old-value
+ (setf t1
+ (sb!vm::%instance-set-conditional lock 4 old-value new-value)))
+ (signal-queue-head lock)
+ (return t))
+ (setf old-value t1))))
+
+(defmacro with-mutex ((mutex &key value (wait-p t)) &body body)
+ (let ((block (gensym "NIL")))
+ `(unwind-protect
+ (block ,block
+ (unless (get-mutex ,mutex ,value ,wait-p) (return-from ,block nil))
+ ,@body)
+ (release-mutex ,mutex))))
+
+
+;;;; condition variables
+
+(defun condition-wait (queue lock)
+ "Atomically release LOCK and enqueue ourselves on QUEUE. Another
+thread may subsequently notify us using CONDITION-NOTIFY, at which
+time we reacquire LOCK and return to the caller."
+ (unwind-protect
+ (wait-on-queue queue lock)
+ ;; If we are interrupted while waiting, we should do these things
+ ;; before returning. Ideally, in the case of an unhandled signal,
+ ;; we should do them before entering the debugger, but this is
+ ;; better than nothing.
+ (dequeue queue)
+ (get-mutex lock)))
+
+(defun condition-notify (queue)
+ "Notify one of the processes waiting on QUEUE"
+ (signal-queue-head queue))
+
+
+;;;; multiple independent listeners
+
+(defvar *session-lock* nil)
+
+(defun make-listener-thread (tty-name)
+ (assert (probe-file tty-name))
+ ;; FIXME probably still need to do some tty stuff to get signals
+ ;; delivered correctly.
+ ;; FIXME
+ (let* ((in (sb!unix:unix-open (namestring tty-name) sb!unix:o_rdwr #o666))
+ (out (sb!unix:unix-dup in))
+ (err (sb!unix:unix-dup in)))
+ (labels ((thread-repl ()
+ (sb!unix::unix-setsid)
+ (let* ((*session-lock*
+ (make-mutex :name (format nil "lock for ~A" tty-name)))
+ (sb!impl::*stdin*
+ (sb!sys:make-fd-stream in :input t :buffering :line))
+ (sb!impl::*stdout*
+ (sb!sys:make-fd-stream out :output t :buffering :line))
+ (sb!impl::*stderr*
+ (sb!sys:make-fd-stream err :output t :buffering :line))
+ (sb!impl::*tty*
+ (sb!sys:make-fd-stream err :input t :output t :buffering :line))
+ (sb!impl::*descriptor-handlers* nil))
+ (get-mutex *session-lock*)
+ (sb!sys:enable-interrupt :sigint #'sb!unix::sigint-handler)
+ (unwind-protect
+ (sb!impl::toplevel-repl nil)
+ (sb!int:flush-standard-output-streams)))))
+ (make-thread #'thread-repl))))
+
+;;;; job control
+
+(defvar *background-threads-wait-for-debugger* t)
+;;; may be T, NIL, or a function called with an fd-stream and thread id
+;;; as its two arguments, returning NIl or T
+
+;;; called from top of invoke-debugger
+(defun debugger-wait-until-foreground-thread (stream)
+ "Returns T if thread had been running in background, NIL if it was
+already the foreground thread, or transfers control to the first applicable
+restart if *BACKGROUND-THREADS-WAIT-FOR-DEBUGGER* says to do that instead"
+ (let* ((wait-p *background-threads-wait-for-debugger*)
+ (*background-threads-wait-for-debugger* nil)
+ (fd-stream (sb!impl::get-underlying-stream stream :input))
+ (lock *session-lock*))
+ (when (not (eql (mutex-value lock) (CURRENT-THREAD-ID)))
+ (when (functionp wait-p)
+ (setf wait-p
+ (funcall wait-p fd-stream (CURRENT-THREAD-ID))))
+ (cond (wait-p (get-foreground))
+ (t (invoke-restart (car (compute-restarts))))))))
+
+;;; install this with (setf SB!INT:*REPL-PROMPT-FUN* #'thread-prompt-fun)
+;;; One day it will be default
+(defun thread-repl-prompt-fun (out-stream)
+ (let ((lock *session-lock*))
+ (get-foreground)
+ (let ((stopped-threads (waitqueue-data lock)))
+ (when stopped-threads
+ (format out-stream "~{~&Thread ~A suspended~}~%" stopped-threads))
+ (sb!impl::repl-prompt-fun out-stream))))
+
+(defun resume-stopped-thread (id)
+ (let ((pid (current-thread-id))
+ (lock *session-lock*))
+ (with-spinlock (lock)
+ (setf (waitqueue-data lock)
+ (cons id (delete id (waitqueue-data lock)))))
+ (release-foreground)))
+
+(defstruct rwlock
+ (name nil :type (or null simple-base-string))
+ (value 0 :type fixnum)
+ (max-readers nil :type (or fixnum null))
+ (max-writers 1 :type fixnum))
+#+nil
+(macrolet
+ ((make-rwlocking-function (lock-fn unlock-fn increment limit test)
+ (let ((do-update '(when (eql old-value
+ (sb!vm::%instance-set-conditional
+ lock 2 old-value new-value))
+ (return (values t old-value))))
+ (vars `((timeout (and timeout (+ (get-internal-real-time) timeout)))
+ old-value
+ new-value
+ (limit ,limit))))
+ (labels ((do-setfs (v) `(setf old-value (rwlock-value lock)
+ new-value (,v old-value ,increment))))
+ `(progn
+ (defun ,lock-fn (lock timeout)
+ (declare (type rwlock lock))
+ (let ,vars
+ (loop
+ ,(do-setfs '+)
+ (when ,test
+ ,do-update)
+ (when (sleep-a-bit timeout) (return nil)) ;expired
+ )))
+ ;; unlock doesn't need timeout or test-in-range
+ (defun ,unlock-fn (lock)
+ (declare (type rwlock lock))
+ (declare (ignorable limit))
+ (let ,(cdr vars)
+ (loop
+ ,(do-setfs '-)
+ ,do-update))))))))
+
+ (make-rwlocking-function %lock-for-reading %unlock-for-reading 1
+ (rwlock-max-readers lock)
+ (and (>= old-value 0)
+ (or (null limit) (<= new-value limit))))
+ (make-rwlocking-function %lock-for-writing %unlock-for-writing -1
+ (- (rwlock-max-writers lock))
+ (and (<= old-value 0)
+ (>= new-value limit))))
+#+nil
+(defun get-rwlock (lock direction &optional timeout)
+ (ecase direction
+ (:read (%lock-for-reading lock timeout))
+ (:write (%lock-for-writing lock timeout))))
+#+nil
+(defun free-rwlock (lock direction)
+ (ecase direction
+ (:read (%unlock-for-reading lock))
+ (:write (%unlock-for-writing lock))))
+
+;;;; beyond this point all is commented.
+
+;;; Lock-Wait-With-Timeout -- Internal
+;;;
+;;; Wait with a timeout for the lock to be free and acquire it for the
+;;; *current-process*.
+;;;
+#+nil
+(defun lock-wait-with-timeout (lock whostate timeout)
+ (declare (type lock lock))
+ (process-wait-with-timeout
+ whostate timeout
+ #'(lambda ()
+ (declare (optimize (speed 3)))
+ #-i486
+ (unless (lock-process lock)
+ (setf (lock-process lock) *current-process*))
+ #+i486
+ (null (kernel:%instance-set-conditional
+ lock 2 nil *current-process*)))))
+
+;;; With-Lock-Held -- Public
+;;;
+#+nil
+(defmacro with-lock-held ((lock &optional (whostate "Lock Wait")
+ &key (wait t) timeout)
+ &body body)
+ "Execute the body with the lock held. If the lock is held by another
+ process then the current process waits until the lock is released or
+ an optional timeout is reached. The optional wait timeout is a time in
+ seconds acceptable to process-wait-with-timeout. The results of the
+ body are return upon success and NIL is return if the timeout is
+ reached. When the wait key is NIL and the lock is held by another
+ process then NIL is return immediately without processing the body."
+ (let ((have-lock (gensym)))
+ `(let ((,have-lock (eq (lock-process ,lock) *current-process*)))
+ (unwind-protect
+ ,(cond ((and timeout wait)
+ `(progn
+ (when (and (error-check-lock-p ,lock) ,have-lock)
+ (error "Dead lock"))
+ (when (or ,have-lock
+ #+i486 (null (kernel:%instance-set-conditional
+ ,lock 2 nil *current-process*))
+ #-i486 (seize-lock ,lock)
+ (if ,timeout
+ (lock-wait-with-timeout
+ ,lock ,whostate ,timeout)
+ (lock-wait ,lock ,whostate)))
+ ,@body)))
+ (wait
+ `(progn
+ (when (and (error-check-lock-p ,lock) ,have-lock)
+ (error "Dead lock"))
+ (unless (or ,have-lock
+ #+i486 (null (kernel:%instance-set-conditional
+ ,lock 2 nil *current-process*))
+ #-i486 (seize-lock ,lock))
+ (lock-wait ,lock ,whostate))
+ ,@body))
+ (t
+ `(when (or (and (recursive-lock-p ,lock) ,have-lock)
+ #+i486 (null (kernel:%instance-set-conditional
+ ,lock 2 nil *current-process*))
+ #-i486 (seize-lock ,lock))
+ ,@body)))
+ (unless ,have-lock
+ #+i486 (kernel:%instance-set-conditional
+ ,lock 2 *current-process* nil)
+ #-i486 (when (eq (lock-process ,lock) *current-process*)
+ (setf (lock-process ,lock) nil)))))))
+
+
+
--- /dev/null
+(in-package :sb!thread)
+
+#+sb-xc-host
+(defun make-mutex (&key name value) nil)
+
+#+sb-xc-host
+(defmacro with-recursive-lock ((mutex) &body body)
+ `(progn ,@body))
+
+#-sb-xc-host
+(defmacro with-recursive-lock ((mutex) &body body)
+ (let ((cfp (gensym "CFP")))
+ `(let ((,cfp (ash (sb!sys:sap-int (sb!vm::current-fp) ) -2)))
+ (unless (and (mutex-value ,mutex)
+ (SB!DI::control-stack-pointer-valid-p
+ (sb!sys:int-sap (ash (mutex-value ,mutex) 2))))
+ (get-mutex ,mutex ,cfp))
+ (unwind-protect
+ (progn ,@body)
+ (when (eql (mutex-value ,mutex) ,cfp) (release-mutex ,mutex))))))
+
+(defun get-foreground ()
+ (when (not (eql (mutex-value *session-lock*) (CURRENT-THREAD-ID)))
+ (get-mutex *session-lock*))
+ (sb!sys:enable-interrupt :sigint #'sb!unix::sigint-handler)
+ t)
+
+(defun release-foreground ()
+ (sb!sys:enable-interrupt :sigint :ignore)
+ (release-mutex *session-lock*)
+ t)
(emit-ea segment dst (reg-tn-encoding src)))))
\f
+
+(define-instruction fs-segment-prefix (segment)
+ (:emitter
+ (emit-byte segment #x64)))
+
;;;; flag control instructions
;;; CLC -- Clear Carry Flag.
--- /dev/null
+#include <stdlib.h>
+#include <stdio.h>
+#include <sched.h>
+#include <stddef.h>
+#ifndef CLONE_PARENT /* lameass glibc 2.2 doesn't define this */
+#define CLONE_PARENT 0x00008000 /* even though the manpage documents it */
+#endif
+#include "runtime.h"
+#include "sbcl.h"
+#include "validate.h" /* for CONTROL_STACK_SIZE etc */
+#include "thread.h"
+#include "arch.h"
+#include "target-arch-os.h"
+#include "os.h"
+#include "globals.h"
+#ifdef LISP_FEATURE_GENCGC
+#include "gencgc.h"
+#endif
+#include "dynbind.h"
+#include "genesis/cons.h"
+#define ALIEN_STACK_SIZE (1*1024*1024) /* 1Mb size chosen at random */
+
+int dynamic_values_bytes=4096*sizeof(lispobj); /* same for all threads */
+struct thread *all_threads;
+lispobj all_threads_lock;
+extern struct interrupt_data * global_interrupt_data;
+
+void get_spinlock(lispobj *word,int value);
+
+/* this is the first thing that clone() runs in the child (which is
+ * why the silly calling convention). Basically it calls the user's
+ * requested lisp function after doing arch_os_thread_init and
+ * whatever other bookkeeping needs to be done
+ */
+
+/* set go to 0 to stop the thread before it starts. Convenient if you
+* want to attach a debugger to it before it does anything */
+volatile int go=1;
+
+int
+new_thread_trampoline(struct thread *th)
+{
+ lispobj function;
+ function = th->unbound_marker;
+ if(go==0) {
+ fprintf(stderr, "/pausing 0x%lx(%d,%d) before new_thread_trampoline(0x%lx)\n",
+ (unsigned long)th,th->pid,getpid(),(unsigned long)function);
+ while(go==0) ;
+ fprintf(stderr, "/continue\n");
+ }
+ th->unbound_marker = UNBOUND_MARKER_WIDETAG;
+ /* wait here until our thread is linked into all_threads: see below */
+ while(th->pid<1) sched_yield();
+
+ if(arch_os_thread_init(th)==0)
+ return 1; /* failure. no, really */
+ return funcall0(function);
+}
+
+/* this is called from any other thread to create the new one, and
+ * initialize all parts of it that can be initialized from another
+ * thread
+ */
+
+pid_t create_thread(lispobj initial_function) {
+ union per_thread_data *per_thread;
+ struct thread *th=0; /* subdue gcc */
+ void *spaces=0;
+ pid_t kid_pid;
+
+ /* may as well allocate all the spaces at once: it saves us from
+ * having to decide what to do if only some of the allocations
+ * succeed */
+ spaces=os_validate(0,
+ THREAD_CONTROL_STACK_SIZE+
+ BINDING_STACK_SIZE+
+ ALIEN_STACK_SIZE+
+ dynamic_values_bytes+
+ 32*SIGSTKSZ
+ );
+ if(!spaces) goto cleanup;
+ per_thread=(union per_thread_data *)
+ (spaces+
+ THREAD_CONTROL_STACK_SIZE+
+ BINDING_STACK_SIZE+
+ ALIEN_STACK_SIZE);
+
+ th=&per_thread->thread;
+ if(all_threads) {
+ memcpy(per_thread,arch_os_get_current_thread(),
+ dynamic_values_bytes);
+ } else {
+ int i;
+ for(i=0;i<(dynamic_values_bytes/sizeof(lispobj));i++)
+ per_thread->dynamic_values[i]=UNBOUND_MARKER_WIDETAG;
+ if(SymbolValue(FREE_TLS_INDEX,0)==UNBOUND_MARKER_WIDETAG)
+ SetSymbolValue
+ (FREE_TLS_INDEX,
+ make_fixnum(MAX_INTERRUPTS+
+ sizeof(struct thread)/sizeof(lispobj)),
+ 0);
+#define STATIC_TLS_INIT(sym,field) \
+ ((struct symbol *)(sym-OTHER_POINTER_LOWTAG))->tls_index= \
+ make_fixnum(THREAD_SLOT_OFFSET_WORDS(field))
+
+ STATIC_TLS_INIT(BINDING_STACK_START,binding_stack_start);
+ STATIC_TLS_INIT(BINDING_STACK_POINTER,binding_stack_pointer);
+ STATIC_TLS_INIT(CONTROL_STACK_START,control_stack_start);
+ STATIC_TLS_INIT(ALIEN_STACK,alien_stack_pointer);
+ STATIC_TLS_INIT(PSEUDO_ATOMIC_ATOMIC,pseudo_atomic_atomic);
+ STATIC_TLS_INIT(PSEUDO_ATOMIC_INTERRUPTED,pseudo_atomic_interrupted);
+#undef STATIC_TLS_INIT
+ }
+
+ th->control_stack_start = spaces;
+ th->binding_stack_start=
+ (lispobj*)((void*)th->control_stack_start+THREAD_CONTROL_STACK_SIZE);
+ th->alien_stack_start=
+ (lispobj*)((void*)th->binding_stack_start+BINDING_STACK_SIZE);
+ th->binding_stack_pointer=th->binding_stack_start;
+ th->this=th;
+ th->pid=0;
+#ifdef LISP_FEATURE_STACK_GROWS_DOWNWARD_NOT_UPWARD
+ th->alien_stack_pointer=((void *)th->alien_stack_start
+ + ALIEN_STACK_SIZE-4); /* naked 4. FIXME */
+#else
+ th->alien_stack_pointer=((void *)th->alien_stack_start);
+#endif
+ th->pseudo_atomic_interrupted=0;
+ /* runtime.c used to set PSEUDO_ATOMIC_ATOMIC =1 globally. I'm not
+ * sure why, but it appears to help */
+ th->pseudo_atomic_atomic=make_fixnum(1);
+ gc_set_region_empty(&th->alloc_region);
+
+ bind_variable(CURRENT_CATCH_BLOCK,make_fixnum(0),th);
+ bind_variable(CURRENT_UNWIND_PROTECT_BLOCK,make_fixnum(0),th);
+ bind_variable(FREE_INTERRUPT_CONTEXT_INDEX,make_fixnum(0),th);
+ bind_variable(INTERRUPT_PENDING, NIL,th);
+ bind_variable(INTERRUPTS_ENABLED,T,th);
+
+ th->interrupt_data=malloc(sizeof (struct interrupt_data));
+ if(all_threads)
+ memcpy(th->interrupt_data,arch_os_get_current_thread()->interrupt_data,
+ sizeof (struct interrupt_data));
+ else
+ memcpy(th->interrupt_data,global_interrupt_data,
+ sizeof (struct interrupt_data));
+
+
+#if defined(LISP_FEATURE_X86) && defined (LISP_FEATURE_LINUX)
+ th->unbound_marker=initial_function;
+ kid_pid=
+ clone(new_thread_trampoline,
+ (((void*)th->control_stack_start)+THREAD_CONTROL_STACK_SIZE-4),
+ (((getpid()!=parent_pid)?(CLONE_PARENT):0)
+ |CLONE_FILES|SIGALRM|CLONE_VM),th);
+ if(kid_pid<=0)
+ goto cleanup;
+#else
+#error this stuff presently only works on x86 Linux
+#endif
+
+ get_spinlock(&all_threads_lock,kid_pid);
+ th->next=all_threads;
+ all_threads=th;
+ /* note that th->pid is 0 at this time. We rely on all_threads_lock
+ * to ensure that we don't have >1 thread with pid=0 on the list at once
+ */
+ protect_control_stack_guard_page(th->pid,1);
+ all_threads_lock=0;
+ th->pid=kid_pid; /* child will not start until this is set */
+ return th->pid;
+ cleanup:
+ /* if(th && th->tls_cookie>=0) os_free_tls_pointer(th); */
+ if(spaces) os_invalidate(spaces,
+ THREAD_CONTROL_STACK_SIZE+BINDING_STACK_SIZE+
+ ALIEN_STACK_SIZE+dynamic_values_bytes);
+ return 0;
+}
+
+void destroy_thread (struct thread *th)
+{
+ /* precondition: the unix task has already been killed and exited.
+ * This is called by the parent */
+ gc_alloc_update_page_tables(0, &th->alloc_region);
+ get_spinlock(&all_threads_lock,th->pid);
+ if(th==all_threads)
+ all_threads=th->next;
+ else {
+ struct thread *th1=all_threads;
+ while(th1->next!=th) th1=th1->next;
+ th1->next=th->next; /* unlink */
+ }
+ all_threads_lock=0;
+ if(th && th->tls_cookie>=0) arch_os_thread_cleanup(th);
+ os_invalidate((os_vm_address_t) th->control_stack_start,
+ THREAD_CONTROL_STACK_SIZE+BINDING_STACK_SIZE+
+ ALIEN_STACK_SIZE+dynamic_values_bytes+
+ 32*SIGSTKSZ);
+}
+
+
+struct thread *find_thread_by_pid(pid_t pid)
+{
+ struct thread *th;
+ for_each_thread(th)
+ if(th->pid==pid) return th;
+ return 0;
+}
+
+
+void get_spinlock(lispobj *word,int value)
+{
+ u32 eax=0;
+ do {
+ asm ("xor %0,%0;cmpxchg %1,%2"
+ : "=a" (eax)
+ : "r" (value), "m" (*word)
+ : "memory", "cc");
+ } while(eax!=0);
+}
+
+void block_sigcont(void)
+{
+ /* don't allow ourselves to receive SIGCONT while we're in the
+ * "ambiguous" state of being on the queue but not actually stopped.
+ */
+ sigset_t newset;
+ sigemptyset(&newset);
+ sigaddset(&newset,SIGCONT);
+ sigprocmask(SIG_BLOCK, &newset, 0);
+}
+
+void unblock_sigcont_and_sleep(void)
+{
+ sigset_t set;
+ sigemptyset(&set);
+ sigaddset(&set,SIGCONT);
+ sigwaitinfo(&set,0);
+ sigprocmask(SIG_UNBLOCK,&set,0);
+}
+
--- /dev/null
+
+#if !defined(_INCLUDE_THREAD_H_)
+#define _INCLUDE_THREAD_H_
+
+#include <sys/types.h>
+#include <unistd.h>
+#include "runtime.h"
+#include "sbcl.h"
+#include "os.h"
+#include "interrupt.h"
+#ifdef LISP_FEATURE_GENCGC
+#include "gencgc-alloc-region.h"
+#else
+#error "threading doesn't work with cheney gc yet"
+#endif
+#include "genesis/symbol.h"
+#include "genesis/static-symbols.h"
+#include "genesis/thread.h"
+
+#define THREAD_SLOT_OFFSET_WORDS(c) \
+ (offsetof(struct thread,c)/(sizeof (struct thread *)))
+
+union per_thread_data {
+ struct thread thread;
+ lispobj dynamic_values[1]; /* actually more like 4000 or so */
+};
+
+extern struct thread *all_threads;
+extern int dynamic_values_bytes;
+extern struct thread *find_thread_by_pid(pid_t pid);
+
+#define for_each_thread(th) for(th=all_threads;th;th=th->next)
+
+static inline lispobj SymbolValue(u32 tagged_symbol_pointer, void *thread) {
+ struct symbol *sym= (struct symbol *)
+ (tagged_symbol_pointer-OTHER_POINTER_LOWTAG);
+ if(thread && sym->tls_index) {
+ lispobj r=
+ ((union per_thread_data *)thread)
+ ->dynamic_values[fixnum_value(sym->tls_index)];
+ if(r!=UNBOUND_MARKER_WIDETAG) return r;
+ }
+ return sym->value;
+}
+static inline lispobj SymbolTlValue(u32 tagged_symbol_pointer, void *thread) {
+ struct symbol *sym= (struct symbol *)
+ (tagged_symbol_pointer-OTHER_POINTER_LOWTAG);
+ return ((union per_thread_data *)thread)
+ ->dynamic_values[fixnum_value(sym->tls_index)];
+}
+
+static inline void SetSymbolValue(u32 tagged_symbol_pointer,lispobj val, void *thread) {
+ struct symbol *sym= (struct symbol *)
+ (tagged_symbol_pointer-OTHER_POINTER_LOWTAG);
+ if(thread && sym->tls_index) {
+ lispobj *pr= &(((union per_thread_data *)thread)
+ ->dynamic_values[fixnum_value(sym->tls_index)]);
+ if(*pr!= UNBOUND_MARKER_WIDETAG) {
+ *pr=val;
+ return;
+ }
+ }
+ sym->value = val;
+}
+static inline void SetTlSymbolValue(u32 tagged_symbol_pointer,lispobj val, void *thread) {
+ struct symbol *sym= (struct symbol *)
+ (tagged_symbol_pointer-OTHER_POINTER_LOWTAG);
+ ((union per_thread_data *)thread)
+ ->dynamic_values[fixnum_value(sym->tls_index)]
+ =val;
+}
+
+
+
+#endif /* _INCLUDE_THREAD_H_ */
;;; versions, especially for internal versions off the main CVS
;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.pre8.9"
+"0.pre8.10"
projects / sbcl.git / commitdiff