Skip to content
This repository
  • 1 commit
  • 5 files changed
  • 0 comments
  • 1 contributor
Feb 27, 2003
Daniel Barlow New files 0ace89b
18  src/code/late-symbol.lisp
... ...
@@ -0,0 +1,18 @@
  1
+;;;; more code to manipulate symbols
  2
+;;;;
  3
+;;;; Many of these definitions are trivial interpreter entries to
  4
+;;;; functions open-coded by the compiler.
  5
+
  6
+;;;; This software is part of the SBCL system. See the README file for
  7
+;;;; more information.
  8
+;;;;
  9
+;;;; This software is derived from the CMU CL system, which was
  10
+;;;; written at Carnegie Mellon University and released into the
  11
+;;;; public domain. The software is in the public domain and is
  12
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  13
+;;;; files for more information.
  14
+
  15
+(in-package "SB!IMPL")
  16
+
  17
+(defun %set-symbol-value (symbol new-value)
  18
+  (%primitive set symbol new-value))
314  src/code/target-thread.lisp
... ...
@@ -0,0 +1,314 @@
  1
+(in-package "SB!THREAD")
  2
+
  3
+(sb!alien::define-alien-routine ("create_thread" %create-thread)
  4
+     sb!alien:unsigned-long
  5
+  (lisp-fun-address sb!alien:unsigned-long))
  6
+
  7
+(defun make-thread (function)
  8
+  (let ((real-function (coerce function 'function)))
  9
+    (%create-thread
  10
+     (sb!kernel:get-lisp-obj-address
  11
+      (lambda ()
  12
+	;; in time we'll move some of the binding presently done in C
  13
+	;; here too
  14
+	(let ((sb!kernel::*restart-clusters* nil))
  15
+	  ;; can't use handling-end-of-the-world, because that flushes
  16
+	  ;; output streams, and we don't necessarily have any (or we
  17
+	  ;; could be sharing them)
  18
+	  (sb!sys:enable-interrupt :sigint :ignore)
  19
+	  (sb!unix:unix-exit
  20
+	   (catch 'sb!impl::%end-of-the-world 
  21
+	     (with-simple-restart 
  22
+		 (destroy-thread
  23
+		  (format nil "~~@<Destroy this thread (~A)~~@:>"
  24
+			  (current-thread-id)))
  25
+	       (funcall real-function))
  26
+	     0))))))))
  27
+
  28
+
  29
+(defun destroy-thread (thread-id)
  30
+  (sb!unix:unix-kill thread-id :sigterm)
  31
+  ;; may have been stopped for some reason, so now wake it up to
  32
+  ;; deliver the TERM
  33
+  (sb!unix:unix-kill thread-id :sigcont))
  34
+
  35
+;; Conventional wisdom says that it's a bad idea to use these unless
  36
+;; you really need to.  Use a lock instead
  37
+(defun suspend-thread (thread-id)
  38
+  (sb!unix:unix-kill thread-id :sigstop))
  39
+(defun resume-thread (thread-id)
  40
+  (sb!unix:unix-kill thread-id :sigcont))
  41
+
  42
+(defun current-thread-id ()
  43
+  (sb!sys:sap-int
  44
+   (sb!vm::current-thread-offset-sap sb!vm::thread-pid-slot)))
  45
+
  46
+;;;; iterate over the in-memory threads
  47
+
  48
+(defun mapcar-threads (function)
  49
+  "Call FUNCTION once for each known thread, giving it the thread structure as argument"
  50
+  (let ((function (coerce function 'function)))
  51
+    (loop for thread = (alien-sap (extern-alien "all_threads" (* t)))
  52
+	  then  (sb!sys:sap-ref-sap thread (* 4 sb!vm::thread-next-slot))
  53
+	  until (sb!sys:sap= thread (sb!sys:int-sap 0))
  54
+	  collect (funcall function thread))))
  55
+
  56
+;;;; mutex and read/write locks
  57
+
  58
+;;; in true OOAOM style, this is also defined in C.  Don't change this
  59
+;;; defn without referring also to add_thread_to_queue
  60
+(defstruct mutex
  61
+  (name nil :type (or null simple-base-string))
  62
+  (value nil)
  63
+  (queuelock 0)
  64
+  (queue nil))
  65
+
  66
+;;; add_thread_to_queue needs to do lots of sigmask manipulation 
  67
+;;; which we don't have the right alien gubbins to do in lisp
  68
+(sb!alien:define-alien-routine
  69
+    ("add_thread_to_queue" add-thread-to-queue) void
  70
+  (pid int) (mutex system-area-pointer))
  71
+
  72
+;; spinlocks use 0 as "free" value: higher-level locks use NIL
  73
+(defun get-spinlock (lock offset new-value)
  74
+  (declare (optimize (speed 3) (safety 0)))
  75
+  (loop until
  76
+	(eql (sb!vm::%instance-set-conditional lock offset 0 new-value) 0)))
  77
+
  78
+(defun get-mutex (lock &optional new-value  timeout)
  79
+  (declare (type mutex lock))
  80
+  (let ((timeout (and timeout (+ (get-internal-real-time) timeout)))
  81
+	(pid (current-thread-id)))
  82
+    (unless new-value (setf new-value pid))
  83
+    (loop
  84
+     (unless
  85
+	 ;; args are object slot-num old-value new-value
  86
+	 (sb!vm::%instance-set-conditional lock 2 nil new-value)
  87
+       ;; success, remove us from the wait queue 
  88
+       (get-spinlock lock 3 pid)
  89
+       (when (eql (car (mutex-queue lock)) pid)
  90
+	 ;; ... if we were there
  91
+	 (setf (mutex-queue lock) (cdr (mutex-queue lock))))
  92
+       (setf (mutex-queuelock lock) 0)
  93
+       (return t))
  94
+     (add-thread-to-queue
  95
+      pid (sb!sys:int-sap (sb!kernel:get-lisp-obj-address lock))))))
  96
+
  97
+(defun release-mutex (lock &optional (new-value nil))
  98
+  (declare (type mutex lock))
  99
+  (let ((old-value (mutex-value lock))
  100
+	(pid (current-thread-id))
  101
+	(t1 nil))
  102
+    (loop
  103
+     (unless
  104
+	 ;; args are object slot-num old-value new-value
  105
+	 (eql old-value
  106
+	      (setf t1
  107
+		    (sb!vm::%instance-set-conditional lock 2 old-value new-value)))       
  108
+       (get-spinlock lock 3 pid)
  109
+       (when (mutex-queue lock)
  110
+	 (sb!unix:unix-kill (car (mutex-queue lock)) :sigalrm))
  111
+       (setf (mutex-queuelock lock) 0)
  112
+       (return t))
  113
+     (setf old-value t1))))
  114
+
  115
+;;;; multiple independent listeners
  116
+
  117
+(defvar *session-lock* nil)
  118
+
  119
+
  120
+
  121
+
  122
+
  123
+(defun make-listener-thread (tty-name)  
  124
+  (assert (probe-file tty-name))
  125
+  ;; FIXME probably still need to do some tty stuff to get signals
  126
+  ;; delivered correctly.
  127
+  ;; FIXME 
  128
+  (let* ((in (sb!unix:unix-open (namestring tty-name) sb!unix:o_rdwr #o666))
  129
+	 (out (sb!unix:unix-dup in))
  130
+	 (err (sb!unix:unix-dup in)))
  131
+    (labels ((thread-repl () 
  132
+	       (sb!unix::unix-setsid)
  133
+	       (let* ((*session-lock*
  134
+		       (make-mutex :name (format nil "lock for ~A" tty-name)))
  135
+		      (sb!impl::*stdin* 
  136
+		       (sb!sys:make-fd-stream in :input t :buffering :line))
  137
+		      (sb!impl::*stdout* 
  138
+		       (sb!sys:make-fd-stream out :output t :buffering :line))
  139
+		      (sb!impl::*stderr* 
  140
+		       (sb!sys:make-fd-stream err :output t :buffering :line))
  141
+		      (sb!impl::*tty* 
  142
+		       (sb!sys:make-fd-stream err :input t :output t :buffering :line))
  143
+		      (sb!impl::*descriptor-handlers* nil))
  144
+		 (get-mutex *session-lock*)
  145
+		 (sb!sys:enable-interrupt :sigint #'sb!unix::sigint-handler)
  146
+		 (unwind-protect
  147
+		      (sb!impl::toplevel-repl nil)
  148
+		   (sb!int:flush-standard-output-streams)))))
  149
+      (make-thread #'thread-repl))))
  150
+  
  151
+;;;; job control
  152
+
  153
+(defvar *background-threads-wait-for-debugger* t)
  154
+;;; may be T, NIL, or a function called with an fd-stream and thread id 
  155
+;;; as its two arguments, returning NIl or T
  156
+
  157
+;;; called from top of invoke-debugger
  158
+(defun debugger-wait-until-foreground-thread (stream)
  159
+  "Returns T if thread had been running in background, NIL if it was
  160
+already the foreground thread, or transfers control to the first applicable
  161
+restart if *BACKGROUND-THREADS-WAIT-FOR-DEBUGGER* says to do that instead"
  162
+  (let* ((wait-p *background-threads-wait-for-debugger*)
  163
+	 (*background-threads-wait-for-debugger* nil)
  164
+	 (fd-stream (sb!impl::get-underlying-stream stream :input))
  165
+	 (lock *session-lock*))
  166
+    (when (not (eql (mutex-value lock)   (CURRENT-THREAD-ID)))
  167
+      (when (functionp wait-p) 
  168
+	(setf wait-p 
  169
+	      (funcall wait-p fd-stream (CURRENT-THREAD-ID))))
  170
+      (cond (wait-p (get-foreground))
  171
+	    (t  (invoke-restart (car (compute-restarts))))))))
  172
+
  173
+;;; install this with (setf SB!INT:*REPL-PROMPT-FUN* #'thread-prompt-fun)
  174
+;;; One day it will be default
  175
+(defun thread-repl-prompt-fun (in-stream out-stream)
  176
+  (let ((lock *session-lock*))
  177
+    (get-foreground)
  178
+    (let ((stopped-threads (mutex-queue lock)))
  179
+      (when stopped-threads
  180
+	(format out-stream "~{~&Thread ~A suspended~}~%" stopped-threads))
  181
+      (sb!impl::repl-prompt-fun in-stream out-stream))))
  182
+
  183
+
  184
+
  185
+(defstruct rwlock
  186
+  (name nil :type (or null simple-base-string))
  187
+  (value 0 :type fixnum)
  188
+  (max-readers nil :type (or fixnum null))
  189
+  (max-writers 1 :type fixnum))
  190
+#+nil
  191
+(macrolet
  192
+    ((make-rwlocking-function (lock-fn unlock-fn increment limit test)
  193
+       (let ((do-update '(when (eql old-value
  194
+				(sb!vm::%instance-set-conditional
  195
+				 lock 2 old-value new-value))
  196
+			  (return (values t old-value))))
  197
+	     (vars `((timeout (and timeout (+ (get-internal-real-time) timeout)))
  198
+		     old-value
  199
+		     new-value
  200
+		     (limit ,limit))))
  201
+	 (labels ((do-setfs (v) `(setf old-value (rwlock-value lock)
  202
+				  new-value (,v old-value ,increment))))
  203
+	   `(progn
  204
+	     (defun ,lock-fn (lock timeout)
  205
+	       (declare (type rwlock lock))
  206
+	       (let ,vars
  207
+		 (loop
  208
+		  ,(do-setfs '+)
  209
+		  (when ,test
  210
+		    ,do-update)
  211
+		  (when (sleep-a-bit timeout) (return nil)) ;expired
  212
+		  )))
  213
+	     ;; unlock doesn't need timeout or test-in-range
  214
+	     (defun ,unlock-fn (lock)
  215
+	       (declare (type rwlock lock))
  216
+	       (declare (ignorable limit))
  217
+	       (let ,(cdr vars)
  218
+		 (loop
  219
+		  ,(do-setfs '-)
  220
+		  ,do-update))))))))
  221
+    
  222
+  (make-rwlocking-function %lock-for-reading %unlock-for-reading 1
  223
+			   (rwlock-max-readers lock)
  224
+			   (and (>= old-value 0)
  225
+				(or (null limit) (<= new-value limit))))
  226
+  (make-rwlocking-function %lock-for-writing %unlock-for-writing -1
  227
+			   (- (rwlock-max-writers lock))
  228
+			   (and (<= old-value 0)
  229
+				(>= new-value limit))))
  230
+#+nil  
  231
+(defun get-rwlock (lock direction &optional timeout)
  232
+  (ecase direction
  233
+    (:read (%lock-for-reading lock timeout))
  234
+    (:write (%lock-for-writing lock timeout))))
  235
+#+nil
  236
+(defun free-rwlock (lock direction)
  237
+  (ecase direction
  238
+    (:read (%unlock-for-reading lock))
  239
+    (:write (%unlock-for-writing lock))))
  240
+
  241
+;;;; beyond this point all is commented.
  242
+
  243
+;;; Lock-Wait-With-Timeout  --  Internal
  244
+;;;
  245
+;;; Wait with a timeout for the lock to be free and acquire it for the
  246
+;;; *current-process*.
  247
+;;;
  248
+#+nil
  249
+(defun lock-wait-with-timeout (lock whostate timeout)
  250
+  (declare (type lock lock))
  251
+  (process-wait-with-timeout
  252
+   whostate timeout
  253
+   #'(lambda ()
  254
+       (declare (optimize (speed 3)))
  255
+       #-i486
  256
+       (unless (lock-process lock)
  257
+	 (setf (lock-process lock) *current-process*))
  258
+       #+i486
  259
+       (null (kernel:%instance-set-conditional
  260
+	      lock 2 nil *current-process*)))))
  261
+
  262
+;;; With-Lock-Held  --  Public
  263
+;;;
  264
+#+nil
  265
+(defmacro with-lock-held ((lock &optional (whostate "Lock Wait")
  266
+				&key (wait t) timeout)
  267
+			  &body body)
  268
+  "Execute the body with the lock held. If the lock is held by another
  269
+  process then the current process waits until the lock is released or
  270
+  an optional timeout is reached. The optional wait timeout is a time in
  271
+  seconds acceptable to process-wait-with-timeout.  The results of the
  272
+  body are return upon success and NIL is return if the timeout is
  273
+  reached. When the wait key is NIL and the lock is held by another
  274
+  process then NIL is return immediately without processing the body."
  275
+  (let ((have-lock (gensym)))
  276
+    `(let ((,have-lock (eq (lock-process ,lock) *current-process*)))
  277
+      (unwind-protect
  278
+	   ,(cond ((and timeout wait)
  279
+		   `(progn
  280
+		      (when (and (error-check-lock-p ,lock) ,have-lock)
  281
+			(error "Dead lock"))
  282
+		      (when (or ,have-lock
  283
+				 #+i486 (null (kernel:%instance-set-conditional
  284
+					       ,lock 2 nil *current-process*))
  285
+				 #-i486 (seize-lock ,lock)
  286
+				 (if ,timeout
  287
+				     (lock-wait-with-timeout
  288
+				      ,lock ,whostate ,timeout)
  289
+				     (lock-wait ,lock ,whostate)))
  290
+			,@body)))
  291
+		  (wait
  292
+		   `(progn
  293
+		      (when (and (error-check-lock-p ,lock) ,have-lock)
  294
+		        (error "Dead lock"))
  295
+		      (unless (or ,have-lock
  296
+				 #+i486 (null (kernel:%instance-set-conditional
  297
+					       ,lock 2 nil *current-process*))
  298
+				 #-i486 (seize-lock ,lock))
  299
+			(lock-wait ,lock ,whostate))
  300
+		      ,@body))
  301
+		  (t
  302
+		   `(when (or (and (recursive-lock-p ,lock) ,have-lock)
  303
+			      #+i486 (null (kernel:%instance-set-conditional
  304
+					    ,lock 2 nil *current-process*))
  305
+			      #-i486 (seize-lock ,lock))
  306
+		      ,@body)))
  307
+	(unless ,have-lock
  308
+	  #+i486 (kernel:%instance-set-conditional
  309
+		  ,lock 2 *current-process* nil)
  310
+	  #-i486 (when (eq (lock-process ,lock) *current-process*)
  311
+		   (setf (lock-process ,lock) nil)))))))
  312
+
  313
+
  314
+
31  src/code/thread.lisp
... ...
@@ -0,0 +1,31 @@
  1
+(in-package :sb!thread)
  2
+
  3
+#+sb-xc-host
  4
+(defun make-mutex (&key name value) nil)
  5
+
  6
+#+sb-xc-host
  7
+(defmacro with-recursive-lock ((mutex) &body body)
  8
+  `(progn ,@body))
  9
+
  10
+#-sb-xc-host
  11
+(defmacro with-recursive-lock ((mutex) &body body)
  12
+  (let ((cfp (gensym "CFP")))
  13
+    `(let ((,cfp (ash (sb!sys:sap-int (sb!vm::current-fp) ) -2)))
  14
+      (unless (and (mutex-value ,mutex)
  15
+		   (SB!DI::control-stack-pointer-valid-p
  16
+		    (sb!sys:int-sap (ash (mutex-value ,mutex) 2))))
  17
+	(get-mutex ,mutex ,cfp))
  18
+      (unwind-protect
  19
+	   (progn ,@body)
  20
+	(when (eql (mutex-value ,mutex) ,cfp) (release-mutex ,mutex))))))
  21
+
  22
+(defun get-foreground ()
  23
+  (when (not (eql (mutex-value *session-lock*)  (CURRENT-THREAD-ID)))
  24
+    (get-mutex *session-lock*))
  25
+  (sb!sys:enable-interrupt :sigint #'sb!unix::sigint-handler)
  26
+  t)
  27
+
  28
+(defun release-foreground ()
  29
+  (sb!sys:enable-interrupt :sigint :ignore)
  30
+  (release-mutex *session-lock*)
  31
+  t)
243  src/runtime/thread.c
... ...
@@ -0,0 +1,243 @@
  1
+#include <stdlib.h>
  2
+#include <stdio.h>
  3
+#include <sched.h>
  4
+#include <stddef.h>
  5
+#ifndef CLONE_PARENT		/* lameass glibc 2.2  doesn't define this */
  6
+#define CLONE_PARENT 0x00008000	/* even though the manpage documents it */
  7
+#endif
  8
+#include "runtime.h"
  9
+#include "sbcl.h"
  10
+#include "validate.h"		/* for CONTROL_STACK_SIZE etc */
  11
+#include "thread.h"
  12
+#include "arch.h"
  13
+#include "target-arch-os.h"
  14
+#include "os.h"
  15
+#include "globals.h"
  16
+#ifdef LISP_FEATURE_GENCGC
  17
+#include "gencgc.h"
  18
+#endif
  19
+#include "dynbind.h"
  20
+#include "genesis/cons.h"
  21
+#define ALIEN_STACK_SIZE (1*1024*1024) /* 1Mb size chosen at random */
  22
+
  23
+int dynamic_values_bytes=4096*sizeof(lispobj);	/* same for all threads */
  24
+struct thread *all_threads;
  25
+lispobj all_threads_lock;
  26
+extern struct interrupt_data * global_interrupt_data;
  27
+
  28
+void get_spinlock(lispobj *word,int value);
  29
+
  30
+/* this is the first thing that clone() runs in the child (which is
  31
+ * why the silly calling convention).  Basically it calls the user's
  32
+ * requested lisp function after doing arch_os_thread_init and
  33
+ * whatever other bookkeeping needs to be done
  34
+ */
  35
+
  36
+/* set go to 0 to stop the thread before it starts.  Convenient if you
  37
+* want to attach a debugger to it before it does anything */
  38
+volatile int go=1;		
  39
+
  40
+int
  41
+new_thread_trampoline(struct thread *th)
  42
+{
  43
+    lispobj function;
  44
+    function = th->unbound_marker;
  45
+    if(go==0) {
  46
+	fprintf(stderr, "/pausing 0x%lx(%d,%d) before new_thread_trampoline(0x%lx)\n",
  47
+		(unsigned long)th,th->pid,getpid(),(unsigned long)function);
  48
+	while(go==0) ;
  49
+	fprintf(stderr, "/continue\n");
  50
+    }
  51
+    th->unbound_marker = UNBOUND_MARKER_WIDETAG;
  52
+    /* wait here until our thread is linked into all_threads: see below */
  53
+    while(th->pid<1) sched_yield();
  54
+
  55
+    if(arch_os_thread_init(th)==0) 
  56
+	return 1;		/* failure.  no, really */
  57
+    return funcall0(function);
  58
+}
  59
+
  60
+/* this is called from any other thread to create the new one, and
  61
+ * initialize all parts of it that can be initialized from another 
  62
+ * thread 
  63
+ */
  64
+
  65
+pid_t create_thread(lispobj initial_function) {
  66
+    union per_thread_data *per_thread;
  67
+    struct thread *th=0;	/*  subdue gcc */
  68
+    void *spaces=0;
  69
+    pid_t kid_pid;
  70
+
  71
+    /* may as well allocate all the spaces at once: it saves us from
  72
+     * having to decide what to do if only some of the allocations
  73
+     * succeed */
  74
+    spaces=os_validate(0,
  75
+		       THREAD_CONTROL_STACK_SIZE+
  76
+		       BINDING_STACK_SIZE+
  77
+		       ALIEN_STACK_SIZE+
  78
+		       dynamic_values_bytes+
  79
+		       32*SIGSTKSZ
  80
+		       );
  81
+    if(!spaces) goto cleanup;
  82
+    per_thread=(union per_thread_data *)
  83
+	(spaces+
  84
+	 THREAD_CONTROL_STACK_SIZE+
  85
+	 BINDING_STACK_SIZE+
  86
+	 ALIEN_STACK_SIZE);
  87
+
  88
+    th=&per_thread->thread;
  89
+    if(all_threads) {
  90
+	memcpy(per_thread,arch_os_get_current_thread(),
  91
+	       dynamic_values_bytes);
  92
+    } else {
  93
+	int i;
  94
+	for(i=0;i<(dynamic_values_bytes/sizeof(lispobj));i++)
  95
+	    per_thread->dynamic_values[i]=UNBOUND_MARKER_WIDETAG;
  96
+	if(SymbolValue(FREE_TLS_INDEX,0)==UNBOUND_MARKER_WIDETAG) 
  97
+	    SetSymbolValue
  98
+		(FREE_TLS_INDEX,
  99
+		 make_fixnum(MAX_INTERRUPTS+
  100
+			     sizeof(struct thread)/sizeof(lispobj)),
  101
+		 0);
  102
+#define STATIC_TLS_INIT(sym,field) \
  103
+  ((struct symbol *)(sym-OTHER_POINTER_LOWTAG))->tls_index= \
  104
+  make_fixnum(THREAD_SLOT_OFFSET_WORDS(field))
  105
+				  
  106
+	STATIC_TLS_INIT(BINDING_STACK_START,binding_stack_start);
  107
+	STATIC_TLS_INIT(BINDING_STACK_POINTER,binding_stack_pointer);
  108
+	STATIC_TLS_INIT(CONTROL_STACK_START,control_stack_start);
  109
+	STATIC_TLS_INIT(ALIEN_STACK,alien_stack_pointer);
  110
+	STATIC_TLS_INIT(PSEUDO_ATOMIC_ATOMIC,pseudo_atomic_atomic);
  111
+	STATIC_TLS_INIT(PSEUDO_ATOMIC_INTERRUPTED,pseudo_atomic_interrupted);
  112
+#undef STATIC_TLS_INIT
  113
+    }
  114
+
  115
+    th->control_stack_start = spaces;
  116
+    th->binding_stack_start=
  117
+	(lispobj*)((void*)th->control_stack_start+THREAD_CONTROL_STACK_SIZE);
  118
+    th->alien_stack_start=
  119
+	(lispobj*)((void*)th->binding_stack_start+BINDING_STACK_SIZE);
  120
+    th->binding_stack_pointer=th->binding_stack_start;
  121
+    th->this=th;
  122
+    th->pid=0;
  123
+#ifdef LISP_FEATURE_STACK_GROWS_DOWNWARD_NOT_UPWARD
  124
+    th->alien_stack_pointer=((void *)th->alien_stack_start
  125
+			     + ALIEN_STACK_SIZE-4); /* naked 4.  FIXME */
  126
+#else
  127
+    th->alien_stack_pointer=((void *)th->alien_stack_start);
  128
+#endif
  129
+    th->pseudo_atomic_interrupted=0;
  130
+    /* runtime.c used to set PSEUDO_ATOMIC_ATOMIC =1 globally.  I'm not
  131
+     * sure why, but it appears to help */
  132
+    th->pseudo_atomic_atomic=make_fixnum(1);
  133
+    gc_set_region_empty(&th->alloc_region);
  134
+    
  135
+    bind_variable(CURRENT_CATCH_BLOCK,make_fixnum(0),th);
  136
+    bind_variable(CURRENT_UNWIND_PROTECT_BLOCK,make_fixnum(0),th); 
  137
+    bind_variable(FREE_INTERRUPT_CONTEXT_INDEX,make_fixnum(0),th);
  138
+    bind_variable(INTERRUPT_PENDING, NIL,th);
  139
+    bind_variable(INTERRUPTS_ENABLED,T,th);
  140
+
  141
+    th->interrupt_data=malloc(sizeof (struct interrupt_data));
  142
+    if(all_threads) 
  143
+	memcpy(th->interrupt_data,arch_os_get_current_thread()->interrupt_data,
  144
+	       sizeof (struct interrupt_data));
  145
+    else 
  146
+	memcpy(th->interrupt_data,global_interrupt_data,
  147
+	       sizeof (struct interrupt_data));
  148
+
  149
+
  150
+#if defined(LISP_FEATURE_X86) && defined (LISP_FEATURE_LINUX)
  151
+    th->unbound_marker=initial_function;
  152
+    kid_pid=
  153
+	clone(new_thread_trampoline,
  154
+	      (((void*)th->control_stack_start)+THREAD_CONTROL_STACK_SIZE-4),
  155
+	      (((getpid()!=parent_pid)?(CLONE_PARENT):0)
  156
+	       |SIGALRM|CLONE_VM),th);
  157
+    if(kid_pid<=0) 
  158
+	goto cleanup;
  159
+#else
  160
+#error this stuff presently only works on x86 Linux
  161
+#endif
  162
+
  163
+    get_spinlock(&all_threads_lock,kid_pid);
  164
+    th->next=all_threads;
  165
+    all_threads=th;
  166
+    /* note that th->pid is 0 at this time.  We rely on all_threads_lock
  167
+     * to ensure that we don't have >1 thread with pid=0 on the list at once
  168
+     */
  169
+    protect_control_stack_guard_page(th->pid,1);
  170
+    all_threads_lock=0;
  171
+    th->pid=kid_pid;		/* child will not start until this is set */
  172
+    return th->pid;
  173
+ cleanup:
  174
+    /* if(th && th->tls_cookie>=0) os_free_tls_pointer(th); */
  175
+    if(spaces) os_invalidate(spaces,
  176
+			     THREAD_CONTROL_STACK_SIZE+BINDING_STACK_SIZE+
  177
+			     ALIEN_STACK_SIZE+dynamic_values_bytes);
  178
+    return 0;
  179
+}
  180
+
  181
+void destroy_thread (struct thread *th)
  182
+{
  183
+    /* precondition: the unix task has already been killed and exited.
  184
+     * This is called by the parent */
  185
+    gc_alloc_update_page_tables(0, &th->alloc_region);
  186
+    get_spinlock(&all_threads_lock,th->pid);
  187
+    if(th==all_threads) 
  188
+	all_threads=th->next;
  189
+    else {
  190
+	struct thread *th1=all_threads;
  191
+	while(th1->next!=th) th1=th1->next;
  192
+	th1->next=th->next;	/* unlink */
  193
+    }
  194
+    all_threads_lock=0;
  195
+    /* if(th && th->tls_cookie>=0) os_free_tls_pointer(th); */
  196
+    os_invalidate((os_vm_address_t) th->control_stack_start,
  197
+		  THREAD_CONTROL_STACK_SIZE+BINDING_STACK_SIZE+
  198
+		  ALIEN_STACK_SIZE+dynamic_values_bytes+
  199
+		  32*SIGSTKSZ);
  200
+}
  201
+
  202
+
  203
+struct thread *find_thread_by_pid(pid_t pid) 
  204
+{
  205
+    struct thread *th;
  206
+    for_each_thread(th)
  207
+	if(th->pid==pid) return th;
  208
+    return 0;
  209
+}
  210
+
  211
+
  212
+struct mutex {
  213
+    lispobj header,type,*name,*value,queuelock, *queue;
  214
+};
  215
+
  216
+void get_spinlock(lispobj *word,int value)
  217
+{
  218
+    u32 new_val=0;
  219
+    do {
  220
+	asm ("xor %0,%0;cmpxchg %1,%2" 
  221
+	     : "=a" (new_val)
  222
+	     : "r" (value), "m" (word)
  223
+	     : "memory", "cc");
  224
+    } while(new_val==0);
  225
+}
  226
+
  227
+void add_thread_to_queue(int pid, lispobj mutex_p)
  228
+{
  229
+    sigset_t oldset,newset;
  230
+    struct mutex *mutex=(struct mutex *)native_pointer(mutex_p);
  231
+    struct cons *cons;
  232
+    sigemptyset(&newset);
  233
+    sigaddset(&newset,SIGALRM);
  234
+    sigprocmask(SIG_BLOCK, &newset, &oldset);
  235
+    
  236
+    get_spinlock(&(mutex->queuelock),pid);
  237
+    cons=alloc_cons(make_fixnum(pid),mutex->queue);
  238
+    mutex->queue=cons;
  239
+    mutex->queuelock=0;
  240
+    sigwaitinfo(&newset,0);
  241
+    sigprocmask(SIG_SETMASK,&oldset,0);
  242
+}
  243
+
75  src/runtime/thread.h
... ...
@@ -0,0 +1,75 @@
  1
+
  2
+#if !defined(_INCLUDE_THREAD_H_)
  3
+#define _INCLUDE_THREAD_H_
  4
+
  5
+#include <sys/types.h>
  6
+#include <unistd.h>
  7
+#include "runtime.h"
  8
+#include "sbcl.h"
  9
+#include "os.h"
  10
+#include "interrupt.h"
  11
+#ifdef LISP_FEATURE_GENCGC
  12
+#include "gencgc-alloc-region.h"
  13
+#else
  14
+#error "threading doesn't work with cheney gc yet"
  15
+#endif
  16
+#include "genesis/symbol.h"
  17
+#include "genesis/static-symbols.h"
  18
+#include "genesis/thread.h"
  19
+
  20
+#define THREAD_SLOT_OFFSET_WORDS(c) \
  21
+ (offsetof(struct thread,c)/(sizeof (struct thread *)))
  22
+
  23
+union per_thread_data {
  24
+    struct thread thread;
  25
+    lispobj dynamic_values[1];	/* actually more like 4000 or so */
  26
+};
  27
+
  28
+extern struct thread *all_threads;
  29
+extern int dynamic_values_bytes;
  30
+extern struct thread *find_thread_by_pid(pid_t pid);
  31
+
  32
+#define for_each_thread(th) for(th=all_threads;th;th=th->next)
  33
+
  34
+static inline lispobj SymbolValue(u32 tagged_symbol_pointer, void *thread) {
  35
+    struct symbol *sym= (struct symbol *)
  36
+	(tagged_symbol_pointer-OTHER_POINTER_LOWTAG);
  37
+    if(thread && sym->tls_index) {
  38
+	lispobj r=
  39
+	    ((union per_thread_data *)thread)
  40
+	    ->dynamic_values[fixnum_value(sym->tls_index)];
  41
+	if(r!=UNBOUND_MARKER_WIDETAG) return r;
  42
+    }
  43
+    return sym->value;
  44
+}
  45
+static inline lispobj SymbolTlValue(u32 tagged_symbol_pointer, void *thread) {
  46
+    struct symbol *sym= (struct symbol *)
  47
+	(tagged_symbol_pointer-OTHER_POINTER_LOWTAG);
  48
+    return ((union per_thread_data *)thread)
  49
+	->dynamic_values[fixnum_value(sym->tls_index)];
  50
+}
  51
+
  52
+static inline void SetSymbolValue(u32 tagged_symbol_pointer,lispobj val, void *thread) {
  53
+    struct symbol *sym=	(struct symbol *)
  54
+	(tagged_symbol_pointer-OTHER_POINTER_LOWTAG);
  55
+    if(thread && sym->tls_index) {
  56
+	lispobj *pr= &(((union per_thread_data *)thread)
  57
+		       ->dynamic_values[fixnum_value(sym->tls_index)]);
  58
+	if(*pr!= UNBOUND_MARKER_WIDETAG) {
  59
+	    *pr=val;
  60
+	    return;
  61
+	}
  62
+    }
  63
+    sym->value = val;
  64
+}
  65
+static inline void SetTlSymbolValue(u32 tagged_symbol_pointer,lispobj val, void *thread) {
  66
+    struct symbol *sym=	(struct symbol *)
  67
+	(tagged_symbol_pointer-OTHER_POINTER_LOWTAG);
  68
+    ((union per_thread_data *)thread)
  69
+	->dynamic_values[fixnum_value(sym->tls_index)]
  70
+	=val;
  71
+}
  72
+
  73
+    
  74
+
  75
+#endif /* _INCLUDE_THREAD_H_ */

No commit comments for this range

Something went wrong with that request. Please try again.