source: project/mpi/trunk/tests/run.scm @ 7323

Last change on this file since 7323 was 7323, checked in by Ivan Raikov, 12 years ago

Print the host name when starting.

File size: 26.1 KB
Line 
1;;
2;;
3;; Chicken MPI regression test
4;;
5;; Based on the Caml/MPI interface by Xavier Leroy.
6;;
7;; Copyright 2007 Ivan Raikov and the Okinawa Institute of Science and Technology
8;;
9;; This program is free software: you can redistribute it and/or
10;; modify it under the terms of the GNU General Public License as
11;; published by the Free Software Foundation, either version 3 of the
12;; License, or (at your option) any later version.
13;;
14;; This program is distributed in the hope that it will be useful, but
15;; WITHOUT ANY WARRANTY; without even the implied warranty of
16;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
17;; General Public License for more details.
18;;
19;; A full copy of the GPL license can be found at
20;; <http://www.gnu.org/licenses/>.
21;;
22
23(require-extension posix)
24(require-extension srfi-4)
25(require-extension srfi-13)
26(require-extension srfi-14)
27(require-extension mpi)
28(require-extension testbase)
29(require-extension testbase-output-compact)
30
31(define-expect-unary pair?)
32
33(define (land . args)
34  (if (null? args) #t
35      (and (car args) (apply land (cdr args)))))
36
37(define (lor . args)
38  (if (null? args) #f
39      (or (car args) (apply lor (cdr args)))))
40
41(define (eval-op op args)
42  (apply
43   (cond ((= op MPI:i_max)   max)
44         ((= op MPI:i_min)   min)
45         ((= op MPI:i_sum)   +)
46         ((= op MPI:i_prod)  *)
47         ((= op MPI:i_land)  land)
48         ((= op MPI:i_lor)   lor)
49         ((= op MPI:i_xor)   fxxor)
50         ((= op MPI:f_max)   max)
51         ((= op MPI:f_min)   min)
52         ((= op MPI:f_sum)   +)
53         ((= op MPI:f_prod)  *)
54         (else (error 'eval-op "unknown op " op)))
55   args))
56
57
58(define (blob-range x i j) 
59  (string->blob (string-copy (blob->string x) i j)))
60
61(define (make-srfi4-vector-map makev vlen vset! vref)
62  (lambda (v f)
63    (let loop ((v v) (newv (makev (vlen v))) (n (- (vlen v) 1)))
64      (if (>= n 0)
65          (let ((x (f (vref v n))))
66            (vset! newv n x)
67            (loop v newv (- n 1)))
68          (begin
69            newv)))))
70
71(define (make-srfi4-vector-range makev vlen vset! vref)
72  (lambda (v i j)
73    (and (and (positive? j) (or (zero? i) (positive? i)) (< i j) (< (- j i) (vlen v)))
74         (let loop ((v v) (newv (makev (- j i))) (n 0) (i i))
75           (if (< i j)
76               (let ((x (vref v i)))
77                 (vset! newv n x)
78                 (loop v newv (+ n 1) (+ i 1)))
79               newv)))))
80         
81(define-macro (define-srfi4-map type)
82  (let ((makev   (string->symbol (string-append "make-" (symbol->string type) "vector")))
83        (vlen    (string->symbol (string-append (symbol->string type) "vector-length")))
84        (vref    (string->symbol (string-append (symbol->string type) "vector-ref")))
85        (vset!   (string->symbol (string-append (symbol->string type) "vector-set!")))
86        (name    (string->symbol (string-append (symbol->string type) "vector-map"))))
87  `(define ,name (make-srfi4-vector-map ,makev ,vlen ,vset! ,vref))))
88
89(define-macro (define-srfi4-range type)
90  (let ((makev   (string->symbol (string-append "make-" (symbol->string type) "vector")))
91        (vlen    (string->symbol (string-append (symbol->string type) "vector-length")))
92        (vref    (string->symbol (string-append (symbol->string type) "vector-ref")))
93        (vset!   (string->symbol (string-append (symbol->string type) "vector-set!")))
94        (name    (string->symbol (string-append (symbol->string type) "vector-range"))))
95  `(define ,name (make-srfi4-vector-range ,makev ,vlen ,vset! ,vref))))
96
97(define-srfi4-map u8)
98(define-srfi4-map s8)
99(define-srfi4-map u16)
100(define-srfi4-map s16)
101(define-srfi4-map u32)
102(define-srfi4-map s32)
103(define-srfi4-map f32)
104(define-srfi4-map f64)
105
106
107(define-srfi4-range u8)
108(define-srfi4-range s8)
109(define-srfi4-range u16)
110(define-srfi4-range s16)
111(define-srfi4-range u32)
112(define-srfi4-range s32)
113(define-srfi4-range f32)
114(define-srfi4-range f64)
115
116(MPI:init)
117
118(print "Host " (get-host-name))
119
120(define-test mpi-test "MPI test"
121  (initial
122   (define comm-world  (MPI:get-comm-world))
123   (define size        (MPI:comm-size comm-world))
124   (define myrank      (MPI:comm-rank comm-world))
125   (define vsize       3)
126   (define intdata     (list-tabulate size (lambda (i) (* 10 i))))
127   (define flodata     (list-tabulate size (lambda (i) (* 0.1 i))))
128   (define vsdata      (list-tabulate size (lambda (i) 
129                                             (list->string (list-tabulate vsize 
130                                                                          (lambda (j) (integer->char (+ i 97))))))))
131   (define vvsdata     (list-tabulate size (lambda (i) 
132                                             (list->string (list-tabulate (+ i 1) 
133                                                                          (lambda (j) (integer->char (+ i 97))))))))
134   (define vintdata    (list-tabulate size (lambda (i) (list-tabulate vsize (lambda (j) (+ (* 10 i) j))))))
135   (define vflodata    (list-tabulate size (lambda (i) (list-tabulate vsize (lambda (j) (+ i (* 0.1 j)))))))
136   (define vvintdata   (list-tabulate size (lambda (i) (list-tabulate (+ i 1) (lambda (j) (+ (* 10 i) j))))))
137   (define vvflodata   (list-tabulate size (lambda (i) (list-tabulate (+ i 1) (lambda (j) (+ i (* 0.1 j)))))))
138   )
139
140  (test/collect 'send-and-receive
141    (if (zero? myrank)
142      (let ((data  "aa"))
143        (print myrank ": sending " data)
144        (MPI:send (string->blob data) 1 0 comm-world)
145        (let ((n (blob->string (MPI:receive MPI:any-source MPI:any-tag comm-world))))
146          (print myrank ": received " n)
147          (collect-test
148           (expect-success (and (= (length (string->list n)) (+ 1 size))
149                                (every (lambda (x) (char=? x #\a)) (string->list n)))))
150          ))
151      (let* ((n   (blob->string (MPI:receive MPI:any-source MPI:any-tag comm-world)))
152             (n1  (string-append n "a")))
153        (print myrank ": received " n ", resending " n1)
154        (MPI:send (string->blob n1) (modulo (+ myrank 1) size) 0 comm-world)
155        (collect-test
156           (expect-success (and (= (length (string->list n)) (+ 1 myrank))
157                                (every (lambda (x) (char=? x #\a)) (string->list n)))))
158        )))
159
160  ;; Barrier
161  (test-eval 'barrier (MPI:barrier comm-world))
162 
163  (test/collect 'send-and-receive-with-tags
164   (if (zero? myrank)
165       (let ((data1  "aa")
166             (data2  "bb"))
167         (print myrank ": sending (tag 0) " data1)
168         (MPI:send (string->blob data1) 1 0 comm-world)
169         (print myrank ": sending (tag 1) " data2)
170         (MPI:send (string->blob data2) 1 1 comm-world)
171         (let-values (((n src tag)  (MPI:receive-with-status MPI:any-source MPI:any-tag comm-world)))
172             (print myrank ": received " (blob->string n) " (tag " tag ")" " from " src)
173             (if (zero? tag) 
174                 (expect-success (and (= (length (string->list n)) (+ 1 size))
175                                      (every (lambda (x) (char=? x #\a)) (string->list n))))
176                 (expect-success (and (= (length (string->list n)) (+ 1 size))
177                                      (every (lambda (x) (char=? x #\b)) (string->list n))))))
178         (let-values (((n src tag)  (MPI:receive-with-status MPI:any-source MPI:any-tag comm-world)))
179             (print myrank ": received " (blob->string n) " (tag " tag ")" " from " src)
180             (if (zero? tag) 
181                 (expect-success (and (= (length (string->list n)) (+ 1 size))
182                                      (every (lambda (x) (char=? x #\a)) (string->list n))))
183                 (expect-success (and (= (length (string->list n)) (+ 1 size))
184                                      (every (lambda (x) (char=? x #\b)) (string->list n)))))))
185       (let-values (((n1 src tag1)  (MPI:receive-with-status MPI:any-source 0 comm-world)))
186           (let* ((n1   (blob->string n1))
187                  (nn1  (if (zero? tag1) (string-append n1 "a") (string-append n1 "b"))))
188             (print myrank ": received " n1 " (tag " tag1 ")" " from " src
189                    ", resending " nn1)
190             (if (zero? tag1)
191                 (collect-test
192                  (expect-success (and (= (length (string->list n1)) (+ 1 myrank))
193                                       (every (lambda (x) (char=? x #\a)) (string->list n1)))))
194                 (collect-test
195                  (expect-success (and (= (length (string->list n1)) (+ 1 myrank))
196                                       (every (lambda (x) (char=? x #\b)) (string->list n1))))))
197             (let-values (((n2 src tag2)  (MPI:receive-with-status MPI:any-source MPI:any-tag comm-world)))
198                         (let* ((n2   (blob->string n2))
199                                (nn2  (if (zero? tag2) (string-append n2 "a") (string-append n2 "b"))))
200                           (if (zero? tag2)
201                               (collect-test
202                                (expect-success (and (= (length (string->list n2)) (+ 1 myrank))
203                                                     (every (lambda (x) (char=? x #\a)) (string->list n2)))))
204                               (collect-test
205                                (expect-success (and (= (length (string->list n2)) (+ 1 myrank))
206                                                     (every (lambda (x) (char=? x #\b)) (string->list n2))))))
207                           (print myrank ": received " n2 " (tag " tag2 ")" " from " src
208                                  ", resending " nn2)
209                           (MPI:send (string->blob nn1) (modulo (+ 1 myrank) size) tag1 comm-world)
210                           (MPI:send (string->blob nn2) (modulo (+ 1 myrank) size) tag2 comm-world)))))))
211
212   ;; Barrier
213   (test-eval (MPI:barrier comm-world))
214
215   (test/collect 'send-and-receive-base-types
216    (let ((test-send-recv
217         (lambda (sendfun recvfun transf data)
218           (if (zero? myrank)
219               (begin
220                 (print myrank ": test-send-recv: data = " data) 
221                 (print myrank ": test-send-recv: size = " size) 
222                 (let loop ((lst data) (i 1))
223                   (if (and (not (null? lst)) (< i size))
224                       (begin
225                         (print myrank ": sending " (car lst) " to " i)
226                         (sendfun (car lst) i 0 comm-world)
227                         (loop (cdr lst) (+ 1 i)))))
228                 (let loop ((i size))
229                   (if (positive? (- i 1))
230                       (let ((x (recvfun (- i 1) 0 comm-world)))
231                         (print myrank ": received " x)
232                         (collect-test 
233                          (expect-success (any (lambda (y) (equal? x y)) (map transf data))))
234                         (loop (- i 1))))))
235               (let ((x (recvfun 0 0 comm-world)))
236                 (print myrank ": received " x)
237                 (collect-test 
238                  (expect-success (member x data)))
239                 (let ((y (transf x)))
240                   (sendfun y 0 0 comm-world))))
241           (MPI:barrier comm-world))))
242     (test-send-recv MPI:send-fixnum MPI:receive-fixnum (lambda (x) (+ 1 x)) intdata)
243     (test-send-recv MPI:send-int MPI:receive-int (lambda (x) (+ 1 x)) intdata)
244     (test-send-recv MPI:send-flonum MPI:receive-flonum (lambda (x) (* 2 x)) flodata)
245    (let ((srfi4-test-send-recv
246           (lambda (len vsend vreceive vmap list->vector)
247             (lambda (data)
248               (test-send-recv vsend
249                               (lambda (src tag comm) (vreceive len src tag comm))
250                               (lambda (v) (vmap v (lambda (x) (+ 1 x))))
251                               (map list->vector data))))))
252      ((srfi4-test-send-recv vsize MPI:send-u8vector MPI:receive-u8vector u8vector-map list->u8vector)
253       vintdata)
254       ((srfi4-test-send-recv vsize MPI:send-s8vector MPI:receive-s8vector s8vector-map list->s8vector)
255        vintdata)
256       ((srfi4-test-send-recv vsize MPI:send-u16vector MPI:receive-u16vector u16vector-map list->u16vector)
257        vintdata)
258       ((srfi4-test-send-recv vsize MPI:send-s16vector MPI:receive-s16vector s16vector-map list->s16vector)
259        vintdata)
260       ((srfi4-test-send-recv vsize MPI:send-u32vector MPI:receive-u32vector u32vector-map list->u32vector)
261        vintdata)
262       ((srfi4-test-send-recv vsize MPI:send-s32vector MPI:receive-s32vector s32vector-map list->s32vector)
263        vintdata)
264       ((srfi4-test-send-recv vsize MPI:send-f32vector MPI:receive-f32vector f32vector-map list->f32vector)
265        vflodata)
266       ((srfi4-test-send-recv vsize MPI:send-f64vector MPI:receive-f64vector f64vector-map list->f64vector)
267        vflodata)
268      )))
269
270    (test-eval 'barrier
271      (begin
272        (if (positive? myrank)
273            (sleep myrank))
274        (print myrank ": hitting barrier")
275        (MPI:barrier comm-world)
276        (if (zero? myrank)
277            (print "jumped barrier"))))
278
279    ;;  Broadcast
280    (test/collect 'broadcast 
281      (let* ((test-broadcast
282              (lambda (bcast data)
283                (if (zero? myrank)
284                    (print myrank ": broadcasting " data))
285                (let ((res (bcast data 0 comm-world)))
286                  (print myrank ": received " (if (blob? res) (blob->string res) res))
287                  (collect-test
288                   (expect-success (equal? res data)))
289                  (MPI:barrier comm-world)))))
290        (test-broadcast MPI:broadcast-bytevector (string->blob "Hello!"))
291        (test-broadcast MPI:broadcast-int 123456)
292        (test-broadcast MPI:broadcast-flonum 3.141592654)
293        (let ((intdata  (list 12 45 78))
294              (flodata  (list 3.14 2.718 0.578))
295              (srfi4-test-broadcast
296               (lambda (bcast list->vector data)
297                 (test-broadcast bcast (list->vector data)))))
298          (srfi4-test-broadcast MPI:broadcast-s8vector  list->s8vector  intdata)
299          (srfi4-test-broadcast MPI:broadcast-u8vector  list->u8vector  intdata)
300          (srfi4-test-broadcast MPI:broadcast-s16vector list->s16vector intdata)
301          (srfi4-test-broadcast MPI:broadcast-u16vector list->u16vector intdata)
302          (srfi4-test-broadcast MPI:broadcast-s32vector list->s32vector intdata)
303          (srfi4-test-broadcast MPI:broadcast-u32vector list->u32vector intdata)
304          (srfi4-test-broadcast MPI:broadcast-f32vector list->f32vector flodata)
305          (srfi4-test-broadcast MPI:broadcast-f64vector list->f64vector flodata))))
306
307  ;; Scatter
308  (test/collect 'scatter
309   (let* ((test-scatter
310           (lambda (scatter vrange data)
311             (if (zero? myrank)
312                 (print myrank ": scatter " (if (blob? data) (blob->string data) data)))
313             (let ((res (scatter data 3 0 comm-world)))
314               (print myrank ": received (scatter) " (if (blob? res) (blob->string res) res))
315               (collect-test
316                (expect-success
317                 (equal? res (vrange data (* myrank vsize) (+ vsize (* myrank vsize)))))))
318             (MPI:barrier comm-world))))
319     (test-scatter MPI:scatter-bytevector blob-range (string->blob (string-concatenate vsdata)))
320     (let ((srfi4-test-scatter
321            (lambda (scatter vrange list->vector data)
322              (test-scatter scatter vrange (list->vector (concatenate data))))))
323        (srfi4-test-scatter MPI:scatter-s8vector  s8vector-range  list->s8vector  vintdata)
324        (srfi4-test-scatter MPI:scatter-u8vector  u8vector-range  list->u8vector  vintdata)
325        (srfi4-test-scatter MPI:scatter-s16vector s16vector-range list->s16vector vintdata)
326        (srfi4-test-scatter MPI:scatter-u16vector u16vector-range list->u16vector vintdata)
327        (srfi4-test-scatter MPI:scatter-s32vector s32vector-range list->s32vector vintdata)
328        (srfi4-test-scatter MPI:scatter-u32vector u32vector-range list->u32vector vintdata)
329        (srfi4-test-scatter MPI:scatter-f32vector f32vector-range list->f32vector vflodata)
330        (srfi4-test-scatter MPI:scatter-f64vector f64vector-range list->f64vector vflodata))))
331     
332 ;;  Scatterv
333  (test/collect 'scatterv
334   (let* ((test-scatterv
335           (lambda (scatterv data)
336             (if (zero? myrank)
337                 (print myrank ": scatterv " data))
338             (let ((res (scatterv data 0 comm-world)))
339               (print myrank ": received (scatterv) " res)
340               (collect-test
341                (expect-success
342                 (equal? res (list-ref data myrank)))))
343             (MPI:barrier comm-world))))
344     (test-scatterv MPI:scatterv-bytevector (map string->blob vvsdata))
345     (let ((srfi4-test-scatterv
346            (lambda (scatterv list->vector data)
347              (test-scatterv scatterv (map list->vector data)))))
348       (srfi4-test-scatterv MPI:scatterv-s8vector   list->s8vector  vvintdata)
349       (srfi4-test-scatterv MPI:scatterv-u8vector   list->u8vector  vvintdata)
350       (srfi4-test-scatterv MPI:scatterv-s16vector  list->s16vector vvintdata)
351       (srfi4-test-scatterv MPI:scatterv-u16vector  list->u16vector vvintdata)
352       (srfi4-test-scatterv MPI:scatterv-s32vector  list->s32vector vvintdata)
353       (srfi4-test-scatterv MPI:scatterv-u32vector  list->u32vector vvintdata)
354       (srfi4-test-scatterv MPI:scatterv-f32vector  list->f32vector vvflodata)
355       (srfi4-test-scatterv MPI:scatterv-f64vector  list->f64vector vvflodata))))
356
357  ;; Gather
358  (test/collect 'gather
359   (let* ((test-gather
360           (lambda (gather data total)
361             (print myrank ": gather " (if (blob? data) (blob->string data) data))
362             (let ((res (gather data 3 0 comm-world)))
363               (if (zero? myrank)
364                   (begin
365                     (print myrank ": received (gather) " (if (blob? res) (blob->string res) res))
366                     (collect-test (expect-success (equal? res total)))))
367               (MPI:barrier comm-world)))))
368     (test-gather MPI:gather-bytevector (string->blob (list-ref vsdata myrank)) 
369                  (string->blob (string-concatenate vsdata)))
370     (test-gather MPI:gather-s8vector   (list->s8vector (list-ref vintdata myrank))
371                  (list->s8vector (concatenate vintdata)))
372     (test-gather MPI:gather-u8vector   (list->u8vector (list-ref vintdata myrank))
373                  (list->u8vector (concatenate vintdata)))
374     (test-gather MPI:gather-s16vector  (list->s16vector (list-ref vintdata myrank))
375                  (list->s16vector (concatenate vintdata)))
376     (test-gather MPI:gather-u16vector  (list->u16vector (list-ref vintdata myrank))
377                  (list->u16vector (concatenate vintdata)))
378     (test-gather MPI:gather-s32vector  (list->s32vector (list-ref vintdata myrank))
379                  (list->s32vector (concatenate vintdata)))
380     (test-gather MPI:gather-u32vector  (list->u32vector (list-ref vintdata myrank))
381                  (list->u32vector (concatenate vintdata)))
382     (test-gather MPI:gather-f32vector  (list->f32vector (list-ref vflodata myrank))
383                  (list->f32vector (concatenate vflodata)))
384     (test-gather MPI:gather-f64vector  (list->f64vector (list-ref vflodata myrank))
385                  (list->f64vector (concatenate vflodata)))))
386
387
388  ;; Gatherv
389  (test/collect 'gatherv
390   (let* ((test-gatherv
391           (lambda (gatherv data total)
392             (print myrank ": gatherv " (if (blob? data) (blob->string data) data))
393             (let ((res (gatherv data 0 comm-world)))
394               (if (zero? myrank)
395                   (begin
396                     (print myrank ": received (gatherv) " 
397                            (map (lambda (x) (if (blob? x) (blob->string x) x)) res))
398                     (collect-test (expect-success (equal? res total)))))
399               (MPI:barrier comm-world)))))
400     (test-gatherv MPI:gatherv-bytevector (string->blob (list-ref vvsdata myrank))
401                   (map string->blob vvsdata))
402     (test-gatherv MPI:gatherv-s8vector   (list->s8vector (list-ref vvintdata myrank))
403                   (map list->s8vector vvintdata))
404     (test-gatherv MPI:gatherv-u8vector   (list->u8vector (list-ref vvintdata myrank))
405                   (map list->u8vector vvintdata))
406     (test-gatherv MPI:gatherv-s16vector  (list->s16vector (list-ref vvintdata myrank))
407                   (map list->s16vector vvintdata))
408     (test-gatherv MPI:gatherv-u16vector  (list->u16vector (list-ref vvintdata myrank))
409                   (map list->u16vector vvintdata))
410     (test-gatherv MPI:gatherv-s32vector  (list->s32vector (list-ref vvintdata myrank))
411                   (map list->s32vector vvintdata))
412     (test-gatherv MPI:gatherv-u32vector  (list->u32vector (list-ref vvintdata myrank))
413                   (map list->u32vector vvintdata))
414     (test-gatherv MPI:gatherv-f32vector  (list->f32vector (list-ref vvflodata myrank))
415                   (map list->f32vector vvflodata))
416     (test-gatherv MPI:gatherv-f64vector  (list->f64vector (list-ref vvflodata myrank))
417                   (map list->f64vector vvflodata))))
418
419
420  ;; Gather to all
421  (test/collect 'allgather
422   (let* ((test-allgather 
423           (lambda (allgather data total)
424             (print myrank ": allgather " data)
425             (let ((res (allgather data 0 comm-world)))
426               (print myrank ": received (allgather) " 
427                      (map (lambda (x) (if (blob? x) (blob->string x) x)) res))
428               (collect-test (expect-success (equal? res total)))
429               (MPI:barrier comm-world)))))
430     (test-allgather MPI:allgather-bytevector (string->blob (list-ref vvsdata myrank))
431                   (map string->blob vvsdata))
432     (test-allgather MPI:allgather-s8vector   (list->s8vector (list-ref vvintdata myrank))
433                   (map list->s8vector vvintdata))
434     (test-allgather MPI:allgather-u8vector   (list->u8vector (list-ref vvintdata myrank))
435                   (map list->u8vector vvintdata))
436     (test-allgather MPI:allgather-s16vector  (list->s16vector (list-ref vvintdata myrank))
437                   (map list->s16vector vvintdata))
438     (test-allgather MPI:allgather-u16vector  (list->u16vector (list-ref vvintdata myrank))
439                   (map list->u16vector vvintdata))
440     (test-allgather MPI:allgather-s32vector  (list->s32vector (list-ref vvintdata myrank))
441                   (map list->s32vector vvintdata))
442     (test-allgather MPI:allgather-u32vector  (list->u32vector (list-ref vvintdata myrank))
443                   (map list->u32vector vvintdata))
444     (test-allgather MPI:allgather-f32vector  (list->f32vector (list-ref vvflodata myrank))
445                   (map list->f32vector vvflodata))
446     (test-allgather MPI:allgather-f64vector  (list->f64vector (list-ref vvflodata myrank))
447                   (map list->f64vector vvflodata))))
448
449
450  ;; Reduce
451  (test/collect 'mpi-reduce
452   (let* ((test-reduce 
453          (lambda (reducefun reduceops data)
454            (for-each (lambda (op)
455                        (print myrank ": reduce")
456                        (let ((res (reducefun data op 0 comm-world)))
457                          (if (zero? myrank)
458                              (begin
459                                (print myrank ": the result of reduction " op " is " res)
460                                (collect-test (expect-success res))
461                                ))
462                          (MPI:barrier comm-world)
463                          ))
464                      reduceops)
465            (MPI:barrier comm-world))))
466    (test-reduce MPI:reduce-int
467                     (list MPI:i_max MPI:i_min MPI:i_sum MPI:i_prod )
468                 (+ 1 myrank))
469     (test-reduce MPI:reduce-flonum
470                  (list MPI:f_max MPI:f_min MPI:f_sum MPI:f_prod )
471                  (+ 1 myrank))
472      (test-reduce MPI:reduce-s8vector 
473                 (list MPI:i_max MPI:i_min MPI:i_sum MPI:i_prod )
474                 (s8vector (* 2 myrank) (+ 1 (* 2 myrank)) (+ 2 (* 2 myrank))))
475      (test-reduce MPI:reduce-u8vector 
476                 (list MPI:i_max MPI:i_min MPI:i_sum MPI:i_prod )
477                 (u8vector (* 2 myrank) (+ 1 (* 2 myrank)) (+ 2 (* 2 myrank))))
478      (test-reduce MPI:reduce-s16vector 
479                 (list MPI:i_max MPI:i_min MPI:i_sum MPI:i_prod )
480                 (s16vector (* 2 myrank) (+ 1 (* 2 myrank)) (+ 2 (* 2 myrank))))
481      (test-reduce MPI:reduce-u16vector 
482                 (list MPI:i_max MPI:i_min MPI:i_sum MPI:i_prod )
483                 (u16vector (* 2 myrank) (+ 1 (* 2 myrank)) (+ 2 (* 2 myrank))))
484      (test-reduce MPI:reduce-s32vector 
485                 (list MPI:i_max MPI:i_min MPI:i_sum MPI:i_prod )
486                 (s32vector (* 2 myrank) (+ 1 (* 2 myrank)) (+ 2 (* 2 myrank))))
487      (test-reduce MPI:reduce-u32vector 
488                 (list MPI:i_max MPI:i_min MPI:i_sum MPI:i_prod )
489                 (u32vector (* 2 myrank) (+ 1 (* 2 myrank)) (+ 2 (* 2 myrank))))
490      (test-reduce MPI:reduce-f32vector 
491                 (list MPI:f_max MPI:f_min MPI:f_sum MPI:f_prod )
492                 (f32vector (* 2 myrank) (+ 0.1 (* 2 myrank)) (+ 0.2 (* 2 myrank))))
493      (test-reduce MPI:reduce-f64vector 
494                 (list MPI:f_max MPI:f_min MPI:f_sum MPI:f_prod )
495                 (f64vector (* 2 myrank) (+ 0.1 (* 2 myrank)) (+ 0.2 (* 2 myrank))))
496     ))
497
498  ;; Reduce all
499  (test/collect 'allreduce
500   (let* ((test-allreduce
501          (lambda (allreducefun reduceop data)
502            (print myrank ": data is " data)
503            (let ((res (allreducefun data reduceop comm-world)))
504              (MPI:barrier comm-world)
505              (print myrank ": the result of reduction " reduceop " is " res)
506              (collect-test (expect-success res))
507              (MPI:barrier comm-world)))))
508    (test-allreduce MPI:allreduce-int MPI:i_sum (+ 1 myrank))
509    (test-allreduce MPI:allreduce-flonum MPI:f_prod (+ 1.0 myrank))
510    (test-allreduce MPI:allreduce-s8vector MPI:i_sum
511                    (s8vector (* 2 myrank) (+ 1 (* 2 myrank)) (+ 2 (* 2 myrank))))
512    (test-allreduce MPI:allreduce-u8vector MPI:i_sum
513                    (u8vector (* 2 myrank) (+ 1 (* 2 myrank)) (+ 2 (* 2 myrank))))
514    (test-allreduce MPI:allreduce-s16vector MPI:i_sum
515                    (s16vector (* 2 myrank) (+ 1 (* 2 myrank)) (+ 2 (* 2 myrank))))
516    (test-allreduce MPI:allreduce-u16vector MPI:i_sum
517                    (u16vector (* 2 myrank) (+ 1 (* 2 myrank)) (+ 2 (* 2 myrank))))
518    (test-allreduce MPI:allreduce-s32vector MPI:i_sum
519                    (s32vector (* 2 myrank) (+ 1 (* 2 myrank)) (+ 2 (* 2 myrank))))
520    (test-allreduce MPI:allreduce-u32vector MPI:i_sum
521                    (u32vector (* 2 myrank) (+ 1 (* 2 myrank)) (+ 2 (* 2 myrank))))
522    (test-allreduce MPI:allreduce-f32vector MPI:f_sum 
523                    (f32vector (* 2 myrank) (+ 0.1 (* 2 myrank)) (+ 0.2 (* 2 myrank))))
524    (test-allreduce MPI:allreduce-f64vector MPI:f_sum 
525                    (f64vector (* 2 myrank) (+ 0.1 (* 2 myrank)) (+ 0.2 (* 2 myrank))))))
526   
527   ;; Scan
528  (test/collect 'scan
529   (let* ((test-scan
530          (lambda (scanfun reduceop data)
531            (print myrank ": data is " data)
532            (let ((res (scanfun data reduceop comm-world)))
533              (MPI:barrier comm-world)
534              (print myrank ": the result of scan " reduceop " is " res)
535              (collect-test (expect-success res))
536              (MPI:barrier comm-world)))))
537    (test-scan MPI:scan-int MPI:i_sum (+ 1 myrank))
538    (test-scan MPI:scan-flonum MPI:f_prod (+ 1.0 myrank))
539    (test-scan MPI:scan-s8vector MPI:i_sum
540               (s8vector (* 2 myrank) (+ 1 (* 2 myrank)) (+ 2 (* 2 myrank))))
541    (test-scan MPI:scan-u8vector MPI:i_sum
542               (u8vector (* 2 myrank) (+ 1 (* 2 myrank)) (+ 2 (* 2 myrank))))
543    (test-scan MPI:scan-s16vector MPI:i_sum
544               (s16vector (* 2 myrank) (+ 1 (* 2 myrank)) (+ 2 (* 2 myrank))))
545    (test-scan MPI:scan-u16vector MPI:i_sum
546               (u16vector (* 2 myrank) (+ 1 (* 2 myrank)) (+ 2 (* 2 myrank))))
547    (test-scan MPI:scan-s32vector MPI:i_sum
548               (s32vector (* 2 myrank) (+ 1 (* 2 myrank)) (+ 2 (* 2 myrank))))
549    (test-scan MPI:scan-u32vector MPI:i_sum
550               (u32vector (* 2 myrank) (+ 1 (* 2 myrank)) (+ 2 (* 2 myrank))))
551    (test-scan MPI:scan-f32vector MPI:f_sum 
552               (f32vector (* 2 myrank) (+ 0.1 (* 2 myrank)) (+ 0.2 (* 2 myrank))))
553    (test-scan MPI:scan-f64vector MPI:f_sum 
554               (f64vector (* 2 myrank) (+ 0.1 (* 2 myrank)) (+ 0.2 (* 2 myrank))))))
555
556  ;; Comm split
557  (test-eval 'comm-split
558   (let ((send-in-comm
559         (lambda (c init incr)
560           (let ((rank-in-c (MPI:comm-rank c))
561                 (size-of-c (MPI:comm-size c)))
562             (if (zero? rank-in-c)
563                 (begin
564                   (print rank-in-c "[" myrank "]: sending " init)
565                   (MPI:send init 1 0 c)
566                   (let ((n (MPI:receive MPI:any-source MPI:any-tag c)))
567                     (print rank-in-c "[" myrank "]: received " n)))
568                 (let ((n (MPI:receive MPI:any-source MPI:any-tag c)))
569                   (let ((n1 (string->blob (string-append (blob->string n) incr))))
570                     (print rank-in-c "[" myrank "]: received " n ", resending " n1)
571                     (MPI:send n1 (modulo (+ 1 rank-in-c) size-of-c) 0 c))))
572             (MPI:barrier comm-world)))))
573    (let ((c (MPI:comm-split comm-world (modulo myrank 2) 0)))
574      (if (zero? (modulo myrank 2))
575          (send-in-comm c (string->blob "aa") "a")
576          (send-in-comm c (string->blob "bb") "b")))))
577
578  ;; Cartesian topology
579  (test-eval 'cart
580   (let ((cart (MPI:make-cart comm-world (u32vector 2 2) (u32vector 0 0) #t))
581        (test-dims-create 
582         (lambda (n hints)
583           (print "make-dims " n " " hints " = " (MPI:make-dims n hints)))))
584    (if (zero? myrank)
585        (begin
586          (print "ranks = " (map (lambda (x) (cons x (MPI:cart-rank cart x)))
587                                 (list
588                                  (u32vector 0 0) (u32vector 1 0)
589                                  (u32vector 1 0) (u32vector 1 1))))
590          (print "coords = " (list-tabulate (MPI:comm-size cart)
591                                 (lambda (n) (cons n (MPI:cart-coords cart n)))))
592          (test-dims-create 60 (u32vector 0 0 0))
593          (test-dims-create 60 (u32vector 3 0 0))
594          (test-dims-create 60 (u32vector 0 4 0))
595          (test-dims-create 60 (u32vector 3 0 5))
596          ))))
597
598  (test-eval 'barrier (MPI:barrier comm-world))
599
600   ;; Wtime
601  (test-eval 'wtime (print myrank ": wtime is "  (MPI:wtime)))
602
603  )
604
605(test::styler-set! mpi-test test::output-style-compact)
606(run-test "mpi test")
607
608
Note: See TracBrowser for help on using the repository browser.