[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.0-74-g65ea26
|
From: |
Ludovic Courtès |
|
Subject: |
[Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.0-74-g65ea26c |
|
Date: |
Sun, 06 Mar 2011 22:26:54 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=65ea26c5824bc3be9d327b4470d19e67d7b5d44d
The branch, stable-2.0 has been updated
via 65ea26c5824bc3be9d327b4470d19e67d7b5d44d (commit)
via 821eca02eb50cb65d41f72fe99acbebd5bc5cc7d (commit)
via 364b6eb7cfc39f18477b8f62c1e5d58a1efae69b (commit)
via 8b2633771269173b55e9808b030a9312e8554aef (commit)
via ceed7709becfe64eaaff54aa445b09d1882d589d (commit)
via d8f1c2162c3a34f4bc29ee7f6fab426e6e11e36a (commit)
via 0b2c2ba353d9dcf0b288950b88d6f205a5ec67ab (commit)
via 691fcf66c0a823b2c4f4018e925cf9f338a4de27 (commit)
from d59dd06eb9a3a45b9a385421555b2414345d7272 (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit 65ea26c5824bc3be9d327b4470d19e67d7b5d44d
Author: Ludovic Courtès <address@hidden>
Date: Sun Mar 6 23:02:57 2011 +0100
Handle `letrec*' like `letrec' in simple cases.
* module/language/tree-il/fix-letrec.scm (fix-letrec!): When X is a
`letrec*' with only lambdas and simple expressions, analyze it as if
it were a `letrec'.
* test-suite/tests/tree-il.test ("letrec"): Add test for
`(letrec* (x y) (xx yy) ((const 1) (const 2)) (lexical y yy))'.
commit 821eca02eb50cb65d41f72fe99acbebd5bc5cc7d
Author: Ludovic Courtès <address@hidden>
Date: Sun Mar 6 22:27:53 2011 +0100
Have `gc-profile.scm' make sure it's on a Linux-based system.
* gc-benchmarks/gc-profile.scm (memory-mappings): Check %HOST-TYPE for
"-linux-".
commit 364b6eb7cfc39f18477b8f62c1e5d58a1efae69b
Author: Ludovic Courtès <address@hidden>
Date: Sun Mar 6 22:26:49 2011 +0100
Add `gc-benchmarks/' to the distribution.
* gc-benchmarks/Makefile.am: New file.
* configure.ac: Produce it.
* Makefile.am (SUBDIRS): Add `gc-benchmarks'.
commit 8b2633771269173b55e9808b030a9312e8554aef
Author: Ludovic Courtès <address@hidden>
Date: Sun Mar 6 22:13:10 2011 +0100
Make `object->string' explicitly close its string output port.
* libguile/strports.c (scm_object_to_string): Close PORT before
returning the resulting string.
commit ceed7709becfe64eaaff54aa445b09d1882d589d
Author: Ludovic Courtès <address@hidden>
Date: Sun Mar 6 21:47:48 2011 +0100
Slightly optimize `gensym'.
* libguile/symbols.c (default_gensym_prefix): New variable.
(scm_gensym): Use it. Use `scm_from_latin1_stringn' instead of
`scm_from_locale_stringn'.
(scm_init_symbols): Initialize DEFAULT_GENSYM_PREFIX.
commit d8f1c2162c3a34f4bc29ee7f6fab426e6e11e36a
Author: Ludovic Courtès <address@hidden>
Date: Sun Mar 6 14:31:28 2011 +0100
Simply grow string port buffers geometrically.
* libguile/strports.c (SCM_WRITE_BLOCK): Remove.
(st_flush): Multiply `pt->write_buf_size' by 2.
(st_seek): Likewise when TARGET == PT->write_buf_size.
commit 0b2c2ba353d9dcf0b288950b88d6f205a5ec67ab
Author: Ludovic Courtès <address@hidden>
Date: Sun Mar 6 11:42:37 2011 +0100
Let `scm_mkstrport' allocate buffers on the caller's behalf.
* libguile/strports.c (INITIAL_BUFFER_SIZE): New macro.
(scm_mkstrport): If STR is false, allocate a bytevector on the
caller's behalf.
(scm_object_to_string, scm_call_with_output_string,
scm_open_output_string): Pass SCM_BOOL_F as the STR argument of
`scm_mkstrport'.
* libguile/backtrace.c (scm_display_application,
display_backtrace_body): Likewise.
* libguile/gdbint.c (scm_init_gdbint): Likewise.
* libguile/print.c (scm_simple_format): Likewise.
commit 691fcf66c0a823b2c4f4018e925cf9f338a4de27
Author: Ludovic Courtès <address@hidden>
Date: Sat Mar 5 20:15:09 2011 +0100
Use a bytevector as the backing buffer of string ports.
* libguile/strports.c (st_resize_port): Adjust to deal with OLD_STREAM
and NEW_STREAM as bytevectors.
(scm_mkstrport): Store a bytevector in the port's stream rather than a
string.
-----------------------------------------------------------------------
Summary of changes:
Makefile.am | 4 +-
configure.ac | 1 +
gc-benchmarks/Makefile.am | 55 ++++++++++++
gc-benchmarks/gc-profile.scm | 3 +
libguile/backtrace.c | 7 +-
libguile/gdbint.c | 12 +--
libguile/print.c | 3 +-
libguile/strports.c | 143 +++++++++++++++++---------------
libguile/symbols.c | 16 +++-
module/language/tree-il/fix-letrec.scm | 141 ++++++++++++++++++-------------
test-suite/tests/tree-il.test | 13 +++-
11 files changed, 252 insertions(+), 146 deletions(-)
create mode 100644 gc-benchmarks/Makefile.am
diff --git a/Makefile.am b/Makefile.am
index 27f7997..3a97683 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -1,6 +1,7 @@
## Process this file with automake to produce Makefile.in.
##
-## Copyright (C) 1998, 1999, 2000, 2001, 2002, 2006, 2007, 2008, 2009,
2010 Free Software Foundation, Inc.
+## Copyright (C) 1998, 1999, 2000, 2001, 2002, 2006, 2007,
+## 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
##
## This file is part of GUILE.
##
@@ -34,6 +35,7 @@ SUBDIRS = \
emacs \
test-suite \
benchmark-suite \
+ gc-benchmarks \
am \
doc
diff --git a/configure.ac b/configure.ac
index 9929064..ba6ff49 100644
--- a/configure.ac
+++ b/configure.ac
@@ -1618,6 +1618,7 @@ AC_CONFIG_FILES([
am/Makefile
lib/Makefile
benchmark-suite/Makefile
+ gc-benchmarks/Makefile
doc/Makefile
doc/r5rs/Makefile
doc/ref/Makefile
diff --git a/gc-benchmarks/Makefile.am b/gc-benchmarks/Makefile.am
new file mode 100644
index 0000000..0fdbcdc
--- /dev/null
+++ b/gc-benchmarks/Makefile.am
@@ -0,0 +1,55 @@
+## Process this file with automake to produce Makefile.in.
+##
+## Copyright (C) 2011 Free Software Foundation, Inc.
+##
+## This file is part of GUILE.
+##
+## GUILE 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, or
+## (at your option) any later version.
+##
+## GUILE is distributed in the hope that it will be useful, but
+## WITHOUT ANY WARRANTY; without even the implied warranty of
+## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+## GNU Lesser General Public License for more details.
+##
+## You should have received a copy of the GNU Lesser General Public
+## License along with GUILE; see the file COPYING.LESSER. If not,
+## write to the Free Software Foundation, Inc., 51 Franklin Street,
+## Fifth Floor, Boston, MA 02110-1301 USA
+
+EXTRA_DIST = \
+ gc-profile.scm \
+ gcbench.scm \
+ guile-test.scm \
+ loop.scm \
+ run-benchmark.scm \
+ string.scm \
+ $(benchmarks)
+
+# GPLv2+ Larceny GC benchmarks by Lars Hansen et al. from
+# <http://www.ccs.neu.edu/home/will/GC/sourcecode.html>.
+benchmarks = \
+ larceny/GPL \
+ larceny/README \
+ larceny/dumb.sch \
+ larceny/dummy.sch \
+ larceny/dynamic-input-large.sch \
+ larceny/dynamic-input-small.sch \
+ larceny/dynamic.sch \
+ larceny/earley.sch \
+ larceny/gcbench.sch \
+ larceny/gcold.scm \
+ larceny/graphs.sch \
+ larceny/lattice.sch \
+ larceny/nboyer.sch \
+ larceny/nucleic2.sch \
+ larceny/perm.sch \
+ larceny/run-benchmark.chez \
+ larceny/sboyer.sch \
+ larceny/softscheme.sch \
+ larceny/twobit-input-long.sch \
+ larceny/twobit-input-short.sch \
+ larceny/twobit-smaller.sch \
+ larceny/twobit.sch
diff --git a/gc-benchmarks/gc-profile.scm b/gc-benchmarks/gc-profile.scm
index 667886e..d95e295 100755
--- a/gc-benchmarks/gc-profile.scm
+++ b/gc-benchmarks/gc-profile.scm
@@ -47,6 +47,9 @@ memory mapping of process @var{pid}. This information is
obtained by reading
(make-regexp
"^Rss:[[:blank:]]+([[:digit:]]+) kB$"))
+ (if (not (string-contains %host-type "-linux-"))
+ (error "this procedure only works on Linux-based systems" %host-type))
+
(with-input-from-port (open-input-file (format #f "/proc/~a/smaps" pid))
(lambda ()
(let loop ((line (read-line))
diff --git a/libguile/backtrace.c b/libguile/backtrace.c
index c7abe31..7140228 100644
--- a/libguile/backtrace.c
+++ b/libguile/backtrace.c
@@ -278,9 +278,7 @@ SCM_DEFINE (scm_display_application, "display-application",
1, 2, 0,
scm_print_state *pstate;
/* Create a string port used for adaptation of printing parameters. */
- sport = scm_mkstrport (SCM_INUM0,
- scm_make_string (scm_from_int (240),
- SCM_UNDEFINED),
+ sport = scm_mkstrport (SCM_INUM0, SCM_BOOL_F,
SCM_OPN | SCM_WRTNG,
FUNC_NAME);
@@ -473,8 +471,7 @@ display_backtrace_body (struct display_backtrace_args *a)
SCM_ASSERT (n > 0, a->depth, SCM_ARG4, s_display_backtrace);
/* Create a string port used for adaptation of printing parameters. */
- sport = scm_mkstrport (SCM_INUM0,
- scm_make_string (scm_from_int (240), SCM_UNDEFINED),
+ sport = scm_mkstrport (SCM_INUM0, SCM_BOOL_F,
SCM_OPN | SCM_WRTNG,
FUNC_NAME);
diff --git a/libguile/gdbint.c b/libguile/gdbint.c
index 7cc9535..77fdbd1 100644
--- a/libguile/gdbint.c
+++ b/libguile/gdbint.c
@@ -1,5 +1,5 @@
/* GDB interface for Guile
- * Copyright (C) 1996,1997,1999,2000,2001,2002,2004,2009
+ * Copyright (C) 1996,1997,1999,2000,2001,2002,2004,2009,2011
* Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
@@ -248,15 +248,13 @@ scm_init_gdbint ()
SCM port;
scm_print_carefully_p = 0;
-
- port = scm_mkstrport (SCM_INUM0,
- scm_c_make_string (0, SCM_UNDEFINED),
+
+ port = scm_mkstrport (SCM_INUM0, SCM_BOOL_F,
SCM_OPN | SCM_WRTNG,
s);
gdb_output_port = scm_permanent_object (port);
-
- port = scm_mkstrport (SCM_INUM0,
- scm_c_make_string (0, SCM_UNDEFINED),
+
+ port = scm_mkstrport (SCM_INUM0, SCM_BOOL_F,
SCM_OPN | SCM_RDNG | SCM_WRTNG,
s);
gdb_input_port = scm_permanent_object (port);
diff --git a/libguile/print.c b/libguile/print.c
index 3855146..e3c9e1c 100644
--- a/libguile/print.c
+++ b/libguile/print.c
@@ -1284,8 +1284,7 @@ SCM_DEFINE (scm_simple_format, "simple-format", 2, 0, 1,
else if (scm_is_false (destination))
{
fReturnString = 1;
- port = scm_mkstrport (SCM_INUM0,
- scm_make_string (SCM_INUM0, SCM_UNDEFINED),
+ port = scm_mkstrport (SCM_INUM0, SCM_BOOL_F,
SCM_OPN | SCM_WRTNG,
FUNC_NAME);
destination = port;
diff --git a/libguile/strports.c b/libguile/strports.c
index af601cf..957c6a1 100644
--- a/libguile/strports.c
+++ b/libguile/strports.c
@@ -30,7 +30,7 @@
#include <unistd.h>
#endif
-#include "libguile/arrays.h"
+#include "libguile/bytevectors.h"
#include "libguile/eval.h"
#include "libguile/ports.h"
#include "libguile/read.h"
@@ -55,15 +55,8 @@
/* NOTES:
- We break the rules set forth by strings.h about accessing the
- internals of strings here. We can do this since we can guarantee
- that the string used as pt->stream is not in use by anyone else.
- Thus, it's representation will not change asynchronously.
-
- (Ports aren't thread-safe yet anyway...)
-
- write_buf/write_end point to the ends of the allocated string.
- read_buf/read_end in principle point to the part of the string which
+ write_buf/write_end point to the ends of the allocated bytevector.
+ read_buf/read_end in principle point to the part of the bytevector which
has been written to, but this is only updated after a flush.
read_pos and write_pos in principle should be equal, but this is only true
when rw_active is SCM_PORT_NEITHER.
@@ -106,25 +99,23 @@ stfill_buffer (SCM port)
return scm_return_first_int (*pt->read_pos, port);
}
-/* change the size of a port's string to new_size. this doesn't
- change read_buf_size. */
-static void
+/* Change the size of a port's bytevector to NEW_SIZE. This doesn't
+ change `read_buf_size'. */
+static void
st_resize_port (scm_t_port *pt, scm_t_off new_size)
{
SCM old_stream = SCM_PACK (pt->stream);
- const char *src = scm_i_string_chars (old_stream);
- char *dst;
- SCM new_stream = scm_i_make_string (new_size, &dst);
- unsigned long int old_size = scm_i_string_length (old_stream);
+ const signed char *src = SCM_BYTEVECTOR_CONTENTS (old_stream);
+ SCM new_stream = scm_c_make_bytevector (new_size);
+ signed char *dst = SCM_BYTEVECTOR_CONTENTS (new_stream);
+ unsigned long int old_size = SCM_BYTEVECTOR_LENGTH (old_stream);
unsigned long int min_size = min (old_size, new_size);
- unsigned long int i;
scm_t_off index = pt->write_pos - pt->write_buf;
pt->write_buf_size = new_size;
- for (i = 0; i != min_size; ++i)
- dst[i] = src[i];
+ memcpy (dst, src, min_size);
scm_remember_upto_here_1 (old_stream);
@@ -138,27 +129,17 @@ st_resize_port (scm_t_port *pt, scm_t_off new_size)
}
}
-/* amount by which write_buf is expanded. */
-#define SCM_WRITE_BLOCK 80
-
-/* ensure that write_pos < write_end by enlarging the buffer when
- necessary. update read_buf to account for written chars.
-
- The buffer is enlarged by 1.5 times, plus SCM_WRITE_BLOCK. Adding just a
- fixed amount is no good, because there's a block copy for each increment,
- and that copying would take quadratic time. In the past it was found to
- be very slow just adding 80 bytes each time (eg. about 10 seconds for
- writing a 100kbyte string). */
-
+/* Ensure that `write_pos' < `write_end' by enlarging the buffer when
+ necessary. Update `read_buf' to account for written chars. The
+ buffer is enlarged geometrically. */
static void
st_flush (SCM port)
{
scm_t_port *pt = SCM_PTAB_ENTRY (port);
if (pt->write_pos == pt->write_end)
- {
- st_resize_port (pt, pt->write_buf_size * 3 / 2 + SCM_WRITE_BLOCK);
- }
+ st_resize_port (pt, pt->write_buf_size * 2);
+
pt->read_pos = pt->write_pos;
if (pt->read_pos > pt->read_end)
{
@@ -255,12 +236,8 @@ st_seek (SCM port, scm_t_off offset, int whence)
SCM_EOL);
}
}
- else
- {
- st_resize_port (pt, target + (target == pt->write_buf_size
- ? SCM_WRITE_BLOCK
- : 0));
- }
+ else if (target == pt->write_buf_size)
+ st_resize_port (pt, target * 2);
}
pt->read_pos = pt->write_pos = pt->read_buf + target;
if (pt->read_pos > pt->read_end)
@@ -289,16 +266,19 @@ st_truncate (SCM port, scm_t_off length)
pt->write_pos = pt->read_end;
}
+/* The initial size in bytes of a string port's buffer. */
+#define INITIAL_BUFFER_SIZE 128
+
+/* Return a new string port with MODES. If STR is #f, a new backing
+ buffer is allocated; otherwise STR must be a string and a copy of it
+ serves as the buffer for the new port. */
SCM
scm_mkstrport (SCM pos, SCM str, long modes, const char *caller)
{
- SCM z;
+ SCM z, buf;
scm_t_port *pt;
size_t str_len, c_pos;
- char *buf, *c_str;
-
- SCM_ASSERT (scm_is_string (str), str, SCM_ARG1, caller);
- c_pos = scm_to_unsigned_integer (pos, 0, scm_i_string_length (str));
+ char *c_buf;
if (!((modes & SCM_WRTNG) || (modes & SCM_RDNG)))
scm_misc_error ("scm_mkstrport", "port must read or write", SCM_EOL);
@@ -308,19 +288,44 @@ scm_mkstrport (SCM pos, SCM str, long modes, const char
*caller)
z = scm_new_port_table_entry (scm_tc16_strport);
pt = SCM_PTAB_ENTRY(z);
- SCM_SETSTREAM (z, SCM_UNPACK (str));
- SCM_SET_CELL_TYPE (z, scm_tc16_strport | modes);
- /* Create a copy of STR in the encoding of Z. */
- buf = scm_to_stringn (str, &str_len, pt->encoding,
- SCM_FAILED_CONVERSION_ERROR);
- c_str = scm_gc_malloc_pointerless (str_len, "strport");
- memcpy (c_str, buf, str_len);
- free (buf);
+ if (scm_is_false (str))
+ {
+ /* Allocate a new buffer to write to. */
+ str_len = INITIAL_BUFFER_SIZE;
+ buf = scm_c_make_bytevector (str_len);
+ c_buf = (char *) SCM_BYTEVECTOR_CONTENTS (buf);
+
+ /* Reset `read_buf_size'. It will contain the actual number of
+ bytes written to PT. */
+ pt->read_buf_size = 0;
+ c_pos = 0;
+ }
+ else
+ {
+ /* STR is a string. */
+ char *copy;
+
+ SCM_ASSERT (scm_is_string (str), str, SCM_ARG1, caller);
+
+ /* Create a copy of STR in the encoding of PT. */
+ copy = scm_to_stringn (str, &str_len, pt->encoding,
+ SCM_FAILED_CONVERSION_ERROR);
+ buf = scm_c_make_bytevector (str_len);
+ c_buf = (char *) SCM_BYTEVECTOR_CONTENTS (buf);
+ memcpy (c_buf, copy, str_len);
+ free (copy);
+
+ c_pos = scm_to_unsigned_integer (pos, 0, str_len);
+ pt->read_buf_size = str_len;
+ }
+
+ SCM_SETSTREAM (z, SCM_UNPACK (buf));
+ SCM_SET_CELL_TYPE (z, scm_tc16_strport | modes);
- pt->write_buf = pt->read_buf = (unsigned char *) c_str;
+ pt->write_buf = pt->read_buf = (unsigned char *) c_buf;
pt->read_pos = pt->write_pos = pt->read_buf + c_pos;
- pt->write_buf_size = pt->read_buf_size = str_len;
+ pt->write_buf_size = str_len;
pt->write_end = pt->read_end = pt->read_buf + pt->read_buf_size;
pt->rw_random = 1;
@@ -369,20 +374,30 @@ SCM_DEFINE (scm_object_to_string, "object->string", 1, 1,
0,
"argument @var{printer} (default: @code{write}).")
#define FUNC_NAME s_scm_object_to_string
{
- SCM str, port;
+ SCM port, result;
if (!SCM_UNBNDP (printer))
SCM_VALIDATE_PROC (2, printer);
- str = scm_c_make_string (0, SCM_UNDEFINED);
- port = scm_mkstrport (SCM_INUM0, str, SCM_OPN | SCM_WRTNG, FUNC_NAME);
+ port = scm_mkstrport (SCM_INUM0, SCM_BOOL_F,
+ SCM_OPN | SCM_WRTNG, FUNC_NAME);
if (SCM_UNBNDP (printer))
scm_write (obj, port);
else
scm_call_2 (printer, obj, port);
- return scm_strport_to_string (port);
+ result = scm_strport_to_string (port);
+
+ /* Explicitly close PORT so that the iconv CDs associated with it are
+ deallocated right away. This is important because CDs use a lot of
+ memory that's not visible to the GC, so not freeing them can lead
+ to almost large heap usage. See
+ <http://wingolog.org/archives/2011/02/25/ports-weaks-gc-and-dark-matter>
+ for details. */
+ scm_close_port (port);
+
+ return result;
}
#undef FUNC_NAME
@@ -395,8 +410,7 @@ SCM_DEFINE (scm_call_with_output_string,
"call-with-output-string", 1, 0, 0,
{
SCM p;
- p = scm_mkstrport (SCM_INUM0,
- scm_make_string (SCM_INUM0, SCM_UNDEFINED),
+ p = scm_mkstrport (SCM_INUM0, SCM_BOOL_F,
SCM_OPN | SCM_WRTNG,
FUNC_NAME);
scm_call_1 (proc, p);
@@ -441,8 +455,7 @@ SCM_DEFINE (scm_open_output_string, "open-output-string",
0, 0, 0,
{
SCM p;
- p = scm_mkstrport (SCM_INUM0,
- scm_make_string (SCM_INUM0, SCM_UNDEFINED),
+ p = scm_mkstrport (SCM_INUM0, SCM_BOOL_F,
SCM_OPN | SCM_WRTNG,
FUNC_NAME);
return p;
@@ -467,8 +480,6 @@ SCM_DEFINE (scm_get_output_string, "get-output-string", 1,
0, 0,
SCM
scm_c_read_string (const char *expr)
{
- /* FIXME: the c string gets packed into a string, only to get
- immediately unpacked in scm_mkstrport. */
SCM port = scm_mkstrport (SCM_INUM0,
scm_from_locale_string (expr),
SCM_OPN | SCM_RDNG,
diff --git a/libguile/symbols.c b/libguile/symbols.c
index b9d41b0..2a1b46d 100644
--- a/libguile/symbols.c
+++ b/libguile/symbols.c
@@ -1,5 +1,6 @@
-/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2003, 2004, 2006, 2009 Free
Software Foundation, Inc.
- *
+/* Copyright (C) 1995, 1996, 1997, 1998, 2000, 2001, 2003, 2004,
+ * 2006, 2009, 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
@@ -341,6 +342,9 @@ SCM_DEFINE (scm_string_ci_to_symbol, "string-ci->symbol",
1, 0, 0,
}
#undef FUNC_NAME
+/* The default prefix for `gensym'd symbols. */
+static SCM default_gensym_prefix;
+
#define MAX_PREFIX_LENGTH 30
SCM_DEFINE (scm_gensym, "gensym", 0, 1, 0,
@@ -359,15 +363,15 @@ SCM_DEFINE (scm_gensym, "gensym", 0, 1, 0,
char buf[SCM_INTBUFLEN];
if (SCM_UNBNDP (prefix))
- prefix = scm_from_locale_string (" g");
-
+ 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);
n_digits = scm_iint2str (n, 10, buf);
- suffix = scm_from_locale_stringn (buf, n_digits);
+ suffix = scm_from_latin1_stringn (buf, n_digits);
name = scm_string_append (scm_list_2 (prefix, suffix));
return scm_string_to_symbol (name);
}
@@ -506,6 +510,8 @@ void
scm_init_symbols ()
{
#include "libguile/symbols.x"
+
+ default_gensym_prefix = scm_from_latin1_string (" g");
}
/*
diff --git a/module/language/tree-il/fix-letrec.scm
b/module/language/tree-il/fix-letrec.scm
index 8d4b239..ee8beb2 100644
--- a/module/language/tree-il/fix-letrec.scm
+++ b/module/language/tree-il/fix-letrec.scm
@@ -1,6 +1,6 @@
;;; transformation of letrec into simpler forms
-;; Copyright (C) 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 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
@@ -190,64 +190,83 @@
x))
((<letrec> src in-order? names gensyms vals body)
- (let ((binds (map list gensyms names vals)))
- ;; The bindings returned by this function need to appear in the
same
- ;; order that they appear in the letrec.
- (define (lookup set)
- (let lp ((binds binds))
- (cond
- ((null? binds) '())
- ((memq (caar binds) set)
- (cons (car binds) (lp (cdr binds))))
- (else (lp (cdr binds))))))
- (let ((u (lookup unref))
- (s (lookup simple))
- (l (lookup lambda*))
- (c (lookup complex)))
- ;; Bind "simple" bindings, and locations for complex
- ;; bindings.
- (make-let
- src
- (append (map cadr s) (map cadr c))
- (append (map car s) (map car c))
- (append (map caddr s) (map (lambda (x) (make-void #f)) c))
- ;; Bind lambdas using the fixpoint operator.
- (make-fix
- src (map cadr l) (map car l) (map caddr l)
- (make-sequence
- src
- (append
- ;; The right-hand-sides of the unreferenced
- ;; bindings, for effect.
- (map caddr u)
- (cond
- ((null? c)
- ;; No complex bindings, just emit the body.
- (list body))
- (in-order?
- ;; For letrec*, assign complex bindings in order, then the
- ;; body.
- (append
- (map (lambda (c)
- (make-lexical-set #f (cadr c) (car c) (caddr c)))
- c)
- (list body)))
- (else
- ;; Otherwise for plain letrec, evaluate the the "complex"
- ;; bindings, in a `let' to indicate that order doesn't
- ;; matter, and bind to their variables.
- (list
- (let ((tmps (map (lambda (x) (gensym)) c)))
- (make-let
- #f (map cadr c) tmps (map caddr c)
- (make-sequence
- #f
- (map (lambda (x tmp)
- (make-lexical-set
- #f (cadr x) (car x)
- (make-lexical-ref #f (cadr x) tmp)))
- c tmps))))
- body))))))))))
+ (if (and in-order?
+ (every (lambda (x)
+ (or (lambda? x)
+ (simple-expression?
+ x gensyms
+ effect+exception-free-primitive?)))
+ vals))
+ ;; If it is a `letrec*', return an equivalent `letrec' when
+ ;; it's possible. This is a hack until we implement the
+ ;; algorithm described in "Fixing Letrec (Reloaded)"
+ ;; (Ghuloum and Dybvig) to allow cases such as
+ ;; (letrec* ((f (lambda () ...))(g (lambda () ...))) ...)
+ ;; or
+ ;; (letrec* ((x 2)(y 3)) y)
+ ;; to be optimized. These can be common when using
+ ;; internal defines.
+ (fix-letrec!
+ (make-letrec src #f names gensyms vals body))
+ (let ((binds (map list gensyms names vals)))
+ ;; The bindings returned by this function need to appear in
the same
+ ;; order that they appear in the letrec.
+ (define (lookup set)
+ (let lp ((binds binds))
+ (cond
+ ((null? binds) '())
+ ((memq (caar binds) set)
+ (cons (car binds) (lp (cdr binds))))
+ (else (lp (cdr binds))))))
+ (let ((u (lookup unref))
+ (s (lookup simple))
+ (l (lookup lambda*))
+ (c (lookup complex)))
+ ;; Bind "simple" bindings, and locations for complex
+ ;; bindings.
+ (make-let
+ src
+ (append (map cadr s) (map cadr c))
+ (append (map car s) (map car c))
+ (append (map caddr s) (map (lambda (x) (make-void #f)) c))
+ ;; Bind lambdas using the fixpoint operator.
+ (make-fix
+ src (map cadr l) (map car l) (map caddr l)
+ (make-sequence
+ src
+ (append
+ ;; The right-hand-sides of the unreferenced
+ ;; bindings, for effect.
+ (map caddr u)
+ (cond
+ ((null? c)
+ ;; No complex bindings, just emit the body.
+ (list body))
+ (in-order?
+ ;; For letrec*, assign complex bindings in order, then
the
+ ;; body.
+ (append
+ (map (lambda (c)
+ (make-lexical-set #f (cadr c) (car c)
+ (caddr c)))
+ c)
+ (list body)))
+ (else
+ ;; Otherwise for plain letrec, evaluate the the
"complex"
+ ;; bindings, in a `let' to indicate that order doesn't
+ ;; matter, and bind to their variables.
+ (list
+ (let ((tmps (map (lambda (x) (gensym)) c)))
+ (make-let
+ #f (map cadr c) tmps (map caddr c)
+ (make-sequence
+ #f
+ (map (lambda (x tmp)
+ (make-lexical-set
+ #f (cadr x) (car x)
+ (make-lexical-ref #f (cadr x) tmp)))
+ c tmps))))
+ body)))))))))))
((<let> src names gensyms vals body)
(let ((binds (map list gensyms names vals)))
@@ -271,3 +290,7 @@
(else x)))
x)))
+
+;;; Local Variables:
+;;; eval: (put 'record-case 'scheme-indent-function 1)
+;;; End:
diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test
index 76c825d..8ea2443 100644
--- a/test-suite/tests/tree-il.test
+++ b/test-suite/tests/tree-il.test
@@ -363,7 +363,18 @@
(lexical #t #t set 1)
(lexical #t #t ref 0)
(lexical #t #t ref 1)
- (call add 2) (call return 1) (unbind))))
+ (call add 2) (call return 1) (unbind)))
+
+ ;; simple bindings in letrec* -> equivalent to letrec
+ (assert-tree-il->glil
+ (letrec* (x y) (xx yy) ((const 1) (const 2))
+ (lexical y yy))
+ (program () (std-prelude 0 1 #f) (label _)
+ (const 2)
+ (bind (y #f 0)) ;; X is removed, and Y is unboxed
+ (lexical #t #f set 0)
+ (lexical #t #f ref 0)
+ (call return 1) (unbind))))
(with-test-prefix "lambda"
(assert-tree-il->glil
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.0-74-g65ea26c,
Ludovic Courtès <=