Add "transient" intmap interface

[bpt/guile.git] / module / ice-9 / threads.scm

diff --git a/module/ice-9/threads.scm b/module/ice-9/threads.scm
index bd0f7b7..9f9e1bf 100644 (file)
--- a/module/ice-9/threads.scm
+++ b/module/ice-9/threads.scm
@@ -1,9 +1,10 @@
-;;;;   Copyright (C) 1996, 1998, 2001, 2002, 2003, 2006 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
 ;;;; License as published by the Free Software Foundation; either
-;;;; version 2.1 of the License, or (at your option) any later version.
+;;;; 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
@@ -32,31 +33,75 @@
 ;;; Code:
 
 (define-module (ice-9 threads)
-  :export (par-map
-          par-for-each
-          n-par-map
-          n-par-for-each
-          n-for-each-par-map
-          %thread-handler)
-  :export-syntax (begin-thread
-                 parallel
-                 letpar
-                 make-thread
-                 with-mutex
-                 monitor))
+  #:use-module (ice-9 futures)
+  #:use-module (ice-9 match)
+  #: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))
 
 \f
 
-(define (par-mapper mapper)
-  (lambda (proc . arglists)
-    (mapper join-thread
-            (apply map
-                   (lambda args
-                     (begin-thread (apply proc args)))
-                   arglists))))
-
-(define par-map (par-mapper map))
-(define par-for-each (par-mapper for-each))
+;;; Macros first, so that the procedures expand correctly.
+
+(define-syntax-rule (begin-thread e0 e1 ...)
+  (call-with-new-thread
+   (lambda () e0 e1 ...)
+   %thread-handler))
+
+(define-syntax parallel
+  (lambda (x)
+    (syntax-case x ()
+      ((_ e0 ...)
+       (with-syntax (((tmp0 ...) (generate-temporaries (syntax (e0 ...)))))
+         #'(let ((tmp0 (future e0))
+                 ...)
+             (values (touch tmp0) ...)))))))
+
+(define-syntax-rule (letpar ((v e) ...) b0 b1 ...)
+  (call-with-values
+      (lambda () (parallel e ...))
+    (lambda (v ...)
+      b0 b1 ...)))
+
+(define-syntax-rule (make-thread proc arg ...)
+  (call-with-new-thread
+   (lambda () (proc arg ...))
+   %thread-handler))
+
+(define-syntax-rule (with-mutex m e0 e1 ...)
+  (let ((x m))
+    (dynamic-wind
+      (lambda () (lock-mutex x))
+      (lambda () (begin e0 e1 ...))
+      (lambda () (unlock-mutex x)))))
+
+(define-syntax-rule (monitor first rest ...)
+  (with-mutex (make-mutex)
+    first rest ...))
+
+(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))
@@ -146,7 +191,6 @@ of applying P-PROC on ARGLISTS."
                  threads)))))
 
 (define (thread-handler tag . args)
-  (fluid-set! the-last-stack #f)
   (let ((n (length args))
        (p (current-error-port)))
     (display "In thread:" p)
@@ -171,52 +215,4 @@ of applying P-PROC on ARGLISTS."
 ;;; Set system thread handler
 (define %thread-handler thread-handler)
 
-; --- MACROS -------------------------------------------------------
-
-(define-macro (begin-thread . forms)
-  (if (null? forms)
-      '(begin)
-      `(call-with-new-thread
-       (lambda ()
-         ,@forms)
-       %thread-handler)))
-
-(define-macro (parallel . forms)
-  (cond ((null? forms) '(values))
-       ((null? (cdr forms)) (car forms))
-       (else
-        (let ((vars (map (lambda (f)
-                           (make-symbol "f"))
-                         forms)))
-          `((lambda ,vars
-              (values ,@(map (lambda (v) `(join-thread ,v)) vars)))
-            ,@(map (lambda (form) `(begin-thread ,form)) forms))))))
-
-(define-macro (letpar bindings . body)
-  (cond ((or (null? bindings) (null? (cdr bindings)))
-        `(let ,bindings ,@body))
-       (else
-        (let ((vars (map car bindings)))
-          `((lambda ,vars
-              ((lambda ,vars ,@body)
-               ,@(map (lambda (v) `(join-thread ,v)) vars)))
-            ,@(map (lambda (b) `(begin-thread ,(cadr b))) bindings))))))
-
-(define-macro (make-thread proc . args)
-  `(call-with-new-thread
-    (lambda ()
-      (,proc ,@args))
-    %thread-handler))
-
-(define-macro (with-mutex m . body)
-  `(dynamic-wind
-       (lambda () (lock-mutex ,m))
-       (lambda () (begin ,@body))
-       (lambda () (unlock-mutex ,m))))
-
-(define-macro (monitor first . rest)
-  `(with-mutex ,(make-mutex)
-     (begin
-       ,first ,@rest)))
-
 ;;; threads.scm ends here