(in-package "SB!THREAD")
+;;; used bu debug-int.lisp to access interrupt contexts
#!-sb-fluid (declaim (inline sb!vm::current-thread-offset-sap))
(defun sb!vm::current-thread-offset-sap (n)
(declare (type (unsigned-byte 27) n))
(* n 4)))
(defun current-thread-id ()
- (sb!sys:sap-int
- (sb!vm::current-thread-offset-sap sb!vm::thread-pid-slot)))
+ (sb!sys:sap-ref-32 (alien-sap (extern-alien "all_threads" (* t)))
+ (* sb!vm::thread-pid-slot 4)))
;;;; queues, locks
(def!constant dynamic-1-space-start #x40000000)
(def!constant dynamic-1-space-end #x4fff0000)
-(def!constant control-stack-start #x50000000)
-(def!constant control-stack-end #x51000000)
-
-(def!constant binding-stack-start #x70000000)
-(def!constant binding-stack-end #x71000000)
-
-
;;; FIXME nothing refers to either of these in alpha or x86 cmucl
;;; backend, so they could probably be removed.
*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*
;; unbound_marker is borrowed very briefly at thread startup to
;; pass the address of initial-function into new_thread_trampoline
(unbound-marker :init :unbound) ; tls[0] = UNBOUND_MARKER_WIDETAG
- (binding-stack-start :c-type "lispobj *")
- (binding-stack-pointer :c-type "lispobj *")
- (control-stack-start :c-type "lispobj *")
- (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")
+ (binding-stack-start :c-type "lispobj *" :length #!+alpha 2 #!-alpha 1)
+ (binding-stack-pointer :c-type "lispobj *" :length #!+alpha 2 #!-alpha 1)
+ (control-stack-start :c-type "lispobj *" :length #!+alpha 2 #!-alpha 1)
+ (control-stack-end :c-type "lispobj *" :length #!+alpha 2 #!-alpha 1)
+ (alien-stack-start :c-type "lispobj *" :length #!+alpha 2 #!-alpha 1)
+ (alien-stack-pointer :c-type "lispobj *" :length #!+alpha 2 #!-alpha 1)
+ #!+gencgc (alloc-region :c-type "struct alloc_region" :length 5)
(tls-cookie) ; on x86, the LDT index
- (this :c-type "struct thread *")
- (next :c-type "struct thread *")
- (pseudo-atomic-atomic)
- (pseudo-atomic-interrupted)
- (interrupt-data :c-type "struct interrupt_data *")
+ (this :c-type "struct thread *" :length #!+alpha 2 #!-alpha 1)
+ (next :c-type "struct thread *" :length #!+alpha 2 #!-alpha 1)
+ #!+x86 (pseudo-atomic-atomic)
+ #!+x86 (pseudo-atomic-interrupted)
+ (interrupt-data :c-type "struct interrupt_data *"
+ :length #!+alpha 2 #!-alpha 1)
(interrupt-contexts :c-type "os_context_t *" :rest-p t))
(def!constant read-only-space-start #x20000000)
(def!constant read-only-space-end #x24000000)
-(def!constant binding-stack-start #x24000000)
-(def!constant binding-stack-end #x24ff0000)
-
-(def!constant control-stack-start #x25000000)
-(def!constant control-stack-end #x25ff0000)
-
(def!constant static-space-start #x28000000)
(def!constant static-space-end #x2a000000)
;; Things needed for non-local-exit.
*current-catch-block*
*current-unwind-protect-block*
+
+ *binding-stack-start*
+ *control-stack-start*
+ *control-stack-end*
;; Interrupt Handling
*free-interrupt-context-index*
(def!constant read-only-space-start #x01000000)
(def!constant read-only-space-end #x05000000)
-(def!constant binding-stack-start #x05000000)
-(def!constant binding-stack-end #x05800000)
-
-(def!constant control-stack-start #x05800000)
-(def!constant control-stack-end #x06000000)
-
(def!constant static-space-start #x06000000)
(def!constant static-space-end #x08000000)
undoably_install_low_level_interrupt_handler(SIGTRAP, sigtrap_handler);
}
+void get_spinlock(lispobj *word, int value) {
+ /* FIXME: dummy definition */
+ *word = value;
+}
+
extern lispobj call_into_lisp(lispobj fun, lispobj *args, int nargs);
lispobj funcall0(lispobj function)
#include "validate.h"
size_t os_vm_page_size;
+#ifdef LISP_FEATURE_SB_THREAD
+#error "Define threading support functions"
+#else
+struct thread *arch_os_get_current_thread() {
+ return all_threads;
+}
+int arch_os_thread_init(struct thread *thread) {
+ return 1; /* success */
+}
+int arch_os_thread_cleanup(struct thread *thread) {
+ return 1; /* success */
+}
+#endif
+
os_context_register_t *
os_context_register_addr(os_context_t *context, int offset)
#include "validate.h"
size_t os_vm_page_size;
+#ifdef LISP_FEATURE_SB_THREAD
+#error "Define threading support functions"
+#else
+struct thread *arch_os_get_current_thread() {
+ return all_threads;
+}
+int arch_os_thread_init(struct thread *thread) {
+ return 1; /* success */
+}
+int arch_os_thread_cleanup(struct thread *thread) {
+ return 1; /* success */
+}
+#endif
os_context_register_t *
os_context_register_addr(os_context_t *context, int offset)
boolean
is_valid_lisp_addr(os_vm_address_t addr)
{
- return in_range_p(addr, READ_ONLY_SPACE_START, READ_ONLY_SPACE_SIZE)
- || in_range_p(addr, STATIC_SPACE_START , STATIC_SPACE_SIZE )
- || in_range_p(addr, DYNAMIC_SPACE_START , DYNAMIC_SPACE_SIZE )
- || in_range_p(addr, CONTROL_STACK_START , CONTROL_STACK_SIZE )
- || in_range_p(addr, BINDING_STACK_START , BINDING_STACK_SIZE );
+ struct thread *th;
+ if(in_range_p(addr, READ_ONLY_SPACE_START, READ_ONLY_SPACE_SIZE) ||
+ in_range_p(addr, STATIC_SPACE_START , STATIC_SPACE_SIZE) ||
+ in_range_p(addr, DYNAMIC_SPACE_START , DYNAMIC_SPACE_SIZE))
+ return 1;
+ for_each_thread(th) {
+ if((th->control_stack_start <= addr) && (addr < th->control_stack_end))
+ return 1;
+ if(in_range_p(addr, th->binding_stack_start, BINDING_STACK_SIZE))
+ return 1;
+ }
+ return 0;
}
\f
/*
undoably_install_low_level_interrupt_handler(SIGBUS,sigbus_handler);
}
+void get_spinlock(lispobj *word, int value) {
+ /* FIXME: dummy definition */
+ *word = value;
+}
+
+
lispobj funcall0(lispobj function)
{
lispobj *args = current_control_stack_pointer;
#include "validate.h"
size_t os_vm_page_size;
+#ifdef LISP_FEATURE_SB_THREAD
+#error "Define threading support functions"
+#else
+struct thread *arch_os_get_current_thread() {
+ return all_threads;
+}
+int arch_os_thread_init(struct thread *thread) {
+ return 1; /* success */
+}
+int arch_os_thread_cleanup(struct thread *thread) {
+ return 1; /* success */
+}
+#endif
os_context_register_t *
os_context_register_addr(os_context_t *context, int offset)
#endif
}
-/* In Debian CMU CL ca. 2.4.9, it was possible to get an infinite
- * cascade of errors from do_mmap(..). This variable is a counter to
- * prevent that; when it counts down to zero, an error in do_mmap
- * causes the low-level monitor to be called. */
-int n_do_mmap_ignorable_errors = 3;
-/* Return 0 for success. */
-static int
-do_mmap(os_vm_address_t *addr, os_vm_size_t len, int flags)
-{
- /* We *must* have the memory where we expect it. */
- os_vm_address_t old_addr = *addr;
+#ifdef LISP_FEATURE_ALPHA
+/* The Alpha is a 64 bit CPU. SBCL is a 32 bit application. Due to all
+ * the places that assume we can get a pointer into a fixnum with no
+ * information loss, we have to make sure it allocates all its ram in the
+ * 0-2Gb region. */
- *addr = mmap(*addr, len, OS_VM_PROT_ALL, flags, -1, 0);
- if (*addr == MAP_FAILED ||
- ((old_addr != NULL) && (*addr != old_addr))) {
- FSHOW((stderr,
- "/retryable error in allocating memory from the OS\n"
- "(addr=0x%lx, len=0x%lx, flags=0x%lx)\n",
- (long) addr,
- (long) len,
- (long) flags));
- if (n_do_mmap_ignorable_errors > 0) {
- --n_do_mmap_ignorable_errors;
- } else {
- lose("too many errors in allocating memory from the OS");
- }
- perror("mmap");
- return 1;
- }
- return 0;
-}
+static void * under_2gb_free_pointer=DYNAMIC_1_SPACE_END;
+#endif
os_vm_address_t
os_validate(os_vm_address_t addr, os_vm_size_t len)
{
- if (addr) {
- int flags = MAP_PRIVATE | MAP_ANONYMOUS | MAP_FIXED;
- os_vm_address_t base_addr = addr;
- do {
- /* KLUDGE: It looks as though this code allocates memory
- * in chunks of size no larger than 'magic', but why? What
- * is the significance of 0x1000000 here? Also, can it be
- * right that if the first few 'do_mmap' calls succeed,
- * then one fails, we leave the memory allocated by the
- * first few in place even while we return a code for
- * complete failure? -- WHN 19991020
- *
- * Peter Van Eynde writes (20000211)
- * This was done because the kernel would only check for
- * overcommit for every allocation seperately. So if you
- * had 16MB of free mem+swap you could allocate 16M. And
- * again, and again, etc.
- * This in [Linux] 2.X could be bad as they changed the memory
- * system. A side effect was/is (I don't really know) that
- * programs with a lot of memory mappings run slower. But
- * of course for 2.2.2X we now have the NO_RESERVE flag that
- * helps...
- *
- * FIXME: The logic is also flaky w.r.t. failed
- * allocations. If we make one or more successful calls to
- * do_mmap(..) before one fails, then we've allocated
- * memory, and we should ensure that it gets deallocated
- * sometime somehow. If this function's response to any
- * failed do_mmap(..) is to give up and return NULL (as in
- * sbcl-0.6.7), then any failed do_mmap(..) after any
- * successful do_mmap(..) causes a memory leak. */
- int magic = 0x1000000;
- if (len <= magic) {
- if (do_mmap(&addr, len, flags)) {
- return NULL;
- }
- len = 0;
- } else {
- if (do_mmap(&addr, magic, flags)) {
- return NULL;
- }
- addr += magic;
- len = len - magic;
- }
- } while (len > 0);
- return base_addr;
- } else {
- int flags = MAP_PRIVATE | MAP_ANONYMOUS;
- if (do_mmap(&addr, len, flags)) {
- return NULL;
- } else {
- return addr;
- }
+ int flags = MAP_PRIVATE | MAP_ANONYMOUS | MAP_NORESERVE;
+ os_vm_address_t actual ;
+
+ if (addr)
+ flags |= MAP_FIXED;
+#ifdef LISP_FEATURE_ALPHA
+ else {
+ flags |= MAP_FIXED;
+ addr=under_2gb_free_pointer;
}
+#endif
+ actual = mmap(addr, len, OS_VM_PROT_ALL, flags, -1, 0);
+ if (actual == MAP_FAILED || (addr && (addr!=actual))) {
+ perror("mmap");
+ return 0; /* caller should check this */
+ }
+
+#ifdef LISP_FEATURE_ALPHA
+
+ len=(len+(os_vm_page_size-1))&(~(os_vm_page_size-1));
+ under_2gb_free_pointer+=len;
+#endif
+
+ return addr;
}
void
undoably_install_low_level_interrupt_handler(SIGFPE,sigfpe_handler);
}
+void get_spinlock(lispobj *word, int value) {
+ /* FIXME: dummy definition */
+ *word = value;
+}
+
extern lispobj call_into_lisp(lispobj fun, lispobj *args, int nargs);
lispobj funcall0(lispobj function)
#include <asm/mipsregs.h>
size_t os_vm_page_size;
+#ifdef LISP_FEATURE_SB_THREAD
+#error "Define threading support functions"
+#else
+struct thread *arch_os_get_current_thread() {
+ return all_threads;
+}
+int arch_os_thread_init(struct thread *thread) {
+ return 1; /* success */
+}
+int arch_os_thread_cleanup(struct thread *thread) {
+ return 1; /* success */
+}
+#endif
os_context_register_t *
os_context_register_addr(os_context_t *context, int offset)
/* this is lifted from linux-os.c, so violates OOAO */
*os_context_register_addr(context,reg_ALLOC) -= (1L<<63);
interrupt_handle_pending(context);
- } else if(((addr>=DYNAMIC_0_SPACE_END) && (addr<DYNAMIC_1_SPACE_START)) ||
- ((addr>=DYNAMIC_1_SPACE_END) && (addr<CONTROL_STACK_START))){
- /* there's empty gap between these spaces. This clause needs
- review if the spaces are ever juggled to make this untrue */
- fprintf(stderr, "bad address 0x%p\n",addr);
- lose("ran off end of dynamic space");
} else if (!interrupt_maybe_gc(signal, info, context)) {
if(!handle_control_stack_guard_triggered(context,addr))
interrupt_handle_now(signal, info, context);
* 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) (THREAD_CONTROL_STACK_SIZE -
- ((current_control_stack_pointer -
- all_threads->control_stack_start)
- * sizeof(lispobj))));
+ (os_vm_size_t)
+ ((all_threads->control_stack_end -
+ current_control_stack_pointer) * sizeof(lispobj)));
#endif
/* It helps to update the heap free pointers so that free_heap can
#include "validate.h"
size_t os_vm_page_size;
+#ifdef LISP_FEATURE_SB_THREAD
+#error "Define threading support functions"
+#else
+struct thread *arch_os_get_current_thread() {
+ return all_threads;
+}
+int arch_os_thread_init(struct thread *thread) {
+ return 1; /* success */
+}
+int arch_os_thread_cleanup(struct thread *thread) {
+ return 1; /* success */
+}
+#endif
os_context_register_t *
os_context_register_addr(os_context_t *context, int offset)
STATIC_TLS_INIT(CONTROL_STACK_START,control_stack_start);
STATIC_TLS_INIT(CONTROL_STACK_END,control_stack_end);
STATIC_TLS_INIT(ALIEN_STACK,alien_stack_pointer);
+#ifdef LISP_FEATURE_X86
STATIC_TLS_INIT(PSEUDO_ATOMIC_ATOMIC,pseudo_atomic_atomic);
STATIC_TLS_INIT(PSEUDO_ATOMIC_INTERRUPTED,pseudo_atomic_interrupted);
+#endif
#undef STATIC_TLS_INIT
#endif
}
#else
th->alien_stack_pointer=((void *)th->alien_stack_start);
#endif
+#ifdef LISP_FEATURE_X86
th->pseudo_atomic_interrupted=0;
/* 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);
+#endif
#ifdef LISP_FEATURE_GENCGC
gc_set_region_empty(&th->alloc_region);
#endif
bind_variable(INTERRUPT_PENDING, NIL,th);
bind_variable(INTERRUPTS_ENABLED,T,th);
- th->interrupt_data=malloc(sizeof (struct interrupt_data));
+ th->interrupt_data=os_validate(0,(sizeof (struct interrupt_data)));
if(all_threads)
memcpy(th->interrupt_data,
arch_os_get_current_thread()->interrupt_data,
static inline lispobj SymbolValue(u32 tagged_symbol_pointer, void *thread) {
struct symbol *sym= (struct symbol *)
- (tagged_symbol_pointer-OTHER_POINTER_LOWTAG);
+ (pointer_sized_uint_t)(tagged_symbol_pointer-OTHER_POINTER_LOWTAG);
#ifdef LISP_FEATURE_SB_THREAD
if(thread && sym->tls_index) {
lispobj r=
}
static inline lispobj SymbolTlValue(u32 tagged_symbol_pointer, void *thread) {
struct symbol *sym= (struct symbol *)
- (tagged_symbol_pointer-OTHER_POINTER_LOWTAG);
+ (pointer_sized_uint_t)(tagged_symbol_pointer-OTHER_POINTER_LOWTAG);
#ifdef LISP_FEATURE_SB_THREAD
return ((union per_thread_data *)thread)
->dynamic_values[fixnum_value(sym->tls_index)];
static inline void SetSymbolValue(u32 tagged_symbol_pointer,lispobj val, void *thread) {
struct symbol *sym= (struct symbol *)
- (tagged_symbol_pointer-OTHER_POINTER_LOWTAG);
+ (pointer_sized_uint_t)(tagged_symbol_pointer-OTHER_POINTER_LOWTAG);
#ifdef LISP_FEATURE_SB_THREAD
if(thread && sym->tls_index) {
lispobj *pr= &(((union per_thread_data *)thread)
static inline void SetTlSymbolValue(u32 tagged_symbol_pointer,lispobj val, void *thread) {
#ifdef LISP_FEATURE_SB_THREAD
struct symbol *sym= (struct symbol *)
- (tagged_symbol_pointer-OTHER_POINTER_LOWTAG);
+ (pointer_sized_uint_t)(tagged_symbol_pointer-OTHER_POINTER_LOWTAG);
((union per_thread_data *)thread)
->dynamic_values[fixnum_value(sym->tls_index)]
=val;
projects / sbcl.git / commitdiff