summaryrefslogtreecommitdiff
path: root/libguile
diff options
context:
space:
mode:
Diffstat (limited to 'libguile')
-rw-r--r--libguile/foreign.c2
-rw-r--r--libguile/frames.c11
-rw-r--r--libguile/frames.h7
-rw-r--r--libguile/hashtab.c7
-rw-r--r--libguile/random.c101
-rw-r--r--libguile/random.h3
-rw-r--r--libguile/symbols.c50
-rw-r--r--libguile/threads.c1
-rw-r--r--libguile/threads.h4
-rw-r--r--libguile/vm-i-system.c25
-rw-r--r--libguile/vm.c5
11 files changed, 190 insertions, 26 deletions
diff --git a/libguile/foreign.c b/libguile/foreign.c
index 445ce0289..851cdedd5 100644
--- a/libguile/foreign.c
+++ b/libguile/foreign.c
@@ -316,8 +316,6 @@ SCM_DEFINE (scm_set_pointer_finalizer_x, "set-pointer-finalizer!", 2, 0, 0,
c_finalizer = SCM_POINTER_VALUE (finalizer);
- SCM_SET_CELL_WORD_0 (pointer, SCM_CELL_WORD_0 (pointer) | (1 << 16UL));
-
GC_REGISTER_FINALIZER_NO_ORDER (SCM_HEAP_OBJECT_BASE (pointer),
pointer_finalizer_trampoline,
c_finalizer,
diff --git a/libguile/frames.c b/libguile/frames.c
index b805137a4..b57b1295d 100644
--- a/libguile/frames.c
+++ b/libguile/frames.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 2001, 2009, 2010, 2011 Free Software Foundation, Inc.
+/* Copyright (C) 2001, 2009, 2010, 2011, 2012 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
@@ -24,9 +24,16 @@
#include <string.h>
#include "_scm.h"
#include "frames.h"
+#include <verify.h>
+
+/* Make sure assumptions on the layout of `struct scm_vm_frame' hold. */
+verify (sizeof (SCM) == sizeof (SCM *));
+verify (sizeof (struct scm_vm_frame) == 5 * sizeof (SCM));
+verify (offsetof (struct scm_vm_frame, dynamic_link) == 0);
-#define RELOC(frame, val) (val + SCM_VM_FRAME_OFFSET (frame))
+#define RELOC(frame, val) \
+ (((SCM *) (val)) + SCM_VM_FRAME_OFFSET (frame))
SCM
scm_c_make_frame (SCM stack_holder, SCM *fp, SCM *sp,
diff --git a/libguile/frames.h b/libguile/frames.h
index cae2bd0c0..71d5b124d 100644
--- a/libguile/frames.h
+++ b/libguile/frames.h
@@ -70,9 +70,10 @@ struct scm_vm_frame
SCM stack[1]; /* Variable-length */
};
-#define SCM_FRAME_STRUCT(fp) ((struct scm_vm_frame*)(((SCM*)(fp)) - 4))
+#define SCM_FRAME_STRUCT(fp) \
+ ((struct scm_vm_frame *) SCM_FRAME_DATA_ADDRESS (fp))
-#define SCM_FRAME_DATA_ADDRESS(fp) (fp - 4)
+#define SCM_FRAME_DATA_ADDRESS(fp) (((SCM *) (fp)) - 4)
#define SCM_FRAME_STACK_ADDRESS(fp) (SCM_FRAME_STRUCT (fp)->stack)
#define SCM_FRAME_UPPER_ADDRESS(fp) ((SCM*)&SCM_FRAME_STRUCT (fp)->return_address)
#define SCM_FRAME_LOWER_ADDRESS(fp) ((SCM*)SCM_FRAME_STRUCT (fp))
@@ -91,7 +92,7 @@ struct scm_vm_frame
#define SCM_FRAME_DYNAMIC_LINK(fp) \
(SCM_FRAME_STRUCT (fp)->dynamic_link)
#define SCM_FRAME_SET_DYNAMIC_LINK(fp, dl) \
- SCM_FRAME_STRUCT (fp)->dynamic_link = (dl)
+ SCM_FRAME_DYNAMIC_LINK (fp) = (dl)
#define SCM_FRAME_VARIABLE(fp,i) \
(SCM_FRAME_STRUCT (fp)->stack[i])
#define SCM_FRAME_PROGRAM(fp) \
diff --git a/libguile/hashtab.c b/libguile/hashtab.c
index 4091afeb9..e6406429e 100644
--- a/libguile/hashtab.c
+++ b/libguile/hashtab.c
@@ -1,5 +1,6 @@
-/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2003, 2004, 2006, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
- *
+/* Copyright (C) 1995, 1996, 1998, 1999, 2000, 2001, 2003, 2004, 2006,
+ * 2008, 2009, 2010, 2011, 2012 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
@@ -168,6 +169,8 @@ void
scm_i_hashtable_print (SCM exp, SCM port, scm_print_state *pstate)
{
scm_puts_unlocked ("#<hash-table ", port);
+ scm_uintprint (SCM_UNPACK (exp), 16, port);
+ scm_putc (' ', port);
scm_uintprint (SCM_HASHTABLE_N_ITEMS (exp), 10, port);
scm_putc_unlocked ('/', port);
scm_uintprint (SCM_SIMPLE_VECTOR_LENGTH (SCM_HASHTABLE_VECTOR (exp)),
diff --git a/libguile/random.c b/libguile/random.c
index 8bc0d8764..2db19f729 100644
--- a/libguile/random.c
+++ b/libguile/random.c
@@ -653,6 +653,107 @@ SCM_DEFINE (scm_random_exp, "random:exp", 0, 1, 0,
}
#undef FUNC_NAME
+/* Return a new random-state seeded from the time, date, process ID, an
+ address from a freshly allocated heap cell, an address from the local
+ stack frame, and a high-resolution timer if available. This is only
+ to be used as a last resort, when no better source of entropy is
+ available. */
+static SCM
+random_state_of_last_resort (void)
+{
+ SCM state;
+ SCM time_of_day = scm_gettimeofday ();
+ SCM sources = scm_list_n
+ (scm_from_unsigned_integer (SCM_UNPACK (time_of_day)), /* heap addr */
+ scm_getpid (), /* process ID */
+ scm_get_internal_real_time (), /* high-resolution process timer */
+ scm_from_unsigned_integer ((scm_t_bits) &time_of_day), /* stack addr */
+ scm_car (time_of_day), /* seconds since midnight 1970-01-01 UTC */
+ scm_cdr (time_of_day), /* microsecond component of the above clock */
+ SCM_UNDEFINED);
+
+ /* Concatenate the sources bitwise to form the seed */
+ SCM seed = SCM_INUM0;
+ while (scm_is_pair (sources))
+ {
+ seed = scm_logxor (seed, scm_ash (scm_car (sources),
+ scm_integer_length (seed)));
+ sources = scm_cdr (sources);
+ }
+
+ /* FIXME The following code belongs in `scm_seed_to_random_state',
+ and here we should simply do:
+
+ return scm_seed_to_random_state (seed);
+
+ Unfortunately, `scm_seed_to_random_state' only preserves around 32
+ bits of entropy from the provided seed. I don't know if it's okay
+ to fix that in 2.0, so for now we have this workaround. */
+ {
+ int i, len;
+ unsigned char *buf;
+ len = scm_to_int (scm_ceiling_quotient (scm_integer_length (seed),
+ SCM_I_MAKINUM (8)));
+ buf = (unsigned char *) malloc (len);
+ for (i = len-1; i >= 0; --i)
+ {
+ buf[i] = scm_to_int (scm_logand (seed, SCM_I_MAKINUM (255)));
+ seed = scm_ash (seed, SCM_I_MAKINUM (-8));
+ }
+ state = make_rstate (scm_c_make_rstate ((char *) buf, len));
+ free (buf);
+ }
+ return state;
+}
+
+/* Attempt to fill buffer with random bytes from /dev/urandom.
+ Return 1 if successful, else return 0. */
+static int
+read_dev_urandom (unsigned char *buf, size_t len)
+{
+ size_t res = 0;
+ FILE *f = fopen ("/dev/urandom", "r");
+ if (f)
+ {
+ res = fread(buf, 1, len, f);
+ fclose (f);
+ }
+ return (res == len);
+}
+
+/* Fill a buffer with random bytes seeded from a platform-specific
+ source of entropy. /dev/urandom is used if available. Note that
+ this function provides no guarantees about the amount of entropy
+ present in the returned bytes. */
+void
+scm_i_random_bytes_from_platform (unsigned char *buf, size_t len)
+{
+ if (read_dev_urandom (buf, len))
+ return;
+ else /* FIXME: support other platform sources */
+ {
+ /* When all else fails, use this (rather weak) fallback */
+ SCM random_state = random_state_of_last_resort ();
+ int i;
+ for (i = len-1; i >= 0; --i)
+ buf[i] = scm_to_int (scm_random (SCM_I_MAKINUM (256), random_state));
+ }
+}
+
+SCM_DEFINE (scm_random_state_from_platform, "random-state-from-platform", 0, 0, 0,
+ (void),
+ "Construct a new random state seeded from a platform-specific\n\
+source of entropy, appropriate for use in non-security-critical applications.")
+#define FUNC_NAME s_scm_random_state_from_platform
+{
+ unsigned char buf[32];
+ if (read_dev_urandom (buf, sizeof(buf)))
+ return make_rstate (scm_c_make_rstate ((char *) buf, sizeof(buf)));
+ else
+ return random_state_of_last_resort ();
+}
+#undef FUNC_NAME
+
void
scm_init_random ()
{
diff --git a/libguile/random.h b/libguile/random.h
index 2f1f0f69a..109969e01 100644
--- a/libguile/random.h
+++ b/libguile/random.h
@@ -86,6 +86,7 @@ SCM_API SCM scm_copy_random_state (SCM state);
SCM_API SCM scm_seed_to_random_state (SCM seed);
SCM_API SCM scm_datum_to_random_state (SCM datum);
SCM_API SCM scm_random_state_to_datum (SCM state);
+SCM_API SCM scm_random_state_from_platform (void);
SCM_API SCM scm_random_uniform (SCM state);
SCM_API SCM scm_random_solid_sphere_x (SCM v, SCM state);
SCM_API SCM scm_random_hollow_sphere_x (SCM v, SCM state);
@@ -94,6 +95,8 @@ SCM_API SCM scm_random_normal_vector_x (SCM v, SCM state);
SCM_API SCM scm_random_exp (SCM state);
SCM_INTERNAL void scm_init_random (void);
+SCM_INTERNAL void scm_i_random_bytes_from_platform (unsigned char *buf, size_t len);
+
#endif /* SCM_RANDOM_H */
/*
diff --git a/libguile/symbols.c b/libguile/symbols.c
index 9cb300ab0..9dd204478 100644
--- a/libguile/symbols.c
+++ b/libguile/symbols.c
@@ -33,6 +33,7 @@
#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"
@@ -378,7 +379,9 @@ 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 MAX_PREFIX_LENGTH 30
+#define GENSYM_LENGTH 22 /* bytes */
+#define GENSYM_RADIX_BITS 6
+#define GENSYM_RADIX (1 << (GENSYM_RADIX_BITS))
SCM_DEFINE (scm_gensym, "gensym", 0, 1, 0,
(SCM prefix),
@@ -389,22 +392,47 @@ SCM_DEFINE (scm_gensym, "gensym", 0, 1, 0,
"resetting the counter.")
#define FUNC_NAME s_scm_gensym
{
- static int gensym_counter = 0;
-
+ 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];
SCM suffix, name;
- int n, n_digits;
- char buf[SCM_INTBUFLEN];
+ int i;
if (SCM_UNBNDP (prefix))
prefix = default_gensym_prefix;
- /* 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);
+ 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];
- n_digits = scm_iint2str (n, 10, buf);
- suffix = scm_from_latin1_stringn (buf, n_digits);
+ suffix = scm_from_latin1_stringn (char_buf, GENSYM_LENGTH);
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 463414f4a..df287b1ac 100644
--- a/libguile/threads.c
+++ b/libguile/threads.c
@@ -544,6 +544,7 @@ 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 54d64141b..2d2348bde 100644
--- a/libguile/threads.h
+++ b/libguile/threads.h
@@ -81,6 +81,10 @@ 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 8981042f8..0804bad5d 100644
--- a/libguile/vm-i-system.c
+++ b/libguile/vm-i-system.c
@@ -1,5 +1,6 @@
-/* Copyright (C) 2001,2008,2009,2010,2011 Free Software Foundation, Inc.
- *
+/* Copyright (C) 2001, 2008, 2009, 2010, 2011,
+ * 2012 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
@@ -19,6 +20,17 @@
/* 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
@@ -55,6 +67,7 @@ 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);
}
@@ -1267,6 +1280,7 @@ 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);
@@ -1302,7 +1316,8 @@ 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];
@@ -1322,7 +1337,8 @@ 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];
@@ -1713,6 +1729,7 @@ VM_DEFINE_INSTRUCTION (93, assert_nargs_ee_locals, "assert-nargs-ee/locals", 1,
NEXT;
}
+#undef COMPILER_BARRIER
/*
(defun renumber-ops ()
diff --git a/libguile/vm.c b/libguile/vm.c
index 859658816..e386202ad 100644
--- a/libguile/vm.c
+++ b/libguile/vm.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 2001, 2009, 2010, 2011 Free Software Foundation, Inc.
+/* Copyright (C) 2001, 2009, 2010, 2011, 2012 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
@@ -280,7 +280,8 @@ vm_reinstate_partial_continuation (SCM vm, SCM cont, SCM intwinds,
cp = SCM_VM_CONT_DATA (cont);
base = SCM_FRAME_UPPER_ADDRESS (vp->fp) + 1;
-#define RELOC(scm_p) (scm_p + cp->reloc + (base - cp->stack_base))
+#define RELOC(scm_p) \
+ (((SCM *) (scm_p)) + cp->reloc + (base - cp->stack_base))
if ((base - vp->stack_base) + cp->stack_size + n + 1 > vp->stack_size)
scm_misc_error ("vm-engine",