X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=inline;f=src%2Fcode%2Ftarget-thread.lisp;h=a79774155218aaa0fd2ba4e66e0a8b035429d70b;hb=076d38141d1d2689a1040dc8af71bd7fbf2b54a4;hp=c668eeacdcf1c8a50d64e7f698e348182e8946c7;hpb=789406b1a4f6d546f426eb4f51aa6a10d432c4dd;p=sbcl.git

diff --git a/src/code/target-thread.lisp b/src/code/target-thread.lisp
index c668eea..a797741 100644
--- a/src/code/target-thread.lisp
+++ b/src/code/target-thread.lisp
@@ -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.
   ;;
@@ -1384,11 +1384,11 @@ have the foreground next."
     (setf (thread-os-thread thread) (current-thread-os-thread))
     (with-mutex ((thread-result-lock thread))
       (with-all-threads-lock
-          (push thread *all-threads*))
+        (push thread *all-threads*))
       (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
@@ -1446,32 +1449,31 @@ See also: RETURN-FROM-THREAD, ABORT-THREAD."
                        'make-thread arguments)
   #!+sb-thread
   (let ((thread (%make-thread :name name :%ephemeral-p ephemeral)))
-     (with-mutex (*make-thread-lock*)
-       (let* ((setup-sem (make-semaphore :name "Thread setup semaphore"))
-              (real-function (coerce function 'function))
-              (arguments     (if (listp arguments)
-                                 arguments
-                                 (list arguments)))
-              (initial-function
-               (named-lambda initial-thread-function ()
-                 ;; 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))))
-         ;; If the starting thread is stopped for gc before it signals the
-         ;; semaphore then we'd be stuck.
-         (assert (not *gc-inhibit*))
-         ;; Keep INITIAL-FUNCTION pinned until the child thread is
-         ;; initialized properly. Wrap the whole thing in
-         ;; WITHOUT-INTERRUPTS because we pass INITIAL-FUNCTION to another
-         ;; thread.
-         (without-interrupts
-           (with-pinned-objects (initial-function)
-             (if (zerop
-                  (%create-thread (get-lisp-obj-address initial-function)))
-                 (setf thread nil)
-                 (wait-on-semaphore setup-sem))))))
-     (or thread (error "Could not create a new thread."))))
+    (let* ((setup-sem (make-semaphore :name "Thread setup semaphore"))
+           (real-function (coerce function 'function))
+           (arguments     (if (listp arguments)
+                              arguments
+                              (list arguments)))
+           (initial-function
+             (named-lambda initial-thread-function ()
+               ;; 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 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*))
+      ;; Keep INITIAL-FUNCTION pinned until the child thread is
+      ;; initialized properly. Wrap the whole thing in
+      ;; WITHOUT-INTERRUPTS because we pass INITIAL-FUNCTION to
+      ;; another thread.
+      (with-system-mutex (*make-thread-lock*)
+        (with-pinned-objects (initial-function)
+          (if (zerop
+               (%create-thread (get-lisp-obj-address initial-function)))
+              (setf thread nil)
+              (wait-on-semaphore setup-sem)))))
+    (or thread (error "Could not create a new thread."))))
 
 (defun join-thread (thread &key (default nil defaultp) timeout)
   #!+sb-doc
@@ -1514,6 +1516,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))