101 lines
3.9 KiB
Scheme
101 lines
3.9 KiB
Scheme
(define thread-proc (lambda (x) #t))
|
|
|
|
(define (new-thread name)
|
|
(let
|
|
((thread
|
|
(make-thread
|
|
(lambda ()
|
|
(letrec*
|
|
((runner
|
|
(lambda ()
|
|
(when (list? (thread-specific (current-thread)))
|
|
(for-each
|
|
(lambda (job)
|
|
(let ((lst (list-ref job 0))
|
|
(index (list-ref job 1))
|
|
(proc (list-ref job 2))
|
|
(result (list-ref job 3))
|
|
(getter (list-ref job 4))
|
|
(setter (list-ref job 5)))
|
|
(guard (condition
|
|
(else
|
|
(display "Error in thread: ")
|
|
(write (thread-name (current-thread)))
|
|
(display ", error: ")
|
|
(write condition)
|
|
(newline)
|
|
(list-set! threads
|
|
(string->number (thread-name (current-thread)))
|
|
(new-thread (thread-name (current-thread))))))
|
|
(setter result
|
|
index
|
|
(apply proc
|
|
(list (getter lst index)))))))
|
|
(thread-specific (current-thread)))
|
|
(thread-specific-set! (current-thread) #f))
|
|
(runner))))
|
|
(runner)))
|
|
name)))
|
|
(thread-specific-set! thread #f)
|
|
(thread-start! thread)
|
|
thread))
|
|
|
|
(define threads
|
|
(letrec*
|
|
((looper
|
|
(lambda (count result)
|
|
(if (>= count thread-count)
|
|
result
|
|
(looper (+ count 1)
|
|
(append result (list (new-thread (number->string count)))))))))
|
|
(looper 0 '())))
|
|
|
|
(define-syntax parallel-map
|
|
(syntax-rules ()
|
|
((_ env (l args body ...) lst)
|
|
(letrec*
|
|
((result (make-list (length lst) #f))
|
|
(lst-length (length lst))
|
|
(loop-length (- (length lst) 2))
|
|
(proc (eval `(lambda args body ...) (apply environment env)))
|
|
(job-queues (make-vector thread-count '()))
|
|
(index 0)
|
|
(waited? #f)
|
|
(waiter (lambda ()
|
|
(for-each
|
|
(lambda (thread)
|
|
(if (not (thread-specific thread))
|
|
(set! waited? #t)
|
|
(set! waited? #f)))
|
|
threads)
|
|
(if (not waited?) (waiter))))
|
|
(queu-builder
|
|
(lambda (index)
|
|
(when (< index lst-length)
|
|
(for-each
|
|
(lambda (thread)
|
|
(when (< index lst-length)
|
|
(let ((thread-index (string->number (thread-name thread))))
|
|
(vector-set! job-queues
|
|
thread-index
|
|
(append (vector-ref job-queues thread-index)
|
|
(list (list lst
|
|
index
|
|
proc
|
|
result
|
|
list-ref
|
|
list-set!)))))
|
|
(set! index (+ index 1))))
|
|
threads)
|
|
(queu-builder index)))))
|
|
(queu-builder 0)
|
|
(for-each
|
|
(lambda (thread)
|
|
(thread-specific-set!
|
|
thread
|
|
(vector-ref job-queues
|
|
(string->number (thread-name thread)))))
|
|
threads)
|
|
(waiter)
|
|
result))))
|