** the USE-VALUE, CONTINUE and STORE-VALUE functions now correctly
exclude restarts of the same name associated with a different
condition;
+ * Experimental native threads support, on x86 Linux. This is not
+ compiled in by default: you need to add :SB-THREAD to the target
+ features. See the "Beyond ANSI" chapter of the manual for
+ details.
+ * Due to rearrangement for threads, the control stack and binding stack
+ are now allocated at arbitrary addresses instead of being hardcoded
+ per-port. Users affected by this probably have to be doing
+ advanced things with shared libraries, and will know who they are
-planned incompatible changes in 0.7.x:
+planned incompatible changes in 0.8.x:
* (not done yet, but planned:) When the profiling interface settles
down, maybe in 0.7.x, maybe later, it might impact TRACE. They both
encapsulate functions, and it's not clear yet how e.g. UNPROFILE
-for late 0.7.x:
+for early 0.8.x:
* test file reworking
** non-x86 ports now pass irrat.pure.lisp
* belated renaming:
** renamed %PRIMITIVE to %VOP
** A few hundred things named FN and FCN should be
- named FUN (but maybe not while dan_b is
- working on a threads branch and drichards is
+ named FUN (but maybe not while drichards is
working on a Windows port).
* These days ANSI C has inline functions, so..
** redid many cpp macros as inline functions:
personal itch): I don't want socket-level stuff so much as I
want RPC-level or higher (CORBA?) interfaces and (possibly
through RPC or CORBA) GUI support
+* Especially when ldb is not compiled in, the default "assertion failed"
+ behaviour in many parts of the runtime is unfriendly. It may
+ be appropriate to look at some of these and see if they can be
+ handled in some less abrupt way than aborting
=======================================================================
important but out of scope (for WHN, anyway: Patches from other people
are still welcome!) until after 1.0:
\f
;;;; Hash primitives
-
+#|
#+sb-assembling
(defparameter sxhash-simple-substring-entry (gen-label))
(inst slwi result accum 5)
(inst srwi result result 3))
+|#
\ No newline at end of file
(if up-frame (1+ (frame-number up-frame)) 0)
escaped)))))
-#!+x86
(defun nth-interrupt-context (n)
(declare (type (unsigned-byte 32) n)
(optimize (speed 3) (safety 0)))
(defun find-escaped-frame (frame-pointer)
(declare (type system-area-pointer frame-pointer))
(dotimes (index *free-interrupt-context-index* (values nil 0 nil))
- (sb!alien:with-alien
- ((lisp-interrupt-contexts (array (* os-context-t) nil) :extern))
- (let ((scp (sb!alien:deref lisp-interrupt-contexts index)))
- (when (= (sap-int frame-pointer)
- (sb!vm:context-register scp sb!vm::cfp-offset))
- (without-gcing
- (let ((code (code-object-from-bits
- (sb!vm:context-register scp sb!vm::code-offset))))
- (when (symbolp code)
- (return (values code 0 scp)))
- (let* ((code-header-len (* (get-header-data code)
- sb!vm:n-word-bytes))
- (pc-offset
+ (let ((scp (nth-interrupt-context index)))
+ (when (= (sap-int frame-pointer)
+ (sb!vm:context-register scp sb!vm::cfp-offset))
+ (without-gcing
+ (let ((code (code-object-from-bits
+ (sb!vm:context-register scp sb!vm::code-offset))))
+ (when (symbolp code)
+ (return (values code 0 scp)))
+ (let* ((code-header-len (* (get-header-data code)
+ sb!vm:n-word-bytes))
+ (pc-offset
(- (sap-int (sb!vm:context-pc scp))
(- (get-lisp-obj-address code)
sb!vm:other-pointer-lowtag)
code-header-len)))
- ;; Check to see whether we were executing in a branch
- ;; delay slot.
- #!+(or pmax sgi) ; pmax only (and broken anyway)
- (when (logbitp 31 (sb!alien:slot scp '%mips::sc-cause))
- (incf pc-offset sb!vm:n-word-bytes))
- (unless (<= 0 pc-offset
- (* (code-header-ref code sb!vm:code-code-size-slot)
- sb!vm:n-word-bytes))
- ;; We were in an assembly routine. Therefore, use the
- ;; LRA as the pc.
- (setf pc-offset
- (- (sb!vm:context-register scp sb!vm::lra-offset)
- (get-lisp-obj-address code)
- code-header-len)))
- (return
- (if (eq (%code-debug-info code) :bogus-lra)
- (let ((real-lra (code-header-ref code
- real-lra-slot)))
- (values (lra-code-header real-lra)
- (get-header-data real-lra)
- nil))
- (values code pc-offset scp)))))))))))
+ ;; Check to see whether we were executing in a branch
+ ;; delay slot.
+ #!+(or pmax sgi) ; pmax only (and broken anyway)
+ (when (logbitp 31 (sb!alien:slot scp '%mips::sc-cause))
+ (incf pc-offset sb!vm:n-word-bytes))
+ (unless (<= 0 pc-offset
+ (* (code-header-ref code sb!vm:code-code-size-slot)
+ sb!vm:n-word-bytes))
+ ;; We were in an assembly routine. Therefore, use the
+ ;; LRA as the pc.
+ (setf pc-offset
+ (- (sb!vm:context-register scp sb!vm::lra-offset)
+ (get-lisp-obj-address code)
+ code-header-len)))
+ (return
+ (if (eq (%code-debug-info code) :bogus-lra)
+ (let ((real-lra (code-header-ref code
+ real-lra-slot)))
+ (values (lra-code-header real-lra)
+ (get-header-data real-lra)
+ nil))
+ (values code pc-offset scp))))))))))
;;; Find the code object corresponding to the object represented by
;;; bits and return it. We assume bogus functions correspond to the
(let* ((csp (sap-int (sb!c::control-stack-pointer-sap)))
(initial-offset (logand csp (1- bytes-per-scrub-unit)))
(end-of-stack
- (- sb!vm:control-stack-end sb!c:*backend-page-size*)))
+ (- sb!vm::*control-stack-end* sb!c:*backend-page-size*)))
(labels
((scrub (ptr offset count)
(declare (type system-area-pointer ptr)
(declare (type unix-fd fd))
(void-syscall ("fsync" int) fd))
\f
+
+(defun unix-setsid ()
+ (int-syscall ("setsid")))
+
;;;; sys/ioctl.h
;;; UNIX-IOCTL performs a variety of operations on open i/o
(control-stack-end :c-type "lispobj *")
(alien-stack-start :c-type "lispobj *")
(alien-stack-pointer :c-type "lispobj *")
+ #!+gencgc
(alloc-region :c-type "struct alloc_region" :length 5)
(pid :c-type "pid_t")
(tls-cookie) ; on x86, the LDT index
(def!constant read-only-space-start #x01000000)
(def!constant read-only-space-end #x04ff8000)
-(def!constant binding-stack-start #x06000000)
-(def!constant binding-stack-end #x06ff0000)
-
-(def!constant control-stack-start #x07000000)
-(def!constant control-stack-end #x07ff0000)
-
(def!constant static-space-start #x08000000)
(def!constant static-space-end #x097fff00)
*current-catch-block*
*current-unwind-protect-block*
+ *binding-stack-start*
+ *control-stack-start*
+ *control-stack-end*
+
;; interrupt handling
*free-interrupt-context-index*
sb!unix::*interrupts-enabled*
sb!unix::*interrupt-pending*
- #|sb!kernel::*current-thread*|#
+
))
(defparameter *static-funs*
(:generator 1
(inst unimp pending-interrupt-trap)))
+(defknown current-thread-offset-sap ((unsigned-byte 32))
+ system-area-pointer (flushable))
+
+(define-vop (current-thread-offset-sap)
+ (:results (sap :scs (sap-reg)))
+ (:result-types system-area-pointer)
+ (:translate current-thread-offset-sap)
+ (:args (n :scs (unsigned-reg) ))
+ (:temporary (:sc unsigned-reg :target sap) temp1)
+ (:temporary (:sc unsigned-reg) temp2)
+ (:arg-types unsigned-num)
+ (:policy :fast-safe)
+ (:generator 3
+ (inst slwi n temp1 2)
+ (inst lr temp2 (make-fixup (extern-alien-name "all_threads") :foreign))
+ (inst lwzx sap temp1 temp2)))
(define-vop (halt)
(:generator 1
#endif
#include "genesis/static-symbols.h"
#include "genesis/primitive-objects.h"
+#include "thread.h"
#ifndef __i386__
static boolean
cs_valid_pointer_p(struct call_frame *pointer)
{
- return (((char *) CONTROL_STACK_START <= (char *) pointer) &&
+ struct thread *thread=arch_os_get_current_thread();
+ return (((char *) thread->control_stack_start <= (char *) pointer) &&
((char *) pointer < (char *) current_control_stack_pointer));
}
#include "interr.h"
#include "genesis/static-symbols.h"
#include "genesis/primitive-objects.h"
+#include "thread.h"
/* So you need to debug? */
#if 0
static void scavenge_newspace(void);
static void scavenge_interrupt_contexts(void);
+extern struct interrupt_data * global_interrupt_data;
\f
/* collecting garbage */
unsigned long static_space_size;
unsigned long control_stack_size, binding_stack_size;
sigset_t tmp, old;
+ struct thread *th=arch_os_get_current_thread();
+ struct interrupt_data *data=
+ th ? th->interrupt_data : global_interrupt_data;
+
#ifdef PRINTNOISE
printf("[Collecting garbage ... \n");
current_static_space_free_pointer =
(lispobj *) ((unsigned long)
- SymbolValue(STATIC_SPACE_FREE_POINTER));
+ SymbolValue(STATIC_SPACE_FREE_POINTER,0));
/* Set up from space and new space pointers. */
printf("Scavenging interrupt handlers (%d bytes) ...\n",
(int)sizeof(interrupt_handlers));
#endif
- scavenge((lispobj *) interrupt_handlers,
- sizeof(interrupt_handlers) / sizeof(lispobj));
+ scavenge((lispobj *) data->interrupt_handlers,
+ sizeof(data->interrupt_handlers) / sizeof(lispobj));
/* _size quantities are in units of sizeof(lispobj) - i.e. 4 */
control_stack_size =
current_control_stack_pointer-
- (lispobj *)CONTROL_STACK_START;
+ (lispobj *)th->control_stack_start;
#ifdef PRINTNOISE
printf("Scavenging the control stack at %p (%ld words) ...\n",
- ((lispobj *)CONTROL_STACK_START),
+ ((lispobj *)th->control_stack_start),
control_stack_size);
#endif
- scavenge(((lispobj *)CONTROL_STACK_START), control_stack_size);
+ scavenge(((lispobj *)th->control_stack_start), control_stack_size);
binding_stack_size =
current_binding_stack_pointer -
- (lispobj *)BINDING_STACK_START;
+ (lispobj *)th->binding_stack_start;
#ifdef PRINTNOISE
printf("Scavenging the binding stack %x - %x (%d words) ...\n",
- BINDING_STACK_START,current_binding_stack_pointer,
+ th->binding_stack_start,current_binding_stack_pointer,
(int)(binding_stack_size));
#endif
- scavenge(((lispobj *)BINDING_STACK_START), binding_stack_size);
+ scavenge(((lispobj *)th->binding_stack_start), binding_stack_size);
static_space_size =
current_static_space_free_pointer - (lispobj *) STATIC_SPACE_START;
int i, index;
os_context_t *context;
- index = fixnum_value(SymbolValue(FREE_INTERRUPT_CONTEXT_INDEX));
+ struct thread *th=arch_os_get_current_thread();
+ struct interrupt_data *data=
+ th ? th->interrupt_data : global_interrupt_data;
+
+ index = fixnum_value(SymbolValue(FREE_INTERRUPT_CONTEXT_INDEX,0));
+
#ifdef DEBUG_SCAVENGE_VERBOSE
fprintf(stderr, "%d interrupt contexts to scan\n",index);
#endif
for (i = 0; i < index; i++) {
- context = lisp_interrupt_contexts[i];
+ context = th->interrupt_contexts[i];
scavenge_interrupt_context(context);
}
}
interrupt_maybe_gc(int signal, siginfo_t *info, void *void_context)
{
os_context_t *context=(os_context_t *) void_context;
+ struct thread *th=arch_os_get_current_thread();
+ struct interrupt_data *data=
+ th ? th->interrupt_data : global_interrupt_data;
if (!foreign_function_call_active
#ifndef LISP_FEATURE_GENCGC
* will detect pending_signal==0 and know to do a GC with the
* signal context instead of calling a Lisp-level handler */
maybe_gc_pending = 1;
- if (pending_signal == 0) {
+ if (data->pending_signal == 0) {
/* FIXME: This copy-pending_mask-then-sigaddset_blockable
* idiom occurs over and over. It should be factored out
* into a function with a descriptive name. */
- memcpy(&pending_mask,
+ memcpy(&(data->pending_mask),
os_context_sigmask_addr(context),
sizeof(sigset_t));
sigaddset_blockable(os_context_sigmask_addr(context));
}
void
+get_spinlock(lispobj *word,int value)
+{
+ /* FIXME */
+ *word=value;
+}
+
+
+void
arch_remove_breakpoint(void *pc, unsigned long orig_inst)
{
*(unsigned long *)pc = orig_inst;
#include "validate.h"
size_t os_vm_page_size;
+struct thread *arch_os_get_current_thread() {
+ return all_threads;
+}
+struct thread *arch_os_thread_init() {
+ return 1; /* success */
+}
+struct thread *arch_os_thread_cleanup() {
+ return 1; /* success */
+}
+
os_context_register_t *
os_context_register_addr(os_context_t *context, int offset)
{
unsigned long os_context_fp_control(os_context_t *context);
void os_restore_fp_control(os_context_t *context);
+extern struct thread *arch_os_get_current_thread();
#endif /* _PPC_LINUX_OS_H */
fflush(stdout);
#endif
+#if (defined(LISP_FEATURE_GENCGC) && defined(LISP_FEATURE_X86))
#if 0
- /* can't do this unless the threads in question are suspended with
- * ptrace
+ /* This is what we should do, but can't unless the threads in
+ * question are suspended with ptrace. That's right, purify is not
+ * threadsafe
*/
-#if (defined(LISP_FEATURE_GENCGC) && defined(LISP_FEATURE_X86))
for_each_thread(thread) {
void **ptr;
struct user_regs_struct regs;
setup_i386_stack_scav(regs.ebp,
((void *)thread->control_stack_end));
}
-#endif
-#endif
+#endif /* 0 */
+ /* stopgap until we can set things up as in preceding comment */
setup_i386_stack_scav(((&static_roots)-2),
((void *)all_threads->control_stack_end));
-
+#endif
pscav(&static_roots, 1, 0);
pscav(&read_only_roots, 1, 1);
fflush(stdout);
#endif
#ifndef __i386__
- pscav((lispobj *)CONTROL_STACK_START,
- current_control_stack_pointer - (lispobj *)CONTROL_STACK_START,
+ pscav((lispobj *)all_threads->control_stack_start,
+ current_control_stack_pointer -
+ all_threads->control_stack_start,
0);
#else
#ifdef LISP_FEATURE_GENCGC
fflush(stdout);
#endif
#if !defined(__i386__)
- pscav( (lispobj *)BINDING_STACK_START,
- (lispobj *)current_binding_stack_pointer - (lispobj *)BINDING_STACK_START,
+ pscav( (lispobj *)all_threads->binding_stack_start,
+ (lispobj *)current_binding_stack_pointer -
+ all_threads->binding_stack_start,
0);
#else
for_each_thread(thread) {
* calling SCRUB-CONTROL-STACK - this zeros the stack on the x86. */
#ifndef __i386__
os_zero((os_vm_address_t) current_control_stack_pointer,
- (os_vm_size_t) (CONTROL_STACK_SIZE -
+ (os_vm_size_t) (THREAD_CONTROL_STACK_SIZE -
((current_control_stack_pointer -
- (lispobj *)CONTROL_STACK_START) *
- sizeof(lispobj))));
+ all_threads->control_stack_start)
+ * sizeof(lispobj))));
#endif
/* It helps to update the heap free pointers so that free_heap can
if(arch_os_thread_init(th)==0)
return 1; /* failure. no, really */
-#ifdef LISP_FEATURE_SB_THREAD
- return call_into_lisp(function,args,0);
-#else
+#if !defined(LISP_FEATURE_SB_THREAD) && defined(LISP_FEATURE_X86)
return call_into_lisp_first_time(function,args,0);
+#else
+ return funcall0(function);
#endif
}
memcpy(per_thread,arch_os_get_current_thread(),
dynamic_values_bytes);
} else {
+#ifdef LISP_FEATURE_SB_THREAD
int i;
for(i=0;i<(dynamic_values_bytes/sizeof(lispobj));i++)
per_thread->dynamic_values[i]=UNBOUND_MARKER_WIDETAG;
make_fixnum(MAX_INTERRUPTS+
sizeof(struct thread)/sizeof(lispobj)),
0);
-#ifdef LISP_FEATURE_SB_THREAD
#define STATIC_TLS_INIT(sym,field) \
((struct symbol *)(sym-OTHER_POINTER_LOWTAG))->tls_index= \
make_fixnum(THREAD_SLOT_OFFSET_WORDS(field))
/* 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);
+#ifdef LISP_FEATURE_GENCGC
gc_set_region_empty(&th->alloc_region);
+#endif
#ifndef LISP_FEATURE_SB_THREAD
/* the tls-points-into-struct-thread trick is only good for threaded
* variable quantities from the C runtime. It's not quite OAOOM,
* it just feels like it */
SetSymbolValue(BINDING_STACK_START,th->binding_stack_start,th);
- SetSymbolValue(BINDING_STACK_POINTER,th->binding_stack_pointer,th);
SetSymbolValue(CONTROL_STACK_START,th->control_stack_start,th);
+ SetSymbolValue(CONTROL_STACK_END,th->control_stack_end,th);
+#ifdef LISP_FEATURE_X86
+ SetSymbolValue(BINDING_STACK_POINTER,th->binding_stack_pointer,th);
SetSymbolValue(ALIEN_STACK,th->alien_stack_pointer,th);
SetSymbolValue(PSEUDO_ATOMIC_ATOMIC,th->pseudo_atomic_atomic,th);
SetSymbolValue(PSEUDO_ATOMIC_INTERRUPTED,th->pseudo_atomic_interrupted,th);
+#else
+ current_binding_stack_pointer=th->binding_stack_pointer;
+ current_control_stack_pointer=th->control_stack_start;
#endif
-
+#endif
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);
th->interrupt_data=malloc(sizeof (struct interrupt_data));
if(all_threads)
- memcpy(th->interrupt_data,arch_os_get_current_thread()->interrupt_data,
+ memcpy(th->interrupt_data,
+ arch_os_get_current_thread()->interrupt_data,
sizeof (struct interrupt_data));
else
memcpy(th->interrupt_data,global_interrupt_data,
{
/* precondition: the unix task has already been killed and exited.
* This is called by the parent */
+#ifdef LISP_FEATURE_GENCGC
gc_alloc_update_page_tables(0, &th->alloc_region);
+#endif
get_spinlock(&all_threads_lock,th->pid);
if(th==all_threads)
all_threads=th->next;
}
-void get_spinlock(lispobj *word,int value)
-{
- u32 eax=0;
- do {
- asm ("xor %0,%0;cmpxchg %1,%2"
- : "=a" (eax)
- : "r" (value), "m" (*word)
- : "memory", "cc");
- } while(eax!=0);
-}
void block_sigcont(void)
{
#ifdef LISP_FEATURE_GENCGC
#include "gencgc-alloc-region.h"
#else
-#error "threading doesn't work with cheney gc yet"
+struct alloc_region { };
#endif
#include "genesis/symbol.h"
#include "genesis/static-symbols.h"
void protect_control_stack_guard_page(pid_t t_id, int protect_p) {
struct thread *th= find_thread_by_pid(t_id);
+#if 0
os_protect(CONTROL_STACK_GUARD_PAGE(th),
os_vm_page_size,protect_p ?
(OS_VM_PROT_READ|OS_VM_PROT_EXECUTE) : OS_VM_PROT_ALL);
+#endif
}
return result;
}
+void
+get_spinlock(lispobj *word,int value)
+{
+ u32 eax=0;
+ do {
+ asm ("xor %0,%0;cmpxchg %1,%2"
+ : "=a" (eax)
+ : "r" (value), "m" (*word)
+ : "memory", "cc");
+ } while(eax!=0);
+}
+
void
arch_remove_breakpoint(void *pc, unsigned long orig_inst)
{
;;; versions, especially for internal versions off the main CVS
;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.pre8.32"
+"0.pre8.33"
projects / sbcl.git / commitdiff