int MPIR_Ineighbor_alltoallv_sched_linear(const void *sendbuf, const int sendcounts[], const int sdispls[], MPI_Datatype sendtype, void *recvbuf, const int recvcounts[], const int rdispls[], MPI_Datatype recvtype, MPIR_Comm *comm_ptr, MPIR_Sched_t s)
{
int mpi_errno = MPI_SUCCESS;
int indegree, outdegree, weighted;
int i, k,l;
int *srcs, *dsts;
int comm_size;
MPI_Aint sendtype_extent, recvtype_extent;
MPIR_CHKLMEM_DECL(2);
comm_size = comm_ptr->local_size;
MPIR_Datatype_get_extent_macro(sendtype, sendtype_extent);
MPIR_Datatype_get_extent_macro(recvtype, recvtype_extent);
for (i = 0; i < comm_size; ++i) {
MPIR_Ensure_Aint_fits_in_pointer(MPIR_VOID_PTR_CAST_TO_MPI_AINT sendbuf +
(sdispls[i] * sendtype_extent));
MPIR_Ensure_Aint_fits_in_pointer(MPIR_VOID_PTR_CAST_TO_MPI_AINT recvbuf +
(rdispls[i] * recvtype_extent));
}
mpi_errno = MPIR_Topo_canon_nhb_count(comm_ptr, &indegree, &outdegree, &weighted);
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
MPIR_CHKLMEM_MALLOC(srcs, int *, indegree*sizeof(int), mpi_errno, "srcs", MPL_MEM_COMM);
MPIR_CHKLMEM_MALLOC(dsts, int *, outdegree*sizeof(int), mpi_errno, "dsts", MPL_MEM_COMM);
mpi_errno = MPIR_Topo_canon_nhb(comm_ptr,
indegree, srcs, MPI_UNWEIGHTED,
outdegree, dsts, MPI_UNWEIGHTED);
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
for (k = 0; k < outdegree; ++k) {
char *sb = ((char *)sendbuf) + sdispls[k] * sendtype_extent;
mpi_errno = MPIR_Sched_send(sb, sendcounts[k], sendtype, dsts[k], comm_ptr, s);
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
}
for (l = 0; l < indegree; ++l) {
char *rb = ((char *)recvbuf) + rdispls[l] * recvtype_extent;
mpi_errno = MPIR_Sched_recv(rb, recvcounts[l], recvtype, srcs[l], comm_ptr, s);
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
}
MPIR_SCHED_BARRIER(s);
fn_exit:
MPIR_CHKLMEM_FREEALL();
return mpi_errno;
fn_fail:
goto fn_exit;
}
int MPIR_Reduce_scatter_block_inter_remote_reduce_local_scatter(const void *sendbuf,
void *recvbuf,
int recvcount,
MPI_Datatype datatype,
MPI_Op op,
MPIR_Comm * comm_ptr,
MPIR_Errflag_t * errflag)
{
int rank, mpi_errno, root, local_size, total_count;
int mpi_errno_ret = MPI_SUCCESS;
MPI_Aint true_extent, true_lb = 0, extent;
void *tmp_buf = NULL;
MPIR_Comm *newcomm_ptr = NULL;
MPIR_CHKLMEM_DECL(1);
rank = comm_ptr->rank;
local_size = comm_ptr->local_size;
total_count = local_size * recvcount;
if (rank == 0) {
/* In each group, rank 0 allocates a temp. buffer for the
* reduce */
MPIR_Type_get_true_extent_impl(datatype, &true_lb, &true_extent);
MPIR_Datatype_get_extent_macro(datatype, extent);
MPIR_CHKLMEM_MALLOC(tmp_buf, void *, total_count * (MPL_MAX(extent, true_extent)),
mpi_errno, "tmp_buf", MPL_MEM_BUFFER);
/* adjust for potential negative lower bound in datatype */
tmp_buf = (void *) ((char *) tmp_buf - true_lb);
}
int MPIR_Scan_intra_smp(const void *sendbuf, void *recvbuf, int count,
MPI_Datatype datatype, MPI_Op op, MPIR_Comm * comm_ptr,
MPIR_Errflag_t * errflag)
{
int mpi_errno = MPI_SUCCESS;
int mpi_errno_ret = MPI_SUCCESS;
MPIR_CHKLMEM_DECL(3);
int rank = comm_ptr->rank;
MPI_Status status;
void *tempbuf = NULL, *localfulldata = NULL, *prefulldata = NULL;
MPI_Aint true_lb, true_extent, extent;
int noneed = 1; /* noneed=1 means no need to bcast tempbuf and
* reduce tempbuf & recvbuf */
MPIR_Type_get_true_extent_impl(datatype, &true_lb, &true_extent);
MPIR_Datatype_get_extent_macro(datatype, extent);
MPIR_Ensure_Aint_fits_in_pointer(count * MPL_MAX(extent, true_extent));
MPIR_CHKLMEM_MALLOC(tempbuf, void *, count * (MPL_MAX(extent, true_extent)),
mpi_errno, "temporary buffer", MPL_MEM_BUFFER);
tempbuf = (void *) ((char *) tempbuf - true_lb);
/* Create prefulldata and localfulldata on local roots of all nodes */
if (comm_ptr->node_roots_comm != NULL) {
MPIR_CHKLMEM_MALLOC(prefulldata, void *, count * (MPL_MAX(extent, true_extent)),
mpi_errno, "prefulldata for scan", MPL_MEM_BUFFER);
prefulldata = (void *) ((char *) prefulldata - true_lb);
if (comm_ptr->node_comm != NULL) {
MPIR_CHKLMEM_MALLOC(localfulldata, void *, count * (MPL_MAX(extent, true_extent)),
mpi_errno, "localfulldata for scan", MPL_MEM_BUFFER);
localfulldata = (void *) ((char *) localfulldata - true_lb);
}
int MPIR_Iallgather_sched_inter_local_gather_remote_bcast(const void *sendbuf, int sendcount,
MPI_Datatype sendtype, void *recvbuf,
int recvcount, MPI_Datatype recvtype,
MPIR_Comm * comm_ptr, MPIR_Sched_t s)
{
int mpi_errno = MPI_SUCCESS;
int rank, local_size, remote_size, root;
MPI_Aint true_extent, true_lb = 0, extent, send_extent;
void *tmp_buf = NULL;
MPIR_Comm *newcomm_ptr = NULL;
MPIR_SCHED_CHKPMEM_DECL(1);
local_size = comm_ptr->local_size;
remote_size = comm_ptr->remote_size;
rank = comm_ptr->rank;
if ((rank == 0) && (sendcount != 0)) {
/* In each group, rank 0 allocates temp. buffer for local
* gather */
MPIR_Type_get_true_extent_impl(sendtype, &true_lb, &true_extent);
MPIR_Datatype_get_extent_macro(sendtype, send_extent);
extent = MPL_MAX(send_extent, true_extent);
MPIR_Ensure_Aint_fits_in_pointer(extent * sendcount * local_size);
MPIR_SCHED_CHKPMEM_MALLOC(tmp_buf, void *, extent * sendcount * local_size, mpi_errno,
"tmp_buf", MPL_MEM_BUFFER);
/* adjust for potential negative lower bound in datatype */
tmp_buf = (void *) ((char *) tmp_buf - true_lb);
}
int MPIR_Ialltoall_sched_intra_permuted_sendrecv(const void *sendbuf, int sendcount, MPI_Datatype sendtype, void *recvbuf, int recvcount, MPI_Datatype recvtype, MPIR_Comm *comm_ptr, MPIR_Sched_t s)
{
int mpi_errno = MPI_SUCCESS;
int i;
int rank, comm_size;
int ii, ss, bblock, dst;
MPI_Aint sendtype_extent, recvtype_extent;
#ifdef HAVE_ERROR_CHECKING
MPIR_Assert(sendbuf != MPI_IN_PLACE); /* we do not handle in-place */
#endif
comm_size = comm_ptr->local_size;
rank = comm_ptr->rank;
MPIR_Datatype_get_extent_macro(sendtype, sendtype_extent);
MPIR_Datatype_get_extent_macro(recvtype, recvtype_extent);
bblock = MPIR_CVAR_ALLTOALL_THROTTLE;
if (bblock == 0) bblock = comm_size;
for (ii = 0; ii < comm_size; ii += bblock) {
ss = comm_size-ii < bblock ? comm_size-ii : bblock;
/* do the communication -- post ss sends and receives: */
for (i = 0; i < ss; i++) {
dst = (rank+i+ii) % comm_size;
mpi_errno = MPIR_Sched_recv(((char *)recvbuf + dst*recvcount*recvtype_extent),
recvcount, recvtype, dst, comm_ptr, s);
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
}
for (i = 0; i < ss; i++) {
dst = (rank-i-ii+comm_size) % comm_size;
mpi_errno = MPIR_Sched_send(((char *)sendbuf + dst*sendcount*sendtype_extent),
sendcount, sendtype, dst, comm_ptr, s);
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
}
/* force the (2*ss) sends/recvs above to complete before posting additional ops */
MPIR_SCHED_BARRIER(s);
}
fn_exit:
return mpi_errno;
fn_fail:
goto fn_exit;
}
int MPIR_Reduce_intra_reduce_scatter_gather (
const void *sendbuf,
void *recvbuf,
int count,
MPI_Datatype datatype,
MPI_Op op,
int root,
MPIR_Comm *comm_ptr,
MPIR_Errflag_t *errflag )
{
int mpi_errno = MPI_SUCCESS;
int mpi_errno_ret = MPI_SUCCESS;
int comm_size, rank, type_size ATTRIBUTE((unused)), pof2, rem, newrank;
int mask, *cnts, *disps, i, j, send_idx=0;
int recv_idx, last_idx=0, newdst;
int dst, send_cnt, recv_cnt, newroot, newdst_tree_root, newroot_tree_root;
MPI_Aint true_lb, true_extent, extent;
void *tmp_buf;
MPIR_CHKLMEM_DECL(4);
comm_size = comm_ptr->local_size;
rank = comm_ptr->rank;
/* set op_errno to 0. stored in perthread structure */
{
MPIR_Per_thread_t *per_thread = NULL;
int err = 0;
MPID_THREADPRIV_KEY_GET_ADDR(MPIR_ThreadInfo.isThreaded, MPIR_Per_thread_key,
MPIR_Per_thread, per_thread, &err);
MPIR_Assert(err == 0);
per_thread->op_errno = 0;
}
/* Create a temporary buffer */
MPIR_Type_get_true_extent_impl(datatype, &true_lb, &true_extent);
MPIR_Datatype_get_extent_macro(datatype, extent);
/* I think this is the worse case, so we can avoid an assert()
* inside the for loop */
/* should be buf+{this}? */
MPIR_Ensure_Aint_fits_in_pointer(count * MPL_MAX(extent, true_extent));
MPIR_CHKLMEM_MALLOC(tmp_buf, void *, count*(MPL_MAX(extent,true_extent)),
mpi_errno, "temporary buffer", MPL_MEM_BUFFER);
/* adjust for potential negative lower bound in datatype */
tmp_buf = (void *)((char*)tmp_buf - true_lb);
/* If I'm not the root, then my recvbuf may not be valid, therefore
I have to allocate a temporary one */
if (rank != root) {
MPIR_CHKLMEM_MALLOC(recvbuf, void *,
count*(MPL_MAX(extent,true_extent)),
mpi_errno, "receive buffer", MPL_MEM_BUFFER);
recvbuf = (void *)((char*)recvbuf - true_lb);
}
int MPIR_Ireduce_sched_intra_binomial(const void *sendbuf, void *recvbuf, int count,
MPI_Datatype datatype, MPI_Op op, int root,
MPIR_Comm * comm_ptr, MPIR_Sched_t s)
{
int mpi_errno = MPI_SUCCESS;
int comm_size, rank, is_commutative;
int mask, relrank, source, lroot;
MPI_Aint true_lb, true_extent, extent;
void *tmp_buf;
MPIR_SCHED_CHKPMEM_DECL(2);
MPIR_Assert(comm_ptr->comm_kind == MPIR_COMM_KIND__INTRACOMM);
if (count == 0)
return MPI_SUCCESS;
comm_size = comm_ptr->local_size;
rank = comm_ptr->rank;
/* set op_errno to 0. stored in perthread structure */
{
MPIR_Per_thread_t *per_thread = NULL;
int err = 0;
MPID_THREADPRIV_KEY_GET_ADDR(MPIR_ThreadInfo.isThreaded, MPIR_Per_thread_key,
MPIR_Per_thread, per_thread, &err);
MPIR_Assert(err == 0);
per_thread->op_errno = 0;
}
/* Create a temporary buffer */
MPIR_Type_get_true_extent_impl(datatype, &true_lb, &true_extent);
MPIR_Datatype_get_extent_macro(datatype, extent);
is_commutative = MPIR_Op_is_commutative(op);
/* I think this is the worse case, so we can avoid an assert()
* inside the for loop */
/* should be buf+{this}? */
MPIR_Ensure_Aint_fits_in_pointer(count * MPL_MAX(extent, true_extent));
MPIR_SCHED_CHKPMEM_MALLOC(tmp_buf, void *, count * (MPL_MAX(extent, true_extent)),
mpi_errno, "temporary buffer", MPL_MEM_BUFFER);
/* adjust for potential negative lower bound in datatype */
tmp_buf = (void *) ((char *) tmp_buf - true_lb);
/* If I'm not the root, then my recvbuf may not be valid, therefore
* I have to allocate a temporary one */
if (rank != root) {
MPIR_SCHED_CHKPMEM_MALLOC(recvbuf, void *,
count * (MPL_MAX(extent, true_extent)),
mpi_errno, "receive buffer", MPL_MEM_BUFFER);
recvbuf = (void *) ((char *) recvbuf - true_lb);
}
int MPIR_Gather_inter_linear(const void *sendbuf, int sendcount, MPI_Datatype sendtype,
void *recvbuf, int recvcount, MPI_Datatype recvtype, int root,
MPIR_Comm * comm_ptr, MPIR_Errflag_t * errflag)
{
int remote_size, mpi_errno = MPI_SUCCESS;
int mpi_errno_ret = MPI_SUCCESS;
int i;
MPI_Status status;
MPI_Aint extent;
if (root == MPI_PROC_NULL) {
/* local processes other than root do nothing */
return MPI_SUCCESS;
}
remote_size = comm_ptr->remote_size;
if (root == MPI_ROOT) {
MPIR_Datatype_get_extent_macro(recvtype, extent);
MPIR_Ensure_Aint_fits_in_pointer(MPIR_VOID_PTR_CAST_TO_MPI_AINT recvbuf +
(recvcount * remote_size * extent));
for (i = 0; i < remote_size; i++) {
mpi_errno =
MPIC_Recv(((char *) recvbuf + recvcount * i * extent), recvcount, recvtype, i,
MPIR_GATHER_TAG, comm_ptr, &status, errflag);
if (mpi_errno) {
/* for communication errors, just record the error but continue */
*errflag =
MPIX_ERR_PROC_FAILED ==
MPIR_ERR_GET_CLASS(mpi_errno) ? MPIR_ERR_PROC_FAILED : MPIR_ERR_OTHER;
MPIR_ERR_SET(mpi_errno, *errflag, "**fail");
MPIR_ERR_ADD(mpi_errno_ret, mpi_errno);
}
}
} else {
mpi_errno =
MPIC_Send(sendbuf, sendcount, sendtype, root, MPIR_GATHER_TAG, comm_ptr, errflag);
if (mpi_errno) {
/* for communication errors, just record the error but continue */
*errflag =
MPIX_ERR_PROC_FAILED ==
MPIR_ERR_GET_CLASS(mpi_errno) ? MPIR_ERR_PROC_FAILED : MPIR_ERR_OTHER;
MPIR_ERR_SET(mpi_errno, *errflag, "**fail");
MPIR_ERR_ADD(mpi_errno_ret, mpi_errno);
}
}
if (mpi_errno_ret)
mpi_errno = mpi_errno_ret;
else if (*errflag != MPIR_ERR_NONE)
MPIR_ERR_SET(mpi_errno, *errflag, "**coll_fail");
return mpi_errno;
}
int MPIR_Iscatter_sched_intra_binomial(const void *sendbuf, int sendcount, MPI_Datatype sendtype,
void *recvbuf, int recvcount, MPI_Datatype recvtype,
int root, MPIR_Comm * comm_ptr, MPIR_Sched_t s)
{
int mpi_errno = MPI_SUCCESS;
MPI_Aint extent = 0;
int rank, comm_size, sendtype_size;
int relative_rank;
int mask, recvtype_size = 0, src, dst;
int tmp_buf_size = 0;
void *tmp_buf = NULL;
struct shared_state *ss = NULL;
MPIR_SCHED_CHKPMEM_DECL(4);
comm_size = comm_ptr->local_size;
rank = comm_ptr->rank;
if (((rank == root) && (sendcount == 0)) || ((rank != root) && (recvcount == 0)))
goto fn_exit;
MPIR_SCHED_CHKPMEM_MALLOC(ss, struct shared_state *, sizeof(struct shared_state), mpi_errno,
"shared_state", MPL_MEM_BUFFER);
ss->sendcount = sendcount;
if (rank == root)
MPIR_Datatype_get_extent_macro(sendtype, extent);
relative_rank = (rank >= root) ? rank - root : rank - root + comm_size;
if (rank == root) {
/* We separate the two cases (root and non-root) because
* in the event of recvbuf=MPI_IN_PLACE on the root,
* recvcount and recvtype are not valid */
MPIR_Datatype_get_size_macro(sendtype, sendtype_size);
MPIR_Ensure_Aint_fits_in_pointer(MPIR_VOID_PTR_CAST_TO_MPI_AINT sendbuf +
extent * sendcount * comm_size);
ss->nbytes = sendtype_size * sendcount;
} else {
MPIR_Datatype_get_size_macro(recvtype, recvtype_size);
MPIR_Ensure_Aint_fits_in_pointer(extent * recvcount * comm_size);
ss->nbytes = recvtype_size * recvcount;
}
ss->curr_count = 0;
/* all even nodes other than root need a temporary buffer to
* receive data of max size (ss->nbytes*comm_size)/2 */
if (relative_rank && !(relative_rank % 2)) {
tmp_buf_size = (ss->nbytes * comm_size) / 2;
MPIR_SCHED_CHKPMEM_MALLOC(tmp_buf, void *, tmp_buf_size, mpi_errno, "tmp_buf",
MPL_MEM_BUFFER);
}
/* Algorithm: Ring
*
* In the first step, each process i sends its contribution to process
* i+1 and receives the contribution from process i-1 (with
* wrap-around). From the second step onwards, each process i
* forwards to process i+1 the data it received from process i-1 in
* the previous step. This takes a total of p-1 steps.
*
* Cost = (p-1).alpha + n.((p-1)/p).beta
*
* This algorithm is preferred to recursive doubling for long messages
* because we find that this communication pattern (nearest neighbor)
* performs twice as fast as recursive doubling for long messages (on
* Myrinet and IBM SP).
*/
int MPIR_Iallgather_sched_intra_ring(const void *sendbuf, int sendcount, MPI_Datatype
sendtype, void *recvbuf, int recvcount, MPI_Datatype recvtype,
MPIR_Comm * comm_ptr, MPIR_Sched_t s)
{
int mpi_errno = MPI_SUCCESS;
int rank, comm_size;
int i, j, jnext, left, right;
MPI_Aint recvtype_extent;
comm_size = comm_ptr->local_size;
rank = comm_ptr->rank;
MPIR_Datatype_get_extent_macro(recvtype, recvtype_extent);
/* First, load the "local" version in the recvbuf. */
if (sendbuf != MPI_IN_PLACE) {
mpi_errno = MPIR_Sched_copy(sendbuf, sendcount, sendtype,
((char *) recvbuf + rank * recvcount * recvtype_extent),
recvcount, recvtype, s);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
MPIR_SCHED_BARRIER(s);
}
/* Now, send left to right. This fills in the receive area in
* reverse order. */
left = (comm_size + rank - 1) % comm_size;
right = (rank + 1) % comm_size;
j = rank;
jnext = left;
for (i = 1; i < comm_size; i++) {
mpi_errno = MPIR_Sched_send(((char *) recvbuf + j * recvcount * recvtype_extent),
recvcount, recvtype, right, comm_ptr, s);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
/* concurrent, no barrier here */
mpi_errno = MPIR_Sched_recv(((char *) recvbuf + jnext * recvcount * recvtype_extent),
recvcount, recvtype, left, comm_ptr, s);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
MPIR_SCHED_BARRIER(s);
j = jnext;
jnext = (comm_size + jnext - 1) % comm_size;
}
fn_exit:
return mpi_errno;
fn_fail:
goto fn_exit;
}
int MPIR_Ineighbor_allgatherv_sched_allcomm_linear(const void *sendbuf, int sendcount,
MPI_Datatype sendtype, void *recvbuf,
const int recvcounts[], const int displs[],
MPI_Datatype recvtype, MPIR_Comm * comm_ptr,
MPIR_Sched_t s)
{
int mpi_errno = MPI_SUCCESS;
int indegree, outdegree, weighted;
int k, l;
int *srcs, *dsts;
MPI_Aint recvtype_extent;
MPIR_CHKLMEM_DECL(2);
MPIR_Datatype_get_extent_macro(recvtype, recvtype_extent);
mpi_errno = MPIR_Topo_canon_nhb_count(comm_ptr, &indegree, &outdegree, &weighted);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
MPIR_CHKLMEM_MALLOC(srcs, int *, indegree * sizeof(int), mpi_errno, "srcs", MPL_MEM_COMM);
MPIR_CHKLMEM_MALLOC(dsts, int *, outdegree * sizeof(int), mpi_errno, "dsts", MPL_MEM_COMM);
mpi_errno = MPIR_Topo_canon_nhb(comm_ptr,
indegree, srcs, MPI_UNWEIGHTED,
outdegree, dsts, MPI_UNWEIGHTED);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
for (k = 0; k < outdegree; ++k) {
mpi_errno = MPIR_Sched_send(sendbuf, sendcount, sendtype, dsts[k], comm_ptr, s);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
}
for (l = 0; l < indegree; ++l) {
char *rb = ((char *) recvbuf) + displs[l] * recvtype_extent;
mpi_errno = MPIR_Sched_recv(rb, recvcounts[l], recvtype, srcs[l], comm_ptr, s);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
}
MPIR_SCHED_BARRIER(s);
fn_exit:
MPIR_CHKLMEM_FREEALL();
return mpi_errno;
fn_fail:
goto fn_exit;
}
int MPIR_Iscan_sched_intra_smp(const void *sendbuf, void *recvbuf, int count, MPI_Datatype datatype, MPI_Op op, MPIR_Comm *comm_ptr, MPIR_Sched_t s)
{
int mpi_errno = MPI_SUCCESS;
int rank = comm_ptr->rank;
MPIR_Comm *node_comm;
MPIR_Comm *roots_comm;
MPI_Aint true_extent, true_lb, extent;
void *tempbuf = NULL;
void *prefulldata = NULL;
void *localfulldata = NULL;
MPIR_SCHED_CHKPMEM_DECL(3);
/* In order to use the SMP-aware algorithm, the "op" can be
either commutative or non-commutative, but we require a
communicator in which all the nodes contain processes with
consecutive ranks. */
if (!MPII_Comm_is_node_consecutive(comm_ptr)) {
/* We can't use the SMP-aware algorithm, use the generic one */
return MPIR_Iscan_sched_intra_recursive_doubling(sendbuf, recvbuf, count, datatype, op, comm_ptr, s);
}
node_comm = comm_ptr->node_comm;
roots_comm = comm_ptr->node_roots_comm;
MPIR_Type_get_true_extent_impl(datatype, &true_lb, &true_extent);
MPIR_Datatype_get_extent_macro(datatype, extent);
MPIR_Ensure_Aint_fits_in_pointer(count * MPL_MAX(extent, true_extent));
MPIR_SCHED_CHKPMEM_MALLOC(tempbuf, void *, count*(MPL_MAX(extent, true_extent)),
mpi_errno, "temporary buffer", MPL_MEM_BUFFER);
tempbuf = (void *)((char*)tempbuf - true_lb);
/* Create prefulldata and localfulldata on local roots of all nodes */
if (comm_ptr->node_roots_comm != NULL) {
MPIR_SCHED_CHKPMEM_MALLOC(prefulldata, void *, count*(MPL_MAX(extent, true_extent)),
mpi_errno, "prefulldata for scan", MPL_MEM_BUFFER);
prefulldata = (void *)((char*)prefulldata - true_lb);
if (node_comm != NULL) {
MPIR_SCHED_CHKPMEM_MALLOC(localfulldata, void *, count*(MPL_MAX(extent, true_extent)),
mpi_errno, "localfulldata for scan", MPL_MEM_BUFFER);
localfulldata = (void *)((char*)localfulldata - true_lb);
}
/* This function implements a binomial tree reduce.
Cost = lgp.alpha + n.lgp.beta + n.lgp.gamma
*/
int MPIR_Reduce_intra_binomial(const void *sendbuf,
void *recvbuf,
int count,
MPI_Datatype datatype,
MPI_Op op, int root, MPIR_Comm * comm_ptr, MPIR_Errflag_t * errflag)
{
int mpi_errno = MPI_SUCCESS;
int mpi_errno_ret = MPI_SUCCESS;
MPI_Status status;
int comm_size, rank, is_commutative, type_size ATTRIBUTE((unused));
int mask, relrank, source, lroot;
MPI_Aint true_lb, true_extent, extent;
void *tmp_buf;
MPIR_CHKLMEM_DECL(2);
if (count == 0)
return MPI_SUCCESS;
comm_size = comm_ptr->local_size;
rank = comm_ptr->rank;
/* Create a temporary buffer */
MPIR_Type_get_true_extent_impl(datatype, &true_lb, &true_extent);
MPIR_Datatype_get_extent_macro(datatype, extent);
is_commutative = MPIR_Op_is_commutative(op);
MPIR_CHKLMEM_MALLOC(tmp_buf, void *, count * (MPL_MAX(extent, true_extent)),
mpi_errno, "temporary buffer", MPL_MEM_BUFFER);
/* adjust for potential negative lower bound in datatype */
tmp_buf = (void *) ((char *) tmp_buf - true_lb);
/* If I'm not the root, then my recvbuf may not be valid, therefore
* I have to allocate a temporary one */
if (rank != root) {
MPIR_CHKLMEM_MALLOC(recvbuf, void *,
count * (MPL_MAX(extent, true_extent)),
mpi_errno, "receive buffer", MPL_MEM_BUFFER);
recvbuf = (void *) ((char *) recvbuf - true_lb);
}
int MPIR_Iscatter_sched_inter_linear(const void *sendbuf, int sendcount, MPI_Datatype sendtype,
void *recvbuf, int recvcount, MPI_Datatype recvtype, int root,
MPIR_Comm * comm_ptr, MPIR_Sched_t s)
{
int mpi_errno = MPI_SUCCESS;
int remote_size;
int i;
MPI_Aint extent;
if (root == MPI_PROC_NULL) {
/* local processes other than root do nothing */
goto fn_exit;
}
remote_size = comm_ptr->remote_size;
if (root == MPI_ROOT) {
MPIR_Datatype_get_extent_macro(sendtype, extent);
for (i = 0; i < remote_size; i++) {
mpi_errno =
MPIR_Sched_send(((char *) sendbuf + sendcount * i * extent), sendcount, sendtype, i,
comm_ptr, s);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
}
MPIR_SCHED_BARRIER(s);
} else {
mpi_errno = MPIR_Sched_recv(recvbuf, recvcount, recvtype, root, comm_ptr, s);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
MPIR_SCHED_BARRIER(s);
}
fn_exit:
return mpi_errno;
fn_fail:
goto fn_exit;
}
int MPIR_Igather_sched_intra_binomial(const void *sendbuf, int sendcount, MPI_Datatype sendtype, void *recvbuf, int recvcount, MPI_Datatype recvtype, int root, MPIR_Comm *comm_ptr, MPIR_Sched_t s)
{
int mpi_errno = MPI_SUCCESS;
int comm_size, rank;
int relative_rank, is_homogeneous;
int mask, src, dst, relative_src;
MPI_Aint recvtype_size, sendtype_size, curr_cnt=0, nbytes;
int recvblks;
int tmp_buf_size, missing;
void *tmp_buf = NULL;
int blocks[2];
int displs[2];
MPI_Aint struct_displs[2];
MPI_Aint extent=0;
int copy_offset = 0, copy_blks = 0;
MPI_Datatype types[2], tmp_type;
MPIR_SCHED_CHKPMEM_DECL(1);
comm_size = comm_ptr->local_size;
rank = comm_ptr->rank;
if (((rank == root) && (recvcount == 0)) || ((rank != root) && (sendcount == 0)))
goto fn_exit;
is_homogeneous = TRUE;
#ifdef MPID_HAS_HETERO
is_homogeneous = !comm_ptr->is_hetero;
#endif
MPIR_Assert(comm_ptr->comm_kind == MPIR_COMM_KIND__INTRACOMM);
/* Use binomial tree algorithm. */
relative_rank = (rank >= root) ? rank - root : rank - root + comm_size;
if (rank == root)
{
MPIR_Datatype_get_extent_macro(recvtype, extent);
MPIR_Ensure_Aint_fits_in_pointer(MPIR_VOID_PTR_CAST_TO_MPI_AINT recvbuf+
(extent*recvcount*comm_size));
}
if (is_homogeneous)
{
/* communicator is homogeneous. no need to pack buffer. */
if (rank == root)
{
MPIR_Datatype_get_size_macro(recvtype, recvtype_size);
nbytes = recvtype_size * recvcount;
}
else
{
MPIR_Datatype_get_size_macro(sendtype, sendtype_size);
nbytes = sendtype_size * sendcount;
}
/* Find the number of missing nodes in my sub-tree compared to
* a balanced tree */
for (mask = 1; mask < comm_size; mask <<= 1);
--mask;
while (relative_rank & mask) mask >>= 1;
missing = (relative_rank | mask) - comm_size + 1;
if (missing < 0) missing = 0;
tmp_buf_size = (mask - missing);
/* If the message is smaller than the threshold, we will copy
* our message in there too */
if (nbytes < MPIR_CVAR_GATHER_VSMALL_MSG_SIZE) tmp_buf_size++;
tmp_buf_size *= nbytes;
/* For zero-ranked root, we don't need any temporary buffer */
if ((rank == root) && (!root || (nbytes >= MPIR_CVAR_GATHER_VSMALL_MSG_SIZE)))
tmp_buf_size = 0;
if (tmp_buf_size) {
MPIR_SCHED_CHKPMEM_MALLOC(tmp_buf, void *, tmp_buf_size, mpi_errno, "tmp_buf", MPL_MEM_BUFFER);
}
if (rank == root) {
if (sendbuf != MPI_IN_PLACE) {
mpi_errno = MPIR_Localcopy(sendbuf, sendcount, sendtype,
((char *) recvbuf + extent*recvcount*rank), recvcount, recvtype);
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
}
}
else if (tmp_buf_size && (nbytes < MPIR_CVAR_GATHER_VSMALL_MSG_SIZE)) {
/* copy from sendbuf into tmp_buf */
mpi_errno = MPIR_Localcopy(sendbuf, sendcount, sendtype,
tmp_buf, nbytes, MPI_BYTE);
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
}
curr_cnt = nbytes;
mask = 0x1;
while (mask < comm_size) {
if ((mask & relative_rank) == 0) {
src = relative_rank | mask;
if (src < comm_size) {
src = (src + root) % comm_size;
if (rank == root) {
recvblks = mask;
if ((2 * recvblks) > comm_size)
recvblks = comm_size - recvblks;
if ((rank + mask + recvblks == comm_size) ||
(((rank + mask) % comm_size) < ((rank + mask + recvblks) % comm_size)))
{
/* If the data contiguously fits into the
* receive buffer, place it directly. This
* should cover the case where the root is
* rank 0. */
char *rp = (char *)recvbuf + (((rank + mask) % comm_size)*recvcount*extent);
mpi_errno = MPIR_Sched_recv(rp, (recvblks * recvcount), recvtype, src, comm_ptr, s);
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
mpi_errno = MPIR_Sched_barrier(s);
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
}
else if (nbytes < MPIR_CVAR_GATHER_VSMALL_MSG_SIZE) {
mpi_errno = MPIR_Sched_recv(tmp_buf, (recvblks * nbytes), MPI_BYTE, src, comm_ptr, s);
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
mpi_errno = MPIR_Sched_barrier(s);
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
copy_offset = rank + mask;
copy_blks = recvblks;
}
else {
blocks[0] = recvcount * (comm_size - root - mask);
displs[0] = recvcount * (root + mask);
blocks[1] = (recvcount * recvblks) - blocks[0];
displs[1] = 0;
mpi_errno = MPIR_Type_indexed_impl(2, blocks, displs, recvtype, &tmp_type);
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
mpi_errno = MPIR_Type_commit_impl(&tmp_type);
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
mpi_errno = MPIR_Sched_recv(recvbuf, 1, tmp_type, src, comm_ptr, s);
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
mpi_errno = MPIR_Sched_barrier(s);
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
/* this "premature" free is safe b/c the sched holds an actual ref to keep it alive */
MPIR_Type_free_impl(&tmp_type);
}
}
else { /* Intermediate nodes store in temporary buffer */
MPI_Aint offset;
/* Estimate the amount of data that is going to come in */
recvblks = mask;
relative_src = ((src - root) < 0) ? (src - root + comm_size) : (src - root);
if (relative_src + mask > comm_size)
recvblks -= (relative_src + mask - comm_size);
if (nbytes < MPIR_CVAR_GATHER_VSMALL_MSG_SIZE)
offset = mask * nbytes;
else
offset = (mask - 1) * nbytes;
mpi_errno = MPIR_Sched_recv(((char *)tmp_buf + offset), (recvblks * nbytes),
MPI_BYTE, src, comm_ptr, s);
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
mpi_errno = MPIR_Sched_barrier(s);
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
curr_cnt += (recvblks * nbytes);
}
}
}
else {
dst = relative_rank ^ mask;
dst = (dst + root) % comm_size;
if (!tmp_buf_size) {
/* leaf nodes send directly from sendbuf */
mpi_errno = MPIR_Sched_send(sendbuf, sendcount, sendtype, dst, comm_ptr, s);
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
mpi_errno = MPIR_Sched_barrier(s);
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
}
else if (nbytes < MPIR_CVAR_GATHER_VSMALL_MSG_SIZE) {
mpi_errno = MPIR_Sched_send(tmp_buf, curr_cnt, MPI_BYTE, dst, comm_ptr, s);
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
mpi_errno = MPIR_Sched_barrier(s);
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
}
else {
blocks[0] = sendcount;
struct_displs[0] = MPIR_VOID_PTR_CAST_TO_MPI_AINT sendbuf;
types[0] = sendtype;
/* check for overflow. work around int limits if needed*/
if (curr_cnt - nbytes != (int)(curr_cnt-nbytes)) {
blocks[1] = 1;
MPIR_Type_contiguous_x_impl(curr_cnt - nbytes,
MPI_BYTE, &(types[1]));
} else {
MPIR_Assign_trunc(blocks[1], curr_cnt - nbytes, int);
types[1] = MPI_BYTE;
}
struct_displs[1] = MPIR_VOID_PTR_CAST_TO_MPI_AINT tmp_buf;
mpi_errno = MPIR_Type_create_struct_impl(2, blocks, struct_displs, types, &tmp_type);
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
mpi_errno = MPIR_Type_commit_impl(&tmp_type);
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
mpi_errno = MPIR_Sched_send(MPI_BOTTOM, 1, tmp_type, dst, comm_ptr, s);
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
MPIR_SCHED_BARRIER(s);
/* this "premature" free is safe b/c the sched holds an actual ref to keep it alive */
MPIR_Type_free_impl(&tmp_type);
}
break;
}
mask <<= 1;
}
if ((rank == root) && root && (nbytes < MPIR_CVAR_GATHER_VSMALL_MSG_SIZE) && copy_blks) {
/* reorder and copy from tmp_buf into recvbuf */
/* FIXME why are there two copies here? */
mpi_errno = MPIR_Sched_copy(tmp_buf, nbytes * (comm_size - copy_offset), MPI_BYTE,
((char *)recvbuf + extent * recvcount * copy_offset),
recvcount * (comm_size - copy_offset), recvtype, s);
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
mpi_errno = MPIR_Sched_copy((char *)tmp_buf + nbytes * (comm_size - copy_offset),
nbytes * (copy_blks - comm_size + copy_offset), MPI_BYTE,
recvbuf, recvcount * (copy_blks - comm_size + copy_offset),
recvtype, s);
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
}
}
#ifdef MPID_HAS_HETERO
else {
void MPIDU_Type_calc_footprint(MPI_Datatype type, DLOOP_Type_footprint *tfp)
{
int mpi_errno;
int nr_ints, nr_aints, nr_types, combiner;
int *ints;
MPI_Aint *aints;
MPI_Datatype *types;
/* used to store parameters for constituent types */
DLOOP_Offset size = 0, lb = 0, ub = 0, true_lb = 0, true_ub = 0;
DLOOP_Offset extent = 0, alignsz;
int has_sticky_lb, has_sticky_ub;
/* used for vector/hvector/hvector_integer calculations */
DLOOP_Offset stride;
/* used for indexed/hindexed calculations */
DLOOP_Offset disp;
/* used for calculations on types with more than one block of data */
DLOOP_Offset i, min_lb, max_ub, ntypes, tmp_lb, tmp_ub;
/* used for processing subarray and darray types */
int ndims;
MPI_Datatype tmptype;
MPIR_Type_get_envelope(type, &nr_ints, &nr_aints, &nr_types, &combiner);
if (combiner == MPI_COMBINER_NAMED) {
int mpisize;
MPI_Aint mpiextent;
MPIR_Datatype_get_size_macro(type, mpisize);
MPIR_Datatype_get_extent_macro(type, mpiextent);
tfp->size = (DLOOP_Offset) mpisize;
tfp->lb = 0;
tfp->ub = (DLOOP_Offset) mpiextent;
tfp->true_lb = 0;
tfp->true_ub = (DLOOP_Offset) mpiextent;
tfp->extent = (DLOOP_Offset) mpiextent;
tfp->alignsz = DLOOP_Named_type_alignsize(type, (MPI_Aint) 0);
tfp->has_sticky_lb = (type == MPI_LB) ? 1 : 0;
tfp->has_sticky_ub = (type == MPI_UB) ? 1 : 0;
goto clean_exit;
}
/* get access to contents; need it immediately to check for zero count */
MPIDU_Type_access_contents(type, &ints, &aints, &types);
/* knock out all the zero count cases */
if ((combiner == MPI_COMBINER_CONTIGUOUS ||
combiner == MPI_COMBINER_VECTOR ||
combiner == MPI_COMBINER_HVECTOR_INTEGER ||
combiner == MPI_COMBINER_HVECTOR ||
combiner == MPI_COMBINER_INDEXED_BLOCK ||
combiner == MPI_COMBINER_HINDEXED_BLOCK ||
combiner == MPI_COMBINER_INDEXED ||
combiner == MPI_COMBINER_HINDEXED_INTEGER ||
combiner == MPI_COMBINER_STRUCT_INTEGER ||
combiner == MPI_COMBINER_STRUCT) && ints[0] == 0)
{
tfp->size = tfp->lb = tfp->ub = tfp->extent = tfp->alignsz = 0;
tfp->true_lb = tfp->true_ub = 0;
tfp->has_sticky_lb = tfp->has_sticky_ub = 0;
goto clean_exit;
}
if (combiner != MPI_COMBINER_STRUCT &&
combiner != MPI_COMBINER_STRUCT_INTEGER)
{
DLOOP_Type_footprint cfp;
MPIDU_Type_calc_footprint(types[0], &cfp);
size = cfp.size;
lb = cfp.lb;
ub = cfp.ub;
true_lb = cfp.true_lb;
true_ub = cfp.true_ub;
extent = cfp.extent;
alignsz = cfp.alignsz;
has_sticky_lb = cfp.has_sticky_lb;
has_sticky_ub = cfp.has_sticky_ub;
/* initialize some common values so we don't have to assign
* them in every case below.
*/
tfp->alignsz = alignsz;
tfp->has_sticky_lb = has_sticky_lb;
tfp->has_sticky_ub = has_sticky_ub;
}
switch(combiner)
{
case MPI_COMBINER_DUP:
tfp->size = size;
tfp->lb = lb;
tfp->ub = ub;
tfp->true_lb = true_lb;
tfp->true_ub = true_ub;
tfp->extent = extent;
break;
case MPI_COMBINER_RESIZED:
tfp->size = size;
tfp->lb = aints[0]; /* lb */
tfp->ub = aints[0] + aints[1];
tfp->true_lb = true_lb;
tfp->true_ub = true_ub;
tfp->extent = aints[1]; /* extent */
tfp->has_sticky_lb = 1;
tfp->has_sticky_ub = 1;
break;
case MPI_COMBINER_CONTIGUOUS:
DLOOP_DATATYPE_CONTIG_LB_UB(ints[0] /* count */,
lb, ub, extent,
tfp->lb, tfp->ub);
tfp->true_lb = tfp->lb + (true_lb - lb);
tfp->true_ub = tfp->ub + (true_ub - ub);
tfp->size = (DLOOP_Offset) ints[0] * size;
tfp->extent = tfp->ub - tfp->lb;
break;
case MPI_COMBINER_VECTOR:
case MPI_COMBINER_HVECTOR:
case MPI_COMBINER_HVECTOR_INTEGER:
if (combiner == MPI_COMBINER_VECTOR) stride = (DLOOP_Offset) ints[2] * extent;
else if (combiner == MPI_COMBINER_HVECTOR) stride = aints[0];
else /* HVECTOR_INTEGER */ stride = (DLOOP_Offset) ints[2];
DLOOP_DATATYPE_VECTOR_LB_UB(ints[0] /* count */,
stride /* stride in bytes */,
ints[1] /* blklen */,
lb, ub, extent,
tfp->lb, tfp->ub);
tfp->true_lb = tfp->lb + (true_lb - lb);
tfp->true_ub = tfp->ub + (true_ub - ub);
tfp->size = (DLOOP_Offset) ints[0] * (DLOOP_Offset) ints[1] * size;
tfp->extent = tfp->ub - tfp->lb;
break;
case MPI_COMBINER_INDEXED_BLOCK:
/* prime min_lb and max_ub */
DLOOP_DATATYPE_BLOCK_LB_UB(ints[1] /* blklen */,
(DLOOP_Offset) ints[2] * extent /* disp */,
lb, ub, extent,
min_lb, max_ub);
for (i=1; i < ints[0]; i++) {
DLOOP_DATATYPE_BLOCK_LB_UB(ints[1] /* blklen */,
(DLOOP_Offset) ints[i+2] * extent /* disp */,
lb, ub, extent,
tmp_lb, tmp_ub);
if (tmp_lb < min_lb) min_lb = tmp_lb;
if (tmp_ub > max_ub) max_ub = tmp_ub;
}
tfp->size = (DLOOP_Offset) ints[0] * (DLOOP_Offset) ints[1] * size;
tfp->lb = min_lb;
tfp->ub = max_ub;
tfp->true_lb = min_lb + (true_lb - lb);
tfp->true_ub = max_ub + (true_ub - ub);
tfp->extent = tfp->ub - tfp->lb;
break;
case MPI_COMBINER_HINDEXED_BLOCK:
/* prime min_lb and max_ub */
DLOOP_DATATYPE_BLOCK_LB_UB(ints[1] /* blklen */,
(DLOOP_Offset) ints[2] /* disp */,
lb, ub, extent,
min_lb, max_ub);
for (i=1; i < ints[0]; i++) {
DLOOP_DATATYPE_BLOCK_LB_UB(ints[1] /* blklen */,
(DLOOP_Offset) ints[i+2] /* disp */,
lb, ub, extent,
tmp_lb, tmp_ub);
if (tmp_lb < min_lb) min_lb = tmp_lb;
if (tmp_ub > max_ub) max_ub = tmp_ub;
}
tfp->size = (DLOOP_Offset) ints[0] * (DLOOP_Offset) ints[1] * size;
tfp->lb = min_lb;
tfp->ub = max_ub;
tfp->true_lb = min_lb + (true_lb - lb);
tfp->true_ub = max_ub + (true_ub - ub);
tfp->extent = tfp->ub - tfp->lb;
break;
case MPI_COMBINER_INDEXED:
case MPI_COMBINER_HINDEXED_INTEGER:
case MPI_COMBINER_HINDEXED:
/* find first non-zero blocklength element */
for (i=0; i < ints[0] && ints[i+1] == 0; i++);
if (i == ints[0]) {
/* all zero blocklengths */
tfp->size = tfp->lb = tfp->ub = tfp->extent = tfp->alignsz = 0;
tfp->has_sticky_lb = tfp->has_sticky_ub = 0;
}
else {
/* prime min_lb, max_ub, count */
ntypes = ints[i+1];
if (combiner == MPI_COMBINER_INDEXED)
disp = (DLOOP_Offset) ints[ints[0]+i+1] * extent;
else if (combiner == MPI_COMBINER_HINDEXED_INTEGER)
disp = (DLOOP_Offset) ints[ints[0]+i+1];
else /* MPI_COMBINER_HINDEXED */
disp = aints[i];
DLOOP_DATATYPE_BLOCK_LB_UB(ints[i+1] /* blklen */,
disp,
lb, ub, extent,
min_lb, max_ub);
for (i++; i < ints[0]; i++) {
/* skip zero blocklength elements */
if (ints[i+1] == 0) continue;
ntypes += ints[i+1];
if (combiner == MPI_COMBINER_INDEXED)
disp = (DLOOP_Offset) ints[ints[0]+i+1] * extent;
else if (combiner == MPI_COMBINER_HINDEXED_INTEGER)
disp = (DLOOP_Offset) ints[ints[0]+i+1];
else /* MPI_COMBINER_HINDEXED */
disp = aints[i];
DLOOP_DATATYPE_BLOCK_LB_UB(ints[i+1],
disp,
lb, ub, extent,
tmp_lb, tmp_ub);
if (tmp_lb < min_lb) min_lb = tmp_lb;
if (tmp_ub > max_ub) max_ub = tmp_ub;
}
tfp->size = ntypes * size;
tfp->lb = min_lb;
tfp->ub = max_ub;
tfp->true_lb = min_lb + (true_lb - lb);
tfp->true_ub = max_ub + (true_ub - ub);
tfp->extent = tfp->ub - tfp->lb;
}
break;
case MPI_COMBINER_STRUCT_INTEGER:
DLOOP_Assert(combiner != MPI_COMBINER_STRUCT_INTEGER);
break;
case MPI_COMBINER_STRUCT:
/* sufficiently complicated to pull out into separate fn */
DLOOP_Type_calc_footprint_struct(type,
combiner, ints, aints, types,
tfp);
break;
case MPI_COMBINER_SUBARRAY:
ndims = ints[0];
MPIDU_Type_convert_subarray(ndims,
&ints[1] /* sizes */,
&ints[1+ndims] /* subsz */,
&ints[1+2*ndims] /* strts */,
ints[1+3*ndims] /* order */,
types[0],
&tmptype);
MPIDU_Type_calc_footprint(tmptype, tfp);
MPIR_Type_free_impl(&tmptype);
break;
case MPI_COMBINER_DARRAY:
ndims = ints[2];
MPIDU_Type_convert_darray(ints[0] /* size */,
ints[1] /* rank */,
ndims,
&ints[3] /* gsizes */,
&ints[3+ndims] /*distribs */,
&ints[3+2*ndims] /* dargs */,
&ints[3+3*ndims] /* psizes */,
ints[3+4*ndims] /* order */,
types[0],
&tmptype);
MPIDU_Type_calc_footprint(tmptype, tfp);
MPIR_Type_free_impl(&tmptype);
break;
case MPI_COMBINER_F90_REAL:
case MPI_COMBINER_F90_COMPLEX:
case MPI_COMBINER_F90_INTEGER:
default:
DLOOP_Assert(0);
break;
}
clean_exit:
MPIDU_Type_release_contents(type, &ints, &aints, &types);
return;
}
int MPIR_Allreduce_intra_reduce_scatter_allgather(
const void *sendbuf,
void *recvbuf,
int count,
MPI_Datatype datatype,
MPI_Op op,
MPIR_Comm * comm_ptr,
MPIR_Errflag_t * errflag)
{
MPIR_CHKLMEM_DECL(3);
#ifdef MPID_HAS_HETERO
int is_homogeneous;
int rc;
#endif
int comm_size, rank;
int mpi_errno = MPI_SUCCESS;
int mpi_errno_ret = MPI_SUCCESS;
int mask, dst, pof2, newrank, rem, newdst, i,
send_idx, recv_idx, last_idx, send_cnt, recv_cnt, *cnts, *disps;
MPI_Aint true_extent, true_lb, extent;
void *tmp_buf;
comm_size = comm_ptr->local_size;
rank = comm_ptr->rank;
/* need to allocate temporary buffer to store incoming data*/
MPIR_Type_get_true_extent_impl(datatype, &true_lb, &true_extent);
MPIR_Datatype_get_extent_macro(datatype, extent);
MPIR_Ensure_Aint_fits_in_pointer(count * MPL_MAX(extent, true_extent));
MPIR_CHKLMEM_MALLOC(tmp_buf, void *, count*(MPL_MAX(extent,true_extent)), mpi_errno, "temporary buffer", MPL_MEM_BUFFER);
/* adjust for potential negative lower bound in datatype */
tmp_buf = (void *)((char*)tmp_buf - true_lb);
/* copy local data into recvbuf */
if (sendbuf != MPI_IN_PLACE) {
mpi_errno = MPIR_Localcopy(sendbuf, count, datatype, recvbuf,
count, datatype);
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
}
/* get nearest power-of-two less than or equal to comm_size */
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 = MPIC_Send(recvbuf, count,
datatype, rank+1,
MPIR_ALLREDUCE_TAG, comm_ptr, 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);
}
/* temporarily set the rank to -1 so that this
process does not pariticipate in recursive
doubling */
newrank = -1;
}
else { /* odd */
mpi_errno = MPIC_Recv(tmp_buf, count,
datatype, rank-1,
MPIR_ALLREDUCE_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);
}
/* 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_Reduce_local(tmp_buf, recvbuf, count, datatype, op);
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
/* change the rank */
newrank = rank / 2;
}
}
else /* rank >= 2*rem */
newrank = rank - rem;
/* If op is user-defined or count is less than pof2, use
recursive doubling algorithm. Otherwise do a reduce-scatter
followed by allgather. (If op is user-defined,
derived datatypes are allowed and the user could pass basic
datatypes on one process and derived on another as long as
the type maps are the same. Breaking up derived
datatypes to do the reduce-scatter is tricky, therefore
using recursive doubling in that case.) */
#ifdef HAVE_ERROR_CHECKING
MPIR_Assert(HANDLE_GET_KIND(op)==HANDLE_KIND_BUILTIN);
MPIR_Assert(count >= pof2);
#endif /* HAVE_ERROR_CHECKING */
if (newrank != -1) {
MPIR_CHKLMEM_MALLOC(cnts, int *, pof2*sizeof(int), mpi_errno, "counts", MPL_MEM_BUFFER);
MPIR_CHKLMEM_MALLOC(disps, int *, pof2*sizeof(int), mpi_errno, "displacements", MPL_MEM_BUFFER);
for (i=0; i<pof2; i++)
cnts[i] = count/pof2;
if ((count % pof2) > 0) {
for (i=0; i<(count % pof2); i++)
cnts[i] += 1;
}
disps[0] = 0;
for (i=1; i<pof2; i++)
disps[i] = disps[i-1] + cnts[i-1];
mask = 0x1;
send_idx = recv_idx = 0;
last_idx = pof2;
while (mask < pof2) {
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 + pof2/(mask*2);
for (i=send_idx; i<last_idx; i++)
send_cnt += cnts[i];
for (i=recv_idx; i<send_idx; i++)
recv_cnt += cnts[i];
}
else {
recv_idx = send_idx + pof2/(mask*2);
for (i=send_idx; i<recv_idx; i++)
send_cnt += cnts[i];
for (i=recv_idx; i<last_idx; i++)
recv_cnt += cnts[i];
}
/* Send data from recvbuf. Recv into tmp_buf */
mpi_errno = MPIC_Sendrecv((char *) recvbuf +
disps[send_idx]*extent,
send_cnt, datatype,
dst, MPIR_ALLREDUCE_TAG,
(char *) tmp_buf +
disps[recv_idx]*extent,
recv_cnt, datatype, dst,
MPIR_ALLREDUCE_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);
}
/* tmp_buf contains data received in this step.
recvbuf contains data accumulated so far */
/* This algorithm is used only for predefined ops
and predefined ops are always commutative. */
mpi_errno = MPIR_Reduce_local(((char *) tmp_buf + disps[recv_idx]*extent),
((char *) recvbuf + disps[recv_idx]*extent),
recv_cnt, datatype, op);
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
/* update send_idx for next iteration */
send_idx = recv_idx;
mask <<= 1;
/* update last_idx, but not in last iteration
because the value is needed in the allgather
step below. */
if (mask < pof2)
last_idx = recv_idx + pof2/mask;
}
/* now do the allgather */
mask >>= 1;
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) {
/* update last_idx except on first iteration */
if (mask != pof2/2)
last_idx = last_idx + pof2/(mask*2);
recv_idx = send_idx + pof2/(mask*2);
for (i=send_idx; i<recv_idx; i++)
send_cnt += cnts[i];
for (i=recv_idx; i<last_idx; i++)
recv_cnt += cnts[i];
}
else {
recv_idx = send_idx - pof2/(mask*2);
for (i=send_idx; i<last_idx; i++)
send_cnt += cnts[i];
for (i=recv_idx; i<send_idx; i++)
recv_cnt += cnts[i];
}
mpi_errno = MPIC_Sendrecv((char *) recvbuf +
disps[send_idx]*extent,
send_cnt, datatype,
dst, MPIR_ALLREDUCE_TAG,
(char *) recvbuf +
disps[recv_idx]*extent,
recv_cnt, datatype, dst,
MPIR_ALLREDUCE_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);
}
if (newrank > newdst) send_idx = recv_idx;
mask >>= 1;
}
}
int MPIR_Allgather_intra_brucks (
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, rank;
int mpi_errno = MPI_SUCCESS;
int mpi_errno_ret = MPI_SUCCESS;
MPI_Aint recvtype_extent;
MPI_Aint recvtype_true_extent, recvbuf_extent, recvtype_true_lb;
int pof2, src, rem;
void *tmp_buf = NULL;
int curr_cnt, dst;
MPIR_CHKLMEM_DECL(1);
if (((sendcount == 0) && (sendbuf != MPI_IN_PLACE)) || (recvcount == 0))
return MPI_SUCCESS;
comm_size = comm_ptr->local_size;
rank = comm_ptr->rank;
MPIR_Datatype_get_extent_macro( recvtype, recvtype_extent );
/* This is the largest offset we add to recvbuf */
MPIR_Ensure_Aint_fits_in_pointer(MPIR_VOID_PTR_CAST_TO_MPI_AINT recvbuf +
(comm_size * recvcount * recvtype_extent));
/* allocate 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", MPL_MEM_BUFFER);
/* adjust for potential negative lower bound in datatype */
tmp_buf = (void *)((char*)tmp_buf - recvtype_true_lb);
/* copy local data to the top of tmp_buf */
if (sendbuf != MPI_IN_PLACE) {
mpi_errno = MPIR_Localcopy (sendbuf, sendcount, sendtype,
tmp_buf, recvcount, recvtype);
if (mpi_errno) {
MPIR_ERR_POP(mpi_errno);
}
}
else {
mpi_errno = MPIR_Localcopy (((char *)recvbuf +
rank * recvcount * recvtype_extent),
recvcount, recvtype, tmp_buf,
recvcount, recvtype);
if (mpi_errno) {
MPIR_ERR_POP(mpi_errno);
}
}
/* do the first \floor(\lg p) steps */
curr_cnt = recvcount;
pof2 = 1;
while (pof2 <= comm_size/2) {
src = (rank + pof2) % comm_size;
dst = (rank - pof2 + comm_size) % comm_size;
mpi_errno = MPIC_Sendrecv(tmp_buf, curr_cnt, recvtype, dst,
MPIR_ALLGATHER_TAG,
((char *)tmp_buf + curr_cnt*recvtype_extent),
curr_cnt, recvtype,
src, MPIR_ALLGATHER_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);
}
curr_cnt *= 2;
pof2 *= 2;
}
/* if comm_size is not a power of two, one more step is needed */
rem = comm_size - pof2;
if (rem) {
src = (rank + pof2) % comm_size;
dst = (rank - pof2 + comm_size) % comm_size;
mpi_errno = MPIC_Sendrecv(tmp_buf, rem * recvcount, recvtype,
dst, MPIR_ALLGATHER_TAG,
((char *)tmp_buf + curr_cnt*recvtype_extent),
rem * recvcount, recvtype,
src, MPIR_ALLGATHER_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);
}
}
/* Rotate blocks in tmp_buf down by (rank) blocks and store
* result in recvbuf. */
mpi_errno = MPIR_Localcopy(tmp_buf, (comm_size-rank)*recvcount,
recvtype, (char *) recvbuf + rank*recvcount*recvtype_extent,
(comm_size-rank)*recvcount, recvtype);
if (mpi_errno) {
MPIR_ERR_POP(mpi_errno);
}
if (rank) {
mpi_errno = MPIR_Localcopy((char *) tmp_buf +
(comm_size-rank)*recvcount*recvtype_extent,
rank*recvcount, recvtype, recvbuf,
rank*recvcount, recvtype);
if (mpi_errno) {
MPIR_ERR_POP(mpi_errno);
}
}
fn_exit:
MPIR_CHKLMEM_FREEALL();
if (mpi_errno_ret)
mpi_errno = mpi_errno_ret;
else if (*errflag != MPIR_ERR_NONE)
MPIR_ERR_SET(mpi_errno, *errflag, "**coll_fail");
return mpi_errno;
fn_fail:
goto fn_exit;
}
int MPIR_Alltoall_intra_scattered(
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;
MPI_Aint sendtype_extent, recvtype_extent;
int mpi_errno=MPI_SUCCESS, dst, rank;
int mpi_errno_ret = MPI_SUCCESS;
MPI_Datatype newtype = MPI_DATATYPE_NULL;
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;
#ifdef HAVE_ERROR_CHECKING
MPIR_Assert(sendbuf != MPI_IN_PLACE);
#endif /* HAVE_ERROR_CHECKING */
/* Get extent of send and recv types */
MPIR_Datatype_get_extent_macro(recvtype, recvtype_extent);
MPIR_Datatype_get_extent_macro(sendtype, sendtype_extent);
int ii, ss, bblock;
bblock = MPIR_CVAR_ALLTOALL_THROTTLE;
if (bblock == 0) bblock = comm_size;
MPIR_CHKLMEM_MALLOC(reqarray, MPIR_Request **, 2*bblock*sizeof(MPIR_Request*), mpi_errno, "reqarray", MPL_MEM_BUFFER);
MPIR_CHKLMEM_MALLOC(starray, MPI_Status *, 2*bblock*sizeof(MPI_Status), mpi_errno, "starray", MPL_MEM_BUFFER);
for (ii=0; ii<comm_size; ii+=bblock) {
ss = comm_size-ii < bblock ? comm_size-ii : bblock;
/* do the communication -- post ss sends and receives: */
for ( i=0; i<ss; i++ ) {
dst = (rank+i+ii) % comm_size;
mpi_errno = MPIC_Irecv((char *)recvbuf +
dst*recvcount*recvtype_extent,
recvcount, recvtype, dst,
MPIR_ALLTOALL_TAG, comm_ptr,
&reqarray[i]);
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
}
for ( i=0; i<ss; i++ ) {
dst = (rank-i-ii+comm_size) % comm_size;
mpi_errno = MPIC_Isend((char *)sendbuf +
dst*sendcount*sendtype_extent,
sendcount, sendtype, dst,
MPIR_ALLTOALL_TAG, comm_ptr,
&reqarray[i+ss], errflag);
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
}
/* ... then wait for them to finish: */
mpi_errno = MPIC_Waitall(2*ss,reqarray,starray, errflag);
if (mpi_errno && mpi_errno != MPI_ERR_IN_STATUS) MPIR_ERR_POP(mpi_errno);
/* --BEGIN ERROR HANDLING-- */
if (mpi_errno == MPI_ERR_IN_STATUS) {
for (j=0; j<2*ss; j++) {
if (starray[j].MPI_ERROR != MPI_SUCCESS) {
mpi_errno = starray[j].MPI_ERROR;
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);
}
}
}
}
/* --END ERROR HANDLING-- */
}
fn_exit:
MPIR_CHKLMEM_FREEALL();
if (mpi_errno_ret)
mpi_errno = mpi_errno_ret;
else if (*errflag != MPIR_ERR_NONE)
MPIR_ERR_SET(mpi_errno, *errflag, "**coll_fail");
return mpi_errno;
fn_fail:
if (newtype != MPI_DATATYPE_NULL)
MPIR_Type_free_impl(&newtype);
goto fn_exit;
}
int MPIR_Iallgatherv_sched_intra_recursive_doubling(const void *sendbuf, int sendcount,
MPI_Datatype sendtype, void *recvbuf,
const int recvcounts[], const int displs[],
MPI_Datatype recvtype, MPIR_Comm * comm_ptr,
MPIR_Sched_t s)
{
int mpi_errno = MPI_SUCCESS;
int comm_size, rank, i, j, k;
int curr_count, send_offset, incoming_count, recv_offset;
int mask, dst, total_count, position, offset, my_tree_root, dst_tree_root;
MPI_Aint recvtype_extent, recvtype_sz;
void *tmp_buf = NULL;
MPIR_SCHED_CHKPMEM_DECL(1);
comm_size = comm_ptr->local_size;
rank = comm_ptr->rank;
#ifdef HAVE_ERROR_CHECKING
/* Currently this algorithm can only handle power-of-2 comm_size.
* Non power-of-2 comm_size is still experimental */
MPIR_Assert(!(comm_size & (comm_size - 1)));
#endif /* HAVE_ERROR_CHECKING */
/* need to receive contiguously into tmp_buf because
* displs could make the recvbuf noncontiguous */
MPIR_Datatype_get_size_macro(recvtype, recvtype_sz);
MPIR_Datatype_get_extent_macro(recvtype, recvtype_extent);
total_count = 0;
for (i = 0; i < comm_size; i++)
total_count += recvcounts[i];
if (total_count == 0)
goto fn_exit;
MPIR_SCHED_CHKPMEM_MALLOC(tmp_buf, void *, total_count * recvtype_sz,
mpi_errno, "tmp_buf", MPL_MEM_BUFFER);
/* copy local data into right location in tmp_buf */
position = 0;
for (i = 0; i < rank; i++)
position += recvcounts[i];
if (sendbuf != MPI_IN_PLACE) {
mpi_errno = MPIR_Sched_copy(sendbuf, sendcount, sendtype,
((char *) tmp_buf + position * recvtype_sz),
recvcounts[rank] * recvtype_sz, MPI_BYTE, s);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
} else {
/* if in_place specified, local data is found in recvbuf */
mpi_errno = MPIR_Sched_copy(((char *) recvbuf + displs[rank] * recvtype_extent),
recvcounts[rank], recvtype,
((char *) tmp_buf + position * recvtype_sz),
recvcounts[rank] * recvtype_sz, MPI_BYTE, s);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
}
curr_count = recvcounts[rank];
/* never used uninitialized w/o this, but compiler can't tell that */
incoming_count = -1;
/* [goodell@] random notes that help slightly when deciphering this code:
* - mask is also equal to the number of blocks that we are going to recv
* (less if comm_size is non-pof2)
* - FOO_tree_root is the leftmost (lowest ranked) process with whom FOO has
* communicated, directly or indirectly, at the beginning of round the
* round. FOO is either "dst" or "my", where "my" means use my rank.
* - in each round we are going to recv the blocks
* B[dst_tree_root],B[dst_tree_root+1],...,B[min(dst_tree_root+mask,comm_size)]
*/
mask = 0x1;
i = 0;
while (mask < comm_size) {
dst = rank ^ mask;
/* find offset into send and recv buffers. zero out
* the least significant "i" bits of rank and dst to
* find root of src and dst subtrees. Use ranks of
* roots as index to send from and recv into buffer */
dst_tree_root = dst >> i;
dst_tree_root <<= i;
my_tree_root = rank >> i;
my_tree_root <<= i;
if (dst < comm_size) {
send_offset = 0;
for (j = 0; j < my_tree_root; j++)
send_offset += recvcounts[j];
recv_offset = 0;
for (j = 0; j < dst_tree_root; j++)
recv_offset += recvcounts[j];
incoming_count = 0;
for (j = dst_tree_root; j < (dst_tree_root + mask) && j < comm_size; ++j)
incoming_count += recvcounts[j];
mpi_errno = MPIR_Sched_send(((char *) tmp_buf + send_offset * recvtype_sz),
curr_count * recvtype_sz, MPI_BYTE, dst, comm_ptr, s);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
/* sendrecv, no barrier here */
mpi_errno = MPIR_Sched_recv(((char *) tmp_buf + recv_offset * recvtype_sz),
incoming_count * recvtype_sz, MPI_BYTE, dst, comm_ptr, s);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
MPIR_SCHED_BARRIER(s);
curr_count += incoming_count;
}
/* 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
* data that they would normally have received from those
* processes. That is, the haves in this subtree must send to
* the havenots. We use a logarithmic
* recursive-halfing algorithm for this. */
/* This part of the code will not currently be
* executed because we are not using recursive
* doubling for non power of two. Mark it as experimental
* so that it doesn't show up as red in the coverage
* tests. */
/* --BEGIN EXPERIMENTAL-- */
if (dst_tree_root + mask > comm_size) {
int tmp_mask, tree_root;
int 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 */
/* [goodell@] it looks like (k==i) is always true, could possibly
* skip the loop below */
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)) {
offset = 0;
for (j = 0; j < (my_tree_root + mask); j++)
offset += recvcounts[j];
offset *= recvtype_sz;
/* incoming_count was set in the previous
* receive. that's the amount of data to be
* sent now. */
mpi_errno = MPIR_Sched_send(((char *) tmp_buf + offset),
incoming_count * recvtype_sz, MPI_BYTE,
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)) {
offset = 0;
for (j = 0; j < (my_tree_root + mask); j++)
offset += recvcounts[j];
/* recalculate incoming_count, since not all processes will have
* this value */
incoming_count = 0;
for (j = dst_tree_root; j < (dst_tree_root + mask) && j < comm_size; ++j)
incoming_count += recvcounts[j];
mpi_errno = MPIR_Sched_recv(((char *) tmp_buf + offset * recvtype_sz),
incoming_count * recvtype_sz, MPI_BYTE,
dst, comm_ptr, s);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
MPIR_SCHED_BARRIER(s);
curr_count += incoming_count;
}
tmp_mask >>= 1;
k--;
}
}
/* --END EXPERIMENTAL-- */
mask <<= 1;
i++;
}
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++;
}
/*@
MPI_Type_create_darray - Create a datatype representing a distributed array
Input Parameters:
+ size - size of process group (positive integer)
. rank - rank in process group (nonnegative integer)
. ndims - number of array dimensions as well as process grid dimensions (positive integer)
. array_of_gsizes - number of elements of type oldtype in each dimension of global array (array of positive integers)
. array_of_distribs - distribution of array in each dimension (array of state)
. array_of_dargs - distribution argument in each dimension (array of positive integers)
. array_of_psizes - size of process grid in each dimension (array of positive integers)
. order - array storage order flag (state)
- oldtype - old datatype (handle)
Output Parameters:
. newtype - new datatype (handle)
.N ThreadSafe
.N Fortran
.N Errors
.N MPI_SUCCESS
.N MPI_ERR_TYPE
.N MPI_ERR_ARG
@*/
int MPI_Type_create_darray(int size,
int rank,
int ndims,
const int array_of_gsizes[],
const int array_of_distribs[],
const int array_of_dargs[],
const int array_of_psizes[],
int order, MPI_Datatype oldtype, MPI_Datatype * newtype)
{
int mpi_errno = MPI_SUCCESS, i;
MPI_Datatype new_handle;
int procs, tmp_rank, tmp_size, *coords;
MPI_Aint *st_offsets, orig_extent, disps[3];
MPI_Datatype type_old, type_new = MPI_DATATYPE_NULL, tmp_type;
#ifdef HAVE_ERROR_CHECKING
MPI_Aint size_with_aint;
MPI_Offset size_with_offset;
#endif
int *ints;
MPIR_Datatype *datatype_ptr = NULL;
MPIR_CHKLMEM_DECL(3);
MPIR_FUNC_TERSE_STATE_DECL(MPID_STATE_MPI_TYPE_CREATE_DARRAY);
MPIR_ERRTEST_INITIALIZED_ORDIE();
MPID_THREAD_CS_ENTER(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX);
MPIR_FUNC_TERSE_ENTER(MPID_STATE_MPI_TYPE_CREATE_DARRAY);
/* Validate parameters, especially handles needing to be converted */
#ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
MPIR_ERRTEST_DATATYPE(oldtype, "datatype", mpi_errno);
}
MPID_END_ERROR_CHECKS;
}
#endif
/* Convert MPI object handles to object pointers */
MPIR_Datatype_get_ptr(oldtype, datatype_ptr);
MPIR_Datatype_get_extent_macro(oldtype, orig_extent);
/* Validate parameters and objects (post conversion) */
#ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
/* Check parameters */
MPIR_ERRTEST_ARGNONPOS(size, "size", mpi_errno, MPI_ERR_ARG);
/* use MPI_ERR_RANK class for PE-MPI compatibility */
MPIR_ERR_CHKANDJUMP3((rank < 0 || rank >= size), mpi_errno, MPI_ERR_RANK,
"**argrange", "**argrange %s %d %d", "rank", rank, (size - 1));
MPIR_ERRTEST_ARGNONPOS(ndims, "ndims", mpi_errno, MPI_ERR_DIMS);
MPIR_ERRTEST_ARGNULL(array_of_gsizes, "array_of_gsizes", mpi_errno);
MPIR_ERRTEST_ARGNULL(array_of_distribs, "array_of_distribs", mpi_errno);
MPIR_ERRTEST_ARGNULL(array_of_dargs, "array_of_dargs", mpi_errno);
MPIR_ERRTEST_ARGNULL(array_of_psizes, "array_of_psizes", mpi_errno);
if (order != MPI_ORDER_C && order != MPI_ORDER_FORTRAN) {
mpi_errno = MPIR_Err_create_code(MPI_SUCCESS,
MPIR_ERR_RECOVERABLE,
__func__,
__LINE__,
MPI_ERR_ARG, "**arg", "**arg %s", "order");
goto fn_fail;
}
tmp_size = 1;
for (i = 0; mpi_errno == MPI_SUCCESS && i < ndims; i++) {
MPIR_ERRTEST_ARGNONPOS(array_of_gsizes[i], "gsize", mpi_errno, MPI_ERR_ARG);
MPIR_ERRTEST_ARGNONPOS(array_of_psizes[i], "psize", mpi_errno, MPI_ERR_ARG);
if ((array_of_distribs[i] != MPI_DISTRIBUTE_NONE) &&
(array_of_distribs[i] != MPI_DISTRIBUTE_BLOCK) &&
(array_of_distribs[i] != MPI_DISTRIBUTE_CYCLIC)) {
mpi_errno = MPIR_Err_create_code(MPI_SUCCESS,
MPIR_ERR_RECOVERABLE,
__func__,
__LINE__, MPI_ERR_ARG, "**darrayunknown", 0);
goto fn_fail;
}
if ((array_of_dargs[i] != MPI_DISTRIBUTE_DFLT_DARG) && (array_of_dargs[i] <= 0)) {
mpi_errno = MPIR_Err_create_code(MPI_SUCCESS,
MPIR_ERR_RECOVERABLE,
__func__,
__LINE__,
MPI_ERR_ARG,
"**arg", "**arg %s", "array_of_dargs");
goto fn_fail;
}
if ((array_of_distribs[i] == MPI_DISTRIBUTE_NONE) && (array_of_psizes[i] != 1)) {
mpi_errno = MPIR_Err_create_code(MPI_SUCCESS,
MPIR_ERR_RECOVERABLE,
__func__,
__LINE__,
MPI_ERR_ARG,
"**darraydist",
"**darraydist %d %d", i, array_of_psizes[i]);
goto fn_fail;
}
tmp_size *= array_of_psizes[i];
}
MPIR_ERR_CHKANDJUMP1((tmp_size != size), mpi_errno, MPI_ERR_ARG,
"**arg", "**arg %s", "array_of_psizes");
/* TODO: GET THIS CHECK IN ALSO */
/* check if MPI_Aint is large enough for size of global array.
* if not, complain. */
size_with_aint = orig_extent;
for (i = 0; i < ndims; i++)
size_with_aint *= array_of_gsizes[i];
size_with_offset = orig_extent;
for (i = 0; i < ndims; i++)
size_with_offset *= array_of_gsizes[i];
if (size_with_aint != size_with_offset) {
mpi_errno = MPIR_Err_create_code(MPI_SUCCESS,
MPIR_ERR_FATAL,
__func__,
__LINE__,
MPI_ERR_ARG,
"**darrayoverflow",
"**darrayoverflow %L", size_with_offset);
goto fn_fail;
}
/* Validate datatype_ptr */
MPIR_Datatype_valid_ptr(datatype_ptr, mpi_errno);
/* If datatype_ptr is not valid, it will be reset to null */
/* --BEGIN ERROR HANDLING-- */
if (mpi_errno)
goto fn_fail;
/* --END ERROR HANDLING-- */
}
MPID_END_ERROR_CHECKS;
}
#endif /* HAVE_ERROR_CHECKING */
/* ... body of routine ... */
/* calculate position in Cartesian grid as MPI would (row-major
ordering) */
MPIR_CHKLMEM_MALLOC_ORJUMP(coords, int *, ndims * sizeof(int), mpi_errno,
"position is Cartesian grid", MPL_MEM_COMM);
procs = size;
tmp_rank = rank;
for (i = 0; i < ndims; i++) {
procs = procs / array_of_psizes[i];
coords[i] = tmp_rank / procs;
tmp_rank = tmp_rank % procs;
}
MPIR_CHKLMEM_MALLOC_ORJUMP(st_offsets, MPI_Aint *, ndims * sizeof(MPI_Aint), mpi_errno,
"st_offsets", MPL_MEM_COMM);
type_old = oldtype;
if (order == MPI_ORDER_FORTRAN) {
/* dimension 0 changes fastest */
for (i = 0; i < ndims; i++) {
switch (array_of_distribs[i]) {
case MPI_DISTRIBUTE_BLOCK:
mpi_errno = MPIR_Type_block(array_of_gsizes,
i,
ndims,
array_of_psizes[i],
coords[i],
array_of_dargs[i],
order,
orig_extent, type_old, &type_new, st_offsets + i);
break;
case MPI_DISTRIBUTE_CYCLIC:
mpi_errno = MPIR_Type_cyclic(array_of_gsizes,
i,
ndims,
array_of_psizes[i],
coords[i],
array_of_dargs[i],
order,
orig_extent, type_old, &type_new, st_offsets + i);
break;
case MPI_DISTRIBUTE_NONE:
/* treat it as a block distribution on 1 process */
mpi_errno = MPIR_Type_block(array_of_gsizes,
i,
ndims,
1,
0,
MPI_DISTRIBUTE_DFLT_DARG,
order,
orig_extent, type_old, &type_new, st_offsets + i);
break;
}
if (i) {
MPIR_Type_free_impl(&type_old);
}
type_old = type_new;
/* --BEGIN ERROR HANDLING-- */
if (mpi_errno != MPI_SUCCESS)
goto fn_fail;
/* --END ERROR HANDLING-- */
}
/* add displacement and UB */
disps[1] = st_offsets[0];
tmp_size = 1;
for (i = 1; i < ndims; i++) {
tmp_size *= array_of_gsizes[i - 1];
disps[1] += (MPI_Aint) tmp_size *st_offsets[i];
}
/* rest done below for both Fortran and C order */
}
else { /* order == MPI_ORDER_C */
/* dimension ndims-1 changes fastest */
for (i = ndims - 1; i >= 0; i--) {
switch (array_of_distribs[i]) {
case MPI_DISTRIBUTE_BLOCK:
mpi_errno = MPIR_Type_block(array_of_gsizes,
i,
ndims,
array_of_psizes[i],
coords[i],
array_of_dargs[i],
order,
orig_extent, type_old, &type_new, st_offsets + i);
break;
case MPI_DISTRIBUTE_CYCLIC:
mpi_errno = MPIR_Type_cyclic(array_of_gsizes,
i,
ndims,
array_of_psizes[i],
coords[i],
array_of_dargs[i],
order,
orig_extent, type_old, &type_new, st_offsets + i);
break;
case MPI_DISTRIBUTE_NONE:
/* treat it as a block distribution on 1 process */
mpi_errno = MPIR_Type_block(array_of_gsizes,
i,
ndims,
array_of_psizes[i],
coords[i],
MPI_DISTRIBUTE_DFLT_DARG,
order,
orig_extent, type_old, &type_new, st_offsets + i);
break;
}
if (i != ndims - 1) {
MPIR_Type_free_impl(&type_old);
}
type_old = type_new;
/* --BEGIN ERROR HANDLING-- */
if (mpi_errno != MPI_SUCCESS)
goto fn_fail;
/* --END ERROR HANDLING-- */
}
/* add displacement and UB */
disps[1] = st_offsets[ndims - 1];
tmp_size = 1;
for (i = ndims - 2; i >= 0; i--) {
tmp_size *= array_of_gsizes[i + 1];
disps[1] += (MPI_Aint) tmp_size *st_offsets[i];
}
}
disps[1] *= orig_extent;
disps[2] = orig_extent;
for (i = 0; i < ndims; i++)
disps[2] *= (MPI_Aint) (array_of_gsizes[i]);
disps[0] = 0;
/* Instead of using MPI_LB/MPI_UB, which have been removed from MPI in MPI-3,
use MPI_Type_create_resized. Use hindexed_block to set the starting displacement
of the datatype (disps[1]) and type_create_resized to set lb to 0 (disps[0])
and extent to disps[2], which makes ub = disps[2].
*/
mpi_errno = MPIR_Type_blockindexed(1, 1, &disps[1], 1, /* 1 means disp is in bytes */
type_new, &tmp_type);
/* --BEGIN ERROR HANDLING-- */
if (mpi_errno != MPI_SUCCESS)
goto fn_fail;
/* --END ERROR HANDLING-- */
mpi_errno = MPIR_Type_create_resized(tmp_type, 0, disps[2], &new_handle);
/* --BEGIN ERROR HANDLING-- */
if (mpi_errno != MPI_SUCCESS)
goto fn_fail;
/* --END ERROR HANDLING-- */
MPIR_Type_free_impl(&tmp_type);
MPIR_Type_free_impl(&type_new);
/* at this point we have the new type, and we've cleaned up any
* intermediate types created in the process. we just need to save
* all our contents/envelope information.
*/
/* Save contents */
MPIR_CHKLMEM_MALLOC_ORJUMP(ints, int *, (4 * ndims + 4) * sizeof(int), mpi_errno,
"content description", MPL_MEM_BUFFER);
ints[0] = size;
ints[1] = rank;
ints[2] = ndims;
for (i = 0; i < ndims; i++) {
ints[i + 3] = array_of_gsizes[i];
}
for (i = 0; i < ndims; i++) {
ints[i + ndims + 3] = array_of_distribs[i];
}
for (i = 0; i < ndims; i++) {
ints[i + 2 * ndims + 3] = array_of_dargs[i];
}
for (i = 0; i < ndims; i++) {
ints[i + 3 * ndims + 3] = array_of_psizes[i];
}
ints[4 * ndims + 3] = order;
MPIR_Datatype_get_ptr(new_handle, datatype_ptr);
mpi_errno = MPIR_Datatype_set_contents(datatype_ptr,
MPI_COMBINER_DARRAY,
4 * ndims + 4, 0, 1, ints, NULL, &oldtype);
/* --BEGIN ERROR HANDLING-- */
if (mpi_errno != MPI_SUCCESS)
goto fn_fail;
/* --END ERROR HANDLING-- */
MPIR_OBJ_PUBLISH_HANDLE(*newtype, new_handle);
/* ... end of body of routine ... */
fn_exit:
MPIR_CHKLMEM_FREEALL();
MPIR_FUNC_TERSE_EXIT(MPID_STATE_MPI_TYPE_CREATE_DARRAY);
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_type_create_darray",
"**mpi_type_create_darray %d %d %d %p %p %p %p %d %D %p", size,
rank, ndims, array_of_gsizes, array_of_distribs, array_of_dargs,
array_of_psizes, order, oldtype, newtype);
}
#endif
mpi_errno = MPIR_Err_return_comm(NULL, __func__, mpi_errno);
goto fn_exit;
/* --END ERROR HANDLING-- */
}
int MPIR_Iscatterv_sched_allcomm_linear(const void *sendbuf, const int sendcounts[],
const int displs[], MPI_Datatype sendtype, void *recvbuf,
int recvcount, MPI_Datatype recvtype, int root,
MPIR_Comm * comm_ptr, MPIR_Sched_t s)
{
int mpi_errno = MPI_SUCCESS;
int rank, comm_size;
MPI_Aint extent;
int i;
rank = comm_ptr->rank;
/* If I'm the root, then scatter */
if (((comm_ptr->comm_kind == MPIR_COMM_KIND__INTRACOMM) && (root == rank)) ||
((comm_ptr->comm_kind == MPIR_COMM_KIND__INTERCOMM) && (root == MPI_ROOT))) {
if (comm_ptr->comm_kind == MPIR_COMM_KIND__INTRACOMM)
comm_size = comm_ptr->local_size;
else
comm_size = comm_ptr->remote_size;
MPIR_Datatype_get_extent_macro(sendtype, extent);
/* We need a check to ensure extent will fit in a
* pointer. That needs extent * (max count) but we can't get
* that without looping over the input data. This is at least
* a minimal sanity check. Maybe add a global var since we do
* loop over sendcount[] in MPI_Scatterv before calling
* this? */
MPIR_Ensure_Aint_fits_in_pointer(MPIR_VOID_PTR_CAST_TO_MPI_AINT sendbuf + extent);
for (i = 0; i < comm_size; i++) {
if (sendcounts[i]) {
if ((comm_ptr->comm_kind == MPIR_COMM_KIND__INTRACOMM) && (i == rank)) {
if (recvbuf != MPI_IN_PLACE) {
mpi_errno = MPIR_Sched_copy(((char *) sendbuf + displs[rank] * extent),
sendcounts[rank], sendtype,
recvbuf, recvcount, recvtype, s);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
}
} else {
mpi_errno = MPIR_Sched_send(((char *) sendbuf + displs[i] * extent),
sendcounts[i], sendtype, i, comm_ptr, s);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
}
}
}
}
else if (root != MPI_PROC_NULL) {
/* non-root nodes, and in the intercomm. case, non-root nodes on remote side */
if (recvcount) {
mpi_errno = MPIR_Sched_recv(recvbuf, recvcount, recvtype, root, comm_ptr, s);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
}
}
fn_exit:
return mpi_errno;
fn_fail:
goto fn_exit;
}
/*
* Recursive Doubling Algorithm:
*
* Restrictions: power-of-two no. of processes
*
* Cost = lgp.alpha + n.((p-1)/p).beta
*
* TODO: On TCP, we may want to use recursive doubling instead of the
* Bruck's algorithm in all cases because of the pairwise-exchange
* property of recursive doubling (see Benson et al paper in Euro
* PVM/MPI 2003).
*/
int MPIR_Allgather_intra_recursive_doubling(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, rank;
int mpi_errno = MPI_SUCCESS;
int mpi_errno_ret = MPI_SUCCESS;
MPI_Aint recvtype_extent;
int j, i;
MPI_Aint curr_cnt, last_recv_cnt = 0;
int dst;
MPI_Status status;
int mask, dst_tree_root, my_tree_root,
send_offset, recv_offset, nprocs_completed, k, offset, tmp_mask, tree_root;
if (((sendcount == 0) && (sendbuf != MPI_IN_PLACE)) || (recvcount == 0))
return MPI_SUCCESS;
comm_size = comm_ptr->local_size;
rank = comm_ptr->rank;
#ifdef HAVE_ERROR_CHECKING
/* Currently this algorithm can only handle power-of-2 comm_size.
* Non power-of-2 comm_size is still experimental */
MPIR_Assert(!(comm_size & (comm_size - 1)));
#endif /* HAVE_ERROR_CHECKING */
MPIR_Datatype_get_extent_macro(recvtype, recvtype_extent);
if (sendbuf != MPI_IN_PLACE) {
mpi_errno = MPIR_Localcopy(sendbuf, sendcount, sendtype,
((char *) recvbuf +
rank * recvcount * recvtype_extent), recvcount, recvtype);
if (mpi_errno) {
MPIR_ERR_POP(mpi_errno);
}
}
curr_cnt = recvcount;
mask = 0x1;
i = 0;
while (mask < comm_size) {
dst = rank ^ mask;
/* find offset into send and recv buffers. zero out
* the least significant "i" bits of rank and dst to
* find root of src and dst subtrees. Use ranks of
* roots as index to send from and recv into buffer */
dst_tree_root = dst >> i;
dst_tree_root <<= i;
my_tree_root = rank >> i;
my_tree_root <<= i;
/* FIXME: saving an MPI_Aint into an int */
send_offset = my_tree_root * recvcount * recvtype_extent;
recv_offset = dst_tree_root * recvcount * recvtype_extent;
if (dst < comm_size) {
mpi_errno = MPIC_Sendrecv(((char *) recvbuf + send_offset),
curr_cnt, recvtype, dst,
MPIR_ALLGATHER_TAG,
((char *) recvbuf + recv_offset),
(comm_size - dst_tree_root) * recvcount,
recvtype, dst,
MPIR_ALLGATHER_TAG, comm_ptr, &status, errflag);
if (mpi_errno) {
/* for communication errors, just record the error but continue */
*errflag =
MPIX_ERR_PROC_FAILED ==
MPIR_ERR_GET_CLASS(mpi_errno) ? MPIR_ERR_PROC_FAILED : MPIR_ERR_OTHER;
MPIR_ERR_SET(mpi_errno, *errflag, "**fail");
MPIR_ERR_ADD(mpi_errno_ret, mpi_errno);
last_recv_cnt = 0;
} else {
MPIR_Get_count_impl(&status, recvtype, &last_recv_cnt);
}
curr_cnt += last_recv_cnt;
}
/* 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
* data that they would normally have received from those
* processes. That is, the haves in this subtree must send to
* the havenots. We use a logarithmic recursive-halfing algorithm
* for this. */
/* This part of the code will not currently be
* executed because we are not using recursive
* doubling for non power of two. Mark it as experimental
* so that it doesn't show up as red in the coverage
* tests. */
/* --BEGIN EXPERIMENTAL-- */
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--;
/* FIXME: saving an MPI_Aint into an int */
offset = recvcount * (my_tree_root + mask) * recvtype_extent;
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)) {
mpi_errno = MPIC_Send(((char *) recvbuf + offset),
last_recv_cnt,
recvtype, dst, MPIR_ALLGATHER_TAG, comm_ptr, errflag);
/* last_recv_cnt was set in the previous
* receive. that's the amount of data to be
* sent now. */
if (mpi_errno) {
/* for communication errors, just record the error but continue */
*errflag =
MPIX_ERR_PROC_FAILED ==
MPIR_ERR_GET_CLASS(mpi_errno) ? MPIR_ERR_PROC_FAILED : MPIR_ERR_OTHER;
MPIR_ERR_SET(mpi_errno, *errflag, "**fail");
MPIR_ERR_ADD(mpi_errno_ret, mpi_errno);
}
}
/* 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 = MPIC_Recv(((char *) recvbuf + offset),
(comm_size - (my_tree_root + mask)) * recvcount,
recvtype, dst,
MPIR_ALLGATHER_TAG, comm_ptr, &status, errflag);
/* nprocs_completed is also equal to the
* no. of processes whose data we don't have */
if (mpi_errno) {
/* for communication errors, just record the error but continue */
*errflag =
MPIX_ERR_PROC_FAILED ==
MPIR_ERR_GET_CLASS(mpi_errno) ? MPIR_ERR_PROC_FAILED : MPIR_ERR_OTHER;
MPIR_ERR_SET(mpi_errno, *errflag, "**fail");
MPIR_ERR_ADD(mpi_errno_ret, mpi_errno);
last_recv_cnt = 0;
} else {
MPIR_Get_count_impl(&status, recvtype, &last_recv_cnt);
}
curr_cnt += last_recv_cnt;
}
tmp_mask >>= 1;
k--;
}
}
/* --END EXPERIMENTAL-- */
mask <<= 1;
i++;
}
/*@
Dataloop_create_blockindexed - create blockindexed dataloop
Arguments:
+ MPI_Aint count
. void *displacement_array (array of either MPI_Aints or ints)
. int displacement_in_bytes (boolean)
. MPI_Datatype old_type
. MPIR_Dataloop **output_dataloop_ptr
. int output_dataloop_size
.N Errors
.N Returns 0 on success, -1 on failure.
@*/
int MPII_Dataloop_create_blockindexed(MPI_Aint icount,
MPI_Aint iblklen,
const void *disp_array,
int dispinbytes,
MPI_Datatype oldtype,
MPIR_Dataloop ** dlp_p, MPI_Aint * dlsz_p)
{
int err, is_builtin, is_vectorizable = 1;
int i;
MPI_Aint new_loop_sz;
MPI_Aint contig_count, count, blklen;
MPI_Aint old_extent, eff_disp0, eff_disp1, last_stride;
MPIR_Dataloop *new_dlp;
count = (MPI_Aint) icount; /* avoid subsequent casting */
blklen = (MPI_Aint) iblklen;
/* if count or blklen are zero, handle with contig code, call it a int */
if (count == 0 || blklen == 0) {
err = MPII_Dataloop_create_contiguous(0, MPI_INT, dlp_p, dlsz_p);
return err;
}
is_builtin = (MPII_DATALOOP_HANDLE_HASLOOP(oldtype)) ? 0 : 1;
if (is_builtin) {
MPIR_Datatype_get_size_macro(oldtype, old_extent);
} else {
MPIR_Datatype_get_extent_macro(oldtype, old_extent);
}
contig_count = MPII_Datatype_blockindexed_count_contig(count,
blklen, disp_array, dispinbytes,
old_extent);
/* optimization:
*
* if contig_count == 1 and block starts at displacement 0,
* store it as a contiguous rather than a blockindexed dataloop.
*/
if ((contig_count == 1) &&
((!dispinbytes && ((int *) disp_array)[0] == 0) ||
(dispinbytes && ((MPI_Aint *) disp_array)[0] == 0))) {
err = MPII_Dataloop_create_contiguous(icount * iblklen, oldtype, dlp_p, dlsz_p);
return err;
}
/* optimization:
*
* if contig_count == 1 store it as a blockindexed with one
* element rather than as a lot of individual blocks.
*/
if (contig_count == 1) {
/* adjust count and blklen and drop through */
blklen *= count;
count = 1;
iblklen *= icount;
icount = 1;
}
/* optimization:
*
* if displacements start at zero and result in a fixed stride,
* store it as a vector rather than a blockindexed dataloop.
*/
eff_disp0 = (dispinbytes) ? ((MPI_Aint) ((MPI_Aint *) disp_array)[0]) :
(((MPI_Aint) ((int *) disp_array)[0]) * old_extent);
if (count > 1 && eff_disp0 == (MPI_Aint) 0) {
eff_disp1 = (dispinbytes) ?
((MPI_Aint) ((MPI_Aint *) disp_array)[1]) :
(((MPI_Aint) ((int *) disp_array)[1]) * old_extent);
last_stride = eff_disp1 - eff_disp0;
for (i = 2; i < count; i++) {
eff_disp0 = eff_disp1;
eff_disp1 = (dispinbytes) ?
((MPI_Aint) ((MPI_Aint *) disp_array)[i]) :
(((MPI_Aint) ((int *) disp_array)[i]) * old_extent);
if (eff_disp1 - eff_disp0 != last_stride) {
is_vectorizable = 0;
break;
}
}
if (is_vectorizable) {
err = MPII_Dataloop_create_vector(count, blklen, last_stride, 1, /* strideinbytes */
oldtype, dlp_p, dlsz_p);
return err;
}
}
/* TODO: optimization:
*
* if displacements result in a fixed stride, but first displacement
* is not zero, store it as a blockindexed (blklen == 1) of a vector.
*/
/* TODO: optimization:
*
* if a blockindexed of a contig, absorb the contig into the blocklen
* parameter and keep the same overall depth
*/
/* otherwise storing as a blockindexed dataloop */
/* Q: HOW CAN WE TELL IF IT IS WORTH IT TO STORE AS AN
* INDEXED WITH FEWER CONTIG BLOCKS (IF CONTIG_COUNT IS SMALL)?
*/
if (is_builtin) {
MPII_Dataloop_alloc(MPII_DATALOOP_KIND_BLOCKINDEXED, count, &new_dlp, &new_loop_sz);
/* --BEGIN ERROR HANDLING-- */
if (!new_dlp)
return -1;
/* --END ERROR HANDLING-- */
new_dlp->kind = MPII_DATALOOP_KIND_BLOCKINDEXED | MPII_DATALOOP_FINAL_MASK;
new_dlp->el_size = old_extent;
new_dlp->el_extent = old_extent;
new_dlp->el_type = oldtype;
} else {
MPIR_Dataloop *old_loop_ptr = NULL;
MPI_Aint old_loop_sz = 0;
MPII_DATALOOP_GET_LOOPPTR(oldtype, old_loop_ptr);
MPII_DATALOOP_GET_LOOPSIZE(oldtype, old_loop_sz);
MPII_Dataloop_alloc_and_copy(MPII_DATALOOP_KIND_BLOCKINDEXED,
count, old_loop_ptr, old_loop_sz, &new_dlp, &new_loop_sz);
/* --BEGIN ERROR HANDLING-- */
if (!new_dlp)
return -1;
/* --END ERROR HANDLING-- */
new_dlp->kind = MPII_DATALOOP_KIND_BLOCKINDEXED;
MPIR_Datatype_get_size_macro(oldtype, new_dlp->el_size);
MPIR_Datatype_get_extent_macro(oldtype, new_dlp->el_extent);
MPIR_Datatype_get_basic_type(oldtype, new_dlp->el_type);
}
new_dlp->loop_params.bi_t.count = count;
new_dlp->loop_params.bi_t.blocksize = blklen;
/* copy in displacement parameters
*
* regardless of dispinbytes, we store displacements in bytes in loop.
*/
blockindexed_array_copy(count,
disp_array,
new_dlp->loop_params.bi_t.offset_array, dispinbytes, old_extent);
*dlp_p = new_dlp;
*dlsz_p = new_loop_sz;
return 0;
}
int MPIR_Allreduce_intra_recursive_doubling(
const void *sendbuf,
void *recvbuf,
int count,
MPI_Datatype datatype,
MPI_Op op,
MPIR_Comm * comm_ptr,
MPIR_Errflag_t * errflag)
{
MPIR_CHKLMEM_DECL(1);
#ifdef MPID_HAS_HETERO
int is_homogeneous;
int rc;
#endif
int comm_size, rank;
int mpi_errno = MPI_SUCCESS;
int mpi_errno_ret = MPI_SUCCESS;
int mask, dst, is_commutative, pof2, newrank, rem, newdst;
MPI_Aint true_extent, true_lb, extent;
void *tmp_buf;
comm_size = comm_ptr->local_size;
rank = comm_ptr->rank;
is_commutative = MPIR_Op_is_commutative(op);
/* need to allocate temporary buffer to store incoming data*/
MPIR_Type_get_true_extent_impl(datatype, &true_lb, &true_extent);
MPIR_Datatype_get_extent_macro(datatype, extent);
MPIR_Ensure_Aint_fits_in_pointer(count * MPL_MAX(extent, true_extent));
MPIR_CHKLMEM_MALLOC(tmp_buf, void *, count*(MPL_MAX(extent,true_extent)), mpi_errno, "temporary buffer", MPL_MEM_BUFFER);
/* adjust for potential negative lower bound in datatype */
tmp_buf = (void *)((char*)tmp_buf - true_lb);
/* copy local data into recvbuf */
if (sendbuf != MPI_IN_PLACE) {
mpi_errno = MPIR_Localcopy(sendbuf, count, datatype, recvbuf,
count, datatype);
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
}
/* get nearest power-of-two less than or equal to comm_size */
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 = MPIC_Send(recvbuf, count,
datatype, rank+1,
MPIR_ALLREDUCE_TAG, comm_ptr, 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);
}
/* temporarily set the rank to -1 so that this
process does not pariticipate in recursive
doubling */
newrank = -1;
}
else { /* odd */
mpi_errno = MPIC_Recv(tmp_buf, count,
datatype, rank-1,
MPIR_ALLREDUCE_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);
}
/* 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_Reduce_local(tmp_buf, recvbuf, count, datatype, op);
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
/* change the rank */
newrank = rank / 2;
}
}
else /* rank >= 2*rem */
newrank = rank - rem;
/* If op is user-defined or count is less than pof2, use
recursive doubling algorithm. Otherwise do a reduce-scatter
followed by allgather. (If op is user-defined,
derived datatypes are allowed and the user could pass basic
datatypes on one process and derived on another as long as
the type maps are the same. Breaking up derived
datatypes to do the reduce-scatter is tricky, therefore
using recursive doubling in that case.) */
if (newrank != -1) {
mask = 0x1;
while (mask < pof2) {
newdst = newrank ^ mask;
/* find real rank of dest */
dst = (newdst < rem) ? newdst*2 + 1 : newdst + rem;
/* Send the most current data, which is in recvbuf. Recv
into tmp_buf */
mpi_errno = MPIC_Sendrecv(recvbuf, count, datatype,
dst, MPIR_ALLREDUCE_TAG, tmp_buf,
count, datatype, dst,
MPIR_ALLREDUCE_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);
}
/* tmp_buf contains data received in this step.
recvbuf contains data accumulated so far */
if (is_commutative || (dst < rank)) {
/* op is commutative OR the order is already right */
mpi_errno = MPIR_Reduce_local(tmp_buf, recvbuf, count, datatype, op);
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
}
else {
/* op is noncommutative and the order is not right */
mpi_errno = MPIR_Reduce_local(recvbuf, tmp_buf, count, datatype, op);
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
/* copy result back into recvbuf */
mpi_errno = MPIR_Localcopy(tmp_buf, count, datatype,
recvbuf, count, datatype);
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
}
mask <<= 1;
}
}
/* In the non-power-of-two case, all odd-numbered
processes of rank < 2*rem send the result to
(rank-1), the ranks who didn't participate above. */
if (rank < 2*rem) {
if (rank % 2) /* odd */
mpi_errno = MPIC_Send(recvbuf, count,
datatype, rank-1,
MPIR_ALLREDUCE_TAG, comm_ptr, errflag);
else /* even */
mpi_errno = MPIC_Recv(recvbuf, count,
datatype, rank+1,
MPIR_ALLREDUCE_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);
}
}
fn_exit:
MPIR_CHKLMEM_FREEALL();
return mpi_errno;
fn_fail:
goto fn_exit;
}
int MPIR_Igatherv_sched_linear(const void *sendbuf, int sendcount, MPI_Datatype sendtype, void *recvbuf,
const int recvcounts[], const int displs[], MPI_Datatype recvtype, int root,
MPIR_Comm *comm_ptr, MPIR_Sched_t s)
{
int mpi_errno = MPI_SUCCESS;
int i;
int comm_size, rank;
MPI_Aint extent;
int min_procs;
rank = comm_ptr->rank;
/* If rank == root, then I recv lots, otherwise I send */
if (((comm_ptr->comm_kind == MPIR_COMM_KIND__INTRACOMM) && (root == rank)) ||
((comm_ptr->comm_kind == MPIR_COMM_KIND__INTERCOMM) && (root == MPI_ROOT)))
{
if (comm_ptr->comm_kind == MPIR_COMM_KIND__INTRACOMM)
comm_size = comm_ptr->local_size;
else
comm_size = comm_ptr->remote_size;
MPIR_Datatype_get_extent_macro(recvtype, extent);
/* each node can make sure it is not going to overflow aint */
MPIR_Ensure_Aint_fits_in_pointer(MPIR_VOID_PTR_CAST_TO_MPI_AINT recvbuf + displs[rank] * extent);
for (i = 0; i < comm_size; i++) {
if (recvcounts[i]) {
if ((comm_ptr->comm_kind == MPIR_COMM_KIND__INTRACOMM) && (i == rank)) {
if (sendbuf != MPI_IN_PLACE) {
mpi_errno = MPIR_Sched_copy(sendbuf, sendcount, sendtype,
((char *)recvbuf+displs[rank]*extent),
recvcounts[rank], recvtype, s);
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
}
}
else {
mpi_errno = MPIR_Sched_recv(((char *)recvbuf+displs[i]*extent),
recvcounts[i], recvtype, i, comm_ptr, s);
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
}
}
}
}
else if (root != MPI_PROC_NULL)
{
/* non-root nodes, and in the intercomm. case, non-root nodes on remote side */
if (sendcount) {
/* we want local size in both the intracomm and intercomm cases
because the size of the root's group (group A in the standard) is
irrelevant here. */
comm_size = comm_ptr->local_size;
min_procs = MPIR_CVAR_GATHERV_INTER_SSEND_MIN_PROCS;
if (min_procs == -1)
min_procs = comm_size + 1; /* Disable ssend */
else if (min_procs == 0) /* backwards compatibility, use default value */
MPIR_CVAR_GET_DEFAULT_INT(GATHERV_INTER_SSEND_MIN_PROCS,&min_procs);
if (comm_size >= min_procs)
mpi_errno = MPIR_Sched_ssend(sendbuf, sendcount, sendtype, root, comm_ptr, s);
else
mpi_errno = MPIR_Sched_send(sendbuf, sendcount, sendtype, root, comm_ptr, s);
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
}
}
fn_exit:
return mpi_errno;
fn_fail:
goto fn_exit;
}
int MPII_Dataloop_convert_subarray(int ndims,
int *array_of_sizes,
int *array_of_subsizes,
int *array_of_starts,
int order, MPI_Datatype oldtype, MPI_Datatype * newtype)
{
int mpi_errno = MPI_SUCCESS;
MPI_Aint extent, disps[3], size;
int i, blklens[3];
MPI_Datatype tmp1, tmp2, types[3];
MPIR_Datatype_get_extent_macro(oldtype, extent);
if (order == MPI_ORDER_FORTRAN) {
/* dimension 0 changes fastest */
if (ndims == 1) {
mpi_errno = MPIR_Type_contiguous_impl(array_of_subsizes[0], oldtype, &tmp1);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
} else {
mpi_errno = MPIR_Type_vector_impl(array_of_subsizes[1],
array_of_subsizes[0],
array_of_sizes[0], oldtype, &tmp1);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
size = (MPI_Aint) (array_of_sizes[0]) * extent;
for (i = 2; i < ndims; i++) {
size *= (MPI_Aint) (array_of_sizes[i - 1]);
mpi_errno = MPIR_Type_hvector_impl(array_of_subsizes[i], 1, size, tmp1, &tmp2);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
MPIR_Type_free_impl(&tmp1);
tmp1 = tmp2;
}
}
/* add displacement and UB */
disps[1] = (MPI_Aint) (array_of_starts[0]);
size = 1;
for (i = 1; i < ndims; i++) {
size *= (MPI_Aint) (array_of_sizes[i - 1]);
disps[1] += size * (MPI_Aint) (array_of_starts[i]);
}
/* rest done below for both Fortran and C order */
}
else { /* order == MPI_ORDER_C */
/* dimension ndims-1 changes fastest */
if (ndims == 1) {
mpi_errno = MPIR_Type_contiguous_impl(array_of_subsizes[0], oldtype, &tmp1);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
} else {
mpi_errno = MPIR_Type_vector_impl(array_of_subsizes[ndims - 2],
array_of_subsizes[ndims - 1],
array_of_sizes[ndims - 1], oldtype, &tmp1);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
size = (MPI_Aint) (array_of_sizes[ndims - 1]) * extent;
for (i = ndims - 3; i >= 0; i--) {
size *= (MPI_Aint) (array_of_sizes[i + 1]);
mpi_errno = MPIR_Type_hvector_impl(array_of_subsizes[i], 1, size, tmp1, &tmp2);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
MPIR_Type_free_impl(&tmp1);
tmp1 = tmp2;
}
}
/* add displacement and UB */
disps[1] = (MPI_Aint) (array_of_starts[ndims - 1]);
size = 1;
for (i = ndims - 2; i >= 0; i--) {
size *= (MPI_Aint) (array_of_sizes[i + 1]);
disps[1] += size * (MPI_Aint) (array_of_starts[i]);
}
}
disps[1] *= extent;
disps[2] = extent;
for (i = 0; i < ndims; i++)
disps[2] *= (MPI_Aint) (array_of_sizes[i]);
disps[0] = 0;
blklens[0] = blklens[1] = blklens[2] = 1;
types[0] = MPI_LB;
types[1] = tmp1;
types[2] = MPI_UB;
mpi_errno = MPIR_Type_struct_impl(3, blklens, disps, types, newtype);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
MPIR_Type_free_impl(&tmp1);
fn_exit:
return mpi_errno;
fn_fail:
goto fn_exit;
}
int MPIR_Alltoallv_intra_pairwise_sendrecv_replace(const void *sendbuf, const int *sendcounts,
const int *sdispls, MPI_Datatype sendtype,
void *recvbuf, const int *recvcounts,
const int *rdispls, MPI_Datatype recvtype,
MPIR_Comm * comm_ptr, MPIR_Errflag_t * errflag)
{
int comm_size, i, j;
MPI_Aint recv_extent;
int mpi_errno = MPI_SUCCESS;
int mpi_errno_ret = MPI_SUCCESS;
MPI_Status status;
int rank;
comm_size = comm_ptr->local_size;
rank = comm_ptr->rank;
/* Get extent of recv type, but send type is only valid if (sendbuf!=MPI_IN_PLACE) */
MPIR_Datatype_get_extent_macro(recvtype, recv_extent);
#ifdef HAVE_ERROR_CHECKING
MPIR_Assert(sendbuf == MPI_IN_PLACE);
#endif
/* 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 + rdispls[j] * recv_extent),
recvcounts[j], recvtype,
j, MPIR_ALLTOALLV_TAG,
j, MPIR_ALLTOALLV_TAG,
comm_ptr, &status, errflag);
if (mpi_errno) {
/* for communication errors, just record the error but continue */
*errflag =
MPIX_ERR_PROC_FAILED ==
MPIR_ERR_GET_CLASS(mpi_errno) ? MPIR_ERR_PROC_FAILED : MPIR_ERR_OTHER;
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 + rdispls[i] * recv_extent),
recvcounts[i], recvtype,
i, MPIR_ALLTOALLV_TAG,
i, MPIR_ALLTOALLV_TAG,
comm_ptr, &status, errflag);
if (mpi_errno) {
/* for communication errors, just record the error but continue */
*errflag =
MPIX_ERR_PROC_FAILED ==
MPIR_ERR_GET_CLASS(mpi_errno) ? MPIR_ERR_PROC_FAILED : MPIR_ERR_OTHER;
MPIR_ERR_SET(mpi_errno, *errflag, "**fail");
MPIR_ERR_ADD(mpi_errno_ret, mpi_errno);
}
}
}
}
if (mpi_errno_ret)
mpi_errno = mpi_errno_ret;
else if (*errflag != MPIR_ERR_NONE)
MPIR_ERR_SET(mpi_errno, *errflag, "**coll_fail");
return 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);
}
}
