Use html for the code block in README
[guile-orca] / orca / internal.scm
1 ;;; Copyright (C) 2020  Ahmet Artu Yildirim
2 ;;;
3 ;;; orca is free software: you can redistribute it and/or modify
4 ;;; it under the terms of the GNU Lesser General Public License as
5 ;;; published by the Free Software Foundation, either version 3 of
6 ;;; the License, or (at your option) any later version.
7 ;;;
8 ;;; orca is distributed in the hope that it will be useful,
9 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
10 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
11 ;;; GNU Lesser General Public License for more details.
12 ;;;
13 ;;; You should have received a copy of the GNU Lesser General Public License
14 ;;; along with orca. If not, see <https://www.gnu.org/licenses/>.
15
16 (define-module (orca internal)
17   #:use-module (orca config)
18   #:use-module (system foreign)
19   #:use-module (rnrs bytevectors)
20   #:use-module (ice-9 q)
21   #:use-module (ice-9 iconv)
22   #:use-module (ice-9 eval-string)
23   #:use-module (srfi srfi-9)
24   #:use-module (ice-9 exceptions))
25
26 ;;------------------------------------------------------------------------------
27
28 ;;; Constants
29
30 ;;------------------------------------------------------------------------------
31
32 ;;; MPI Constants
33 (define MPI_COMM_WORLD #x44000000)
34 (define MPI_SUCCESS 0)
35 (define MPI_BYTE #x4c00010d)
36 (define MPI_STATUS_IGNORE (make-pointer 1))
37 (define MPI_STATUSES_IGNORE (make-pointer 1))
38
39 ;;; Internal Constants
40 (define DEFAULT_ENCODING "utf-8")
41 (define MPI_OP_SEND 1)
42 (define MPI_OP_RECV 2)
43
44 ;;------------------------------------------------------------------------------
45
46 ;;; Object properties used internally
47
48 ;;------------------------------------------------------------------------------
49
50 (define %mpi-request-buffer% (make-object-property))
51 (define %mpi-request-origin% (make-object-property))
52 (define %mpi-request-op% (make-object-property))
53 (define %mpi-receive-source% (make-object-property))
54
55 ;;------------------------------------------------------------------------------
56
57 ;;; Helper Functions
58
59 ;;------------------------------------------------------------------------------
60
61 (define mpi-func
62   (lambda* (return-type function-name arg-types)
63     (pointer->procedure return-type
64                         (dynamic-func function-name *libmpi*)
65                         arg-types)))
66
67 (define-syntax-rule (define-mpi-foreign
68                       name return-type func-name arg-types)
69   (define name
70     (mpi-func return-type func-name arg-types)))
71
72 (define (boolean->c-bool b)
73   "Convert the boolean to a c boolean."
74   (if b 1 0))
75
76 (define (c-bool->boolean b)
77   "Convert the c boolean to boolean."
78   (if (zero? b) #f #t))
79
80 (define (bytevector->int bv)
81   (bytevector-sint-ref bv
82                        0
83                        (native-endianness)
84                        (sizeof int)))
85
86 (define (bvlist->pointer lst size)
87   (cond
88    ((null? lst) %null-pointer)
89    ((not (pair? lst)) (error "input is not a list"))
90    (else (let* ((lst-length (length lst))
91                 (bv-target (make-bytevector (* size lst-length))))
92
93            (do ((i 0 (1+ i)))
94                ((>= i lst-length))
95              (bytevector-copy! (list-ref lst i) 0 bv-target
96                                (* i size)
97                                size))
98            (bytevector->pointer bv-target)))))
99
100 ;;; MPI_Status structure
101
102 (define-record-type <mpi-status>
103   (%make-mpi-status count cancelled mpi-source mpi-tag mpi-error)
104   mpi-status?
105   (count mpi-status-count set-mpi-status-count!)
106   (cancelled mpi-status-cancelled set-mpi-status-cancelled!)
107   (mpi-source mpi-status-source set-mpi-status-source!)
108   (mpi-tag mpi-status-tag set-mpi-status-tag!)
109   (mpi-error mpi-status-error set-mpi-status-error!))
110
111 (define* (make-mpi-status #:key
112                           (count 0)
113                           (cancelled 0)
114                           (mpi-source 0)
115                           (mpi-tag 0)
116                           (mpi-error 0))
117   (%make-mpi-status count cancelled mpi-source mpi-tag mpi-error))
118
119 (define mpi-status-types (list int int int int int))
120
121 (define (make-mpi-status-pointer)
122   (make-c-struct
123    mpi-status-types
124    (list 0 0 0 0 0)))
125
126 (define (pointer->mpi-status pointer)
127   (let ((lst (parse-c-struct pointer mpi-status-types)))
128     (make-mpi-status #:count (list-ref lst 0)
129                      #:cancelled (list-ref lst 1)
130                      #:mpi-source (list-ref lst 2)
131                      #:mpi-tag (list-ref lst 3)
132                      #:mpi-error (list-ref lst 4))))
133
134 ;;------------------------------------------------------------------------------
135
136 ;;; MPI_Request
137
138 ;;------------------------------------------------------------------------------
139
140 (define (make-mpi-request)
141   (bytevector->pointer (make-bytevector (sizeof int))))
142
143 (define (mpi-request-list->pointer lst)
144   (let ((bv-lst (map (lambda (ptr)
145                        (pointer->bytevector ptr (sizeof int))) lst)))
146     (bvlist->pointer lst (sizeof int))))
147
148 (define (mpi-request-list->buffer-list lst)
149   (let ((q (make-q)))
150     (let lp ((rest lst))
151       (if (null? rest)
152           (car q)
153           (begin
154             (when (= (%mpi-request-op% (car rest)) MPI_OP_RECV)
155               (enq! q (bytevector->string
156                        (%mpi-request-buffer% (car rest))
157                        DEFAULT_ENCODING)))
158             (lp (cdr rest)))))))
159
160 ;;------------------------------------------------------------------------------
161
162 (define (exp->string s-exp)
163   (call-with-output-string
164     (lambda (port) (write s-exp port))))
165
166 (export exp->string)
167
168 ;;------------------------------------------------------------------------------
169
170 (define (string->exp str)
171   (call-with-input-string str (lambda (port) (read port))))
172
173 (export string->exp)
174
175 ;;------------------------------------------------------------------------------
176
177 (define (eval-message message)
178   (exp->string (eval (string->exp message) (interaction-environment))))
179
180 (export eval-message)
181
182 ;;------------------------------------------------------------------------------
183
184 ;;; MPI Bindings
185
186 ;;------------------------------------------------------------------------------
187
188 (define-mpi-foreign %mpi-init
189   int "MPI_Init" (list '* '*))
190
191 (define (mpi-init)
192   "Initialize the MPI execution environment."
193   (unless (= MPI_SUCCESS (%mpi-init %null-pointer %null-pointer))
194     (error "failed to init mpi")))
195
196 (export mpi-init)
197
198 ;;------------------------------------------------------------------------------
199
200 (define-mpi-foreign %mpi-finalize
201   int "MPI_Finalize" '())
202
203 (define (mpi-finalize)
204   "Terminates MPI execution environment."
205   (unless (= MPI_SUCCESS (%mpi-finalize))
206     (error "failed to finalize mpi")))
207
208 (export mpi-finalize)
209
210 ;;------------------------------------------------------------------------------
211
212 (define-mpi-foreign %mpi-barrier
213   int "MPI_Barrier" (list int))
214
215 (define (mpi-barrier)
216   "Blocks until all processes in the communicator have reached this routine."
217   (unless (= MPI_SUCCESS (%mpi-barrier MPI_COMM_WORLD))
218     (error "failed to block")))
219
220 (export mpi-barrier)
221
222 ;;------------------------------------------------------------------------------
223
224 (define-mpi-foreign %mpi-initialized
225   int "MPI_Initialized" (list '*))
226
227 (define (mpi-initialized)
228   "Check whether MPI has been initialized."
229   (let* ((bv-flag (make-bytevector (sizeof int)))
230          (result (%mpi-initialized (bytevector->pointer bv-flag))))
231     (c-bool->boolean
232      (bytevector->int bv-flag))))
233
234 (export mpi-initialized)
235
236 ;;------------------------------------------------------------------------------
237
238 (define-mpi-foreign %mpi-comm-rank
239   int "MPI_Comm_rank" (list int '*))
240
241 (define (mpi-rank)
242   "Determine the rank of the calling process in the communicator."
243   (let* ((bv-rank (make-bytevector (sizeof int)))
244          (result (%mpi-comm-rank MPI_COMM_WORLD (bytevector->pointer bv-rank))))
245     (if (= MPI_SUCCESS result)
246         (bytevector->int bv-rank)
247         (error "failed to get rank"))))
248
249 (export mpi-rank)
250
251 ;;------------------------------------------------------------------------------
252
253 (define-mpi-foreign %mpi-comm-size
254   int "MPI_Comm_size" (list int '*))
255
256 (define (mpi-size)
257   "Return the size of the group associated with a communicator."
258   (let* ((bv-size (make-bytevector (sizeof int)))
259          (result (%mpi-comm-size MPI_COMM_WORLD (bytevector->pointer bv-size))))
260     (if (= MPI_SUCCESS result)
261         (bytevector->int bv-size)
262         (error "failed to get size"))))
263
264 (export mpi-size)
265
266 ;;------------------------------------------------------------------------------
267
268 (define-mpi-foreign %mpi-send
269   int "MPI_Send" (list '* int int int int int))
270
271 (define (mpi-send-string dest message tag)
272   "Send string message to destination process in a blocking mode."
273   (let* ((bv-message (string->bytevector message DEFAULT_ENCODING))
274          (bv-message-size (bytevector-length bv-message))
275          (result (%mpi-send (bytevector->pointer bv-message)
276                             bv-message-size
277                             MPI_BYTE
278                             dest
279                             tag
280                             MPI_COMM_WORLD)))
281     (unless (= MPI_SUCCESS result)
282       (error "failed to send message"))))
283
284 (export mpi-send-string)
285
286 ;;------------------------------------------------------------------------------
287
288 (define-mpi-foreign %mpi-isend
289   int "MPI_Isend" (list '* int int int int int '*))
290
291 (define (mpi-isend-string dest message tag)
292   "Send string message to destination process in a nonblocking mode."
293   (let* ((bv-message (string->bytevector message DEFAULT_ENCODING))
294          (bv-message-size (bytevector-length bv-message))
295          (mpi-request (make-mpi-request))
296          (result (%mpi-isend (bytevector->pointer bv-message)
297                              bv-message-size
298                              MPI_BYTE
299                              dest
300                              tag
301                              MPI_COMM_WORLD
302                              mpi-request)))
303     (if (= MPI_SUCCESS result)
304         (begin
305                                         ; associate data with the request pointer
306           (set! (%mpi-request-origin% mpi-request) dest)
307           (set! (%mpi-request-op% mpi-request) MPI_OP_SEND)
308           mpi-request)
309         (error "failed to send message"))))
310
311 (export mpi-isend-string)
312
313 ;;------------------------------------------------------------------------------
314
315 (define-mpi-foreign %mpi-probe
316   int "MPI_Probe" (list int int int '*))
317
318 (define (mpi-probe source tag)
319   "Blocking test for a message."
320   (let* ((status-p (make-mpi-status-pointer))
321          (result (%mpi-probe source
322                              tag
323                              MPI_COMM_WORLD
324                              status-p)))
325     (if (= MPI_SUCCESS result)
326         status-p
327         (error "failed to probe for message"))))
328
329 ;;------------------------------------------------------------------------------
330
331 (define-mpi-foreign %mpi-get-count
332   int "MPI_Get_count" (list '* int '*))
333
334 (define (mpi-get-byte-count status-p)
335   "Gets the number of bytes in the status"
336   (let* ((bv-count (make-bytevector (sizeof int)))
337          (result (%mpi-get-count status-p
338                                  MPI_BYTE
339                                  (bytevector->pointer bv-count))))
340     (if (= MPI_SUCCESS result)
341         (bytevector->int bv-count)
342         (error "failed to get byte count"))))
343
344 ;;------------------------------------------------------------------------------
345
346 (define-mpi-foreign %mpi-recv
347   int "MPI_Recv" (list '* int int int int int '*))
348
349 (define (mpi-recv-string source tag)
350   "Receive a string message from source process in a blocking mode."
351   (let* ((status-p (mpi-probe source tag))
352          (buf-count (mpi-get-byte-count status-p))
353          (bv-buf (make-bytevector buf-count))
354          (result (%mpi-recv (bytevector->pointer bv-buf)
355                             buf-count
356                             MPI_BYTE
357                             source
358                             tag
359                             MPI_COMM_WORLD
360                             MPI_STATUS_IGNORE)))
361     (if (= MPI_SUCCESS result)
362         (bytevector->string bv-buf DEFAULT_ENCODING)
363         (error "failed to receive message"))))
364
365 (export mpi-recv-string)
366
367 ;;------------------------------------------------------------------------------
368
369 (define-mpi-foreign %mpi-irecv
370   int "MPI_Irecv" (list '* int int int int int '*))
371
372 (define (mpi-irecv-string source tag)
373   "Begins a nonblocking receive."
374   (let* ((status-p (mpi-probe source tag))
375          (buf-count (mpi-get-byte-count status-p))
376          (bv-buf (make-bytevector buf-count))
377          (mpi-request (make-mpi-request))
378          (result (%mpi-irecv (bytevector->pointer bv-buf)
379                              buf-count
380                              MPI_BYTE
381                              source
382                              tag
383                              MPI_COMM_WORLD
384                              mpi-request)))
385     (if (= MPI_SUCCESS result)
386         (begin
387                                         ; associate data with the request pointer
388           (set! (%mpi-request-buffer% mpi-request) bv-buf)
389           (set! (%mpi-request-origin% mpi-request) source)
390           (set! (%mpi-request-op% mpi-request) MPI_OP_RECV)
391           mpi-request)
392         (error "failed to begin nonblocking receive"))))
393
394 (export mpi-irecv-string)
395
396 ;;------------------------------------------------------------------------------
397
398 (define-mpi-foreign %mpi-wait
399   int "MPI_Wait" (list '* '*))
400
401 (define (mpi-wait request)
402   "Waits for an MPI request to complete."
403   (let ((result (%mpi-wait request
404                            MPI_STATUS_IGNORE)))
405     (if (= MPI_SUCCESS result)
406         (when (= (%mpi-request-op% request) MPI_OP_RECV)
407           (bytevector->string (%mpi-request-buffer% request) DEFAULT_ENCODING))
408         (error "failed to wait all"))))
409
410 (export mpi-wait)
411
412 ;;------------------------------------------------------------------------------
413
414 (define-mpi-foreign %mpi-waitall
415   int "MPI_Waitall" (list int '* '*))
416
417 (define (mpi-waitall requests)
418   "Waits for all given MPI requests to complete."
419   (cond
420    ((null? requests) (error "input list is empty"))
421    ((not (pair? requests)) (error "input is not a list"))
422    (else (let* ((request-length (length requests))
423                 (result (%mpi-waitall request-length
424                                       (mpi-request-list->pointer requests)
425                                       MPI_STATUSES_IGNORE)))
426            (if (= MPI_SUCCESS result)
427                (mpi-request-list->buffer-list requests)
428                (error "failed to wait all"))))))
429
430 (export mpi-waitall)