[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. release_1-9-2-15-g1b9
|
From: |
Michael Gran |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. release_1-9-2-15-g1b9ac45 |
|
Date: |
Thu, 20 Aug 2009 06:18:51 +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=1b9ac4580c9405b7e665cbf8c88b85fe73627e9f
The branch, master has been updated
via 1b9ac4580c9405b7e665cbf8c88b85fe73627e9f (commit)
via 06b961904de0c3007763b0e5bd21cc9f8afebe76 (commit)
via 2759c092d0fe200dd5abee9b1e8a7f5123e25e5d (commit)
via 9aa27c1a30c222ab668d8d6fc7aa7ad815282594 (commit)
via f8ba2bb9117d75c93503fe3dde9054f5ff92c51c (commit)
via 1c7b216f848fd454db15881709ed766323cdeed3 (commit)
from 2a0db0e326137cbf3b462376872c1d9f06c2bd52 (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 1b9ac4580c9405b7e665cbf8c88b85fe73627e9f
Author: Michael Gran <address@hidden>
Date: Wed Aug 19 21:21:29 2009 -0700
Updates to benchmarks for srfi-13
Test more of the positive paths. Add test for string-prefix-ci?
string-suffix-ci? and string-hash-ci. Update the counts per test
to give approximately the same bench/interp time for each test for
1.8.7.
* benchmark-suite/benchmarks/srfi-13.bm: update benchmarks
commit 06b961904de0c3007763b0e5bd21cc9f8afebe76
Author: Michael Gran <address@hidden>
Date: Wed Aug 19 21:47:19 2009 -0700
Avoid possible mutex hang on error message output
Avoid possible mutex hang when scm_lfwrite_substr is used in error
message output and when an error has caused the stringbuf write
mutex to not be unlocked. scm_lfwrite_substr makes a substring:
making a substring requires that mutex.
Hopefully, all cases of non-local jumps when the stringbuf write
lock is held have been eliminated anyway, making this O.B.E.
* libguile/ports.c (scm_lfwrite_str): include functionality in this
function instead of making this a special case of scm_lfwrite_substr
commit 2759c092d0fe200dd5abee9b1e8a7f5123e25e5d
Author: Michael Gran <address@hidden>
Date: Wed Aug 19 22:12:33 2009 -0700
Add VM exception in strings.test
* test-suite/tests/strings.test (exception:wrong-type-arg): change regex
commit 9aa27c1a30c222ab668d8d6fc7aa7ad815282594
Author: Michael Gran <address@hidden>
Date: Wed Aug 19 21:26:11 2009 -0700
Try to optimize scm_string for speed
* libguile/strings.c (scm_string): optimize for speed
commit f8ba2bb9117d75c93503fe3dde9054f5ff92c51c
Author: Michael Gran <address@hidden>
Date: Wed Aug 19 21:24:23 2009 -0700
Rename string-width to string-bytes-per-char
* libguile/strings.h: rename scm_string_width to scm_string_bytes_per_char
* libguile/strings.c (scm_string_width): renamed to
scm_string_bytes_per_char
(scm_string_bytes_per_char): renamed from scm_string_width
* module/language/assembly/compile-bytecode.scm (write-bytecode):
string-width
-> string-bytes-per-char
* module/language/glil/compile-assembly.scm (dump-object): string-width
-> string-bytes-per-char
commit 1c7b216f848fd454db15881709ed766323cdeed3
Author: Michael Gran <address@hidden>
Date: Wed Aug 19 21:25:23 2009 -0700
Misleading error message text in scm_i_string_writable_wide_chars
* libguile/strings.c (scm_i_string_writable_wide_chars): change error text
-----------------------------------------------------------------------
Summary of changes:
benchmark-suite/benchmarks/srfi-13.bm | 111 ++++++++++++++----------
libguile/ports.c | 27 ++++++-
libguile/strings.c | 48 ++++++++---
libguile/strings.h | 2 +-
module/language/assembly/compile-bytecode.scm | 2 +-
module/language/glil/compile-assembly.scm | 8 +-
test-suite/tests/strings.test | 4 +
7 files changed, 136 insertions(+), 66 deletions(-)
diff --git a/benchmark-suite/benchmarks/srfi-13.bm
b/benchmark-suite/benchmarks/srfi-13.bm
index a8187d5..e648e2a 100644
--- a/benchmark-suite/benchmarks/srfi-13.bm
+++ b/benchmark-suite/benchmarks/srfi-13.bm
@@ -46,66 +46,66 @@ Italiam, fato profugus, Laviniaque venit")
(with-benchmark-prefix "predicates"
- (benchmark "string?" 250000
+ (benchmark "string?" 1190000
(string? short-string)
(string? medium-string)
(string? long-string))
- (benchmark "null?" 390000
+ (benchmark "null?" 969000
(string-null? short-string)
(string-null? medium-string)
(string-null? long-string))
- (benchmark "any" 22000
+ (benchmark "any" 94000
(string-any #\a short-string)
(string-any #\a medium-string)
(string-any #\a long-string))
- (benchmark "every" 22000
+ (benchmark "every" 94000
(string-every #\a short-string)
(string-every #\a medium-string)
(string-every #\a long-string)))
(with-benchmark-prefix "constructors"
- (benchmark "string" 2000
+ (benchmark "string" 5000
(apply string short-chlist)
(apply string medium-chlist)
(apply string long-chlist))
- (benchmark "list->" 2500
+ (benchmark "list->" 4500
(list->string short-chlist)
(list->string medium-chlist)
(list->string long-chlist))
- (benchmark "reverse-list->" 2000
+ (benchmark "reverse-list->" 5000
(reverse-list->string short-chlist)
(reverse-list->string medium-chlist)
(reverse-list->string long-chlist))
- (benchmark "make" 20000
+ (benchmark "make" 22000
(make-string 250 #\x))
- (benchmark "tabulate" 16000
+ (benchmark "tabulate" 17000
(string-tabulate integer->char 250))
- (benchmark "join" 5000
+ (benchmark "join" 5500
(string-join (list short-string medium-string long-string) "|" 'suffix)))
(with-benchmark-prefix "list/string"
- (benchmark "->list" 3300
+ (benchmark "->list" 7300
(string->list short-string)
(string->list medium-string)
(string->list long-string))
- (benchmark "split" 20000
+ (benchmark "split" 60000
(string-split short-string #\a)
(string-split medium-string #\a)
(string-split long-string #\a)))
(with-benchmark-prefix "selection"
- (benchmark "ref" 300
+ (benchmark "ref" 660
(let loop ((k 0))
(if (< k (string-length short-string))
(begin
@@ -122,7 +122,7 @@ Italiam, fato profugus, Laviniaque venit")
(string-ref long-string k)
(loop (+ k 1))))))
- (benchmark "copy" 20000
+ (benchmark "copy" 1100
(string-copy short-string)
(string-copy medium-string)
(string-copy long-string)
@@ -130,12 +130,12 @@ Italiam, fato profugus, Laviniaque venit")
(substring/copy medium-string 10 20)
(substring/copy long-string 100 200))
- (benchmark "pad" 20000
+ (benchmark "pad" 6800
(string-pad short-string 100)
(string-pad medium-string 100)
(string-pad long-string 100))
- (benchmark "trim trim-right trim-both" 20000
+ (benchmark "trim trim-right trim-both" 60000
(string-trim short-string char-alphabetic?)
(string-trim medium-string char-alphabetic?)
(string-trim long-string char-alphabetic?)
@@ -152,7 +152,7 @@ Italiam, fato profugus, Laviniaque venit")
(set! str2 (string-copy medium-string))
(set! str3 (string-copy long-string))
- (benchmark "set!" 300
+ (benchmark "set!" 3000
(let loop ((k 1))
(if (< k (string-length short-string))
(begin
@@ -173,7 +173,7 @@ Italiam, fato profugus, Laviniaque venit")
(set! str2 (string-copy medium-string))
(set! str3 (string-copy long-string))
- (benchmark "sub-move!" 20000
+ (benchmark "sub-move!" 230000
(substring-move! short-string 0 2 str2 10)
(substring-move! medium-string 10 20 str3 20))
@@ -181,66 +181,66 @@ Italiam, fato profugus, Laviniaque venit")
(set! str2 (string-copy medium-string))
(set! str3 (string-copy long-string))
- (benchmark "fill!" 20000
+ (benchmark "fill!" 230000
(string-fill! str1 #\y 0 1)
(string-fill! str2 #\y 10 20)
(string-fill! str3 #\y 20 30))
(with-benchmark-prefix "comparison"
- (benchmark "compare compare-ci" 20000
+ (benchmark "compare compare-ci" 140000
(string-compare short-string medium-string string<? string=? string>?)
(string-compare long-string medium-string string<? string=? string>?)
- (string-compare short-string medium-string string<? string=? string>?)
- (string-compare long-string medium-string string<? string=? string>?))
+ (string-compare-ci short-string medium-string string<? string=?
string>?)
+ (string-compare-ci long-string medium-string string<? string=? string>?))
- (benchmark "hash hash-ci" 20000
+ (benchmark "hash hash-ci" 1000
(string-hash short-string)
(string-hash medium-string)
(string-hash long-string)
- (string-hash short-string)
- (string-hash medium-string)
- (string-hash long-string))))
+ (string-hash-ci short-string)
+ (string-hash-ci medium-string)
+ (string-hash-ci long-string))))
(with-benchmark-prefix "searching" 20000
- (benchmark "prefix-length suffix-length" 1000
+ (benchmark "prefix-length suffix-length" 270
(string-prefix-length short-string
(string-append short-string medium-string))
(string-prefix-length long-string
(string-append long-string medium-string))
(string-suffix-length short-string
- (string-append long-string medium-string))
+ (string-append medium-string short-string))
(string-suffix-length long-string
- (string-append long-string medium-string))
+ (string-append medium-string long-string))
(string-prefix-length-ci short-string
(string-append short-string medium-string))
(string-prefix-length-ci long-string
(string-append long-string medium-string))
(string-suffix-length-ci short-string
- (string-append long-string medium-string))
+ (string-append medium-string short-string))
(string-suffix-length-ci long-string
- (string-append long-string medium-string)))
+ (string-append medium-string long-string)))
- (benchmark "prefix? suffix?" 1000
+ (benchmark "prefix? suffix?" 270
(string-prefix? short-string
(string-append short-string medium-string))
(string-prefix? long-string
(string-append long-string medium-string))
(string-suffix? short-string
- (string-append long-string medium-string))
+ (string-append medium-string short-string))
(string-suffix? long-string
- (string-append long-string medium-string))
- (string-prefix? short-string
+ (string-append medium-string long-string))
+ (string-prefix-ci? short-string
(string-append short-string medium-string))
- (string-prefix? long-string
+ (string-prefix-ci? long-string
(string-append long-string medium-string))
- (string-suffix? short-string
- (string-append long-string medium-string))
- (string-suffix? long-string
- (string-append long-string medium-string)))
+ (string-suffix-ci? short-string
+ (string-append medium-string short-string))
+ (string-suffix-ci? long-string
+ (string-append medium-string long-string)))
- (benchmark "index index-right rindex" 10000
+ (benchmark "index index-right rindex" 100000
(string-index short-string #\T)
(string-index medium-string #\T)
(string-index long-string #\T)
@@ -251,7 +251,7 @@ Italiam, fato profugus, Laviniaque venit")
(string-rindex medium-string #\T)
(string-rindex long-string #\T))
- (benchmark "skip skip-right?" 10000
+ (benchmark "skip skip-right?" 100000
(string-skip short-string char-alphabetic?)
(string-skip medium-string char-alphabetic?)
(string-skip long-string char-alphabetic?)
@@ -259,12 +259,12 @@ Italiam, fato profugus, Laviniaque venit")
(string-skip-right medium-string char-alphabetic?)
(string-skip-right long-string char-alphabetic?))
- (benchmark "count" 3000
+ (benchmark "count" 10000
(string-count short-string char-alphabetic?)
(string-count medium-string char-alphabetic?)
(string-count long-string char-alphabetic?))
- (benchmark "contains contains-ci" 10000
+ (benchmark "contains contains-ci" 34000
(string-contains short-string short-string)
(string-contains medium-string (substring medium-string 10 15))
(string-contains long-string (substring long-string 100 130))
@@ -276,7 +276,7 @@ Italiam, fato profugus, Laviniaque venit")
(set! str2 (string-copy medium-string))
(set! str3 (string-copy long-string))
- (benchmark "upcase downcase upcase! downcase!" 500
+ (benchmark "upcase downcase upcase! downcase!" 600
(string-upcase short-string)
(string-upcase medium-string)
(string-upcase long-string)
@@ -288,4 +288,23 @@ Italiam, fato profugus, Laviniaque venit")
(string-upcase! str3 100 130)
(string-downcase! str1 0 1)
(string-downcase! str2 10 20)
- (string-downcase! str3 100 130))))
\ No newline at end of file
+ (string-downcase! str3 100 130)))
+
+ (with-benchmark-prefix "readers"
+
+ (benchmark "read token, method 1" 1200
+ (let ((buf (make-string 512)))
+ (let loop ((i 0))
+ (if (< i 512)
+ (begin
+ (string-set! buf i #\x)
+ (loop (+ i 1)))
+ buf))))
+
+ (benchmark "read token, method 2" 1200
+ (let ((lst '()))
+ (let loop ((i 0))
+ (set! lst (append! lst (list #\x)))
+ (if (< i 512)
+ (loop (+ i 1))
+ (list->string lst)))))))
diff --git a/libguile/ports.c b/libguile/ports.c
index 60b21dd..1ddeaa3 100644
--- a/libguile/ports.c
+++ b/libguile/ports.c
@@ -1023,6 +1023,9 @@ scm_lfwrite_substr (SCM str, size_t start, size_t end,
SCM port)
end = size;
size = end - start;
+ /* Note that making a substring will likely take the
+ stringbuf_write_mutex. So, one shouldn't use scm_lfwrite_substr
+ if the stringbuf write mutex may still be held elsewhere. */
buf = scm_to_stringn (scm_c_substring (str, start, end), &len,
NULL, SCM_FAILED_CONVERSION_ESCAPE_SEQUENCE);
ptob->write (port, buf, len);
@@ -1042,7 +1045,29 @@ scm_lfwrite_substr (SCM str, size_t start, size_t end,
SCM port)
void
scm_lfwrite_str (SCM str, SCM port)
{
- scm_lfwrite_substr (str, 0, (size_t) (-1), port);
+ size_t i, size = scm_i_string_length (str);
+ scm_t_port *pt = SCM_PTAB_ENTRY (port);
+ scm_t_ptob_descriptor *ptob = &scm_ptobs[SCM_PTOBNUM (port)];
+ scm_t_wchar p;
+ char *buf;
+ size_t len;
+
+ if (pt->rw_active == SCM_PORT_READ)
+ scm_end_input (port);
+
+ buf = scm_to_stringn (str, &len,
+ NULL, SCM_FAILED_CONVERSION_ESCAPE_SEQUENCE);
+ ptob->write (port, buf, len);
+ free (buf);
+
+ for (i = 0; i < size; i++)
+ {
+ p = scm_i_string_ref (str, i);
+ update_port_lf (p, port);
+ }
+
+ if (pt->rw_random)
+ pt->rw_active = SCM_PORT_WRITE;
}
/* scm_c_read
diff --git a/libguile/strings.c b/libguile/strings.c
index d28f5ad..6275861 100644
--- a/libguile/strings.c
+++ b/libguile/strings.c
@@ -568,7 +568,7 @@ scm_i_string_writable_wide_chars (SCM str)
if (!scm_i_is_narrow_string (str))
return STRINGBUF_WIDE_CHARS (buf) + start;
else
- scm_misc_error (NULL, "Invalid read access of chars of narrow string: ~s",
+ scm_misc_error (NULL, "Invalid write access of chars of narrow string: ~s",
scm_list_1 (str));
}
@@ -1008,11 +1008,12 @@ SCM_DEFINE (scm_string, "string", 0, 0, 1,
"@var{chrs}.")
#define FUNC_NAME s_scm_string
{
- SCM result;
+ SCM result = SCM_BOOL_F;
SCM rest;
size_t len;
size_t p = 0;
long i;
+ int wide = 0;
/* Verify that this is a list of chars. */
i = scm_ilength (chrs);
@@ -1025,6 +1026,8 @@ SCM_DEFINE (scm_string, "string", 0, 0, 1,
{
SCM elt = SCM_CAR (rest);
SCM_VALIDATE_CHAR (SCM_ARGn, elt);
+ if (SCM_CHAR (elt) > 0xFF)
+ wide = 1;
rest = SCM_CDR (rest);
len--;
scm_remember_upto_here_1 (elt);
@@ -1034,16 +1037,35 @@ SCM_DEFINE (scm_string, "string", 0, 0, 1,
len = (size_t) i;
rest = chrs;
- result = scm_i_make_string (len, NULL);
- result = scm_i_string_start_writing (result);
- while (len > 0 && scm_is_pair (rest))
+ if (wide == 0)
{
- SCM elt = SCM_CAR (rest);
- scm_i_string_set_x (result, p, SCM_CHAR (elt));
- p++;
- rest = SCM_CDR (rest);
- len--;
- scm_remember_upto_here_1 (elt);
+ result = scm_i_make_string (len, NULL);
+ result = scm_i_string_start_writing (result);
+ char *buf = scm_i_string_writable_chars (result);
+ while (len > 0 && scm_is_pair (rest))
+ {
+ SCM elt = SCM_CAR (rest);
+ buf[p] = (unsigned char) SCM_CHAR (elt);
+ p++;
+ rest = SCM_CDR (rest);
+ len--;
+ scm_remember_upto_here_1 (elt);
+ }
+ }
+ else
+ {
+ result = scm_i_make_wide_string (len, NULL);
+ result = scm_i_string_start_writing (result);
+ scm_t_wchar *buf = scm_i_string_writable_wide_chars (result);
+ while (len > 0 && scm_is_pair (rest))
+ {
+ SCM elt = SCM_CAR (rest);
+ buf[p] = SCM_CHAR (elt);
+ p++;
+ rest = SCM_CDR (rest);
+ len--;
+ scm_remember_upto_here_1 (elt);
+ }
}
scm_i_string_stop_writing ();
@@ -1098,11 +1120,11 @@ SCM_DEFINE (scm_string_length, "string-length", 1, 0, 0,
}
#undef FUNC_NAME
-SCM_DEFINE (scm_string_width, "string-width", 1, 0, 0,
+SCM_DEFINE (scm_string_bytes_per_char, "string-bytes-per-char", 1, 0, 0,
(SCM string),
"Return the bytes used to represent a character in @var{string}."
"This will return 1 or 4.")
-#define FUNC_NAME s_scm_string_width
+#define FUNC_NAME s_scm_string_bytes_per_char
{
SCM_VALIDATE_STRING (1, string);
if (!scm_i_is_narrow_string (string))
diff --git a/libguile/strings.h b/libguile/strings.h
index fe9162d..390b4f6 100644
--- a/libguile/strings.h
+++ b/libguile/strings.h
@@ -102,7 +102,7 @@ SCM_API SCM scm_string_p (SCM x);
SCM_API SCM scm_string (SCM chrs);
SCM_API SCM scm_make_string (SCM k, SCM chr);
SCM_API SCM scm_string_length (SCM str);
-SCM_API SCM scm_string_width (SCM str);
+SCM_API SCM scm_string_bytes_per_char (SCM str);
SCM_API SCM scm_string_ref (SCM str, SCM k);
SCM_API SCM scm_string_set_x (SCM str, SCM k, SCM chr);
SCM_API SCM scm_substring (SCM str, SCM start, SCM end);
diff --git a/module/language/assembly/compile-bytecode.scm
b/module/language/assembly/compile-bytecode.scm
index 4706cce..688cb6b 100644
--- a/module/language/assembly/compile-bytecode.scm
+++ b/module/language/assembly/compile-bytecode.scm
@@ -82,7 +82,7 @@
(write-string str))
(define (write-sized-loader str)
(let ((len (string-length str))
- (wid (string-width str)))
+ (wid (string-bytes-per-char str)))
(write-loader-len len)
(write-byte wid)
(if (= wid 4)
diff --git a/module/language/glil/compile-assembly.scm
b/module/language/glil/compile-assembly.scm
index c67ef69..121d9db 100644
--- a/module/language/glil/compile-assembly.scm
+++ b/module/language/glil/compile-assembly.scm
@@ -391,17 +391,17 @@
((number? x)
`((load-number ,(number->string x))))
((string? x)
- (case (string-width x)
+ (case (string-bytes-per-char x)
((1) `((load-string ,x)))
((4) (align-code `(load-wide-string ,x) addr 4 4))
- (else (error "bad string width" x))))
+ (else (error "bad string bytes per char" x))))
((symbol? x)
(let ((str (symbol->string x)))
- (case (string-width str)
+ (case (string-bytes-per-char str)
((1) `((load-symbol ,str)))
((4) `(,@(dump-object str addr)
(make-symbol)))
- (else (error "bad string width" str)))))
+ (else (error "bad string bytes per char" str)))))
((keyword? x)
`(,@(dump-object (keyword->symbol x) addr)
(make-keyword)))
diff --git a/test-suite/tests/strings.test b/test-suite/tests/strings.test
index a35dd20..3f24537 100644
--- a/test-suite/tests/strings.test
+++ b/test-suite/tests/strings.test
@@ -24,6 +24,10 @@
(cons 'misc-error "^string is read-only"))
(define exception:illegal-escape
(cons 'read-error "illegal character in escape sequence"))
+;; Wrong types may have either the 'wrong-type-arg key when
+;; interpreted or 'vm-error when compiled. This matches both.
+(define exception:wrong-type-arg
+ (cons #t "Wrong type"))
;; Create a string from integer char values, eg. (string-ints 65) => "A"
(define (string-ints . args)
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. release_1-9-2-15-g1b9ac45,
Michael Gran <=