diff --git a/Makefile b/Makefile index 7155f5c..23236b3 100644 --- a/Makefile +++ b/Makefile @@ -39,7 +39,6 @@ package: retropikzel/${LIBRARY}/LICENSE retropikzel/${LIBRARY}/VERSION retropikz --authors=${AUTHOR} \ --doc=${DOCFILE} \ --description="${DESCRIPTION}" \ - --test=${TESTFILE} \ ${LIBRARY_FILE} ${PKG}: package diff --git a/retropikzel/parallel-srfi-18.scm b/retropikzel/parallel-srfi-18.scm index ff85d62..dbe5871 100644 --- a/retropikzel/parallel-srfi-18.scm +++ b/retropikzel/parallel-srfi-18.scm @@ -1,19 +1,100 @@ (define thread-proc (lambda (x) #t)) -(define (new-thread) - (make-thread - (lambda () - (thread-specific-set! - (current-thread) - (thread-proc (thread-specific (current-thread))))))) +(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 (make-list thread-count (new-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) - (let* ((lst-length (length lst)) - (thread-proc (eval `(lambda args body ...) - (apply environment 'env)))) - (map thread-proc 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)))) diff --git a/retropikzel/parallel.scm b/retropikzel/parallel.scm index 4040fbd..52233dc 100644 --- a/retropikzel/parallel.scm +++ b/retropikzel/parallel.scm @@ -1,6 +1,4 @@ (define-syntax parallel-map (syntax-rules () ((_ env (l args body ...) lst) - (let* ((lst-length (length lst)) - (proc (eval `(lambda args body ...) (apply environment 'env)))) - (map proc lst))))) + (map (eval '(lambda args body ...) (apply environment env)) lst)))) diff --git a/retropikzel/parallel.sld b/retropikzel/parallel.sld index 9b578e2..c0fe62d 100644 --- a/retropikzel/parallel.sld +++ b/retropikzel/parallel.sld @@ -3,14 +3,12 @@ (import (scheme base) (scheme write) (scheme eval) - (retropikzel hardware-info) - (retropikzel purer)) + (retropikzel hardware-info)) (include "parallel/shared.scm") (cond-expand ((library (srfi 18)) (import (srfi 18)) (include "parallel-srfi-18.scm")) - (else - (import (scheme base)) - (include "parallel.scm"))) + (else (include "parallel.scm")) + ) (export parallel-map)) diff --git a/retropikzel/parallel/README.md b/retropikzel/parallel/README.md index 00d7bdd..2602c4b 100644 --- a/retropikzel/parallel/README.md +++ b/retropikzel/parallel/README.md @@ -1 +1 @@ -WIP +Utilities to process things in parallel easily diff --git a/retropikzel/parallel/test.scm b/retropikzel/parallel/test.scm index 0dd2cc1..deebd3c 100644 --- a/retropikzel/parallel/test.scm +++ b/retropikzel/parallel/test.scm @@ -1,9 +1,23 @@ +(import (scheme base) + (scheme write) + (retropikzel tap) + (retropikzel debug) + (retropikzel parallel) + (srfi 19) + (srfi 64)) -(write (parallel-map - ((scheme base)) - (lambda (i) - (+ i 1)) - '(1 2 3 4 5 6 7 8 9 10))) +(test-runner-current (tap-runner)) + +(define lst '(1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16)) + +(write (parallel-map '((scheme base)) (lambda (i) (+ i 1)) lst)) +(newline) +(newline) +(write (parallel-map '((scheme base)) (lambda (i) (+ i 1)) lst)) +(newline) +(newline) +(write (parallel-map '((scheme base)) (lambda (i) (+ i 1)) lst)) +(newline) (newline)