summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--benchmark-suite/benchmarks/ports.bm84
-rw-r--r--configure.ac2
-rw-r--r--doc/ref/api-data.texi10
-rw-r--r--libguile/finalizers.c23
-rw-r--r--libguile/gc.c2
-rw-r--r--libguile/init.c4
-rw-r--r--libguile/strings.c2
-rw-r--r--libguile/threads.c3
-rw-r--r--libguile/vports.c18
-rw-r--r--module/ice-9/psyntax-pp.scm137
-rw-r--r--module/ice-9/psyntax.scm22
11 files changed, 86 insertions, 221 deletions
diff --git a/benchmark-suite/benchmarks/ports.bm b/benchmark-suite/benchmarks/ports.bm
index 166cfa5f1..630ece290 100644
--- a/benchmark-suite/benchmarks/ports.bm
+++ b/benchmark-suite/benchmarks/ports.bm
@@ -1,6 +1,6 @@
;;; ports.bm --- Port I/O. -*- mode: scheme; coding: utf-8; -*-
;;;
-;;; Copyright (C) 2010, 2011 Free Software Foundation, Inc.
+;;; Copyright (C) 2010, 2011, 2012 Free Software Foundation, Inc.
;;;
;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Lesser General Public License
@@ -21,68 +21,72 @@
#:use-module (ice-9 rdelim)
#:use-module (benchmark-suite lib))
+(define-syntax sequence
+ (lambda (s)
+ ;; Create a sequence `(begin EXPR ...)' with COUNT occurrences of EXPR.
+ (syntax-case s ()
+ ((_ expr count)
+ (number? (syntax->datum #'count))
+ (cons #'begin
+ (make-list (syntax->datum #'count) #'expr))))))
+
+(define (large-string s)
+ (string-concatenate (make-list (* iteration-factor 10000) s)))
+
(define %latin1-port
(with-fluids ((%default-port-encoding #f))
- (open-input-string "hello, world")))
+ (open-input-string (large-string "hello, world"))))
(define %utf8/ascii-port
(with-fluids ((%default-port-encoding "UTF-8"))
- (open-input-string "hello, world")))
+ (open-input-string (large-string "hello, world"))))
(define %utf8/wide-port
(with-fluids ((%default-port-encoding "UTF-8"))
- (open-input-string "안녕하세요")))
+ (open-input-string (large-string "안녕하세요"))))
(with-benchmark-prefix "peek-char"
- (benchmark "latin-1 port" 700000
- (peek-char %latin1-port))
+ (benchmark "latin-1 port" 700
+ (sequence (peek-char %latin1-port) 1000))
- (benchmark "utf-8 port, ascii character" 700000
- (peek-char %utf8/ascii-port))
+ (benchmark "utf-8 port, ascii character" 700
+ (sequence (peek-char %utf8/ascii-port) 1000))
- (benchmark "utf-8 port, Korean character" 700000
- (peek-char %utf8/wide-port)))
+ (benchmark "utf-8 port, Korean character" 700
+ (sequence (peek-char %utf8/wide-port) 1000)))
-(with-benchmark-prefix "read-char"
+(with-benchmark-prefix "char-ready?"
- (benchmark "latin-1 port" 10000000
- (read-char %latin1-port))
+ (benchmark "latin-1 port" 10000
+ (sequence (char-ready? %latin1-port) 1000))
- (benchmark "utf-8 port, ascii character" 10000000
- (read-char %utf8/ascii-port))
+ (benchmark "utf-8 port, ascii character" 10000
+ (sequence (char-ready? %utf8/ascii-port) 1000))
- (benchmark "utf-8 port, Korean character" 10000000
- (read-char %utf8/wide-port)))
+ (benchmark "utf-8 port, Korean character" 10000
+ (sequence (char-ready? %utf8/wide-port) 1000)))
-(with-benchmark-prefix "char-ready?"
+;; Keep the `read-char' benchmarks last as they consume input from the
+;; ports.
+
+(with-benchmark-prefix "read-char"
- (benchmark "latin-1 port" 10000000
- (char-ready? %latin1-port))
+ (benchmark "latin-1 port" 10000
+ (sequence (read-char %latin1-port) 1000))
- (benchmark "utf-8 port, ascii character" 10000000
- (char-ready? %utf8/ascii-port))
+ (benchmark "utf-8 port, ascii character" 10000
+ (sequence (read-char %utf8/ascii-port) 1000))
- (benchmark "utf-8 port, Korean character" 10000000
- (char-ready? %utf8/wide-port)))
+ (benchmark "utf-8 port, Korean character" 10000
+ (sequence (read-char %utf8/wide-port) 1000)))
(with-benchmark-prefix "rdelim"
- (let-syntax ((sequence (lambda (s)
- ;; Create a sequence `(begin EXPR ...)' with
- ;; COUNT occurrences of EXPR.
- (syntax-case s ()
- ((_ expr count)
- (number? (syntax->datum #'count))
- (cons #'begin
- (make-list
- (syntax->datum #'count)
- #'expr)))))))
- (let ((str (string-concatenate
- (make-list 1000 "one line\n"))))
- (benchmark "read-line" 1000
- (let ((port (with-fluids ((%default-port-encoding "UTF-8"))
- (open-input-string str))))
- (sequence (read-line port) 1000))))))
+ (let ((str (string-concatenate (make-list 1000 "one line\n"))))
+ (benchmark "read-line" 1000
+ (let ((port (with-fluids ((%default-port-encoding "UTF-8"))
+ (open-input-string str))))
+ (sequence (read-line port) 1000)))))
diff --git a/configure.ac b/configure.ac
index 3a5fd0e35..f79c671df 100644
--- a/configure.ac
+++ b/configure.ac
@@ -1232,7 +1232,7 @@ save_LIBS="$LIBS"
LIBS="$BDW_GC_LIBS $LIBS"
CFLAGS="$BDW_GC_CFLAGS $CFLAGS"
-AC_CHECK_FUNCS([GC_do_blocking GC_call_with_gc_active GC_pthread_exit GC_pthread_cancel GC_allow_register_threads GC_pthread_sigmask GC_set_start_callback GC_get_suspend_signal GC_move_disappearing_link GC_get_heap_usage_safe GC_get_free_space_divisor GC_gcollect_and_unmap GC_get_unmapped_bytes])
+AC_CHECK_FUNCS([GC_do_blocking GC_call_with_gc_active GC_pthread_exit GC_pthread_cancel GC_allow_register_threads GC_pthread_sigmask GC_set_start_callback GC_get_suspend_signal GC_move_disappearing_link GC_get_heap_usage_safe GC_get_free_space_divisor GC_gcollect_and_unmap GC_get_unmapped_bytes GC_set_finalizer_notifier])
# Though the `GC_do_blocking ()' symbol is present in GC 7.1, it is not
# declared, and has a different type (returning void instead of
diff --git a/doc/ref/api-data.texi b/doc/ref/api-data.texi
index 4fc11c81d..39c97909a 100644
--- a/doc/ref/api-data.texi
+++ b/doc/ref/api-data.texi
@@ -3405,7 +3405,6 @@ i18n)} module}, for locale-dependent string comparison.
@rnindex string=?
@deffn {Scheme Procedure} string=? s1 s2 s3 @dots{}
-@deffnx {C Function} scm_i_string_equal_p (s1, s2, rest)
Lexicographic equality predicate; return @code{#t} if all strings are
the same length and contain the same characters in the same positions,
otherwise return @code{#f}.
@@ -3418,7 +3417,6 @@ characters.
@rnindex string<?
@deffn {Scheme Procedure} string<? s1 s2 s3 @dots{}
-@deffnx {C Function} scm_i_string_less_p (s1, s2, rest)
Lexicographic ordering predicate; return @code{#t} if, for every pair of
consecutive string arguments @var{str_i} and @var{str_i+1}, @var{str_i} is
lexicographically less than @var{str_i+1}.
@@ -3426,7 +3424,6 @@ lexicographically less than @var{str_i+1}.
@rnindex string<=?
@deffn {Scheme Procedure} string<=? s1 s2 s3 @dots{}
-@deffnx {C Function} scm_i_string_leq_p (s1, s2, rest)
Lexicographic ordering predicate; return @code{#t} if, for every pair of
consecutive string arguments @var{str_i} and @var{str_i+1}, @var{str_i} is
lexicographically less than or equal to @var{str_i+1}.
@@ -3434,7 +3431,6 @@ lexicographically less than or equal to @var{str_i+1}.
@rnindex string>?
@deffn {Scheme Procedure} string>? s1 s2 s3 @dots{}
-@deffnx {C Function} scm_i_string_gr_p (s1, s2, rest)
Lexicographic ordering predicate; return @code{#t} if, for every pair of
consecutive string arguments @var{str_i} and @var{str_i+1}, @var{str_i} is
lexicographically greater than @var{str_i+1}.
@@ -3442,7 +3438,6 @@ lexicographically greater than @var{str_i+1}.
@rnindex string>=?
@deffn {Scheme Procedure} string>=? s1 s2 s3 @dots{}
-@deffnx {C Function} scm_i_string_geq_p (s1, s2, rest)
Lexicographic ordering predicate; return @code{#t} if, for every pair of
consecutive string arguments @var{str_i} and @var{str_i+1}, @var{str_i} is
lexicographically greater than or equal to @var{str_i+1}.
@@ -3450,7 +3445,6 @@ lexicographically greater than or equal to @var{str_i+1}.
@rnindex string-ci=?
@deffn {Scheme Procedure} string-ci=? s1 s2 s3 @dots{}
-@deffnx {C Function} scm_i_string_ci_equal_p (s1, s2, rest)
Case-insensitive string equality predicate; return @code{#t} if
all strings are the same length and their component
characters match (ignoring case) at each position; otherwise
@@ -3459,7 +3453,6 @@ return @code{#f}.
@rnindex string-ci<?
@deffn {Scheme Procedure} string-ci<? s1 s2 s3 @dots{}
-@deffnx {C Function} scm_i_string_ci_less_p (s1, s2, rest)
Case insensitive lexicographic ordering predicate; return @code{#t} if,
for every pair of consecutive string arguments @var{str_i} and
@var{str_i+1}, @var{str_i} is lexicographically less than @var{str_i+1}
@@ -3468,7 +3461,6 @@ regardless of case.
@rnindex string<=?
@deffn {Scheme Procedure} string-ci<=? s1 s2 s3 @dots{}
-@deffnx {C Function} scm_i_string_ci_leq_p (s1, s2, rest)
Case insensitive lexicographic ordering predicate; return @code{#t} if,
for every pair of consecutive string arguments @var{str_i} and
@var{str_i+1}, @var{str_i} is lexicographically less than or equal to
@@ -3477,7 +3469,6 @@ for every pair of consecutive string arguments @var{str_i} and
@rnindex string-ci>?
@deffn {Scheme Procedure} string-ci>? s1 s2 s3 @dots{}
-@deffnx {C Function} scm_i_string_ci_gr_p (s1, s2, rest)
Case insensitive lexicographic ordering predicate; return @code{#t} if,
for every pair of consecutive string arguments @var{str_i} and
@var{str_i+1}, @var{str_i} is lexicographically greater than
@@ -3486,7 +3477,6 @@ for every pair of consecutive string arguments @var{str_i} and
@rnindex string-ci>=?
@deffn {Scheme Procedure} string-ci>=? s1 s2 s3 @dots{}
-@deffnx {C Function} scm_i_string_ci_geq_p (s1, s2, rest)
Case insensitive lexicographic ordering predicate; return @code{#t} if,
for every pair of consecutive string arguments @var{str_i} and
@var{str_i+1}, @var{str_i} is lexicographically greater than or equal to
diff --git a/libguile/finalizers.c b/libguile/finalizers.c
index 07d8f0748..25aadf431 100644
--- a/libguile/finalizers.c
+++ b/libguile/finalizers.c
@@ -43,6 +43,17 @@ static size_t finalization_count;
+#ifndef HAVE_GC_SET_FINALIZER_NOTIFIER
+static void
+GC_set_finalizer_notifier (void (*notifier) (void))
+{
+ GC_finalizer_notifier = notifier;
+}
+#endif
+
+
+
+
void
scm_i_set_finalizer (void *obj, scm_t_finalizer_proc proc, void *data)
{
@@ -142,10 +153,9 @@ run_finalizers_async_thunk (void)
}
-/* The function queue_after_gc_hook is run by the scm_before_gc_c_hook
- * at the end of the garbage collection. The only purpose of this
- * function is to mark the after_gc_async (which will eventually lead to
- * the execution of the after_gc_async_thunk).
+/* The function queue_finalizer_async is run by the GC when there are
+ * objects to finalize. It will enqueue an asynchronous call to
+ * GC_invoke_finalizers() at the next SCM_TICK in this thread.
*/
static void
queue_finalizer_async (void)
@@ -154,7 +164,10 @@ queue_finalizer_async (void)
static scm_i_pthread_mutex_t lock = SCM_I_PTHREAD_MUTEX_INITIALIZER;
scm_i_pthread_mutex_lock (&lock);
- if (scm_is_false (SCM_CDR (finalizer_async_cell)))
+ /* If t is NULL, that could be because we're allocating in
+ threads.c:guilify_self_1. In that case, rely on the
+ GC_invoke_finalizers call there after the thread spins up. */
+ if (t && scm_is_false (SCM_CDR (finalizer_async_cell)))
{
SCM_SETCDR (finalizer_async_cell, t->active_asyncs);
t->active_asyncs = finalizer_async_cell;
diff --git a/libguile/gc.c b/libguile/gc.c
index b33fb0ca1..df93d32e5 100644
--- a/libguile/gc.c
+++ b/libguile/gc.c
@@ -384,6 +384,8 @@ SCM_DEFINE (scm_gc, "gc", 0, 0, 0,
#define FUNC_NAME s_scm_gc
{
scm_i_gc ("call");
+ /* If you're calling scm_gc(), you probably want synchronous
+ finalization. */
GC_invoke_finalizers ();
return SCM_UNSPECIFIED;
}
diff --git a/libguile/init.c b/libguile/init.c
index 90b01eedb..684f6eb02 100644
--- a/libguile/init.c
+++ b/libguile/init.c
@@ -444,7 +444,8 @@ scm_i_init_guile (void *base)
scm_init_ioext ();
scm_init_keywords (); /* Requires smob_prehistory */
scm_init_list ();
- scm_init_macros (); /* Requires smob_prehistory */
+ scm_init_random (); /* Requires smob_prehistory */
+ scm_init_macros (); /* Requires smob_prehistory and random */
scm_init_mallocs (); /* Requires smob_prehistory */
scm_init_modules (); /* Requires smob_prehistory */
scm_init_numbers ();
@@ -502,7 +503,6 @@ scm_i_init_guile (void *base)
scm_init_eval_in_scheme ();
scm_init_evalext ();
scm_init_debug (); /* Requires macro smobs */
- scm_init_random (); /* Requires smob_prehistory */
scm_init_simpos ();
#if HAVE_MODULES
scm_init_dynamic_linking (); /* Requires smob_prehistory */
diff --git a/libguile/strings.c b/libguile/strings.c
index 961705782..c84c8301a 100644
--- a/libguile/strings.c
+++ b/libguile/strings.c
@@ -748,7 +748,7 @@ scm_i_make_symbol (SCM name, scm_t_bits flags,
name = SH_STRING_STRING (name);
start += STRING_START (name);
}
- buf = SYMBOL_STRINGBUF (name);
+ buf = STRING_STRINGBUF (name);
if (start == 0 && length == STRINGBUF_LENGTH (buf))
{
diff --git a/libguile/threads.c b/libguile/threads.c
index f9104f9e3..8e72eafdf 100644
--- a/libguile/threads.c
+++ b/libguile/threads.c
@@ -625,6 +625,9 @@ guilify_self_2 (SCM parent)
t->join_queue = make_queue ();
t->block_asyncs = 0;
+
+ /* See note in finalizers.c:queue_finalizer_async(). */
+ GC_invoke_finalizers ();
}
diff --git a/libguile/vports.c b/libguile/vports.c
index 62f552ad7..4ff13f2e8 100644
--- a/libguile/vports.c
+++ b/libguile/vports.c
@@ -56,21 +56,11 @@ sf_flush (SCM port)
scm_t_port *pt = SCM_PTAB_ENTRY (port);
SCM stream = SCM_PACK (pt->stream);
- if (pt->write_pos > pt->write_buf)
- {
- /* write the byte. */
- scm_call_1 (SCM_SIMPLE_VECTOR_REF (stream, 0),
- SCM_MAKE_CHAR (*pt->write_buf));
- pt->write_pos = pt->write_buf;
-
- /* flush the output. */
- {
- SCM f = SCM_SIMPLE_VECTOR_REF (stream, 2);
+ SCM f = SCM_SIMPLE_VECTOR_REF (stream, 2);
+
+ if (scm_is_true (f))
+ scm_call_0 (f);
- if (scm_is_true (f))
- scm_call_0 (f);
- }
- }
}
static void
diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm
index f82a14c0c..d1ad7fe27 100644
--- a/module/ice-9/psyntax-pp.scm
+++ b/module/ice-9/psyntax-pp.scm
@@ -2682,83 +2682,6 @@
"source expression failed to match any pattern"
tmp-1)))))))
-(define do
- (make-syntax-transformer
- 'do
- 'macro
- (lambda (orig-x)
- (let ((tmp-1 orig-x))
- (let ((tmp ($sc-dispatch
- tmp-1
- '(_ #(each (any any . any)) (any . each-any) . each-any))))
- (if tmp
- (apply (lambda (var init step e0 e1 c)
- (let ((tmp-1 (map (lambda (v s)
- (let ((tmp-1 s))
- (let ((tmp ($sc-dispatch tmp-1 '())))
- (if tmp
- (apply (lambda () v) tmp)
- (let ((tmp ($sc-dispatch tmp-1 '(any))))
- (if tmp
- (apply (lambda (e) e) tmp)
- (syntax-violation 'do "bad step expression" orig-x s)))))))
- var
- step)))
- (let ((tmp ($sc-dispatch tmp-1 'each-any)))
- (if tmp
- (apply (lambda (step)
- (let ((tmp e1))
- (let ((tmp-1 ($sc-dispatch tmp '())))
- (if tmp-1
- (apply (lambda ()
- (list '#(syntax-object let ((top)) (hygiene guile))
- '#(syntax-object doloop ((top)) (hygiene guile))
- (map list var init)
- (list '#(syntax-object if ((top)) (hygiene guile))
- (list '#(syntax-object not ((top)) (hygiene guile)) e0)
- (cons '#(syntax-object begin ((top)) (hygiene guile))
- (append
- c
- (list (cons '#(syntax-object
- doloop
- ((top))
- (hygiene guile))
- step)))))))
- tmp-1)
- (let ((tmp-1 ($sc-dispatch tmp '(any . each-any))))
- (if tmp-1
- (apply (lambda (e1 e2)
- (list '#(syntax-object let ((top)) (hygiene guile))
- '#(syntax-object doloop ((top)) (hygiene guile))
- (map list var init)
- (list '#(syntax-object if ((top)) (hygiene guile))
- e0
- (cons '#(syntax-object begin ((top)) (hygiene guile))
- (cons e1 e2))
- (cons '#(syntax-object begin ((top)) (hygiene guile))
- (append
- c
- (list (cons '#(syntax-object
- doloop
- ((top))
- (hygiene guile))
- step)))))))
- tmp-1)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- tmp)))))))
- tmp)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- tmp-1)))))
- tmp)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- tmp-1)))))))
-
(define quasiquote
(make-syntax-transformer
'quasiquote
@@ -3163,66 +3086,6 @@
"expression not valid outside of quasiquote"
x))))
-(define case
- (make-syntax-transformer
- 'case
- 'macro
- (lambda (x)
- (let ((tmp-1 x))
- (let ((tmp ($sc-dispatch tmp-1 '(_ any any . each-any))))
- (if tmp
- (apply (lambda (e m1 m2)
- (let ((tmp (let f ((clause m1) (clauses m2))
- (if (null? clauses)
- (let ((tmp-1 clause))
- (let ((tmp ($sc-dispatch
- tmp-1
- '(#(free-id #(syntax-object else ((top)) (hygiene guile)))
- any
- .
- each-any))))
- (if tmp
- (apply (lambda (e1 e2)
- (cons '#(syntax-object begin ((top)) (hygiene guile)) (cons e1 e2)))
- tmp)
- (let ((tmp ($sc-dispatch tmp-1 '(each-any any . each-any))))
- (if tmp
- (apply (lambda (k e1 e2)
- (list '#(syntax-object if ((top)) (hygiene guile))
- (list '#(syntax-object memv ((top)) (hygiene guile))
- '#(syntax-object t ((top)) (hygiene guile))
- (list '#(syntax-object quote ((top)) (hygiene guile))
- k))
- (cons '#(syntax-object begin ((top)) (hygiene guile))
- (cons e1 e2))))
- tmp)
- (syntax-violation 'case "bad clause" x clause))))))
- (let ((tmp (f (car clauses) (cdr clauses))))
- (let ((rest tmp))
- (let ((tmp clause))
- (let ((tmp ($sc-dispatch tmp '(each-any any . each-any))))
- (if tmp
- (apply (lambda (k e1 e2)
- (list '#(syntax-object if ((top)) (hygiene guile))
- (list '#(syntax-object memv ((top)) (hygiene guile))
- '#(syntax-object t ((top)) (hygiene guile))
- (list '#(syntax-object quote ((top)) (hygiene guile))
- k))
- (cons '#(syntax-object begin ((top)) (hygiene guile))
- (cons e1 e2))
- rest))
- tmp)
- (syntax-violation 'case "bad clause" x clause))))))))))
- (let ((body tmp))
- (list '#(syntax-object let ((top)) (hygiene guile))
- (list (list '#(syntax-object t ((top)) (hygiene guile)) e))
- body))))
- tmp)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- tmp-1)))))))
-
(define make-variable-transformer
(lambda (proc)
(if (procedure? proc)
diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm
index 760f8252f..2cc6386e9 100644
--- a/module/ice-9/psyntax.scm
+++ b/module/ice-9/psyntax.scm
@@ -608,22 +608,15 @@
;; syntax object wraps
- ;; <wrap> ::= ((<mark> ...) . (<subst> ...))
- ;; <subst> ::= <shift> | <subs>
- ;; <subs> ::= #(<old name> <label> (<mark> ...))
- ;; <shift> ::= positive fixnum
+ ;; <wrap> ::= ((<mark> ...) . (<subst> ...))
+ ;; <subst> ::= shift | <subs>
+ ;; <subs> ::= #(ribcage #(<sym> ...) #(<mark> ...) #(<label> ...))
+ ;; | #(ribcage (<sym> ...) (<mark> ...) (<label> ...))
(define-syntax make-wrap (identifier-syntax cons))
(define-syntax wrap-marks (identifier-syntax car))
(define-syntax wrap-subst (identifier-syntax cdr))
- (define-syntax subst-rename? (identifier-syntax vector?))
- (define-syntax-rule (rename-old x) (vector-ref x 0))
- (define-syntax-rule (rename-new x) (vector-ref x 1))
- (define-syntax-rule (rename-marks x) (vector-ref x 2))
- (define-syntax-rule (make-rename old new marks)
- (vector old new marks))
-
;; labels must be comparable with "eq?", have read-write invariance,
;; and distinct from symbols.
(define (gen-label)
@@ -2903,6 +2896,9 @@
(binding (car bindings)))
#'(let (binding) body))))))))
+;; This definition of 'do' is never used, as it is immediately
+;; replaced by the definition in boot-9.scm.
+#;
(define-syntax do
(lambda (orig-x)
(syntax-case orig-x ()
@@ -3076,6 +3072,10 @@
"expression not valid outside of quasiquote"
x)))
+;; This definition of 'case' is never used, as it is immediately
+;; replaced by the definition in boot-9.scm. This version lacks
+;; R7RS-mandated support for '=>'.
+#;
(define-syntax case
(lambda (x)
(syntax-case x ()