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))) - -(with-benchmark-prefix "read-char" - - (benchmark "latin-1 port" 10000000 - (read-char %latin1-port)) - - (benchmark "utf-8 port, ascii character" 10000000 - (read-char %utf8/ascii-port)) - - (benchmark "utf-8 port, Korean character" 10000000 - (read-char %utf8/wide-port))) + (benchmark "utf-8 port, Korean character" 700 + (sequence (peek-char %utf8/wide-port) 1000))) (with-benchmark-prefix "char-ready?" - (benchmark "latin-1 port" 10000000 - (char-ready? %latin1-port)) + (benchmark "latin-1 port" 10000 + (sequence (char-ready? %latin1-port) 1000)) - (benchmark "utf-8 port, ascii character" 10000000 - (char-ready? %utf8/ascii-port)) + (benchmark "utf-8 port, ascii character" 10000 + (sequence (char-ready? %utf8/ascii-port) 1000)) - (benchmark "utf-8 port, Korean character" 10000000 - (char-ready? %utf8/wide-port))) + (benchmark "utf-8 port, Korean character" 10000 + (sequence (char-ready? %utf8/wide-port) 1000))) + +;; Keep the `read-char' benchmarks last as they consume input from the +;; ports. + +(with-benchmark-prefix "read-char" + + (benchmark "latin-1 port" 10000 + (sequence (read-char %latin1-port) 1000)) + + (benchmark "utf-8 port, ascii character" 10000 + (sequence (read-char %utf8/ascii-port) 1000)) + + (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_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_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 @@ -41,6 +41,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 @@ -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 - ;; ::= (( ...) . ( ...)) - ;; ::= | - ;; ::= #(