Foreign callbacks
authorDavid Lichteblau <david@lichteblau.com>
Wed, 12 Dec 2012 13:30:52 +0000 (14:30 +0100)
committerDavid Lichteblau <david@lichteblau.com>
Fri, 21 Dec 2012 19:28:09 +0000 (20:28 +0100)
Allow alien callbacks to be invoked in pthreads created outside of
the Lisp runtime:

Add new runtime functions attach_os_thread, detach_os_thread
allowing such threads to acquire a `struct thread' temporarily,
turning them into Lisp threads.

In a main deviation from the Windows branch (which has a similar
feature), this mechanism does not involve user-land thread (fiber)
mechanisms to switch between stacks.  Instead, Lisp code merely runs
on the existing pthread's stack.

Currently a safepoint-only feature, because only safepoint-based
builds already go through a convenient trampoline function for
callbacks, but a backport of this feature to non-safepoint builds
might be straightforward.

package-data-list.lisp-expr
src/code/target-thread.lisp
src/code/thread.lisp
src/compiler/generic/parms.lisp
src/runtime/safepoint.c
src/runtime/thread.c
src/runtime/thread.h

index 8e96d24..03ab6ee 100644 (file)
@@ -2022,6 +2022,7 @@ is a good idea, but see SB-SYS re. blurring of boundaries."
                "THREAD-EMPHEMERAL-P"
                "THREAD-NAME"
                "THREAD-YIELD"
+               "FOREIGN-THREAD"
                ;; Memory barrier
                "BARRIER"
                ;; Mutexes
index c668eea..80e3fee 100644 (file)
@@ -1351,7 +1351,7 @@ have the foreground next."
 
 #!+sb-thread
 (defun initial-thread-function-trampoline
-    (thread setup-sem real-function arguments)
+    (thread setup-sem real-function arguments arg1 arg2 arg3)
   ;; In time we'll move some of the binding presently done in C here
   ;; too.
   ;;
@@ -1388,7 +1388,7 @@ have the foreground next."
       (with-session-lock (*session*)
         (push thread (session-threads *session*)))
       (setf (thread-%alive-p thread) t)
-      (signal-semaphore setup-sem)
+      (when setup-sem (signal-semaphore setup-sem))
       ;; Using handling-end-of-the-world would be a bit tricky
       ;; due to other catches and interrupts, so we essentially
       ;; re-implement it here. Once and only once more.
@@ -1400,14 +1400,17 @@ have the foreground next."
               (without-interrupts
                   (unwind-protect
                        (with-local-interrupts
-                           (sb!unix::unblock-deferrable-signals)
+                         (setf *gc-inhibit* nil) ;for foreign callbacks
+                         (sb!unix::unblock-deferrable-signals)
                          (setf (thread-result thread)
                                (prog1
                                    (cons t
                                          (multiple-value-list
                                           (unwind-protect
                                                (catch '%return-from-thread
-                                                 (apply real-function arguments))
+                                                 (if (listp arguments)
+                                                     (apply real-function arguments)
+                                                     (funcall real-function arg1 arg2 arg3)))
                                             (when *exit-in-process*
                                               (sb!impl::call-exit-hooks)))))
                                  #!+sb-safepoint
@@ -1457,7 +1460,7 @@ See also: RETURN-FROM-THREAD, ABORT-THREAD."
                  ;; As it is, this lambda must not cons until we are ready
                  ;; to run GC. Be very careful.
                  (initial-thread-function-trampoline
-                  thread setup-sem real-function arguments))))
+                  thread setup-sem real-function arguments nil nil nil))))
          ;; If the starting thread is stopped for gc before it signals the
          ;; semaphore then we'd be stuck.
          (assert (not *gc-inhibit*))
@@ -1514,6 +1517,12 @@ subject to change."
   "Deprecated. Same as TERMINATE-THREAD."
   (terminate-thread thread))
 
+#!+sb-safepoint
+(defun enter-foreign-callback (arg1 arg2 arg3)
+  (initial-thread-function-trampoline
+   (make-foreign-thread :name "foreign callback")
+   nil #'sb!alien::enter-alien-callback t arg1 arg2 arg3))
+
 (defmacro with-interruptions-lock ((thread) &body body)
   `(with-system-mutex ((thread-interruptions-lock ,thread))
      ,@body))
index e45fa64..2cfd567 100644 (file)
@@ -35,6 +35,13 @@ in future versions."
    :type mutex)
   waiting-for)
 
+(def!struct (foreign-thread
+             (:include thread)
+             (:conc-name "THREAD-"))
+  #!+sb-doc
+  "Type of native threads which are attached to the runtime as Lisp threads
+temporarily.")
+
 (def!struct mutex
   #!+sb-doc
   "Mutex type."
index abe0fba..ca556c2 100644 (file)
     sb!di::handle-single-step-trap
     fdefinition-object
     #!+win32 sb!kernel::handle-win32-exception
-    #!+sb-thruption sb!thread::run-interruption))
+    #!+sb-thruption sb!thread::run-interruption
+    #!+sb-safepoint sb!thread::enter-foreign-callback))
 
 (defparameter *common-static-symbols*
   '(t
index 8a34a08..a9e578c 100644 (file)
@@ -979,9 +979,17 @@ callback_wrapper_trampoline(
 #endif
     lispobj arg0, lispobj arg1, lispobj arg2)
 {
+#if defined(LISP_FEATURE_WIN32)
+    pthread_np_notice_thread();
+#endif
     struct thread* th = arch_os_get_current_thread();
-    if (!th)
-        lose("callback invoked in non-lisp thread.  Sorry, that is not supported yet.");
+    if (!th) {                  /* callback invoked in non-lisp thread */
+        init_thread_data scribble;
+        attach_os_thread(&scribble);
+        funcall3(StaticSymbolFunction(ENTER_FOREIGN_CALLBACK), arg0,arg1,arg2);
+        detach_os_thread(&scribble);
+        return;
+    }
 
 #ifdef LISP_FEATURE_WIN32
     /* arg2 is the pointer to a return value, which sits on the stack */
index 053f486..4d20d0f 100644 (file)
@@ -349,8 +349,9 @@ schedule_thread_post_mortem(struct thread *corpse)
 
 # endif /* !IMMEDIATE_POST_MORTEM */
 
+/* Note: scribble must be stack-allocated */
 static void
-init_new_thread(struct thread *th, init_thread_data *scribble)
+init_new_thread(struct thread *th, init_thread_data *scribble, int guardp)
 {
     int lock_ret;
 
@@ -361,7 +362,8 @@ init_new_thread(struct thread *th, init_thread_data *scribble)
     }
 
     th->os_thread=thread_self();
-    protect_control_stack_guard_page(1, NULL);
+    if (guardp)
+        protect_control_stack_guard_page(1, NULL);
     protect_binding_stack_guard_page(1, NULL);
     protect_alien_stack_guard_page(1, NULL);
     /* Since GC can only know about this thread from the all_threads
@@ -369,7 +371,7 @@ init_new_thread(struct thread *th, init_thread_data *scribble)
      * danger of deadlocking even with SIG_STOP_FOR_GC blocked (which
      * it is not). */
 #ifdef LISP_FEATURE_SB_SAFEPOINT
-    *th->csp_around_foreign_call = (lispobj)&lock_ret;
+    *th->csp_around_foreign_call = (lispobj)scribble;
 #endif
     lock_ret = pthread_mutex_lock(&all_threads_lock);
     gc_assert(lock_ret == 0);
@@ -449,6 +451,15 @@ undo_init_new_thread(struct thread *th, init_thread_data *scribble)
     TlsSetValue(OUR_TLS_INDEX,NULL);
 #endif
 
+    /* Undo the association of the current pthread to its `struct thread',
+     * such that we can call arch_os_get_current_thread() later in this
+     * thread and cleanly get back NULL. */
+#ifdef LISP_FEATURE_GCC_TLS
+    current_thread = NULL;
+#else
+    pthread_setspecific(specials, NULL);
+#endif
+
     schedule_thread_post_mortem(th);
 }
 
@@ -471,7 +482,7 @@ new_thread_trampoline(struct thread *th)
 
     lispobj function = th->no_tls_value_marker;
     th->no_tls_value_marker = NO_TLS_VALUE_MARKER_WIDETAG;
-    init_new_thread(th, &scribble);
+    init_new_thread(th, &scribble, 1);
     result = funcall0(function);
     undo_init_new_thread(th, &scribble);
 
@@ -479,6 +490,67 @@ new_thread_trampoline(struct thread *th)
     return result;
 }
 
+# ifdef LISP_FEATURE_SB_SAFEPOINT
+static struct thread *create_thread_struct(lispobj);
+
+void
+attach_os_thread(init_thread_data *scribble)
+{
+    os_thread_t os = pthread_self();
+    odxprint(misc, "attach_os_thread: attaching to %p", os);
+
+    struct thread *th = create_thread_struct(NIL);
+    block_deferrable_signals(0, &scribble->oldset);
+    th->no_tls_value_marker = NO_TLS_VALUE_MARKER_WIDETAG;
+    /* We don't actually want a pthread_attr here, but rather than add
+     * `if's to the post-mostem, let's just keep that code happy by
+     * keeping it initialized: */
+    pthread_attr_init(th->os_attr);
+
+#ifndef LISP_FEATURE_WIN32
+    /* On windows, arch_os_thread_init will take care of finding the
+     * stack. */
+    pthread_attr_t attr;
+    int pthread_getattr_np(pthread_t, pthread_attr_t *);
+    pthread_getattr_np(os, &attr);
+    void *stack_addr;
+    size_t stack_size;
+    pthread_attr_getstack(&attr, &stack_addr, &stack_size);
+    th->control_stack_start = stack_addr;
+    th->control_stack_end = (void *) (((uintptr_t) stack_addr) + stack_size);
+#endif
+
+    init_new_thread(th, scribble, 0);
+
+    /* We will be calling into Lisp soon, and the functions being called
+     * recklessly ignore the comment in target-thread which says that we
+     * must be careful to not cause GC while initializing a new thread.
+     * Since we first need to create a fresh thread object, it's really
+     * tempting to just perform such unsafe allocation though.  So let's
+     * at least try to suppress GC before consing, and hope that it
+     * works: */
+    SetSymbolValue(GC_INHIBIT, T, th);
+
+    uword_t stacksize
+        = (uword_t) th->control_stack_end - (uword_t) th->control_stack_start;
+    odxprint(misc, "attach_os_thread: attached %p as %p (0x%lx bytes stack)",
+             os, th, (long) stacksize);
+}
+
+void
+detach_os_thread(init_thread_data *scribble)
+{
+    struct thread *th = arch_os_get_current_thread();
+    odxprint(misc, "detach_os_thread: detaching");
+
+    undo_init_new_thread(th, scribble);
+
+    odxprint(misc, "deattach_os_thread: detached");
+    pthread_setspecific(lisp_thread, (void *)0);
+    thread_sigmask(SIG_SETMASK, &scribble->oldset, 0);
+}
+# endif /* safepoint */
+
 #endif /* LISP_FEATURE_SB_THREAD */
 
 static void
index dd36df5..8bde9ba 100644 (file)
@@ -338,10 +338,10 @@ extern kern_return_t mach_lisp_thread_destroy(struct thread *thread);
 #endif
 
 typedef struct init_thread_data {
+    sigset_t oldset;
 #ifdef LISP_FEATURE_SB_SAFEPOINT
     struct gcing_safety safety;
 #endif
-    void *dummy;
 } init_thread_data;
 
 #ifdef LISP_FEATURE_SB_SAFEPOINT
@@ -419,6 +419,9 @@ void pop_gcing_safety(struct gcing_safety *from)
 
 int check_pending_thruptions(os_context_t *ctx);
 
+void attach_os_thread(init_thread_data *);
+void detach_os_thread(init_thread_data *);
+
 #endif
 
 extern void create_initial_thread(lispobj);