From be76f6319dcb41477209676e6f26e0030e4659ba Mon Sep 17 00:00:00 2001 From: Daniel Barlow Date: Wed, 26 Mar 2003 01:04:41 +0000 Subject: [PATCH] 0.pre8.10 Add some files needed by the soon-to-be-merged thread support Some non-invasive (supposed not to break unithread builds) changes to existing files ... add SB-THREAD package ... fs-segment-prefix "instruction" definition ... some documentation (OK, so it will break McCLIM. That's easily fixable, though) --- base-target-features.lisp-expr | 21 +-- doc/beyond-ansi.sgml | 110 ++++++++++++ package-data-list.lisp-expr | 10 ++ src/code/serve-event.lisp | 3 +- src/code/target-thread.lisp | 372 ++++++++++++++++++++++++++++++++++++++++ src/code/thread.lisp | 31 ++++ src/compiler/x86/insts.lisp | 5 + src/runtime/thread.c | 242 ++++++++++++++++++++++++++ src/runtime/thread.h | 75 ++++++++ version.lisp-expr | 2 +- 10 files changed, 854 insertions(+), 17 deletions(-) create mode 100644 src/code/target-thread.lisp create mode 100644 src/code/thread.lisp create mode 100644 src/runtime/thread.c create mode 100644 src/runtime/thread.h diff --git a/base-target-features.lisp-expr b/base-target-features.lisp-expr index 2bef560..c6e3c90 100644 --- a/base-target-features.lisp-expr +++ b/base-target-features.lisp-expr @@ -152,21 +152,14 @@ ; :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. diff --git a/doc/beyond-ansi.sgml b/doc/beyond-ansi.sgml index 65e201e..1990336 100644 --- a/doc/beyond-ansi.sgml +++ b/doc/beyond-ansi.sgml @@ -1,3 +1,4 @@ + Beyond The &ANSI; Standard</> <para>&SBCL; is mostly an implementation of the &ANSI; standard for @@ -126,6 +127,115 @@ behaviour) -->.</para> </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 + +A rudimentary interface to creating and managing multiple threads +can be found in the sb-thread package. This is +intended for public consumption, so look at the exported symbols and +their documentation strings. + +Dynamic bindings to symbols are per-thread. Signal handlers +are per-thread. + +sb-ext:quit exits the current thread, not +necessarily the whole environment. The environment will be shut down +when the last thread exits. + +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. + +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. +sb-thread:make-listener-thread can be used to +start a new thread in its own `session'. + +Mutexes and condition variables are available for +managing access to shared data: see + + + +(apropos "mutex" :sb-thread) + +(apropos "condition" :sb-thread) + and the waitqueue structure + + + + +and poke around in their documentation strings. + +Implementation (Linux x86) + +On Linux x86, this is implemented using +clone() and does not involve pthreads. This is +not because there is anything wrong with pthreads per +se, 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. ps output. + +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. + +Threads waiting on queues (e.g. for locks or condition +variables) are put to sleep using sigtimedwait() +and woken with SIGCONT. + +&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. + +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 ptrace(), so you +should be very careful if you wish to examine an &SBCL; worker thread +using strace, truss, +gdb or similar. It may be prudent to disable GC +before doing so. + +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. + +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* + +A thread can be created in a new Lisp 'session' (new terminal or +window) using sb-thread:make-listener-thread. +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. + Support For Unix</> <para>The UNIX command line can be read from the variable diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 28fac31..9225f7a 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -1388,6 +1388,16 @@ is a good idea, but see SB-SYS re. blurring of boundaries." "%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") diff --git a/src/code/serve-event.lisp b/src/code/serve-event.lisp index 7b1b4e9..1183d6c 100644 --- a/src/code/serve-event.lisp +++ b/src/code/serve-event.lisp @@ -279,8 +279,7 @@ ;;; 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*)) diff --git a/src/code/target-thread.lisp b/src/code/target-thread.lisp new file mode 100644 index 0000000..176336e --- /dev/null +++ b/src/code/target-thread.lisp @@ -0,0 +1,372 @@ +(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))))))) + + + diff --git a/src/code/thread.lisp b/src/code/thread.lisp new file mode 100644 index 0000000..c5c7104 --- /dev/null +++ b/src/code/thread.lisp @@ -0,0 +1,31 @@ +(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) diff --git a/src/compiler/x86/insts.lisp b/src/compiler/x86/insts.lisp index b221393..c2ca16c 100644 --- a/src/compiler/x86/insts.lisp +++ b/src/compiler/x86/insts.lisp @@ -1036,6 +1036,11 @@ (emit-ea segment dst (reg-tn-encoding src))))) + +(define-instruction fs-segment-prefix (segment) + (:emitter + (emit-byte segment #x64))) + ;;;; flag control instructions ;;; CLC -- Clear Carry Flag. diff --git a/src/runtime/thread.c b/src/runtime/thread.c new file mode 100644 index 0000000..40d3afe --- /dev/null +++ b/src/runtime/thread.c @@ -0,0 +1,242 @@ +#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); +} + diff --git a/src/runtime/thread.h b/src/runtime/thread.h new file mode 100644 index 0000000..674f051 --- /dev/null +++ b/src/runtime/thread.h @@ -0,0 +1,75 @@ + +#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_ */ diff --git a/version.lisp-expr b/version.lisp-expr index 78d07cc..71fcd84 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -18,4 +18,4 @@ ;;; 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" -- 1.7.10.4