diff options
Diffstat (limited to 'libguile')
-rw-r--r-- | libguile/Makefile.am | 1 | ||||
-rw-r--r-- | libguile/bytevectors.c | 90 | ||||
-rw-r--r-- | libguile/filesys.c | 28 | ||||
-rw-r--r-- | libguile/goops.c | 15 | ||||
-rw-r--r-- | libguile/i18n.c | 2 | ||||
-rw-r--r-- | libguile/load.c | 25 | ||||
-rw-r--r-- | libguile/modules.c | 75 | ||||
-rw-r--r-- | libguile/read.c | 11 | ||||
-rw-r--r-- | libguile/threads.c | 18 | ||||
-rw-r--r-- | libguile/vm-engine.c | 18 | ||||
-rw-r--r-- | libguile/vm-engine.h | 8 |
11 files changed, 202 insertions, 89 deletions
diff --git a/libguile/Makefile.am b/libguile/Makefile.am index e69a1551e..1817100fd 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -647,6 +647,7 @@ libpath.h: $(srcdir)/Makefile.in $(top_builddir)/config.status @echo '#define SCM_LIB_DIR "$(libdir)"' >> libpath.tmp @echo '#define SCM_EXTENSIONS_DIR "$(pkglibdir)/$(GUILE_EFFECTIVE_VERSION)/extensions"' >> libpath.tmp @echo '#define SCM_CCACHE_DIR "$(pkglibdir)/$(GUILE_EFFECTIVE_VERSION)/ccache"' >> libpath.tmp + @echo '#define SCM_SITE_CCACHE_DIR "$(pkglibdir)/$(GUILE_EFFECTIVE_VERSION)/site-ccache"' >> libpath.tmp @echo '#define SCM_EFFECTIVE_VERSION "$(GUILE_EFFECTIVE_VERSION)"' >> libpath.tmp @echo '#define SCM_BUILD_INFO { \' >> libpath.tmp @echo ' { "srcdir", "'"`cd @srcdir@; pwd`"'" }, \' >> libpath.tmp diff --git a/libguile/bytevectors.c b/libguile/bytevectors.c index 90252a7a0..99ac1761d 100644 --- a/libguile/bytevectors.c +++ b/libguile/bytevectors.c @@ -2109,26 +2109,56 @@ SCM_DEFINE (scm_utf32_to_string, "utf32->string", /* Bytevectors as generalized vectors & arrays. */ +#define COMPLEX_ACCESSOR_PROLOGUE(_type) \ + size_t c_len, c_index; \ + char *c_bv; \ + \ + SCM_VALIDATE_BYTEVECTOR (1, bv); \ + c_index = scm_to_size_t (index); \ + \ + c_len = SCM_BYTEVECTOR_LENGTH (bv); \ + c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv); \ + \ + if (SCM_UNLIKELY (c_index + 2 * sizeof (_type) - 1 >= c_len)) \ + scm_out_of_range (FUNC_NAME, index); + +/* Template for native access to complex numbers of type TYPE. */ +#define COMPLEX_NATIVE_REF(_type) \ + SCM result; \ + \ + COMPLEX_ACCESSOR_PROLOGUE (_type); \ + \ + { \ + _type real, imag; \ + \ + memcpy (&real, &c_bv[c_index], sizeof (_type)); \ + memcpy (&imag, &c_bv[c_index + sizeof (_type)], sizeof (_type)); \ + \ + result = scm_c_make_rectangular (real, imag); \ + } \ + \ + return result; static SCM -bytevector_ref_c32 (SCM bv, SCM idx) -{ /* FIXME add some checks */ - const float *contents = (const float*)SCM_BYTEVECTOR_CONTENTS (bv); - size_t i = scm_to_size_t (idx); - return scm_c_make_rectangular (contents[i/4], contents[i/4 + 1]); +bytevector_ref_c32 (SCM bv, SCM index) +#define FUNC_NAME "bytevector_ref_c32" +{ + COMPLEX_NATIVE_REF (float); } +#undef FUNC_NAME static SCM -bytevector_ref_c64 (SCM bv, SCM idx) -{ /* FIXME add some checks */ - const double *contents = (const double*)SCM_BYTEVECTOR_CONTENTS (bv); - size_t i = scm_to_size_t (idx); - return scm_c_make_rectangular (contents[i/8], contents[i/8 + 1]); +bytevector_ref_c64 (SCM bv, SCM index) +#define FUNC_NAME "bytevector_ref_c64" +{ + COMPLEX_NATIVE_REF (double); } +#undef FUNC_NAME typedef SCM (*scm_t_bytevector_ref_fn)(SCM, SCM); -const scm_t_bytevector_ref_fn bytevector_ref_fns[SCM_ARRAY_ELEMENT_TYPE_LAST + 1] = +static const scm_t_bytevector_ref_fn +bytevector_ref_fns[SCM_ARRAY_ELEMENT_TYPE_LAST + 1] = { NULL, /* SCM */ NULL, /* CHAR */ @@ -2160,24 +2190,36 @@ bv_handle_ref (scm_t_array_handle *h, size_t index) return ref_fn (h->array, byte_index); } -/* FIXME add checks!!! */ -static SCM -bytevector_set_c32 (SCM bv, SCM idx, SCM val) -{ float *contents = (float*)SCM_BYTEVECTOR_CONTENTS (bv); - size_t i = scm_to_size_t (idx); - contents[i/4] = scm_c_real_part (val); - contents[i/4 + 1] = scm_c_imag_part (val); +/* Template for native modification of complex numbers of type TYPE. */ +#define COMPLEX_NATIVE_SET(_type) \ + COMPLEX_ACCESSOR_PROLOGUE (_type); \ + \ + { \ + _type real, imag; \ + real = scm_c_real_part (value); \ + imag = scm_c_imag_part (value); \ + \ + memcpy (&c_bv[c_index], &real, sizeof (_type)); \ + memcpy (&c_bv[c_index + sizeof (_type)], &imag, sizeof (_type)); \ + } \ + \ return SCM_UNSPECIFIED; + +static SCM +bytevector_set_c32 (SCM bv, SCM index, SCM value) +#define FUNC_NAME "bytevector_set_c32" +{ + COMPLEX_NATIVE_SET (float); } +#undef FUNC_NAME static SCM -bytevector_set_c64 (SCM bv, SCM idx, SCM val) -{ double *contents = (double*)SCM_BYTEVECTOR_CONTENTS (bv); - size_t i = scm_to_size_t (idx); - contents[i/8] = scm_c_real_part (val); - contents[i/8 + 1] = scm_c_imag_part (val); - return SCM_UNSPECIFIED; +bytevector_set_c64 (SCM bv, SCM index, SCM value) +#define FUNC_NAME "bytevector_set_c64" +{ + COMPLEX_NATIVE_SET (double); } +#undef FUNC_NAME typedef SCM (*scm_t_bytevector_set_fn)(SCM, SCM, SCM); diff --git a/libguile/filesys.c b/libguile/filesys.c index ceec87776..f60032818 100644 --- a/libguile/filesys.c +++ b/libguile/filesys.c @@ -261,8 +261,10 @@ SCM_DEFINE (scm_open, "open", 2, 1, 0, fd = scm_to_int (scm_open_fdes (path, flags, mode)); iflags = SCM_NUM2INT (2, flags); - if (iflags & O_RDWR) + + if ((iflags & O_RDWR) == O_RDWR) { + /* Opened read-write. */ if (iflags & O_APPEND) port_mode = "a+"; else if (iflags & O_CREAT) @@ -270,14 +272,17 @@ SCM_DEFINE (scm_open, "open", 2, 1, 0, else port_mode = "r+"; } - else { - if (iflags & O_APPEND) - port_mode = "a"; - else if (iflags & O_WRONLY) - port_mode = "w"; - else - port_mode = "r"; - } + else + { + /* Opened read-only or write-only. */ + if (iflags & O_APPEND) + port_mode = "a"; + else if (iflags & O_WRONLY) + port_mode = "w"; + else + port_mode = "r"; + } + newpt = scm_fdes_to_port (fd, port_mode, path); return newpt; } @@ -1856,7 +1861,10 @@ scm_init_filesys () #endif #ifdef O_LARGEFILE scm_c_define ("O_LARGEFILE", scm_from_int (O_LARGEFILE)); -#endif +#endif +#ifdef O_NOTRANS + scm_c_define ("O_NOTRANS", scm_from_int (O_NOTRANS)); +#endif #ifdef F_DUPFD scm_c_define ("F_DUPFD", scm_from_int (F_DUPFD)); diff --git a/libguile/goops.c b/libguile/goops.c index 9f6149171..f0a4315c1 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -2284,15 +2284,21 @@ SCM_DEFINE (scm_sys_method_more_specific_p, "%method-more-specific?", 3, 0, 0, * ******************************************************************************/ +/* Munge the CPL of C in place such that BEFORE appears before AFTER, + assuming that currently the reverse is true. Recalculate slots and + associated getters-n-setters. */ static void fix_cpl (SCM c, SCM before, SCM after) { SCM cpl = SCM_SLOT (c, scm_si_cpl); SCM ls = scm_c_memq (after, cpl); - SCM tail = scm_delq1_x (before, SCM_CDR (ls)); + SCM tail; + if (scm_is_false (ls)) /* if this condition occurs, fix_cpl should not be applied this way */ abort (); + + tail = scm_delq1_x (before, SCM_CDR (ls)); SCM_SETCAR (ls, before); SCM_SETCDR (ls, scm_cons (after, tail)); { @@ -2418,8 +2424,8 @@ create_standard_classes (void) make_stdcls (&scm_class_extended_generic_with_setter, "<extended-generic-with-setter>", scm_class_applicable_struct_class, - scm_list_2 (scm_class_generic_with_setter, - scm_class_extended_generic), + scm_list_2 (scm_class_extended_generic, + scm_class_generic_with_setter), SCM_EOL); SCM_SET_CLASS_FLAGS (scm_class_extended_generic_with_setter, SCM_CLASSF_PURE_GENERIC); @@ -2428,8 +2434,9 @@ create_standard_classes (void) scm_list_2 (scm_class_accessor, scm_class_extended_generic_with_setter), SCM_EOL); + /* <extended-generic> is misplaced. */ fix_cpl (scm_class_extended_accessor, - scm_class_extended_generic, scm_class_generic); + scm_class_extended_generic, scm_class_generic_with_setter); SCM_SET_CLASS_FLAGS (scm_class_extended_accessor, SCM_CLASSF_PURE_GENERIC); /* Primitive types classes */ diff --git a/libguile/i18n.c b/libguile/i18n.c index b22b33222..f9ec723a0 100644 --- a/libguile/i18n.c +++ b/libguile/i18n.c @@ -400,7 +400,7 @@ install_locale (scm_t_locale locale) account. */ category_mask |= locale->category_mask; - if (locale->base_locale != SCM_UNDEFINED) + if (!SCM_UNBNDP (locale->base_locale)) locale = (scm_t_locale) SCM_SMOB_DATA (locale->base_locale); else locale = NULL; diff --git a/libguile/load.c b/libguile/load.c index 3b6ba2b38..de6bf7c60 100644 --- a/libguile/load.c +++ b/libguile/load.c @@ -270,7 +270,10 @@ scm_init_load_path () else if (env) cpath = scm_parse_path (scm_from_locale_string (env), cpath); else - cpath = scm_cons (scm_from_locale_string (SCM_CCACHE_DIR), cpath); + { + cpath = scm_list_2 (scm_from_locale_string (SCM_CCACHE_DIR), + scm_from_locale_string (SCM_SITE_CCACHE_DIR)); + } #endif /* SCM_LIBRARY_DIR */ @@ -793,6 +796,22 @@ scm_try_auto_compile (SCM source) NULL, NULL); } +/* See also (system base compile):compiled-file-name. */ +static SCM +canonical_to_suffix (SCM canon) +{ + size_t len = scm_c_string_length (canon); + + if (len > 1 && scm_is_eq (scm_c_string_ref (canon, 0), SCM_MAKE_CHAR ('/'))) + return canon; + else if (len > 2 && scm_is_eq (scm_c_string_ref (canon, 1), SCM_MAKE_CHAR (':'))) + return scm_string_append (scm_list_3 (scm_from_latin1_string ("/"), + scm_c_substring (canon, 0, 1), + scm_c_substring (canon, 2, len))); + else + return canon; +} + SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 0, 0, 1, (SCM args), "Search @var{%load-path} for the file named @var{filename} and\n" @@ -857,7 +876,7 @@ SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 0, 0, 1, { SCM fallback = scm_string_append (scm_list_3 (*scm_loc_compile_fallback_path, - full_filename, + canonical_to_suffix (full_filename), scm_car (*scm_loc_load_compiled_extensions))); if (scm_is_true (scm_stat (fallback, SCM_BOOL_F))) { @@ -895,7 +914,7 @@ SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 0, 0, 1, { SCM fallback = scm_string_append (scm_list_3 (*scm_loc_compile_fallback_path, - full_filename, + canonical_to_suffix (full_filename), scm_car (*scm_loc_load_compiled_extensions))); if (scm_is_true (scm_stat (fallback, SCM_BOOL_F)) && compiled_is_fresh (full_filename, fallback)) diff --git a/libguile/modules.c b/libguile/modules.c index ca8875dab..6c3f2629e 100644 --- a/libguile/modules.c +++ b/libguile/modules.c @@ -294,39 +294,46 @@ resolve_duplicate_binding (SCM module, SCM sym, SCM iface1, SCM var1, SCM iface2, SCM var2) { + SCM args[8]; + SCM handlers; SCM result = SCM_BOOL_F; - if (!scm_is_eq (var1, var2)) + if (scm_is_eq (var1, var2)) + return var1; + + args[0] = module; + args[1] = sym; + args[2] = iface1; + args[3] = SCM_VARIABLE_REF (var1); + if (SCM_UNBNDP (args[3])) + args[3] = SCM_BOOL_F; + args[4] = iface2; + args[5] = SCM_VARIABLE_REF (var2); + if (SCM_UNBNDP (args[5])) + args[5] = SCM_BOOL_F; + args[6] = scm_hashq_ref (SCM_MODULE_IMPORT_OBARRAY (module), sym, SCM_BOOL_F); + args[7] = SCM_BOOL_F; + + handlers = SCM_MODULE_DUPLICATE_HANDLERS (module); + if (scm_is_false (handlers)) + handlers = default_duplicate_binding_handlers (); + + for (; scm_is_pair (handlers); handlers = SCM_CDR (handlers)) { - SCM val1, val2; - SCM handlers, h, handler_args; - - val1 = SCM_VARIABLE_REF (var1); - val2 = SCM_VARIABLE_REF (var2); - - val1 = scm_is_eq (val1, SCM_UNSPECIFIED) ? SCM_BOOL_F : val1; - val2 = scm_is_eq (val2, SCM_UNSPECIFIED) ? SCM_BOOL_F : val2; - - handlers = SCM_MODULE_DUPLICATE_HANDLERS (module); - if (scm_is_false (handlers)) - handlers = default_duplicate_binding_handlers (); - - handler_args = scm_list_n (module, sym, - iface1, val1, iface2, val2, - var1, val1, - SCM_UNDEFINED); - - for (h = handlers; - scm_is_pair (h) && scm_is_false (result); - h = SCM_CDR (h)) - { - result = scm_apply (SCM_CAR (h), handler_args, SCM_EOL); - } + if (scm_is_true (args[6])) + { + args[7] = SCM_VARIABLE_REF (args[6]); + if (SCM_UNBNDP (args[7])) + args[7] = SCM_BOOL_F; + } + + result = scm_call_n (SCM_CAR (handlers), args, 8); + + if (scm_is_true (result)) + return result; } - else - result = var1; - return result; + return SCM_BOOL_F; } /* No lock is needed for access to this variable, as there are no @@ -368,9 +375,15 @@ module_imported_variable (SCM module, SCM sym) { /* SYM is a duplicate binding (imported more than once) so we need to resolve it. */ - found_var = resolve_duplicate_binding (module, sym, - found_iface, found_var, - iface, var); + found_var = resolve_duplicate_binding (module, sym, + found_iface, found_var, + iface, var); + + /* Note that it could be that FOUND_VAR doesn't belong + either to FOUND_IFACE or to IFACE, if it was created + by merge-generics. The right thing to do there would + be to treat the import obarray as the iface, but the + import obarray isn't actually a module. Oh well. */ if (scm_is_eq (found_var, var)) found_iface = iface; } diff --git a/libguile/read.c b/libguile/read.c index 6e7804dd8..c95db5c25 100644 --- a/libguile/read.c +++ b/libguile/read.c @@ -376,8 +376,12 @@ scm_read_sexp (scm_t_wchar chr, SCM port) return SCM_EOL; scm_ungetc (c, port); - if (scm_is_eq (scm_sym_dot, - (tmp = scm_read_expression (port)))) + tmp = scm_read_expression (port); + + /* Note that it is possible for scm_read_expression to return + scm_sym_dot, but not as part of a dotted pair: as in #{.}#. So + check that it's a real dot by checking `c'. */ + if (c == '.' && scm_is_eq (scm_sym_dot, tmp)) { ans = scm_read_expression (port); if (terminating_char != (c = flush_ws (port, FUNC_NAME))) @@ -401,7 +405,8 @@ scm_read_sexp (scm_t_wchar chr, SCM port) scm_ungetc (c, port); tmp = scm_read_expression (port); - if (scm_is_eq (scm_sym_dot, tmp)) + /* See above note about scm_sym_dot. */ + if (c == '.' && scm_is_eq (scm_sym_dot, tmp)) { SCM_SETCDR (tl, tmp = scm_read_expression (port)); diff --git a/libguile/threads.c b/libguile/threads.c index 6f529def2..fcd1c1d2b 100644 --- a/libguile/threads.c +++ b/libguile/threads.c @@ -692,6 +692,10 @@ on_thread_exit (void *v) /* This handler is executed in non-guile mode. */ scm_i_thread *t = (scm_i_thread *) v, **tp; + /* If we were canceled, we were unable to clear `t->guile_mode', so do + it here. */ + t->guile_mode = 0; + /* If this thread was cancelled while doing a cond wait, it will still have a mutex locked, so we unlock it here. */ if (t->held_mutex) @@ -831,12 +835,6 @@ scm_init_guile () } } -SCM_UNUSED static void -scm_leave_guile_cleanup (void *x) -{ - on_thread_exit (SCM_I_CURRENT_THREAD); -} - struct with_guile_args { GC_fn_type func; @@ -1368,7 +1366,9 @@ fat_mutex_lock (SCM mutex, scm_t_timespec *timeout, SCM owner, int *ret) { scm_i_thread *t = SCM_I_THREAD_DATA (new_owner); - scm_i_pthread_mutex_unlock (&m->lock); + /* FIXME: The order in which `t->admin_mutex' and + `m->lock' are taken differs from that in + `on_thread_exit', potentially leading to deadlocks. */ scm_i_pthread_mutex_lock (&t->admin_mutex); /* Only keep a weak reference to MUTEX so that it's not @@ -1379,7 +1379,6 @@ fat_mutex_lock (SCM mutex, scm_t_timespec *timeout, SCM owner, int *ret) t->mutexes = scm_weak_car_pair (mutex, t->mutexes); scm_i_pthread_mutex_unlock (&t->admin_mutex); - scm_i_pthread_mutex_lock (&m->lock); } *ret = 1; break; @@ -1458,6 +1457,9 @@ SCM_DEFINE (scm_lock_mutex_timed, "lock-mutex", 1, 2, 0, waittime = &cwaittime; } + if (!SCM_UNBNDP (owner) && !scm_is_false (owner)) + SCM_VALIDATE_THREAD (3, owner); + exception = fat_mutex_lock (m, waittime, owner, &ret); if (!scm_is_false (exception)) scm_ithrow (SCM_CAR (exception), scm_list_1 (SCM_CDR (exception)), 1); diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c index 22bd39c0e..c90458df6 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -61,23 +61,31 @@ VM_NAME (SCM vm, SCM program, SCM *argv, int nargs) SCM finish_args; /* used both for returns: both in error and normal situations */ #ifdef HAVE_LABELS_AS_VALUES - static void **jump_table = NULL; + static const void **jump_table_pointer = NULL; #endif - + #ifdef HAVE_LABELS_AS_VALUES - if (SCM_UNLIKELY (!jump_table)) + register const void **jump_table JT_REG; + + if (SCM_UNLIKELY (!jump_table_pointer)) { int i; - jump_table = malloc (SCM_VM_NUM_INSTRUCTIONS * sizeof(void*)); + jump_table_pointer = malloc (SCM_VM_NUM_INSTRUCTIONS * sizeof (void*)); for (i = 0; i < SCM_VM_NUM_INSTRUCTIONS; i++) - jump_table[i] = &&vm_error_bad_instruction; + jump_table_pointer[i] = &&vm_error_bad_instruction; #define VM_INSTRUCTION_TO_LABEL 1 +#define jump_table jump_table_pointer #include <libguile/vm-expand.h> #include <libguile/vm-i-system.i> #include <libguile/vm-i-scheme.i> #include <libguile/vm-i-loader.i> +#undef jump_table #undef VM_INSTRUCTION_TO_LABEL } + + /* Attempt to keep JUMP_TABLE_POINTER in a register. This saves one + load instruction at each instruction dispatch. */ + jump_table = jump_table_pointer; #endif /* Initialization */ diff --git a/libguile/vm-engine.h b/libguile/vm-engine.h index 48ab09a12..000397de2 100644 --- a/libguile/vm-engine.h +++ b/libguile/vm-engine.h @@ -57,6 +57,11 @@ /* too few registers! because of register allocation errors with various gcs, just punt on explicit assignments on i386, hoping that the "register" declaration will be sufficient. */ +#elif defined __x86_64__ +/* GCC 4.6 chooses %rbp for IP_REG and %rbx for SP_REG, which works + well. Tell it to keep the jump table in a r12, which is + callee-saved. */ +#define JT_REG asm ("r12") #endif #if defined(PPC) || defined(_POWER) || defined(_IBMR2) #define IP_REG asm("26") @@ -89,6 +94,9 @@ #ifndef FP_REG #define FP_REG #endif +#ifndef JT_REG +#define JT_REG +#endif /* |