diff options
-rw-r--r-- | doc/ref/api-scheduling.texi | 7 | ||||
-rw-r--r-- | module/ice-9/futures.scm | 23 | ||||
-rw-r--r-- | test-suite/tests/future.test | 18 | ||||
-rw-r--r-- | test-suite/tests/threads.test | 9 |
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 |