tebdol

Simulation of ultracold atoms in optical lattices
git clone https://miroslavurbanek.com/git/tebdol.git
Log | Files | Refs | README

mpi.lisp (6248B)


      1 (defpackage :mpi
      2   (:use :common-lisp :sb-alien :serial)
      3   (:export :mpi-comm
      4 	   :mpi-datatype
      5 	   :mpi-request
      6 	   :mpi-status
      7 	   :*mpi-comm-world*
      8 	   :*mpi-byte*
      9 	   :*mpi-status-ignore*
     10 	   :+mpi-any-source+
     11 	   :alien-mpi-init
     12 	   :alien-mpi-finalize
     13 	   :alien-mpi-comm-size
     14 	   :alien-mpi-comm-rank
     15 	   :alien-mpi-get-processor-name
     16 	   :alien-mpi-send
     17 	   :alien-mpi-ssend
     18 	   :alien-mpi-issend
     19 	   :alien-mpi-wait
     20 	   :alien-mpi-recv
     21 	   :alien-mpi-probe
     22 	   :alien-mpi-get-count
     23 	   :mpi-init
     24 	   :mpi-finalize
     25 	   :mpi-comm-size
     26 	   :mpi-comm-rank
     27 	   :mpi-get-processor-name
     28 	   :mpi-send-object
     29 	   :mpi-issend-object
     30 	   :mpi-wait
     31 	   :mpi-receive-object
     32 	   :mpi-wtime))
     33 
     34 (in-package :mpi)
     35 
     36 #+openmpi
     37 (progn
     38   (define-alien-type nil (struct ompi-communicator-t))
     39   (define-alien-type nil (struct ompi-datatype-t))
     40   (define-alien-type nil (struct ompi-request-t))
     41   (define-alien-type nil (struct ompi-status-t
     42 				 (mpi-source int)
     43 				 (mpi-tag int)
     44 				 (mpi-error int)
     45 				 (-count int)
     46 				 (-cancelled int)))
     47 
     48   (define-alien-type mpi-comm (* (struct ompi-communicator-t)))
     49   (define-alien-type mpi-datatype (* (struct ompi-datatype-t)))
     50   (define-alien-type mpi-request (* (struct ompi-request-t)))
     51   (define-alien-type mpi-status (struct ompi-status-t))
     52 
     53   (define-alien-variable "ompi_mpi_comm_world" (struct ompi-communicator-t))
     54   (define-alien-variable "ompi_mpi_byte" (struct ompi-datatype-t))
     55 
     56   (defparameter *mpi-comm-world* (addr ompi-mpi-comm-world))
     57   (defparameter *mpi-byte* (addr ompi-mpi-byte))
     58   (defparameter *mpi-status-ignore* (sb-sys:int-sap 0))
     59   (defconstant +mpi-any-source+ -1))
     60 
     61 #+mpich
     62 (progn
     63   (define-alien-type mpi-comm int)
     64   (define-alien-type mpi-datatype int)
     65   (define-alien-type mpi-request int)
     66   (define-alien-type mpi-status (struct mpi-status
     67 					(count int)
     68 					(cancelled int)
     69 					(mpi-source int)
     70 					(mpi-tag int)
     71 					(mpi-error int)))
     72 
     73   (defparameter *mpi-comm-world* #x44000000)
     74   (defparameter *mpi-byte* #x4c00010d)
     75   (defparameter *mpi-status-ignore* (sb-sys:int-sap 1))
     76   (defconstant +mpi-any-source+ -2))
     77 
     78 (declaim (inline alien-mpi-init))
     79 (define-alien-routine ("MPI_Init" alien-mpi-init) int
     80   (argc (* int))
     81   (argv (* (array c-string))))
     82 
     83 (declaim (inline alien-mpi-finalize))
     84 (define-alien-routine ("MPI_Finalize" alien-mpi-finalize) int)
     85 
     86 (declaim (inline alien-mpi-comm-size))
     87 (define-alien-routine ("MPI_Comm_size" alien-mpi-comm-size) int
     88   (comm mpi-comm)
     89   (size (* int)))
     90 
     91 (declaim (inline alien-mpi-comm-rank))
     92 (define-alien-routine ("MPI_Comm_rank" alien-mpi-comm-rank) int
     93   (comm mpi-comm)
     94   (rank (* int)))
     95 
     96 (defconstant +mpi-max-processor-name+ 256)
     97 
     98 (declaim (inline alien-mpi-get-processor-name))
     99 (define-alien-routine ("MPI_Get_processor_name" alien-mpi-get-processor-name) int
    100   (name (* char))
    101   (resultlen (* int)))
    102 
    103 (declaim (inline alien-mpi-send))
    104 (define-alien-routine ("MPI_Send" alien-mpi-send) int
    105   (buf (* t))
    106   (count int)
    107   (datatype mpi-datatype)
    108   (dest int)
    109   (tag int)
    110   (comm mpi-comm))
    111 
    112 (declaim (inline alien-mpi-ssend))
    113 (define-alien-routine ("MPI_Ssend" alien-mpi-ssend) int
    114   (buf (* t))
    115   (count int)
    116   (datatype mpi-datatype)
    117   (dest int)
    118   (tag int)
    119   (comm mpi-comm))
    120 
    121 (declaim (inline alien-mpi-issend))
    122 (define-alien-routine ("MPI_Issend" alien-mpi-issend) int
    123   (buf (* t))
    124   (count int)
    125   (datatype mpi-datatype)
    126   (dest int)
    127   (tag int)
    128   (comm mpi-comm)
    129   (request (* mpi-request)))
    130 
    131 (declaim (inline alien-mpi-wait))
    132 (define-alien-routine ("MPI_Wait" alien-mpi-wait) int
    133   (request (* mpi-request))
    134   (status (* mpi-status)))
    135 
    136 (declaim (inline alien-mpi-recv))
    137 (define-alien-routine ("MPI_Recv" alien-mpi-recv) int
    138   (buf (* t))
    139   (count int)
    140   (datatype mpi-datatype)
    141   (source int)
    142   (tag int)
    143   (comm mpi-comm)
    144   (status (* mpi-status)))
    145 
    146 (declaim (inline alien-mpi-probe))
    147 (define-alien-routine ("MPI_Probe" alien-mpi-probe) int
    148   (source int)
    149   (tag int)
    150   (comm mpi-comm)
    151   (status (* mpi-status)))
    152 
    153 (declaim (inline alien-mpi-get-count))
    154 (define-alien-routine ("MPI_Get_count" alien-mpi-get-count) int
    155   (status (* mpi-status))
    156   (datatype mpi-datatype)
    157   (count (* int)))
    158 
    159 (declaim (inline alien-mpi-wtime))
    160 (define-alien-routine ("MPI_Wtime" alien-mpi-wtime) double)
    161 
    162 (defun mpi-init ()
    163   (alien-mpi-init nil nil))
    164 
    165 (defun mpi-finalize ()
    166   (alien-mpi-finalize))
    167 
    168 (defun mpi-comm-size (comm)
    169   (with-alien ((size int))
    170     (alien-mpi-comm-size comm (addr size))
    171     size))
    172 
    173 (defun mpi-comm-rank (comm)
    174   (with-alien ((rank int))
    175     (alien-mpi-comm-rank comm (addr rank))
    176     rank))
    177 
    178 (defun mpi-get-processor-name ()
    179   (with-alien ((name (* char) (make-alien char +mpi-max-processor-name+))
    180 	       (resultlen int))
    181     (prog2
    182 	(alien-mpi-get-processor-name name (addr resultlen))
    183 	(cast name c-string)
    184       (free-alien name))))
    185 
    186 (defun mpi-send-object (object dest)
    187   (let ((buf (serialize object)))
    188     (sb-sys:with-pinned-objects
    189 	((sb-ext:array-storage-vector buf))
    190       (alien-mpi-send
    191        (sap-alien
    192 	(sb-sys:vector-sap (sb-ext:array-storage-vector buf))
    193 	(* char))
    194        (length buf)
    195        *mpi-byte*
    196        dest
    197        0
    198        *mpi-comm-world*))))
    199 
    200 ;; external without-gcing
    201 
    202 (defun mpi-issend-object (object dest)
    203   (let ((buf (serialize object))
    204 	(request (make-alien mpi-request)))
    205     (alien-mpi-issend
    206      (sap-alien
    207       (sb-sys:vector-sap (sb-ext:array-storage-vector buf))
    208       (* char))
    209      (length buf)
    210      *mpi-byte*
    211      dest
    212      0
    213      *mpi-comm-world*
    214      request)
    215     request))
    216 
    217 (defun mpi-wait (request)
    218   (alien-mpi-wait
    219    request
    220    *mpi-status-ignore*)
    221   (free-alien request))
    222 
    223 (defun mpi-receive-object (source)
    224   (with-alien ((status mpi-status)
    225 	       (count int))
    226     (alien-mpi-probe source 0 *mpi-comm-world* (addr status))
    227     (alien-mpi-get-count (addr status) *mpi-byte* (addr count))
    228     (let ((buf (make-array count :element-type '(unsigned-byte 8))))
    229       (sb-sys:with-pinned-objects
    230 	  ((sb-ext:array-storage-vector buf))
    231 	(alien-mpi-recv
    232 	 (sap-alien
    233 	  (sb-sys:vector-sap (sb-ext:array-storage-vector buf))
    234 	  (* char))
    235 	 count
    236 	 *mpi-byte*
    237 	 (slot status 'mpi-source)
    238 	 (slot status 'mpi-tag)
    239 	 *mpi-comm-world*
    240 	 *mpi-status-ignore*))
    241       (values (deserialize buf) (slot status 'mpi-source)))))
    242 
    243 (defun mpi-wtime ()
    244   (alien-mpi-wtime))