Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

New files

  • Loading branch information...
commit 0ace89b82aa6a1683fedf6f1fadbc2dca4666e03 1 parent 3bb2fb5
@telent telent authored
View
18 src/code/late-symbol.lisp
@@ -0,0 +1,18 @@
+;;;; more code to manipulate symbols
+;;;;
+;;;; Many of these definitions are trivial interpreter entries to
+;;;; functions open-coded by the compiler.
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!IMPL")
+
+(defun %set-symbol-value (symbol new-value)
+ (%primitive set symbol new-value))
View
314 src/code/target-thread.lisp
@@ -0,0 +1,314 @@
+(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))
+ ;; 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 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))))
+
+;;;; mutex and read/write locks
+
+;;; in true OOAOM style, this is also defined in C. Don't change this
+;;; defn without referring also to add_thread_to_queue
+(defstruct mutex
+ (name nil :type (or null simple-base-string))
+ (value nil)
+ (queuelock 0)
+ (queue nil))
+
+;;; add_thread_to_queue needs to do lots of sigmask manipulation
+;;; which we don't have the right alien gubbins to do in lisp
+(sb!alien:define-alien-routine
+ ("add_thread_to_queue" add-thread-to-queue) void
+ (pid int) (mutex system-area-pointer))
+
+;; 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)))
+
+(defun get-mutex (lock &optional new-value timeout)
+ (declare (type mutex lock))
+ (let ((timeout (and timeout (+ (get-internal-real-time) timeout)))
+ (pid (current-thread-id)))
+ (unless new-value (setf new-value pid))
+ (loop
+ (unless
+ ;; args are object slot-num old-value new-value
+ (sb!vm::%instance-set-conditional lock 2 nil new-value)
+ ;; success, remove us from the wait queue
+ (get-spinlock lock 3 pid)
+ (when (eql (car (mutex-queue lock)) pid)
+ ;; ... if we were there
+ (setf (mutex-queue lock) (cdr (mutex-queue lock))))
+ (setf (mutex-queuelock lock) 0)
+ (return t))
+ (add-thread-to-queue
+ pid (sb!sys:int-sap (sb!kernel:get-lisp-obj-address lock))))))
+
+(defun release-mutex (lock &optional (new-value nil))
+ (declare (type mutex lock))
+ (let ((old-value (mutex-value lock))
+ (pid (current-thread-id))
+ (t1 nil))
+ (loop
+ (unless
+ ;; args are object slot-num old-value new-value
+ (eql old-value
+ (setf t1
+ (sb!vm::%instance-set-conditional lock 2 old-value new-value)))
+ (get-spinlock lock 3 pid)
+ (when (mutex-queue lock)
+ (sb!unix:unix-kill (car (mutex-queue lock)) :sigalrm))
+ (setf (mutex-queuelock lock) 0)
+ (return t))
+ (setf old-value t1))))
+
+;;;; 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 (in-stream out-stream)
+ (let ((lock *session-lock*))
+ (get-foreground)
+ (let ((stopped-threads (mutex-queue lock)))
+ (when stopped-threads
+ (format out-stream "~{~&Thread ~A suspended~}~%" stopped-threads))
+ (sb!impl::repl-prompt-fun in-stream out-stream))))
+
+
+
+(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)))))))
+
+
+
View
31 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)
View
243 src/runtime/thread.c
@@ -0,0 +1,243 @@
+#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)
+ |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) os_free_tls_pointer(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;
+}
+
+
+struct mutex {
+ lispobj header,type,*name,*value,queuelock, *queue;
+};
+
+void get_spinlock(lispobj *word,int value)
+{
+ u32 new_val=0;
+ do {
+ asm ("xor %0,%0;cmpxchg %1,%2"
+ : "=a" (new_val)
+ : "r" (value), "m" (word)
+ : "memory", "cc");
+ } while(new_val==0);
+}
+
+void add_thread_to_queue(int pid, lispobj mutex_p)
+{
+ sigset_t oldset,newset;
+ struct mutex *mutex=(struct mutex *)native_pointer(mutex_p);
+ struct cons *cons;
+ sigemptyset(&newset);
+ sigaddset(&newset,SIGALRM);
+ sigprocmask(SIG_BLOCK, &newset, &oldset);
+
+ get_spinlock(&(mutex->queuelock),pid);
+ cons=alloc_cons(make_fixnum(pid),mutex->queue);
+ mutex->queue=cons;
+ mutex->queuelock=0;
+ sigwaitinfo(&newset,0);
+ sigprocmask(SIG_SETMASK,&oldset,0);
+}
+
View
75 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_ */
Please sign in to comment.
Something went wrong with that request. Please try again.