1 |
;;;; Copyright (C) 1996, 1998, 2001, 2002 Free Software Foundation, Inc. |
;;;; Copyright (C) 1996, 1998, 2001, 2002, 2003 Free Software Foundation, Inc. |
2 |
;;;; |
;;;; |
3 |
;;;; This program is free software; you can redistribute it and/or modify |
;;;; This program is free software; you can redistribute it and/or modify |
4 |
;;;; it under the terms of the GNU General Public License as published by |
;;;; it under the terms of the GNU General Public License as published by |
73 |
|
|
74 |
|
|
75 |
(define ((par-mapper mapper) proc . arglists) |
(define ((par-mapper mapper) proc . arglists) |
76 |
(mapper join-thread |
(mapper future-ref |
77 |
(apply map |
(apply map |
78 |
(lambda args |
(lambda args |
79 |
(call-with-new-thread (lambda () |
(future (apply proc args))) |
|
(apply proc args)) |
|
|
%thread-handler)) |
|
80 |
arglists))) |
arglists))) |
81 |
|
|
82 |
(define par-map (par-mapper map)) |
(define par-map (par-mapper map)) |
84 |
|
|
85 |
(define (n-par-map n proc . arglists) |
(define (n-par-map n proc . arglists) |
86 |
(let* ((m (make-mutex)) |
(let* ((m (make-mutex)) |
87 |
(threads '()) |
(futures '()) |
88 |
(results (make-list (length (car arglists)))) |
(results (make-list (length (car arglists)))) |
89 |
(result results)) |
(result results)) |
90 |
(do ((i 0 (+ 1 i))) |
(do ((i 0 (+ 1 i))) |
91 |
((= i n) |
((= i n) |
92 |
(for-each join-thread threads) |
(for-each future-ref futures) |
93 |
results) |
results) |
94 |
(set! threads |
(set! futures |
95 |
(cons (call-with-new-thread |
(cons (future |
96 |
(lambda () |
(let loop () |
97 |
(let loop () |
(lock-mutex m) |
98 |
(lock-mutex m) |
(if (null? result) |
99 |
(if (null? result) |
(unlock-mutex m) |
100 |
|
(let ((args (map car arglists)) |
101 |
|
(my-result result)) |
102 |
|
(set! arglists (map cdr arglists)) |
103 |
|
(set! result (cdr result)) |
104 |
(unlock-mutex m) |
(unlock-mutex m) |
105 |
(let ((args (map car arglists)) |
(set-car! my-result (apply proc args)) |
106 |
(my-result result)) |
(loop))))) |
107 |
(set! arglists (map cdr arglists)) |
futures))))) |
|
(set! result (cdr result)) |
|
|
(unlock-mutex m) |
|
|
(set-car! my-result (apply proc args)) |
|
|
(loop))))) |
|
|
%thread-handler) |
|
|
threads))))) |
|
108 |
|
|
109 |
(define (n-par-for-each n proc . arglists) |
(define (n-par-for-each n proc . arglists) |
110 |
(let ((m (make-mutex)) |
(let ((m (make-mutex)) |
111 |
(threads '())) |
(futures '())) |
112 |
(do ((i 0 (+ 1 i))) |
(do ((i 0 (+ 1 i))) |
113 |
((= i n) |
((= i n) |
114 |
(for-each join-thread threads)) |
(for-each future-ref futures)) |
115 |
(set! threads |
(set! futures |
116 |
(cons (call-with-new-thread |
(cons (future |
117 |
(lambda () |
(let loop () |
118 |
(let loop () |
(lock-mutex m) |
119 |
(lock-mutex m) |
(if (null? (car arglists)) |
120 |
(if (null? (car arglists)) |
(unlock-mutex m) |
121 |
|
(let ((args (map car arglists))) |
122 |
|
(set! arglists (map cdr arglists)) |
123 |
(unlock-mutex m) |
(unlock-mutex m) |
124 |
(let ((args (map car arglists))) |
(apply proc args) |
125 |
(set! arglists (map cdr arglists)) |
(loop))))) |
126 |
(unlock-mutex m) |
futures))))) |
|
(apply proc args) |
|
|
(loop))))) |
|
|
%thread-handler) |
|
|
threads))))) |
|
127 |
|
|
128 |
(define (thread-handler tag . args) |
(define (thread-handler tag . args) |
129 |
(fluid-set! the-last-stack #f) |
(fluid-set! the-last-stack #f) |