1 /*
2 * Copyright (C) by Argonne National Laboratory
3 * See COPYRIGHT in top-level directory
4 */
5
6 #include "mpiimpl.h"
7 #include "mpicomm.h"
8
9 /* -- Begin Profiling Symbol Block for routine MPI_Intercomm_create */
10 #if defined(HAVE_PRAGMA_WEAK)
11 #pragma weak MPI_Intercomm_create = PMPI_Intercomm_create
12 #elif defined(HAVE_PRAGMA_HP_SEC_DEF)
13 #pragma _HP_SECONDARY_DEF PMPI_Intercomm_create MPI_Intercomm_create
14 #elif defined(HAVE_PRAGMA_CRI_DUP)
15 #pragma _CRI duplicate MPI_Intercomm_create as PMPI_Intercomm_create
16 #elif defined(HAVE_WEAK_ATTRIBUTE)
17 int MPI_Intercomm_create(MPI_Comm local_comm, int local_leader, MPI_Comm peer_comm,
18 int remote_leader, int tag, MPI_Comm * newintercomm)
19 __attribute__ ((weak, alias("PMPI_Intercomm_create")));
20 #endif
21 /* -- End Profiling Symbol Block */
22
23 /* Define MPICH_MPI_FROM_PMPI if weak symbols are not supported to build
24 the MPI routines */
25 #ifndef MPICH_MPI_FROM_PMPI
26 #undef MPI_Intercomm_create
27 #define MPI_Intercomm_create PMPI_Intercomm_create
28
MPIR_Intercomm_create_impl(MPIR_Comm * local_comm_ptr,int local_leader,MPIR_Comm * peer_comm_ptr,int remote_leader,int tag,MPIR_Comm ** new_intercomm_ptr)29 int MPIR_Intercomm_create_impl(MPIR_Comm * local_comm_ptr, int local_leader,
30 MPIR_Comm * peer_comm_ptr, int remote_leader, int tag,
31 MPIR_Comm ** new_intercomm_ptr)
32 {
33 int mpi_errno = MPI_SUCCESS;
34 MPIR_Context_id_t final_context_id, recvcontext_id;
35 int remote_size = 0, *remote_lpids = NULL;
36 int comm_info[3];
37 int is_low_group = 0;
38 MPIR_Errflag_t errflag = MPIR_ERR_NONE;
39 MPIR_FUNC_TERSE_STATE_DECL(MPID_STATE_MPIR_COMM_KIND__INTERCOMM_CREATE_IMPL);
40
41 MPIR_FUNC_TERSE_ENTER(MPID_STATE_MPIR_COMM_KIND__INTERCOMM_CREATE_IMPL);
42
43 /* Shift tag into the tagged coll space */
44 tag |= MPIR_TAG_COLL_BIT;
45
46 mpi_errno = MPID_Intercomm_exchange_map(local_comm_ptr, local_leader,
47 peer_comm_ptr, remote_leader,
48 &remote_size, &remote_lpids, &is_low_group);
49 MPIR_ERR_CHECK(mpi_errno);
50
51 /*
52 * Create the contexts. Each group will have a context for sending
53 * to the other group. All processes must be involved. Because
54 * we know that the local and remote groups are disjoint, this
55 * step will complete
56 */
57 MPL_DBG_MSG_FMT(MPIR_DBG_COMM, VERBOSE,
58 (MPL_DBG_FDEST, "About to get contextid (local_size=%d) on rank %d",
59 local_comm_ptr->local_size, local_comm_ptr->rank));
60 /* In the multi-threaded case, MPIR_Get_contextid_sparse assumes that the
61 * calling routine already holds the single criticial section */
62 /* TODO: Make sure this is tag-safe */
63 mpi_errno = MPIR_Get_contextid_sparse(local_comm_ptr, &recvcontext_id, FALSE);
64 MPIR_ERR_CHECK(mpi_errno);
65 MPIR_Assert(recvcontext_id != 0);
66 MPL_DBG_MSG_FMT(MPIR_DBG_COMM, VERBOSE, (MPL_DBG_FDEST, "Got contextid=%d", recvcontext_id));
67
68 /* Leaders can now swap context ids and then broadcast the value
69 * to the local group of processes */
70 if (local_comm_ptr->rank == local_leader) {
71 MPIR_Context_id_t remote_context_id;
72
73 mpi_errno =
74 MPIC_Sendrecv(&recvcontext_id, 1, MPIR_CONTEXT_ID_T_DATATYPE, remote_leader, tag,
75 &remote_context_id, 1, MPIR_CONTEXT_ID_T_DATATYPE, remote_leader, tag,
76 peer_comm_ptr, MPI_STATUS_IGNORE, &errflag);
77 MPIR_ERR_CHECK(mpi_errno);
78
79 final_context_id = remote_context_id;
80
81 /* Now, send all of our local processes the remote_lpids,
82 * along with the final context id */
83 comm_info[0] = final_context_id;
84 MPL_DBG_MSG(MPIR_DBG_COMM, VERBOSE, "About to bcast on local_comm");
85 mpi_errno = MPIR_Bcast(comm_info, 1, MPI_INT, local_leader, local_comm_ptr, &errflag);
86 MPIR_ERR_CHECK(mpi_errno);
87 MPIR_ERR_CHKANDJUMP(errflag, mpi_errno, MPI_ERR_OTHER, "**coll_fail");
88 MPL_DBG_MSG_D(MPIR_DBG_COMM, VERBOSE, "end of bcast on local_comm of size %d",
89 local_comm_ptr->local_size);
90 } else {
91 /* we're the other processes */
92 MPL_DBG_MSG(MPIR_DBG_COMM, VERBOSE, "About to receive bcast on local_comm");
93 mpi_errno = MPIR_Bcast(comm_info, 1, MPI_INT, local_leader, local_comm_ptr, &errflag);
94 MPIR_ERR_CHECK(mpi_errno);
95 MPIR_ERR_CHKANDJUMP(errflag, mpi_errno, MPI_ERR_OTHER, "**coll_fail");
96
97 /* Extract the context and group sign informatin */
98 final_context_id = comm_info[0];
99 }
100
101 /* At last, we now have the information that we need to build the
102 * intercommunicator */
103
104 /* All processes in the local_comm now build the communicator */
105
106 mpi_errno = MPIR_Comm_create(new_intercomm_ptr);
107 if (mpi_errno)
108 goto fn_fail;
109
110 (*new_intercomm_ptr)->context_id = final_context_id;
111 (*new_intercomm_ptr)->recvcontext_id = recvcontext_id;
112 (*new_intercomm_ptr)->remote_size = remote_size;
113 (*new_intercomm_ptr)->local_size = local_comm_ptr->local_size;
114 (*new_intercomm_ptr)->rank = local_comm_ptr->rank;
115 (*new_intercomm_ptr)->comm_kind = MPIR_COMM_KIND__INTERCOMM;
116 (*new_intercomm_ptr)->local_comm = 0;
117 (*new_intercomm_ptr)->is_low_group = is_low_group;
118
119 mpi_errno = MPID_Create_intercomm_from_lpids(*new_intercomm_ptr, remote_size, remote_lpids);
120 if (mpi_errno)
121 goto fn_fail;
122
123 MPIR_Comm_map_dup(*new_intercomm_ptr, local_comm_ptr, MPIR_COMM_MAP_DIR__L2L);
124
125 /* Inherit the error handler (if any) */
126 MPID_THREAD_CS_ENTER(POBJ, MPIR_THREAD_POBJ_COMM_MUTEX(local_comm_ptr));
127 (*new_intercomm_ptr)->errhandler = local_comm_ptr->errhandler;
128 if (local_comm_ptr->errhandler) {
129 MPIR_Errhandler_add_ref(local_comm_ptr->errhandler);
130 }
131 MPID_THREAD_CS_EXIT(POBJ, MPIR_THREAD_POBJ_COMM_MUTEX(local_comm_ptr));
132
133 (*new_intercomm_ptr)->tainted = 1;
134 mpi_errno = MPIR_Comm_commit(*new_intercomm_ptr);
135 MPIR_ERR_CHECK(mpi_errno);
136
137
138 fn_exit:
139 MPL_free(remote_lpids);
140 remote_lpids = NULL;
141 MPIR_FUNC_TERSE_EXIT(MPID_STATE_MPIR_COMM_KIND__INTERCOMM_CREATE_IMPL);
142 return mpi_errno;
143 fn_fail:
144 goto fn_exit;
145 }
146
147
148 #endif /* MPICH_MPI_FROM_PMPI */
149
150
151 /*@
152
153 MPI_Intercomm_create - Creates an intercommuncator from two intracommunicators
154
155 Input Parameters:
156 + local_comm - Local (intra)communicator
157 . local_leader - Rank in local_comm of leader (often 0)
158 . peer_comm - Communicator used to communicate between a
159 designated process in the other communicator.
160 Significant only at the process in 'local_comm' with
161 rank 'local_leader'.
162 . remote_leader - Rank in peer_comm of remote leader (often 0)
163 - tag - Message tag to use in constructing intercommunicator; if multiple
164 'MPI_Intercomm_creates' are being made, they should use different tags (more
165 precisely, ensure that the local and remote leaders are using different
166 tags for each 'MPI_intercomm_create').
167
168 Output Parameters:
169 . newintercomm - Created intercommunicator
170
171 Notes:
172 'peer_comm' is significant only for the process designated the
173 'local_leader' in the 'local_comm'.
174
175 The MPI 1.1 Standard contains two mutually exclusive comments on the
176 input intercommunicators. One says that their repective groups must be
177 disjoint; the other that the leaders can be the same process. After
178 some discussion by the MPI Forum, it has been decided that the groups must
179 be disjoint. Note that the `reason` given for this in the standard is
180 `not` the reason for this choice; rather, the `other` operations on
181 intercommunicators (like 'MPI_Intercomm_merge') do not make sense if the
182 groups are not disjoint.
183
184 .N ThreadSafe
185
186 .N Fortran
187
188 .N Errors
189 .N MPI_SUCCESS
190 .N MPI_ERR_COMM
191 .N MPI_ERR_TAG
192 .N MPI_ERR_EXHAUSTED
193 .N MPI_ERR_RANK
194
195 .seealso: MPI_Intercomm_merge, MPI_Comm_free, MPI_Comm_remote_group,
196 MPI_Comm_remote_size
197
198 @*/
MPI_Intercomm_create(MPI_Comm local_comm,int local_leader,MPI_Comm peer_comm,int remote_leader,int tag,MPI_Comm * newintercomm)199 int MPI_Intercomm_create(MPI_Comm local_comm, int local_leader,
200 MPI_Comm peer_comm, int remote_leader, int tag, MPI_Comm * newintercomm)
201 {
202 int mpi_errno = MPI_SUCCESS;
203 MPIR_Comm *local_comm_ptr = NULL;
204 MPIR_Comm *peer_comm_ptr = NULL;
205 MPIR_Comm *new_intercomm_ptr;
206 MPIR_FUNC_TERSE_STATE_DECL(MPID_STATE_MPI_INTERCOMM_CREATE);
207
208 MPIR_ERRTEST_INITIALIZED_ORDIE();
209
210 MPID_THREAD_CS_ENTER(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX);
211 MPIR_FUNC_TERSE_ENTER(MPID_STATE_MPI_INTERCOMM_CREATE);
212
213 /* Validate parameters, especially handles needing to be converted */
214 #ifdef HAVE_ERROR_CHECKING
215 {
216 MPID_BEGIN_ERROR_CHECKS;
217 {
218 MPIR_ERRTEST_COMM_TAG(tag, mpi_errno);
219 MPIR_ERRTEST_COMM(local_comm, mpi_errno);
220 }
221 MPID_END_ERROR_CHECKS;
222 }
223 #endif /* HAVE_ERROR_CHECKING */
224
225 /* Convert MPI object handles to object pointers */
226 MPIR_Comm_get_ptr(local_comm, local_comm_ptr);
227
228 /* Validate parameters and objects (post conversion) */
229 #ifdef HAVE_ERROR_CHECKING
230 {
231 MPID_BEGIN_ERROR_CHECKS;
232 {
233 /* Validate local_comm_ptr */
234 MPIR_Comm_valid_ptr(local_comm_ptr, mpi_errno, FALSE);
235 if (local_comm_ptr) {
236 /* Only check if local_comm_ptr valid */
237 MPIR_ERRTEST_COMM_INTRA(local_comm_ptr, mpi_errno);
238 if ((local_leader < 0 || local_leader >= local_comm_ptr->local_size)) {
239 MPIR_ERR_SET2(mpi_errno, MPI_ERR_RANK,
240 "**ranklocal", "**ranklocal %d %d",
241 local_leader, local_comm_ptr->local_size - 1);
242 /* If local_comm_ptr is not valid, it will be reset to null */
243 if (mpi_errno)
244 goto fn_fail;
245 }
246 if (local_comm_ptr->rank == local_leader) {
247 MPIR_ERRTEST_COMM(peer_comm, mpi_errno);
248 }
249 }
250 MPIR_ERRTEST_ARGNULL(newintercomm, "newintercomm", mpi_errno);
251 }
252 MPID_END_ERROR_CHECKS;
253 }
254 #endif /* HAVE_ERROR_CHECKING */
255
256 if (local_comm_ptr->rank == local_leader) {
257
258 MPIR_Comm_get_ptr(peer_comm, peer_comm_ptr);
259 #ifdef HAVE_ERROR_CHECKING
260 {
261 MPID_BEGIN_ERROR_CHECKS;
262 {
263 MPIR_Comm_valid_ptr(peer_comm_ptr, mpi_errno, FALSE);
264 /* Note: In MPI 1.0, peer_comm was restricted to
265 * intracommunicators. In 1.1, it may be any communicator */
266
267 /* In checking the rank of the remote leader,
268 * allow the peer_comm to be in intercommunicator
269 * by checking against the remote size */
270 if (!mpi_errno && peer_comm_ptr &&
271 (remote_leader < 0 || remote_leader >= peer_comm_ptr->remote_size)) {
272 MPIR_ERR_SET2(mpi_errno, MPI_ERR_RANK,
273 "**rankremote", "**rankremote %d %d",
274 remote_leader, peer_comm_ptr->remote_size - 1);
275 }
276 /* Check that the local leader and the remote leader are
277 * different processes. This test requires looking at
278 * the lpid for the two ranks in their respective
279 * communicators. However, an easy test is for
280 * the same ranks in an intracommunicator; we only
281 * need the lpid comparison for intercommunicators */
282 /* Here is the test. We restrict this test to the
283 * process that is the local leader (local_comm_ptr->rank ==
284 * local_leader because we can then use peer_comm_ptr->rank
285 * to get the rank in peer_comm of the local leader. */
286 if (peer_comm_ptr->comm_kind == MPIR_COMM_KIND__INTRACOMM &&
287 local_comm_ptr->rank == local_leader && peer_comm_ptr->rank == remote_leader) {
288 MPIR_ERR_SET(mpi_errno, MPI_ERR_RANK, "**ranksdistinct");
289 }
290 if (mpi_errno)
291 goto fn_fail;
292 MPIR_ERRTEST_ARGNULL(newintercomm, "newintercomm", mpi_errno);
293 }
294 MPID_END_ERROR_CHECKS;
295 }
296 #endif /* HAVE_ERROR_CHECKING */
297 }
298
299 /* ... body of routine ... */
300 mpi_errno = MPIR_Intercomm_create_impl(local_comm_ptr, local_leader, peer_comm_ptr,
301 remote_leader, tag, &new_intercomm_ptr);
302 if (mpi_errno)
303 goto fn_fail;
304
305 MPIR_OBJ_PUBLISH_HANDLE(*newintercomm, new_intercomm_ptr->handle);
306 /* ... end of body of routine ... */
307
308 fn_exit:
309 MPIR_FUNC_TERSE_EXIT(MPID_STATE_MPI_INTERCOMM_CREATE);
310 MPID_THREAD_CS_EXIT(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX);
311 return mpi_errno;
312
313 fn_fail:
314 /* --BEGIN ERROR HANDLING-- */
315 #ifdef HAVE_ERROR_CHECKING
316 {
317 mpi_errno =
318 MPIR_Err_create_code(mpi_errno, MPIR_ERR_RECOVERABLE, __func__, __LINE__, MPI_ERR_OTHER,
319 "**mpi_intercomm_create",
320 "**mpi_intercomm_create %C %d %C %d %d %p", local_comm,
321 local_leader, peer_comm, remote_leader, tag, newintercomm);
322 }
323 #endif /* HAVE_ERROR_CHECKING */
324 mpi_errno = MPIR_Err_return_comm(local_comm_ptr, __func__, mpi_errno);
325 goto fn_exit;
326 /* --END ERROR HANDLING-- */
327 }
328