diff options
Diffstat (limited to 'libguile')
-rw-r--r-- | libguile/debug.c | 13 | ||||
-rw-r--r-- | libguile/debug.h | 4 | ||||
-rw-r--r-- | libguile/eval.c | 46 | ||||
-rw-r--r-- | libguile/eval.h | 7 | ||||
-rw-r--r-- | libguile/gc.c | 4 | ||||
-rw-r--r-- | libguile/i18n.c | 3 | ||||
-rw-r--r-- | libguile/macros.c | 34 | ||||
-rw-r--r-- | libguile/symbols.c | 50 | ||||
-rw-r--r-- | libguile/threads.c | 1 | ||||
-rw-r--r-- | libguile/threads.h | 4 | ||||
-rw-r--r-- | libguile/vm-i-system.c | 25 |
11 files changed, 124 insertions, 67 deletions
diff --git a/libguile/debug.c b/libguile/debug.c index c6ce99e7c..87513bf48 100644 --- a/libguile/debug.c +++ b/libguile/debug.c @@ -1,5 +1,5 @@ /* Debugging extensions for Guile - * Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2006, 2008, 2009, 2010, 2011 Free Software Foundation + * Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2006, 2008, 2009, 2010, 2011, 2012 Free Software Foundation * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public License @@ -199,6 +199,17 @@ SCM_DEFINE (scm_debug_hang, "debug-hang", 0, 1, 0, #undef FUNC_NAME #endif +SCM +scm_local_eval (SCM exp, SCM env) +{ + static SCM local_eval_var = SCM_BOOL_F; + + if (scm_is_false (local_eval_var)) + local_eval_var = scm_c_public_variable ("ice-9 local-eval", "local-eval"); + + return scm_call_2 (SCM_VARIABLE_REF (local_eval_var), exp, env); +} + static void init_stack_limit (void) { diff --git a/libguile/debug.h b/libguile/debug.h index 0749d283c..362d9b7e2 100644 --- a/libguile/debug.h +++ b/libguile/debug.h @@ -3,7 +3,7 @@ #ifndef SCM_DEBUG_H #define SCM_DEBUG_H -/* Copyright (C) 1995,1996,1998,1999,2000,2001,2002,2004,2008,2009,2010,2011 +/* Copyright (C) 1995,1996,1998,1999,2000,2001,2002,2004,2008,2009,2010,2011,2012 * Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or @@ -41,6 +41,8 @@ typedef union scm_t_debug_info +SCM_API SCM scm_local_eval (SCM exp, SCM env); + SCM_API SCM scm_reverse_lookup (SCM env, SCM data); SCM_API SCM scm_procedure_source (SCM proc); SCM_API SCM scm_procedure_name (SCM proc); diff --git a/libguile/eval.c b/libguile/eval.c index ad0a84a58..5a42b1ead 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -24,6 +24,7 @@ #endif #include <alloca.h> +#include <stdarg.h> #include "libguile/__scm.h" @@ -521,11 +522,56 @@ scm_call_6 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM arg4, SCM arg5, } SCM +scm_call_7 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM arg4, SCM arg5, + SCM arg6, SCM arg7) +{ + SCM args[] = { arg1, arg2, arg3, arg4, arg5, arg6, arg7 }; + return scm_c_vm_run (scm_the_vm (), proc, args, 7); +} + +SCM +scm_call_8 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM arg4, SCM arg5, + SCM arg6, SCM arg7, SCM arg8) +{ + SCM args[] = { arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8 }; + return scm_c_vm_run (scm_the_vm (), proc, args, 8); +} + +SCM +scm_call_9 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM arg4, SCM arg5, + SCM arg6, SCM arg7, SCM arg8, SCM arg9) +{ + SCM args[] = { arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8, arg9 }; + return scm_c_vm_run (scm_the_vm (), proc, args, 9); +} + +SCM scm_call_n (SCM proc, SCM *argv, size_t nargs) { return scm_c_vm_run (scm_the_vm (), proc, argv, nargs); } +SCM +scm_call (SCM proc, ...) +{ + va_list argp; + SCM *argv = NULL; + size_t i, nargs = 0; + + va_start (argp, proc); + while (!SCM_UNBNDP (va_arg (argp, SCM))) + nargs++; + va_end (argp); + + argv = alloca (nargs * sizeof (SCM)); + va_start (argp, proc); + for (i = 0; i < nargs; i++) + argv[i] = va_arg (argp, SCM); + va_end (argp); + + return scm_c_vm_run (scm_the_vm (), proc, argv, nargs); +} + /* Simple procedure applies */ diff --git a/libguile/eval.h b/libguile/eval.h index f193ad64e..014f0dec5 100644 --- a/libguile/eval.h +++ b/libguile/eval.h @@ -72,7 +72,14 @@ SCM_API SCM scm_call_5 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM arg4, SCM arg5); SCM_API SCM scm_call_6 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM arg4, SCM arg5, SCM arg6); +SCM_API SCM scm_call_7 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM arg4, + SCM arg5, SCM arg6, SCM arg7); +SCM_API SCM scm_call_8 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM arg4, + SCM arg5, SCM arg6, SCM arg7, SCM arg8); +SCM_API SCM scm_call_9 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM arg4, + SCM arg5, SCM arg6, SCM arg7, SCM arg8, SCM arg9); SCM_API SCM scm_call_n (SCM proc, SCM *argv, size_t nargs); +SCM_API SCM scm_call (SCM proc, ...); SCM_API SCM scm_apply_0 (SCM proc, SCM args); SCM_API SCM scm_apply_1 (SCM proc, SCM arg1, SCM args); SCM_API SCM scm_apply_2 (SCM proc, SCM arg1, SCM arg2, SCM args); diff --git a/libguile/gc.c b/libguile/gc.c index 5f61a1de8..6d44f5e38 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -227,6 +227,10 @@ scm_t_c_hook scm_after_gc_c_hook; static void run_before_gc_c_hook (void) { + if (!SCM_I_CURRENT_THREAD) + /* GC while a thread is spinning up; punt. */ + return; + scm_c_hook_run (&scm_before_gc_c_hook, NULL); } diff --git a/libguile/i18n.c b/libguile/i18n.c index 4bb9e2137..5a53bfae5 100644 --- a/libguile/i18n.c +++ b/libguile/i18n.c @@ -645,6 +645,7 @@ SCM_DEFINE (scm_make_locale, "make-locale", 2, 1, 0, c_locale = newlocale (c_category_mask, c_locale_name, c_base_locale); free (c_locale_name); + c_locale_name = NULL; if (c_locale == (locale_t) 0) { @@ -662,6 +663,7 @@ SCM_DEFINE (scm_make_locale, "make-locale", 2, 1, 0, c_locale->category_mask = c_category_mask; c_locale->locale_name = scm_gc_strdup (c_locale_name, "locale"); free (c_locale_name); + c_locale_name = NULL; if (scm_is_eq (base_locale, SCM_VARIABLE_REF (scm_global_locale))) { @@ -1652,6 +1654,7 @@ SCM_DEFINE (scm_nl_langinfo, "nl-langinfo", 1, 1, 0, default: result = scm_from_latin1_symbol ("unspecified"); } + free (c_result); break; #endif diff --git a/libguile/macros.c b/libguile/macros.c index 7423e9758..34aa60c83 100644 --- a/libguile/macros.c +++ b/libguile/macros.c @@ -177,12 +177,46 @@ SCM_DEFINE (scm_macro_binding, "macro-binding", 1, 0, 0, #undef FUNC_NAME +static SCM syntax_session_id; + +#define SESSION_ID_LENGTH 22 /* bytes */ +#define BASE64_RADIX_BITS 6 +#define BASE64_RADIX (1 << (BASE64_RADIX_BITS)) +#define BASE64_MASK (BASE64_RADIX - 1) + +static SCM +fresh_syntax_session_id (void) +{ + static const char base64[BASE64_RADIX] = + "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789$@"; + + unsigned char digit_buf[SESSION_ID_LENGTH]; + char char_buf[SESSION_ID_LENGTH]; + size_t i; + + scm_i_random_bytes_from_platform (digit_buf, SESSION_ID_LENGTH); + for (i = 0; i < SESSION_ID_LENGTH; ++i) + char_buf[i] = base64[digit_buf[i] & BASE64_MASK]; + + return scm_from_latin1_stringn (char_buf, SESSION_ID_LENGTH); +} + +static SCM +scm_syntax_session_id (void) +{ + return syntax_session_id; +} + + void scm_init_macros () { scm_tc16_macro = scm_make_smob_type ("macro", 0); scm_set_smob_print (scm_tc16_macro, macro_print); #include "libguile/macros.x" + + syntax_session_id = fresh_syntax_session_id(); + scm_c_define_gsubr ("syntax-session-id", 0, 0, 0, scm_syntax_session_id); } /* diff --git a/libguile/symbols.c b/libguile/symbols.c index 9dd204478..9cb300ab0 100644 --- a/libguile/symbols.c +++ b/libguile/symbols.c @@ -33,7 +33,6 @@ #include "libguile/variable.h" #include "libguile/alist.h" #include "libguile/fluids.h" -#include "libguile/threads.h" #include "libguile/strings.h" #include "libguile/vectors.h" #include "libguile/weak-set.h" @@ -379,9 +378,7 @@ SCM_DEFINE (scm_string_ci_to_symbol, "string-ci->symbol", 1, 0, 0, /* The default prefix for `gensym'd symbols. */ static SCM default_gensym_prefix; -#define GENSYM_LENGTH 22 /* bytes */ -#define GENSYM_RADIX_BITS 6 -#define GENSYM_RADIX (1 << (GENSYM_RADIX_BITS)) +#define MAX_PREFIX_LENGTH 30 SCM_DEFINE (scm_gensym, "gensym", 0, 1, 0, (SCM prefix), @@ -392,47 +389,22 @@ SCM_DEFINE (scm_gensym, "gensym", 0, 1, 0, "resetting the counter.") #define FUNC_NAME s_scm_gensym { - static const char base64[GENSYM_RADIX] = - "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789$@"; - static const char base4[4] = "_.-~"; - - unsigned char *digit_buf = SCM_I_CURRENT_THREAD->gensym_counter; - char char_buf[GENSYM_LENGTH]; + static int gensym_counter = 0; + SCM suffix, name; - int i; + int n, n_digits; + char buf[SCM_INTBUFLEN]; if (SCM_UNBNDP (prefix)) prefix = default_gensym_prefix; - if (SCM_UNLIKELY (digit_buf == NULL)) - { - /* This is the first time gensym has been called in this thread. - Allocate and randomize our new thread-local gensym counter */ - digit_buf = (unsigned char *) - scm_gc_malloc_pointerless (GENSYM_LENGTH, "gensym-counter"); - scm_i_random_bytes_from_platform (digit_buf, GENSYM_LENGTH); - for (i = (GENSYM_LENGTH - 1); i >= 0; --i) - digit_buf[i] &= (GENSYM_RADIX - 1); - SCM_I_CURRENT_THREAD->gensym_counter = digit_buf; - } - - /* Increment our thread-local gensym_counter. */ - for (i = (GENSYM_LENGTH - 1); i >= 0; --i) - { - if (SCM_LIKELY (++(digit_buf[i]) < GENSYM_RADIX)) - break; - else - digit_buf[i] = 0; - } - - /* Encode digit_buf as base64, except for the first character where we - use the sparse glyphs "_.-~" (base 4) to provide some visual - separation between the prefix and the dense base64 block. */ - for (i = (GENSYM_LENGTH - 1); i > 0; --i) - char_buf[i] = base64[digit_buf[i]]; - char_buf[0] = base4[digit_buf[0] & 3]; + /* mutex in case another thread looks and incs at the exact same moment */ + scm_i_scm_pthread_mutex_lock (&scm_i_misc_mutex); + n = gensym_counter++; + scm_i_pthread_mutex_unlock (&scm_i_misc_mutex); - suffix = scm_from_latin1_stringn (char_buf, GENSYM_LENGTH); + n_digits = scm_iint2str (n, 10, buf); + suffix = scm_from_latin1_stringn (buf, n_digits); name = scm_string_append (scm_list_2 (prefix, suffix)); return scm_string_to_symbol (name); } diff --git a/libguile/threads.c b/libguile/threads.c index df287b1ac..463414f4a 100644 --- a/libguile/threads.c +++ b/libguile/threads.c @@ -544,7 +544,6 @@ guilify_self_1 (struct GC_stack_base *base) t.join_queue = SCM_EOL; t.dynamic_state = SCM_BOOL_F; t.dynwinds = SCM_EOL; - t.gensym_counter = NULL; t.active_asyncs = SCM_EOL; t.block_asyncs = 1; t.pending_asyncs = 1; diff --git a/libguile/threads.h b/libguile/threads.h index 2d2348bde..54d64141b 100644 --- a/libguile/threads.h +++ b/libguile/threads.h @@ -81,10 +81,6 @@ typedef struct scm_i_thread { SCM dynamic_state; SCM dynwinds; - /* Thread-local gensym counter. - */ - unsigned char *gensym_counter; - /* For system asyncs. */ SCM active_asyncs; /* The thunks to be run at the next diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c index 0804bad5d..8981042f8 100644 --- a/libguile/vm-i-system.c +++ b/libguile/vm-i-system.c @@ -1,6 +1,5 @@ -/* Copyright (C) 2001, 2008, 2009, 2010, 2011, - * 2012 Free Software Foundation, Inc. - * +/* Copyright (C) 2001,2008,2009,2010,2011 Free Software Foundation, Inc. + * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public License * as published by the Free Software Foundation; either version 3 of @@ -20,17 +19,6 @@ /* This file is included in vm_engine.c */ -/* Compiler barrier, to prevent instruction reordering, apparently due - to a bug in GCC 4.3.2 on sparc-linux-gnu and on hppa2.0-linux-gnu. - See <http://bugs.gnu.org/10520>, for details. */ - -#ifdef __GNUC__ -# define COMPILER_BARRIER __asm__ __volatile__ ("") -#else -# define COMPILER_BARRIER do { } while (0) -#endif - - /* * Basic operations @@ -67,7 +55,6 @@ VM_DEFINE_INSTRUCTION (1, halt, "halt", 0, 0, 0) stack */ ip = SCM_FRAME_RETURN_ADDRESS (fp); fp = SCM_FRAME_DYNAMIC_LINK (fp); - COMPILER_BARRIER; NULLSTACK (old_sp - sp); } @@ -1280,7 +1267,6 @@ VM_DEFINE_INSTRUCTION (67, return, "return", 0, 1, 1) sp = SCM_FRAME_LOWER_ADDRESS (fp); ip = SCM_FRAME_RETURN_ADDRESS (fp); fp = SCM_FRAME_DYNAMIC_LINK (fp); - COMPILER_BARRIER; #ifdef VM_ENABLE_STACK_NULLING NULLSTACK (old_sp - sp); @@ -1316,8 +1302,7 @@ VM_DEFINE_INSTRUCTION (68, return_values, "return/values", 1, -1, -1) sp = SCM_FRAME_LOWER_ADDRESS (fp) - 1; ip = SCM_FRAME_MV_RETURN_ADDRESS (fp); fp = SCM_FRAME_DYNAMIC_LINK (fp); - COMPILER_BARRIER; - + /* Push return values, and the number of values */ for (i = 0; i < nvalues; i++) *++sp = vals[i+1]; @@ -1337,8 +1322,7 @@ VM_DEFINE_INSTRUCTION (68, return_values, "return/values", 1, -1, -1) sp = SCM_FRAME_LOWER_ADDRESS (fp) - 1; ip = SCM_FRAME_RETURN_ADDRESS (fp); fp = SCM_FRAME_DYNAMIC_LINK (fp); - COMPILER_BARRIER; - + /* Push first value */ *++sp = vals[1]; @@ -1729,7 +1713,6 @@ VM_DEFINE_INSTRUCTION (93, assert_nargs_ee_locals, "assert-nargs-ee/locals", 1, NEXT; } -#undef COMPILER_BARRIER /* (defun renumber-ops () |