;;; this is appalling misuse of asdf. please don't treat it as any
;;; kind of example. this shouldn't be a compile-op, or if it is, should
-;;; define output-files properly instead oif leaving it be the fasl
+;;; define output-files properly instead of leaving it be the fasl
(defclass exe-file (cl-source-file) ())
(defmethod perform :after ((o compile-op) (c exe-file))
(sb-executable:make-executable
:use ("CL" "SB!ALIEN" "SB!INT")
:doc "public (but low-level): native thread support"
:export ("MAKE-THREAD"
- "MAKE-LISTENER-THREAD" "DESTROY-THREAD" "WITH-RECURSIVE-LOCK"
+ "MAKE-LISTENER-THREAD" "DESTROY-THREAD" "TERMINATE-THREAD"
+ "INTERRUPT-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"))
"undefined function"))
(:foreign-function
(make-bogus-debug-fun
- "foreign function call land"))
+ (format nil "foreign function call land: ra=#x~X"
+ (sap-int ra))))
((nil)
(make-bogus-debug-fun
"bogus stack frame"))
"undefined function"))
(:foreign-function
(make-bogus-debug-fun
- "foreign function call land"))
+ (format nil "foreign function call land: ra=#x~X"
+ (sap-int ra))))
((nil)
(make-bogus-debug-fun
"bogus stack frame"))
(funcall real-function))
0))))))))
+;;; 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))
+;;; Note warning about cleanup forms
(defun destroy-thread (thread-id)
+ "Destroy the thread identified by THREAD-ID abruptly, without running cleanup forms"
(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))
+
+;;; a moderate degree of care is expected for use of interrupt-thread,
+;;; due to its nature: if you interrupt a thread that was holding
+;;; important locks then do something that turns out to need those
+;;; locks, you probably won't like the effect. Used with thought
+;;; though, it's a good deal gentler than the last-resort functions above
+
+(defun interrupt-thread (thread function)
+ "Interrupt THREAD and make it run FUNCTION. "
+ (sb!unix::syscall* ("interrupt_thread"
+ sb!alien:unsigned-long sb!alien:unsigned-long)
+ thread
+ thread (sb!kernel:get-lisp-obj-address
+ (coerce function 'function))))
+(defun terminate-thread (thread-id)
+ "Terminate the thread identified by THREAD-ID, by causing it to run
+SB-EXT:QUIT - the usual cleanup forms will be evaluated"
+ (interrupt-thread thread-id 'sb!ext:quit))
+
(defun current-thread-id ()
(sb!sys:sap-int
(cond (wait-p (get-foreground))
(t (invoke-restart (car (compute-restarts))))))))
-;;; install this with (setf SB!INT:*REPL-PROMPT-FUN* #'thread-prompt-fun)
+;;; install this with
+;;; (setf SB-INT:*REPL-PROMPT-FUN* #'sb-thread::thread-repl-prompt-fun)
;;; One day it will be default
(defun thread-repl-prompt-fun (out-stream)
(let ((lock *session-lock*))
}
#endif
-/* and similarly for the control stack guard page */
+/* manipulate the signal context and stack such that when the handler
+ * returns, it will call function instead of whatever it was doing
+ * previously
+ */
+
+extern lispobj call_into_lisp(lispobj fun, lispobj *args, int nargs);
+extern void post_signal_tramp(void);
+void return_to_lisp_function(os_context_t *context, lispobj function)
+{
+ void * fun=native_pointer(function);
+ char *code = &(((struct simple_fun *) fun)->code);
+
+ u32 *sp=(u32 *)*os_context_register_addr(context,reg_ESP);
+
+ /* Build a stack frame showing `interrupted' so that the
+ * user's backtrace makes (as much) sense (as usual) */
+#ifdef LISP_FEATURE_X86
+ /* Suppose the existence of some function that saved all
+ * registers, called call_into_lisp, then restored GP registers and
+ * returned. We shortcut this: fake the stack that call_into_lisp
+ * would see, then arrange to have it called directly. post_signal_tramp
+ * is the second half of this function
+ */
+
+ *(sp-14) = post_signal_tramp; /* return address for call_into_lisp */
+ *(sp-13) = function; /* args for call_into_lisp : function*/
+ *(sp-12) = 0; /* arg array */
+ *(sp-11) = 0; /* no. args */
+ /* this order matches that used in POPAD */
+ *(sp-10)=*os_context_register_addr(context,reg_EDI);
+ *(sp-9)=*os_context_register_addr(context,reg_ESI);
+ /* this gets overwritten again before it's used, anyway */
+ *(sp-8)=*os_context_register_addr(context,reg_EBP);
+ *(sp-7)=0 ; /* POPAD doesn't set ESP, but expects a gap for it anyway */
+ *(sp-6)=*os_context_register_addr(context,reg_EBX);
+
+ *(sp-5)=*os_context_register_addr(context,reg_EDX);
+ *(sp-4)=*os_context_register_addr(context,reg_ECX);
+ *(sp-3)=*os_context_register_addr(context,reg_EAX);
+ *(sp-2)=*os_context_register_addr(context,reg_EBP);
+ *(sp-1)=*os_context_pc_addr(context);
+
+#else
+ build_fake_control_stack_frames(th,context);
+#endif
+
+ *os_context_pc_addr(context) = call_into_lisp;
+#ifdef LISP_FEATURE_X86
+ *os_context_register_addr(context,reg_ECX) = 0;
+ *os_context_register_addr(context,reg_EBP) = sp-2;
+ *os_context_register_addr(context,reg_ESP) = sp-14;
+#else
+ /* this much of the calling convention is common to all
+ non-x86 ports */
+ *os_context_register_addr(context,reg_NARGS) = 0;
+ *os_context_register_addr(context,reg_LIP) = code;
+ *os_context_register_addr(context,reg_CFP) =
+ current_control_frame_pointer;
+#endif
+#ifdef ARCH_HAS_NPC_REGISTER
+ *os_context_npc_addr(context) =
+ 4 + *os_context_pc_addr(context);
+#endif
+#ifdef LISP_FEATURE_SPARC
+ *os_context_register_addr(context,reg_CODE) =
+ fun + FUN_POINTER_LOWTAG;
+#endif
+#ifdef LISP_FEATURE_LINUX
+ /* Under Linux on some architectures it seems we have to restore
+ the FPU control word from the context, as after the signal is
+ delivered we have a null FPU control word. */
+ os_restore_fp_control(context);
+#endif
+}
+
+boolean handle_rt_signal(int num, siginfo_t *info, void *v_context)
+{
+ struct
+ os_context_t *context = (os_context_t*)arch_os_get_context(&v_context);
+ return_to_lisp_function(context,info->si_value.sival_int);
+}
boolean handle_control_stack_guard_triggered(os_context_t *context,void *addr)
{
* it won't go back to what it was doing ... */
if(addr>=(void *)CONTROL_STACK_GUARD_PAGE(th) &&
addr<(void *)(CONTROL_STACK_GUARD_PAGE(th)+os_vm_page_size)) {
- void *fun;
- void *code;
- /* fprintf(stderr, "hit end of control stack\n"); */
/* we hit the end of the control stack. disable protection
* temporarily so the error handler has some headroom */
- protect_control_stack_guard_page(th->pid,0L);
+ protect_control_stack_guard_page(th->pid,0L);
- fun = (void *)
- native_pointer((lispobj) SymbolFunction(CONTROL_STACK_EXHAUSTED_ERROR));
- code = &(((struct simple_fun *) fun)->code);
-
- /* Build a stack frame showing `interrupted' so that the
- * user's backtrace makes (as much) sense (as usual) */
- build_fake_control_stack_frames(th,context);
- /* signal handler will "return" to this error-causing function */
- *os_context_pc_addr(context) = code;
-#ifdef LISP_FEATURE_X86
- *os_context_register_addr(context,reg_ECX) = 0;
-#else
- /* this much of the calling convention is common to all
- non-x86 ports */
- *os_context_register_addr(context,reg_NARGS) = 0;
- *os_context_register_addr(context,reg_LIP) = code;
- *os_context_register_addr(context,reg_CFP) =
- current_control_frame_pointer;
-#endif
-#ifdef ARCH_HAS_NPC_REGISTER
- *os_context_npc_addr(context) =
- 4 + *os_context_pc_addr(context);
-#endif
-#ifdef LISP_FEATURE_SPARC
- /* Bletch. This is a feature of the SPARC calling convention,
- which sadly I'm not going to go into in large detail here,
- as I don't know it well enough. Suffice to say that if the
- line
-
- (INST MOVE CODE-TN FUNCTION)
-
- in compiler/sparc/call.lisp is changed, then this bit can
- probably go away. -- CSR, 2002-07-24 */
- *os_context_register_addr(context,reg_CODE) =
- fun + FUN_POINTER_LOWTAG;
-#endif
+ return_to_lisp_function
+ (context, SymbolFunction(CONTROL_STACK_EXHAUSTED_ERROR));
return 1;
}
else return 0;
sigaddset_blockable(&sa.sa_mask);
sa.sa_flags = SA_SIGINFO | SA_RESTART;
#ifdef LISP_FEATURE_C_STACK_IS_CONTROL_STACK
- if(signal==SIG_MEMORY_FAULT) sa.sa_flags|= SA_ONSTACK;
+ if((signal==SIG_MEMORY_FAULT) ||
+ (signal==SIG_INTERRUPT_THREAD))
+ sa.sa_flags|= SA_ONSTACK;
#endif
sigaction(signal, &sa, NULL);
boolean continuable);
extern boolean handle_control_stack_guard_triggered(os_context_t *,void *);
extern boolean interrupt_maybe_gc(int, siginfo_t*, void*);
+extern boolean handle_rt_signal(int, siginfo_t*, void*);
extern void undoably_install_low_level_interrupt_handler (int signal,
void
handler(int,
{
undoably_install_low_level_interrupt_handler(SIG_MEMORY_FAULT,
sigsegv_handler);
+ undoably_install_low_level_interrupt_handler(SIG_INTERRUPT_THREAD,
+ handle_rt_signal);
undoably_install_low_level_interrupt_handler(SIGCONT,
sigcont_handler);
}
#define OS_VM_PROT_EXECUTE PROT_EXEC
#define SIG_MEMORY_FAULT SIGSEGV
+#define SIG_INTERRUPT_THREAD SIGRTMIN
sigwaitinfo(&set,0);
sigprocmask(SIG_UNBLOCK,&set,0);
}
+
+int interrupt_thread(pid_t pid, lispobj function)
+{
+ union sigval sigval;
+ sigval.sival_int=function;
+
+ sigqueue(pid, SIG_INTERRUPT_THREAD, sigval);
+}
#endif
/* Save the NPX state */
fwait # Catch any pending NPX exceptions.
subl $108,%esp # Make room for the NPX state.
- fnsave (%esp) # resets NPX
+ fnsave (%esp) # save and reset NPX
movl (%esp),%eax # Load NPX control word.
andl $0xfffff3ff,%eax # Set rounding mode to nearest.
sub $8,%esp # Ensure 3 slots are allocated, one above.
mov %ebx,%ebp # Switch to new frame.
- /* Indirect the closure. */
call *CLOSURE_FUN_OFFSET(%eax)
- /* Multi-value return; blow off any extra values. */
+ /* If the function returned multiple values, it will return to
+ this point. Lose them */
mov %ebx, %esp
- /* single value return */
+ /* A singled value function returns here */
/* Restore the stack, in case there was a stack change. */
popl %esp # c-sp
.size GNAME(alloc_16_to_edi),.-GNAME(alloc_16_to_edi)
+ .align align_4byte,0x90
+ .globl GNAME(post_signal_tramp)
+ .type GNAME(post_signal_tramp),@function
+GNAME(post_signal_tramp):
+ /* this is notionally the second half of a function whose first half
+ * doesn't exist. This is where call_into_lisp returns when called
+ * using return_to_lisp_function */
+ addl $12,%esp /* clear call_into_lisp args from stack */
+ popa /* restore registers */
+ popl %ebp
+ ret
+ .size GNAME(post_signal_tramp),.-GNAME(post_signal_tramp)
+
+
\f
#ifdef GENCGC_INLINE_ALLOC /* LISP_FEATURE_GENCGC */
os_context_register_addr(os_context_t *context, int offset)
{
switch(offset) {
- case 0: return &context->uc_mcontext.gregs[11]; /* EAX */
- case 2: return &context->uc_mcontext.gregs[10]; /* ECX */
- case 4: return &context->uc_mcontext.gregs[9]; /* EDX */
- case 6: return &context->uc_mcontext.gregs[8]; /* EBX */
- case 8: return &context->uc_mcontext.gregs[7]; /* ESP */
- case 10: return &context->uc_mcontext.gregs[6]; /* EBP */
- case 12: return &context->uc_mcontext.gregs[5]; /* ESI */
- case 14: return &context->uc_mcontext.gregs[4]; /* EDI */
+ case reg_EAX: return &context->uc_mcontext.gregs[11];
+ case reg_ECX: return &context->uc_mcontext.gregs[10];
+ case reg_EDX: return &context->uc_mcontext.gregs[9];
+ case reg_EBX: return &context->uc_mcontext.gregs[8];
+ case reg_ESP: return &context->uc_mcontext.gregs[7];
+ case reg_EBP: return &context->uc_mcontext.gregs[6];
+ case reg_ESI: return &context->uc_mcontext.gregs[5];
+ case reg_EDI: return &context->uc_mcontext.gregs[4];
default: return 0;
}
return &context->uc_mcontext.gregs[offset];
(in-package "SB-THREAD") ; this is white-box testing, really
+;;; For one of the interupt-thread tests, we want a foreign function
+;;; that does not make syscalls
+
+(setf SB-INT:*REPL-PROMPT-FUN* #'sb-thread::thread-repl-prompt-fun)
+(with-open-file (o "threads-foreign.c" :direction :output)
+ (format o "void loop_forever() { while(1) ; }~%"))
+(sb-ext:run-program
+ "cc"
+ (or #+linux '("-shared" "-o" "threads-foreign.so" "threads-foreign.c")
+ (error "Missing shared library compilation options for this platform"))
+ :search t)
+(sb-alien:load-1-foreign "threads-foreign.so")
+(sb-alien:define-alien-routine loop-forever sb-alien:void)
+
+
;;; elementary "can we get a lock and release it again"
(let ((l (make-mutex :name "foo"))
(p (current-thread-id)))
(condition-notify queue))
(sleep 1)))
-;;; success
+
+(defun test-interrupt (function-to-interrupt &optional quit-p)
+ (let ((child (make-thread function-to-interrupt)))
+ ;;(format t "gdb ./src/runtime/sbcl ~A~%attach ~A~%" child child)
+ (sleep 2)
+ (format t "interrupting child ~A~%" child)
+ (interrupt-thread child
+ (lambda ()
+ (format t "child pid ~A~%" (current-thread-id))
+ (when quit-p (sb-ext:quit))))
+ (sleep 1)
+ child))
+
+;;; separate tests for (a) interrupting Lisp code, (b) C code, (c) a syscall,
+;;; (d) waiting on a lock
+
+(let ((child (test-interrupt (lambda () (loop))))) (terminate-thread child))
+
+(test-interrupt #'loop-forever :quit)
+
+(let ((child (test-interrupt (lambda () (loop (sleep 2000))))))
+ ;; Interrupting a sleep form causes it to return early. Welcome to Unix.
+ ;; Just to be sure our LOOP form works, let's check the child is still
+ ;; there
+ (assert (zerop (sb-unix:unix-kill child 0)))
+ (terminate-thread child))
+
+(let ((lock (make-mutex :name "loctite"))
+ child)
+ (with-mutex (lock)
+ (setf child (test-interrupt
+ (lambda ()
+ (with-mutex (lock)
+ (assert (eql (mutex-value lock) (current-thread-id))))
+ (assert (not (eql (mutex-value lock) (current-thread-id)))))))
+ ;;hold onto lock for long enough that child can't get it immediately
+ (sleep 5))
+ (terminate-thread child))
+
(sb-ext:quit :unix-status 104)
;;; checkins which aren't released. (And occasionally for internal
;;; versions, especially for internal versions off the main CVS
;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.8.2.32"
+"0.8.2.33"
projects / sbcl.git / commitdiff