From 34dcb46f78a01d543756703d7ccdf3d999a134d0 Mon Sep 17 00:00:00 2001 From: Daniel Barlow Date: Mon, 7 Apr 2003 13:16:52 +0000 Subject: [PATCH] 0.pre8.40 === Threads merge, 0.390625 metres === Unithread fixes for all remaining architectures, although I'm not 100% that BSD ports are all working. Various 32/64 bit fixes for Alpha Removed the allocate-16Mb-at-a-time hacks from the Linux port, substitute with MAP_NORESERVE: CMUCL has been doing this for a long time already without user complaint. Also the retryable mmap errors: as there's no logic in the caller to actually retry, we'd be better off losing if mmap fails. --- src/code/target-unithread.lisp | 5 +- src/compiler/alpha/parms.lisp | 11 ++-- src/compiler/generic/objdef.lisp | 26 ++++----- src/compiler/hppa/parms.lisp | 10 ++-- src/compiler/mips/parms.lisp | 6 -- src/runtime/alpha-arch.c | 5 ++ src/runtime/alpha-linux-os.c | 14 +++++ src/runtime/alpha-osf1-os.c | 13 +++++ src/runtime/bsd-os.c | 17 ++++-- src/runtime/hppa-arch.c | 6 ++ src/runtime/hppa-linux-os.c | 13 +++++ src/runtime/linux-os.c | 113 ++++++++++---------------------------- src/runtime/mips-arch.c | 5 ++ src/runtime/mips-linux-os.c | 13 +++++ src/runtime/osf1-os.c | 6 -- src/runtime/purify.c | 7 +-- src/runtime/sparc-linux-os.c | 13 +++++ src/runtime/thread.c | 6 +- src/runtime/thread.h | 8 +-- 19 files changed, 160 insertions(+), 137 deletions(-) diff --git a/src/code/target-unithread.lisp b/src/code/target-unithread.lisp index bd57e74..c684a3c 100644 --- a/src/code/target-unithread.lisp +++ b/src/code/target-unithread.lisp @@ -1,5 +1,6 @@ (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)) @@ -7,8 +8,8 @@ (* 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 diff --git a/src/compiler/alpha/parms.lisp b/src/compiler/alpha/parms.lisp index f208e17..5bb2213 100644 --- a/src/compiler/alpha/parms.lisp +++ b/src/compiler/alpha/parms.lisp @@ -139,13 +139,6 @@ (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. @@ -208,6 +201,10 @@ *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* diff --git a/src/compiler/generic/objdef.lisp b/src/compiler/generic/objdef.lisp index 85a0b4b..ff6ae86 100644 --- a/src/compiler/generic/objdef.lisp +++ b/src/compiler/generic/objdef.lisp @@ -370,19 +370,19 @@ ;; 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)) diff --git a/src/compiler/hppa/parms.lisp b/src/compiler/hppa/parms.lisp index 3ebb8b2..6be70c6 100644 --- a/src/compiler/hppa/parms.lisp +++ b/src/compiler/hppa/parms.lisp @@ -66,12 +66,6 @@ (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) @@ -142,6 +136,10 @@ ;; 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* diff --git a/src/compiler/mips/parms.lisp b/src/compiler/mips/parms.lisp index 2fd09ce..50d4d4e 100644 --- a/src/compiler/mips/parms.lisp +++ b/src/compiler/mips/parms.lisp @@ -63,12 +63,6 @@ (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) diff --git a/src/runtime/alpha-arch.c b/src/runtime/alpha-arch.c index 4402723..20f86a4 100644 --- a/src/runtime/alpha-arch.c +++ b/src/runtime/alpha-arch.c @@ -369,6 +369,11 @@ void arch_install_interrupt_handlers() 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) diff --git a/src/runtime/alpha-linux-os.c b/src/runtime/alpha-linux-os.c index 80c8913..e8e8ec0 100644 --- a/src/runtime/alpha-linux-os.c +++ b/src/runtime/alpha-linux-os.c @@ -39,6 +39,20 @@ #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) diff --git a/src/runtime/alpha-osf1-os.c b/src/runtime/alpha-osf1-os.c index 14362c8..d4e54d8 100644 --- a/src/runtime/alpha-osf1-os.c +++ b/src/runtime/alpha-osf1-os.c @@ -41,6 +41,19 @@ #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) diff --git a/src/runtime/bsd-os.c b/src/runtime/bsd-os.c index 707ea9a..bcca635 100644 --- a/src/runtime/bsd-os.c +++ b/src/runtime/bsd-os.c @@ -190,11 +190,18 @@ in_range_p(os_vm_address_t a, lispobj sbeg, size_t slen) 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; } /* diff --git a/src/runtime/hppa-arch.c b/src/runtime/hppa-arch.c index 9e8abb6..8d2ae21 100644 --- a/src/runtime/hppa-arch.c +++ b/src/runtime/hppa-arch.c @@ -416,6 +416,12 @@ void arch_install_interrupt_handlers(void) 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; diff --git a/src/runtime/hppa-linux-os.c b/src/runtime/hppa-linux-os.c index a6b39dc..f69b16b 100644 --- a/src/runtime/hppa-linux-os.c +++ b/src/runtime/hppa-linux-os.c @@ -37,6 +37,19 @@ #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) diff --git a/src/runtime/linux-os.c b/src/runtime/linux-os.c index 9669247..113563a 100644 --- a/src/runtime/linux-os.c +++ b/src/runtime/linux-os.c @@ -90,96 +90,43 @@ void os_init(void) #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 diff --git a/src/runtime/mips-arch.c b/src/runtime/mips-arch.c index 7b68e65..c1ca525 100644 --- a/src/runtime/mips-arch.c +++ b/src/runtime/mips-arch.c @@ -351,6 +351,11 @@ void arch_install_interrupt_handlers() 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) diff --git a/src/runtime/mips-linux-os.c b/src/runtime/mips-linux-os.c index e9d9803..27ced24 100644 --- a/src/runtime/mips-linux-os.c +++ b/src/runtime/mips-linux-os.c @@ -42,6 +42,19 @@ #include 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) diff --git a/src/runtime/osf1-os.c b/src/runtime/osf1-os.c index 57ee8c1..5dd0d46 100644 --- a/src/runtime/osf1-os.c +++ b/src/runtime/osf1-os.c @@ -132,12 +132,6 @@ sigsegv_handler(int signal, siginfo_t *info, void* void_context) /* 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_END) && (addrcontrol_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 diff --git a/src/runtime/sparc-linux-os.c b/src/runtime/sparc-linux-os.c index fec7970..8c685c2 100644 --- a/src/runtime/sparc-linux-os.c +++ b/src/runtime/sparc-linux-os.c @@ -37,6 +37,19 @@ #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) diff --git a/src/runtime/thread.c b/src/runtime/thread.c index 45086eb..4056eb0 100644 --- a/src/runtime/thread.c +++ b/src/runtime/thread.c @@ -120,8 +120,10 @@ pid_t create_thread(lispobj initial_function) { 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 } @@ -141,10 +143,12 @@ pid_t create_thread(lispobj initial_function) { #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 @@ -175,7 +179,7 @@ pid_t create_thread(lispobj initial_function) { 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, diff --git a/src/runtime/thread.h b/src/runtime/thread.h index cf0a26e..f1a1df9 100644 --- a/src/runtime/thread.h +++ b/src/runtime/thread.h @@ -39,7 +39,7 @@ extern struct thread *find_thread_by_pid(pid_t pid); 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= @@ -52,7 +52,7 @@ static inline lispobj SymbolValue(u32 tagged_symbol_pointer, void *thread) { } 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)]; @@ -63,7 +63,7 @@ static inline lispobj SymbolTlValue(u32 tagged_symbol_pointer, void *thread) { 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) @@ -79,7 +79,7 @@ static inline void SetSymbolValue(u32 tagged_symbol_pointer,lispobj val, void *t 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; -- 1.7.10.4