summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--doc/ref/api-scheduling.texi7
-rw-r--r--module/ice-9/futures.scm23
-rw-r--r--test-suite/tests/future.test18
-rw-r--r--test-suite/tests/threads.test9
4 files changed, 37 insertions, 20 deletions
diff --git a/doc/ref/api-scheduling.texi b/doc/ref/api-scheduling.texi
index e040904cf..b23082192 100644
--- a/doc/ref/api-scheduling.texi
+++ b/doc/ref/api-scheduling.texi
@@ -1037,6 +1037,13 @@ future has completed. This suspend/resume is achieved by capturing the
calling future's continuation, and later reinstating it (@pxref{Prompts,
delimited continuations}).
+Note that @code{par-map} above is not tail-recursive. This could lead
+to stack overflows when @var{lst} is large compared to
+@code{(current-processor-count)}. To address that, @code{touch} uses
+the suspend mechanism described above to limit the number of nested
+futures executing on the same stack. Thus, the above code should never
+run into stack overflows.
+
@deffn {Scheme Syntax} future exp
Return a future for expression @var{exp}. This is equivalent to:
diff --git a/module/ice-9/futures.scm b/module/ice-9/futures.scm
index 6ff104d73..35a36ca59 100644
--- a/module/ice-9/futures.scm
+++ b/module/ice-9/futures.scm
@@ -1,6 +1,6 @@
;;; -*- mode: scheme; coding: utf-8; -*-
;;;
-;;; Copyright (C) 2010, 2011, 2012 Free Software Foundation, Inc.
+;;; Copyright (C) 2010, 2011, 2012, 2013 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
@@ -88,8 +88,14 @@ touched."
;; 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))
+;; Nesting level of futures. Incremented each time a future is touched
+;; from within a future.
+(define %nesting-level (make-parameter 0))
+
+;; Maximum nesting level. The point is to avoid stack overflows when
+;; nested futures are executed on the same stack. See
+;; <http://bugs.gnu.org/13188>.
+(define %max-nesting-level 200)
(define-syntax-rule (with-mutex m e0 e1 ...)
;; Copied from (ice-9 threads) to avoid circular dependency.
@@ -155,7 +161,8 @@ adding it to the waiter queue."
(thunk (lambda ()
(call-with-prompt %future-prompt
(lambda ()
- (parameterize ((%within-future? #t))
+ (parameterize ((%nesting-level
+ (1+ (%nesting-level))))
((future-thunk future))))
suspend))))
(set-future-result! future
@@ -254,14 +261,16 @@ adding it to the waiter queue."
(unlock-mutex (future-mutex future)))
((started)
(unlock-mutex (future-mutex future))
- (if (%within-future?)
+ (if (> (%nesting-level) 0)
(abort-to-prompt %future-prompt future)
(begin
(work)
(loop))))
- (else
+ (else ; queued
(unlock-mutex (future-mutex future))
- (work)
+ (if (> (%nesting-level) %max-nesting-level)
+ (abort-to-prompt %future-prompt future)
+ (work))
(loop))))
((future-result future)))
diff --git a/test-suite/tests/future.test b/test-suite/tests/future.test
index b8bacb2f0..a398aff37 100644
--- a/test-suite/tests/future.test
+++ b/test-suite/tests/future.test
@@ -2,7 +2,7 @@
;;;;
;;;; Ludovic Courtès <ludo@gnu.org>
;;;;
-;;;; Copyright (C) 2010, 2012 Free Software Foundation, Inc.
+;;;; Copyright (C) 2010, 2012, 2013 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,8 +22,7 @@
#:use-module (test-suite lib)
#:use-module (ice-9 futures)
#:use-module (srfi srfi-1)
- #:use-module (srfi srfi-26)
- #:use-module (system base compile))
+ #:use-module (srfi srfi-26))
(define specific-exception-key (gensym))
@@ -98,11 +97,8 @@
(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))))
+ (let loop ((list (iota 1000)))
+ (if (null? list)
+ '()
+ (cons (- (car list))
+ (touch (future (loop (cdr list)))))))))
diff --git a/test-suite/tests/threads.test b/test-suite/tests/threads.test
index be722fc75..817812051 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, 2010, 2011, 2012 Free Software Foundation, Inc.
+;;;; Copyright 2003, 2006, 2007, 2009, 2010, 2011, 2012, 2013 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
@@ -86,7 +86,12 @@
(equal? (par-map fibo (iota 13))
(map fibo (iota 13))))
#:to 'value
- #:env (current-module))))
+ #:env (current-module)))
+
+ (pass-if-equal "long list" (map 1+ (iota 10000))
+ ;; In Guile 2.0.7, this would trigger a stack overflow.
+ ;; See <http://bugs.gnu.org/13188>.
+ (par-map 1+ (iota 10000))))
;;
;; par-for-each