[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.6-91-g2c7b7e
|
From: |
Ludovic Courtès |
|
Subject: |
[Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.6-91-g2c7b7e0 |
|
Date: |
Wed, 21 Nov 2012 23:25:43 +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=2c7b7e0f214be5ec5184949a94209668775f60bc
The branch, stable-2.0 has been updated
via 2c7b7e0f214be5ec5184949a94209668775f60bc (commit)
via 2d37a9349404c3161d89967c014cbaa1a28e59ea (commit)
via 3e529bf02af7939c7c7d06ed68f0108b336ed4d2 (commit)
via ab975cf592a89eee30fec94e77ef064eda0b38b5 (commit)
via f2fb5e5328473556208b041cc4806e5a8fd11a4c (commit)
from 7ae4e75af5366086e60fbc2e9454dfd9e5965102 (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 2c7b7e0f214be5ec5184949a94209668775f60bc
Author: Ludovic Courtès <address@hidden>
Date: Wed Nov 21 23:51:16 2012 +0100
cse: Fix out-of-bounds access to the database.
Fixes <http://bugs.gnu.org/12883>.
* module/language/tree-il/cse.scm (cse)[find-dominating-lexical]: Fix
computation of the last argument passed to `unroll'.
Patch by Stefan Israelsson Tampe <address@hidden>.
* test-suite/tests/cse.test ("cse")["http://bugs.gnu.org/12883"]: New
test.
commit 2d37a9349404c3161d89967c014cbaa1a28e59ea
Author: Ludovic Courtès <address@hidden>
Date: Sat Nov 17 00:11:23 2012 +0100
Update `par-map' to use nested futures.
This allows it to actually use all CPU cores, instead of having the main
thread stuck on a `wait-condition-variable'.
* module/ice-9/threads.scm (par-mapper): Add a `cons' argument; update
callers accordingly. Rewrite using nested futures.
commit 3e529bf02af7939c7c7d06ed68f0108b336ed4d2
Author: Ludovic Courtès <address@hidden>
Date: Sat Nov 17 00:20:21 2012 +0100
futures: Allow nested futures; put the main thread to work.
* module/ice-9/futures.scm (%futures-waiting, %within-future?,
%future-prompt): New variables.
(let/ec): New macro.
(process-future!): Run FUTURE's thunk in a prompt; capture FUTURE's
continuation when it aborts, and add it to %FUTURES-WAITING. Set
%WITHIN-FUTURE? in the dynamic extent of the call FUTURE's thunk.
(process-futures): Move loop body to...
(process-one-future): ... here. New procedure.
(notify-completion): New procedure.
(touch)[work, loop]: New procedures.
When %WITHIN-FUTURE? and FUTURE is started, abort; if not
%WITHIN-FUTURE, call `work' while waiting.
When FUTURE is queued, call `work' too.
* test-suite/tests/future.test ("nested futures"): New tests.
commit ab975cf592a89eee30fec94e77ef064eda0b38b5
Author: Ludovic Courtès <address@hidden>
Date: Fri Nov 16 23:51:59 2012 +0100
futures: Add a record printer.
* module/ice-9/futures.scm: Add a record printer for <future>.
commit f2fb5e5328473556208b041cc4806e5a8fd11a4c
Author: Ludovic Courtès <address@hidden>
Date: Wed Nov 7 15:16:03 2012 +0100
futures: Keep futures unlocked while they are processing.
* module/ice-9/futures.scm (<future>)[completion]: New field.
[done?]: Rename to...
[state]: ... this. Change `set-future-done?!' to
`set-future-state!', and `future-done?' to `future-state'.
(make-future): Initialize the `completion' field to 'queued.
(with-mutex): New macro.
(process-future!): Remove `set-future-done?!' call.
(process-futures): Check `future-state'. Unlock FUTURE's mutex before
processing it. Broadcast FUTURE's `completion' cond. var. when done.
(touch): Likewise.
-----------------------------------------------------------------------
Summary of changes:
module/ice-9/futures.scm | 235 ++++++++++++++++++++++++++++++---------
module/ice-9/threads.scm | 25 +++--
module/language/tree-il/cse.scm | 9 +-
test-suite/tests/cse.test | 19 +++-
test-suite/tests/future.test | 20 +++-
5 files changed, 239 insertions(+), 69 deletions(-)
diff --git a/module/ice-9/futures.scm b/module/ice-9/futures.scm
index 7fbccf6..48eeb6a 100644
--- a/module/ice-9/futures.scm
+++ b/module/ice-9/futures.scm
@@ -19,8 +19,11 @@
(define-module (ice-9 futures)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9)
+ #:use-module (srfi srfi-9 gnu)
+ #:use-module (srfi srfi-11)
#:use-module (ice-9 threads)
#:use-module (ice-9 q)
+ #:use-module (ice-9 match)
#:export (future make-future future? touch))
;;; Author: Ludovic Courtès <address@hidden>
@@ -44,19 +47,29 @@
;;;
(define-record-type <future>
- (%make-future thunk done? mutex)
+ (%make-future thunk state mutex completion)
future?
- (thunk future-thunk)
- (done? future-done? set-future-done?!)
- (result future-result set-future-result!)
- (mutex future-mutex))
+ (thunk future-thunk set-future-thunk!)
+ (state future-state set-future-state!) ; done | started | queued
+ (result future-result set-future-result!)
+ (mutex future-mutex)
+ (completion future-completion)) ; completion cond. var.
+
+(set-record-type-printer!
+ <future>
+ (lambda (future port)
+ (simple-format port "#<future ~a ~a ~s>"
+ (number->string (object-address future) 16)
+ (future-state future)
+ (future-thunk future))))
(define (make-future thunk)
"Return a new future for THUNK. Execution may start at any point
concurrently, or it can start at the time when the returned future is
touched."
(create-workers!)
- (let ((future (%make-future thunk #f (make-mutex))))
+ (let ((future (%make-future thunk 'queued
+ (make-mutex) (make-condition-variable))))
(register-future! future)
future))
@@ -65,10 +78,44 @@ touched."
;;; Future queues.
;;;
+;; Global queue of pending futures.
+;; TODO: Use per-worker queues to reduce contention.
(define %futures (make-q))
+
+;; Lock for %FUTURES and %FUTURES-WAITING.
(define %futures-mutex (make-mutex))
(define %futures-available (make-condition-variable))
+;; A mapping of nested futures to futures waiting for them to complete.
+(define %futures-waiting '())
+
+;; Whether currently running within a future.
+(define %within-future? (make-parameter #f))
+
+(define-syntax-rule (with-mutex m e0 e1 ...)
+ ;; Copied from (ice-9 threads) to avoid circular dependency.
+ (let ((x m))
+ (dynamic-wind
+ (lambda () (lock-mutex x))
+ (lambda () (begin e0 e1 ...))
+ (lambda () (unlock-mutex x)))))
+
+(define-syntax-rule (let/ec k e e* ...) ; TODO: move to core
+ (let ((tag (make-prompt-tag)))
+ (call-with-prompt
+ tag
+ (lambda ()
+ (let ((k (lambda args (apply abort-to-prompt tag args))))
+ e e* ...))
+ (lambda (_ res) res))))
+
+
+(define %future-prompt
+ ;; The prompt futures abort to when they want to wait for another
+ ;; future.
+ (make-prompt-tag))
+
+
(define (register-future! future)
;; Register FUTURE as being processable.
(lock-mutex %futures-mutex)
@@ -77,66 +124,146 @@ touched."
(unlock-mutex %futures-mutex))
(define (process-future! future)
- ;; Process FUTURE, assuming its mutex is already taken.
- (set-future-result! future
- (catch #t
- (lambda ()
- (call-with-values (future-thunk future)
- (lambda results
+ "Process FUTURE. When FUTURE completes, return #t and update its
+result; otherwise, when FUTURE touches a nested future that has not
+completed yet, then suspend it and return #f. Suspending a future
+consists in capturing its continuation, marking it as `queued', and
+adding it to the waiter queue."
+ (let/ec return
+ (let* ((suspend
+ (lambda (cont future-to-wait)
+ ;; FUTURE wishes to wait for the completion of FUTURE-TO-WAIT.
+ ;; At this point, FUTURE is unlocked and in `started' state,
+ ;; and FUTURE-TO-WAIT is unlocked.
+ (with-mutex %futures-mutex
+ (with-mutex (future-mutex future)
+ (set-future-thunk! future cont)
+ (set-future-state! future 'queued))
+
+ (with-mutex (future-mutex future-to-wait)
+ ;; If FUTURE-TO-WAIT completed in the meantime, then
+ ;; reschedule FUTURE directly; otherwise, add it to the
+ ;; waiter queue.
+ (if (eq? 'done (future-state future-to-wait))
+ (begin
+ (enq! %futures future)
+ (signal-condition-variable %futures-available))
+ (set! %futures-waiting
+ (alist-cons future-to-wait future
+ %futures-waiting))))
+
+ (return #f))))
+ (thunk (lambda ()
+ (call-with-prompt %future-prompt
+ (lambda ()
+ (parameterize ((%within-future? #t))
+ ((future-thunk future))))
+ suspend))))
+ (set-future-result! future
+ (catch #t
+ (lambda ()
+ (call-with-values thunk
+ (lambda results
+ (lambda ()
+ (apply values results)))))
+ (lambda args
(lambda ()
- (apply values results)))))
- (lambda args
- (lambda ()
- (apply throw args)))))
- (set-future-done?! future #t))
+ (apply throw args)))))
+ #t)))
+
+(define (process-one-future)
+ "Attempt to pick one future from the queue and process it."
+ ;; %FUTURES-MUTEX must be locked on entry, and is locked on exit.
+ (or (q-empty? %futures)
+ (let ((future (deq! %futures)))
+ (lock-mutex (future-mutex future))
+ (case (future-state future)
+ ((done started)
+ ;; Nothing to do.
+ (unlock-mutex (future-mutex future)))
+ (else
+ ;; Do the actual work.
+
+ ;; We want to release %FUTURES-MUTEX so that other workers can
+ ;; progress. However, to avoid deadlocks, we have to unlock
+ ;; FUTURE as well, to preserve lock ordering.
+ (unlock-mutex (future-mutex future))
+ (unlock-mutex %futures-mutex)
+
+ (lock-mutex (future-mutex future))
+ (if (eq? (future-state future) 'queued) ; lost the race?
+ (begin ; no, so let's process it
+ (set-future-state! future 'started)
+ (unlock-mutex (future-mutex future))
+
+ (let ((done? (process-future! future)))
+ (when done?
+ (with-mutex %futures-mutex
+ (with-mutex (future-mutex future)
+ (set-future-state! future 'done)
+ (notify-completion future))))))
+ (unlock-mutex (future-mutex future))) ; yes
+
+ (lock-mutex %futures-mutex))))))
(define (process-futures)
- ;; Wait for futures to be available and process them.
+ "Continuously process futures from the queue."
(lock-mutex %futures-mutex)
(let loop ()
(when (q-empty? %futures)
(wait-condition-variable %futures-available
%futures-mutex))
- (or (q-empty? %futures)
- (let ((future (deq! %futures)))
- (lock-mutex (future-mutex future))
- (or (and (future-done? future)
- (unlock-mutex (future-mutex future)))
- (begin
- ;; Do the actual work.
-
- ;; We want to release %FUTURES-MUTEX so that other workers
- ;; can progress. However, to avoid deadlocks, we have to
- ;; unlock FUTURE as well, to preserve lock ordering.
- (unlock-mutex (future-mutex future))
- (unlock-mutex %futures-mutex)
-
- (lock-mutex (future-mutex future))
- (or (future-done? future) ; lost the race?
- (process-future! future))
- (unlock-mutex (future-mutex future))
-
- (lock-mutex %futures-mutex)))))
+ (process-one-future)
(loop)))
+(define (notify-completion future)
+ "Notify futures and callers waiting that FUTURE completed."
+ ;; FUTURE and %FUTURES-MUTEX are locked.
+ (broadcast-condition-variable (future-completion future))
+ (let-values (((waiting remaining)
+ (partition (match-lambda ; TODO: optimize
+ ((waitee . _)
+ (eq? waitee future)))
+ %futures-waiting)))
+ (set! %futures-waiting remaining)
+ (for-each (match-lambda
+ ((_ . waiter)
+ (enq! %futures waiter)))
+ waiting)))
+
(define (touch future)
"Return the result of FUTURE, computing it if not already done."
- (lock-mutex (future-mutex future))
- (or (future-done? future)
- (begin
- ;; Do the actual work. Unlock FUTURE first to preserve lock
- ;; ordering.
- (unlock-mutex (future-mutex future))
-
- (lock-mutex %futures-mutex)
- (q-remove! %futures future)
- (unlock-mutex %futures-mutex)
+ (define (work)
+ ;; Do some work while waiting for FUTURE to complete.
+ (lock-mutex %futures-mutex)
+ (if (q-empty? %futures)
+ (begin
+ (unlock-mutex %futures-mutex)
+ (with-mutex (future-mutex future)
+ (unless (eq? 'done (future-state future))
+ (wait-condition-variable (future-completion future)
+ (future-mutex future)))))
+ (begin
+ (process-one-future)
+ (unlock-mutex %futures-mutex))))
- (lock-mutex (future-mutex future))
- (or (future-done? future) ; lost the race?
- (process-future! future))))
- (unlock-mutex (future-mutex future))
+ (let loop ()
+ (lock-mutex (future-mutex future))
+ (case (future-state future)
+ ((done)
+ (unlock-mutex (future-mutex future)))
+ ((started)
+ (unlock-mutex (future-mutex future))
+ (if (%within-future?)
+ (abort-to-prompt %future-prompt future)
+ (begin
+ (work)
+ (loop))))
+ (else
+ (unlock-mutex (future-mutex future))
+ (work)
+ (loop))))
((future-result future)))
@@ -184,3 +311,7 @@ touched."
(define-syntax-rule (future body)
"Return a new future for BODY."
(make-future (lambda () body)))
+
+;;; Local Variables:
+;;; eval: (put 'with-mutex 'scheme-indent-function 1)
+;;; End:
diff --git a/module/ice-9/threads.scm b/module/ice-9/threads.scm
index 047a733..9f9e1bf 100644
--- a/module/ice-9/threads.scm
+++ b/module/ice-9/threads.scm
@@ -1,4 +1,5 @@
-;;;; Copyright (C) 1996, 1998, 2001, 2002, 2003, 2006, 2010, 2011 Free
Software Foundation, Inc.
+;;;; Copyright (C) 1996, 1998, 2001, 2002, 2003, 2006, 2010, 2011,
+;;;; 2012 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
@@ -33,6 +34,7 @@
(define-module (ice-9 threads)
#:use-module (ice-9 futures)
+ #:use-module (ice-9 match)
#:export (begin-thread
parallel
letpar
@@ -87,16 +89,19 @@
(with-mutex (make-mutex)
first rest ...))
-(define (par-mapper mapper)
- (lambda (proc . arglists)
- (mapper touch
- (apply map
- (lambda args
- (future (apply proc args)))
- arglists))))
-
-(define par-map (par-mapper map))
-(define par-for-each (par-mapper for-each))
+(define (par-mapper mapper cons)
+ (lambda (proc . lists)
+ (let loop ((lists lists))
+ (match lists
+ (((heads tails ...) ...)
+ (let ((tail (future (loop tails)))
+ (head (apply proc heads)))
+ (cons head (touch tail))))
+ (_
+ '())))))
+
+(define par-map (par-mapper map cons))
+(define par-for-each (par-mapper for-each (const *unspecified*)))
(define (n-par-map n proc . arglists)
(let* ((m (make-mutex))
diff --git a/module/language/tree-il/cse.scm b/module/language/tree-il/cse.scm
index b8e7229..d8c7e3f 100644
--- a/module/language/tree-il/cse.scm
+++ b/module/language/tree-il/cse.scm
@@ -330,10 +330,11 @@
(and (< n env-len)
(match (vlist-ref env n)
((#(exp* name sym db-len*) . h*)
- (and (unroll db m (- db-len db-len*))
- (if (and (= h h*) (tree-il=? exp* exp))
- (make-lexical-ref (tree-il-src exp) name sym)
- (lp (1+ n) (- db-len db-len*))))))))))))
+ (let ((niter (- (- db-len db-len*) m)))
+ (and (unroll db m niter)
+ (if (and (= h h*) (tree-il=? exp* exp))
+ (make-lexical-ref (tree-il-src exp) name sym)
+ (lp (1+ n) (- db-len db-len*)))))))))))))
(define (lookup-lexical sym env)
(let ((env-len (vlist-length env)))
diff --git a/test-suite/tests/cse.test b/test-suite/tests/cse.test
index 523635f..e0219e8 100644
--- a/test-suite/tests/cse.test
+++ b/test-suite/tests/cse.test
@@ -292,4 +292,21 @@
(begin (cons 1 2 3) 4)
(begin
(apply (primitive cons) (const 1) (const 2) (const 3))
- (const 4))))
+ (const 4)))
+
+ (pass-if "http://bugs.gnu.org/12883";
+ ;; In 2.0.6, compiling this code would trigger an out-of-bounds
+ ;; vlist access in CSE's traversal of its "database".
+ (glil-program?
+ (compile '(define (proc v)
+ (let ((failure (lambda () (bail-out 'match))))
+ (if (and (pair? v)
+ (null? (cdr v)))
+ (let ((w foo)
+ (x (cdr w)))
+ (if (and (pair? x) (null? w))
+ #t
+ (failure)))
+ (failure))))
+ #:from 'scheme
+ #:to 'glil))))
diff --git a/test-suite/tests/future.test b/test-suite/tests/future.test
index e82b4e3..b8bacb2 100644
--- a/test-suite/tests/future.test
+++ b/test-suite/tests/future.test
@@ -2,7 +2,7 @@
;;;;
;;;; Ludovic Courtès <address@hidden>
;;;;
-;;;; Copyright (C) 2010 Free Software Foundation, Inc.
+;;;; Copyright (C) 2010, 2012 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
@@ -22,7 +22,8 @@
#:use-module (test-suite lib)
#:use-module (ice-9 futures)
#:use-module (srfi srfi-1)
- #:use-module (srfi srfi-26))
+ #:use-module (srfi srfi-26)
+ #:use-module (system base compile))
(define specific-exception-key (gensym))
@@ -90,3 +91,18 @@
(pass-if-exception "exception"
specific-exception
(touch (future (throw specific-exception-key 'test "thrown!")))))
+
+(with-test-prefix "nested futures"
+
+ (pass-if-equal "simple" 2
+ (touch (future (1+ (touch (future (1+ (touch (future 0)))))))))
+
+ (pass-if-equal "loop" (map - (iota 1000))
+ ;; Compile to avoid stack overflows.
+ (compile '(let loop ((list (iota 1000)))
+ (if (null? list)
+ '()
+ (cons (- (car list))
+ (touch (future (loop (cdr list)))))))
+ #:to 'value
+ #:env (current-module))))
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.6-91-g2c7b7e0,
Ludovic Courtès <=