├── .gitignore ├── INSTALL ├── LICENSE ├── README.org ├── cl-mpi-asdf-integration.asd ├── cl-mpi-asdf-integration.lisp ├── cl-mpi-extensions.asd ├── cl-mpi-test-suite.asd ├── cl-mpi.asd ├── examples ├── cellular.lisp ├── cl-mpi-examples.asd ├── cl-mpi-examples.lisp ├── pingpong.lisp ├── ring.lisp └── transmit-anything.lisp ├── extensions ├── package.lisp └── transmit-anything.lisp ├── mpi ├── asdf-utilities.lisp ├── collective.lisp ├── contexts.lisp ├── datatypes.lisp ├── environment.lisp ├── grovel.lisp ├── one-sided.lisp ├── packages.lisp ├── point-to-point.lisp ├── setup.lisp ├── utilities.lisp └── wrap.lisp ├── roswell └── cl-mpi.ros ├── scripts ├── build-cl-mpi-application.sh └── run-test-suite.sh └── test-suite ├── packages.lisp ├── parallel-tests.lisp ├── serial-tests.lisp ├── stress-tests.lisp └── test-suite.lisp /.gitignore: -------------------------------------------------------------------------------- 1 | *.fasl 2 | # ignore images produced by the run-test-suite.sh script 3 | scripts/*.image 4 | -------------------------------------------------------------------------------- /INSTALL: -------------------------------------------------------------------------------- 1 | 2 | cl-mpi can be loaded with ASDF (www.common-lisp.net/project/asdf/). However it 3 | has some non-Lisp dependencies: 4 | 5 | * An MPI implementation 6 | On your supercomputer, there is usually some vendor-specific version of 7 | MPI. On your desktop system, there are plenty of free MPI implementations 8 | like OpenMPI (http://www.open-mpi.org/) or MPICH (http://www.mpich.org/) 9 | that you can install manually or with a package manager. 10 | * A C Compiler + mpicc 11 | Usually MPI provides a small wrapper around the systems C compiler named 12 | "mpicc". If cl-mpi fails to load, it is most certainly because there is no 13 | program named mpicc or mpicc is not able to produce shared libraries. If you 14 | encounter this problem, please let me know or send me a patch. 15 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | The MIT License (MIT) 2 | 3 | Copyright (c) 2008,2009 Alex Fukunaga 4 | Copyright (c) 2014 Marco Heisig 5 | 6 | Permission is hereby granted, free of charge, to any person obtaining a copy 7 | of this software and associated documentation files (the "Software"), to deal 8 | in the Software without restriction, including without limitation the rights 9 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 10 | copies of the Software, and to permit persons to whom the Software is 11 | furnished to do so, subject to the following conditions: 12 | 13 | The above copyright notice and this permission notice shall be included in 14 | all copies or substantial portions of the Software. 15 | 16 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 17 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 18 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 19 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 20 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 21 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 22 | THE SOFTWARE. 23 | -------------------------------------------------------------------------------- /README.org: -------------------------------------------------------------------------------- 1 | #+TITLE: cl-mpi 2 | 3 | cl-mpi provides convenient CFFI bindings for the Message Passing 4 | Interface (MPI). MPI is typically used in High Performance Computing to 5 | utilize big parallel computers with thousands of cores. It features minimal 6 | communication overhead with a latency in the range of microseconds. In 7 | comparison to the C or FORTRAN interface of MPI, cl-mpi relieves the 8 | programmer from working with raw pointers to memory and a plethora of 9 | mandatory function arguments. 10 | 11 | If you have questions or suggestions, feel free to contact me 12 | (marco.heisig@fau.de). 13 | 14 | cl-mpi has been tested with MPICH, MPICH2, IntelMPI and Open MPI. 15 | 16 | ** Usage 17 | An MPI program must be launched with =mpirun= or =mpiexec=. These commands 18 | spawn multiple processes depending on your system and commandline 19 | parameters. Each process is identical, except that it has a unique rank 20 | that can be queried with =(MPI-COMM-RANK)=. The ranks are assigned from 0 21 | to =(- (MPI-COMM-SIZE) 1)=. A wide range of communication functions is 22 | available to transmit messages between different ranks. To become familiar 23 | with cl-mpi, see the [[file:examples/][examples directory]]. 24 | 25 | The easiest way to deploy and run cl-mpi applications is by creating a 26 | statically linked binary. To do so, create a separate ASDF system like 27 | this: 28 | #+BEGIN_SRC lisp 29 | (defsystem :my-mpi-app 30 | :depends-on (:cl-mpi) 31 | :defsystem-depends-on (:cl-mpi-asdf-integration) 32 | :class :mpi-program 33 | :build-operation :static-program-op 34 | :build-pathname "my-mpi-app" 35 | :entry-point "my-mpi-app:main" 36 | :serial t 37 | :components 38 | ((:file "foo") (:file "bar"))) 39 | #+END_SRC 40 | 41 | and simply run 42 | #+BEGIN_SRC lisp 43 | (asdf:make :my-mpi-app) 44 | #+END_SRC 45 | on the REPL. Note that not all Lisp implementation support the creation of 46 | statically linked binaries (actually, we only tested SBCL so far). 47 | Alternatively, you can try to use uiop:dump-image to create binaries. 48 | 49 | Further remark: If the creation of statically linked binaries with SBCL 50 | fails with something like "undefined reference to main", your SBCL is 51 | probably not built with the =:sb-linkable-runtime= feature. You are 52 | affected by this when =(find :sb-linkable-runtime *features*)= returns 53 | NIL. In that case, you have to compile SBCL yourself, which is as simple as 54 | executing the following commands, where SOMEWHERE is the desired 55 | installation folder 56 | #+BEGIN_SRC sh 57 | git clone git://git.code.sf.net/p/sbcl/sbcl 58 | cd sbcl 59 | sh make.sh --prefix=SOMEWHERE --fancy --with-sb-linkable-runtime --with-sb-dynamic-core 60 | cd tests && sh run-tests.sh 61 | sh install.sh 62 | #+END_SRC 63 | 64 | ** Testing 65 | To run the test suite: 66 | #+BEGIN_SRC sh :results output 67 | ./scripts/run-test-suite.sh all 68 | #+END_SRC 69 | 70 | or 71 | 72 | #+BEGIN_SRC sh :results output 73 | ./scripts/run-test-suite.sh YOUR-FAVOURITE-LISP 74 | #+END_SRC 75 | 76 | ** Performance 77 | cl-mpi makes no additional copies of transmitted data and has therefore the 78 | same bandwidth as any other language (C, FORTRAN). However the convenience 79 | of error handling, automatic inference of the message types and safe 80 | computation of memory locations adds a little overhead to each message. The 81 | exact overhead varies depending on the Lisp implementation and platform but 82 | is somewhere around 1000 machine cycles. 83 | 84 | Summary: 85 | - latency increase per message: 400 nanoseconds (SBCL on a 2.4GHz Intel i7-5500U) 86 | - bandwidth unchanged 87 | 88 | ** Authors 89 | - Alex Fukunaga 90 | - Marco Heisig 91 | 92 | ** Special Thanks 93 | This project was funded by KONWIHR (The Bavarian Competence Network for 94 | Technical and Scientific High Performance Computing) and the Chair for 95 | Applied Mathematics 3 of Prof. Dr. Bänsch at the FAU Erlangen-Nürnberg. 96 | 97 | Big thanks to Nicolas Neuss for all the useful suggestions. 98 | -------------------------------------------------------------------------------- /cl-mpi-asdf-integration.asd: -------------------------------------------------------------------------------- 1 | (cl:in-package #:asdf-user) 2 | 3 | (defsystem :cl-mpi-asdf-integration 4 | :description "CFFI and ASDF integration for CL-MPI." 5 | :author "Marco Heisig " 6 | :license "MIT" 7 | :depends-on (:cffi-grovel :cffi-toolchain) 8 | :components 9 | ((:file "cl-mpi-asdf-integration"))) 10 | -------------------------------------------------------------------------------- /cl-mpi-asdf-integration.lisp: -------------------------------------------------------------------------------- 1 | (cl:defpackage #:cl-mpi-asdf-integration 2 | (:use :cl) 3 | (:export #:mpi-grovel-file #:mpi-wrapper-file #:mpi-program)) 4 | 5 | (cl:in-package #:cl-mpi-asdf-integration) 6 | 7 | (defclass mpi-mixin () 8 | ()) 9 | 10 | (defclass mpi-grovel-file (cffi-grovel:grovel-file mpi-mixin) 11 | ()) 12 | 13 | (defclass mpi-wrapper-file (cffi-grovel:wrapper-file mpi-mixin) 14 | ()) 15 | 16 | (defclass mpi-program (asdf:system mpi-mixin) 17 | () 18 | (:documentation 19 | "Class of ASDF systems that represent standalone MPI programs.")) 20 | 21 | (defmethod asdf:perform :around ((op asdf:operation) (c mpi-mixin)) 22 | (let ((cffi-toolchain:*cc* "mpicc") 23 | (cffi-toolchain:*ld* "mpicc")) 24 | (call-next-method))) 25 | 26 | #+sbcl 27 | (defmethod asdf:perform :before ((op asdf:program-op) (c mpi-program)) 28 | (loop for object in sb-alien::*shared-objects* do 29 | (setf (sb-alien::shared-object-dont-save object) t))) 30 | 31 | ;; Allow for keywords in ASDF definitions. 32 | 33 | (setf (find-class 'asdf::mpi-grovel-file) 34 | (find-class 'mpi-grovel-file)) 35 | 36 | (setf (find-class 'asdf::mpi-wrapper-file) 37 | (find-class 'mpi-wrapper-file)) 38 | 39 | (setf (find-class 'asdf::mpi-program) 40 | (find-class 'mpi-program)) 41 | -------------------------------------------------------------------------------- /cl-mpi-extensions.asd: -------------------------------------------------------------------------------- 1 | (cl:in-package #:asdf-user) 2 | 3 | (defsystem :cl-mpi-extensions 4 | :depends-on (:cl-mpi :cffi :cl-conspack) 5 | :license "MIT" 6 | :components 7 | ((:module "extensions" 8 | :components 9 | ((:file "package") 10 | (:file "transmit-anything" :depends-on ("package")))))) 11 | -------------------------------------------------------------------------------- /cl-mpi-test-suite.asd: -------------------------------------------------------------------------------- 1 | (cl:in-package #:asdf-user) 2 | 3 | (defsystem :cl-mpi-test-suite 4 | :description "The cl-mpi test suite" 5 | :author "Marco Heisig " 6 | :license "MIT" 7 | :depends-on (:cl-mpi :fiveam :cffi) 8 | :perform (test-op (o s) 9 | (uiop:symbol-call 10 | '#:cl-mpi-test-suite 11 | '#:run-cl-mpi-test-suite)) 12 | :serial t 13 | :components 14 | ((:module "test-suite" 15 | :components 16 | ((:file "packages") 17 | (:file "serial-tests") 18 | (:file "parallel-tests") 19 | (:file "stress-tests") 20 | (:file "test-suite"))))) 21 | -------------------------------------------------------------------------------- /cl-mpi.asd: -------------------------------------------------------------------------------- 1 | (cl:in-package #:asdf-user) 2 | 3 | (defsystem :cl-mpi 4 | :description "Common Lisp bindings for the Message Passing Interface (MPI)" 5 | :author "Marco Heisig " 6 | :version "1.0" 7 | :license "MIT" 8 | :long-description 9 | "cl-mpi provides convenient CFFI bindings for the Message Passing 10 | Interface (MPI). MPI is typically used in High Performance Computing to 11 | utilize big parallel computers with thousands of cores. It features minimal 12 | communication overhead with a latency in the range of microseconds. In 13 | comparison to the C or FORTRAN interface of MPI, cl-mpi relieves the 14 | programmer from working with raw pointers to memory and a plethora of 15 | mandatory function arguments." 16 | :defsystem-depends-on (:cl-mpi-asdf-integration) 17 | :depends-on (:alexandria :uiop :cffi :static-vectors) 18 | :in-order-to ((test-op (test-op "cl-mpi-test-suite"))) 19 | :components 20 | ((:module "mpi" 21 | :serial t 22 | :components 23 | ((:file "packages") 24 | 25 | ;; Extract all constants from "mpi.h". 26 | (:mpi-grovel-file "grovel") 27 | 28 | ;; Derive MPI implementation dependent constants. 29 | (:file "setup") 30 | 31 | ;; Create a small library to portably access the MPI runtime. 32 | (:mpi-wrapper-file "wrap") 33 | 34 | ;; MPI related utilities. 35 | (:file "utilities") 36 | 37 | ;; One file per chapter of the MPI specification. 38 | (:file "datatypes") 39 | (:file "collective") 40 | (:file "contexts") 41 | (:file "environment") 42 | (:file "point-to-point") 43 | (:file "one-sided"))))) 44 | -------------------------------------------------------------------------------- /examples/cellular.lisp: -------------------------------------------------------------------------------- 1 | ;;; A one dimensional cellular automaton. 2 | ;;; 3 | ;;; This example is particularly interesting as it works with bit 4 | ;;; vectors. MPI supports only messages that are aligned to byte 5 | ;;; boundaries, so special care must be taken to have each message properly 6 | ;;; aligned. 7 | 8 | (in-package :cl-user) 9 | 10 | (defpackage :cl-mpi/examples/cellular 11 | (:use :cl :alexandria :cl-mpi :static-vectors)) 12 | 13 | (in-package :cl-mpi/examples/cellular) 14 | 15 | (defun printf (fmt &rest args) 16 | (format t "rank ~d: " (mpi-comm-rank +mpi-comm-world+)) 17 | (apply #'format t fmt args) 18 | (finish-output)) 19 | 20 | (defun print-usage () 21 | (printf "usage: cellular CELLS~%")) 22 | 23 | (defun update (src dst) 24 | (declare (type simple-bit-vector src dst) 25 | (optimize (speed 3) (debug 0) (safety 0))) 26 | (loop for i from 1 below (- (length src) 1) do 27 | (let ((x__ (aref src (- i 1))) 28 | (_x_ (aref src i)) 29 | (__x (aref src (+ i 1)))) 30 | (setf (aref dst i) 31 | (aref 32 | ;; #*01111000 ; rule-30 33 | ;; #*01011010 ; rule-90 34 | ;; #*00011101 ; rule-184 35 | #*01110110 ; rule-30 36 | (+ (* 4 x__) (* 2 _x_) __x)))))) 37 | 38 | (defun synchronize (domain lsend lrecv rsend rrecv) 39 | (declare (type simple-bit-vector domain) 40 | (type (simple-bit-vector 8) lsend lrecv rsend rrecv)) 41 | (replace lsend domain :start2 8) 42 | (replace rsend domain :start2 (- (length domain) 16)) 43 | (let ((left (mod (- (mpi-comm-rank) 1) (mpi-comm-size))) 44 | (right (mod (+ (mpi-comm-rank) 1) (mpi-comm-size)))) 45 | (mpi-waitall 46 | (mpi-isend lsend left) 47 | (mpi-isend rsend right) 48 | (mpi-irecv lrecv left) 49 | (mpi-irecv rrecv right))) 50 | (replace domain lrecv :start1 0) 51 | (replace domain rrecv :start1 (- (length domain) 8))) 52 | 53 | (defun byte-align (n) 54 | ;; round up to a power of eight, see the book "Hacker's Delight" 55 | (logand (+ 7 n) -8)) 56 | 57 | (defun print-domain (domain) 58 | (declare (type simple-bit-vector domain)) 59 | (let ((count (- (length domain) 16)) ; strip the ghost layer 60 | (size (mpi-comm-size)) 61 | (rank (mpi-comm-rank)) 62 | (root 0) (meta-tag 0) (data-tag 1)) 63 | (with-static-vector (metadata 1 :element-type '(unsigned-byte 64) 64 | :initial-element count) 65 | ;; have each rank (including ROOT) send his data to ROOT 66 | (let ((meta-request (mpi-isend metadata root :tag meta-tag)) 67 | (data-request (mpi-isend domain root 68 | :tag data-tag 69 | :start 8 70 | :end (byte-align (+ 8 count))))) 71 | (when (= rank root) 72 | ;; process all ranks sequentially 73 | (with-static-vectors ((meta-recv 1 :element-type '(unsigned-byte 64)) 74 | ;; note that that ROOT has the longest domain! 75 | (data (length domain) :element-type 'bit)) 76 | (loop for source below size do 77 | (mpi-recv meta-recv source :tag meta-tag) 78 | (let ((N (aref meta-recv 0))) 79 | (mpi-recv data source :start 0 :end (byte-align N) :tag data-tag) 80 | ;; print the data received from SOURCE 81 | (loop for i below N do 82 | (if (zerop (aref data i)) 83 | (write-char #\.) 84 | (write-char #\X)))))) 85 | (write-char #\NEWLINE) 86 | (finish-output)) 87 | ;; wait for the send requests to complete 88 | (mpi-waitall meta-request data-request))))) 89 | 90 | (defun partition-domain (N) 91 | (let* ((size (mpi-comm-size)) 92 | (rank (mpi-comm-rank)) 93 | (chunk-size (max (floor N size) 8))) 94 | (multiple-value-bind (active-ranks remainder) 95 | (floor N chunk-size) 96 | (when (zerop active-ranks) 97 | (error "Need a domain size of at least ~D cells." chunk-size)) 98 | ;; split the remainder amongst all active ranks 99 | (multiple-value-bind (bonus big-chunks) 100 | (floor remainder active-ranks) 101 | (values 102 | ;; the size of the local domain of RANK 103 | (cond 104 | ((< rank big-chunks) (+ chunk-size bonus 1)) 105 | ((< rank active-ranks) (+ chunk-size bonus)) 106 | (t 0)) 107 | ;; the communicator containing only active ranks 108 | (mpi-comm-create 109 | (mpi-group-incl (mpi-comm-group) `(0 ,(- active-ranks 1))))))))) 110 | 111 | (defmacro with-partitioning ((N-local N) &body body) 112 | ;; binding *standard-communicator* so that consecutive calls 113 | ;; to (MPI-COMM-SIZE) and (MPI-COMM-RANK) consider only 114 | ;; the active ranks determined by PARTITION-DOMAIN 115 | (assert (symbolp N-local)) 116 | `(multiple-value-bind (,N-local *standard-communicator*) 117 | (partition-domain ,N) 118 | ,@body)) 119 | 120 | (defun cellular (N iterations) 121 | (with-partitioning (N-local N) 122 | (printf "simulating ~D cells~%" N-local) 123 | (unless (zerop N-local) 124 | (let ((domain-size (+ (* 2 8) ; include ghost layers 125 | N-local)) 126 | (random-state (make-random-state t))) 127 | (with-static-vectors ((v1 domain-size :element-type 'bit) 128 | (v2 domain-size :element-type 'bit) 129 | (b1 8 :element-type 'bit) 130 | (b2 8 :element-type 'bit) 131 | (b3 8 :element-type 'bit) 132 | (b4 8 :element-type 'bit)) 133 | ;; initialize the domain 134 | (loop for i below domain-size do 135 | (setf (aref v1 i) (random 2 random-state))) 136 | (print-domain v1) 137 | (synchronize v1 b1 b2 b3 b4) 138 | ;; now the iterations 139 | (loop repeat (floor iterations 8) do 140 | (loop repeat 4 do 141 | (print-domain v1) 142 | (update v1 v2) 143 | (print-domain v2) 144 | (update v2 v1)) 145 | ;; sync is only required every 8th iteration 146 | (synchronize v1 b1 b2 b3 b4))))))) 147 | 148 | (defun main (&optional args) 149 | (mpi-init) 150 | (let ((N (or (parse-integer (or (car args) "") :junk-allowed t) 151 | (print-usage) 152 | (mpi-finalize) 153 | (uiop:quit))) 154 | (iterations 80)) 155 | (cellular N iterations) 156 | (mpi-finalize) 157 | (uiop:quit))) 158 | -------------------------------------------------------------------------------- /examples/cl-mpi-examples.asd: -------------------------------------------------------------------------------- 1 | (cl:in-package #:asdf-user) 2 | 3 | (defsystem :cl-mpi-examples 4 | :depends-on (:uiop :cl-mpi) 5 | :defsystem-depends-on (:cl-mpi-asdf-integration) 6 | :class :mpi-program 7 | 8 | :build-operation :static-program-op 9 | :build-pathname "cl-mpi-examples" 10 | :entry-point "cl-mpi-examples:entry-point" 11 | 12 | :serial t 13 | :components 14 | ((:file "ring") 15 | (:file "cl-mpi-examples"))) 16 | -------------------------------------------------------------------------------- /examples/cl-mpi-examples.lisp: -------------------------------------------------------------------------------- 1 | (cl:defpackage #:cl-mpi-examples 2 | (:use :cl) 3 | (:export #:entry-point)) 4 | 5 | (cl:in-package #:cl-mpi-examples) 6 | 7 | (defun entry-point () 8 | (cl-mpi/examples/ring::main)) 9 | -------------------------------------------------------------------------------- /examples/pingpong.lisp: -------------------------------------------------------------------------------- 1 | ;; A simple benchmark, where a message is sent back and forth between pairs 2 | ;; of processors 3 | 4 | (in-package :cl-user) 5 | 6 | (defpackage :cl-mpi/examples/pingpong 7 | (:use :cl :alexandria :cl-mpi :static-vectors) 8 | (:export #:main)) 9 | 10 | (in-package :cl-mpi/examples/pingpong) 11 | 12 | (defun printf (fmt &rest args) 13 | (format t "rank ~d: " (mpi-comm-rank)) 14 | (apply #'format t fmt args) 15 | (finish-output)) 16 | 17 | (defun die (fmt &rest args) 18 | (apply #'printf fmt args) 19 | (mpi-finalize) 20 | (uiop:quit)) 21 | 22 | (defun target-rank () 23 | (when (oddp (mpi-comm-size)) 24 | (die "pingpong requires an even number of processors~%") 25 | (mpi-finalize) 26 | (uiop:quit)) 27 | (let ((rank (mpi-comm-rank))) 28 | (cond ((evenp rank) (1+ rank)) 29 | ((oddp rank) (1- rank))))) 30 | 31 | (defun pingpong (&rest message-sizes) 32 | (with-static-vector (buffer (apply #'max message-sizes)) 33 | (loop for message-size in message-sizes 34 | with target = (target-rank) do 35 | (let ((iterations (ceiling 100000000 (+ message-size 1000))) 36 | (tbegin (mpi-wtime))) 37 | (loop repeat iterations do 38 | (cond ((evenp target) 39 | (mpi-send buffer target :end message-size) 40 | (mpi-recv buffer target :end message-size)) 41 | ((oddp target) 42 | (mpi-recv buffer target :end message-size) 43 | (mpi-send buffer target :end message-size))) 44 | ;; in case you want to compare the performance of cl-mpi 45 | ;; with low level CFFI calls, here is what the latter would 46 | ;; look like. (Spoiler: 100 nanoseconds, so dont bother) 47 | ;; 48 | ;; (cond ((evenp target) 49 | ;; (mpi::%mpi-send ptr count +mpi-byte+ target 0 comm) 50 | ;; (mpi::%mpi-recv ptr count +mpi-byte+ target 0 comm +mpi-status-ignore+)) 51 | ;; ((oddp target) 52 | ;; (mpi::%mpi-recv ptr count +mpi-byte+ target 0 comm +mpi-status-ignore+) 53 | ;; (mpi::%mpi-send ptr count +mpi-byte+ target 0 comm))) 54 | ) 55 | (let ((usec (* 1000000.0d0 (- (mpi-wtime) tbegin)))) 56 | (when (= (mpi-comm-rank) 0) 57 | (printf "~9D bytes ~12,4F usec/msg ~8,2F MB/sec~%" 58 | message-size 59 | (/ usec iterations 2) 60 | (/ (* message-size iterations 2) usec)))))))) 61 | 62 | (defun main (&optional args) 63 | (mpi-init) 64 | (let ((parsed-args (mapcar 65 | (lambda (arg) 66 | (or (parse-integer arg :junk-allowed t) 67 | (die "pingpong [MSG-SIZE]*~%"))) 68 | args)) 69 | (default-args (loop for i below 30 collect (expt 2 i)))) 70 | (apply #'pingpong (or parsed-args default-args)) 71 | (mpi-finalize) 72 | (uiop:quit))) 73 | -------------------------------------------------------------------------------- /examples/ring.lisp: -------------------------------------------------------------------------------- 1 | ;;; all participating processes pass a given message in a circle until it 2 | ;;; reaches again the original sender (here rank 0) 3 | 4 | (in-package :cl-user) 5 | 6 | (defpackage :cl-mpi/examples/ring 7 | (:use :cl :alexandria :cl-mpi :static-vectors) 8 | (:export #:main)) 9 | 10 | (in-package :cl-mpi/examples/ring) 11 | 12 | (defun printf (fmt &rest args) 13 | (format t "rank ~d: " (mpi-comm-rank)) 14 | (apply #'format t fmt args) 15 | (finish-output)) 16 | 17 | (defun main (&optional arg) 18 | (declare (ignorable arg)) 19 | (mpi-init) 20 | (let* ((message "foobar") 21 | (rank (mpi-comm-rank)) 22 | (size (mpi-comm-size)) 23 | (left-neighbor (mod (- rank 1) size)) 24 | (right-neighbor (mod (+ rank 1) size))) 25 | (with-static-vector (buffer (length message) 26 | :element-type 'character) 27 | (when (= 0 rank) (printf "sending ~S~%" message)) 28 | (mpi-barrier) 29 | (cond ((= 0 rank) 30 | ;; rank null must use the nonblocking versions MPI-ISEND and 31 | ;; MPI-IRECV, otherwise in the trivial case of only a single 32 | ;; process (= (mpi-comm-size) 1), both right-neighbor and 33 | ;; left-neighbor will be zero and we have a potential 34 | ;; deadlock. Alternatively one could use MPI-SENDRECV. 35 | (mpi-waitall 36 | (mpi-isend message right-neighbor) 37 | (mpi-irecv buffer left-neighbor)) 38 | (printf "received ~S~%" buffer)) 39 | (t 40 | (mpi-recv buffer left-neighbor) 41 | (printf "received ~S~%" buffer) 42 | (mpi-send buffer right-neighbor))))) 43 | (mpi-finalize) 44 | (uiop:quit)) 45 | -------------------------------------------------------------------------------- /examples/transmit-anything.lisp: -------------------------------------------------------------------------------- 1 | ;;; A demonstration of the transmit-anything extension of cl-mpi 2 | ;;; 3 | ;;; Every rank greets his left and right neighbor by sending a list of a 4 | ;;; string and an object. In the end, each process displays the result of 5 | ;;; MPI-WAITALL-ANYTHING. 6 | 7 | (defpackage :cl-mpi/examples/transmit-anything 8 | (:use :cl :alexandria :cl-mpi :static-vectors :cl-mpi-extensions)) 9 | 10 | (in-package :cl-mpi/examples/transmit-anything) 11 | 12 | (defun printf (fmt &rest args) 13 | (format t "rank ~d: " (mpi-comm-rank)) 14 | (apply #'format t fmt args) 15 | (finish-output)) 16 | 17 | (defun main (&optional arg) 18 | (declare (ignorable arg)) 19 | (mpi-init) 20 | (let* ((*random-state* (make-random-state)) 21 | (rank (mpi-comm-rank)) 22 | (size (mpi-comm-size)) 23 | (left-neighbor (mod (- rank 1) size)) 24 | (right-neighbor (mod (+ rank 1) size)) 25 | (object (random-elt '(:banana :potato :apple)))) 26 | (printf 27 | "~s~%" 28 | (mpi-waitall-anything 29 | (mpi-irecv-anything right-neighbor :tag 1) 30 | (mpi-irecv-anything left-neighbor :tag 2) 31 | (mpi-isend-anything 32 | `(,(format nil "Greetings left neighbor! Have a ~a." object) ,object) 33 | left-neighbor :tag 1) 34 | (mpi-isend-anything 35 | `(,(format nil "Greetings right neighbor! Have a ~a." object) ,object) 36 | right-neighbor :tag 2)))) 37 | (mpi-finalize) 38 | (uiop:quit)) 39 | -------------------------------------------------------------------------------- /extensions/package.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :cl-mpi-extensions 2 | (:nicknames :mpi-extensions) 3 | (:use :cl :cl-mpi :static-vectors :alexandria) 4 | (:export 5 | #:mpi-send-anything 6 | #:mpi-recv-anything 7 | #:mpi-waitall-anything 8 | #:mpi-isend-anything 9 | #:mpi-irecv-anything 10 | #:mpi-broadcast-anything)) 11 | -------------------------------------------------------------------------------- /extensions/transmit-anything.lisp: -------------------------------------------------------------------------------- 1 | #| -*- Mode: Lisp; indent-tabs-mode: nil -*- 2 | 3 | Lispy extensions to MPI 4 | 5 | Copyright (C) 2014,2015 Marco Heisig 6 | 7 | Permission is hereby granted, free of charge, to any person obtaining a copy 8 | of this software and associated documentation files (the "Software"), to deal 9 | in the Software without restriction, including without limitation the rights 10 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 11 | copies of the Software, and to permit persons to whom the Software is 12 | furnished to do so, subject to the following conditions: 13 | 14 | The above copyright notice and this permission notice shall be included in 15 | all copies or substantial portions of the Software. 16 | 17 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 18 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 19 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 20 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 21 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 23 | THE SOFTWARE. 24 | |# 25 | 26 | (in-package :cl-mpi-extensions) 27 | 28 | (defvar *standard-encode-function* 29 | #'(lambda (x) (conspack:encode x :stream :static)) 30 | "A function that serializes a given object.") 31 | 32 | (defvar *standard-cleanup-function* #'free-static-vector 33 | "A function that cleans up the buffer returned by the corresponding 34 | encode function.") 35 | 36 | (defvar *standard-decode-function* #'conspack:decode 37 | "A function that can deserialize the buffer created by the 38 | corresponding encode function.") 39 | 40 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 41 | ;;; 42 | ;;; nonblocking communication 43 | 44 | (defun mpi-send-anything (object dest &key (comm *standard-communicator*) 45 | (tag 0) 46 | (encode *standard-encode-function*) 47 | (cleanup *standard-cleanup-function*)) 48 | "MPI-SEND-ANYTHING is a slower but more general variant of MPI-SEND. It can 49 | transmit any object to a matching MPI-RECV-ANYTHING." 50 | (mpi-waitall-anything 51 | (mpi-isend-anything object dest :comm comm :tag tag :encode encode :cleanup cleanup)) 52 | nil) 53 | 54 | (defun mpi-recv-anything (source &key (comm *standard-communicator*) 55 | (tag +mpi-any-tag+) 56 | (decode *standard-decode-function*)) 57 | "Returns three values, the transmitted object, the rank of the sending 58 | process and the tag of the message." 59 | (destructuring-bind ((source tag data)) 60 | (mpi-waitall-anything 61 | (mpi-irecv-anything source :comm comm :tag tag :decode decode)) 62 | (values data source tag))) 63 | 64 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 65 | ;;; 66 | ;;; all to all communication 67 | 68 | (defun mpi-broadcast-anything (root &key (comm *standard-communicator*) 69 | object 70 | (encode *standard-encode-function*) 71 | (decode *standard-decode-function*) 72 | (cleanup *standard-cleanup-function*)) 73 | "The node with rank ROOT sends the given object to every other rank in the 74 | communicator COMM." 75 | (declare (type (signed-byte 32) root) 76 | (type mpi-comm comm)) 77 | (cond 78 | ((= root (mpi-comm-rank)) 79 | (let* ((sendbuf (funcall encode object)) 80 | (size (make-static-vector 1 :element-type '(signed-byte 64) 81 | :initial-element (length sendbuf)))) 82 | (mpi-bcast size root :comm comm) 83 | (mpi-bcast sendbuf root :comm comm) 84 | (prog1 object 85 | (funcall cleanup sendbuf) 86 | (free-static-vector size)))) 87 | (t 88 | (let ((size (make-static-vector 1 :element-type '(signed-byte 64)))) 89 | (mpi-bcast size root :comm comm) 90 | (let ((recvbuf (make-static-vector (aref size 0)))) 91 | (mpi-bcast recvbuf root :comm comm) 92 | (prog1 (funcall decode recvbuf) 93 | (free-static-vector recvbuf) 94 | (free-static-vector size))))))) 95 | 96 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 97 | ;;; 98 | ;;; nonblocking communication 99 | 100 | (defclass mpi-request-anything (mpi-request) 101 | ((%hook :initarg :hook :reader hook))) 102 | 103 | (defun run-hook (request) 104 | (funcall (hook request))) 105 | 106 | (defun mpi-waitall-anything (&rest requests) 107 | "REQUESTS must be objects returned by MPI-ISEND-ANYTHING or 108 | MPI-IRECV-ANYTHING. Block until all given requests have been 109 | completed. Return a list with one (SOURCE TAG DATA) triple per 110 | MPI-IRECV-ANYTHING request." 111 | (let ((data-requests (mapcar #'run-hook (apply #'mpi-waitall requests)))) 112 | (delete-if #'not (mapcar #'run-hook (apply #'mpi-waitall data-requests))))) 113 | 114 | (defun mpi-isend-anything (object dest &key (comm *standard-communicator*) 115 | (tag 0) 116 | (encode *standard-encode-function*) 117 | (cleanup *standard-cleanup-function*)) 118 | "MPI-SEND-ANYTHING is a slower but more general variant of MPI-SEND. It 119 | can transmit any object to a matching MPI-IRECV-ANYTHING when passed to 120 | MPI-WAITALL-ANYTHING." 121 | (declare (type (signed-byte 32) dest tag) 122 | (type mpi-comm comm)) 123 | (let* ((data-buffer 124 | (funcall encode object)) 125 | (metadata-buffer 126 | (make-static-vector 1 :element-type '(unsigned-byte 64) 127 | :initial-element (length data-buffer)))) 128 | (change-class 129 | (mpi-isend metadata-buffer dest :tag tag :comm comm :mode :synchronous) 130 | 'mpi-request-anything 131 | :hook 132 | (lambda () 133 | (free-static-vector metadata-buffer) 134 | (change-class 135 | (mpi-isend data-buffer dest :tag tag :comm comm :mode :synchronous) 136 | 'mpi-request-anything 137 | :hook (lambda () 138 | (funcall cleanup data-buffer) 139 | nil)))))) 140 | 141 | (defun mpi-irecv-anything (source &key (comm *standard-communicator*) 142 | (tag +mpi-any-tag+) 143 | (decode *standard-decode-function*)) 144 | "Returns a request that can be passed to MPI-WAITALL-ANYTHING to receive 145 | an arbitrary object from a matching MPI-ISEND-ANYTHING." 146 | (declare (type (signed-byte 32) source tag) 147 | (type mpi-comm comm)) 148 | (let ((metadata-buffer 149 | (make-static-vector 1 :element-type '(unsigned-byte 64))) 150 | data-buffer) 151 | (change-class 152 | (mpi-irecv metadata-buffer source :comm comm :tag tag) 153 | 'mpi-request-anything 154 | :hook 155 | (lambda () 156 | (setf data-buffer 157 | (make-static-vector (aref metadata-buffer 0))) 158 | (free-static-vector metadata-buffer) 159 | (change-class 160 | (mpi-irecv data-buffer source :comm comm :tag tag) 161 | 'mpi-request-anything 162 | :hook 163 | (lambda () 164 | (prog1 165 | (list source tag (funcall decode data-buffer)) 166 | (free-static-vector data-buffer)))))))) 167 | -------------------------------------------------------------------------------- /mpi/asdf-utilities.lisp: -------------------------------------------------------------------------------- 1 | ;;; Extend ASDF and the CFFI groveller to be MPI aware 2 | (defpackage :cl-mpi-asdf-utilities 3 | (:use :asdf :cl :uiop) 4 | (:export #:mpi-stub #:grovel-mpi-file)) 5 | 6 | (in-package :cl-mpi-asdf-utilities) 7 | 8 | (defclass grovel-mpi-file (cffi-grovel:grovel-file) ()) 9 | 10 | (defclass mpi-stub (c-source-file) 11 | ((%mpi-info :initform "" 12 | :accessor mpi-info))) 13 | 14 | ;;; use "mpicc" as compiler for all mpi related cffi-grovel files 15 | (defmethod perform ((op cffi-grovel::process-op) 16 | (c grovel-mpi-file)) 17 | (let ((cc (getenv "CC")) 18 | (cffi-grovel::*cc* "mpicc")) 19 | (unless (or (not cc) 20 | (string-equal cc "mpicc")) 21 | (warn 22 | (format nil 23 | "The environment variable CC with value ~A overrides the recommended 24 | compiler mpicc. Some headers and libraries might not get found." cc))) 25 | (call-next-method))) 26 | 27 | (defun compute-mpi-info () 28 | "Produce some value that is EQUALP unless the MPI implementation changes." 29 | (multiple-value-bind (output stderr exit-code) 30 | (uiop:run-program "mpicc -show~%" :output :string 31 | :ignore-error-status t) 32 | (declare (ignore stderr)) 33 | (if (zerop exit-code) 34 | output 35 | nil))) 36 | 37 | (defmethod output-files ((o compile-op) (c mpi-stub)) 38 | (declare (ignorable o)) 39 | (list (make-pathname :defaults (component-pathname c) 40 | :type "so"))) 41 | 42 | ;; Convert a single c source file into a shared library that can be loaded 43 | ;; with ASDF:LOAD-OP. 44 | (defmethod perform ((o compile-op) (c mpi-stub)) 45 | (let ((target (output-file o c)) 46 | (source (component-pathname c))) 47 | (let ((possible-commands 48 | (list 49 | (format nil "mpicc -shared -fPIC -o ~A ~A" target source) 50 | ;; more commands can be added here if there is a system where the 51 | ;; above command fails 52 | ))) 53 | (block compile-stub-library 54 | (dolist (cmd possible-commands) 55 | (if (multiple-value-bind (stdout stderr exit-code) 56 | (uiop:run-program cmd :ignore-error-status t 57 | :error-output :string) 58 | (declare (ignore stdout stderr)) 59 | (zerop exit-code)) 60 | (progn 61 | (format *standard-output* "; ~A~%" cmd) 62 | (return-from compile-stub-library)))) 63 | (error "Failed to compile c-mpi-stub.c - please check mpicc.")) 64 | (setf (mpi-info c) (compute-mpi-info))))) 65 | 66 | (defmethod perform ((o load-op) (c mpi-stub)) 67 | (cffi:load-foreign-library (output-file 'compile-op c))) 68 | 69 | (defmethod operation-done-p ((o compile-op) (c mpi-stub)) 70 | "Return NIL if the current MPI implementation differs from the one that 71 | was used to build this component." 72 | (if (equalp (mpi-info c) 73 | (compute-mpi-info)) 74 | (call-next-method) 75 | nil)) 76 | -------------------------------------------------------------------------------- /mpi/collective.lisp: -------------------------------------------------------------------------------- 1 | #| -*- Mode: Lisp; indent-tabs-mode: nil -*- 2 | 3 | MPI collective communication functions 4 | 5 | Copyright (c) 2008,2009 Alex Fukunaga 6 | Copyright (C) 2014,2015 Marco Heisig 7 | 8 | Permission is hereby granted, free of charge, to any person obtaining a copy 9 | of this software and associated documentation files (the "Software"), to deal 10 | in the Software without restriction, including without limitation the rights 11 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 12 | copies of the Software, and to permit persons to whom the Software is 13 | furnished to do so, subject to the following conditions: 14 | 15 | The above copyright notice and this permission notice shall be included in 16 | all copies or substantial portions of the Software. 17 | 18 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 19 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 20 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 21 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 22 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 23 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 24 | THE SOFTWARE. 25 | |# 26 | 27 | (in-package :cl-mpi) 28 | 29 | (defmpifun "MPI_Allgather" (*sendbuf sendcount sendtype *recvbuf recvcount recvtype comm)) 30 | (defmpifun "MPI_Allgatherv" (*sendbuf sendcount sendtype *recvbuf recvcounts displs recvtype comm)) 31 | (defmpifun "MPI_Allreduce" (*sendbuf *recvbuf count datatype op comm)) 32 | (defmpifun "MPI_Alltoall" (*sendbuf *recvbuf count datatype op comm)) 33 | (defmpifun "MPI_Alltoallv" (*sendbuf sendcounts sdispls sendtype *recvbuf recvcounts rdispls recvtype comm)) 34 | (defmpifun "MPI_Alltoallw" (*sendbuf sendcounts sdispls sendtypes *recvbuf recvcounts rdispls recvtypes comm) :introduced "2.0") 35 | (defmpifun "MPI_Barrier" (comm)) 36 | (defmpifun "MPI_Bcast" (*buf count datatype root comm)) 37 | (defmpifun "MPI_Exscan" (*sendbuf *recvbuf count datatype op comm) :introduced "2.0") 38 | (defmpifun "MPI_Gather" (*sendbuf sendcount sendtype *recvbuf recvcount recvtype root comm)) 39 | (defmpifun "MPI_Gatherv" (*sendbuf sendcount sendtype *recvbuf recvcounts displs recvtype root comm)) 40 | (defmpifun "MPI_Iallgather" (*sendbuf sendcount sendtype *recvbuf recvcount recvtype comm *request) :introduced "3.0") 41 | (defmpifun "MPI_Iallgatherv" (*sendbuf sendcount sendtype *recvbuf recvcounts displs recvtype comm *request) :introduced "3.0") 42 | (defmpifun "MPI_Iallreduce" (*sendbuf *recvbuf count datatype op comm *request) :introduced "3.0") 43 | (defmpifun "MPI_Ialltoall" (*sendbuf sendcount sendtype *recvbuf recvcount recvtype comm *request) :introduced "3.0") 44 | (defmpifun "MPI_Ialltoallv" (*sendbuf sendcounts sdispls sendtype *recvbuf recvcounts rdispls recvtype comm *request) :introduced "3.0") 45 | (defmpifun "MPI_Ialltoallw" (*sendbuf sendcounts sdispls sendtypes *recvbuf recvcounts rdispls recvtypes comm *request) :introduced "3.0") 46 | (defmpifun "MPI_Ibarrier" (comm *request) :introduced "3.0") 47 | (defmpifun "MPI_Ibcast" (*buf count datatype root comm *request) :introduced "3.0") 48 | (defmpifun "MPI_Iexscan" (*sendbuf *recvbuf count datatype op comm *request) :introduced "3.0") 49 | (defmpifun "MPI_Igather" (*sendbuf sendcount sendtype *recvbuf recvcount recvtype root comm *request) :introduced "3.0") 50 | (defmpifun "MPI_Igatherv" (*sendbuf sendcount sendtype *recvbuf recvcounts displs recvtype root comm *request) :introduced "3.0") 51 | (defmpifun "MPI_Ireduce" (*sendbuf *recvbuf count datatype op root comm *request) :introduced "3.0") 52 | (defmpifun "MPI_Ireduce_scatter" (*sendbuf *recvbuf recvcounts datatype op comm *request) :introduced "3.0") 53 | (defmpifun "MPI_Ireduce_scatter_block" (*sendbuf *recvbuf recvcount datatype op comm *request) :introduced "3.0") 54 | (defmpifun "MPI_Iscan" (*sendbuf *recvbuf count datatype op comm *request) :introduced "3.0") 55 | (defmpifun "MPI_Iscatter" (*sendbuf sendcount sendtype *recvbuf recvcount recvtype root comm *request) :introduced "3.0") 56 | (defmpifun "MPI_Iscatterv" (*sendbuf sendcounts displs sendtype *recvbuf recvcount recvtype root comm *request) :introduced "3.0") 57 | (defmpifun "MPI_Op_commutative" (op *commute)) 58 | (defmpifun "MPI_Op_create" (fun commute *op)) 59 | (defmpifun "MPI_Op_free" (*op)) 60 | (defmpifun "MPI_Reduce" (*sendbuf *recvbuf count datatype op root comm)) 61 | (defmpifun "MPI_Reduce_local" (*inbuf *inoutbuf count datatype op)) 62 | (defmpifun "MPI_Reduce_scatter" (*sendbuf *recvbuf recvcounts datatype op comm)) 63 | (defmpifun "MPI_Reduce_scatter_block" (*sendbuf *recvbuf recvcount datatype op comm) :introduced "2.2") 64 | (defmpifun "MPI_Scan" (*sendbuf *recvbuf count datatype op comm)) 65 | (defmpifun "MPI_Scatter" (*sendbuf sendcount sendtype *recvbuf recvcount recvtype root comm)) 66 | (defmpifun "MPI_Scatterv" (*sendbuf sendcounts displs sendtype *recvbuf recvcount recvtype root comm)) 67 | 68 | (defun mpi-allgather (send-array recv-array &key (comm *standard-communicator*) 69 | send-start send-end 70 | recv-start recv-end) 71 | "After MPI-ALLGATHER returns, RECV-ARRAY will contain the contents of 72 | each processes SEND-ARRAY ordered by increasing mpi rank." 73 | (declare (type simple-array send-array recv-array) 74 | (type mpi-comm comm) 75 | (type index send-start send-end recv-start recv-end)) 76 | (multiple-value-bind (sendbuf sendtype sendcount) 77 | (static-vector-mpi-data send-array send-start send-end) 78 | (multiple-value-bind (recvbuf recvtype recvcount) 79 | (static-vector-mpi-data recv-array recv-start recv-end) 80 | (declare (ignore recvcount)) 81 | (%mpi-allgather sendbuf sendcount sendtype 82 | recvbuf sendcount recvtype comm)))) 83 | 84 | (defun mpi-allreduce (send-array recv-array op &key (comm *standard-communicator*) 85 | send-start send-end 86 | recv-start recv-end) 87 | "Combine the contents of each SEND-ARRAY element wise with the operation 88 | OP and store the result RECV-ARRAY." 89 | (declare (type simple-array send-array recv-array) 90 | (type mpi-op op) 91 | (type mpi-comm comm) 92 | (type index send-start send-end recv-start recv-end)) 93 | (multiple-value-bind (sendbuf sendtype sendcount) 94 | (static-vector-mpi-data send-array send-start send-end) 95 | (multiple-value-bind (recvbuf recvtype recvcount) 96 | (static-vector-mpi-data recv-array recv-start recv-end) 97 | (assert (= recvcount sendcount)) 98 | (assert (eq recvtype sendtype)) 99 | (%mpi-allreduce sendbuf recvbuf sendcount sendtype op comm)))) 100 | 101 | (defun mpi-barrier (&optional (comm *standard-communicator*)) 102 | "MPI-BARRIER blocks the caller until all members of COMM have called 103 | it. The call returns at any process only after all members of COMM have 104 | entered the call." 105 | (%mpi-barrier comm)) 106 | 107 | (defun mpi-bcast (array root &key (comm *standard-communicator*) 108 | start end) 109 | "Transfer the contents of ARRAY of the process with rank ROOT to all 110 | members of COMM. The call returns at any process only after all members of 111 | COMM have entered the call. The arguments START and END can be used to 112 | manipulate only a sub-sequence of ARRAY." 113 | (declare (type simple-array array) 114 | (type int root) 115 | (type mpi-comm comm) 116 | (type index start end)) 117 | (multiple-value-bind (ptr type count) 118 | (static-vector-mpi-data array start end) 119 | (%mpi-bcast ptr count type root comm))) 120 | 121 | (defun mpi-reduce (send-array recv-array op root &key (comm *standard-communicator*) 122 | send-start send-end 123 | recv-start recv-end) 124 | "Combine the contents of each SEND-ARRAY element wise with the operation 125 | OP and store the result into the RECV-ARRAY of the process with rank ROOT." 126 | (declare (type simple-array send-array) 127 | (type mpi-op op) 128 | (type int root) 129 | (type mpi-comm comm) 130 | (type index send-start send-end recv-start recv-end)) 131 | (multiple-value-bind (sendbuf sendtype sendcount) 132 | (static-vector-mpi-data send-array send-start send-end) 133 | (if (= (mpi-comm-rank comm) root) 134 | (multiple-value-bind (recvbuf recvtype recvcount) 135 | (static-vector-mpi-data recv-array recv-start recv-end) 136 | (assert (= recvcount sendcount)) 137 | (assert (eq recvtype sendtype)) 138 | (%mpi-reduce sendbuf recvbuf sendcount sendtype op root comm)) 139 | (%mpi-reduce sendbuf (null-pointer) sendcount sendtype op root comm)))) 140 | -------------------------------------------------------------------------------- /mpi/contexts.lisp: -------------------------------------------------------------------------------- 1 | #| -*- Mode: Lisp; indent-tabs-mode: nil -*- 2 | 3 | MPI context handling - groups, communicators, caching 4 | 5 | Copyright (C) 2015 Marco Heisig 6 | 7 | Permission is hereby granted, free of charge, to any person obtaining a copy 8 | of this software and associated documentation files (the "Software"), to deal 9 | in the Software without restriction, including without limitation the rights 10 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 11 | copies of the Software, and to permit persons to whom the Software is 12 | furnished to do so, subject to the following conditions: 13 | 14 | The above copyright notice and this permission notice shall be included in 15 | all copies or substantial portions of the Software. 16 | 17 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 18 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 19 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 20 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 21 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 23 | THE SOFTWARE. 24 | |# 25 | 26 | (in-package :cl-mpi) 27 | 28 | ;; (defmpifun "MPI_COMM_DUP_FN") 29 | ;; (defmpifun "MPI_COMM_NULL_COPY_FN") 30 | ;; (defmpifun "MPI_COMM_NULL_DELETE_FN") 31 | (defmpifun "MPI_Comm_compare" (comm1 comm2 *result)) 32 | (defmpifun "MPI_Comm_create" (comm group *newcomm)) 33 | (defmpifun "MPI_Comm_create_group" (comm group tag *newcomm) :introduced "3.0") 34 | ;; (defmpifun "MPI_Comm_create_keyval") 35 | ;; (defmpifun "MPI_Comm_delete_attr") 36 | (defmpifun "MPI_Comm_dup" (comm *newcomm)) 37 | ;; (defmpifun "MPI_Comm_dup_with_info") 38 | (defmpifun "MPI_Comm_free" (*comm)) 39 | ;; (defmpifun "MPI_Comm_free_keyval") 40 | ;; (defmpifun "MPI_Comm_get_attr") 41 | ;; (defmpifun "MPI_Comm_get_info") 42 | ;; (defmpifun "MPI_Comm_get_name") 43 | (defmpifun "MPI_Comm_group" (comm *group)) 44 | (defmpifun "MPI_Comm_idup" (comm *newcomm *request) :introduced "3.0") 45 | (defmpifun "MPI_Comm_rank" (comm *rank)) 46 | (defmpifun "MPI_Comm_remote_group" (comm *group)) 47 | (defmpifun "MPI_Comm_remote_size" (comm *size)) 48 | ;; (defmpifun "MPI_Comm_set_attr") 49 | ;; (defmpifun "MPI_Comm_set_info") 50 | ;; (defmpifun "MPI_Comm_set_name") 51 | (defmpifun "MPI_Comm_size" (comm *size)) 52 | (defmpifun "MPI_Comm_split" (comm color key *newcomm)) 53 | ;; (defmpifun "MPI_Comm_split_type") 54 | (defmpifun "MPI_Comm_test_inter" (comm *flag)) 55 | (defmpifun "MPI_Group_compare" (group1 group2 *result)) 56 | (defmpifun "MPI_Group_difference" (group1 group2 *newgroup)) 57 | (defmpifun "MPI_Group_excl" (group count ranges *newgroup)) 58 | (defmpifun "MPI_Group_free" (*group)) 59 | (defmpifun "MPI_Group_incl" (group count ranges *newgroup)) 60 | (defmpifun "MPI_Group_intersection" (group1 group2 *newgroup)) 61 | (defmpifun "MPI_Group_range_excl" (group count ranges *newgroup)) 62 | (defmpifun "MPI_Group_range_incl" (group count ranges *newgroup)) 63 | (defmpifun "MPI_Group_rank" (group *rank)) 64 | (defmpifun "MPI_Group_size" (group *size)) 65 | (defmpifun "MPI_Group_translate_ranks" (group1 count ranks1 group2 ranks2)) 66 | (defmpifun "MPI_Group_union" (group1 group2 *newgroup)) 67 | ;; (defmpifun "MPI_Intercomm_create") 68 | ;; (defmpifun "MPI_Intercomm_merge") 69 | ;; (defmpifun "MPI_TYPE_DUP_FN") 70 | ;; (defmpifun "MPI_TYPE_NULL_COPY_FN") 71 | ;; (defmpifun "MPI_TYPE_NULL_DELETE_FN") 72 | ;; (defmpifun "MPI_Type_create_keyval") 73 | ;; (defmpifun "MPI_Type_free_keyval") 74 | ;; (defmpifun "MPI_Type_get_attr") 75 | ;; (defmpifun "MPI_Type_get_name") 76 | ;; (defmpifun "MPI_Type_set_attr") 77 | ;; (defmpifun "MPI_Type_set_name") 78 | ;; (defmpifun "MPI_WIN_DUP_FN") 79 | ;; (defmpifun "MPI_WIN_NULL_COPY_FN") 80 | ;; (defmpifun "MPI_WIN_NULL_DELETE_FN") 81 | ;; (defmpifun "MPI_Win_create_keyval") 82 | ;; (defmpifun "MPI_Win_delete_attr") 83 | ;; (defmpifun "MPI_Win_free_attr") 84 | ;; (defmpifun "MPI_Win_get_attr") 85 | ;; (defmpifun "MPI_Win_get_name") 86 | ;; (defmpifun "MPI_Win_set_attr") 87 | ;; (defmpifun "MPI_Win_set_name") 88 | 89 | (defun mpi-comm-group (&optional (comm *standard-communicator*)) 90 | (declare (type mpi-comm comm)) 91 | (with-foreign-results ((newgroup 'mpi-group)) 92 | (%mpi-comm-group comm newgroup))) 93 | 94 | (defun mpi-group-size (group) 95 | (declare (type mpi-group group)) 96 | (with-foreign-results ((size :int)) 97 | (%mpi-group-size group size))) 98 | 99 | (defun mpi-group-rank (group) 100 | (declare (type mpi-group group)) 101 | (with-foreign-results ((rank :int)) 102 | (%mpi-group-rank group rank))) 103 | 104 | (defun mpi-group-union (group1 group2) 105 | (with-foreign-results ((newgroup 'mpi-group)) 106 | (%mpi-group-union group1 group2 newgroup))) 107 | 108 | (defun mpi-group-intersection (group1 group2) 109 | (with-foreign-results ((newgroup 'mpi-group)) 110 | (%mpi-group-intersection group1 group2 newgroup))) 111 | 112 | (defun mpi-group-difference (group1 group2) 113 | (with-foreign-results ((newgroup 'mpi-group)) 114 | (%mpi-group-difference group1 group2 newgroup))) 115 | 116 | (defun to-mpi-rank-spec (rank-spec) 117 | (let* ((count (length rank-spec)) 118 | (buffer (foreign-alloc :int :count (* 3 count)))) 119 | (loop for spec in rank-spec and i from 0 by 3 120 | with step-size = 1 and last-rank and first-rank do 121 | (etypecase spec 122 | (integer 123 | (setf first-rank spec) 124 | (setf last-rank spec)) 125 | ((cons integer (cons integer null)) 126 | (setf first-rank (car spec)) 127 | (setf last-rank (cadr spec))) 128 | ((cons integer (cons integer (cons integer null))) 129 | (setf first-rank (car spec)) 130 | (setf last-rank (cadr spec)) 131 | (setf step-size (caddr spec)))) 132 | (setf (mem-aref buffer :int (+ i 0)) first-rank) 133 | (setf (mem-aref buffer :int (+ i 1)) last-rank) 134 | (setf (mem-aref buffer :int (+ i 2)) step-size)) 135 | buffer)) 136 | 137 | (defmacro with-mpi-rank-spec ((spec-name count-name) 138 | (rank-spec) &body body) 139 | (check-type spec-name symbol) 140 | (check-type count-name symbol) 141 | (once-only (rank-spec) 142 | `(let ((,count-name (length ,rank-spec)) 143 | (,spec-name (to-mpi-rank-spec ,rank-spec))) 144 | (unwind-protect 145 | (progn ,@body) 146 | (foreign-free ,spec-name))))) 147 | 148 | (defun mpi-group-incl (group &rest rank-spec) 149 | "Create a new MPI group consisting of a subset of the ranks of the original 150 | group. A valid range can be 151 | - an integer 152 | - a list of the form (first-rank last-rank &optional step-size)" 153 | (with-foreign-results ((newgroup 'mpi-group)) 154 | (with-mpi-rank-spec (spec count) (rank-spec) 155 | (%mpi-group-range-incl group count spec newgroup)))) 156 | 157 | (defun mpi-group-excl (group &rest rank-spec) 158 | "Create a new MPI group consisting of a subset of the ranks of the original 159 | group. A valid range can be 160 | - an integer 161 | - a list of the form (first-rank last-rank &optional step-size)" 162 | (with-foreign-results ((newgroup 'mpi-group)) 163 | (with-mpi-rank-spec (spec count) (rank-spec) 164 | (%mpi-group-range-excl group count spec newgroup)))) 165 | 166 | (defun mpi-group-free (&rest groups) 167 | (let ((handle (foreign-alloc 'mpi-group))) 168 | (loop for group in groups do 169 | (setf (mem-ref handle 'mpi-group) group) 170 | (%mpi-group-free handle) 171 | (setf (mpi-object-handle group) 172 | (mem-ref handle #.foreign-mpi-object-type))))) 173 | 174 | (defun mpi-comm-size (&optional (comm *standard-communicator*)) 175 | "Indicates the number of processes involved in a communicator. For 176 | +mpi-comm-world+, it indicates the total number of processes available." 177 | (with-foreign-results ((size :int)) 178 | (%mpi-comm-size comm size))) 179 | 180 | (defun mpi-comm-rank (&optional (comm *standard-communicator*)) 181 | "Returns the rank of the process in a given communicator." 182 | (with-foreign-results ((rank :int)) 183 | (%mpi-comm-rank comm rank))) 184 | 185 | (defun mpi-comm-create (group &key (comm *standard-communicator*)) 186 | (declare (type mpi-group group) 187 | (type mpi-comm comm)) 188 | (with-foreign-results ((newcomm 'mpi-comm)) 189 | (%mpi-comm-create comm group newcomm))) 190 | 191 | (defun mpi-comm-dup (&optional (comm *standard-communicator*)) 192 | (with-foreign-results ((newcomm 'mpi-comm)) 193 | (%mpi-comm-dup comm newcomm))) 194 | 195 | (defun mpi-comm-free (comm) 196 | (let ((handle (foreign-alloc 'mpi-comm))) 197 | (setf (mem-ref handle 'mpi-comm) comm) 198 | (%mpi-comm-free handle) 199 | (setf (mpi-object-handle comm) 200 | (mem-ref handle #.foreign-mpi-object-type))) 201 | comm) 202 | 203 | (defun mpi-comm-split (color key &key (comm *standard-communicator*)) 204 | "Returns new communicator by partitioning a communicator according 205 | to color and key." 206 | (declare (type (or (and int (integer 0)) (eql #.+mpi-undefined+)) color) 207 | (type int key) 208 | (type mpi-comm comm)) 209 | (with-foreign-results ((newcomm 'mpi-comm)) 210 | (%mpi-comm-split comm color key newcomm))) 211 | -------------------------------------------------------------------------------- /mpi/datatypes.lisp: -------------------------------------------------------------------------------- 1 | #| -*- Mode: Lisp; indent-tabs-mode: nil -*- 2 | 3 | MPI datatype handling 4 | 5 | Copyright (C) 2015 Marco Heisig 6 | 7 | Permission is hereby granted, free of charge, to any person obtaining a copy 8 | of this software and associated documentation files (the "Software"), to deal 9 | in the Software without restriction, including without limitation the rights 10 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 11 | copies of the Software, and to permit persons to whom the Software is 12 | furnished to do so, subject to the following conditions: 13 | 14 | The above copyright notice and this permission notice shall be included in 15 | all copies or substantial portions of the Software. 16 | 17 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 18 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 19 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 20 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 21 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 23 | THE SOFTWARE. 24 | |# 25 | 26 | (in-package :cl-mpi) 27 | 28 | ;; (defmpifun "MPI_Get_address") 29 | ;; (defmpifun "MPI_Get_elements") 30 | ;; (defmpifun "MPI_Get_elements_x") 31 | (defmpifun "MPI_Pack" (*inbuf incount datatype *outbuf outsize *position comm)) 32 | ;; (defmpifun "MPI_Pack_external") 33 | ;; (defmpifun "MPI_Pack_external_size") 34 | (defmpifun "MPI_Pack_size" (incount datatype comm *size)) 35 | ;; (defmpifun "MPI_Type_commit" (*datatype)) 36 | ;; (defmpifun "MPI_Type_contiguous" (count oldtype *newtype)) 37 | ;; (defmpifun "MPI_Type_create_darray") 38 | ;; (defmpifun "MPI_Type_create_hindexed") 39 | ;; (defmpifun "MPI_Type_create_hindexed_block") 40 | ;; (defmpifun "MPI_Type_create_hvector") 41 | ;; (defmpifun "MPI_Type_create_indexed_block") 42 | ;; (defmpifun "MPI_Type_create_resized") 43 | ;; (defmpifun "MPI_Type_create_struct") 44 | ;; (defmpifun "MPI_Type_create_subarray") 45 | ;; (defmpifun "MPI_Type_dup" (oldtype *newtype)) 46 | ;; (defmpifun "MPI_Type_free" (*datatype)) 47 | ;; (defmpifun "MPI_Type_get_contents") 48 | ;; (defmpifun "MPI_Type_get_envelope") 49 | ;; (defmpifun "MPI_Txpe_get_extent") 50 | ;; (defmpifun "MPI_Type_get_extent_x") 51 | ;; (defmpifun "MPI_Type_get_true_extent") 52 | ;; (defmpifun "MPI_Type_get_true_extent_x") 53 | ;; (defmpifun "MPI_Type_indexed") 54 | (defmpifun "MPI_Type_size" (datatype *size)) 55 | ;; (defmpifun "MPI_Type_size_x" (datatype *size)) 56 | ;; (defmpifun "MPI_Type_vector") 57 | (defmpifun "MPI_Unpack" (*inbuf insize *position *outbuf outcount datatype comm)) 58 | ;; (defmpifun "MPI_Unpack_external") 59 | 60 | (declaim (ftype (function (mpi-datatype) int) mpi-type-size)) 61 | (defun mpi-type-size (datatype) 62 | (with-foreign-results ((size :int)) 63 | (%mpi-type-size datatype size))) 64 | -------------------------------------------------------------------------------- /mpi/environment.lisp: -------------------------------------------------------------------------------- 1 | #| -*- Mode: Lisp; indent-tabs-mode: nil -*- 2 | 3 | MPI environmental management 4 | 5 | Copyright (c) 2008,2009 Alex Fukunaga 6 | Copyright (C) 2014,2015 Marco Heisig 7 | 8 | Permission is hereby granted, free of charge, to any person obtaining a copy 9 | of this software and associated documentation files (the "Software"), to deal 10 | in the Software without restriction, including without limitation the rights 11 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 12 | copies of the Software, and to permit persons to whom the Software is 13 | furnished to do so, subject to the following conditions: 14 | 15 | The above copyright notice and this permission notice shall be included in 16 | all copies or substantial portions of the Software. 17 | 18 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 19 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 20 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 21 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 22 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 23 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 24 | THE SOFTWARE. 25 | |# 26 | 27 | (in-package :cl-mpi) 28 | 29 | (defcfun "MPI_Wtime" :double 30 | "Returns a (double) floating-point number of seconds, representing elapsed 31 | wall-clock time since some time in the past. 32 | 33 | The 'time in the past' is guaranteed not to change during the life of the 34 | process. The user is responsible for converting large numbers of seconds to 35 | other units if they are preferred. This function is portable (it returns 36 | seconds, not 'ticks'), it allows high-resolution, and carries no unnecessary 37 | baggage. The times returned are local to the node that called them. There is 38 | no requirement that different nodes return 'the same time.'") 39 | 40 | (defcfun "MPI_Wtick" :double 41 | "Returns the resolution of MPI-WTIME in seconds. That is, it returns, as a 42 | double precision value, the number of seconds between successive clock 43 | ticks. For example, if the clock is implemented by the hardware as a counter 44 | that is incremented every millisecond, the value returned by MPI-WTICK should 45 | be 0.001") 46 | 47 | (defmpifun "MPI_Abort" (comm errorcode)) 48 | ;; (defmpifun "MPI_Add_error_class") 49 | ;; (defmpifun "MPI_Add_error_code") 50 | ;; (defmpifun "MPI_Add_error_string") 51 | (defmpifun "MPI_Alloc_mem" (count ptr *buf)) 52 | (defmpifun "MPI_Comm_call_errhandler" (comm errorcode)) 53 | ;; (defmpifun "MPI_Comm_create_errhandler") 54 | ;; (defmpifun "MPI_Comm_get_errhandler") 55 | (defmpifun "MPI_Comm_set_errhandler" (comm errhandler)) 56 | ;; (defmpifun "MPI_Errhandler_free") 57 | ;; (defmpifun "MPI_Error_class") 58 | (defmpifun "MPI_Error_string" (errorcode string *size)) 59 | ;; (defmpifun "MPI_File_call_errhandler") 60 | ;; (defmpifun "MPI_File_create_errhandler") 61 | ;; (defmpifun "MPI_File_get_errhandler") 62 | ;; (defmpifun "MPI_File_set_errhandler") 63 | (defmpifun "MPI_Finalize" ()) 64 | (defmpifun "MPI_Finalized" (*flag)) 65 | (defmpifun "MPI_Free_mem" (ptr)) 66 | ;; (defmpifun "MPI_Get_library_version") 67 | (defmpifun "MPI_Get_processor_name" (string *size)) 68 | ;; (defmpifun "MPI_Get_version") 69 | (defmpifun "MPI_Init" (argc argv)) 70 | (defmpifun "MPI_Init_thread" (argc argv (required mpi-thread-options) (provided :pointer))) 71 | (defmpifun "MPI_Initialized" (*flag)) 72 | ;; (defmpifun "MPI_Win_call_errhandler") 73 | ;; (defmpifun "MPI_Win_create_errhandler") 74 | ;; (defmpifun "MPI_Win_get_errhandler") 75 | ;; (defmpifun "MPI_Win_set_errhandler") 76 | 77 | (defun mpi-init (&key (thread-support nil thread-support-p)) 78 | "Initialize MPI. If supplied, the keyword parameter THREAD-SUPPORT 79 | denotes the required level of thread support in MPI. It must be one of the 80 | following keywords: 81 | 82 | :MPI-THREAD-SINGLE - Only one thread will ever execute. 83 | 84 | :MPI-THREAD-FUNNELED - The process may be multi-threaded, but the 85 | application must ensure that only the main thread makes MPI calls. 86 | 87 | :MPI-THREAD-SERIALIZED - The process may be multi-threaded, and multiple 88 | threads may make MPI calls, but not concurrently from two distinct 89 | threads. 90 | 91 | :MPI-THREAD-MULTIPLE - Multiple threads may call MPI, with no restrictions. 92 | 93 | An error is signaled when the MPI implementation fails to provide the 94 | required level of thread support." 95 | (unless (mpi-initialized) 96 | ;; Initialize cl-mpi constants like +MPI-COMM-WORLD+. 97 | (initialize-mpi-constants) 98 | (if (not thread-support-p) 99 | (%mpi-init (null-pointer) (null-pointer)) 100 | (let ((required 101 | (cffi:foreign-enum-value 'mpi-thread-options thread-support)) 102 | (provided 103 | (with-foreign-results ((provided :int)) 104 | (%mpi-init-thread (null-pointer) (null-pointer) 105 | thread-support provided)))) 106 | (when (> required provided) 107 | (error "The required level of thread support is ~W,~@ 108 | but this MPI implementation can only provide ~W." 109 | thread-support 110 | (cffi:foreign-enum-keyword 'mpi-thread-options provided))))) 111 | ;; by default MPI reacts to each failure by crashing the process. This is 112 | ;; not the Lisp way of doing things. The following call makes errors 113 | ;; non-fatal in most cases. 114 | (%mpi-comm-set-errhandler +mpi-comm-world+ +mpi-errors-return+))) 115 | 116 | (defun mpi-finalize () 117 | "This routines cleans up all MPI state. Once this routine is called, no MPI 118 | routine (even MPI-INIT) may be called. The user must ensure that all pending 119 | communications involving a process complete before the process calls 120 | MPI-FINALIZE." 121 | (when (mpi-initialized) 122 | (unless (mpi-finalized) 123 | (mpi-buffer-detach) 124 | (%mpi-finalize)))) 125 | 126 | (defun mpi-initialized () 127 | "Returns true if MPI_INIT has been called and nil otherwise. 128 | This routine may be used to determine whether MPI-INIT has been called. It 129 | is the only routine that may be called before MPI-INIT is called." 130 | (with-foreign-results ((flag :boolean)) 131 | (%mpi-initialized flag))) 132 | 133 | (defun mpi-finalized () 134 | "Returns true if MPI_FINALIZE has been called and nil otherwise." 135 | (with-foreign-results ((flag :boolean)) 136 | (%mpi-finalized flag))) 137 | 138 | (defun mpi-abort(&key (comm *standard-communicator*) (errcode -1)) 139 | "This routine makes a 'best attempt' to abort all tasks in the group of 140 | comm. This function does not require that the invoking environment take any 141 | action with the error code. However, a Unix or POSIX environment should handle 142 | this as a return errorcode from the main program or an abort(errorcode)." 143 | (%mpi-abort comm errcode)) 144 | 145 | (defun mpi-get-processor-name () 146 | "This routine returns the name of the processor on which it was called at 147 | the moment of the call. The name is a character string for maximum 148 | flexibility. From this value it must be possible to identify a specific piece 149 | of hardware; possible values include 'processor 9 in rack 4 of mpp.cs.org' and 150 | '231' (where 231 is the actual processor number in the running homogeneous 151 | system)." 152 | (with-foreign-object (namelen :int) 153 | (with-foreign-pointer (processor-name +mpi-max-processor-name+) 154 | (%mpi-get-processor-name processor-name namelen) 155 | (values (foreign-string-to-lisp 156 | processor-name 157 | :count (mem-aref namelen :int)))))) 158 | 159 | (defun mpi-error-string (errorcode) 160 | "Convert the given errorcode to a human readable error message" 161 | (declare (type int errorcode)) 162 | (with-foreign-object (strlen :int) 163 | (with-foreign-pointer (error-string +mpi-max-error-string+) 164 | (%mpi-error-string errorcode error-string strlen) 165 | (values (foreign-string-to-lisp 166 | error-string 167 | :count (mem-aref strlen :int)))))) 168 | -------------------------------------------------------------------------------- /mpi/grovel.lisp: -------------------------------------------------------------------------------- 1 | ;;;; extract all MPI symbols from mpi.h 2 | 3 | (include "mpi.h") 4 | 5 | (in-package :cl-mpi) 6 | 7 | ;;; optional and MPI implementation specific constants 8 | (constant (|MPICH| "MPICH") :optional t) 9 | (constant (|MPICH_VERSION| "MPICH_VERSION") :optional t) 10 | 11 | (constant (|MPICH2| "MPICH2") :optional t) 12 | (constant (|MPICH2_VERSION| "MPICH2_VERSION") :optional t) 13 | 14 | (constant (|OPEN_MPI| "OPEN_MPI") :optional t) 15 | (constant (|OPEN_MPI_MAJOR_VERSION| "OMPI_MAJOR_VERSION") :optional t) 16 | (constant (|OPEN_MPI_MINOR_VERSION| "OMPI_MINOR_VERSION") :optional t) 17 | (constant (|OPEN_MPI_RELEASE_VERSION| "OMPI_RELEASE_VERSION") :optional t) 18 | 19 | ;;; standardized MPI constants 20 | 21 | (constant (|MPI_VERSION| "MPI_VERSION")) 22 | (constant (|MPI_SUBVERSION| "MPI_SUBVERSION")) 23 | (constant (+mpi-any-source+ "MPI_ANY_SOURCE")) 24 | (constant (+mpi-proc-null+ "MPI_PROC_NULL")) 25 | (constant (+mpi-root+ "MPI_ROOT")) 26 | (constant (+mpi-any-tag+ "MPI_ANY_TAG")) 27 | (constant (+mpi-undefined+ "MPI_UNDEFINED")) 28 | 29 | (constant (+mpi-max-processor-name+ "MPI_MAX_PROCESSOR_NAME")) 30 | (constant (+mpi-max-error-string+ "MPI_MAX_ERROR_STRING")) 31 | 32 | (cenum (mpi-thread-options :base-type :int) 33 | ((:mpi-thread-single "MPI_THREAD_SINGLE")) 34 | ((:mpi-thread-funneled "MPI_THREAD_FUNNELED")) 35 | ((:mpi-thread-serialized "MPI_THREAD_SERIALIZED")) 36 | ((:mpi-thread-multiple "MPI_THREAD_MULTIPLE"))) 37 | 38 | (cstruct mpi-status "MPI_Status" 39 | (mpi-source "MPI_SOURCE" :type :int) 40 | (mpi-tag "MPI_TAG" :type :int) 41 | (mpi-error "MPI_ERROR" :type :int)) 42 | -------------------------------------------------------------------------------- /mpi/one-sided.lisp: -------------------------------------------------------------------------------- 1 | #| -*- Mode: Lisp; indent-tabs-mode: nil -*- 2 | 3 | MPI one-sided communications 4 | 5 | Copyright (c) 2008,2009 Alex Fukunaga 6 | Copyright (C) 2014,2015 Marco Heisig 7 | 8 | Permission is hereby granted, free of charge, to any person obtaining a copy 9 | of this software and associated documentation files (the "Software"), to deal 10 | in the Software without restriction, including without limitation the rights 11 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 12 | copies of the Software, and to permit persons to whom the Software is 13 | furnished to do so, subject to the following conditions: 14 | 15 | The above copyright notice and this permission notice shall be included in 16 | all copies or substantial portions of the Software. 17 | 18 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 19 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 20 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 21 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 22 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 23 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 24 | THE SOFTWARE. 25 | |# 26 | 27 | (in-package :mpi) 28 | 29 | #| 30 | (defmpifun "MPI_Accumulate" (*origin_addr origin_count origin_datatype target_rank target_disp target_count target_datatype op win) :introduced "2.0") 31 | (defmpifun "MPI_Compare_and_swap" (*origin_addr *compare_addr *result_addr datatype target_rank target_disp win) :introduced "3.0") 32 | (defmpifun "MPI_Fetch_and_op" () :introduced "3.0") 33 | (defmpifun "MPI_Get" () :introduced "2.0") 34 | (defmpifun "MPI_Get_accumulate" () :introduced "3.0") 35 | (defmpifun "MPI_Put" () :introduced "2.0") 36 | (defmpifun "MPI_Raccumulate" () :introduced "3.0") 37 | (defmpifun "MPI_Rget" () :introduced "3.0") 38 | (defmpifun "MPI_Rget_accumulate" () :introduced "3.0") 39 | (defmpifun "MPI_Rput" () :introduced "3.0") 40 | (defmpifun "MPI_Win_allocate" () :introduced "3.0") 41 | (defmpifun "MPI_Win_allocate_shared" () :introduced "3.0") 42 | (defmpifun "MPI_Win_attach" () :introduced "3.0") 43 | (defmpifun "MPI_Win_complete" () :introduced "2.0") 44 | (defmpifun "MPI_Win_create" () :introduced "2.0") 45 | (defmpifun "MPI_Win_create_dynamic" () :introduced "3.0") 46 | (defmpifun "MPI_Win_detach" () :introduced "3.0") 47 | (defmpifun "MPI_Win_fence" () :introduced "2.0") 48 | (defmpifun "MPI_Win_flush" () :introduced "3.0") 49 | (defmpifun "MPI_Win_flush_all" () :introduced "3.0") 50 | (defmpifun "MPI_Win_flush_local" () :introduced "3.0") 51 | (defmpifun "MPI_Win_flush_local_all" () :introduced "3.0") 52 | (defmpifun "MPI_Win_free" (*win) :introduced "2.0") 53 | (defmpifun "MPI_Win_get_group" (win *group) :introduced "2.0") 54 | (defmpifun "MPI_Win_get_info" (win *info_used) :introduced "3.0") 55 | (defmpifun "MPI_Win_lock" () :introduced "2.0") 56 | (defmpifun "MPI_Win_lock_all" () :introduced "3.0") 57 | (defmpifun "MPI_Win_post" (group assert win) :introduced "2.0") 58 | (defmpifun "MPI_Win_set_info" (win info) :introduced "3.0") 59 | (defmpifun "MPI_Win_shared_query" () :introduced "3.0") 60 | (defmpifun "MPI_Win_start" () :introduced "2.0") 61 | (defmpifun "MPI_Win_sync" (win) :introduced "3.0") 62 | (defmpifun "MPI_Win_test" (win *flag) :introduced "2.0") 63 | (defmpifun "MPI_Win_unlock" (rank win) :introduced "2.0") 64 | (defmpifun "MPI_Win_unlock_all" (rank win) :introduced "3.0") 65 | (defmpifun "MPI_Win_wait" (win) :introduced "2.0") 66 | |# 67 | -------------------------------------------------------------------------------- /mpi/packages.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :mpi 2 | (:nicknames :cl-mpi) 3 | (:documentation 4 | "CL-MPI: Common Lisp bindings for the Message Passing Interface MPI") 5 | (:use :cl :cffi :static-vectors :alexandria) 6 | (:import-from :uiop #:version<=) 7 | (:export 8 | 9 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 10 | ;;; grovel.lisp 11 | 12 | #:+mpi-any-source+ 13 | #:+mpi-proc-null+ 14 | #:+mpi-root+ 15 | #:+mpi-any-tag+ 16 | #:+mpi-undefined+ 17 | 18 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 19 | ;;; setup.lisp 20 | 21 | #:+mpi-version+ 22 | 23 | ;; MPI types 24 | #:mpi-error-condition 25 | #:mpi-object 26 | #:mpi-errhandler 27 | #:mpi-comm 28 | #:mpi-group 29 | #:mpi-datatype 30 | #:mpi-op 31 | #:mpi-info 32 | #:mpi-request 33 | 34 | ;; MPI constants 35 | #:+mpi-library+ 36 | #:+mpi-implementation+ 37 | #:+mpi-implementation-version+ 38 | 39 | #:+mpi-errors-return+ 40 | #:+mpi-errors-are-fatal+ 41 | #:+mpi-group-empty+ 42 | #:+mpi-comm-world+ 43 | #:+mpi-comm-self+ 44 | #:+mpi-char+ 45 | #:+mpi-signed-char+ 46 | #:+mpi-unsigned-char+ 47 | #:+mpi-byte+ 48 | #:+mpi-short+ 49 | #:+mpi-unsigned-short+ 50 | #:+mpi-int+ 51 | #:+mpi-unsigned+ 52 | #:+mpi-long+ 53 | #:+mpi-unsigned-long+ 54 | #:+mpi-long-long-int+ 55 | #:+mpi-unsigned-long-long+ 56 | #:+mpi-float+ 57 | #:+mpi-double+ 58 | #:+mpi-long-double+ 59 | #:+mpi-wchar+ 60 | #:+mpi-c-bool+ 61 | #:+mpi-int8-t+ 62 | #:+mpi-int16-t+ 63 | #:+mpi-int32-t+ 64 | #:+mpi-int64-t+ 65 | #:+mpi-uint8-t+ 66 | #:+mpi-uint16-t+ 67 | #:+mpi-uint32-t+ 68 | #:+mpi-uint64-t+ 69 | #:+mpi-packed+ 70 | #:+mpi-min+ 71 | #:+mpi-max+ 72 | #:+mpi-sum+ 73 | #:+mpi-prod+ 74 | #:+mpi-land+ 75 | #:+mpi-band+ 76 | #:+mpi-lor+ 77 | #:+mpi-bor+ 78 | #:+mpi-lxor+ 79 | #:+mpi-bxor+ 80 | #:+mpi-maxloc+ 81 | #:+mpi-minloc+ 82 | #:+mpi-replace+ 83 | #:*standard-communicator* 84 | 85 | ;; null handles 86 | #:+mpi-group-null+ 87 | #:+mpi-comm-null+ 88 | #:+mpi-op-null+ 89 | #:+mpi-request-null+ 90 | #:+mpi-datatype-null+ 91 | 92 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 93 | ;;; utilities.lisp 94 | 95 | #:mpi-equal 96 | #:mpi-null 97 | 98 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 99 | ;;; datatypes.lisp 100 | 101 | #:mpi-type-size 102 | 103 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 104 | ;;; collective.lisp 105 | 106 | #:mpi-barrier 107 | #:mpi-bcast 108 | #:mpi-allgather 109 | #:mpi-allreduce 110 | #:mpi-reduce 111 | 112 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 113 | ;;; contexts.lisp 114 | 115 | #:mpi-comm-group 116 | #:mpi-comm-split 117 | #:mpi-group-size 118 | #:mpi-group-rank 119 | #:mpi-group-union 120 | #:mpi-group-intersection 121 | #:mpi-group-difference 122 | #:mpi-group-incl 123 | #:mpi-group-excl 124 | #:mpi-group-free 125 | #:mpi-comm-size 126 | #:mpi-comm-rank 127 | #:mpi-comm-create 128 | #:mpi-comm-dup 129 | #:mpi-comm-free 130 | 131 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 132 | ;;; environment.lisp 133 | 134 | #:mpi-wtime 135 | #:mpi-wtick 136 | #:mpi-finalize 137 | #:mpi-init 138 | #:mpi-initialized 139 | #:mpi-finalized 140 | #:mpi-abort 141 | #:mpi-get-processor-name 142 | #:mpi-error-string 143 | 144 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 145 | ;;; point-to-point.lisp 146 | 147 | #:mpi-demand-buffering 148 | #:mpi-sendrecv 149 | #:mpi-send 150 | #:mpi-isend 151 | #:mpi-recv 152 | #:mpi-irecv 153 | #:mpi-probe 154 | #:mpi-iprobe 155 | #:mpi-test 156 | #:mpi-wait 157 | #:mpi-waitall 158 | 159 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 160 | ;;; one-sided.lisp 161 | 162 | )) 163 | -------------------------------------------------------------------------------- /mpi/point-to-point.lisp: -------------------------------------------------------------------------------- 1 | #| -*- Mode: Lisp; indent-tabs-mode: nil -*- 2 | 3 | MPI point to point communication functions 4 | 5 | Copyright (c) 2008,2009 Alex Fukunaga 6 | Copyright (C) 2014,2015 Marco Heisig 7 | 8 | Permission is hereby granted, free of charge, to any person obtaining a copy 9 | of this software and associated documentation files (the "Software"), to deal 10 | in the Software without restriction, including without limitation the rights 11 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 12 | copies of the Software, and to permit persons to whom the Software is 13 | furnished to do so, subject to the following conditions: 14 | 15 | The above copyright notice and this permission notice shall be included in 16 | all copies or substantial portions of the Software. 17 | 18 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 19 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 20 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 21 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 22 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 23 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 24 | THE SOFTWARE. 25 | |# 26 | 27 | (in-package :cl-mpi) 28 | 29 | (defmpifun "MPI_Bsend" (*buf count datatype dest tag comm)) 30 | (defmpifun "MPI_Bsend_init" (*buf count datatype dest tag comm *request)) 31 | (defmpifun "MPI_Buffer_attach" (*buf size)) 32 | (defmpifun "MPI_Buffer_detach" (*buf *size)) 33 | (defmpifun "MPI_Cancel" (*request)) 34 | (defmpifun "MPI_Get_count" (*status datatype *count)) 35 | (defmpifun "MPI_Ibsend" (*buf count datatype dest tag comm *request)) 36 | (defmpifun "MPI_Improbe" (source tag comm *flag *message *status) :introduced "3.0") 37 | (defmpifun "MPI_Imrecv" (*buf count datatype *message *request) :introduced "3.0") 38 | (defmpifun "MPI_Iprobe" (source tag comm *flag *status)) 39 | (defmpifun "MPI_Irecv" (*buf count datatype source tag comm *request)) 40 | (defmpifun "MPI_Irsend" (*buf count datatype dest tag comm *request)) 41 | (defmpifun "MPI_Isend" (*buf count datatype dest tag comm *request)) 42 | (defmpifun "MPI_Issend" (*buf count datatype dest tag comm *request)) 43 | (defmpifun "MPI_Mprobe" (source tag comm *message *status) :introduced "3.0") 44 | (defmpifun "MPI_Mrecv" (*buf count datatype *message *status) :introduced "3.0") 45 | (defmpifun "MPI_Probe" (source tag comm *status)) 46 | (defmpifun "MPI_Recv" (*buf count datatype source tag comm *status)) 47 | (defmpifun "MPI_Recv_init" (*buf count datatype source tag comm *request)) 48 | (defmpifun "MPI_Request_free" (*request)) 49 | (defmpifun "MPI_Request_get_status" (request *flag *status) :introduced "2.1") 50 | (defmpifun "MPI_Rsend" (*buf count datatype dest tag comm)) 51 | (defmpifun "MPI_Rsend_init" (*buf count datatype dest tag comm *request)) 52 | (defmpifun "MPI_Send" (*buf count datatype dest tag comm)) 53 | (defmpifun "MPI_Send_init" (*buf count datatype dest tag comm *request)) 54 | (defmpifun "MPI_Sendrecv" (*sendbuf sendcount sendtype dest sendtag *recvbuf recvcount recvtype source recvtag comm *status)) 55 | (defmpifun "MPI_Sendrecv_replace" (*buf count datatype dest sendtag source recvtag comm *status)) 56 | (defmpifun "MPI_Ssend" (*buf count datatype dest tag comm)) 57 | (defmpifun "MPI_Ssend_init" (*buf count datatype dest tag comm *request)) 58 | (defmpifun "MPI_Start" (*request)) 59 | (defmpifun "MPI_Startall" (count requests)) 60 | (defmpifun "MPI_Test" (*request *flag *status)) 61 | (defmpifun "MPI_Test_cancelled" (*status *flag)) 62 | (defmpifun "MPI_Testall" (count requests *flag statuses)) 63 | (defmpifun "MPI_Testany" (count requests *index *flag *status)) 64 | (defmpifun "MPI_Testsome" (incount requests *outcount indices statuses)) 65 | (defmpifun "MPI_Wait" (*request *status)) 66 | (defmpifun "MPI_Waitall" (count requests statuses)) 67 | (defmpifun "MPI_Waitany" (count requests *index *status)) 68 | (defmpifun "MPI_Waitsome" (incount requests *outcount indices statuses)) 69 | 70 | (defvar *current-buffer* nil) 71 | 72 | (defun mpi-demand-buffering (size) 73 | "Ensure that the MPI buffer that is used for blocking commands has a size 74 | of at least SIZE bytes." 75 | (declare (type int size)) 76 | (when (> size (length *current-buffer*)) 77 | (mpi-buffer-detach) 78 | (let ((buffer (make-static-vector size))) 79 | (%mpi-buffer-attach (static-vector-pointer buffer) size) 80 | (setf *current-buffer* buffer) 81 | (values)))) 82 | 83 | (defun mpi-buffer-detach () 84 | "Release the resources that MPI uses for messages with :MODE :BUFFERING." 85 | (when *current-buffer* 86 | (let ((buffer *current-buffer*)) 87 | (with-foreign-objects ((pointer :pointer) 88 | (size :int)) 89 | (%mpi-buffer-detach pointer size)) 90 | (setf *current-buffer* nil) 91 | (free-static-vector buffer) 92 | (values)))) 93 | 94 | (defun mpi-sendrecv (send-data dest recv-data source 95 | &key (comm *standard-communicator*) 96 | (send-tag 0) 97 | (recv-tag +mpi-any-tag+) 98 | send-start send-end 99 | recv-start recv-end) 100 | "Simultaneously send and receive a message. Behaves as if calls to 101 | MPI-SEND and MPI-RECV were issued in separate threads that were then 102 | joined. 103 | 104 | Returns three values: 105 | 106 | 1. The size of the incoming message in bytes. 107 | 108 | 2. The rank of the sender of the received message. This value is 109 | particularly useful if the SOURCE was specified as +MPI-ANY-SOURCE+. 110 | 111 | 3. The tag of the sender of the received message. This value is 112 | particularly useful if the TAG was specified as +MPI-ANY-TAG+. 113 | " 114 | (declare (type simple-array send-data recv-data) 115 | (type int dest send-tag source recv-tag) 116 | (type mpi-comm comm) 117 | (type index 118 | send-start send-end recv-start recv-end)) 119 | (multiple-value-bind (send-buf send-type send-count) 120 | (static-vector-mpi-data send-data send-start send-end) 121 | (multiple-value-bind (recv-buf recv-type recv-count) 122 | (static-vector-mpi-data recv-data recv-start recv-end) 123 | (with-foreign-object (status '(:struct mpi-status)) 124 | (%mpi-sendrecv 125 | send-buf send-count send-type dest send-tag 126 | recv-buf recv-count recv-type source recv-tag 127 | comm status) 128 | (with-foreign-slots ((mpi-tag mpi-source mpi-error) status (:struct mpi-status)) 129 | (values 130 | (with-foreign-results ((count :int)) 131 | (%mpi-get-count status +mpi-byte+ count)) 132 | mpi-source 133 | mpi-tag)))))) 134 | 135 | (defun mpi-send (array dest &key (comm *standard-communicator*) 136 | start end 137 | (tag 0) 138 | (mode :basic)) 139 | "Send a given ARRAY to a corresponding MPI-RECV. The arrays passed to 140 | MPI-SEND and MPI-RECV must be of type SIMPLE-ARRAY and have the same 141 | element-type and dimensions. Undefined behaviour occurs if the arrays at 142 | sender and receiver side do not match." 143 | (declare (type simple-array array) 144 | (type int dest tag) 145 | (type mpi-comm comm) 146 | (type (member :basic :buffered :synchronous :ready) mode) 147 | (type index start end)) 148 | (let ((send-function 149 | (ecase mode 150 | (:basic #'%mpi-send) 151 | (:buffered #'%mpi-bsend) 152 | (:synchronous #'%mpi-ssend) 153 | (:ready #'%mpi-rsend)))) 154 | (multiple-value-bind (ptr type count) 155 | (static-vector-mpi-data array start end) 156 | (funcall send-function ptr count type dest tag comm)))) 157 | 158 | (defun mpi-isend (array dest &key (comm *standard-communicator*) 159 | start 160 | end 161 | (tag 0) 162 | (mode :basic)) 163 | "A non-blocking variant of MPI-SEND. Returns a MPI-REQUEST that can be 164 | passed to MPI-TEST, MPI-WAIT and MPI-WAITALL. 165 | 166 | WARNING: The caller of MPI-ISEND is responsible that the given array is not 167 | relocated or garbage-collected until the send operation is complete. This can 168 | be achieved by using STATIC-VECTORS or some implementation dependent 169 | mechanism such as sb-sys:with-pinned-objects." 170 | (declare (type simple-array array) 171 | (type int dest tag) 172 | (type mpi-comm comm) 173 | (type (member :basic :buffered :synchronous :ready) mode) 174 | (type index start end)) 175 | (let ((send-function 176 | (ecase mode 177 | (:basic #'%mpi-isend) 178 | (:buffered #'%mpi-ibsend) 179 | (:synchronous #'%mpi-issend) 180 | (:ready #'%mpi-irsend)))) 181 | (multiple-value-bind (ptr type count) 182 | (static-vector-mpi-data array start end) 183 | (with-foreign-results ((request 'mpi-request)) 184 | (funcall send-function ptr count type dest tag comm request))))) 185 | 186 | (defun mpi-recv (array source &key (comm *standard-communicator*) 187 | start end 188 | (tag +mpi-any-tag+)) 189 | "Blocks until a message from a process with rank SOURCE and tag TAG has 190 | been received. 191 | 192 | Returns three values: 193 | 194 | 1. The size of the incoming message in bytes. 195 | 196 | 2. The rank of the sender of the message. This value is particularly 197 | useful if the SOURCE was specified as +MPI-ANY-SOURCE+. 198 | 199 | 3. The tag of the sender of the message. This value is particularly 200 | useful if the TAG was specified as +MPI-ANY-TAG+. 201 | " 202 | (declare (type simple-array array) 203 | (type int source tag) 204 | (type mpi-comm comm) 205 | (type index start end)) 206 | (multiple-value-bind (ptr type count) 207 | (static-vector-mpi-data array start end) 208 | (with-foreign-object (status '(:struct mpi-status)) 209 | (%mpi-recv ptr count type source tag comm status) 210 | (with-foreign-slots ((mpi-tag mpi-source mpi-error) status (:struct mpi-status)) 211 | (values 212 | (with-foreign-results ((count :int)) 213 | (%mpi-get-count status +mpi-byte+ count)) 214 | mpi-source 215 | mpi-tag))))) 216 | 217 | (defun mpi-irecv (array source &key (comm *standard-communicator*) 218 | start end 219 | (tag +mpi-any-tag+)) 220 | (declare (type simple-array array) 221 | (type int source tag) 222 | (type mpi-comm comm) 223 | (type index start end)) 224 | (multiple-value-bind (ptr type count) 225 | (static-vector-mpi-data array start end) 226 | (with-foreign-results ((request 'mpi-request)) 227 | (%mpi-irecv ptr count type source tag comm request)))) 228 | 229 | (defun mpi-probe (source &key 230 | (tag +mpi-any-tag+) 231 | (comm *standard-communicator*)) 232 | "Block until a message with matching TAG and SOURCE has been sent on the 233 | communicator COMM. 234 | 235 | Returns three values: 236 | 237 | 1. The size of the incoming message in bytes. 238 | 239 | 2. The rank of the sender of the message. This value is particularly 240 | useful if the SOURCE was specified as +MPI-ANY-SOURCE+. 241 | 242 | 3. The tag of the sender of the message. This value is particularly 243 | useful if the TAG was specified as +MPI-ANY-TAG+. 244 | " 245 | (declare (type int source tag) 246 | (type mpi-comm comm)) 247 | (with-foreign-object (status '(:struct mpi-status)) 248 | (%mpi-probe source tag comm status) 249 | (with-foreign-slots ((mpi-tag mpi-source mpi-error) status (:struct mpi-status)) 250 | (values 251 | (with-foreign-results ((count :int)) 252 | (%mpi-get-count status +mpi-byte+ count)) 253 | mpi-source 254 | mpi-tag)))) 255 | 256 | (defun mpi-iprobe (source &key 257 | (tag +mpi-any-tag+) 258 | (comm *standard-communicator*)) 259 | "Checks whether a message with matching TAG and SOURCE has been sent on 260 | the communicator COMM. If so, it returns three values: The size of the 261 | incoming message in bytes, and the rank and tag of the sender. Otherwise, 262 | it returns false. 263 | 264 | MPI makes a progress guarantee, such that repeated calls to MPI-IPROBE to 265 | a message that has been sent will eventually succeed." 266 | (declare (type int source tag) 267 | (type mpi-comm comm)) 268 | (with-foreign-objects ((status '(:struct mpi-status)) 269 | (flag :int)) 270 | (%mpi-iprobe source tag comm flag status) 271 | (unless (zerop (mem-ref flag :int)) 272 | (with-foreign-slots ((mpi-tag mpi-source mpi-error) status (:struct mpi-status)) 273 | (values 274 | (with-foreign-results ((count :int)) 275 | (%mpi-get-count status +mpi-byte+ count)) 276 | mpi-source 277 | mpi-tag))))) 278 | 279 | (defun mpi-test (request) 280 | "Returns whether REQUEST has been completed. 281 | 282 | MPI makes a progress guarantee, such that repeated calls to MPI-TEST to a 283 | request whose matching operation has been issued will eventually succeed." 284 | (declare (type mpi-request request)) 285 | (with-foreign-objects ((status* '(:struct mpi-status)) 286 | (flag* :int) 287 | (request* 'mpi-request)) 288 | (setf (mem-ref request* 'mpi-request) request) 289 | (%mpi-test request* flag* status*) 290 | (setf (mpi-object-handle request) 291 | (mem-ref request* #.foreign-mpi-object-type)) 292 | (values (not (zerop (mem-ref flag* :int))) request))) 293 | 294 | (defun mpi-wait (request) 295 | "Blocks until REQUEST has been completed." 296 | (declare (type mpi-request request)) 297 | (with-foreign-objects ((status* '(:struct mpi-status)) 298 | (request* 'mpi-request)) 299 | (setf (mem-ref request* 'mpi-request) request) 300 | (%mpi-wait request* status*) 301 | (setf (mpi-object-handle request) 302 | (mem-ref request* #.foreign-mpi-object-type)) 303 | request)) 304 | 305 | (defun mpi-waitall (&rest requests) 306 | "MPI-WAITALL blocks until all given requests have been completed. It 307 | returns REQUESTS." 308 | (let ((n-requests (length requests))) 309 | (with-foreign-objects ((requests* 'mpi-request n-requests) 310 | (statuses* '(:struct mpi-status) n-requests)) 311 | (loop for request in requests 312 | and i below n-requests do 313 | (setf (mem-aref requests* 'mpi-request i) request)) 314 | (%mpi-waitall n-requests requests* statuses*) 315 | (loop for request in requests 316 | and i below n-requests do 317 | (setf (mpi-object-handle request) 318 | (mem-aref requests* #.foreign-mpi-object-type))) 319 | requests))) 320 | -------------------------------------------------------------------------------- /mpi/setup.lisp: -------------------------------------------------------------------------------- 1 | #| -*- Mode: Lisp; indent-tabs-mode: nil -*- 2 | 3 | Definition of fundamental MPI constants and types. 4 | 5 | Copyright (C) 2014,2015 Marco Heisig 6 | 7 | Permission is hereby granted, free of charge, to any person obtaining a copy 8 | of this software and associated documentation files (the "Software"), to deal 9 | in the Software without restriction, including without limitation the rights 10 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 11 | copies of the Software, and to permit persons to whom the Software is 12 | furnished to do so, subject to the following conditions: 13 | 14 | The above copyright notice and this permission notice shall be included in 15 | all copies or substantial portions of the Software. 16 | 17 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 18 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 19 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 20 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 21 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 23 | THE SOFTWARE. 24 | |# 25 | 26 | (in-package :cl-mpi) 27 | 28 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 29 | ;;; 30 | ;;; Error Handling 31 | ;;; 32 | ;;; (Almost) all MPI functions return a status code as an integer. In 33 | ;;; cl-mpi, the user never sees the status code at all. It is automatically 34 | ;;; checked and converted to a condition. 35 | 36 | (define-condition mpi-error-condition (error) 37 | ((%error-code :initarg :error-code :reader error-code)) 38 | (:report 39 | (lambda (c stream) 40 | (princ (mpi-error-string (error-code c)) 41 | stream))) 42 | (:documentation 43 | "Signaled when a MPI function returns a status code other than MPI_SUCCESS.")) 44 | 45 | (defun signal-mpi-error (value) 46 | (cerror "Ignore the error." 47 | 'mpi-error-condition :error-code value)) 48 | 49 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 50 | ;;; 51 | ;;; Version Information 52 | 53 | (define-constant +mpi-version+ 54 | (format nil "~d.~d" |MPI_VERSION| |MPI_SUBVERSION|) 55 | :test #'string-equal 56 | :documentation 57 | "The version of the MPI standard supported by the underlying implementation.") 58 | 59 | (define-constant +mpi-library+ 60 | (cond 61 | ((boundp '|MPICH|) 62 | (format nil "MPICH ~D" (symbol-value '|MPICH_VERSION|))) 63 | ((boundp '|MPICH2|) 64 | (format nil "MPICH2 ~D" (symbol-value '|MPICH2_VERSION|))) 65 | ((boundp '|OPEN_MPI|) 66 | (format nil "Open MPI ~D.~D.~D" 67 | (symbol-value '|OPEN_MPI_MAJOR_VERSION|) 68 | (symbol-value '|OPEN_MPI_MINOR_VERSION|) 69 | (symbol-value '|OPEN_MPI_RELEASE_VERSION|))) 70 | (t "Unkown")) 71 | :test #'string-equal 72 | :documentation 73 | "A string describing the MPI library that CL-MPI uses to send its 74 | messages. Something like \"Open MPI 1.6.2\".") 75 | 76 | (defmacro since-mpi-version (version &body body) 77 | (when (version<= version +mpi-version+) 78 | `(progn ,@body))) 79 | 80 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 81 | ;;; 82 | ;;; Handling of Foreign Types 83 | ;;; 84 | ;;; There is a plethora of types in MPI. We represent them as a subclass of 85 | ;;; MPI-OBJECT and provide appropriate CFFI wrapper types of the form 86 | ;;; -type. 87 | 88 | (defclass mpi-object () 89 | ((%handle :accessor mpi-object-handle :initarg :handle))) 90 | 91 | (defclass mpi-errhandler (mpi-object) ()) 92 | 93 | (defclass mpi-comm (mpi-object) ()) 94 | 95 | (defclass mpi-group (mpi-object) ()) 96 | 97 | (defclass mpi-datatype (mpi-object) ()) 98 | 99 | (defclass mpi-op (mpi-object) ()) 100 | 101 | (defclass mpi-info (mpi-object) ()) 102 | 103 | (defclass mpi-request (mpi-object) ()) 104 | 105 | ;;; some deftypes for the most common types handled by MPI 106 | (deftype int () '(signed-byte 32)) 107 | 108 | (deftype index () '(or null (integer 0 #.array-total-size-limit))) 109 | 110 | (eval-when (:compile-toplevel :load-toplevel :execute) 111 | (define-constant foreign-mpi-object-type 112 | (if (boundp '|OPEN_MPI|) :pointer :int))) 113 | 114 | (define-foreign-type mpi-object-type () 115 | () (:actual-type 116 | ;; The MPI standard does not prescribe the C type of several of its 117 | ;; objects. In practice, this means that OpenMPI represents its 118 | ;; objects as pointers to structs, while MPICH and its derivatives 119 | ;; represent them with ints. 120 | #.foreign-mpi-object-type)) 121 | 122 | (define-foreign-type mpi-errhandler-type (mpi-object-type) 123 | () (:simple-parser mpi-errhandler)) 124 | 125 | (define-foreign-type mpi-comm-type (mpi-object-type) 126 | () (:simple-parser mpi-comm)) 127 | 128 | (define-foreign-type mpi-group-type (mpi-object-type) 129 | () (:simple-parser mpi-group)) 130 | 131 | (define-foreign-type mpi-datatype-type (mpi-object-type) 132 | () (:simple-parser mpi-datatype)) 133 | 134 | (define-foreign-type mpi-op-type (mpi-object-type) 135 | () (:simple-parser mpi-op)) 136 | 137 | (define-foreign-type mpi-info-type (mpi-object-type) 138 | () (:simple-parser mpi-info)) 139 | 140 | (define-foreign-type mpi-message-type (mpi-object-type) 141 | () (:simple-parser mpi-message)) 142 | 143 | (define-foreign-type mpi-request-type (mpi-object-type) 144 | () (:simple-parser mpi-request)) 145 | 146 | (define-foreign-type mpi-error-type () 147 | () 148 | (:actual-type :int) 149 | (:simple-parser mpi-error-code)) 150 | 151 | (defmethod expand-to-foreign (value (type mpi-object-type)) 152 | `(mpi-object-handle ,value)) 153 | 154 | (defmethod expand-from-foreign (value (type mpi-error-type)) 155 | (let ((return-value (gensym))) 156 | `(let ((,return-value ,value)) 157 | (unless (zerop ,return-value) 158 | (signal-mpi-error ,return-value)) 159 | (values)))) 160 | 161 | (defmethod expand-from-foreign (value (type mpi-object-type)) 162 | (let ((instance-type 163 | (etypecase type 164 | (mpi-errhandler-type 'mpi-errhandler) 165 | (mpi-comm-type 'mpi-comm) 166 | (mpi-group-type 'mpi-group) 167 | (mpi-datatype-type 'mpi-datatype) 168 | (mpi-op-type 'mpi-op) 169 | (mpi-info-type 'mpi-info) 170 | (mpi-request-type 'mpi-request)))) 171 | `(make-instance ',instance-type :handle ,value))) 172 | 173 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 174 | ;;; 175 | ;;; Accessing MPI constants. 176 | 177 | ;; Each entry in this list is of the form (object c-name reader) 178 | (defvar *mpi-constant-table* '()) 179 | 180 | (eval-when (:compile-toplevel :load-toplevel :execute) 181 | (flet ((reader-symbol (c-name) 182 | (intern 183 | (concatenate 'string "cl_mpi_get_" c-name))) 184 | (lisp-symbol (c-name) 185 | (intern 186 | (format nil "+~A+" (substitute #\- #\_ (string-upcase c-name)))))) 187 | (defmacro define-mpi-constant (class c-name) 188 | `(defvar ,(lisp-symbol c-name) 189 | (let ((object (make-instance ',class))) 190 | (pushnew (list object ',c-name ',(reader-symbol c-name)) 191 | *mpi-constant-table* 192 | :test #'string= :key #'second) 193 | object))))) 194 | 195 | (define-mpi-constant mpi-errhandler "MPI_ERRORS_RETURN") 196 | (define-mpi-constant mpi-errhandler "MPI_ERRORS_ARE_FATAL") 197 | (define-mpi-constant mpi-errhandler "MPI_ERRHANDLER_NULL") 198 | (define-mpi-constant mpi-group "MPI_GROUP_EMPTY") 199 | (define-mpi-constant mpi-group "MPI_GROUP_NULL") 200 | (define-mpi-constant mpi-comm "MPI_COMM_WORLD") 201 | (define-mpi-constant mpi-comm "MPI_COMM_SELF") 202 | (define-mpi-constant mpi-comm "MPI_COMM_NULL") 203 | (define-mpi-constant mpi-datatype "MPI_DATATYPE_NULL") 204 | (define-mpi-constant mpi-datatype "MPI_CHAR") 205 | (define-mpi-constant mpi-datatype "MPI_SIGNED_CHAR") 206 | (define-mpi-constant mpi-datatype "MPI_UNSIGNED_CHAR") 207 | (define-mpi-constant mpi-datatype "MPI_BYTE") 208 | (define-mpi-constant mpi-datatype "MPI_SHORT") 209 | (define-mpi-constant mpi-datatype "MPI_UNSIGNED_SHORT") 210 | (define-mpi-constant mpi-datatype "MPI_INT") 211 | (define-mpi-constant mpi-datatype "MPI_UNSIGNED") 212 | (define-mpi-constant mpi-datatype "MPI_LONG") 213 | (define-mpi-constant mpi-datatype "MPI_UNSIGNED_LONG") 214 | (define-mpi-constant mpi-datatype "MPI_LONG_LONG_INT") 215 | (define-mpi-constant mpi-datatype "MPI_UNSIGNED_LONG_LONG") 216 | (define-mpi-constant mpi-datatype "MPI_FLOAT") 217 | (define-mpi-constant mpi-datatype "MPI_DOUBLE") 218 | (define-mpi-constant mpi-datatype "MPI_LONG_DOUBLE") 219 | (define-mpi-constant mpi-datatype "MPI_WCHAR") 220 | (define-mpi-constant mpi-datatype "MPI_C_BOOL") 221 | (since-mpi-version "2.2" 222 | (define-mpi-constant mpi-datatype "MPI_INT8_T") 223 | (define-mpi-constant mpi-datatype "MPI_INT16_T") 224 | (define-mpi-constant mpi-datatype "MPI_INT32_T") 225 | (define-mpi-constant mpi-datatype "MPI_INT64_T") 226 | (define-mpi-constant mpi-datatype "MPI_UINT8_T") 227 | (define-mpi-constant mpi-datatype "MPI_UINT16_T") 228 | (define-mpi-constant mpi-datatype "MPI_UINT32_T") 229 | (define-mpi-constant mpi-datatype "MPI_UINT64_T")) 230 | (define-mpi-constant mpi-datatype "MPI_PACKED") 231 | (define-mpi-constant mpi-op "MPI_MIN") 232 | (define-mpi-constant mpi-op "MPI_MAX") 233 | (define-mpi-constant mpi-op "MPI_SUM") 234 | (define-mpi-constant mpi-op "MPI_PROD") 235 | (define-mpi-constant mpi-op "MPI_LAND") 236 | (define-mpi-constant mpi-op "MPI_BAND") 237 | (define-mpi-constant mpi-op "MPI_LOR") 238 | (define-mpi-constant mpi-op "MPI_BOR") 239 | (define-mpi-constant mpi-op "MPI_LXOR") 240 | (define-mpi-constant mpi-op "MPI_BXOR") 241 | (define-mpi-constant mpi-op "MPI_MAXLOC") 242 | (define-mpi-constant mpi-op "MPI_MINLOC") 243 | (define-mpi-constant mpi-op "MPI_REPLACE") 244 | (define-mpi-constant mpi-op "MPI_OP_NULL") 245 | (define-mpi-constant mpi-request "MPI_REQUEST_NULL") 246 | 247 | (declaim (type mpi-comm *standard-communicator*)) 248 | (defvar *standard-communicator* +mpi-comm-world+) 249 | 250 | (defun initialize-mpi-constants () 251 | (loop for (object nil reader-name) in *mpi-constant-table* 252 | do (setf (mpi-object-handle object) 253 | (funcall reader-name)))) 254 | -------------------------------------------------------------------------------- /mpi/utilities.lisp: -------------------------------------------------------------------------------- 1 | #| -*- Mode: Lisp; indent-tabs-mode: nil -*- 2 | 3 | MPI related utility functions 4 | 5 | Copyright (c) 2008,2009 Alex Fukunaga 6 | Copyright (C) 2014,2015 Marco Heisig 7 | 8 | Permission is hereby granted, free of charge, to any person obtaining a copy 9 | of this software and associated documentation files (the "Software"), to deal 10 | in the Software without restriction, including without limitation the rights 11 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 12 | copies of the Software, and to permit persons to whom the Software is 13 | furnished to do so, subject to the following conditions: 14 | 15 | The above copyright notice and this permission notice shall be included in 16 | all copies or substantial portions of the Software. 17 | 18 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 19 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 20 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 21 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 22 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 23 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 24 | THE SOFTWARE. 25 | |# 26 | 27 | (in-package :mpi) 28 | 29 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 30 | ;;; 31 | ;;; DEFMPIFUN 32 | ;;; 33 | ;;; A CFFI:DEFCFUN invocation looks something like 34 | ;;; (CFFI:DEFCFUN NAMESPEC RETURN-VALUE (ARG1 TYPE1) (ARG2 TYPE2) ...) 35 | ;;; 36 | ;;; A typical MPI routine takes sometimes more than eight arguments and 37 | ;;; always returns an MPI-ERROR-CODE. To improve readablility, I provide a 38 | ;;; function DEFMPIFUN, which expands into defcfun, but attempts to look up 39 | ;;; the type of a variable in the table *MPI-NAMING-CONVENTIONS*. 40 | ;;; 41 | ;;; example: the type of an argument variable COUNT is always :INTEGER. 42 | 43 | (defvar *mpi-naming-conventions* 44 | (let ((table (make-hash-table))) 45 | (flet ((introduce-conventions (type &rest symbols) 46 | (loop for symbol in symbols do 47 | (setf (gethash symbol table) type)))) 48 | (mapc 49 | (lambda (x) (apply #'introduce-conventions x)) 50 | '((:pointer 51 | *buf *sendbuf *recvbuf *inbuf *outbuf *inoutbuf fun argc argv ptr) 52 | ((:pointer :int) 53 | *result *count *position *size *rank *index *outcount *commute *keyval) 54 | (:string string) 55 | ((:pointer :boolean) *flag) 56 | (:int 57 | count incount outcount insize outsize sendcount recvcount source dest 58 | tag sendtag recvtag size root commute errorcode color key) 59 | (:boolean flag) 60 | (mpi-errhandler errhandler) 61 | (mpi-comm comm oldcomm comm1 comm2) 62 | (mpi-group group group1 group2) 63 | (mpi-datatype datatype sendtype recvtype oldtype) 64 | (mpi-op op) 65 | (mpi-request request) 66 | ((:pointer (:struct mpi-status)) *status) 67 | ((:pointer mpi-op) *op) 68 | ((:pointer mpi-message) *message) 69 | ((:pointer mpi-request) *request) 70 | ((:pointer mpi-comm) *newcomm *comm) 71 | ((:pointer mpi-group) *newgroup *group) 72 | ((:pointer mpi-datatype) *newtype) 73 | ((:pointer (:struct mpi-status)) statuses) 74 | ((:pointer mpi-datatype) sendtypes recvtypes) 75 | ((:pointer mpi-request) requests) 76 | ((:array :int *) indices) 77 | ((:pointer (:array :int *)) ranges) 78 | ((:array :int *) 79 | ranks ranks1 ranks2 sendcounts recvcounts displs sdispls rdispls)))) 80 | table)) 81 | 82 | (defmacro defmpifun (foreign-name (&rest args) &key (introduced "1.0")) 83 | (check-type foreign-name string) 84 | (let ((lisp-name 85 | (intern 86 | (concatenate 'string "%" (substitute #\- #\_ (string-upcase foreign-name))) 87 | '#:cl-mpi)) 88 | (expanded-args 89 | (loop for arg in args 90 | collect 91 | (if (symbolp arg) 92 | `(,arg ,(gethash arg *mpi-naming-conventions*)) 93 | arg)))) 94 | ;; Currently I do not handle deprecation - this is ok because as of June 95 | ;; 2015 the MPI Committee also has no way to handle deprecation. 96 | `(since-mpi-version ,introduced 97 | (defcfun (,foreign-name ,lisp-name) mpi-error-code ,@expanded-args)))) 98 | 99 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 100 | ;;; 101 | ;;; converting Lisp vectors to raw pointers 102 | ;;; 103 | ;;; The next section is not for the weak of heart and demonstrates how one 104 | ;;; can obtain the address and length of subsequences of Lisp vectors. 105 | 106 | (eval-when (:compile-toplevel :load-toplevel :execute) 107 | (defvar *mpi-datatype-table* 108 | '((+mpi-char+ . :char) 109 | (+mpi-signed-char+ . :char) 110 | (+mpi-unsigned-char+ . :unsigned-char) 111 | (+mpi-byte+ . :char) 112 | (+mpi-short+ . :short) 113 | (+mpi-unsigned-short+ . :unsigned-short) 114 | (+mpi-int+ . :int) 115 | (+mpi-unsigned+ . :unsigned-int) 116 | (+mpi-long+ . :long) 117 | (+mpi-unsigned-long+ . :unsigned-long) 118 | (+mpi-long-long-int+ . :long-long) 119 | (+mpi-unsigned-long-long+ . :unsigned-long-long) 120 | (+mpi-float+ . :float) 121 | (+mpi-double+ . :double) 122 | (+mpi-long-double+ . :long-double)) 123 | "An alist of MPI datatypes and corresponding CFFI types.")) 124 | 125 | (eval-when (:compile-toplevel :load-toplevel :execute) 126 | (defun bits-per-element (array-element-type) 127 | "Bits reserved per array element of type ARRAY-ELEMENT-TYPE." 128 | (when (eq (upgraded-array-element-type array-element-type) t) 129 | (error "Cannot determine bits per element for elements of type T.")) 130 | (let ((initial-element 131 | (cond 132 | ((subtypep array-element-type 'character) #\B) 133 | ((subtypep array-element-type 'float) (coerce 0 array-element-type)) 134 | (t 0)))) 135 | (with-static-vector (test-array 8 :element-type array-element-type 136 | :initial-element initial-element) 137 | (let ((ptr (static-vector-pointer test-array))) 138 | ;; flip more and more bytes until the outer values of the static 139 | ;; array changes. The upper bound of 128 should never be reached 140 | ;; and is only a safeguard against overwriting the whole heap in 141 | ;; case of something odd. 142 | (loop for i below 128 and flipped-bytes from 1 do 143 | (setf (mem-ref ptr :int8 i) (lognot (mem-ref ptr :int8 i))) 144 | when (not (eql (aref test-array 7) initial-element)) 145 | do (return (if (< flipped-bytes 8) flipped-bytes 146 | (* 8 (floor flipped-bytes 7)))))))))) 147 | 148 | (eval-when (:compile-toplevel :load-toplevel :execute) 149 | (defvar *bits-per-element-table* 150 | (let* ((upgraded-array-element-types 151 | (remove-duplicates 152 | (mapcar #'upgraded-array-element-type 153 | `(single-float 154 | double-float 155 | base-char 156 | character 157 | ,@(loop for n from 1 to 64 158 | append `((signed-byte ,n) 159 | (unsigned-byte ,n))))) 160 | :test #'equal)) 161 | (alist (loop for uaet in (remove 't upgraded-array-element-types) 162 | collect 163 | (let ((bits (bits-per-element uaet))) 164 | `(,uaet . ,bits))))) 165 | ;; now remove all unnecessary clauses, that is where the element type 166 | ;; is a true subtype of another one, while having the same number of 167 | ;; bits per element. 168 | (loop for (uaet . bits) in (copy-seq alist) do 169 | (setf alist 170 | (delete-if 171 | (lambda (x) 172 | (let ((x-uaet (car x)) 173 | (x-bits (cdr x))) 174 | (and (subtypep x-uaet uaet) 175 | (not (equal x-uaet uaet)) 176 | (= x-bits bits)))) 177 | alist))) 178 | alist))) 179 | 180 | (defmacro mpi-datatype-of-size (size) 181 | `',(car (find size *mpi-datatype-table* 182 | :key (lambda (x) (foreign-type-size (cdr x)))))) 183 | 184 | ;;; This macro is essentially a specialized compiler for vector memory 185 | ;;; access and is only useful in the body of STATIC-VECTOR-MPI-DATA 186 | (defmacro static-vector-mpi-data-dispatch (vector start end) 187 | (let ((blocks 188 | (loop for bits in (remove-duplicates (mapcar #'cdr *bits-per-element-table*)) 189 | collect 190 | (let ((mpi-datatype (ecase bits 191 | ((1 2 4 8) (mpi-datatype-of-size 1)) 192 | (16 (mpi-datatype-of-size 2)) 193 | (32 (mpi-datatype-of-size 4)) 194 | (64 (mpi-datatype-of-size 8)))) 195 | (bytes-per-element (/ bits 8)) 196 | (elements-per-mpi-datatype (ceiling 8 bits))) 197 | `(,bits 198 | (setf offset (* ,start ,bytes-per-element)) 199 | (setf mpi-datatype ,mpi-datatype) 200 | (setf count (ceiling (- ,end ,start) ,elements-per-mpi-datatype)) 201 | (go end))))) 202 | (clauses 203 | (loop for (uaet . bits) in *bits-per-element-table* collect 204 | `((simple-array ,uaet (*)) (go ,bits))))) 205 | `(let ((offset 0) mpi-datatype (count 0)) 206 | (declare (type fixnum offset) 207 | (type (or mpi-datatype null) mpi-datatype) 208 | (type int count)) 209 | (tagbody 210 | (etypecase ,vector ,@clauses) 211 | ,@(apply #'append blocks) 212 | end) 213 | (values (static-vector-pointer ,vector :offset offset) mpi-datatype count)))) 214 | 215 | (defun static-vector-mpi-data (vector &optional start end) 216 | "Return a pointer to the raw memory of the given vector, as well as the 217 | corresponding MPI-DATATYPE and the number of elements to transmit. 218 | 219 | WARNING: If ARRAY is somehow moved in memory (e.g. by the garbage collector), 220 | your code is broken, so better have a look at the STATIC-VECTORS package." 221 | (declare (type (simple-array * (*)) vector) 222 | (type index start end) 223 | (optimize (safety 0) (debug 0))) 224 | (let* ((dim (length vector)) 225 | (start (or start 0)) 226 | (end (or end dim))) 227 | (assert (<= 0 start end dim)) 228 | ;; The macroexpansion of the following line is quite beautiful 229 | (static-vector-mpi-data-dispatch vector start end))) 230 | 231 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 232 | ;;; 233 | ;;; Finally some miscellaneous utilites for cl-mpi 234 | 235 | (defmacro with-foreign-results (bindings &body body) 236 | "Evaluate body as with WITH-FOREIGN-OBJECTS, but afterwards convert them to 237 | lisp objects and return them via VALUES." 238 | `(with-foreign-objects ,bindings 239 | ,@body 240 | (values 241 | ,@(loop for binding in bindings 242 | collect `(mem-ref ,@binding))))) 243 | 244 | (defun reload-mpi-libraries () 245 | "Load all MPI related libraries again. This might be necessary after a 246 | session is resumed from a Lisp image" 247 | 248 | ;; the following code can actually be triggered on ECL, when quicklisp is 249 | ;; available at image creation time, but not when the image is executed. 250 | #+quicklisp 251 | (unless (find :quicklisp *features*) 252 | (let ((quicklisp-init (merge-pathnames "quicklisp/setup.lisp" (user-homedir-pathname)))) 253 | (when (probe-file quicklisp-init) 254 | (load quicklisp-init)))) 255 | (load-foreign-library 256 | (asdf:output-file 257 | 'asdf:compile-op 258 | (asdf:find-component "cl-mpi" '("mpi" . "cl-mpi-stub"))))) 259 | 260 | (defun mpi-equal (a b) 261 | (when (and (typep a 'mpi-object) 262 | (typep b 'mpi-object)) 263 | (let ((a (mpi-object-handle a)) 264 | (b (mpi-object-handle b))) 265 | (if (and (integerp a) (integerp b)) 266 | (eql a b) 267 | (pointer-eq a b))))) 268 | 269 | (defun mpi-null (object) 270 | (mpi-equal 271 | object 272 | (typecase object 273 | (mpi-group +mpi-group-null+) 274 | (mpi-comm +mpi-comm-null+) 275 | (mpi-request +mpi-request-null+) 276 | (mpi-op +mpi-op-null+) 277 | (mpi-errhandler +mpi-errhandler-null+) 278 | (t nil)))) 279 | -------------------------------------------------------------------------------- /mpi/wrap.lisp: -------------------------------------------------------------------------------- 1 | ;;; Wrapper library specification for querying information that is not 2 | ;;; necessarily static, such as the definition of MPI_COMM_WORLD. 3 | 4 | (include "mpi.h") 5 | 6 | (in-package :cl-mpi) 7 | 8 | #. 9 | `(progn 10 | ,@(loop for (object c-name reader-name) in *mpi-constant-table* 11 | collect 12 | `(defwrapper* 13 | ,reader-name 14 | ,(cffi::canonicalize-foreign-type 15 | (class-name 16 | (class-of object))) () 17 | ,(format nil "return ~A;" c-name)))) 18 | -------------------------------------------------------------------------------- /roswell/cl-mpi.ros: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | #|-*- mode:lisp -*-|# 3 | #| 4 | exec ros -Q -- $0 "$@" 5 | |# 6 | (defpackage :ros.script.cl-mpi.3657791497 7 | (:use :cl)) 8 | 9 | (in-package :ros.script.cl-mpi.3657791497) 10 | 11 | (ql:quickload 12 | '(:cffi-grovel :uiop :cl-mpi-test-suite) 13 | :silent t) 14 | 15 | (defun main (&rest argv) 16 | (unwind-protect 17 | (cond 18 | ((string-equal (first argv) "stress") 19 | (cl-mpi-test-suite:run-cl-mpi-stress-tests)) 20 | (t 21 | (cl-mpi-test-suite:run-cl-mpi-test-suite))) 22 | (ignore-errors 23 | (uiop:symbol-call "CL-MPI" "MPI-FINALIZE") 24 | (uiop:quit 0)))) 25 | -------------------------------------------------------------------------------- /scripts/build-cl-mpi-application.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | usage() 4 | { 5 | echo "Usage: $0 IN OUT" 6 | echo "" 7 | echo -n "Build a standalone executable named OUT that will execute" 8 | echo "the function CL-USER::MAIN when launched." 9 | } 10 | 11 | if [ ! $1 ] || [ ! $2 ] 12 | then 13 | usage 14 | exit 15 | fi 16 | 17 | if [ ! `which cl-launch` ] 18 | then 19 | echo "This script requires cl-launch (http://cliki.net/CL-Launch)" 20 | exit 21 | fi 22 | 23 | IN=$1 24 | OUT=$2 25 | 26 | cl-launch \ 27 | -Q -s cl-mpi-extensions -s cl-mpi-test-suite -o $OUT -d $OUT \ 28 | -L $IN -E main 29 | -------------------------------------------------------------------------------- /scripts/run-test-suite.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | BASEDIR=$(dirname $0) 4 | 5 | LISP_IMPLEMENTATIONS="sbcl ccl ecl" 6 | 7 | usage() 8 | { 9 | echo "Usage: $0 [all|clean|ecl|ccl|...]" 10 | } 11 | 12 | clean() 13 | { 14 | rm -f $BASEDIR/*.image 15 | } 16 | 17 | build_image() 18 | { 19 | LISP=$1 20 | IMAGE=$BASEDIR/$LISP.image 21 | LISP_VERSION=$($1 --version) || "unknown version" 22 | 23 | echo "=========================================" 24 | echo "Building $LISP ($LISP_VERSION) image ..." 25 | 26 | if cl-launch --lisp $LISP \ 27 | -Q -sp cl-mpi-test-suite \ 28 | -i "(unwind-protect (run-cl-mpi-test-suite) (mpi-finalize) (uiop:quit))" \ 29 | -o $IMAGE -d $IMAGE; then 30 | echo "...$LISP image complete" 31 | echo "=========================================" 32 | echo 33 | return 0 34 | else 35 | echo "...$LISP image creation failed" 36 | echo "=========================================" 37 | echo 38 | return 1 39 | fi 40 | } 41 | 42 | test_image() 43 | { 44 | LISP=$1 45 | IMAGE=$BASEDIR/$LISP.image 46 | 47 | echo "=========================================" 48 | echo "Testing $LISP..." 49 | 50 | mpiexec -n 2 $IMAGE 51 | echo "...$LISP testing complete" 52 | echo "=========================================" 53 | echo 54 | } 55 | 56 | 57 | 58 | if [ ! $1 ] || [ $1 = "--help" ] 59 | then 60 | usage 61 | exit 62 | fi 63 | 64 | if [ ! `which cl-launch` ] 65 | then 66 | echo "This script requires cl-launch (http://cliki.net/CL-Launch)" 67 | exit 68 | fi 69 | 70 | if [ $1 = "clean" ] 71 | then 72 | clean 73 | exit 74 | fi 75 | 76 | if ! [ $1 = "all" ] 77 | then 78 | LISP_IMPLEMENTATIONS=$@ 79 | fi 80 | 81 | clean 82 | 83 | for LISP in $LISP_IMPLEMENTATIONS; do 84 | if build_image $LISP; then 85 | test_image $LISP 86 | fi 87 | done 88 | -------------------------------------------------------------------------------- /test-suite/packages.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :cl-mpi-test-suite 2 | (:nicknames :mpi-test-suite) 3 | (:use :cl :cl-mpi :5am :uiop :cffi :static-vectors) 4 | (:export 5 | #:run-cl-mpi-test-suite 6 | #:run-cl-mpi-stress-tests)) 7 | 8 | (in-package :cl-mpi-test-suite) 9 | 10 | (def-suite mpi-test-suite 11 | :description "All MPI related tests.") 12 | 13 | (def-suite mpi-serial-tests 14 | :in mpi-test-suite 15 | :description "CL-MPI tests that can be run on a single process.") 16 | 17 | (def-suite mpi-parallel-tests 18 | :in mpi-test-suite 19 | :description "CL-MPI tests that need more than one participating process.") 20 | 21 | (def-suite mpi-stress-tests 22 | :in mpi-test-suite 23 | :description "CL-MPI tests that require a long time to run.") 24 | -------------------------------------------------------------------------------- /test-suite/parallel-tests.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-mpi-test-suite) 2 | 3 | (in-suite mpi-parallel-tests) 4 | 5 | (defun team-partner () 6 | "Group all processes in teams of two. Return the rank of the partner." 7 | (let ((rank (mpi-comm-rank)) 8 | (size (mpi-comm-size))) 9 | (cond 10 | ((and (oddp size) 11 | (>= rank (- size 1))) 12 | +mpi-proc-null+) 13 | ((evenp rank) 14 | (+ rank 1)) 15 | ((oddp rank) 16 | (- rank 1))))) 17 | 18 | ;;; The parallel tests must form a serial dependency chain so that their order 19 | ;;; is deterministic. Otherwise the parallel test suite can deadlock. 20 | 21 | (test (mpi-barrier) 22 | "synchronize all processes with multiple MPI barriers." 23 | (loop for i from 0 below 10 do (mpi-barrier))) 24 | 25 | (test (mpi-ring :depends-on mpi-barrier) 26 | "Send a Common Lisp datastructure through all nodes." 27 | (let ((rank (mpi-comm-rank)) 28 | (size (mpi-comm-size)) 29 | (buffer (make-static-vector 7 :element-type 'character 30 | :initial-element #\SPACE)) 31 | (message (make-static-vector 7 :element-type 'character 32 | :initial-contents "foobar!"))) 33 | (let ((left-neighbor (mod (- rank 1) size)) 34 | (right-neighbor (mod (+ rank 1) size))) 35 | (unwind-protect 36 | (cond ((= 0 rank) 37 | (mpi-send message right-neighbor) 38 | (mpi-recv buffer left-neighbor) 39 | (is (string= "foobar!" buffer))) 40 | (t 41 | (mpi-recv buffer left-neighbor) 42 | (mpi-send buffer right-neighbor))) 43 | (free-static-vector buffer) 44 | (free-static-vector message))))) 45 | 46 | (test (mpi-sendrecv :depends-on mpi-ring) 47 | "Send a Common Lisp datastructure through all nodes using mpi-sendrecv." 48 | (let ((rank (mpi-comm-rank)) 49 | (size (mpi-comm-size))) 50 | (let ((left-neighbor (mod (- rank 1) size)) 51 | (right-neighbor (mod (+ rank 1) size)) 52 | (left-buffer (make-static-vector 1 :element-type '(unsigned-byte 64) 53 | :initial-element 0)) 54 | (right-buffer (make-static-vector 1 :element-type '(unsigned-byte 64) 55 | :initial-element 0)) 56 | (my-buffer (make-static-vector 1 :element-type '(unsigned-byte 64) 57 | :initial-element rank))) 58 | (unwind-protect 59 | (progn 60 | (mpi-sendrecv my-buffer right-neighbor left-buffer left-neighbor) 61 | (mpi-sendrecv my-buffer left-neighbor right-buffer right-neighbor)) 62 | (is (= (aref left-buffer 0) left-neighbor)) 63 | (is (= (aref right-buffer 0) right-neighbor)) 64 | (free-static-vector left-buffer) 65 | (free-static-vector right-buffer) 66 | (free-static-vector my-buffer))))) 67 | 68 | (test (send-subsequence :depends-on mpi-sendrecv) 69 | "Send only a subsequence of an array" 70 | (let* ((partner (team-partner)) 71 | (recvbuf (make-static-vector 11 :element-type 'character 72 | :initial-element #\SPACE)) 73 | (sendbuf (make-static-vector 9 :element-type 'character 74 | :initial-contents "+foobar!+"))) 75 | (unwind-protect 76 | (mpi-sendrecv sendbuf partner 77 | recvbuf partner 78 | :send-start 1 :send-end 8 79 | :recv-start 2 :recv-end 9) 80 | (is (string= " foobar! " recvbuf)) 81 | (free-static-vector recvbuf) 82 | (free-static-vector sendbuf)))) 83 | 84 | (test (mpi-bcast :depends-on send-subsequence) 85 | "Use mpi-bcast to broadcast a single number." 86 | (let ((rank (mpi-comm-rank)) 87 | (size (mpi-comm-size))) 88 | (with-static-vector (buffer 1 :element-type 'double-float) 89 | (let ((root (- size 1)) 90 | (message (coerce pi 'double-float))) 91 | (if (= rank root) 92 | (setf (aref buffer 0) message)) 93 | (mpi-bcast buffer root) 94 | (is (= (aref buffer 0) message)))))) 95 | 96 | (test (mpi-allgather :depends-on mpi-bcast) 97 | "Use mpi-allgather to generate a vector of all ranks." 98 | (let ((rank (mpi-comm-rank)) 99 | (size (mpi-comm-size))) 100 | (with-static-vector (recv-array size :element-type '(signed-byte 32) 101 | :initial-element 0) 102 | (with-static-vector (send-array 1 :element-type '(signed-byte 32) 103 | :initial-element rank) 104 | (mpi-allgather send-array recv-array) 105 | (is (loop for i below size 106 | when (/= (aref recv-array i) i) do 107 | (return nil) 108 | finally 109 | (return t))))))) 110 | 111 | (test (nonblocking :depends-on mpi-allgather) 112 | "Nonblocking communication with MPI-I[SEND,RECV], MPI-WAIT and 113 | MPI-WAITALL" 114 | (let ((partner (team-partner))) 115 | (with-static-vector (recvbuf 3 :element-type '(unsigned-byte 32) 116 | :initial-element 0) 117 | (with-static-vector (sendbuf 3 :element-type '(unsigned-byte 32) 118 | :initial-element 1) 119 | (mpi-waitall (mpi-isend sendbuf partner) 120 | (mpi-irecv recvbuf partner)) 121 | (is (equalp recvbuf #(1 1 1)))) 122 | (with-static-vector (sendbuf 3 :element-type '(unsigned-byte 32) 123 | :initial-element 2) 124 | (mapc #'mpi-wait 125 | (list (mpi-isend sendbuf partner) 126 | (mpi-irecv recvbuf partner))) 127 | (is (equalp recvbuf #(2 2 2)))) 128 | (with-static-vector (sendbuf 3 :element-type '(unsigned-byte 32) 129 | :initial-element 3) 130 | (let ((requests (list (mpi-isend sendbuf partner) 131 | (mpi-irecv recvbuf partner)))) 132 | (is (not (some #'mpi-null requests))) 133 | (mapc #'mpi-wait requests) 134 | (is (every #'mpi-null requests)) 135 | (is (equalp recvbuf #(3 3 3)))))))) 136 | 137 | (test (mpi-allreduce :depends-on nonblocking) 138 | "Perform different reductions with MPI-Allreduce." 139 | (let ((size (mpi-comm-size))) 140 | (with-static-vector (source 3 :element-type '(unsigned-byte 64) 141 | :initial-element 1) 142 | (with-static-vector (dest 3 :element-type '(unsigned-byte 64) 143 | :initial-element 0) 144 | (mpi-allreduce source dest +mpi-prod+) 145 | (is (every (lambda (x) (= x 1)) dest)) 146 | (mpi-allreduce source dest +mpi-sum+) 147 | (is (every (lambda (x) (= x size)) dest)))))) 148 | 149 | (test (mpi-reduce :depends-on mpi-allreduce) 150 | "Perform different reductions with MPI-Reduce" 151 | (let* ((size (mpi-comm-size)) 152 | (rank (mpi-comm-rank)) 153 | (root (- size 1))) 154 | (with-static-vector (source 3 :element-type 'double-float 155 | :initial-element 1.0d0) 156 | (with-static-vector (allgood 1 :element-type '(unsigned-byte 8) 157 | :initial-element 0) 158 | (if (= rank root) 159 | (with-static-vector (dest 3 :element-type 'double-float 160 | :initial-element 0d0) 161 | (mpi-reduce source dest +mpi-max+ root) 162 | (when (every (lambda (x) (= x 1.0d0)) dest) 163 | (setf (aref allgood 0) 1))) 164 | (mpi-reduce source nil +mpi-max+ root)) 165 | (mpi-bcast allgood root) 166 | (is (plusp (aref allgood 0))))))) 167 | -------------------------------------------------------------------------------- /test-suite/serial-tests.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-mpi-test-suite) 2 | 3 | (in-suite mpi-serial-tests) 4 | 5 | (defmacro with-fresh-mpi-context (&body body) 6 | "Execute body with *STANDARD-COMMUNICATOR* bound to a new unique 7 | communicator. This prevents errors within BODY to affect other parts of the 8 | program." 9 | `(let ((*standard-communicator* (mpi-comm-dup))) 10 | (unwind-protect 11 | (progn ,@body) 12 | (mpi-comm-free *standard-communicator*)))) 13 | 14 | (test (mpi-wtime) 15 | (is (<= 0 (mpi-wtime))) 16 | (is (<= 0 (mpi-wtick)))) 17 | 18 | (test (mpi-init) 19 | "MPI Initialization." 20 | (mpi-init) 21 | (is (mpi-initialized)) 22 | (is (not (mpi-finalized)))) 23 | 24 | (test (processor-name :depends-on mpi-init) 25 | "The function mpi-get-processor-name should return a string describing the 26 | current processor in use." 27 | (let ((processor-name (mpi-get-processor-name))) 28 | (is (stringp processor-name)) 29 | (is (plusp (length processor-name))))) 30 | 31 | (test (serial-groups :depends-on mpi-init) 32 | "MPI group management functions." 33 | (let* ((size (mpi-comm-size)) 34 | (all-procs (mpi-comm-group +mpi-comm-world+)) 35 | (first (mpi-group-incl all-procs 0)) 36 | (all-but-first (mpi-group-excl all-procs 0)) 37 | (evens (mpi-group-incl all-procs `(0 ,(- size 1) 2))) 38 | (odds (if (> size 1) 39 | (mpi-group-excl all-procs `(1 ,(- size 1) 2)) 40 | (mpi-group-incl all-procs)))) 41 | (is (= size (mpi-group-size all-procs))) 42 | (is (= 1 (mpi-group-size first))) 43 | (is (= (- size 1) (mpi-group-size all-but-first))) 44 | (is (= (ceiling size 2) (mpi-group-size evens))) 45 | (is (= (floor size 2) (mpi-group-size odds))) 46 | (mpi-group-free all-procs first all-but-first odds evens))) 47 | 48 | (test (mpi-buffering :depends-on mpi-init) 49 | (mpi::mpi-buffer-detach) 50 | (is (length mpi::*current-buffer*) 0) 51 | (mpi-demand-buffering 1000) 52 | (is (length mpi::*current-buffer*) 1000)) 53 | 54 | (test (mpi-context :depends-on mpi-init) 55 | (is (mpi-comm-free (mpi-comm-dup))) 56 | (let ((c1 *standard-communicator*) 57 | (c2 (mpi-comm-dup *standard-communicator*)) 58 | (c3 (let ((group (mpi-comm-group *standard-communicator*))) 59 | (unwind-protect (mpi-comm-create group :comm *standard-communicator*) 60 | (mpi-group-free group))))) 61 | (unwind-protect 62 | (is (= (mpi-comm-size c1) 63 | (mpi-comm-size c2) 64 | (mpi-comm-size c3))) 65 | (mpi-comm-free c2) 66 | (mpi-comm-free c3)))) 67 | 68 | (test (mpi-split :depends-on mpi-context) 69 | "Test that mpi-comm-split is working." 70 | (with-fresh-mpi-context 71 | (let ((c1 (mpi-comm-split 0 0)) 72 | (c2 (mpi-comm-split 0 (mpi-comm-rank))) 73 | (c3 (mpi-comm-split 0 (- (mpi-comm-rank)))) 74 | (c4 (mpi-comm-split (mpi-comm-rank) -1)) 75 | (c5 (mpi-comm-split +mpi-undefined+ 0))) 76 | (unwind-protect 77 | (progn 78 | (is (= (mpi-comm-size c1) (mpi-comm-size))) 79 | (is (= (mpi-comm-rank c1) (mpi-comm-rank))) 80 | (is (= (mpi-comm-size c2) (mpi-comm-size))) 81 | (is (= (mpi-comm-rank c2) (mpi-comm-rank))) 82 | (is (= (mpi-comm-size c3) (mpi-comm-size))) 83 | (is (= (mpi-comm-rank c3) (- (mpi-comm-size) 84 | (mpi-comm-rank) 85 | 1))) 86 | (is (= (mpi-comm-size c4) 1)) 87 | (is (= (mpi-comm-rank c4) 0)) 88 | (is (mpi-null c5)))) 89 | (mpi-comm-free c1) 90 | (mpi-comm-free c2) 91 | (mpi-comm-free c3) 92 | (mpi-comm-free c4)))) 93 | 94 | ;;; point to point communication 95 | 96 | (test (serial-mpi-sendrecv :depends-on mpi-context) 97 | (with-fresh-mpi-context 98 | (let ((self (mpi-comm-rank))) 99 | ;; send an array containing 10 zeros 100 | (with-static-vectors ((src 10 :element-type 'double-float 101 | :initial-element 0.0d0) 102 | (dst 10 :element-type 'double-float 103 | :initial-element 1.0d0)) 104 | (mpi-sendrecv src self dst self :send-tag 42 :recv-tag 42) 105 | (is (every #'zerop dst))) 106 | ;; swap the latter 10 elements of two buffers 107 | (with-static-vectors ((ones 20 :element-type 'double-float 108 | :initial-element 1.0d0) 109 | (temp 10 :element-type 'double-float 110 | :initial-element 0.0d0) 111 | (twos 20 :element-type 'double-float 112 | :initial-element 2.0d0)) 113 | (mpi-sendrecv ones self temp self :send-start 10 :send-end 20) 114 | (mpi-sendrecv twos self ones self :send-start 10 :send-end 20 115 | :recv-start 10 :recv-end 20) 116 | (mpi-sendrecv temp self twos self :recv-start 10 :recv-end 20) 117 | (is (and (every (lambda (x) (= x 1.0d0)) (subseq ones 0 10)) 118 | (every (lambda (x) (= x 2.0d0)) (subseq ones 10 20)))) 119 | (is (and (every (lambda (x) (= x 2.0d0)) (subseq twos 0 10)) 120 | (every (lambda (x) (= x 1.0d0)) (subseq twos 10 20)))))))) 121 | 122 | (test (serial-mpi-isend :depends-on mpi-context) 123 | (with-fresh-mpi-context 124 | (mpi-demand-buffering 1000) 125 | (let ((self (mpi-comm-rank))) 126 | (loop 127 | for (mode size) 128 | in '((:basic 1) 129 | (:basic 100) 130 | (:basic 1000000) 131 | (:buffered 10) 132 | (:synchronous 100) 133 | (:ready 1) 134 | (:ready 1000000)) 135 | do 136 | (with-static-vectors ((src size :element-type 'double-float 137 | :initial-element 0.0d0) 138 | (dst size :element-type 'double-float 139 | :initial-element 1.0d0)) 140 | (mpi-waitall 141 | (mpi-irecv dst self) 142 | (mpi-isend src self :mode mode)) 143 | (is (every #'zerop dst) 144 | (format nil "Error during ~s MPI-ISEND of ~d bytes." 145 | mode (* 8 size)))))))) 146 | 147 | (test (mpi-probe :depends-on mpi-context) 148 | (with-fresh-mpi-context 149 | (let ((self (mpi-comm-rank))) 150 | (with-static-vectors ((src 3 :element-type 'double-float) 151 | (dst 3 :element-type 'double-float)) 152 | (let ((request (mpi-isend src self :tag 10))) 153 | (multiple-value-bind (size id tag) 154 | (mpi-probe self :tag 10) 155 | (is (= (* 3 8) size)) 156 | (is (= id self)) 157 | (is (= tag 10))) 158 | (is (every 159 | (lambda (x) (mpi-null x)) 160 | (mpi-waitall 161 | request 162 | (mpi-irecv dst self :tag 10))))))))) 163 | 164 | (test (mpi-iprobe :depends-on mpi-context) 165 | (with-fresh-mpi-context 166 | (let ((self (mpi-comm-rank))) 167 | (with-static-vectors ((src 3 :element-type 'double-float) 168 | (dst 3 :element-type 'double-float)) 169 | (let ((request (mpi-isend src self :tag 11))) 170 | (loop ; luckily MPI makes a progress guarantee for this case 171 | (multiple-value-bind (size id tag) 172 | (mpi-iprobe self :tag 11) 173 | (when size 174 | (is (= (* 3 8) size)) 175 | (is (= id self)) 176 | (is (= tag 11)) 177 | (return)))) 178 | (is (every 179 | (lambda (x) (mpi-null x)) 180 | (mpi-waitall 181 | request 182 | (mpi-irecv dst self :tag 11))))))))) 183 | 184 | (test (mpi-wait-and-test :depends-on mpi-context) 185 | (with-fresh-mpi-context 186 | (let ((self (mpi-comm-rank))) 187 | (with-static-vectors ((src 3 :element-type 'double-float) 188 | (dst 3 :element-type 'double-float)) 189 | (let ((recv-request (mpi-irecv src self :tag 12))) 190 | (multiple-value-bind (done request) 191 | (mpi-test recv-request) 192 | (is (not done)) 193 | (is (typep recv-request 'mpi-request)) 194 | (is (not (mpi-null request)))) 195 | (let ((send-request (mpi-isend dst self :tag 12))) 196 | (loop until (and (mpi-test send-request) 197 | (mpi-test recv-request))) 198 | (is (mpi-null (mpi-wait send-request))) 199 | (is (mpi-null (mpi-wait recv-request))))))))) 200 | -------------------------------------------------------------------------------- /test-suite/stress-tests.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-mpi-test-suite) 2 | 3 | (in-suite mpi-stress-tests) 4 | 5 | (test (serial-mpi-request-stress-test) 6 | "Create and use a lot of MPI-REQUEST objects." 7 | (mpi-init) 8 | (let ((self (mpi-comm-rank)) 9 | (errors? nil)) 10 | (with-static-vectors ((v1 4 :element-type 'single-float 11 | :initial-element 1.0) 12 | (v2 4 :element-type 'single-float 13 | :initial-element 2.0)) 14 | (loop repeat 1000000 do 15 | (progn 16 | (mpi-waitall ;; swap the contents of v1 and v2 17 | (mpi-isend v1 self) 18 | (mpi-isend v2 self) 19 | (mpi-irecv v2 self) 20 | (mpi-irecv v1 self)) 21 | (rotatef v1 v2) 22 | (unless (and (every (lambda (x) (= x 1.0)) v1) 23 | (every (lambda (x) (= x 2.0)) v2)) 24 | (setf errors? t))))) 25 | (is (not errors?)))) 26 | -------------------------------------------------------------------------------- /test-suite/test-suite.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-mpi-test-suite) 2 | 3 | (defun print-test-suite-banner (destination) 4 | (let ((machine 5 | (format nil "~A ~A" 6 | (machine-type) 7 | (machine-version))) 8 | (lisp 9 | (format nil "~A ~A" 10 | (lisp-implementation-type) 11 | (lisp-implementation-version))) 12 | (cl-mpi 13 | (asdf:component-version 14 | (asdf:find-system :cl-mpi))) 15 | (mpi 16 | (format nil "~A" +mpi-library+))) 17 | (format destination 18 | "== Testing CL-MPI == 19 | Machine: ~A 20 | Lisp: ~A 21 | MPI: ~A 22 | cl-mpi: cl-mpi ~A~%" 23 | machine lisp mpi cl-mpi))) 24 | 25 | (defmacro with-single-output (&body body) 26 | "Disable output on all processes but the one with MPI rank zero." 27 | `(let ((*test-dribble* 28 | (if (zerop (mpi-comm-rank)) 29 | *test-dribble* 30 | (make-broadcast-stream)))) 31 | ,@body)) 32 | 33 | (defun run-cl-mpi-test-suite () 34 | (mpi-init) 35 | (assert (mpi-initialized)) 36 | (let ((size (mpi-comm-size)) 37 | (rank (mpi-comm-rank))) 38 | (assert (> size 0)) 39 | (assert (> size rank -1)) 40 | ;; discard the output of all but one MPI process 41 | (with-single-output 42 | (print-test-suite-banner *test-dribble*) 43 | (run! 'mpi-serial-tests) 44 | (if (> size 1) ; check whether we run in parallel 45 | (run! 'mpi-parallel-tests) 46 | (format *test-dribble* " 47 | Note: You tested cl-mpi with only one process. Some test cases require a 48 | parallel run and have been skipped. Rerun the program with `$ mpiexec 49 | -np 2 YOUR_PROGRAM' to perform all tests. 50 | "))))) 51 | 52 | (defun run-cl-mpi-stress-tests () 53 | (mpi-init) 54 | (with-single-output 55 | (print-test-suite-banner *test-dribble*) 56 | (run! 'mpi-stress-tests))) 57 | --------------------------------------------------------------------------------