www.artulab.com Git - guile-orca/blob - 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)