int MPID_nem_mxm_issend(MPIDI_VC_t * vc, const void *buf, MPI_Aint count, MPI_Datatype datatype,
int rank, int tag, MPID_Comm * comm, int context_offset,
MPID_Request ** sreq_ptr)
{
int mpi_errno = MPI_SUCCESS;
MPID_Request *sreq = NULL;
MPID_Datatype *dt_ptr;
int dt_contig;
MPIDI_msg_sz_t data_sz;
MPI_Aint dt_true_lb;
MPID_nem_mxm_vc_area *vc_area = NULL;
MPID_nem_mxm_req_area *req_area = NULL;
mxm_mq_h *mq_h_v = (mxm_mq_h *) comm->dev.ch.netmod_priv;
MPIDI_STATE_DECL(MPID_STATE_MPID_NEM_MXM_ISSEND);
MPIDI_FUNC_ENTER(MPID_STATE_MPID_NEM_MXM_ISSEND);
MPIDI_Datatype_get_info(count, datatype, dt_contig, data_sz, dt_ptr, dt_true_lb);
/* create a request */
MPIDI_Request_create_sreq(sreq, mpi_errno, goto fn_exit);
MPIU_Assert(sreq != NULL);
MPIDI_Request_set_type(sreq, MPIDI_REQUEST_TYPE_SSEND);
MPIDI_VC_FAI_send_seqnum(vc, seqnum);
MPIDI_Request_set_seqnum(sreq, seqnum);
if (HANDLE_GET_KIND(datatype) != HANDLE_KIND_BUILTIN) {
MPID_Datatype_get_ptr(datatype, sreq->dev.datatype_ptr);
MPID_Datatype_add_ref(sreq->dev.datatype_ptr);
}
sreq->partner_request = NULL;
sreq->dev.OnDataAvail = NULL;
sreq->dev.tmpbuf = NULL;
sreq->ch.vc = vc;
sreq->ch.noncontig = FALSE;
_dbg_mxm_output(5,
"isSend ========> Sending USER msg for req %p (context %d to %d tag %d size %d) \n",
sreq, comm->context_id + context_offset, rank, tag, data_sz);
vc_area = VC_BASE(vc);
req_area = REQ_BASE(sreq);
req_area->ctx = sreq;
req_area->iov_buf = req_area->tmp_buf;
req_area->iov_count = 0;
req_area->iov_buf[0].ptr = NULL;
req_area->iov_buf[0].length = 0;
if (data_sz) {
if (dt_contig) {
req_area->iov_count = 1;
req_area->iov_buf[0].ptr = (char *) (buf) + dt_true_lb;
req_area->iov_buf[0].length = data_sz;
}
else {
MPIDI_msg_sz_t last;
MPI_Aint packsize = 0;
sreq->ch.noncontig = TRUE;
sreq->dev.segment_ptr = MPID_Segment_alloc();
MPIR_ERR_CHKANDJUMP1((sreq->dev.segment_ptr == NULL), mpi_errno, MPI_ERR_OTHER,
"**nomem", "**nomem %s", "MPID_Segment_alloc");
MPIR_Pack_size_impl(count, datatype, &packsize);
last = data_sz;
if (packsize > 0) {
sreq->dev.tmpbuf = MPIU_Malloc((size_t) packsize);
MPIU_Assert(sreq->dev.tmpbuf);
MPID_Segment_init(buf, count, datatype, sreq->dev.segment_ptr, 0);
MPID_Segment_pack(sreq->dev.segment_ptr, 0, &last, sreq->dev.tmpbuf);
req_area->iov_count = 1;
req_area->iov_buf[0].ptr = sreq->dev.tmpbuf;
req_area->iov_buf[0].length = last;
}
}
}
vc_area->pending_sends += 1;
mpi_errno = _mxm_isend(vc_area->mxm_ep, req_area, MXM_MPICH_ISEND_SYNC,
mq_h_v[1], comm->rank, tag, _mxm_tag_mpi2mxm(tag,
comm->context_id
+ context_offset), 0);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
_dbg_mxm_out_req(sreq);
fn_exit:
*sreq_ptr = sreq;
MPIDI_FUNC_EXIT(MPID_STATE_MPID_NEM_MXM_ISSEND);
return mpi_errno;
fn_fail:
goto fn_exit;
}
int MPIR_Init_thread(int *argc, char ***argv, int required, int *provided)
{
int mpi_errno = MPI_SUCCESS;
int has_args;
int has_env;
int thread_provided = 0;
int exit_init_cs_on_failure = 0;
MPIR_Info *info_ptr;
#if defined(MPICH_IS_THREADED)
bool cs_initialized = false;
#endif
/* The threading library must be initialized at the very beginning because
* it manages all synchronization objects (e.g., mutexes) that will be
* initialized later */
{
int thread_err;
MPL_thread_init(&thread_err);
if (thread_err)
goto fn_fail;
}
#ifdef HAVE_HWLOC
MPIR_Process.bindset = hwloc_bitmap_alloc();
hwloc_topology_init(&MPIR_Process.hwloc_topology);
MPIR_Process.bindset_is_valid = 0;
hwloc_topology_set_io_types_filter(MPIR_Process.hwloc_topology, HWLOC_TYPE_FILTER_KEEP_ALL);
if (!hwloc_topology_load(MPIR_Process.hwloc_topology)) {
MPIR_Process.bindset_is_valid =
!hwloc_get_proc_cpubind(MPIR_Process.hwloc_topology, getpid(), MPIR_Process.bindset,
HWLOC_CPUBIND_PROCESS);
}
#endif
#ifdef HAVE_NETLOC
MPIR_Process.network_attr.u.tree.node_levels = NULL;
MPIR_Process.network_attr.network_endpoint = NULL;
MPIR_Process.netloc_topology = NULL;
MPIR_Process.network_attr.type = MPIR_NETLOC_NETWORK_TYPE__INVALID;
if (strlen(MPIR_CVAR_NETLOC_NODE_FILE)) {
mpi_errno =
netloc_parse_topology(&MPIR_Process.netloc_topology, MPIR_CVAR_NETLOC_NODE_FILE);
if (mpi_errno == NETLOC_SUCCESS) {
MPIR_Netloc_parse_topology(MPIR_Process.netloc_topology, &MPIR_Process.network_attr);
}
}
#endif
/* For any code in the device that wants to check for runtime
* decisions on the value of isThreaded, set a provisional
* value here. We could let the MPID_Init routine override this */
#if defined MPICH_IS_THREADED
MPIR_ThreadInfo.isThreaded = required == MPI_THREAD_MULTIPLE;
#endif /* MPICH_IS_THREADED */
#if defined(MPICH_IS_THREADED)
mpi_errno = thread_cs_init();
cs_initialized = true;
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
#endif
/* FIXME: Move to os-dependent interface? */
#ifdef HAVE_WINDOWS_H
/* prevent the process from bringing up an error message window if mpich
* asserts */
_CrtSetReportMode(_CRT_ASSERT, _CRTDBG_MODE_FILE);
_CrtSetReportFile(_CRT_ASSERT, _CRTDBG_FILE_STDERR);
_CrtSetReportHook2(_CRT_RPTHOOK_INSTALL, assert_hook);
#ifdef _WIN64
{
/* FIXME: (Windows) This severly degrades performance but fixes alignment
* issues with the datatype code. */
/* Prevent misaligned faults on Win64 machines */
UINT mode, old_mode;
old_mode = SetErrorMode(SEM_NOALIGNMENTFAULTEXCEPT);
mode = old_mode | SEM_NOALIGNMENTFAULTEXCEPT;
SetErrorMode(mode);
}
#endif
#endif
/* We need this inorder to implement IS_THREAD_MAIN */
#if (MPICH_THREAD_LEVEL >= MPI_THREAD_SERIALIZED) && defined(MPICH_IS_THREADED)
{
MPID_Thread_self(&MPIR_ThreadInfo.master_thread);
}
#endif
#ifdef HAVE_ERROR_CHECKING
/* Because the PARAM system has not been initialized, temporarily
* uncondtionally enable error checks. Once the PARAM system is
* initialized, this may be reset */
MPIR_Process.do_error_checks = 1;
#else
MPIR_Process.do_error_checks = 0;
#endif
/* Initialize necessary subsystems and setup the predefined attribute
* values. Subsystems may change these values. */
MPIR_Process.attrs.appnum = -1;
MPIR_Process.attrs.host = MPI_PROC_NULL;
MPIR_Process.attrs.io = MPI_PROC_NULL;
MPIR_Process.attrs.lastusedcode = MPI_ERR_LASTCODE;
MPIR_Process.attrs.universe = MPIR_UNIVERSE_SIZE_NOT_SET;
MPIR_Process.attrs.wtime_is_global = 0;
/* Set the functions used to duplicate attributes. These are
* when the first corresponding keyval is created */
MPIR_Process.attr_dup = 0;
MPIR_Process.attr_free = 0;
#ifdef HAVE_CXX_BINDING
/* Set the functions used to call functions in the C++ binding
* for reductions and attribute operations. These are null
* until a C++ operation is defined. This allows the C code
* that implements these operations to not invoke a C++ code
* directly, which may force the inclusion of symbols known only
* to the C++ compiler (e.g., under more non-GNU compilers, including
* Solaris and IRIX). */
MPIR_Process.cxx_call_op_fn = 0;
#endif
#ifdef HAVE_F08_BINDING
MPIR_C_MPI_UNWEIGHTED = MPI_UNWEIGHTED;
MPIR_C_MPI_WEIGHTS_EMPTY = MPI_WEIGHTS_EMPTY;
#endif
/* This allows the device to select an alternative function for
* dimsCreate */
MPIR_Process.dimsCreate = 0;
/* "Allocate" from the reserved space for builtin communicators and
* (partially) initialize predefined communicators. comm_parent is
* intially NULL and will be allocated by the device if the process group
* was started using one of the MPI_Comm_spawn functions. */
MPIR_Process.comm_world = MPIR_Comm_builtin + 0;
MPII_Comm_init(MPIR_Process.comm_world);
MPIR_Process.comm_world->handle = MPI_COMM_WORLD;
MPIR_Process.comm_world->context_id = 0 << MPIR_CONTEXT_PREFIX_SHIFT;
MPIR_Process.comm_world->recvcontext_id = 0 << MPIR_CONTEXT_PREFIX_SHIFT;
MPIR_Process.comm_world->comm_kind = MPIR_COMM_KIND__INTRACOMM;
/* This initialization of the comm name could be done only when
* comm_get_name is called */
MPL_strncpy(MPIR_Process.comm_world->name, "MPI_COMM_WORLD", MPI_MAX_OBJECT_NAME);
MPIR_Process.comm_self = MPIR_Comm_builtin + 1;
MPII_Comm_init(MPIR_Process.comm_self);
MPIR_Process.comm_self->handle = MPI_COMM_SELF;
MPIR_Process.comm_self->context_id = 1 << MPIR_CONTEXT_PREFIX_SHIFT;
MPIR_Process.comm_self->recvcontext_id = 1 << MPIR_CONTEXT_PREFIX_SHIFT;
MPIR_Process.comm_self->comm_kind = MPIR_COMM_KIND__INTRACOMM;
MPL_strncpy(MPIR_Process.comm_self->name, "MPI_COMM_SELF", MPI_MAX_OBJECT_NAME);
#ifdef MPID_NEEDS_ICOMM_WORLD
MPIR_Process.icomm_world = MPIR_Comm_builtin + 2;
MPII_Comm_init(MPIR_Process.icomm_world);
MPIR_Process.icomm_world->handle = MPIR_ICOMM_WORLD;
MPIR_Process.icomm_world->context_id = 2 << MPIR_CONTEXT_PREFIX_SHIFT;
MPIR_Process.icomm_world->recvcontext_id = 2 << MPIR_CONTEXT_PREFIX_SHIFT;
MPIR_Process.icomm_world->comm_kind = MPIR_COMM_KIND__INTRACOMM;
MPL_strncpy(MPIR_Process.icomm_world->name, "MPI_ICOMM_WORLD", MPI_MAX_OBJECT_NAME);
/* Note that these communicators are not ready for use - MPID_Init
* will setup self and world, and icomm_world if it desires it. */
#endif
MPIR_Process.comm_parent = NULL;
/* Setup the initial communicator list in case we have
* enabled the debugger message-queue interface */
MPII_COMML_REMEMBER(MPIR_Process.comm_world);
MPII_COMML_REMEMBER(MPIR_Process.comm_self);
/* MPIU_Timer_pre_init(); */
/* Wait for debugger to attach if requested. */
if (MPIR_CVAR_DEBUG_HOLD) {
volatile int hold = 1;
while (hold)
#ifdef HAVE_USLEEP
usleep(100);
#endif
;
}
#if defined(HAVE_ERROR_CHECKING) && (HAVE_ERROR_CHECKING == MPID_ERROR_LEVEL_RUNTIME)
MPIR_Process.do_error_checks = MPIR_CVAR_ERROR_CHECKING;
#endif
/* define MPI as initialized so that we can use MPI functions within
* MPID_Init if necessary */
OPA_store_int(&MPIR_Process.mpich_state, MPICH_MPI_STATE__IN_INIT);
/* We can't acquire any critical sections until this point. Any
* earlier the basic data structures haven't been initialized */
MPID_THREAD_CS_ENTER(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX);
exit_init_cs_on_failure = 1;
/* create MPI_INFO_NULL object */
/* FIXME: Currently this info object is empty, we need to add data to this
* as defined by the standard. */
info_ptr = MPIR_Info_builtin + 1;
info_ptr->handle = MPI_INFO_ENV;
MPIR_Object_set_ref(info_ptr, 1);
info_ptr->next = NULL;
info_ptr->key = NULL;
info_ptr->value = NULL;
#ifdef USE_MEMORY_TRACING
MPL_trinit();
#endif
/* Set the number of tag bits. The device may override this value. */
MPIR_Process.tag_bits = MPIR_TAG_BITS_DEFAULT;
/* Create complete request to return in the event of immediately complete
* operations. Use a SEND request to cover all possible use-cases. */
MPIR_Process.lw_req = MPIR_Request_create(MPIR_REQUEST_KIND__SEND);
MPIR_ERR_CHKANDSTMT(MPIR_Process.lw_req == NULL, mpi_errno, MPIX_ERR_NOREQ, goto fn_fail,
"**nomemreq");
MPIR_cc_set(&MPIR_Process.lw_req->cc, 0);
mpi_errno = MPID_Init(argc, argv, required, &thread_provided, &has_args, &has_env);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
/* Initialize collectives infrastructure */
mpi_errno = MPII_Coll_init();
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
/* Set tag_ub as function of tag_bits set by the device */
MPIR_Process.attrs.tag_ub = MPIR_TAG_USABLE_BITS;
/* Assert: tag_ub should be a power of 2 minus 1 */
MPIR_Assert(((unsigned) MPIR_Process.
attrs.tag_ub & ((unsigned) MPIR_Process.attrs.tag_ub + 1)) == 0);
/* Assert: tag_ub is at least the minimum asked for in the MPI spec */
MPIR_Assert(MPIR_Process.attrs.tag_ub >= 32767);
/* Capture the level of thread support provided */
MPIR_ThreadInfo.thread_provided = thread_provided;
if (provided)
*provided = thread_provided;
#if defined MPICH_IS_THREADED
MPIR_ThreadInfo.isThreaded = (thread_provided == MPI_THREAD_MULTIPLE);
#endif /* MPICH_IS_THREADED */
/* FIXME: Define these in the interface. Does Timer init belong here? */
MPII_Timer_init(MPIR_Process.comm_world->rank, MPIR_Process.comm_world->local_size);
#ifdef USE_MEMORY_TRACING
#ifdef MPICH_IS_THREADED
MPL_trconfig(MPIR_Process.comm_world->rank, MPIR_ThreadInfo.isThreaded);
#else
MPL_trconfig(MPIR_Process.comm_world->rank, 0);
#endif
/* Indicate that we are near the end of the init step; memory
* allocated already will have an id of zero; this helps
* separate memory leaks in the initialization code from
* leaks in the "active" code */
#endif
#ifdef MPL_USE_DBG_LOGGING
/* FIXME: This is a hack to handle the common case of two worlds.
* If the parent comm is not NULL, we always give the world number
* as "1" (false). */
#ifdef MPICH_IS_THREADED
MPL_dbg_init(argc, argv, has_args, has_env,
MPIR_Process.comm_parent != NULL, MPIR_Process.comm_world->rank,
MPIR_ThreadInfo.isThreaded);
#else
MPL_dbg_init(argc, argv, has_args, has_env,
MPIR_Process.comm_parent != NULL, MPIR_Process.comm_world->rank, 0);
#endif
MPIR_DBG_INIT = MPL_dbg_class_alloc("INIT", "init");
MPIR_DBG_PT2PT = MPL_dbg_class_alloc("PT2PT", "pt2pt");
MPIR_DBG_THREAD = MPL_dbg_class_alloc("THREAD", "thread");
MPIR_DBG_DATATYPE = MPL_dbg_class_alloc("DATATYPE", "datatype");
MPIR_DBG_HANDLE = MPL_dbg_class_alloc("HANDLE", "handle");
MPIR_DBG_COMM = MPL_dbg_class_alloc("COMM", "comm");
MPIR_DBG_BSEND = MPL_dbg_class_alloc("BSEND", "bsend");
MPIR_DBG_ERRHAND = MPL_dbg_class_alloc("ERRHAND", "errhand");
MPIR_DBG_OTHER = MPL_dbg_class_alloc("OTHER", "other");
MPIR_DBG_REQUEST = MPL_dbg_class_alloc("REQUEST", "request");
MPIR_DBG_COLL = MPL_dbg_class_alloc("COLL", "coll");
MPIR_DBG_ASSERT = MPL_dbg_class_alloc("ASSERT", "assert");
MPIR_DBG_STRING = MPL_dbg_class_alloc("STRING", "string");
#endif
/* Initialize the C versions of the Fortran link-time constants.
*
* We now initialize the Fortran symbols from within the Fortran
* interface in the routine that first needs the symbols.
* This fixes a problem with symbols added by a Fortran compiler that
* are not part of the C runtime environment (the Portland group
* compilers would do this)
*/
#if defined(HAVE_FORTRAN_BINDING) && defined(HAVE_MPI_F_INIT_WORKS_WITH_C)
mpirinitf_();
#endif
/* FIXME: Does this need to come before the call to MPID_InitComplete?
* For some debugger support, MPII_Wait_for_debugger may want to use
* MPI communication routines to collect information for the debugger */
#ifdef HAVE_DEBUGGER_SUPPORT
MPII_Wait_for_debugger();
#endif
/* Let the device know that the rest of the init process is completed */
if (mpi_errno == MPI_SUCCESS)
mpi_errno = MPID_InitCompleted();
MPID_THREAD_CS_EXIT(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX);
/* Make fields of MPIR_Process global visible and set mpich_state
* atomically so that MPI_Initialized() etc. are thread safe */
OPA_write_barrier();
OPA_store_int(&MPIR_Process.mpich_state, MPICH_MPI_STATE__POST_INIT);
return mpi_errno;
fn_fail:
/* --BEGIN ERROR HANDLING-- */
/* signal to error handling routines that core services are unavailable */
OPA_store_int(&MPIR_Process.mpich_state, MPICH_MPI_STATE__PRE_INIT);
if (exit_init_cs_on_failure) {
MPID_THREAD_CS_EXIT(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX);
}
#if defined(MPICH_IS_THREADED)
if (cs_initialized) {
MPIR_Thread_CS_Finalize();
}
#endif
return mpi_errno;
/* --END ERROR HANDLING-- */
}
/* comm create impl for intracommunicators, assumes that the standard error
* checking has already taken place in the calling function */
int MPIR_Comm_create_intra(MPID_Comm *comm_ptr, MPID_Group *group_ptr,
MPID_Comm **newcomm_ptr)
{
int mpi_errno = MPI_SUCCESS;
MPIU_Context_id_t new_context_id = 0;
int *mapping = NULL;
int n;
MPID_MPI_STATE_DECL(MPID_STATE_MPIR_COMM_CREATE_INTRA);
MPID_MPI_FUNC_ENTER(MPID_STATE_MPIR_COMM_CREATE_INTRA);
MPIU_Assert(comm_ptr->comm_kind == MPID_INTRACOMM);
n = group_ptr->size;
*newcomm_ptr = NULL;
/* Create a new communicator from the specified group members */
/* Creating the context id is collective over the *input* communicator,
so it must be created before we decide if this process is a
member of the group */
/* In the multi-threaded case, MPIR_Get_contextid_sparse assumes that the
calling routine already holds the single criticial section */
mpi_errno = MPIR_Get_contextid_sparse( comm_ptr, &new_context_id,
group_ptr->rank == MPI_UNDEFINED );
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
MPIU_Assert(new_context_id != 0);
if (group_ptr->rank != MPI_UNDEFINED) {
MPID_Comm *mapping_comm = NULL;
mpi_errno = MPIR_Comm_create_calculate_mapping(group_ptr, comm_ptr,
&mapping, &mapping_comm);
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
/* Get the new communicator structure and context id */
mpi_errno = MPIR_Comm_create( newcomm_ptr );
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
(*newcomm_ptr)->recvcontext_id = new_context_id;
(*newcomm_ptr)->rank = group_ptr->rank;
(*newcomm_ptr)->comm_kind = comm_ptr->comm_kind;
/* Since the group has been provided, let the new communicator know
about the group */
(*newcomm_ptr)->local_comm = 0;
(*newcomm_ptr)->local_group = group_ptr;
MPIR_Group_add_ref( group_ptr );
(*newcomm_ptr)->remote_group = group_ptr;
MPIR_Group_add_ref( group_ptr );
(*newcomm_ptr)->context_id = (*newcomm_ptr)->recvcontext_id;
(*newcomm_ptr)->remote_size = (*newcomm_ptr)->local_size = n;
/* Setup the communicator's network address mapping. This is for the remote group,
which is the same as the local group for intracommunicators */
mpi_errno = MPIR_Comm_create_map(n, 0,
mapping,
NULL,
mapping_comm,
*newcomm_ptr);
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
mpi_errno = MPIR_Comm_commit(*newcomm_ptr);
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
}
else {
/* This process is not in the group */
new_context_id = 0;
}
fn_exit:
if (mapping)
MPL_free(mapping);
MPID_MPI_FUNC_EXIT(MPID_STATE_MPIR_COMM_CREATE_INTRA);
return mpi_errno;
fn_fail:
/* --BEGIN ERROR HANDLING-- */
if (*newcomm_ptr != NULL) {
MPIR_Comm_release(*newcomm_ptr);
new_context_id = 0; /* MPIR_Comm_release frees the new ctx id */
}
if (new_context_id != 0 && group_ptr->rank != MPI_UNDEFINED) {
MPIR_Free_contextid(new_context_id);
}
/* --END ERROR HANDLING-- */
goto fn_exit;
}
int MPID_PG_ForwardPGInfo( MPID_Comm *peer_ptr, MPID_Comm *comm_ptr,
int nPGids, const MPID_Gpid in_gpids[],
int root )
{
int mpi_errno = MPI_SUCCESS;
int i, allfound = 1, pgid, pgidWorld;
MPIDI_PG_t *pg = 0;
MPIDI_PG_iterator iter;
MPIR_Errflag_t errflag = MPIR_ERR_NONE;
const int *gpids = (const int*)&in_gpids[0];
/* Get the pgid for CommWorld (always attached to the first process
group) */
MPIDI_PG_Get_iterator(&iter);
MPIDI_PG_Get_next( &iter, &pg );
MPIDI_PG_IdToNum( pg, &pgidWorld );
/* Extract the unique process groups */
for (i=0; i<nPGids && allfound; i++) {
if (gpids[0] != pgidWorld) {
/* Add this gpid to the list of values to check */
/* FIXME: For testing, we just test in place */
MPIDI_PG_Get_iterator(&iter);
do {
MPIDI_PG_Get_next( &iter, &pg );
if (!pg) {
/* We don't know this pgid */
allfound = 0;
break;
}
MPIDI_PG_IdToNum( pg, &pgid );
} while (pgid != gpids[0]);
}
gpids += 2;
}
/* See if everyone is happy */
mpi_errno = MPIR_Allreduce_impl( MPI_IN_PLACE, &allfound, 1, MPI_INT, MPI_LAND, comm_ptr, &errflag );
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
MPIR_ERR_CHKANDJUMP(errflag, mpi_errno, MPI_ERR_OTHER, "**coll_fail");
if (allfound) return MPI_SUCCESS;
/* FIXME: We need a cleaner way to handle this case than using an ifdef.
We could have an empty version of MPID_PG_BCast in ch3u_port.c, but
that's a rather crude way of addressing this problem. Better is to
make the handling of local and remote PIDS for the dynamic process
case part of the dynamic process "module"; devices that don't support
dynamic processes (and hence have only COMM_WORLD) could optimize for
that case */
#ifndef MPIDI_CH3_HAS_NO_DYNAMIC_PROCESS
/* We need to share the process groups. We use routines
from ch3u_port.c */
MPID_PG_BCast( peer_ptr, comm_ptr, root );
#endif
fn_exit:
return MPI_SUCCESS;
fn_fail:
goto fn_exit;
}
int MPIR_Ireduce_scatter_sched_intra_recursive_doubling(const void *sendbuf, void *recvbuf, const int recvcounts[],
MPI_Datatype datatype, MPI_Op op, MPIR_Comm *comm_ptr,
MPIR_Sched_t s)
{
int mpi_errno = MPI_SUCCESS;
int rank, comm_size, i;
MPI_Aint extent, true_extent, true_lb;
int *disps;
void *tmp_recvbuf, *tmp_results;
int type_size ATTRIBUTE((unused)), dis[2], blklens[2], total_count, dst;
int mask, dst_tree_root, my_tree_root, j, k;
int received;
MPI_Datatype sendtype, recvtype;
int nprocs_completed, tmp_mask, tree_root, is_commutative;
MPIR_SCHED_CHKPMEM_DECL(5);
comm_size = comm_ptr->local_size;
rank = comm_ptr->rank;
MPIR_Datatype_get_extent_macro(datatype, extent);
MPIR_Type_get_true_extent_impl(datatype, &true_lb, &true_extent);
is_commutative = MPIR_Op_is_commutative(op);
MPIR_SCHED_CHKPMEM_MALLOC(disps, int *, comm_size * sizeof(int), mpi_errno, "disps", MPL_MEM_BUFFER);
total_count = 0;
for (i=0; i<comm_size; i++) {
disps[i] = total_count;
total_count += recvcounts[i];
}
if (total_count == 0) {
goto fn_exit;
}
MPIR_Datatype_get_size_macro(datatype, type_size);
/* total_count*extent eventually gets malloced. it isn't added to
* a user-passed in buffer */
MPIR_Ensure_Aint_fits_in_pointer(total_count * MPL_MAX(true_extent, extent));
/* need to allocate temporary buffer to receive incoming data*/
MPIR_SCHED_CHKPMEM_MALLOC(tmp_recvbuf, void *, total_count*(MPL_MAX(true_extent,extent)), mpi_errno, "tmp_recvbuf", MPL_MEM_BUFFER);
/* adjust for potential negative lower bound in datatype */
tmp_recvbuf = (void *)((char*)tmp_recvbuf - true_lb);
/* need to allocate another temporary buffer to accumulate
results */
MPIR_SCHED_CHKPMEM_MALLOC(tmp_results, void *, total_count*(MPL_MAX(true_extent,extent)), mpi_errno, "tmp_results", MPL_MEM_BUFFER);
/* adjust for potential negative lower bound in datatype */
tmp_results = (void *)((char*)tmp_results - true_lb);
/* copy sendbuf into tmp_results */
if (sendbuf != MPI_IN_PLACE)
mpi_errno = MPIR_Sched_copy(sendbuf, total_count, datatype,
tmp_results, total_count, datatype, s);
else
mpi_errno = MPIR_Sched_copy(recvbuf, total_count, datatype,
tmp_results, total_count, datatype, s);
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
MPIR_SCHED_BARRIER(s);
mask = 0x1;
i = 0;
while (mask < comm_size) {
dst = rank ^ mask;
dst_tree_root = dst >> i;
dst_tree_root <<= i;
my_tree_root = rank >> i;
my_tree_root <<= i;
/* At step 1, processes exchange (n-n/p) amount of
data; at step 2, (n-2n/p) amount of data; at step 3, (n-4n/p)
amount of data, and so forth. We use derived datatypes for this.
At each step, a process does not need to send data
indexed from my_tree_root to
my_tree_root+mask-1. Similarly, a process won't receive
data indexed from dst_tree_root to dst_tree_root+mask-1. */
/* calculate sendtype */
blklens[0] = blklens[1] = 0;
for (j=0; j<my_tree_root; j++)
blklens[0] += recvcounts[j];
for (j=my_tree_root+mask; j<comm_size; j++)
blklens[1] += recvcounts[j];
dis[0] = 0;
dis[1] = blklens[0];
for (j=my_tree_root; (j<my_tree_root+mask) && (j<comm_size); j++)
dis[1] += recvcounts[j];
mpi_errno = MPIR_Type_indexed_impl(2, blklens, dis, datatype, &sendtype);
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
mpi_errno = MPIR_Type_commit_impl(&sendtype);
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
/* calculate recvtype */
blklens[0] = blklens[1] = 0;
for (j=0; j<dst_tree_root && j<comm_size; j++)
blklens[0] += recvcounts[j];
for (j=dst_tree_root+mask; j<comm_size; j++)
blklens[1] += recvcounts[j];
dis[0] = 0;
dis[1] = blklens[0];
for (j=dst_tree_root; (j<dst_tree_root+mask) && (j<comm_size); j++)
dis[1] += recvcounts[j];
mpi_errno = MPIR_Type_indexed_impl(2, blklens, dis, datatype, &recvtype);
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
mpi_errno = MPIR_Type_commit_impl(&recvtype);
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
received = 0;
if (dst < comm_size) {
/* tmp_results contains data to be sent in each step. Data is
received in tmp_recvbuf and then accumulated into
tmp_results. accumulation is done later below. */
mpi_errno = MPIR_Sched_send(tmp_results, 1, sendtype, dst, comm_ptr, s);
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
mpi_errno = MPIR_Sched_recv(tmp_recvbuf, 1, recvtype, dst, comm_ptr, s);
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
MPIR_SCHED_BARRIER(s);
received = 1;
}
/* if some processes in this process's subtree in this step
did not have any destination process to communicate with
because of non-power-of-two, we need to send them the
result. We use a logarithmic recursive-halfing algorithm
for this. */
if (dst_tree_root + mask > comm_size) {
nprocs_completed = comm_size - my_tree_root - mask;
/* nprocs_completed is the number of processes in this
subtree that have all the data. Send data to others
in a tree fashion. First find root of current tree
that is being divided into two. k is the number of
least-significant bits in this process's rank that
must be zeroed out to find the rank of the root */
j = mask;
k = 0;
while (j) {
j >>= 1;
k++;
}
k--;
tmp_mask = mask >> 1;
while (tmp_mask) {
dst = rank ^ tmp_mask;
tree_root = rank >> k;
tree_root <<= k;
/* send only if this proc has data and destination
doesn't have data. at any step, multiple processes
can send if they have the data */
if ((dst > rank) &&
(rank < tree_root + nprocs_completed)
&& (dst >= tree_root + nprocs_completed))
{
/* send the current result */
mpi_errno = MPIR_Sched_send(tmp_recvbuf, 1, recvtype, dst, comm_ptr, s);
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
MPIR_SCHED_BARRIER(s);
}
/* recv only if this proc. doesn't have data and sender
has data */
else if ((dst < rank) &&
(dst < tree_root + nprocs_completed) &&
(rank >= tree_root + nprocs_completed))
{
mpi_errno = MPIR_Sched_recv(tmp_recvbuf, 1, recvtype, dst, comm_ptr, s);
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
MPIR_SCHED_BARRIER(s);
received = 1;
}
tmp_mask >>= 1;
k--;
}
}
/* N.B. The following comment comes from the FT version of
* MPI_Reduce_scatter. It does not currently apply to this code, but
* will in the future when we update the NBC code to be fault-tolerant
* in roughly the same fashion. [goodell@ 2011-03-03] */
/* The following reduction is done here instead of after
the MPIC_Sendrecv or MPIC_Recv above. This is
because to do it above, in the noncommutative
case, we would need an extra temp buffer so as not to
overwrite temp_recvbuf, because temp_recvbuf may have
to be communicated to other processes in the
non-power-of-two case. To avoid that extra allocation,
we do the reduce here. */
if (received) {
if (is_commutative || (dst_tree_root < my_tree_root)) {
mpi_errno = MPIR_Sched_reduce(tmp_recvbuf, tmp_results, blklens[0], datatype, op, s);
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
mpi_errno = MPIR_Sched_reduce(((char *)tmp_recvbuf + dis[1]*extent),
((char *)tmp_results + dis[1]*extent),
blklens[1], datatype, op, s);
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
MPIR_SCHED_BARRIER(s);
}
else {
mpi_errno = MPIR_Sched_reduce(tmp_results, tmp_recvbuf, blklens[0], datatype, op, s);
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
mpi_errno = MPIR_Sched_reduce(((char *)tmp_results + dis[1]*extent),
((char *)tmp_recvbuf + dis[1]*extent),
blklens[1], datatype, op, s);
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
MPIR_SCHED_BARRIER(s);
/* copy result back into tmp_results */
mpi_errno = MPIR_Sched_copy(tmp_recvbuf, 1, recvtype,
tmp_results, 1, recvtype, s);
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
MPIR_SCHED_BARRIER(s);
}
}
MPIR_Type_free_impl(&sendtype);
MPIR_Type_free_impl(&recvtype);
mask <<= 1;
i++;
}
/* XXX DJG FIXME at some point this should poll, much like the newtcp module.
But then we have that whole pollfd array to manage, which we don't really
need until this proof-of-concept proves itself. */
int MPID_nem_lmt_vmsplice_progress(void)
{
int mpi_errno = MPI_SUCCESS;
struct lmt_vmsplice_node *prev = NULL;
struct lmt_vmsplice_node *free_me = NULL;
struct lmt_vmsplice_node *cur = outstanding_head;
MPIDI_STATE_DECL(MPID_STATE_MPID_NEM_LMT_VMSPLICE_PROGRESS);
MPIDI_FUNC_ENTER(MPID_STATE_MPID_NEM_LMT_VMSPLICE_PROGRESS);
while (cur) {
int complete = 0;
switch (MPIDI_Request_get_type(cur->req)) {
case MPIDI_REQUEST_TYPE_RECV:
mpi_errno = do_readv(cur->req, cur->pipe_fd, cur->req->dev.iov,
&cur->req->dev.iov_offset,
&cur->req->dev.iov_count, &complete);
/* FIXME: set the error status of the req and complete it, rather than POP */
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
break;
case MPIDI_REQUEST_TYPE_SEND:
mpi_errno = do_vmsplice(cur->req, cur->pipe_fd, cur->req->dev.iov,
&cur->req->dev.iov_offset,
&cur->req->dev.iov_count, &complete);
/* FIXME: set the error status of the req and complete it, rather than POP */
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
break;
default:
MPIR_ERR_INTERNALANDJUMP(mpi_errno, "unexpected request type");
break;
}
if (complete) {
MPIU_DBG_MSG(CH3_CHANNEL, VERBOSE, ".... complete");
/* remove the node from the list */
if (cur == outstanding_head) {
outstanding_head = cur->next;
prev = NULL;
free_me = cur;
cur = cur->next;
}
else {
prev->next = cur->next;
prev = cur;
free_me = cur;
cur = cur->next;
}
if (free_me) MPIU_Free(free_me);
--MPID_nem_local_lmt_pending;
}
if (!cur) break; /* we might have made cur NULL above */
prev = cur;
cur = cur->next;
}
fn_exit:
MPIDI_FUNC_EXIT(MPID_STATE_MPID_NEM_LMT_VMSPLICE_PROGRESS);
return mpi_errno;
fn_fail:
goto fn_exit;
}
/*@
MPI_Get_elements - Returns the number of basic elements
in a datatype
Input Parameters:
+ status - return status of receive operation (Status)
- datatype - datatype used by receive operation (handle)
Output Parameters:
. count - number of received basic elements (integer)
Notes:
If the size of the datatype is zero and the amount of data returned as
determined by 'status' is also zero, this routine will return a count of
zero. This is consistent with a clarification made by the MPI Forum.
.N Fortran
.N Errors
.N MPI_SUCCESS
@*/
int MPI_Get_elements(const MPI_Status *status, MPI_Datatype datatype, int *count)
{
int mpi_errno = MPI_SUCCESS;
MPI_Count count_x;
MPID_MPI_STATE_DECL(MPID_STATE_MPI_GET_ELEMENTS);
MPIR_ERRTEST_INITIALIZED_ORDIE();
MPID_MPI_FUNC_ENTER(MPID_STATE_MPI_GET_ELEMENTS);
/* Validate parameters, especially handles needing to be converted */
# ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
MPIR_ERRTEST_DATATYPE(datatype, "datatype", mpi_errno);
}
MPID_END_ERROR_CHECKS;
}
# endif
/* Validate parameters and objects (post conversion) */
# ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
MPID_Datatype *datatype_ptr = NULL;
MPIR_ERRTEST_ARGNULL(status, "status", mpi_errno);
MPIR_ERRTEST_ARGNULL(count, "count", mpi_errno);
/* Convert MPI object handles to object pointers */
MPID_Datatype_get_ptr(datatype, datatype_ptr);
/* Validate datatype_ptr */
if (HANDLE_GET_KIND(datatype) != HANDLE_KIND_BUILTIN) {
MPID_Datatype_get_ptr(datatype, datatype_ptr);
MPID_Datatype_valid_ptr(datatype_ptr, mpi_errno);
if (mpi_errno != MPI_SUCCESS) goto fn_fail;
MPID_Datatype_committed_ptr(datatype_ptr, mpi_errno);
if (mpi_errno != MPI_SUCCESS) goto fn_fail;
}
}
MPID_END_ERROR_CHECKS;
}
# endif
/* ... body of routine ... */
mpi_errno = MPIR_Get_elements_x_impl(status, datatype, &count_x);
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
/* clip the value if it cannot be correctly returned to the user */
*count = (count_x > INT_MAX) ? MPI_UNDEFINED : (int)count_x;
/* ... end of body of routine ... */
fn_exit:
MPID_MPI_FUNC_EXIT(MPID_STATE_MPI_GET_ELEMENTS);
return mpi_errno;
/* --BEGIN ERROR HANDLING-- */
fn_fail:
{
mpi_errno = MPIR_Err_create_code(
mpi_errno, MPIR_ERR_RECOVERABLE, FCNAME, __LINE__, MPI_ERR_OTHER,
"**mpi_get_elements",
"**mpi_get_elements %p %D %p", status, datatype, count);
}
mpi_errno = MPIR_Err_return_comm(0, FCNAME, mpi_errno);
goto fn_exit;
/* --END ERROR HANDLING-- */
}
static int ptl_init(MPIDI_PG_t *pg_p, int pg_rank, char **bc_val_p, int *val_max_sz_p)
{
int mpi_errno = MPI_SUCCESS;
int ret;
ptl_md_t md;
ptl_ni_limits_t desired;
MPIR_FUNC_VERBOSE_STATE_DECL(MPID_STATE_PTL_INIT);
MPIR_FUNC_VERBOSE_ENTER(MPID_STATE_PTL_INIT);
/* first make sure that our private fields in the vc and req fit into the area provided */
MPIR_Assert(sizeof(MPID_nem_ptl_vc_area) <= MPIDI_NEM_VC_NETMOD_AREA_LEN);
MPIR_Assert(sizeof(MPID_nem_ptl_req_area) <= MPIDI_NEM_REQ_NETMOD_AREA_LEN);
/* Make sure our IOV is the same as portals4's IOV */
MPIR_Assert(sizeof(ptl_iovec_t) == sizeof(MPL_IOV));
MPIR_Assert(((void*)&(((ptl_iovec_t*)0)->iov_base)) == ((void*)&(((MPL_IOV*)0)->MPL_IOV_BUF)));
MPIR_Assert(((void*)&(((ptl_iovec_t*)0)->iov_len)) == ((void*)&(((MPL_IOV*)0)->MPL_IOV_LEN)));
MPIR_Assert(sizeof(((ptl_iovec_t*)0)->iov_len) == sizeof(((MPL_IOV*)0)->MPL_IOV_LEN));
mpi_errno = MPIDI_CH3I_Register_anysource_notification(MPID_nem_ptl_anysource_posted, MPID_nem_ptl_anysource_matched);
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
MPIDI_Anysource_improbe_fn = MPID_nem_ptl_anysource_improbe;
/* init portals */
ret = PtlInit();
MPIR_ERR_CHKANDJUMP1(ret, mpi_errno, MPI_ERR_OTHER, "**ptlinit", "**ptlinit %s", MPID_nem_ptl_strerror(ret));
/* do an interface pre-init to get the default limits struct */
ret = PtlNIInit(PTL_IFACE_DEFAULT, PTL_NI_MATCHING | PTL_NI_PHYSICAL,
PTL_PID_ANY, NULL, &desired, &MPIDI_nem_ptl_ni);
MPIR_ERR_CHKANDJUMP1(ret, mpi_errno, MPI_ERR_OTHER, "**ptlniinit", "**ptlniinit %s", MPID_nem_ptl_strerror(ret));
/* finalize the interface so we can re-init with our desired maximums */
ret = PtlNIFini(MPIDI_nem_ptl_ni);
MPIR_ERR_CHKANDJUMP1(ret, mpi_errno, MPI_ERR_OTHER, "**ptlnifini", "**ptlnifini %s", MPID_nem_ptl_strerror(ret));
/* set higher limits if they are determined to be too low */
if (desired.max_unexpected_headers < UNEXPECTED_HDR_COUNT && getenv("PTL_LIM_MAX_UNEXPECTED_HEADERS") == NULL)
desired.max_unexpected_headers = UNEXPECTED_HDR_COUNT;
if (desired.max_list_size < LIST_SIZE && getenv("PTL_LIM_MAX_LIST_SIZE") == NULL)
desired.max_list_size = LIST_SIZE;
if (desired.max_entries < ENTRY_COUNT && getenv("PTL_LIM_MAX_ENTRIES") == NULL)
desired.max_entries = ENTRY_COUNT;
/* do the real init */
ret = PtlNIInit(PTL_IFACE_DEFAULT, PTL_NI_MATCHING | PTL_NI_PHYSICAL,
PTL_PID_ANY, &desired, &MPIDI_nem_ptl_ni_limits, &MPIDI_nem_ptl_ni);
MPIR_ERR_CHKANDJUMP1(ret, mpi_errno, MPI_ERR_OTHER, "**ptlniinit", "**ptlniinit %s", MPID_nem_ptl_strerror(ret));
/* allocate EQs for each portal */
ret = PtlEQAlloc(MPIDI_nem_ptl_ni, EVENT_COUNT, &MPIDI_nem_ptl_eq);
MPIR_ERR_CHKANDJUMP1(ret, mpi_errno, MPI_ERR_OTHER, "**ptleqalloc", "**ptleqalloc %s", MPID_nem_ptl_strerror(ret));
ret = PtlEQAlloc(MPIDI_nem_ptl_ni, EVENT_COUNT, &MPIDI_nem_ptl_get_eq);
MPIR_ERR_CHKANDJUMP1(ret, mpi_errno, MPI_ERR_OTHER, "**ptleqalloc", "**ptleqalloc %s", MPID_nem_ptl_strerror(ret));
ret = PtlEQAlloc(MPIDI_nem_ptl_ni, EVENT_COUNT, &MPIDI_nem_ptl_control_eq);
MPIR_ERR_CHKANDJUMP1(ret, mpi_errno, MPI_ERR_OTHER, "**ptleqalloc", "**ptleqalloc %s", MPID_nem_ptl_strerror(ret));
ret = PtlEQAlloc(MPIDI_nem_ptl_ni, EVENT_COUNT, &MPIDI_nem_ptl_rpt_eq);
MPIR_ERR_CHKANDJUMP1(ret, mpi_errno, MPI_ERR_OTHER, "**ptleqalloc", "**ptleqalloc %s", MPID_nem_ptl_strerror(ret));
/* allocate a separate EQ for origin events. with this, we can implement rate-limit operations
to prevent a locally triggered flow control even */
ret = PtlEQAlloc(MPIDI_nem_ptl_ni, EVENT_COUNT, &MPIDI_nem_ptl_origin_eq);
MPIR_ERR_CHKANDJUMP1(ret, mpi_errno, MPI_ERR_OTHER, "**ptleqalloc", "**ptleqalloc %s", MPID_nem_ptl_strerror(ret));
/* allocate portal for matching messages */
ret = PtlPTAlloc(MPIDI_nem_ptl_ni, PTL_PT_ONLY_USE_ONCE | PTL_PT_ONLY_TRUNCATE | PTL_PT_FLOWCTRL, MPIDI_nem_ptl_eq,
PTL_PT_ANY, &MPIDI_nem_ptl_pt);
MPIR_ERR_CHKANDJUMP1(ret, mpi_errno, MPI_ERR_OTHER, "**ptlptalloc", "**ptlptalloc %s", MPID_nem_ptl_strerror(ret));
/* allocate portal for large messages where receiver does a get */
ret = PtlPTAlloc(MPIDI_nem_ptl_ni, PTL_PT_ONLY_USE_ONCE | PTL_PT_ONLY_TRUNCATE | PTL_PT_FLOWCTRL, MPIDI_nem_ptl_get_eq,
PTL_PT_ANY, &MPIDI_nem_ptl_get_pt);
MPIR_ERR_CHKANDJUMP1(ret, mpi_errno, MPI_ERR_OTHER, "**ptlptalloc", "**ptlptalloc %s", MPID_nem_ptl_strerror(ret));
/* allocate portal for MPICH control messages */
ret = PtlPTAlloc(MPIDI_nem_ptl_ni, PTL_PT_ONLY_USE_ONCE | PTL_PT_ONLY_TRUNCATE | PTL_PT_FLOWCTRL, MPIDI_nem_ptl_control_eq,
PTL_PT_ANY, &MPIDI_nem_ptl_control_pt);
MPIR_ERR_CHKANDJUMP1(ret, mpi_errno, MPI_ERR_OTHER, "**ptlptalloc", "**ptlptalloc %s", MPID_nem_ptl_strerror(ret));
/* allocate portal for MPICH control messages */
ret = PtlPTAlloc(MPIDI_nem_ptl_ni, PTL_PT_ONLY_USE_ONCE | PTL_PT_ONLY_TRUNCATE | PTL_PT_FLOWCTRL, MPIDI_nem_ptl_rpt_eq,
PTL_PT_ANY, &MPIDI_nem_ptl_rpt_pt);
MPIR_ERR_CHKANDJUMP1(ret, mpi_errno, MPI_ERR_OTHER, "**ptlptalloc", "**ptlptalloc %s", MPID_nem_ptl_strerror(ret));
/* allocate portal for MPICH control messages */
ret = PtlPTAlloc(MPIDI_nem_ptl_ni, PTL_PT_ONLY_USE_ONCE | PTL_PT_ONLY_TRUNCATE | PTL_PT_FLOWCTRL, MPIDI_nem_ptl_rpt_eq,
PTL_PT_ANY, &MPIDI_nem_ptl_get_rpt_pt);
MPIR_ERR_CHKANDJUMP1(ret, mpi_errno, MPI_ERR_OTHER, "**ptlptalloc", "**ptlptalloc %s", MPID_nem_ptl_strerror(ret));
/* allocate portal for MPICH control messages */
ret = PtlPTAlloc(MPIDI_nem_ptl_ni, PTL_PT_ONLY_USE_ONCE | PTL_PT_ONLY_TRUNCATE | PTL_PT_FLOWCTRL, MPIDI_nem_ptl_rpt_eq,
PTL_PT_ANY, &MPIDI_nem_ptl_control_rpt_pt);
MPIR_ERR_CHKANDJUMP1(ret, mpi_errno, MPI_ERR_OTHER, "**ptlptalloc", "**ptlptalloc %s", MPID_nem_ptl_strerror(ret));
/* create an MD that covers all of memory */
md.start = 0;
md.length = (ptl_size_t)-1;
md.options = 0x0;
md.eq_handle = MPIDI_nem_ptl_origin_eq;
md.ct_handle = PTL_CT_NONE;
ret = PtlMDBind(MPIDI_nem_ptl_ni, &md, &MPIDI_nem_ptl_global_md);
MPIR_ERR_CHKANDJUMP1(ret, mpi_errno, MPI_ERR_OTHER, "**ptlmdbind", "**ptlmdbind %s", MPID_nem_ptl_strerror(ret));
/* currently, rportlas only works with a single NI and EQ */
ret = MPID_nem_ptl_rptl_init(MPIDI_Process.my_pg->size, ORIGIN_EVENTS, get_target_info);
MPIR_ERR_CHKANDJUMP1(ret, mpi_errno, MPI_ERR_OTHER, "**ptlniinit", "**ptlniinit %s", MPID_nem_ptl_strerror(ret));
/* allow rportal to manage the primary portal and retransmit if needed */
ret = MPID_nem_ptl_rptl_ptinit(MPIDI_nem_ptl_ni, MPIDI_nem_ptl_origin_eq, MPIDI_nem_ptl_pt, MPIDI_nem_ptl_rpt_pt);
MPIR_ERR_CHKANDJUMP1(ret, mpi_errno, MPI_ERR_OTHER, "**ptlptalloc", "**ptlptalloc %s", MPID_nem_ptl_strerror(ret));
/* allow rportal to manage the get and control portals, but we
* don't expect retransmission to be needed on the get portal, so
* we pass PTL_PT_ANY as the dummy portal. unfortunately, portals
* does not have an "invalid" PT constant, which would have been
* more appropriate to pass over here. */
ret = MPID_nem_ptl_rptl_ptinit(MPIDI_nem_ptl_ni, MPIDI_nem_ptl_origin_eq, MPIDI_nem_ptl_get_pt, MPIDI_nem_ptl_get_rpt_pt);
MPIR_ERR_CHKANDJUMP1(ret, mpi_errno, MPI_ERR_OTHER, "**ptlptalloc", "**ptlptalloc %s", MPID_nem_ptl_strerror(ret));
ret = MPID_nem_ptl_rptl_ptinit(MPIDI_nem_ptl_ni, MPIDI_nem_ptl_origin_eq, MPIDI_nem_ptl_control_pt, MPIDI_nem_ptl_control_rpt_pt);
MPIR_ERR_CHKANDJUMP1(ret, mpi_errno, MPI_ERR_OTHER, "**ptlptalloc", "**ptlptalloc %s", MPID_nem_ptl_strerror(ret));
/* create business card */
mpi_errno = get_business_card(pg_rank, bc_val_p, val_max_sz_p);
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
/* init other modules */
mpi_errno = MPID_nem_ptl_poll_init();
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
mpi_errno = MPID_nem_ptl_nm_init();
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
fn_exit:
MPIR_FUNC_VERBOSE_EXIT(MPID_STATE_PTL_INIT);
return mpi_errno;
fn_fail:
goto fn_exit;
}
static int ptl_finalize(void)
{
int mpi_errno = MPI_SUCCESS;
int ret;
ptl_handle_eq_t eqs[5];
MPIR_FUNC_VERBOSE_STATE_DECL(MPID_STATE_PTL_FINALIZE);
MPIR_FUNC_VERBOSE_ENTER(MPID_STATE_PTL_FINALIZE);
/* shut down other modules */
mpi_errno = MPID_nem_ptl_nm_finalize();
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
mpi_errno = MPID_nem_ptl_poll_finalize();
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
/* shut down portals */
eqs[0] = MPIDI_nem_ptl_eq;
eqs[1] = MPIDI_nem_ptl_get_eq;
eqs[2] = MPIDI_nem_ptl_control_eq;
eqs[3] = MPIDI_nem_ptl_origin_eq;
eqs[4] = MPIDI_nem_ptl_rpt_eq;
ret = MPID_nem_ptl_rptl_drain_eq(5, eqs);
MPIR_ERR_CHKANDJUMP1(ret, mpi_errno, MPI_ERR_OTHER, "**ptlptfree", "**ptlptfree %s", MPID_nem_ptl_strerror(ret));
ret = MPID_nem_ptl_rptl_ptfini(MPIDI_nem_ptl_pt);
MPIR_ERR_CHKANDJUMP1(ret, mpi_errno, MPI_ERR_OTHER, "**ptlptfree", "**ptlptfree %s", MPID_nem_ptl_strerror(ret));
ret = PtlPTFree(MPIDI_nem_ptl_ni, MPIDI_nem_ptl_pt);
MPIR_ERR_CHKANDJUMP1(ret, mpi_errno, MPI_ERR_OTHER, "**ptlptfree", "**ptlptfree %s", MPID_nem_ptl_strerror(ret));
ret = MPID_nem_ptl_rptl_ptfini(MPIDI_nem_ptl_get_pt);
MPIR_ERR_CHKANDJUMP1(ret, mpi_errno, MPI_ERR_OTHER, "**ptlptfree", "**ptlptfree %s", MPID_nem_ptl_strerror(ret));
ret = PtlPTFree(MPIDI_nem_ptl_ni, MPIDI_nem_ptl_get_pt);
MPIR_ERR_CHKANDJUMP1(ret, mpi_errno, MPI_ERR_OTHER, "**ptlptfree", "**ptlptfree %s", MPID_nem_ptl_strerror(ret));
ret = MPID_nem_ptl_rptl_ptfini(MPIDI_nem_ptl_control_pt);
MPIR_ERR_CHKANDJUMP1(ret, mpi_errno, MPI_ERR_OTHER, "**ptlptfree", "**ptlptfree %s", MPID_nem_ptl_strerror(ret));
ret = PtlPTFree(MPIDI_nem_ptl_ni, MPIDI_nem_ptl_control_pt);
MPIR_ERR_CHKANDJUMP1(ret, mpi_errno, MPI_ERR_OTHER, "**ptlptfree", "**ptlptfree %s", MPID_nem_ptl_strerror(ret));
ret = PtlPTFree(MPIDI_nem_ptl_ni, MPIDI_nem_ptl_rpt_pt);
MPIR_ERR_CHKANDJUMP1(ret, mpi_errno, MPI_ERR_OTHER, "**ptlptfree", "**ptlptfree %s", MPID_nem_ptl_strerror(ret));
ret = PtlPTFree(MPIDI_nem_ptl_ni, MPIDI_nem_ptl_get_rpt_pt);
MPIR_ERR_CHKANDJUMP1(ret, mpi_errno, MPI_ERR_OTHER, "**ptlptfree", "**ptlptfree %s", MPID_nem_ptl_strerror(ret));
ret = PtlPTFree(MPIDI_nem_ptl_ni, MPIDI_nem_ptl_control_rpt_pt);
MPIR_ERR_CHKANDJUMP1(ret, mpi_errno, MPI_ERR_OTHER, "**ptlptfree", "**ptlptfree %s", MPID_nem_ptl_strerror(ret));
ret = PtlNIFini(MPIDI_nem_ptl_ni);
MPIR_ERR_CHKANDJUMP1(ret, mpi_errno, MPI_ERR_OTHER, "**ptlnifini", "**ptlnifini %s", MPID_nem_ptl_strerror(ret));
PtlFini();
fn_exit:
MPIR_FUNC_VERBOSE_EXIT(MPID_STATE_PTL_FINALIZE);
return mpi_errno;
fn_fail:
goto fn_exit;
}
static int MPIDI_CH3I_Win_allocate_shm(MPI_Aint size, int disp_unit, MPIR_Info * info,
MPIR_Comm * comm_ptr, void *base_ptr, MPIR_Win ** win_ptr)
{
int mpi_errno = MPI_SUCCESS;
void **base_pp = (void **) base_ptr;
int i, node_size, node_rank;
MPIR_Comm *node_comm_ptr;
MPI_Aint *node_sizes;
MPIR_Errflag_t errflag = MPIR_ERR_NONE;
int noncontig = FALSE;
MPIR_CHKPMEM_DECL(1);
MPIR_CHKLMEM_DECL(1);
MPIR_FUNC_VERBOSE_STATE_DECL(MPID_STATE_MPIDI_CH3I_WIN_ALLOCATE_SHM);
MPIR_FUNC_VERBOSE_RMA_ENTER(MPID_STATE_MPIDI_CH3I_WIN_ALLOCATE_SHM);
if ((*win_ptr)->comm_ptr->node_comm == NULL) {
mpi_errno =
MPIDI_CH3U_Win_allocate_no_shm(size, disp_unit, info, comm_ptr, base_ptr, win_ptr);
goto fn_exit;
}
/* see if we can allocate all windows contiguously */
noncontig = (*win_ptr)->info_args.alloc_shared_noncontig;
(*win_ptr)->shm_allocated = TRUE;
/* When allocating shared memory region segment, we need comm of processes
* that are on the same node as this process (node_comm).
* If node_comm == NULL, this process is the only one on this node, therefore
* we use comm_self as node comm. */
node_comm_ptr = (*win_ptr)->comm_ptr->node_comm;
MPIR_Assert(node_comm_ptr != NULL);
node_size = node_comm_ptr->local_size;
node_rank = node_comm_ptr->rank;
MPIR_T_PVAR_TIMER_START(RMA, rma_wincreate_allgather);
/* allocate memory for the base addresses, disp_units, and
* completion counters of all processes */
MPIR_CHKPMEM_MALLOC((*win_ptr)->shm_base_addrs, void **,
node_size * sizeof(void *), mpi_errno, "(*win_ptr)->shm_base_addrs");
/* get the sizes of the windows and window objectsof
* all processes. allocate temp. buffer for communication */
MPIR_CHKLMEM_MALLOC(node_sizes, MPI_Aint *, node_size * sizeof(MPI_Aint), mpi_errno,
"node_sizes");
/* FIXME: This needs to be fixed for heterogeneous systems */
node_sizes[node_rank] = (MPI_Aint) size;
mpi_errno = MPIR_Allgather_impl(MPI_IN_PLACE, 0, MPI_DATATYPE_NULL,
node_sizes, sizeof(MPI_Aint), MPI_BYTE,
node_comm_ptr, &errflag);
MPIR_T_PVAR_TIMER_END(RMA, rma_wincreate_allgather);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
MPIR_ERR_CHKANDJUMP(errflag, mpi_errno, MPI_ERR_OTHER, "**coll_fail");
(*win_ptr)->shm_segment_len = 0;
for (i = 0; i < node_size; i++) {
if (noncontig)
/* Round up to next page size */
(*win_ptr)->shm_segment_len += MPIDI_CH3_ROUND_UP_PAGESIZE(node_sizes[i]);
else
(*win_ptr)->shm_segment_len += node_sizes[i];
}
if ((*win_ptr)->shm_segment_len == 0) {
(*win_ptr)->base = NULL;
}
else {
mpi_errno = MPL_shm_hnd_init(&(*win_ptr)->shm_segment_handle);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
if (node_rank == 0) {
char *serialized_hnd_ptr = NULL;
/* create shared memory region for all processes in win and map */
mpi_errno =
MPL_shm_seg_create_and_attach((*win_ptr)->shm_segment_handle,
(*win_ptr)->shm_segment_len,
(char **) &(*win_ptr)->shm_base_addr, 0);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
/* serialize handle and broadcast it to the other processes in win */
mpi_errno =
MPL_shm_hnd_get_serialized_by_ref((*win_ptr)->shm_segment_handle,
&serialized_hnd_ptr);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
mpi_errno =
MPIR_Bcast_impl(serialized_hnd_ptr, MPL_SHM_GHND_SZ, MPI_CHAR, 0, node_comm_ptr,
&errflag);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
MPIR_ERR_CHKANDJUMP(errflag, mpi_errno, MPI_ERR_OTHER, "**coll_fail");
/* wait for other processes to attach to win */
mpi_errno = MPIR_Barrier_impl(node_comm_ptr, &errflag);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
MPIR_ERR_CHKANDJUMP(errflag, mpi_errno, MPI_ERR_OTHER, "**coll_fail");
/* unlink shared memory region so it gets deleted when all processes exit */
mpi_errno = MPL_shm_seg_remove((*win_ptr)->shm_segment_handle);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
}
else {
char serialized_hnd[MPL_SHM_GHND_SZ] = { 0 };
/* get serialized handle from rank 0 and deserialize it */
mpi_errno =
MPIR_Bcast_impl(serialized_hnd, MPL_SHM_GHND_SZ, MPI_CHAR, 0, node_comm_ptr,
&errflag);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
MPIR_ERR_CHKANDJUMP(errflag, mpi_errno, MPI_ERR_OTHER, "**coll_fail");
mpi_errno =
MPL_shm_hnd_deserialize((*win_ptr)->shm_segment_handle, serialized_hnd,
strlen(serialized_hnd));
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
/* attach to shared memory region created by rank 0 */
mpi_errno =
MPL_shm_seg_attach((*win_ptr)->shm_segment_handle, (*win_ptr)->shm_segment_len,
(char **) &(*win_ptr)->shm_base_addr, 0);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
mpi_errno = MPIR_Barrier_impl(node_comm_ptr, &errflag);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
MPIR_ERR_CHKANDJUMP(errflag, mpi_errno, MPI_ERR_OTHER, "**coll_fail");
}
/* Allocated the interprocess mutex segment. */
mpi_errno = MPL_shm_hnd_init(&(*win_ptr)->shm_mutex_segment_handle);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
if (node_rank == 0) {
char *serialized_hnd_ptr = NULL;
/* create shared memory region for all processes in win and map */
mpi_errno =
MPL_shm_seg_create_and_attach((*win_ptr)->shm_mutex_segment_handle,
sizeof(MPIDI_CH3I_SHM_MUTEX),
(char **) &(*win_ptr)->shm_mutex, 0);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
MPIDI_CH3I_SHM_MUTEX_INIT(*win_ptr);
/* serialize handle and broadcast it to the other processes in win */
mpi_errno =
MPL_shm_hnd_get_serialized_by_ref((*win_ptr)->shm_mutex_segment_handle,
&serialized_hnd_ptr);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
mpi_errno =
MPIR_Bcast_impl(serialized_hnd_ptr, MPL_SHM_GHND_SZ, MPI_CHAR, 0, node_comm_ptr,
&errflag);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
MPIR_ERR_CHKANDJUMP(errflag, mpi_errno, MPI_ERR_OTHER, "**coll_fail");
/* wait for other processes to attach to win */
mpi_errno = MPIR_Barrier_impl(node_comm_ptr, &errflag);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
MPIR_ERR_CHKANDJUMP(errflag, mpi_errno, MPI_ERR_OTHER, "**coll_fail");
/* unlink shared memory region so it gets deleted when all processes exit */
mpi_errno = MPL_shm_seg_remove((*win_ptr)->shm_mutex_segment_handle);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
}
else {
char serialized_hnd[MPL_SHM_GHND_SZ] = { 0 };
/* get serialized handle from rank 0 and deserialize it */
mpi_errno =
MPIR_Bcast_impl(serialized_hnd, MPL_SHM_GHND_SZ, MPI_CHAR, 0, node_comm_ptr,
&errflag);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
MPIR_ERR_CHKANDJUMP(errflag, mpi_errno, MPI_ERR_OTHER, "**coll_fail");
mpi_errno =
MPL_shm_hnd_deserialize((*win_ptr)->shm_mutex_segment_handle, serialized_hnd,
strlen(serialized_hnd));
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
/* attach to shared memory region created by rank 0 */
mpi_errno =
MPL_shm_seg_attach((*win_ptr)->shm_mutex_segment_handle,
sizeof(MPIDI_CH3I_SHM_MUTEX), (char **) &(*win_ptr)->shm_mutex,
0);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
mpi_errno = MPIR_Barrier_impl(node_comm_ptr, &errflag);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
MPIR_ERR_CHKANDJUMP(errflag, mpi_errno, MPI_ERR_OTHER, "**coll_fail");
}
/* compute the base addresses of each process within the shared memory segment */
{
char *cur_base;
int cur_rank;
cur_base = (*win_ptr)->shm_base_addr;
cur_rank = 0;
((*win_ptr)->shm_base_addrs)[0] = (*win_ptr)->shm_base_addr;
for (i = 1; i < node_size; ++i) {
if (node_sizes[i]) {
/* For the base addresses, we track the previous
* process that has allocated non-zero bytes of shared
* memory. We can not simply use "i-1" for the
* previous process because rank "i-1" might not have
* allocated any memory. */
if (noncontig) {
((*win_ptr)->shm_base_addrs)[i] =
cur_base + MPIDI_CH3_ROUND_UP_PAGESIZE(node_sizes[cur_rank]);
}
else {
((*win_ptr)->shm_base_addrs)[i] = cur_base + node_sizes[cur_rank];
}
cur_base = ((*win_ptr)->shm_base_addrs)[i];
cur_rank = i;
}
else {
((*win_ptr)->shm_base_addrs)[i] = NULL;
}
}
}
(*win_ptr)->base = (*win_ptr)->shm_base_addrs[node_rank];
}
*base_pp = (*win_ptr)->base;
/* gather window information among processes via shared memory region. */
mpi_errno = MPIDI_CH3I_Win_gather_info((*base_pp), size, disp_unit, info, comm_ptr, win_ptr);
if (mpi_errno != MPI_SUCCESS)
MPIR_ERR_POP(mpi_errno);
/* Cache SHM windows */
MPIDI_CH3I_SHM_Wins_append(&shm_wins_list, (*win_ptr));
fn_exit:
MPIR_CHKLMEM_FREEALL();
MPIR_FUNC_VERBOSE_RMA_EXIT(MPID_STATE_MPIDI_CH3I_WIN_ALLOCATE_SHM);
return mpi_errno;
/* --BEGIN ERROR HANDLING-- */
fn_fail:
MPIR_CHKPMEM_REAP();
goto fn_exit;
/* --END ERROR HANDLING-- */
}
/*@
MPI_Neighbor_alltoallw - Like MPI_Neighbor_alltoallv but it allows one to send
and receive with different types to and from each neighbor.
Input Parameters:
+ sendbuf - starting address of the send buffer (choice)
. sendcounts - non-negative integer array (of length outdegree) specifying the number of elements to send to each neighbor
. sdispls - integer array (of length outdegree). Entry j specifies the displacement in bytes (relative to sendbuf) from which to take the outgoing data destined for neighbor j (array of integers)
. sendtypes - array of datatypes (of length outdegree). Entry j specifies the type of data to send to neighbor j (array of handles)
. recvcounts - non-negative integer array (of length indegree) specifying the number of elements that are received from each neighbor
. rdispls - integer array (of length indegree). Entry i specifies the displacement in bytes (relative to recvbuf) at which to place the incoming data from neighbor i (array of integers).
. recvtypes - array of datatypes (of length indegree). Entry i specifies the type of data received from neighbor i (array of handles).
- comm - communicator with topology structure (handle)
Output Parameters:
. recvbuf - starting address of the receive buffer (choice)
.N ThreadSafe
.N Fortran
.N Errors
@*/
int MPI_Neighbor_alltoallw(const void *sendbuf, const int sendcounts[], const MPI_Aint sdispls[], const MPI_Datatype sendtypes[], void *recvbuf, const int recvcounts[], const MPI_Aint rdispls[], const MPI_Datatype recvtypes[], MPI_Comm comm)
{
int mpi_errno = MPI_SUCCESS;
MPIR_Comm *comm_ptr = NULL;
MPIR_FUNC_TERSE_STATE_DECL(MPID_STATE_MPI_NEIGHBOR_ALLTOALLW);
MPID_THREAD_CS_ENTER(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX);
MPIR_FUNC_TERSE_ENTER(MPID_STATE_MPI_NEIGHBOR_ALLTOALLW);
/* Validate parameters, especially handles needing to be converted */
# ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS
{
MPIR_ERRTEST_COMM(comm, mpi_errno);
/* TODO more checks may be appropriate */
if (mpi_errno != MPI_SUCCESS) goto fn_fail;
}
MPID_END_ERROR_CHECKS
}
# endif /* HAVE_ERROR_CHECKING */
/* Convert MPI object handles to object pointers */
MPIR_Comm_get_ptr(comm, comm_ptr);
/* Validate parameters and objects (post conversion) */
# ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS
{
MPIR_Comm_valid_ptr( comm_ptr, mpi_errno, FALSE );
/* TODO more checks may be appropriate (counts, in_place, buffer aliasing, etc) */
if (mpi_errno != MPI_SUCCESS) goto fn_fail;
}
MPID_END_ERROR_CHECKS
}
# endif /* HAVE_ERROR_CHECKING */
/* ... body of routine ... */
mpi_errno = MPID_Neighbor_alltoallw(sendbuf, sendcounts, sdispls, sendtypes, recvbuf, recvcounts, rdispls, recvtypes, comm_ptr);
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
/* ... end of body of routine ... */
fn_exit:
MPIR_FUNC_TERSE_EXIT(MPID_STATE_MPI_NEIGHBOR_ALLTOALLW);
MPID_THREAD_CS_EXIT(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX);
return mpi_errno;
fn_fail:
/* --BEGIN ERROR HANDLING-- */
# ifdef HAVE_ERROR_CHECKING
{
mpi_errno = MPIR_Err_create_code(
mpi_errno, MPIR_ERR_RECOVERABLE, FCNAME, __LINE__, MPI_ERR_OTHER,
"**mpi_neighbor_alltoallw", "**mpi_neighbor_alltoallw %p %p %p %p %p %p %p %p %C", sendbuf, sendcounts, sdispls, sendtypes, recvbuf, recvcounts, rdispls, recvtypes, comm);
}
# endif
mpi_errno = MPIR_Err_return_comm(NULL, FCNAME, mpi_errno);
goto fn_exit;
/* --END ERROR HANDLING-- */
}
static int MPIDI_CH3I_Win_gather_info(void *base, MPI_Aint size, int disp_unit, MPIR_Info * info,
MPIR_Comm * comm_ptr, MPIR_Win ** win_ptr)
{
MPIR_Comm *node_comm_ptr = NULL;
int node_rank;
int comm_rank, comm_size;
MPI_Aint *tmp_buf = NULL;
int i, k;
MPIR_Errflag_t errflag = MPIR_ERR_NONE;
int mpi_errno = MPI_SUCCESS;
MPIR_CHKLMEM_DECL(1);
MPIR_FUNC_VERBOSE_STATE_DECL(MPID_STATE_MPIDI_CH3I_WIN_GATHER_INFO);
MPIR_FUNC_VERBOSE_RMA_ENTER(MPID_STATE_MPIDI_CH3I_WIN_GATHER_INFO);
if ((*win_ptr)->comm_ptr->node_comm == NULL) {
mpi_errno = MPIDI_CH3U_Win_gather_info(base, size, disp_unit, info, comm_ptr, win_ptr);
goto fn_exit;
}
comm_size = (*win_ptr)->comm_ptr->local_size;
comm_rank = (*win_ptr)->comm_ptr->rank;
node_comm_ptr = (*win_ptr)->comm_ptr->node_comm;
MPIR_Assert(node_comm_ptr != NULL);
node_rank = node_comm_ptr->rank;
(*win_ptr)->info_shm_segment_len = comm_size * sizeof(MPIDI_Win_basic_info_t);
mpi_errno = MPL_shm_hnd_init(&(*win_ptr)->info_shm_segment_handle);
if (mpi_errno != MPI_SUCCESS)
MPIR_ERR_POP(mpi_errno);
if (node_rank == 0) {
char *serialized_hnd_ptr = NULL;
/* create shared memory region for all processes in win and map. */
mpi_errno = MPL_shm_seg_create_and_attach((*win_ptr)->info_shm_segment_handle,
(*win_ptr)->info_shm_segment_len,
(char **) &(*win_ptr)->info_shm_base_addr, 0);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
/* serialize handle and broadcast it to the other processes in win */
mpi_errno =
MPL_shm_hnd_get_serialized_by_ref((*win_ptr)->info_shm_segment_handle,
&serialized_hnd_ptr);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
mpi_errno =
MPIR_Bcast_impl(serialized_hnd_ptr, MPL_SHM_GHND_SZ, MPI_CHAR, 0, node_comm_ptr,
&errflag);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
MPIR_ERR_CHKANDJUMP(errflag, mpi_errno, MPI_ERR_OTHER, "**coll_fail");
/* wait for other processes to attach to win */
mpi_errno = MPIR_Barrier_impl(node_comm_ptr, &errflag);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
MPIR_ERR_CHKANDJUMP(errflag, mpi_errno, MPI_ERR_OTHER, "**coll_fail");
/* unlink shared memory region so it gets deleted when all processes exit */
mpi_errno = MPL_shm_seg_remove((*win_ptr)->info_shm_segment_handle);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
}
else {
char serialized_hnd[MPL_SHM_GHND_SZ] = { 0 };
/* get serialized handle from rank 0 and deserialize it */
mpi_errno =
MPIR_Bcast_impl(serialized_hnd, MPL_SHM_GHND_SZ, MPI_CHAR, 0, node_comm_ptr,
&errflag);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
MPIR_ERR_CHKANDJUMP(errflag, mpi_errno, MPI_ERR_OTHER, "**coll_fail");
mpi_errno = MPL_shm_hnd_deserialize((*win_ptr)->info_shm_segment_handle, serialized_hnd,
strlen(serialized_hnd));
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
/* attach to shared memory region created by rank 0 */
mpi_errno =
MPL_shm_seg_attach((*win_ptr)->info_shm_segment_handle,
(*win_ptr)->info_shm_segment_len,
(char **) &(*win_ptr)->info_shm_base_addr, 0);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
mpi_errno = MPIR_Barrier_impl(node_comm_ptr, &errflag);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
MPIR_ERR_CHKANDJUMP(errflag, mpi_errno, MPI_ERR_OTHER, "**coll_fail");
}
(*win_ptr)->basic_info_table = (MPIDI_Win_basic_info_t *) ((*win_ptr)->info_shm_base_addr);
MPIR_CHKLMEM_MALLOC(tmp_buf, MPI_Aint *, 4 * comm_size * sizeof(MPI_Aint),
mpi_errno, "tmp_buf");
tmp_buf[4 * comm_rank] = MPIR_Ptr_to_aint(base);
tmp_buf[4 * comm_rank + 1] = size;
tmp_buf[4 * comm_rank + 2] = (MPI_Aint) disp_unit;
tmp_buf[4 * comm_rank + 3] = (MPI_Aint) (*win_ptr)->handle;
mpi_errno = MPIR_Allgather_impl(MPI_IN_PLACE, 0, MPI_DATATYPE_NULL, tmp_buf, 4, MPI_AINT,
(*win_ptr)->comm_ptr, &errflag);
if (mpi_errno != MPI_SUCCESS)
MPIR_ERR_POP(mpi_errno);
if (node_rank == 0) {
/* only node_rank == 0 writes results to basic_info_table on shared memory region. */
k = 0;
for (i = 0; i < comm_size; i++) {
(*win_ptr)->basic_info_table[i].base_addr = MPIR_Aint_to_ptr(tmp_buf[k++]);
(*win_ptr)->basic_info_table[i].size = tmp_buf[k++];
(*win_ptr)->basic_info_table[i].disp_unit = (int) tmp_buf[k++];
(*win_ptr)->basic_info_table[i].win_handle = (MPI_Win) tmp_buf[k++];
}
}
/* Make sure that all local processes see the results written by node_rank == 0 */
mpi_errno = MPIR_Barrier_impl(node_comm_ptr, &errflag);
if (mpi_errno != MPI_SUCCESS)
MPIR_ERR_POP(mpi_errno);
fn_exit:
MPIR_CHKLMEM_FREEALL();
MPIR_FUNC_VERBOSE_RMA_EXIT(MPID_STATE_MPIDI_CH3I_WIN_GATHER_INFO);
return mpi_errno;
/* --BEGIN ERROR HANDLING-- */
fn_fail:
goto fn_exit;
/* --END ERROR HANDLING-- */
}
static int MPIDI_CH3I_SHM_Wins_match(MPIR_Win ** win_ptr, MPIR_Win ** matched_win,
MPI_Aint ** base_shm_offs_ptr)
{
int mpi_errno = MPI_SUCCESS;
int i, comm_size;
int node_size, node_rank, shm_node_size;
int group_diff;
int base_diff;
MPIR_Comm *node_comm_ptr = NULL, *shm_node_comm_ptr = NULL;
int *node_ranks = NULL, *node_ranks_in_shm_node = NULL;
MPIR_Group *node_group_ptr = NULL, *shm_node_group_ptr = NULL;
MPIR_Errflag_t errflag = MPIR_ERR_NONE;
MPI_Aint *base_shm_offs;
MPIDI_SHM_Win_t *elem = shm_wins_list;
MPIR_CHKLMEM_DECL(2);
MPIR_FUNC_VERBOSE_STATE_DECL(MPID_STATE_MPIDI_CH3I_SHM_WINS_MATCH);
MPIR_FUNC_VERBOSE_RMA_ENTER(MPID_STATE_MPIDI_CH3I_SHM_WINS_MATCH);
*matched_win = NULL;
base_shm_offs = *base_shm_offs_ptr;
node_comm_ptr = (*win_ptr)->comm_ptr->node_comm;
MPIR_Assert(node_comm_ptr != NULL);
node_size = node_comm_ptr->local_size;
node_rank = node_comm_ptr->rank;
comm_size = (*win_ptr)->comm_ptr->local_size;
MPIR_CHKLMEM_MALLOC(node_ranks, int *, node_size * sizeof(int), mpi_errno, "node_ranks");
MPIR_CHKLMEM_MALLOC(node_ranks_in_shm_node, int *, node_size * sizeof(int),
mpi_errno, "node_ranks_in_shm_comm");
for (i = 0; i < node_size; i++) {
node_ranks[i] = i;
}
mpi_errno = MPIR_Comm_group_impl(node_comm_ptr, &node_group_ptr);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
while (elem != NULL) {
MPIR_Win *shm_win = elem->win;
if (!shm_win)
MPIDI_SHM_Wins_next_and_continue(elem);
/* Compare node_comm.
*
* Only support shm if new node_comm is equal to or a subset of shm node_comm.
* Shm node_comm == a subset of node_comm is not supported, because it means
* some processes of node_comm cannot be shared, but RMA operation simply checks
* the node_id of a target process for distinguishing shm target. */
shm_node_comm_ptr = shm_win->comm_ptr->node_comm;
shm_node_size = shm_node_comm_ptr->local_size;
if (node_size > shm_node_size)
MPIDI_SHM_Wins_next_and_continue(elem);
mpi_errno = MPIR_Comm_group_impl(shm_win->comm_ptr, &shm_node_group_ptr);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
mpi_errno = MPIR_Group_translate_ranks_impl(node_group_ptr, node_size,
node_ranks, shm_node_group_ptr,
node_ranks_in_shm_node);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
mpi_errno = MPIR_Group_free_impl(shm_node_group_ptr);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
shm_node_group_ptr = NULL;
group_diff = 0;
for (i = 0; i < node_size; i++) {
/* not exist in shm_comm->node_comm */
if (node_ranks_in_shm_node[i] == MPI_UNDEFINED) {
group_diff = 1;
break;
}
}
if (group_diff)
MPIDI_SHM_Wins_next_and_continue(elem);
/* Gather the offset of base_addr from all local processes. Match only
* when all of them are included in the shm segment in current shm_win.
*
* Note that this collective call must be called after checking the
* group match in order to guarantee all the local processes can perform
* this call. */
base_shm_offs[node_rank] = (MPI_Aint) ((*win_ptr)->base)
- (MPI_Aint) (shm_win->shm_base_addr);
mpi_errno = MPIR_Allgather_impl(MPI_IN_PLACE, 0, MPI_DATATYPE_NULL,
base_shm_offs, 1, MPI_AINT, node_comm_ptr, &errflag);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
MPIR_ERR_CHKANDJUMP(errflag, mpi_errno, MPI_ERR_OTHER, "**coll_fail");
base_diff = 0;
for (i = 0; i < comm_size; ++i) {
int i_node_rank = (*win_ptr)->comm_ptr->intranode_table[i];
if (i_node_rank >= 0) {
MPIR_Assert(i_node_rank < node_size);
if (base_shm_offs[i_node_rank] < 0 ||
base_shm_offs[i_node_rank] + (*win_ptr)->basic_info_table[i].size >
shm_win->shm_segment_len) {
base_diff = 1;
break;
}
}
}
if (base_diff)
MPIDI_SHM_Wins_next_and_continue(elem);
/* Found the first matched shm_win */
*matched_win = shm_win;
break;
}
fn_exit:
if (node_group_ptr != NULL)
mpi_errno = MPIR_Group_free_impl(node_group_ptr);
/* Only free it here when group_translate_ranks fails. */
if (shm_node_group_ptr != NULL)
mpi_errno = MPIR_Group_free_impl(shm_node_group_ptr);
MPIR_CHKLMEM_FREEALL();
MPIR_FUNC_VERBOSE_RMA_EXIT(MPID_STATE_MPIDI_CH3I_SHM_WINS_MATCH);
return mpi_errno;
/* --BEGIN ERROR HANDLING-- */
fn_fail:
goto fn_exit;
/* --END ERROR HANDLING-- */
}
/*@
MPI_Get_elements_x - Returns the number of basic elements
in a datatype
Input Parameters:
+ status - return status of receive operation (Status)
- datatype - datatype used by receive operation (handle)
Output Parameters:
. count - number of received basic elements (integer)
.N ThreadSafe
.N Fortran
.N Errors
@*/
int MPI_Get_elements_x(const MPI_Status *status, MPI_Datatype datatype, MPI_Count *count)
{
int mpi_errno = MPI_SUCCESS;
MPID_MPI_STATE_DECL(MPID_STATE_MPI_GET_ELEMENTS_X);
MPID_THREAD_CS_ENTER(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX);
MPID_MPI_FUNC_ENTER(MPID_STATE_MPI_GET_ELEMENTS_X);
/* Validate parameters, especially handles needing to be converted */
# ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS
{
MPIR_ERRTEST_DATATYPE(datatype, "datatype", mpi_errno);
/* TODO more checks may be appropriate */
if (mpi_errno != MPI_SUCCESS) goto fn_fail;
}
MPID_END_ERROR_CHECKS
}
# endif /* HAVE_ERROR_CHECKING */
/* Convert MPI object handles to object pointers */
/* Validate parameters and objects (post conversion) */
# ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS
{
if (HANDLE_GET_KIND(datatype) != HANDLE_KIND_BUILTIN) {
MPID_Datatype *datatype_ptr = NULL;
MPID_Datatype_get_ptr(datatype, datatype_ptr);
MPID_Datatype_valid_ptr(datatype_ptr, mpi_errno);
MPID_Datatype_committed_ptr(datatype_ptr, mpi_errno);
}
/* TODO more checks may be appropriate (counts, in_place, buffer aliasing, etc) */
if (mpi_errno != MPI_SUCCESS) goto fn_fail;
}
MPID_END_ERROR_CHECKS
}
# endif /* HAVE_ERROR_CHECKING */
/* ... body of routine ... */
mpi_errno = MPIR_Get_elements_x_impl(status, datatype, count);
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
/* ... end of body of routine ... */
fn_exit:
MPID_MPI_FUNC_EXIT(MPID_STATE_MPI_GET_ELEMENTS_X);
MPID_THREAD_CS_EXIT(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX);
return mpi_errno;
fn_fail:
/* --BEGIN ERROR HANDLING-- */
# ifdef HAVE_ERROR_CHECKING
{
mpi_errno = MPIR_Err_create_code(
mpi_errno, MPIR_ERR_RECOVERABLE, FCNAME, __LINE__, MPI_ERR_OTHER,
"**mpi_get_elements_x", "**mpi_get_elements_x %p %D %p", status, datatype, count);
}
# endif
mpi_errno = MPIR_Err_return_comm(NULL, FCNAME, mpi_errno);
goto fn_exit;
/* --END ERROR HANDLING-- */
}
/*@
MPI_Ssend - Blocking synchronous send
Input Parameters:
+ buf - initial address of send buffer (choice)
. count - number of elements in send buffer (nonnegative integer)
. datatype - datatype of each send buffer element (handle)
. dest - rank of destination (integer)
. tag - message tag (integer)
- comm - communicator (handle)
.N ThreadSafe
.N Fortran
.N Errors
.N MPI_SUCCESS
.N MPI_ERR_COMM
.N MPI_ERR_COUNT
.N MPI_ERR_TYPE
.N MPI_ERR_TAG
.N MPI_ERR_RANK
@*/
int MPI_Ssend(const void *buf, int count, MPI_Datatype datatype, int dest, int tag,
MPI_Comm comm)
{
static const char FCNAME[] = "MPI_Ssend";
int mpi_errno = MPI_SUCCESS;
MPIR_Comm *comm_ptr = NULL;
MPIR_Request * request_ptr = NULL;
MPIR_FUNC_TERSE_STATE_DECL(MPID_STATE_MPI_SSEND);
MPIR_ERRTEST_INITIALIZED_ORDIE();
MPID_THREAD_CS_ENTER(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX);
MPIR_FUNC_TERSE_PT2PT_ENTER_FRONT(MPID_STATE_MPI_SSEND);
/* Validate handle parameters needing to be converted */
# ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
MPIR_ERRTEST_COMM(comm, mpi_errno);
}
MPID_END_ERROR_CHECKS;
}
# endif /* HAVE_ERROR_CHECKING */
/* Convert MPI object handles to object pointers */
MPIR_Comm_get_ptr( comm, comm_ptr );
/* Validate parameters if error checking is enabled */
# ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
MPIR_Comm_valid_ptr( comm_ptr, mpi_errno, FALSE );
if (mpi_errno) goto fn_fail;
MPIR_ERRTEST_COUNT(count, mpi_errno);
MPIR_ERRTEST_SEND_RANK(comm_ptr, dest, mpi_errno);
MPIR_ERRTEST_SEND_TAG(tag, mpi_errno);
/* Validate datatype handle */
MPIR_ERRTEST_DATATYPE(datatype, "datatype", mpi_errno);
/* Validate datatype object */
if (HANDLE_GET_KIND(datatype) != HANDLE_KIND_BUILTIN)
{
MPIR_Datatype *datatype_ptr = NULL;
MPIR_Datatype_get_ptr(datatype, datatype_ptr);
MPIR_Datatype_valid_ptr(datatype_ptr, mpi_errno);
if (mpi_errno) goto fn_fail;
MPIR_Datatype_committed_ptr(datatype_ptr, mpi_errno);
if (mpi_errno) goto fn_fail;
}
/* Validate buffer */
MPIR_ERRTEST_USERBUFFER(buf,count,datatype,mpi_errno);
}
MPID_END_ERROR_CHECKS;
}
# endif /* HAVE_ERROR_CHECKING */
/* ... body of routine ... */
mpi_errno = MPID_Ssend(buf, count, datatype, dest, tag, comm_ptr,
MPIR_CONTEXT_INTRA_PT2PT, &request_ptr);
if (mpi_errno != MPI_SUCCESS) goto fn_fail;
if (request_ptr == NULL)
{
goto fn_exit;
}
/* If a request was returned, then we need to block until the request
is complete */
mpi_errno = MPIR_Progress_wait_request(request_ptr);
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
mpi_errno = request_ptr->status.MPI_ERROR;
MPIR_Request_free(request_ptr);
if (mpi_errno != MPI_SUCCESS) goto fn_fail;
/* ... end of body of routine ... */
fn_exit:
MPIR_FUNC_TERSE_PT2PT_EXIT(MPID_STATE_MPI_SSEND);
MPID_THREAD_CS_EXIT(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX);
return mpi_errno;
fn_fail:
/* --BEGIN ERROR HANDLING-- */
# ifdef HAVE_ERROR_CHECKING
{
mpi_errno = MPIR_Err_create_code(
mpi_errno, MPIR_ERR_RECOVERABLE, FCNAME, __LINE__, MPI_ERR_OTHER, "**mpi_ssend",
"**mpi_ssend %p %d %D %i %t %C", buf, count, datatype, dest, tag, comm);
}
# endif
mpi_errno = MPIR_Err_return_comm( comm_ptr, FCNAME, mpi_errno );
goto fn_exit;
/* --END ERROR HANDLING-- */
}
/*@
MPI_Intercomm_merge - Creates an intracommuncator from an intercommunicator
Input Parameters:
+ intercomm - Intercommunicator (handle)
- high - Used to order the groups within comm (logical)
when creating the new communicator. This is a boolean value; the group
that sets high true has its processes ordered `after` the group that sets
this value to false. If all processes in the intercommunicator provide
the same value, the choice of which group is ordered first is arbitrary.
Output Parameters:
. newintracomm - Created intracommunicator (handle)
Notes:
While all processes may provide the same value for the 'high' parameter,
this requires the MPI implementation to determine which group of
processes should be ranked first.
.N ThreadSafe
.N Fortran
Algorithm:
.Eb
.i Allocate contexts
.i Local and remote group leaders swap high values
.i Determine the high value.
.i Merge the two groups and make the intra-communicator
.Ee
.N Errors
.N MPI_SUCCESS
.N MPI_ERR_COMM
.N MPI_ERR_EXHAUSTED
.seealso: MPI_Intercomm_create, MPI_Comm_free
@*/
int MPI_Intercomm_merge(MPI_Comm intercomm, int high, MPI_Comm *newintracomm)
{
int mpi_errno = MPI_SUCCESS;
MPID_Comm *comm_ptr = NULL;
MPID_Comm *new_intracomm_ptr;
MPID_THREADPRIV_DECL;
MPID_MPI_STATE_DECL(MPID_STATE_MPI_INTERCOMM_MERGE);
MPIR_ERRTEST_INITIALIZED_ORDIE();
MPID_THREAD_CS_ENTER(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX);
MPID_MPI_FUNC_ENTER(MPID_STATE_MPI_INTERCOMM_MERGE);
MPID_THREADPRIV_GET;
/* Validate parameters, especially handles needing to be converted */
# ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
MPIR_ERRTEST_COMM(intercomm, mpi_errno);
}
MPID_END_ERROR_CHECKS;
}
# endif /* HAVE_ERROR_CHECKING */
/* Convert MPI object handles to object pointers */
MPID_Comm_get_ptr( intercomm, comm_ptr );
/* Validate parameters and objects (post conversion) */
# ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
/* Validate comm_ptr */
MPID_Comm_valid_ptr( comm_ptr, mpi_errno, FALSE );
/* If comm_ptr is not valid, it will be reset to null */
if (comm_ptr && comm_ptr->comm_kind != MPID_INTERCOMM) {
mpi_errno = MPIR_Err_create_code( MPI_SUCCESS,
MPIR_ERR_RECOVERABLE, FCNAME, __LINE__, MPI_ERR_COMM,
"**commnotinter", 0 );
}
if (mpi_errno) goto fn_fail;
}
MPID_END_ERROR_CHECKS;
}
# endif /* HAVE_ERROR_CHECKING */
/* Make sure that we have a local intercommunicator */
if (!comm_ptr->local_comm) {
/* Manufacture the local communicator */
MPIR_Setup_intercomm_localcomm( comm_ptr );
}
# ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
int acthigh;
MPIR_Errflag_t errflag = MPIR_ERR_NONE;
/* Check for consistent valus of high in each local group.
The Intel test suite checks for this; it is also an easy
error to make */
acthigh = high ? 1 : 0; /* Clamp high into 1 or 0 */
mpi_errno = MPIR_Allreduce_impl( MPI_IN_PLACE, &acthigh, 1, MPI_INT,
MPI_SUM, comm_ptr->local_comm, &errflag );
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
MPIR_ERR_CHKANDJUMP(errflag, mpi_errno, MPI_ERR_OTHER, "**coll_fail");
/* acthigh must either == 0 or the size of the local comm */
if (acthigh != 0 && acthigh != comm_ptr->local_size) {
mpi_errno = MPIR_Err_create_code( MPI_SUCCESS,
MPIR_ERR_RECOVERABLE, FCNAME, __LINE__, MPI_ERR_ARG,
"**notsame",
"**notsame %s %s", "high",
"MPI_Intercomm_merge" );
goto fn_fail;
}
}
MPID_END_ERROR_CHECKS;
}
# endif /* HAVE_ERROR_CHECKING */
/* ... body of routine ... */
mpi_errno = MPIR_Intercomm_merge_impl(comm_ptr, high, &new_intracomm_ptr);
if (mpi_errno) goto fn_fail;
MPID_OBJ_PUBLISH_HANDLE(*newintracomm, new_intracomm_ptr->handle);
/* ... end of body of routine ... */
fn_exit:
MPID_MPI_FUNC_EXIT(MPID_STATE_MPI_INTERCOMM_MERGE);
MPID_THREAD_CS_EXIT(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX);
return mpi_errno;
fn_fail:
/* --BEGIN ERROR HANDLING-- */
# ifdef HAVE_ERROR_CHECKING
{
mpi_errno = MPIR_Err_create_code(
mpi_errno, MPIR_ERR_RECOVERABLE, FCNAME, __LINE__, MPI_ERR_OTHER,
"**mpi_intercomm_merge",
"**mpi_intercomm_merge %C %d %p", intercomm, high, newintracomm);
}
# endif
mpi_errno = MPIR_Err_return_comm( comm_ptr, FCNAME, mpi_errno );
goto fn_exit;
/* --END ERROR HANDLING-- */
}
/*@
MPI_Type_size - Return the number of bytes occupied by entries
in the datatype
Input Parameters:
. datatype - datatype (handle)
Output Parameters:
. size - datatype size (integer)
.N SignalSafe
.N Fortran
.N Errors
.N MPI_SUCCESS
.N MPI_ERR_TYPE
.N MPI_ERR_ARG
@*/
int MPI_Type_size(MPI_Datatype datatype, int *size)
{
int mpi_errno = MPI_SUCCESS;
MPI_Count size_x = MPI_UNDEFINED;
MPIR_FUNC_TERSE_STATE_DECL(MPID_STATE_MPI_TYPE_SIZE);
MPIR_ERRTEST_INITIALIZED_ORDIE();
MPIR_FUNC_TERSE_ENTER(MPID_STATE_MPI_TYPE_SIZE);
/* Validate parameters, especially handles needing to be converted */
# ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
MPIR_ERRTEST_DATATYPE(datatype, "datatype", mpi_errno);
}
MPID_END_ERROR_CHECKS;
}
# endif /* HAVE_ERROR_CHECKING */
/* If this is a built-in datatype, then get the size out of the handle */
if (HANDLE_GET_KIND(datatype) == HANDLE_KIND_BUILTIN)
{
MPIR_Datatype_get_size_macro(datatype, *size);
goto fn_exit;
}
/* Validate parameters and objects (post conversion) */
# ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
MPIR_Datatype *datatype_ptr = NULL;
/* Convert MPI object handles to object pointers */
MPIR_Datatype_get_ptr( datatype, datatype_ptr );
/* Validate datatype_ptr */
MPIR_Datatype_valid_ptr( datatype_ptr, mpi_errno );
if (mpi_errno) goto fn_fail;
}
MPID_END_ERROR_CHECKS;
}
# endif /* HAVE_ERROR_CHECKING */
/* ... body of routine ... */
mpi_errno = MPIR_Type_size_x_impl(datatype, &size_x);
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
MPIR_Assert(size_x >= 0);
/* handle overflow: see MPI-3 p.104 */
*size = (size_x > INT_MAX) ? MPI_UNDEFINED : (int)size_x;
/* ... end of body of routine ... */
fn_exit:
MPIR_FUNC_TERSE_EXIT(MPID_STATE_MPI_TYPE_SIZE);
return mpi_errno;
/* --BEGIN ERROR HANDLING-- */
fn_fail:
{
mpi_errno = MPIR_Err_create_code(
mpi_errno, MPIR_ERR_RECOVERABLE, FCNAME, __LINE__, MPI_ERR_OTHER,
"**mpi_type_size",
"**mpi_type_size %D %p", datatype, size);
}
mpi_errno = MPIR_Err_return_comm( NULL, FCNAME, mpi_errno );
goto fn_exit;
/* --END ERROR HANDLING-- */
}
int MPIR_Intercomm_merge_impl(MPID_Comm *comm_ptr, int high, MPID_Comm **new_intracomm_ptr)
{
int mpi_errno = MPI_SUCCESS;
int local_high, remote_high, new_size;
MPIU_Context_id_t new_context_id;
MPIR_Errflag_t errflag = MPIR_ERR_NONE;
MPID_MPI_STATE_DECL(MPID_STATE_MPIR_INTERCOMM_MERGE_IMPL);
MPID_MPI_FUNC_ENTER(MPID_STATE_MPIR_INTERCOMM_MERGE_IMPL);
/* Make sure that we have a local intercommunicator */
if (!comm_ptr->local_comm) {
/* Manufacture the local communicator */
mpi_errno = MPIR_Setup_intercomm_localcomm( comm_ptr );
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
}
/* Find the "high" value of the other group of processes. This
will be used to determine which group is ordered first in
the generated communicator. high is logical */
local_high = high;
if (comm_ptr->rank == 0) {
/* This routine allows use to use the collective communication
context rather than the point-to-point context. */
mpi_errno = MPIC_Sendrecv( &local_high, 1, MPI_INT, 0, 0,
&remote_high, 1, MPI_INT, 0, 0, comm_ptr,
MPI_STATUS_IGNORE, &errflag );
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
/* If local_high and remote_high are the same, then order is arbitrary.
we use the gpids of the rank 0 member of the local and remote
groups to choose an order in this case. */
if (local_high == remote_high) {
MPID_Gpid ingpid, outgpid;
mpi_errno = MPID_GPID_Get( comm_ptr, 0, &ingpid );
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
mpi_errno = MPIC_Sendrecv( &ingpid, sizeof(MPID_Gpid), MPI_BYTE, 0, 1,
&outgpid, sizeof(MPID_Gpid), MPI_BYTE, 0, 1, comm_ptr,
MPI_STATUS_IGNORE, &errflag );
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
/* Note that the gpids cannot be the same because we are
starting from a valid intercomm */
int rc = memcmp(&ingpid,&outgpid,sizeof(MPID_Gpid));
if(rc < 0)
local_high = 1;
else if(rc > 0)
local_high = 0;
else
{
/* req#3930: The merge algorithm will deadlock if the gpids are inadvertently the
same due to implementation bugs in the MPID_GPID_Get() function */
MPIU_Assert(rc != 0);
}
}
}
/*
All processes in the local group now need to get the
value of local_high, which may have changed if both groups
of processes had the same value for high
*/
mpi_errno = MPIR_Bcast_impl( &local_high, 1, MPI_INT, 0, comm_ptr->local_comm, &errflag );
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
MPIR_ERR_CHKANDJUMP(errflag, mpi_errno, MPI_ERR_OTHER, "**coll_fail");
mpi_errno = MPIR_Comm_create( new_intracomm_ptr );
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
new_size = comm_ptr->local_size + comm_ptr->remote_size;
/* FIXME: For the intracomm, we need a consistent context id.
That means that one of the two groups needs to use
the recvcontext_id and the other must use the context_id */
if (local_high) {
(*new_intracomm_ptr)->context_id = comm_ptr->recvcontext_id + 2; /* See below */
}
else {
(*new_intracomm_ptr)->context_id = comm_ptr->context_id + 2; /* See below */
}
(*new_intracomm_ptr)->recvcontext_id = (*new_intracomm_ptr)->context_id;
(*new_intracomm_ptr)->remote_size = (*new_intracomm_ptr)->local_size = new_size;
(*new_intracomm_ptr)->rank = -1;
(*new_intracomm_ptr)->comm_kind = MPID_INTRACOMM;
/* Now we know which group comes first. Build the new mapping
from the existing comm */
mpi_errno = create_and_map(comm_ptr, local_high, (*new_intracomm_ptr));
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
/* We've setup a temporary context id, based on the context id
used by the intercomm. This allows us to perform the allreduce
operations within the context id algorithm, since we already
have a valid (almost - see comm_create_hook) communicator.
*/
mpi_errno = MPIR_Comm_commit((*new_intracomm_ptr));
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
/* printf( "About to get context id \n" ); fflush( stdout ); */
/* In the multi-threaded case, MPIR_Get_contextid_sparse assumes that the
calling routine already holds the single criticial section */
new_context_id = 0;
mpi_errno = MPIR_Get_contextid_sparse( (*new_intracomm_ptr), &new_context_id, FALSE );
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
MPIU_Assert(new_context_id != 0);
/* We release this communicator that was involved just to
* get valid context id and create true one
*/
mpi_errno = MPIR_Comm_release(*new_intracomm_ptr);
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
mpi_errno = MPIR_Comm_create( new_intracomm_ptr );
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
(*new_intracomm_ptr)->remote_size = (*new_intracomm_ptr)->local_size = new_size;
(*new_intracomm_ptr)->rank = -1;
(*new_intracomm_ptr)->comm_kind = MPID_INTRACOMM;
(*new_intracomm_ptr)->context_id = new_context_id;
(*new_intracomm_ptr)->recvcontext_id = new_context_id;
mpi_errno = create_and_map(comm_ptr, local_high, (*new_intracomm_ptr));
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
mpi_errno = MPIR_Comm_commit((*new_intracomm_ptr));
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
fn_exit:
MPID_MPI_FUNC_EXIT(MPID_STATE_MPIR_INTERCOMM_MERGE_IMPL);
return mpi_errno;
fn_fail:
goto fn_exit;
}
/*@
MPI_Neighbor_allgather - In this function, each process i gathers data items
from each process j if an edge (j,i) exists in the topology graph, and each
process i sends the same data items to all processes j where an edge (i,j)
exists. The send buffer is sent to each neighboring process and the l-th block
in the receive buffer is received from the l-th neighbor.
Input Parameters:
+ sendbuf - starting address of the send buffer (choice)
. sendcount - number of elements sent to each neighbor (non-negative integer)
. sendtype - data type of send buffer elements (handle)
. recvcount - number of elements received from each neighbor (non-negative integer)
. recvtype - data type of receive buffer elements (handle)
- comm - communicator (handle)
Output Parameters:
. recvbuf - starting address of the receive buffer (choice)
.N ThreadSafe
.N Fortran
.N Errors
@*/
int MPI_Neighbor_allgather(const void *sendbuf, int sendcount, MPI_Datatype sendtype, void *recvbuf,
int recvcount, MPI_Datatype recvtype, MPI_Comm comm)
{
int mpi_errno = MPI_SUCCESS;
MPIR_Comm *comm_ptr = NULL;
MPIR_FUNC_TERSE_STATE_DECL(MPID_STATE_MPI_NEIGHBOR_ALLGATHER);
MPID_THREAD_CS_ENTER(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX);
MPIR_FUNC_TERSE_ENTER(MPID_STATE_MPI_NEIGHBOR_ALLGATHER);
/* Validate parameters, especially handles needing to be converted */
#ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
MPIR_ERRTEST_DATATYPE(sendtype, "sendtype", mpi_errno);
MPIR_ERRTEST_DATATYPE(recvtype, "recvtype", mpi_errno);
MPIR_ERRTEST_COMM(comm, mpi_errno);
/* TODO more checks may be appropriate */
}
MPID_END_ERROR_CHECKS;
}
#endif /* HAVE_ERROR_CHECKING */
/* Convert MPI object handles to object pointers */
MPIR_Comm_get_ptr(comm, comm_ptr);
/* Validate parameters and objects (post conversion) */
#ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
if (HANDLE_GET_KIND(sendtype) != HANDLE_KIND_BUILTIN) {
MPIR_Datatype *sendtype_ptr = NULL;
MPIR_Datatype_get_ptr(sendtype, sendtype_ptr);
MPIR_Datatype_valid_ptr(sendtype_ptr, mpi_errno);
MPIR_Datatype_committed_ptr(sendtype_ptr, mpi_errno);
}
if (HANDLE_GET_KIND(recvtype) != HANDLE_KIND_BUILTIN) {
MPIR_Datatype *recvtype_ptr = NULL;
MPIR_Datatype_get_ptr(recvtype, recvtype_ptr);
MPIR_Datatype_valid_ptr(recvtype_ptr, mpi_errno);
MPIR_Datatype_committed_ptr(recvtype_ptr, mpi_errno);
}
MPIR_Comm_valid_ptr(comm_ptr, mpi_errno, FALSE);
/* TODO more checks may be appropriate (counts, in_place, buffer aliasing, etc) */
if (mpi_errno != MPI_SUCCESS)
goto fn_fail;
}
MPID_END_ERROR_CHECKS;
}
#endif /* HAVE_ERROR_CHECKING */
/* ... body of routine ... */
mpi_errno = MPIR_Neighbor_allgather(sendbuf, sendcount, sendtype, recvbuf,
recvcount, recvtype, comm_ptr);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
/* ... end of body of routine ... */
fn_exit:
MPIR_FUNC_TERSE_EXIT(MPID_STATE_MPI_NEIGHBOR_ALLGATHER);
MPID_THREAD_CS_EXIT(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX);
return mpi_errno;
fn_fail:
/* --BEGIN ERROR HANDLING-- */
#ifdef HAVE_ERROR_CHECKING
{
mpi_errno =
MPIR_Err_create_code(mpi_errno, MPIR_ERR_RECOVERABLE, __func__, __LINE__, MPI_ERR_OTHER,
"**mpi_neighbor_allgather",
"**mpi_neighbor_allgather %p %d %D %p %d %D %C", sendbuf,
sendcount, sendtype, recvbuf, recvcount, recvtype, comm);
}
#endif
mpi_errno = MPIR_Err_return_comm(NULL, __func__, mpi_errno);
goto fn_exit;
/* --END ERROR HANDLING-- */
}
int MPIR_Alltoall_intra(
const void *sendbuf,
int sendcount,
MPI_Datatype sendtype,
void *recvbuf,
int recvcount,
MPI_Datatype recvtype,
MPIR_Comm *comm_ptr,
MPIR_Errflag_t *errflag )
{
int comm_size, i, j, pof2;
MPI_Aint sendtype_extent, recvtype_extent;
MPI_Aint recvtype_true_extent, recvbuf_extent, recvtype_true_lb;
int mpi_errno=MPI_SUCCESS, src, dst, rank, nbytes;
int mpi_errno_ret = MPI_SUCCESS;
MPI_Status status;
int sendtype_size, block, *displs, count;
MPI_Aint pack_size, position;
MPI_Datatype newtype = MPI_DATATYPE_NULL;
void *tmp_buf;
MPIR_Request **reqarray;
MPI_Status *starray;
MPIR_CHKLMEM_DECL(6);
if (recvcount == 0) return MPI_SUCCESS;
comm_size = comm_ptr->local_size;
rank = comm_ptr->rank;
/* Get extent of send and recv types */
MPID_Datatype_get_extent_macro(recvtype, recvtype_extent);
MPID_Datatype_get_extent_macro(sendtype, sendtype_extent);
MPID_Datatype_get_size_macro(sendtype, sendtype_size);
nbytes = sendtype_size * sendcount;
if (sendbuf == MPI_IN_PLACE) {
/* We use pair-wise sendrecv_replace in order to conserve memory usage,
* which is keeping with the spirit of the MPI-2.2 Standard. But
* because of this approach all processes must agree on the global
* schedule of sendrecv_replace operations to avoid deadlock.
*
* Note that this is not an especially efficient algorithm in terms of
* time and there will be multiple repeated malloc/free's rather than
* maintaining a single buffer across the whole loop. Something like
* MADRE is probably the best solution for the MPI_IN_PLACE scenario. */
for (i = 0; i < comm_size; ++i) {
/* start inner loop at i to avoid re-exchanging data */
for (j = i; j < comm_size; ++j) {
if (rank == i) {
/* also covers the (rank == i && rank == j) case */
mpi_errno = MPIC_Sendrecv_replace(((char *)recvbuf + j*recvcount*recvtype_extent),
recvcount, recvtype,
j, MPIR_ALLTOALL_TAG,
j, MPIR_ALLTOALL_TAG,
comm_ptr, &status, errflag);
if (mpi_errno) {
/* for communication errors, just record the error but continue */
*errflag = MPIR_ERR_GET_CLASS(mpi_errno);
MPIR_ERR_SET(mpi_errno, *errflag, "**fail");
MPIR_ERR_ADD(mpi_errno_ret, mpi_errno);
}
}
else if (rank == j) {
/* same as above with i/j args reversed */
mpi_errno = MPIC_Sendrecv_replace(((char *)recvbuf + i*recvcount*recvtype_extent),
recvcount, recvtype,
i, MPIR_ALLTOALL_TAG,
i, MPIR_ALLTOALL_TAG,
comm_ptr, &status, errflag);
if (mpi_errno) {
/* for communication errors, just record the error but continue */
*errflag = MPIR_ERR_GET_CLASS(mpi_errno);
MPIR_ERR_SET(mpi_errno, *errflag, "**fail");
MPIR_ERR_ADD(mpi_errno_ret, mpi_errno);
}
}
}
}
}
else if ((nbytes <= MPIR_CVAR_ALLTOALL_SHORT_MSG_SIZE) && (comm_size >= 8)) {
/* use the indexing algorithm by Jehoshua Bruck et al,
* IEEE TPDS, Nov. 97 */
/* allocate temporary buffer */
MPIR_Pack_size_impl(recvcount*comm_size, recvtype, &pack_size);
MPIR_CHKLMEM_MALLOC(tmp_buf, void *, pack_size, mpi_errno, "tmp_buf");
/* Do Phase 1 of the algorithim. Shift the data blocks on process i
* upwards by a distance of i blocks. Store the result in recvbuf. */
mpi_errno = MPIR_Localcopy((char *) sendbuf +
rank*sendcount*sendtype_extent,
(comm_size - rank)*sendcount, sendtype, recvbuf,
(comm_size - rank)*recvcount, recvtype);
if (mpi_errno) { MPIR_ERR_POP(mpi_errno); }
mpi_errno = MPIR_Localcopy(sendbuf, rank*sendcount, sendtype,
(char *) recvbuf +
(comm_size-rank)*recvcount*recvtype_extent,
rank*recvcount, recvtype);
if (mpi_errno) { MPIR_ERR_POP(mpi_errno); }
/* Input data is now stored in recvbuf with datatype recvtype */
/* Now do Phase 2, the communication phase. It takes
ceiling(lg p) steps. In each step i, each process sends to rank+2^i
and receives from rank-2^i, and exchanges all data blocks
whose ith bit is 1. */
/* allocate displacements array for indexed datatype used in
communication */
MPIR_CHKLMEM_MALLOC(displs, int *, comm_size * sizeof(int), mpi_errno, "displs");
pof2 = 1;
while (pof2 < comm_size) {
dst = (rank + pof2) % comm_size;
src = (rank - pof2 + comm_size) % comm_size;
/* Exchange all data blocks whose ith bit is 1 */
/* Create an indexed datatype for the purpose */
count = 0;
for (block=1; block<comm_size; block++) {
if (block & pof2) {
displs[count] = block * recvcount;
count++;
}
}
mpi_errno = MPIR_Type_create_indexed_block_impl(count, recvcount,
displs, recvtype, &newtype);
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
mpi_errno = MPIR_Type_commit_impl(&newtype);
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
position = 0;
mpi_errno = MPIR_Pack_impl(recvbuf, 1, newtype, tmp_buf, pack_size, &position);
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
mpi_errno = MPIC_Sendrecv(tmp_buf, position, MPI_PACKED, dst,
MPIR_ALLTOALL_TAG, recvbuf, 1, newtype,
src, MPIR_ALLTOALL_TAG, comm_ptr,
MPI_STATUS_IGNORE, errflag);
if (mpi_errno) {
/* for communication errors, just record the error but continue */
*errflag = MPIR_ERR_GET_CLASS(mpi_errno);
MPIR_ERR_SET(mpi_errno, *errflag, "**fail");
MPIR_ERR_ADD(mpi_errno_ret, mpi_errno);
}
MPIR_Type_free_impl(&newtype);
pof2 *= 2;
}
/* Rotate blocks in recvbuf upwards by (rank + 1) blocks. Need
* a temporary buffer of the same size as recvbuf. */
/* get true extent of recvtype */
MPIR_Type_get_true_extent_impl(recvtype, &recvtype_true_lb, &recvtype_true_extent);
recvbuf_extent = recvcount * comm_size *
(MPL_MAX(recvtype_true_extent, recvtype_extent));
MPIR_CHKLMEM_MALLOC(tmp_buf, void *, recvbuf_extent, mpi_errno, "tmp_buf");
/* adjust for potential negative lower bound in datatype */
tmp_buf = (void *)((char*)tmp_buf - recvtype_true_lb);
mpi_errno = MPIR_Localcopy((char *) recvbuf + (rank+1)*recvcount*recvtype_extent,
(comm_size - rank - 1)*recvcount, recvtype, tmp_buf,
(comm_size - rank - 1)*recvcount, recvtype);
if (mpi_errno) { MPIR_ERR_POP(mpi_errno); }
mpi_errno = MPIR_Localcopy(recvbuf, (rank+1)*recvcount, recvtype,
(char *) tmp_buf + (comm_size-rank-1)*recvcount*recvtype_extent,
(rank+1)*recvcount, recvtype);
if (mpi_errno) { MPIR_ERR_POP(mpi_errno); }
/* Blocks are in the reverse order now (comm_size-1 to 0).
* Reorder them to (0 to comm_size-1) and store them in recvbuf. */
for (i=0; i<comm_size; i++){
mpi_errno = MPIR_Localcopy((char *) tmp_buf + i*recvcount*recvtype_extent,
recvcount, recvtype,
(char *) recvbuf + (comm_size-i-1)*recvcount*recvtype_extent,
recvcount, recvtype);
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
}
}
int MPIR_Ireduce_scatter_sched_intra_recursive_halving(const void *sendbuf, void *recvbuf,
const int recvcounts[],
MPI_Datatype datatype, MPI_Op op,
MPIR_Comm * comm_ptr, MPIR_Sched_t s)
{
int mpi_errno = MPI_SUCCESS;
int rank, comm_size, i;
MPI_Aint extent, true_extent, true_lb;
int *disps;
void *tmp_recvbuf, *tmp_results;
int type_size ATTRIBUTE((unused)), total_count, dst;
int mask;
int *newcnts, *newdisps, rem, newdst, send_idx, recv_idx, last_idx, send_cnt, recv_cnt;
int pof2, old_i, newrank;
MPIR_SCHED_CHKPMEM_DECL(5);
comm_size = comm_ptr->local_size;
rank = comm_ptr->rank;
MPIR_Datatype_get_extent_macro(datatype, extent);
MPIR_Type_get_true_extent_impl(datatype, &true_lb, &true_extent);
#ifdef HAVE_ERROR_CHECKING
MPIR_Assert(MPIR_Op_is_commutative(op));
#endif
MPIR_SCHED_CHKPMEM_MALLOC(disps, int *, comm_size * sizeof(int), mpi_errno, "disps",
MPL_MEM_BUFFER);
total_count = 0;
for (i = 0; i < comm_size; i++) {
disps[i] = total_count;
total_count += recvcounts[i];
}
if (total_count == 0) {
goto fn_exit;
}
MPIR_Datatype_get_size_macro(datatype, type_size);
/* allocate temp. buffer to receive incoming data */
MPIR_SCHED_CHKPMEM_MALLOC(tmp_recvbuf, void *, total_count * (MPL_MAX(true_extent, extent)),
mpi_errno, "tmp_recvbuf", MPL_MEM_BUFFER);
/* adjust for potential negative lower bound in datatype */
tmp_recvbuf = (void *) ((char *) tmp_recvbuf - true_lb);
/* need to allocate another temporary buffer to accumulate
* results because recvbuf may not be big enough */
MPIR_SCHED_CHKPMEM_MALLOC(tmp_results, void *, total_count * (MPL_MAX(true_extent, extent)),
mpi_errno, "tmp_results", MPL_MEM_BUFFER);
/* adjust for potential negative lower bound in datatype */
tmp_results = (void *) ((char *) tmp_results - true_lb);
/* copy sendbuf into tmp_results */
if (sendbuf != MPI_IN_PLACE)
mpi_errno = MPIR_Sched_copy(sendbuf, total_count, datatype,
tmp_results, total_count, datatype, s);
else
mpi_errno = MPIR_Sched_copy(recvbuf, total_count, datatype,
tmp_results, total_count, datatype, s);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
MPIR_SCHED_BARRIER(s);
pof2 = comm_ptr->pof2;
rem = comm_size - pof2;
/* In the non-power-of-two case, all even-numbered
* processes of rank < 2*rem send their data to
* (rank+1). These even-numbered processes no longer
* participate in the algorithm until the very end. The
* remaining processes form a nice power-of-two. */
if (rank < 2 * rem) {
if (rank % 2 == 0) { /* even */
mpi_errno = MPIR_Sched_send(tmp_results, total_count, datatype, rank + 1, comm_ptr, s);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
MPIR_SCHED_BARRIER(s);
/* temporarily set the rank to -1 so that this
* process does not pariticipate in recursive
* doubling */
newrank = -1;
} else { /* odd */
mpi_errno = MPIR_Sched_recv(tmp_recvbuf, total_count, datatype, rank - 1, comm_ptr, s);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
MPIR_SCHED_BARRIER(s);
/* do the reduction on received data. since the
* ordering is right, it doesn't matter whether
* the operation is commutative or not. */
mpi_errno = MPIR_Sched_reduce(tmp_recvbuf, tmp_results, total_count, datatype, op, s);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
MPIR_SCHED_BARRIER(s);
/* change the rank */
newrank = rank / 2;
}
} else /* rank >= 2*rem */
newrank = rank - rem;
if (newrank != -1) {
/* recalculate the recvcounts and disps arrays because the
* even-numbered processes who no longer participate will
* have their result calculated by the process to their
* right (rank+1). */
MPIR_SCHED_CHKPMEM_MALLOC(newcnts, int *, pof2 * sizeof(int), mpi_errno, "newcnts",
MPL_MEM_BUFFER);
MPIR_SCHED_CHKPMEM_MALLOC(newdisps, int *, pof2 * sizeof(int), mpi_errno, "newdisps",
MPL_MEM_BUFFER);
for (i = 0; i < pof2; i++) {
/* what does i map to in the old ranking? */
old_i = (i < rem) ? i * 2 + 1 : i + rem;
if (old_i < 2 * rem) {
/* This process has to also do its left neighbor's
* work */
newcnts[i] = recvcounts[old_i] + recvcounts[old_i - 1];
} else
newcnts[i] = recvcounts[old_i];
}
newdisps[0] = 0;
for (i = 1; i < pof2; i++)
newdisps[i] = newdisps[i - 1] + newcnts[i - 1];
mask = pof2 >> 1;
send_idx = recv_idx = 0;
last_idx = pof2;
while (mask > 0) {
newdst = newrank ^ mask;
/* find real rank of dest */
dst = (newdst < rem) ? newdst * 2 + 1 : newdst + rem;
send_cnt = recv_cnt = 0;
if (newrank < newdst) {
send_idx = recv_idx + mask;
for (i = send_idx; i < last_idx; i++)
send_cnt += newcnts[i];
for (i = recv_idx; i < send_idx; i++)
recv_cnt += newcnts[i];
} else {
recv_idx = send_idx + mask;
for (i = send_idx; i < recv_idx; i++)
send_cnt += newcnts[i];
for (i = recv_idx; i < last_idx; i++)
recv_cnt += newcnts[i];
}
/* Send data from tmp_results. Recv into tmp_recvbuf */
{
/* avoid sending and receiving pointless 0-byte messages */
int send_dst = (send_cnt ? dst : MPI_PROC_NULL);
int recv_dst = (recv_cnt ? dst : MPI_PROC_NULL);
mpi_errno = MPIR_Sched_send(((char *) tmp_results + newdisps[send_idx] * extent),
send_cnt, datatype, send_dst, comm_ptr, s);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
mpi_errno = MPIR_Sched_recv(((char *) tmp_recvbuf + newdisps[recv_idx] * extent),
recv_cnt, datatype, recv_dst, comm_ptr, s);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
MPIR_SCHED_BARRIER(s);
}
/* tmp_recvbuf contains data received in this step.
* tmp_results contains data accumulated so far */
if (recv_cnt) {
mpi_errno = MPIR_Sched_reduce(((char *) tmp_recvbuf + newdisps[recv_idx] * extent),
((char *) tmp_results + newdisps[recv_idx] * extent),
recv_cnt, datatype, op, s);
MPIR_SCHED_BARRIER(s);
}
/* update send_idx for next iteration */
send_idx = recv_idx;
last_idx = recv_idx + mask;
mask >>= 1;
}
/* copy this process's result from tmp_results to recvbuf */
if (recvcounts[rank]) {
mpi_errno = MPIR_Sched_copy(((char *) tmp_results + disps[rank] * extent),
recvcounts[rank], datatype,
recvbuf, recvcounts[rank], datatype, s);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
MPIR_SCHED_BARRIER(s);
}
}
int MPIDI_CH3U_Get_failed_group(int last_rank, MPIR_Group **failed_group)
{
char *c;
int i, mpi_errno = MPI_SUCCESS, rank;
UT_array *failed_procs = NULL;
MPIR_Group *world_group;
MPIR_FUNC_VERBOSE_STATE_DECL(MPID_STATE_GET_FAILED_GROUP);
MPIR_FUNC_VERBOSE_ENTER(MPID_STATE_GET_FAILED_GROUP);
MPL_DBG_MSG_D(MPIDI_CH3_DBG_OTHER, VERBOSE, "Getting failed group with %d as last acknowledged\n", last_rank);
if (-1 == last_rank) {
MPL_DBG_MSG(MPIDI_CH3_DBG_OTHER, VERBOSE, "No failure acknowledged");
*failed_group = MPIR_Group_empty;
goto fn_exit;
}
if (*MPIDI_failed_procs_string == '\0') {
MPL_DBG_MSG(MPIDI_CH3_DBG_OTHER, VERBOSE, "Found no failed ranks");
*failed_group = MPIR_Group_empty;
goto fn_exit;
}
utarray_new(failed_procs, &ut_int_icd);
/* parse list of failed processes. This is a comma separated list
of ranks or ranges of ranks (e.g., "1, 3-5, 11") */
i = 0;
c = MPIDI_failed_procs_string;
while(1) {
parse_rank(&rank);
++i;
MPL_DBG_MSG_D(MPIDI_CH3_DBG_OTHER, VERBOSE, "Found failed rank: %d", rank);
utarray_push_back(failed_procs, &rank);
MPIDI_last_known_failed = rank;
MPIR_ERR_CHKINTERNAL(*c != ',' && *c != '\0', mpi_errno, "error parsing failed process list");
if (*c == '\0' || last_rank == rank)
break;
++c; /* skip ',' */
}
/* Create group of failed processes for comm_world. Failed groups for other
communicators can be created from this one using group_intersection. */
mpi_errno = MPIR_Comm_group_impl(MPIR_Process.comm_world, &world_group);
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
mpi_errno = MPIR_Group_incl_impl(world_group, i, ut_int_array(failed_procs), failed_group);
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
mpi_errno = MPIR_Group_release(world_group);
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
fn_exit:
MPIR_FUNC_VERBOSE_EXIT(MPID_STATE_GET_FAILED_GROUP);
if (failed_procs)
utarray_free(failed_procs);
return mpi_errno;
fn_oom:
MPIR_ERR_SET1(mpi_errno, MPI_ERR_OTHER, "**nomem", "**nomem %s", "utarray");
fn_fail:
goto fn_exit;
}
/*@
MPI_Ialltoallw - Nonblocking generalized all-to-all communication allowing
different datatypes, counts, and displacements for each partner
Input Parameters:
+ sendbuf - starting address of the send buffer (choice)
. sendcounts - non-negative integer array (of length group size) specifying the number of elements to send to each processor
. sdispls - integer array (of length group size). Entry j specifies the displacement relative to sendbuf from which to take the outgoing data destined for process j
. sendtypes - array of datatypes (of length group size). Entry j specifies the type of data to send to process j (array of handles)
. recvcounts - non-negative integer array (of length group size) specifying the number of elements that can be received from each processor
. rdispls - integer array (of length group size). Entry i specifies the displacement relative to recvbuf at which to place the incoming data from process i
. recvtypes - array of datatypes (of length group size). Entry i specifies the type of data received from process i (array of handles)
- comm - communicator (handle)
Output Parameters:
+ recvbuf - starting address of the receive buffer (choice)
- request - communication request (handle)
.N ThreadSafe
.N Fortran
.N Errors
@*/
int MPI_Ialltoallw(const void *sendbuf, const int sendcounts[], const int sdispls[],
const MPI_Datatype sendtypes[], void *recvbuf, const int recvcounts[],
const int rdispls[], const MPI_Datatype recvtypes[], MPI_Comm comm,
MPI_Request * request)
{
int mpi_errno = MPI_SUCCESS;
MPIR_Comm *comm_ptr = NULL;
MPIR_Request *request_ptr = NULL;
MPIR_FUNC_TERSE_STATE_DECL(MPID_STATE_MPI_IALLTOALLW);
MPID_THREAD_CS_ENTER(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX);
MPIR_FUNC_TERSE_ENTER(MPID_STATE_MPI_IALLTOALLW);
/* Validate parameters, especially handles needing to be converted */
#ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
MPIR_ERRTEST_COMM(comm, mpi_errno);
/* TODO more checks may be appropriate */
}
MPID_END_ERROR_CHECKS;
}
#endif /* HAVE_ERROR_CHECKING */
/* Convert MPI object handles to object pointers */
MPIR_Comm_get_ptr(comm, comm_ptr);
/* Validate parameters and objects (post conversion) */
#ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
MPIR_Comm_valid_ptr(comm_ptr, mpi_errno, FALSE);
if (mpi_errno != MPI_SUCCESS)
goto fn_fail;
if (sendbuf != MPI_IN_PLACE) {
MPIR_ERRTEST_ARGNULL(sendcounts, "sendcounts", mpi_errno);
MPIR_ERRTEST_ARGNULL(sdispls, "sdispls", mpi_errno);
MPIR_ERRTEST_ARGNULL(sendtypes, "sendtypes", mpi_errno);
if (comm_ptr->comm_kind == MPIR_COMM_KIND__INTRACOMM &&
sendcounts == recvcounts && sendtypes == recvtypes)
MPIR_ERRTEST_ALIAS_COLL(sendbuf, recvbuf, mpi_errno);
}
MPIR_ERRTEST_ARGNULL(recvcounts, "recvcounts", mpi_errno);
MPIR_ERRTEST_ARGNULL(rdispls, "rdispls", mpi_errno);
MPIR_ERRTEST_ARGNULL(recvtypes, "recvtypes", mpi_errno);
if (comm_ptr->comm_kind == MPIR_COMM_KIND__INTERCOMM && sendbuf == MPI_IN_PLACE) {
MPIR_ERR_SETANDJUMP(mpi_errno, MPI_ERR_OTHER, "**sendbuf_inplace");
}
MPIR_ERRTEST_ARGNULL(request, "request", mpi_errno);
/* TODO more checks may be appropriate (counts, in_place, etc) */
}
MPID_END_ERROR_CHECKS;
}
#endif /* HAVE_ERROR_CHECKING */
/* ... body of routine ... */
mpi_errno = MPIR_Ialltoallw(sendbuf, sendcounts, sdispls, sendtypes, recvbuf,
recvcounts, rdispls, recvtypes, comm_ptr, &request_ptr);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
/* create a complete request, if needed */
if (!request_ptr)
request_ptr = MPIR_Request_create_complete(MPIR_REQUEST_KIND__COLL);
/* return the handle of the request to the user */
*request = request_ptr->handle;
/* ... end of body of routine ... */
fn_exit:
MPIR_FUNC_TERSE_EXIT(MPID_STATE_MPI_IALLTOALLW);
MPID_THREAD_CS_EXIT(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX);
return mpi_errno;
fn_fail:
/* --BEGIN ERROR HANDLING-- */
#ifdef HAVE_ERROR_CHECKING
{
mpi_errno =
MPIR_Err_create_code(mpi_errno, MPIR_ERR_RECOVERABLE, __func__, __LINE__, MPI_ERR_OTHER,
"**mpi_ialltoallw",
"**mpi_ialltoallw %p %p %p %p %p %p %p %p %C %p", sendbuf,
sendcounts, sdispls, sendtypes, recvbuf, recvcounts, rdispls,
recvtypes, comm, request);
}
#endif
mpi_errno = MPIR_Err_return_comm(comm_ptr, __func__, mpi_errno);
goto fn_exit;
/* --END ERROR HANDLING-- */
}
/*@
MPIDI_CH3U_Handle_connection - handle connection event
Input Parameters:
+ vc - virtual connection
. event - connection event
NOTE:
This routine is used to transition the VC state.
The only events currently handled are TERMINATED events. This
routine should be called (with TERMINATED) whenever a connection is
terminated whether normally (in MPIDI_CH3_Connection_terminate() ),
or abnormally.
FIXME: Currently state transitions resulting from receiving CLOSE
packets are performed in MPIDI_CH3_PktHandler_Close(). Perhaps that
should move here.
@*/
int MPIDI_CH3U_Handle_connection(MPIDI_VC_t * vc, MPIDI_VC_Event_t event)
{
int inuse;
int mpi_errno = MPI_SUCCESS;
MPIR_FUNC_VERBOSE_STATE_DECL(MPID_STATE_MPIDI_CH3U_HANDLE_CONNECTION);
MPIR_FUNC_VERBOSE_ENTER(MPID_STATE_MPIDI_CH3U_HANDLE_CONNECTION);
switch (event)
{
case MPIDI_VC_EVENT_TERMINATED:
{
switch (vc->state)
{
case MPIDI_VC_STATE_CLOSED:
/* Normal termination. */
MPIDI_CHANGE_VC_STATE(vc, INACTIVE);
/* MT: this is not thread safe */
MPIDI_Outstanding_close_ops -= 1;
MPL_DBG_MSG_D(MPIDI_CH3_DBG_DISCONNECT,TYPICAL,
"outstanding close operations = %d", MPIDI_Outstanding_close_ops);
if (MPIDI_Outstanding_close_ops == 0)
{
MPIDI_CH3_Progress_signal_completion();
mpi_errno = MPIDI_CH3_Channel_close();
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
}
break;
case MPIDI_VC_STATE_INACTIVE:
/* VC was terminated before it was activated.
This can happen if a failed process was
detected before the process used the VC. */
MPL_DBG_MSG(MPIDI_CH3_DBG_DISCONNECT,TYPICAL, "VC terminated before it was activated. We probably got a failed"
" process notification.");
MPIDI_CH3U_Complete_posted_with_error(vc);
++MPIDI_Failed_vc_count;
MPIDI_CHANGE_VC_STATE(vc, MORIBUND);
break;
case MPIDI_VC_STATE_ACTIVE:
case MPIDI_VC_STATE_REMOTE_CLOSE:
/* This is a premature termination. This process
has not started the close protocol. There may
be outstanding sends or receives on the local
side, remote side or both. */
MPL_DBG_MSG(MPIDI_CH3_DBG_DISCONNECT,TYPICAL, "Connection closed prematurely.");
MPIDI_CH3U_Complete_posted_with_error(vc);
++MPIDI_Failed_vc_count;
MPIDU_Ftb_publish_vc(MPIDU_FTB_EV_UNREACHABLE, vc);
MPIDI_CHANGE_VC_STATE(vc, MORIBUND);
break;
case MPIDI_VC_STATE_LOCAL_CLOSE:
/* This is a premature termination. This process
has started the close protocol, but hasn't
received a CLOSE packet from the remote side.
This process may not have been able to send the
CLOSE ack=F packet to the remote side. There
may be outstanding sends or receives on the
local or remote sides. */
case MPIDI_VC_STATE_CLOSE_ACKED:
/* This is a premature termination. Both sides
have started the close protocol. This process
has received CLOSE ack=F, but not CLOSE ack=t.
This process may not have been able to send
CLOSE ack=T. There should not be any
outstanding sends or receives on either
side. */
MPL_DBG_MSG_D(MPIDI_CH3_DBG_DISCONNECT,TYPICAL, "Connection closed prematurely during close protocol. "
"Outstanding close operations = %d", MPIDI_Outstanding_close_ops);
MPIDI_CH3U_Complete_posted_with_error(vc);
++MPIDI_Failed_vc_count;
MPIDU_Ftb_publish_vc(MPIDU_FTB_EV_UNREACHABLE, vc);
MPIDI_CHANGE_VC_STATE(vc, MORIBUND);
/* MT: this is not thread safe */
MPIDI_Outstanding_close_ops -= 1;
if (MPIDI_Outstanding_close_ops == 0) {
MPIDI_CH3_Progress_signal_completion();
mpi_errno = MPIDI_CH3_Channel_close();
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
}
break;
default:
{
MPL_DBG_MSG_D(MPIDI_CH3_DBG_DISCONNECT,TYPICAL, "Unhandled connection state %d when closing connection",vc->state);
mpi_errno = MPIR_Err_create_code(
MPI_SUCCESS, MPIR_ERR_FATAL, FCNAME, __LINE__,
MPI_ERR_INTERN, "**ch3|unhandled_connection_state",
"**ch3|unhandled_connection_state %p %d", vc, vc->state);
goto fn_fail;
break;
}
}
/* FIXME: Decrement the reference count? Who increments? */
/* FIXME: The reference count is often already 0. But
not always */
/* MPIR_Object_set_ref(vc, 0); ??? */
/*
* FIXME: The VC used in connect accept has a NULL
* process group
*/
/* XXX DJG FIXME-MT should we be checking this ref_count? */
if (vc->pg != NULL && (MPIR_Object_get_ref(vc) == 0))
{
/* FIXME: Who increments the reference count that
this is decrementing? */
/* When the reference count for a vc becomes zero,
decrement the reference count
of the associated process group. */
/* FIXME: This should be done when the reference
count of the vc is first decremented */
MPIDI_PG_release_ref(vc->pg, &inuse);
if (inuse == 0) {
MPIDI_PG_Destroy(vc->pg);
}
}
break;
}
default:
{
break;
}
}
fn_exit:
MPIR_FUNC_VERBOSE_EXIT(MPID_STATE_MPIDI_CH3U_HANDLE_CONNECTION);
return mpi_errno;
fn_fail:
goto fn_exit;
}
/*@
MPI_Imrecv - Nonblocking receive of message matched by MPI_Mprobe or MPI_Improbe.
Input/Output Parameters:
. message - message (handle)
Input Parameters:
+ count - number of elements in the receive buffer (non-negative integer)
- datatype - datatype of each receive buffer element (handle)
Output Parameters:
+ buf - initial address of the receive buffer (choice)
- request - communication request (handle)
.N ThreadSafe
.N Fortran
.N Errors
@*/
int MPI_Imrecv(void *buf, int count, MPI_Datatype datatype, MPI_Message *message, MPI_Request *request)
{
int mpi_errno = MPI_SUCCESS;
MPID_Request *rreq = NULL;
MPID_Request *msgp = NULL;
MPID_MPI_STATE_DECL(MPID_STATE_MPI_IMRECV);
MPID_THREAD_CS_ENTER(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX);
MPID_MPI_FUNC_ENTER(MPID_STATE_MPI_IMRECV);
/* Validate parameters, especially handles needing to be converted */
# ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS
{
MPIR_ERRTEST_DATATYPE(datatype, "datatype", mpi_errno);
/* TODO more checks may be appropriate */
}
MPID_END_ERROR_CHECKS
}
# endif /* HAVE_ERROR_CHECKING */
/* Convert MPI object handles to object pointers */
MPID_Request_get_ptr(*message, msgp);
/* Validate parameters and objects (post conversion) */
# ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS
{
if (HANDLE_GET_KIND(datatype) != HANDLE_KIND_BUILTIN) {
MPID_Datatype *datatype_ptr = NULL;
MPID_Datatype_get_ptr(datatype, datatype_ptr);
MPID_Datatype_valid_ptr(datatype_ptr, mpi_errno);
if (mpi_errno != MPI_SUCCESS) goto fn_fail;
MPID_Datatype_committed_ptr(datatype_ptr, mpi_errno);
if (mpi_errno != MPI_SUCCESS) goto fn_fail;
}
/* MPI_MESSAGE_NO_PROC should yield a "proc null" status */
if (*message != MPI_MESSAGE_NO_PROC) {
MPID_Request_valid_ptr(msgp, mpi_errno);
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
MPIR_ERR_CHKANDJUMP((msgp->kind != MPID_REQUEST_MPROBE),
mpi_errno, MPI_ERR_ARG, "**reqnotmsg");
}
MPIR_ERRTEST_ARGNULL(request, "request", mpi_errno);
/* TODO more checks may be appropriate (counts, in_place, buffer aliasing, etc) */
}
MPID_END_ERROR_CHECKS
}
# endif /* HAVE_ERROR_CHECKING */
/* ... body of routine ... */
mpi_errno = MPID_Imrecv(buf, count, datatype, msgp, &rreq);
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
MPIU_Assert(rreq != NULL);
*request = rreq->handle;
*message = MPI_MESSAGE_NULL;
/* ... end of body of routine ... */
fn_exit:
MPID_MPI_FUNC_EXIT(MPID_STATE_MPI_IMRECV);
MPID_THREAD_CS_EXIT(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX);
return mpi_errno;
fn_fail:
/* --BEGIN ERROR HANDLING-- */
# ifdef HAVE_ERROR_CHECKING
{
mpi_errno = MPIR_Err_create_code(
mpi_errno, MPIR_ERR_RECOVERABLE, FCNAME, __LINE__, MPI_ERR_OTHER,
"**mpi_imrecv", "**mpi_imrecv %p %d %D %p %p", buf, count, datatype, message, request);
}
# endif
mpi_errno = MPIR_Err_return_comm(NULL, FCNAME, mpi_errno);
goto fn_exit;
/* --END ERROR HANDLING-- */
}
int MPIDI_CH3U_Check_for_failed_procs(void)
{
int mpi_errno = MPI_SUCCESS;
int pmi_errno;
int len;
char *kvsname;
MPIR_Group *prev_failed_group, *new_failed_group;
MPIR_FUNC_VERBOSE_STATE_DECL(MPID_STATE_MPIDI_CH3U_CHECK_FOR_FAILED_PROCS);
MPIR_FUNC_VERBOSE_ENTER(MPID_STATE_MPIDI_CH3U_CHECK_FOR_FAILED_PROCS);
/* FIXME: Currently this only handles failed processes in
comm_world. We need to fix hydra to include the pgid along
with the rank, then we need to create the failed group from
something bigger than comm_world. */
mpi_errno = MPIDI_PG_GetConnKVSname(&kvsname);
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
#ifdef USE_PMI2_API
{
int vallen = 0;
pmi_errno = PMI2_KVS_Get(kvsname, PMI2_ID_NULL, "PMI_dead_processes", MPIDI_failed_procs_string, PMI2_MAX_VALLEN, &vallen);
MPIR_ERR_CHKANDJUMP(pmi_errno, mpi_errno, MPI_ERR_OTHER, "**pmi_kvs_get");
}
#else
pmi_errno = PMI_KVS_Get_value_length_max(&len);
MPIR_ERR_CHKANDJUMP(pmi_errno, mpi_errno, MPI_ERR_OTHER, "**pmi_kvs_get_value_length_max");
pmi_errno = PMI_KVS_Get(kvsname, "PMI_dead_processes", MPIDI_failed_procs_string, len);
MPIR_ERR_CHKANDJUMP(pmi_errno, mpi_errno, MPI_ERR_OTHER, "**pmi_kvs_get");
#endif
if (*MPIDI_failed_procs_string == '\0') {
/* there are no failed processes */
MPIDI_Failed_procs_group = MPIR_Group_empty;
goto fn_exit;
}
MPL_DBG_MSG_S(MPIDI_CH3_DBG_OTHER, TYPICAL, "Received proc fail notification: %s", MPIDI_failed_procs_string);
/* save reference to previous group so we can identify new failures */
prev_failed_group = MPIDI_Failed_procs_group;
/* Parse the list of failed processes */
MPIDI_CH3U_Get_failed_group(-2, &MPIDI_Failed_procs_group);
/* get group of newly failed processes */
mpi_errno = MPIR_Group_difference_impl(MPIDI_Failed_procs_group, prev_failed_group, &new_failed_group);
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
if (new_failed_group != MPIR_Group_empty) {
mpi_errno = MPIDI_CH3I_Comm_handle_failed_procs(new_failed_group);
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
mpi_errno = terminate_failed_VCs(new_failed_group);
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
mpi_errno = MPIR_Group_release(new_failed_group);
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
}
/* free prev group */
if (prev_failed_group != MPIR_Group_empty) {
mpi_errno = MPIR_Group_release(prev_failed_group);
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
}
fn_exit:
MPIR_FUNC_VERBOSE_EXIT(MPID_STATE_MPIDI_CH3U_CHECK_FOR_FAILED_PROCS);
return mpi_errno;
fn_oom: /* out-of-memory handler for utarray operations */
MPIR_ERR_SET1(mpi_errno, MPI_ERR_OTHER, "**nomem", "**nomem %s", "utarray");
fn_fail:
goto fn_exit;
}
/*@
MPI_Graph_neighbors_count - Returns the number of neighbors of a node
associated with a graph topology
Input Parameters:
+ comm - communicator with graph topology (handle)
- rank - rank of process in group of 'comm' (integer)
Output Parameters:
. nneighbors - number of neighbors of specified process (integer)
.N SignalSafe
.N Fortran
.N Errors
.N MPI_SUCCESS
.N MPI_ERR_TOPOLOGY
.N MPI_ERR_COMM
.N MPI_ERR_ARG
.N MPI_ERR_RANK
@*/
int MPI_Graph_neighbors_count(MPI_Comm comm, int rank, int *nneighbors)
{
int mpi_errno = MPI_SUCCESS;
MPID_Comm *comm_ptr = NULL;
MPID_MPI_STATE_DECL(MPID_STATE_MPI_GRAPH_NEIGHBORS_COUNT);
MPIR_ERRTEST_INITIALIZED_ORDIE();
/* Note that this routine does not require a CS_ENTER/EXIT */
MPID_MPI_FUNC_ENTER(MPID_STATE_MPI_GRAPH_NEIGHBORS_COUNT);
/* Validate parameters, especially handles needing to be converted */
# ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
MPIR_ERRTEST_COMM(comm, mpi_errno);
}
MPID_END_ERROR_CHECKS;
}
# endif
/* Convert MPI object handles to object pointers */
MPID_Comm_get_ptr( comm, comm_ptr );
/* Validate parameters and objects (post conversion) */
# ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
/* Validate comm_ptr */
MPID_Comm_valid_ptr( comm_ptr, mpi_errno, TRUE );
if (mpi_errno) goto fn_fail;
MPIR_ERRTEST_ARGNULL(nneighbors, "nneighbors", mpi_errno);
/* If comm_ptr is not value, it will be reset to null */
}
MPID_END_ERROR_CHECKS;
}
# endif /* HAVE_ERROR_CHECKING */
/* ... body of routine ... */
mpi_errno = MPIR_Graph_neighbors_count_impl(comm_ptr, rank, nneighbors);
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
/* ... end of body of routine ... */
fn_exit:
MPID_MPI_FUNC_EXIT(MPID_STATE_MPI_GRAPH_NEIGHBORS_COUNT);
return mpi_errno;
fn_fail:
/* --BEGIN ERROR HANDLING-- */
# ifdef HAVE_ERROR_CHECKING
{
mpi_errno = MPIR_Err_create_code(
mpi_errno, MPIR_ERR_RECOVERABLE, FCNAME, __LINE__, MPI_ERR_OTHER, "**mpi_graph_neighbors_count",
"**mpi_graph_neighbors_count %C %d %p", comm, rank, nneighbors);
}
# endif
mpi_errno = MPIR_Err_return_comm( comm_ptr, FCNAME, mpi_errno );
goto fn_exit;
/* --END ERROR HANDLING-- */
}
int MPID_Mprobe(int source, int tag, MPID_Comm *comm, int context_offset,
MPID_Request **message, MPI_Status *status)
{
int mpi_errno = MPI_SUCCESS;
MPID_Progress_state progress_state;
int found = FALSE;
int context_id = comm->recvcontext_id + context_offset;
*message = NULL;
if (source == MPI_PROC_NULL)
{
MPIR_Status_set_procnull(status);
found = TRUE;
*message = NULL; /* should be interpreted as MPI_MESSAGE_NO_PROC */
goto fn_exit;
}
/* Check to make sure the communicator hasn't already been revoked */
if (comm->revoked) {
MPIR_ERR_SETANDJUMP(mpi_errno,MPIX_ERR_REVOKED,"**revoked");
}
#ifdef ENABLE_COMM_OVERRIDES
if (MPIDI_Anysource_improbe_fn) {
if (source == MPI_ANY_SOURCE) {
/* if it's anysource, loop while checking the shm recv
queue and improbing the netmod, then do a progress
test to make some progress. */
do {
MPID_THREAD_CS_ENTER(POBJ, MPIR_THREAD_MSGQ_MUTEX);
*message = MPIDI_CH3U_Recvq_FDU_matchonly(source, tag, context_id, comm,&found);
MPID_THREAD_CS_EXIT(POBJ, MPIR_THREAD_MSGQ_MUTEX);
if (found) goto fn_exit;
mpi_errno = MPIDI_Anysource_improbe_fn(tag, comm, context_offset, &found, message, status);
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
if (found) goto fn_exit;
MPID_THREAD_CS_YIELD(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX);
/* FIXME could this be replaced with a progress_wait? */
mpi_errno = MPIDI_CH3_Progress_test();
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
} while (1);
}
else {
/* it's not anysource, see if this is for the netmod */
MPIDI_VC_t * vc;
MPIDI_Comm_get_vc_set_active(comm, source, &vc);
if (vc->comm_ops && vc->comm_ops->improbe) {
/* netmod has overridden improbe */
do {
mpi_errno = vc->comm_ops->improbe(vc, source, tag, comm, context_offset, &found,
message, status);
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
if (found) goto fn_exit;
MPID_THREAD_CS_YIELD(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX);
/* FIXME could this be replaced with a progress_wait? */
mpi_errno = MPIDI_CH3_Progress_test();
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
} while (1);
}
/* fall-through to shm case */
}
}
#endif
/* Inefficient implementation: we poll the unexpected queue looking for a
* matching request, interleaved with calls to progress. If there are many
* non-matching unexpected messages in the queue then we will end up
* needlessly scanning the UQ.
*
* A smarter implementation would enqueue a partial request (one lacking the
* recv buffer triple) onto the PQ. Unfortunately, this is a lot harder to
* do than it seems at first because of the spread-out nature of callers to
* various CH3U_Recvq routines and especially because of the enqueue/dequeue
* hooks for native MX tag matching support. */
MPIDI_CH3_Progress_start(&progress_state);
do
{
MPID_THREAD_CS_ENTER(POBJ, MPIR_THREAD_MSGQ_MUTEX);
*message = MPIDI_CH3U_Recvq_FDU_matchonly(source, tag, context_id, comm, &found);
MPID_THREAD_CS_EXIT(POBJ, MPIR_THREAD_MSGQ_MUTEX);
if (found)
break;
mpi_errno = MPIDI_CH3_Progress_wait(&progress_state);
}
while(mpi_errno == MPI_SUCCESS);
MPIDI_CH3_Progress_end(&progress_state);
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
if (*message) {
(*message)->kind = MPID_REQUEST_MPROBE;
MPIR_Request_extract_status((*message), status);
}
fn_exit:
return mpi_errno;
fn_fail:
goto fn_exit;
}
/* comm create impl for intercommunicators, assumes that the standard error
* checking has already taken place in the calling function */
PMPI_LOCAL int MPIR_Comm_create_inter(MPID_Comm *comm_ptr, MPID_Group *group_ptr,
MPID_Comm **newcomm_ptr)
{
int mpi_errno = MPI_SUCCESS;
MPIU_Context_id_t new_context_id;
int *mapping = NULL;
int *remote_mapping = NULL;
MPID_Comm *mapping_comm = NULL;
int remote_size = -1;
int rinfo[2];
MPIR_Errflag_t errflag = MPIR_ERR_NONE;
MPIU_CHKLMEM_DECL(1);
MPID_MPI_STATE_DECL(MPID_STATE_MPIR_COMM_CREATE_INTER);
MPID_MPI_FUNC_ENTER(MPID_STATE_MPIR_COMM_CREATE_INTER);
MPIU_Assert(comm_ptr->comm_kind == MPID_INTERCOMM);
/* Create a new communicator from the specified group members */
/* If there is a context id cache in oldcomm, use it here. Otherwise,
use the appropriate algorithm to get a new context id.
Creating the context id is collective over the *input* communicator,
so it must be created before we decide if this process is a
member of the group */
/* In the multi-threaded case, MPIR_Get_contextid_sparse assumes that the
calling routine already holds the single criticial section */
if (!comm_ptr->local_comm) {
MPIR_Setup_intercomm_localcomm( comm_ptr );
}
mpi_errno = MPIR_Get_contextid_sparse( comm_ptr->local_comm, &new_context_id, FALSE );
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
MPIU_Assert(new_context_id != 0);
MPIU_Assert(new_context_id != comm_ptr->recvcontext_id);
mpi_errno = MPIR_Comm_create_calculate_mapping(group_ptr, comm_ptr,
&mapping, &mapping_comm);
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
*newcomm_ptr = NULL;
if (group_ptr->rank != MPI_UNDEFINED) {
/* Get the new communicator structure and context id */
mpi_errno = MPIR_Comm_create( newcomm_ptr );
if (mpi_errno) goto fn_fail;
(*newcomm_ptr)->recvcontext_id = new_context_id;
(*newcomm_ptr)->rank = group_ptr->rank;
(*newcomm_ptr)->comm_kind = comm_ptr->comm_kind;
/* Since the group has been provided, let the new communicator know
about the group */
(*newcomm_ptr)->local_comm = 0;
(*newcomm_ptr)->local_group = group_ptr;
MPIR_Group_add_ref( group_ptr );
(*newcomm_ptr)->local_size = group_ptr->size;
(*newcomm_ptr)->remote_group = 0;
(*newcomm_ptr)->is_low_group = comm_ptr->is_low_group;
}
/* There is an additional step. We must communicate the
information on the local context id and the group members,
given by the ranks so that the remote process can construct the
appropriate network address mapping.
First we exchange group sizes and context ids. Then the ranks
in the remote group, from which the remote network address
mapping can be constructed. We need to use the "collective"
context in the original intercommunicator */
if (comm_ptr->rank == 0) {
int info[2];
info[0] = new_context_id;
info[1] = group_ptr->size;
mpi_errno = MPIC_Sendrecv(info, 2, MPI_INT, 0, 0,
rinfo, 2, MPI_INT, 0, 0,
comm_ptr, MPI_STATUS_IGNORE, &errflag );
if (mpi_errno) { MPIR_ERR_POP( mpi_errno ); }
if (*newcomm_ptr != NULL) {
(*newcomm_ptr)->context_id = rinfo[0];
}
remote_size = rinfo[1];
MPIU_CHKLMEM_MALLOC(remote_mapping,int*,
remote_size*sizeof(int),
mpi_errno,"remote_mapping");
/* Populate and exchange the ranks */
mpi_errno = MPIC_Sendrecv( mapping, group_ptr->size, MPI_INT, 0, 0,
remote_mapping, remote_size, MPI_INT, 0, 0,
comm_ptr, MPI_STATUS_IGNORE, &errflag );
if (mpi_errno) { MPIR_ERR_POP( mpi_errno ); }
/* Broadcast to the other members of the local group */
mpi_errno = MPIR_Bcast_impl( rinfo, 2, MPI_INT, 0,
comm_ptr->local_comm, &errflag);
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
mpi_errno = MPIR_Bcast_impl( remote_mapping, remote_size, MPI_INT, 0,
comm_ptr->local_comm, &errflag);
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
MPIR_ERR_CHKANDJUMP(errflag, mpi_errno, MPI_ERR_OTHER, "**coll_fail");
}
int MPID_nem_mxm_SendNoncontig(MPIDI_VC_t * vc, MPID_Request * sreq, void *hdr,
MPIDI_msg_sz_t hdr_sz)
{
int mpi_errno = MPI_SUCCESS;
MPIDI_msg_sz_t last;
MPID_nem_mxm_vc_area *vc_area = NULL;
MPID_nem_mxm_req_area *req_area = NULL;
MPIDI_STATE_DECL(MPID_STATE_MPID_NEM_MXM_SENDNONCONTIGMSG);
MPIDI_FUNC_ENTER(MPID_STATE_MPID_NEM_MXM_SENDNONCONTIGMSG);
MPIU_Assert(hdr_sz <= sizeof(MPIDI_CH3_Pkt_t));
MPIU_DBG_MSG(CH3_CHANNEL, VERBOSE, "MPID_nem_mxm_iSendNoncontig");
MPIU_Memcpy(&(sreq->dev.pending_pkt), (char *) hdr, sizeof(MPIDI_CH3_Pkt_t));
_dbg_mxm_output(5,
"SendNoncontig ========> Sending ADI msg (to=%d type=%d) for req %p (data_size %d, %d) \n",
vc->pg_rank, sreq->dev.pending_pkt.type, sreq, sizeof(MPIDI_CH3_Pkt_t),
sreq->dev.segment_size - sreq->dev.segment_first);
vc_area = VC_BASE(vc);
req_area = REQ_BASE(sreq);
req_area->ctx = sreq;
req_area->iov_buf = req_area->tmp_buf;
req_area->iov_count = 0;
req_area->iov_buf[req_area->iov_count].ptr = (void *) &(sreq->dev.pending_pkt);
req_area->iov_buf[req_area->iov_count].length = sizeof(MPIDI_CH3_Pkt_t);
(req_area->iov_count)++;
if (sreq->dev.ext_hdr_ptr != NULL) {
req_area->iov_buf[req_area->iov_count].ptr = (void *) (sreq->dev.ext_hdr_ptr);
req_area->iov_buf[req_area->iov_count].length = sreq->dev.ext_hdr_sz;
(req_area->iov_count)++;
}
last = sreq->dev.segment_size;
/* NOTE: currently upper layer never pass packet with data that has
* either "last <= 0" or "last-sreq->dev.segment_first <=0" to this
* layer. In future, if upper layer passes such kind of packet, the
* judgement of the following IF branch needs to be modified. */
MPIU_Assert(last > 0 && last - sreq->dev.segment_first > 0);
if (last > 0) {
sreq->dev.tmpbuf = MPIU_Malloc((size_t) (sreq->dev.segment_size - sreq->dev.segment_first));
MPIU_Assert(sreq->dev.tmpbuf);
MPID_Segment_pack(sreq->dev.segment_ptr, sreq->dev.segment_first, &last, sreq->dev.tmpbuf);
MPIU_Assert(last == sreq->dev.segment_size);
req_area->iov_buf[req_area->iov_count].ptr = sreq->dev.tmpbuf;
req_area->iov_buf[req_area->iov_count].length = last - sreq->dev.segment_first;
(req_area->iov_count)++;
}
vc_area->pending_sends += 1;
sreq->ch.vc = vc;
sreq->ch.noncontig = TRUE;
mpi_errno = _mxm_isend(vc_area->mxm_ep, req_area, MXM_MPICH_ISEND_AM,
mxm_obj->mxm_mq, mxm_obj->mxm_rank, MXM_MPICH_HID_ADI_MSG, 0, 0);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
fn_exit:
MPIDI_FUNC_EXIT(MPID_STATE_MPID_NEM_MXM_SENDNONCONTIGMSG);
return mpi_errno;
fn_fail:
goto fn_exit;
}
