[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-13-207-gc
|
From: |
Ludovic Courtès |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. release_1-9-13-207-gc21a5dd |
|
Date: |
Thu, 16 Dec 2010 22:53:52 +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=c21a5ddcaf2b17d65355c977f37ee50375961d17
The branch, master has been updated
via c21a5ddcaf2b17d65355c977f37ee50375961d17 (commit)
via 6c17f7bd7147c613fc2c5ddad3e3139defdb55e7 (commit)
via 691a1c3c06f6930cc6d89c6630d9bb4343e84f5d (commit)
via 70249b98575f3e04d5058f18682d5bd242cb6710 (commit)
via 3854d5fd235c1c5f4a81e9e967cb3f12af9e6046 (commit)
via 183f784947ad350aab7595cd58874585ac389e79 (commit)
via 18f06db925a67cb6b174a9210f7bed8adced4e00 (commit)
from 0bfba83a038ba03924eb82841407d387310181d5 (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 c21a5ddcaf2b17d65355c977f37ee50375961d17
Author: Ludovic Courtès <address@hidden>
Date: Thu Dec 16 23:44:55 2010 +0100
Implement `(ice-9 threads)' high-level constructs in terms of futures.
* module/ice-9/threads.scm (parallel, par-mapper): Rewrite in terms of
`future' and `touch'.
* test-suite/tests/threads.test ("par-map", "par-for-each"): New test
prefixes.
* doc/ref/api-scheduling.texi (Parallel Forms): Add cross-ref to
futures. Recommend against the `n-' variants.
commit 6c17f7bd7147c613fc2c5ddad3e3139defdb55e7
Author: Ludovic Courtès <address@hidden>
Date: Thu Dec 16 17:38:32 2010 +0100
futures: Support multiple-value returns.
* module/ice-9/futures.scm (process-future!): Use `call-with-values'
when invoking `(future-thunk future)'.
* test-suite/tests/future.test ("futures")["multiple values"]: New test.
commit 691a1c3c06f6930cc6d89c6630d9bb4343e84f5d
Author: Ludovic Courtès <address@hidden>
Date: Thu Dec 16 17:37:02 2010 +0100
futures: Fix potential deadlock.
* module/ice-9/futures.scm (process-futures): Fix potential deadlock,
whereby %FUTURES-MUTEX would be acquired *after* FUTURE's mutex.
commit 70249b98575f3e04d5058f18682d5bd242cb6710
Author: Ludovic Courtès <address@hidden>
Date: Thu Dec 16 17:07:50 2010 +0100
Rehash weak hash tables less frequently.
* libguile/hashtab.c (weak_bucket_assoc): Call `scm_i_rehash' only when
REMAINING is below `SCM_HASHTABLE_LOWER (table)'.
commit 3854d5fd235c1c5f4a81e9e967cb3f12af9e6046
Author: Ludovic Courtès <address@hidden>
Date: Thu Dec 16 17:06:52 2010 +0100
Fix `hash' for pointer objects.
Previously all pointer objects would hash to the same value.
* libguile/hash.c (scm_hasher): Add case for `scm_tc7_pointer'.
commit 183f784947ad350aab7595cd58874585ac389e79
Author: Ludovic Courtès <address@hidden>
Date: Thu Dec 16 15:20:10 2010 +0100
Inline `scm_is_string'.
* libguile/strings.c (scm_is_string): Move to...
* libguile/inline.h (scm_is_string): ... here. Inline.
commit 18f06db925a67cb6b174a9210f7bed8adced4e00
Author: Ludovic Courtès <address@hidden>
Date: Thu Dec 16 15:14:33 2010 +0100
Add `compose', `negate', and `const'.
* module/ice-9/boot-9.scm (compose, negate, const): New procedures.
* doc/ref/api-procedures.texi (Higher-Order Functions): New node.
* test-suite/Makefile.am (SCM_TESTS): Add `tests/procs.test'.
* test-suite/tests/procs.test: New file.
-----------------------------------------------------------------------
Summary of changes:
doc/ref/api-procedures.texi | 57 +++++++++++++++++++++++++
doc/ref/api-scheduling.texi | 15 +++++++
libguile/hash.c | 11 +++++
libguile/hashtab.c | 3 +-
libguile/inline.h | 8 ++++
libguile/strings.c | 5 --
module/ice-9/boot-9.scm | 23 ++++++++++
module/ice-9/futures.scm | 12 +++--
module/ice-9/threads.scm | 36 ++++++++--------
test-suite/Makefile.am | 1 +
test-suite/tests/future.test | 9 ++++
test-suite/tests/{srfi-98.test => procs.test} | 45 ++++++++++++-------
test-suite/tests/threads.test | 39 ++++++++++++++++-
13 files changed, 215 insertions(+), 49 deletions(-)
copy test-suite/tests/{srfi-98.test => procs.test} (50%)
diff --git a/doc/ref/api-procedures.texi b/doc/ref/api-procedures.texi
index 8fc7f33..c087f4c 100644
--- a/doc/ref/api-procedures.texi
+++ b/doc/ref/api-procedures.texi
@@ -13,6 +13,7 @@
* Compiled Procedures:: Scheme procedures can be compiled.
* Optional Arguments:: Handling keyword, optional and rest arguments.
* Case-lambda:: One function, multiple arities.
+* Higher-Order Functions:: Function that take or return functions.
* Procedure Properties:: Procedure properties and meta-information.
* Procedures with Setters:: Procedures with setters.
@end menu
@@ -573,6 +574,62 @@ arguments, and on the predicate; keyword arguments may be
present but
do not contribute to the ``success'' of a match. In fact a bad keyword
argument list may cause an error to be raised.
address@hidden Higher-Order Functions
address@hidden Higher-Order Functions
+
address@hidden higher-order functions
+
+As a functional programming language, Scheme allows the definition of
address@hidden functions}, i.e., functions that take functions as
+arguments and/or return functions. Utilities to derive procedures from
+other procedures are provided and described below.
+
address@hidden {Scheme Procedure} const value
+Return a procedure that accepts any number of arguments and returns
address@hidden
+
address@hidden
+(procedure? (const 3)) @result{} #t
+((const 'hello)) @result{} hello
+((const 'hello) 'world) @result{} hello
address@hidden lisp
address@hidden deffn
+
address@hidden {Scheme Procedure} negate proc
+Return a procedure with the same arity as @var{proc} that returns the
address@hidden of @var{proc}'s result.
+
address@hidden
+(procedure? (negate number?)) @result{} #t
+((negate odd?) 2) @result{} #t
+((negate real?) 'dream) @result{} #t
+((negate string-prefix?) "GNU" "GNU Guile")
+ @result{} #f
+(filter (negate number?) '(a 2 "b"))
+ @result{} (a "b")
address@hidden lisp
address@hidden deffn
+
address@hidden {Scheme Procedure} compose proc rest ...
+Compose @var{proc} with the procedures in @var{rest}, such that the last
+one in @var{rest} is applied first and @var{proc} last, and return the
+resulting procedure. The given procedures must have compatible arity.
+
address@hidden
+(procedure? (compose 1+ 1-)) @result{} #t
+((compose sqrt 1+ 1+) 2) @result{} 2.0
+((compose 1+ sqrt) 3) @result{} 2.73205080756888
+(eq? (compose 1+) 1+) @result{} #t
+
+((compose zip unzip2) '((1 2) (a b)))
+ @result{} ((1 2) (a b))
address@hidden lisp
address@hidden deffn
+
address@hidden {Scheme Procedure} identity x
+Return X.
address@hidden deffn
+
@node Procedure Properties
@subsection Procedure Properties and Meta-information
diff --git a/doc/ref/api-scheduling.texi b/doc/ref/api-scheduling.texi
index d202f4a..d550416 100644
--- a/doc/ref/api-scheduling.texi
+++ b/doc/ref/api-scheduling.texi
@@ -904,6 +904,11 @@ The functions described in this section are available from
(use-modules (ice-9 threads))
@end example
+They provide high-level parallel constructs. The following functions
+are implemented in terms of futures (@pxref{Futures}). Thus they are
+relatively cheap as they re-use existing threads, and portable, since
+they automatically use one thread per available CPU core.
+
@deffn syntax parallel expr1 @dots{} exprN
Evaluate each @var{expr} expression in parallel, each in its own thread.
Return the results as a set of @var{N} multiple values
@@ -935,6 +940,16 @@ These functions are like @code{map} and @code{for-each}
(@pxref{List
Mapping}), but make their @var{proc} calls in parallel.
@end deffn
+Unlike those above, the functions described below take a number of
+threads as an argument. This makes them inherently non-portable since
+the specified number of threads may differ from the number of available
+CPU cores as returned by @code{current-processor-count}
+(@pxref{Processes}). In addition, these functions create the specified
+number of threads when they are called and terminate them upon
+completion, which makes them quite expensive.
+
+Therefore, they should be avoided.
+
@deffn {Scheme Procedure} n-par-map n proc lst1 @dots{} lstN
@deffnx {Scheme Procedure} n-par-for-each n proc lst1 @dots{} lstN
Call @var{proc} on the elements of the given lists, in the same way as
diff --git a/libguile/hash.c b/libguile/hash.c
index d2ce575..78a84a4 100644
--- a/libguile/hash.c
+++ b/libguile/hash.c
@@ -135,6 +135,17 @@ scm_hasher(SCM obj, unsigned long n, size_t d)
}
case scm_tc7_symbol:
return scm_i_symbol_hash (obj) % n;
+ case scm_tc7_pointer:
+ {
+ /* Pointer objects are typically used to store addresses of heap
+ objects. On most platforms, these are at least 3-byte
+ aligned (on x86_64-*-gnu, `malloc' returns 4-byte aligned
+ addresses), so get rid of the least significant bits. */
+ scm_t_uintptr significant_bits;
+
+ significant_bits = (scm_t_uintptr) SCM_POINTER_VALUE (obj) >> 4UL;
+ return (size_t) significant_bits % n;
+ }
case scm_tc7_wvect:
case scm_tc7_vector:
{
diff --git a/libguile/hashtab.c b/libguile/hashtab.c
index d5f39cb..b7cc72b 100644
--- a/libguile/hashtab.c
+++ b/libguile/hashtab.c
@@ -222,7 +222,8 @@ weak_bucket_assoc (SCM table, SCM buckets, size_t
bucket_index,
remaining = SCM_HASHTABLE_N_ITEMS (table) - args.removed_items;
SCM_SET_HASHTABLE_N_ITEMS (table, remaining);
- scm_i_rehash (table, hash_fn, closure, "weak_bucket_assoc");
+ if (remaining < SCM_HASHTABLE_LOWER (table))
+ scm_i_rehash (table, hash_fn, closure, "weak_bucket_assoc");
}
return result;
diff --git a/libguile/inline.h b/libguile/inline.h
index 018e6c6..9cc23ba 100644
--- a/libguile/inline.h
+++ b/libguile/inline.h
@@ -332,6 +332,14 @@ scm_is_pair (SCM x)
return SCM_I_CONSP (x);
}
+#ifndef SCM_INLINE_C_INCLUDING_INLINE_H
+SCM_C_EXTERN_INLINE
+#endif
+int
+scm_is_string (SCM x)
+{
+ return SCM_NIMP (x) && (SCM_TYP7 (x) == scm_tc7_string);
+}
/* Port I/O. */
diff --git a/libguile/strings.c b/libguile/strings.c
index 729b33d..71f0b52 100644
--- a/libguile/strings.c
+++ b/libguile/strings.c
@@ -1405,11 +1405,6 @@ SCM_DEFINE (scm_string_append, "string-append", 0, 0, 1,
}
#undef FUNC_NAME
-int
-scm_is_string (SCM obj)
-{
- return IS_STRING (obj);
-}
/* Conversion to/from other encodings. */
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index 1a61ce0..1b2985d 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -531,6 +531,29 @@ If there is no handler at all, Guile prints an error and
then exits."
;;;
(define (identity x) x)
+
+(define (compose proc . rest)
+ "Compose PROC with the procedures in REST, such that the last one in
+REST is applied first and PROC last, and return the resulting procedure.
+The given procedures must have compatible arity."
+ (if (null? rest)
+ proc
+ (let ((g (apply compose rest)))
+ (lambda args
+ (call-with-values (lambda () (apply g args)) proc)))))
+
+(define (negate proc)
+ "Return a procedure with the same arity as PROC that returns the `not'
+of PROC's result."
+ (lambda args
+ (not (apply proc args))))
+
+(define (const value)
+ "Return a procedure that accepts any number of arguments and returns
+VALUE."
+ (lambda _
+ value))
+
(define (and=> value procedure) (and value (procedure value)))
(define call/cc call-with-current-continuation)
diff --git a/module/ice-9/futures.scm b/module/ice-9/futures.scm
index 1e9247d..742e124 100644
--- a/module/ice-9/futures.scm
+++ b/module/ice-9/futures.scm
@@ -83,9 +83,10 @@ touched."
(set-future-result! future
(catch #t
(lambda ()
- (let ((result ((future-thunk future))))
- (lambda ()
- result)))
+ (call-with-values (future-thunk future)
+ (lambda results
+ (lambda ()
+ (apply values results)))))
(lambda args
(lambda ()
(apply throw args)))))
@@ -101,7 +102,8 @@ touched."
(() (loop))
((future _ ...)
(lock-mutex (future-mutex future))
- (or (future-done? future)
+ (or (and (future-done? future)
+ (unlock-mutex (future-mutex future)))
(begin
;; Do the actual work.
(unregister-future! future)
@@ -115,9 +117,9 @@ touched."
(lock-mutex (future-mutex future))
(or (future-done? future) ; lost the race?
(process-future! future))
+ (unlock-mutex (future-mutex future))
(lock-mutex %futures-mutex)))
- (unlock-mutex (future-mutex future))
(loop)))))
(define (touch future)
diff --git a/module/ice-9/threads.scm b/module/ice-9/threads.scm
index f56939d..ee7ff26 100644
--- a/module/ice-9/threads.scm
+++ b/module/ice-9/threads.scm
@@ -32,19 +32,20 @@
;;; Code:
(define-module (ice-9 threads)
- :export (begin-thread
- parallel
- letpar
- make-thread
- with-mutex
- monitor
-
- par-map
- par-for-each
- n-par-map
- n-par-for-each
- n-for-each-par-map
- %thread-handler))
+ #:use-module (ice-9 futures)
+ #:export (begin-thread
+ parallel
+ letpar
+ make-thread
+ with-mutex
+ monitor
+
+ par-map
+ par-for-each
+ n-par-map
+ n-par-for-each
+ n-for-each-par-map
+ %thread-handler))
@@ -62,10 +63,9 @@
(syntax-case x ()
((_ e0 ...)
(with-syntax (((tmp0 ...) (generate-temporaries (syntax (e0 ...)))))
- (syntax
- (let ((tmp0 (begin-thread e0))
- ...)
- (values (join-thread tmp0) ...))))))))
+ #'(let ((tmp0 (future e0))
+ ...)
+ (values (touch tmp0) ...)))))))
(define-syntax letpar
(syntax-rules ()
@@ -99,10 +99,10 @@
(define (par-mapper mapper)
(lambda (proc . arglists)
- (mapper join-thread
+ (mapper touch
(apply map
(lambda args
- (begin-thread (apply proc args)))
+ (future (apply proc args)))
arglists))))
(define par-map (par-mapper map))
diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am
index 2e43e87..b1f184e 100644
--- a/test-suite/Makefile.am
+++ b/test-suite/Makefile.am
@@ -72,6 +72,7 @@ SCM_TESTS = tests/00-initial-env.test \
tests/options.test \
tests/print.test \
tests/procprop.test \
+ tests/procs.test \
tests/poe.test \
tests/popen.test \
tests/popen-child.scm \
diff --git a/test-suite/tests/future.test b/test-suite/tests/future.test
index 440376d..e82b4e3 100644
--- a/test-suite/tests/future.test
+++ b/test-suite/tests/future.test
@@ -75,6 +75,15 @@
(iota 123)))))))
(reduce + 0 (iota 123))))
+ (pass-if "multiple values"
+ (let ((lst (iota 123)))
+ (equal? (zip lst lst)
+ (map (lambda (f)
+ (call-with-values (cut touch f) list))
+ (map (lambda (i)
+ (future (values i i)))
+ lst)))))
+
(pass-if "no exception"
(future? (future (throw 'foo 'bar))))
diff --git a/test-suite/tests/srfi-98.test b/test-suite/tests/procs.test
similarity index 50%
copy from test-suite/tests/srfi-98.test
copy to test-suite/tests/procs.test
index ac0d517..c17a021 100644
--- a/test-suite/tests/srfi-98.test
+++ b/test-suite/tests/procs.test
@@ -1,37 +1,48 @@
-;;;; srfi-98.test --- Test suite for Guile's SRFI-98 functions. -*- scheme -*-
+;;;; procss.test --- Procedures. -*- mode: scheme; coding: utf-8; -*-
;;;;
-;;;; Copyright 2009 Free Software Foundation, Inc.
+;;;; Copyright (C) 2010 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 the License, or (at your option) any later version.
-;;;;
+;;;;
;;;; This library 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 this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
-(define-module (test-srfi-98)
- #:use-module (srfi srfi-98)
+(define-module (test-procs)
+ #:use-module (srfi srfi-1)
#:use-module (test-suite lib))
-(with-test-prefix "get-environment-variable"
- (pass-if "get-environment-variable retrieves binding"
- (putenv "foo=bar")
- (equal? (get-environment-variable "foo") "bar"))
+(with-test-prefix "common procedures"
+
+ (pass-if "identity"
+ (eq? 'a (identity 'a)))
+
+ (pass-if "const"
+ (and (procedure? (const 'a))
+ (eq? 'a ((const 'a)))
+ (eq? 'a ((const 'a) 'b 'c 'd))))
+
+ (pass-if "negate"
+ (and (procedure? (negate number?))
+ ((negate real?) 'dream)
+ ((negate odd?) 0)))
- (pass-if "get-environment-variable #f on unbound name"
- (unsetenv "foo")
- (not (get-environment-variable "foo"))))
+ (with-test-prefix "compose"
-(with-test-prefix "get-environment-variables"
+ (pass-if "identity"
+ (eq? 1+ (compose 1+)))
- (pass-if "get-environment-variables contains binding"
- (putenv "foo=bar")
- (equal? (assoc-ref (get-environment-variables) "foo") "bar")))
+ (pass-if "simple"
+ (= 2.0 ((compose sqrt 1+ 1+) 2)))
+ (pass-if "multiple values"
+ (equal? ((compose zip unzip2) '((1 2) (a b)))
+ '((1 2) (a b))))))
diff --git a/test-suite/tests/threads.test b/test-suite/tests/threads.test
index 58a2eba..2ffffb5 100644
--- a/test-suite/tests/threads.test
+++ b/test-suite/tests/threads.test
@@ -1,6 +1,6 @@
;;;; threads.test --- Tests for Guile threading. -*- scheme -*-
;;;;
-;;;; Copyright 2003, 2006, 2007, 2009 Free Software Foundation, Inc.
+;;;; Copyright 2003, 2006, 2007, 2009, 2010 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
@@ -17,8 +17,9 @@
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
(define-module (test-threads)
- :use-module (ice-9 threads)
- :use-module (test-suite lib))
+ #:use-module (ice-9 threads)
+ #:use-module (system base compile)
+ #:use-module (test-suite lib))
(define (asyncs-still-working?)
(let ((a #f))
@@ -71,6 +72,38 @@
(equal? z 3))))))
;;
+ ;; par-map
+ ;;
+
+ (with-test-prefix "par-map"
+
+ (pass-if "simple"
+ (compile '(letrec ((fibo (lambda (n)
+ (if (<= n 1)
+ n
+ (+ (fibo (- n 1))
+ (fibo (- n 2)))))))
+ (equal? (par-map fibo (iota 13))
+ (map fibo (iota 13))))
+ #:to 'value
+ #:env (current-module))))
+
+ ;;
+ ;; par-for-each
+ ;;
+
+ (with-test-prefix "par-for-each"
+
+ (pass-if "simple"
+ (compile '(let ((v (make-vector 6 #f)))
+ (par-for-each (lambda (n)
+ (vector-set! v n n))
+ (iota 6))
+ (equal? v (list->vector (iota 6))))
+ #:to 'value
+ #:env (current-module))))
+
+ ;;
;; n-par-for-each
;;
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. release_1-9-13-207-gc21a5dd,
Ludovic Courtès <=