5 /* The Inline::C source for this is available in the __DATA__ section
9 #define GATHER_TAG 11001 /* used to be unlikely to upset other sends */
12 root process first broadcasts length of stored data then broadcasts
13 the data. Non-root processes receive length (via bcast), allocate
14 space to take incomming data from root
16 Both root and non-root processes then create and return a new scalar
17 with contents identical to those root started with.
20 SV* _Bcast (SV* data, int root, SV* comm) {
24 MPI_Comm_rank((MPI_Comm)SvIVX(comm), &rank);
26 buf_len[0] = sv_len(data);
27 MPI_Bcast(buf_len, 1, MPI_INT, root, (MPI_Comm)SvIVX(comm));
28 MPI_Bcast(SvPVX(data), buf_len[0], MPI_CHAR, root, (MPI_Comm)SvIVX(comm));
29 rval = newSVpvn(SvPVX(data), buf_len[0]);
33 MPI_Bcast(buf_len, 1, MPI_INT, root, (MPI_Comm)SvIVX(comm));
34 recv_buf = (char*)malloc((buf_len[0]+1)*sizeof(char));
35 if (recv_buf == NULL) croak("Allocation error in _Bcast");
36 MPI_Bcast(recv_buf, buf_len[0], MPI_CHAR, root, (MPI_Comm)SvIVX(comm));
37 rval = newSVpvn(recv_buf, buf_len[0]);
44 Finds length of data in stor_ref, sends this to receiver, then
45 sends actual data, uses same tag for each message.
48 int _Send(SV* stor_ref, int dest, int tag, SV*comm) {
50 str_len[0] = sv_len(stor_ref);
51 MPI_Send(str_len, 1, MPI_INT, dest, tag, (MPI_Comm)SvIVX(comm));
52 MPI_Send(SvPVX(stor_ref), sv_len(stor_ref),MPI_CHAR,
53 dest, tag, (MPI_Comm)SvIVX(comm));
58 Receives int for length of data it should then expect, allocates space
59 then receives data into that space. Creates a new SV and returns it.
62 SV* _Recv (int source, int tag, SV*comm, SV*status) {
68 MPI_Recv(len_buf, 1, MPI_INT, source, tag, (MPI_Comm)SvIVX(comm), &tstatus);
69 recv_buf = (char*)malloc((len_buf[0]+1)*sizeof(char));
70 if (recv_buf == NULL) croak("Allocation error in _Recv");
71 MPI_Recv(recv_buf, len_buf[0], MPI_CHAR, source, tag,
72 (MPI_Comm)SvIVX(comm), &tstatus);
73 rval = newSVpvn(recv_buf, len_buf[0]);
74 sv_setiv(status, tstatus.MPI_SOURCE);
79 /* Calls MPI_Init with dummy arguments, a bit dodgy but sort of ok */
81 MPI_Init(&PL_origargc, &PL_origargv);
84 /* Returns rank of process within comm */
85 int _Comm_rank (SV* comm) {
87 MPI_Comm_rank((MPI_Comm)SvIVX(comm),&trank);
91 /* returns total number of processes within comm */
92 int _Comm_size (SV* comm) {
94 MPI_Comm_size((MPI_Comm)SvIVX(comm), &tsize);
98 /* returns SV whose IV slot is a cast pointer to the MPI_COMM_WORLD object */
100 return newSViv((IV)MPI_COMM_WORLD);
103 /* returns SV whose IV slot is a cast pointer to the MPI_ANY_SOURCE value */
105 return newSViv((IV)MPI_ANY_SOURCE);
108 /* calls MPI_Barrier for comm */
109 int Barrier (SV*comm) {
110 MPI_Barrier((MPI_Comm)SvIVX(comm));
113 /* ends MPI participation */
119 If non-root: participates in Gather so that root finds length of data
120 to expect from this process. Then send (using MPI_Send)
123 If root: receives array of ints detailing length of scalars held by
124 other processes, then receives from each in turn (using MPI_Recv)
125 returns an array ref to root process only.
128 SV* _Gather (SV* data, int root, SV* comm) {
129 int rank, size, *buf_lens, i, max;
135 /* find out how long data is */
136 ret_arr = av_make(0,(SV**)NULL);
137 my_buf[0] = sv_len(data);
138 if (_Comm_rank(comm) == root) {
139 MPI_Comm_size((MPI_Comm)SvIVX(comm), &size);
140 buf_lens = malloc(size*sizeof(int));
141 if (buf_lens == NULL) croak("Allocation error (lens) in _Gather");
142 /* gather all scalar length data */
143 MPI_Gather(my_buf, 1, MPI_INT, buf_lens, 1,
144 MPI_INT, root, (MPI_Comm)SvIVX(comm));
145 max = 0; // keep buffer allocation calls to minimum
146 for (i=0;i<size;i++) {
147 max = max < buf_lens[i] ? buf_lens[i] : max;
149 recv_buf = malloc(max * sizeof(char));
150 if (recv_buf == NULL) croak("Allocation error (recv) in _Gather");
151 for (i=0;i<size;i++) {
153 av_push(ret_arr, data);
154 continue; /* me, no point sending */
156 MPI_Recv(recv_buf, buf_lens[i], MPI_CHAR, i, GATHER_TAG,
157 (MPI_Comm)SvIVX(comm), &tstatus );
158 av_push(ret_arr, sv_2mortal( newSVpvn(recv_buf, buf_lens[i]) ) );
164 /* send out how long my scalar data is */
165 MPI_Gather(my_buf, 1, MPI_INT, buf_lens, 1,
166 MPI_INT, root, (MPI_Comm)SvIVX(comm) );
167 /* send out my scalar data as normal send with tag of ???? */
168 MPI_Send(SvPVX(data), my_buf[0], MPI_CHAR,
169 root, GATHER_TAG,(MPI_Comm)SvIVX(comm));
172 return newRV_inc((SV*)ret_arr);
175 /* compares two communicators, translates MPI constants into something I
176 can use as constants in the module interface */
177 int _Comm_compare(SV* comm1, SV* comm2) {
179 MPI_Comm_compare((MPI_Comm)SvIVX(comm1), (MPI_Comm)SvIVX(comm2), &result);
194 /* frees a communicator, once all pending communication has taken place */
195 void _Comm_free (SV* comm) {
196 MPI_Comm_free((MPI_Comm*)&SvIVX(comm));
197 if ((MPI_Comm)SvIVX(comm) != MPI_COMM_NULL)
198 croak("Communicator not freed properly\n");
201 SV* _Comm_dup (SV*comm) {
203 MPI_Comm_dup((MPI_Comm)SvIVX(comm), &newcomm);
204 return newSViv((IV)newcomm);
207 SV* _Comm_split (SV* comm, int colour, int key) {
210 MPI_Comm_split((MPI_Comm)SvIVX(comm),
211 (colour < 0 ? MPI_UNDEFINED : colour),
213 return newSViv((IV)newcomm);
219 MODULE = Parallel::MPI::Simple PACKAGE = Parallel::MPI::Simple
224 _Bcast (data, root, comm)
230 _Send (stor_ref, dest, tag, comm)
237 _Recv (source, tag, comm, status)
268 _Gather (data, root, comm)
274 _Comm_compare (comm1, comm2)
284 temp = PL_markstack_ptr++;
286 if (PL_markstack_ptr != temp) {
287 /* truly void, because dXSARGS not invoked */
288 PL_markstack_ptr = temp;
289 XSRETURN_EMPTY; /* return empty stack */
291 /* must have used dXSARGS; list context implied */
292 return; /* assume stack size is correct */
299 _Comm_split (comm, colour, key)