/*@
MPI_Op_free - Frees a user-defined combination function handle
Input Parameter:
. op - operation (handle)
Notes:
'op' is set to 'MPI_OP_NULL' on exit.
.N NULL
.N fortran
.N Errors
.N MPI_SUCCESS
.N MPI_ERR_ARG
.N MPI_ERR_PERM_OP
.seealso: MPI_Op_create
@*/
EXPORT_MPI_API int MPI_Op_free( MPI_Op *op )
{
int mpi_errno = MPI_SUCCESS;
struct MPIR_OP *old;
static char myname[] = "MPI_OP_FREE";
#ifndef MPIR_NO_ERROR_CHECKING
/* Freeing a NULL op should not return successfully */
MPIR_TEST_ARG(op);
if ( (*op) == MPI_OP_NULL ) {
mpi_errno = MPIR_ERRCLASS_TO_CODE(MPI_ERR_OP,MPIR_ERR_OP_NULL);
}
if (mpi_errno)
return MPIR_ERROR(MPIR_COMM_WORLD, mpi_errno, myname );
#endif
old = MPIR_GET_OP_PTR( *op );
MPIR_TEST_MPI_OP(*op,old,MPIR_COMM_WORLD,myname);
/* We can't free permanent objects unless finalize has been called */
if ( ( old->permanent == 1 ) && (MPIR_Has_been_initialized == 1) )
return MPIR_ERROR( MPIR_COMM_WORLD,
MPIR_ERRCLASS_TO_CODE(MPI_ERR_ARG,MPIR_ERR_PERM_OP),myname );
MPIR_CLR_COOKIE(old);
FREE( old );
MPIR_RmPointer( *op );
(*op) = MPI_OP_NULL;
TR_POP;
return (MPI_SUCCESS);
}
static int intra_Reduce(void *sendbuf,
void *recvbuf,
int count,
struct MPIR_DATATYPE *datatype,
MPI_Op op,
int root, struct MPIR_COMMUNICATOR *comm)
{
MPI_Status status;
int size, rank;
int mask, relrank, source, lroot;
int mpi_errno = MPI_SUCCESS;
MPI_User_function *uop;
MPI_Aint lb, ub, m_extent; /* Extent in memory */
void *buffer;
struct MPIR_OP *op_ptr;
static char myname[] = "MPI_REDUCE";
MPIR_ERROR_DECL;
mpi_comm_err_ret = 0;
/* Is root within the communicator? */
MPIR_Comm_size(comm, &size);
#ifndef MPIR_NO_ERROR_CHECKING
if (root >= size)
mpi_errno = MPIR_Err_setmsg(MPI_ERR_ROOT, MPIR_ERR_ROOT_TOOBIG,
myname, (char *) 0, (char *) 0, root,
size);
if (root < 0)
mpi_errno = MPIR_Err_setmsg(MPI_ERR_ROOT, MPIR_ERR_DEFAULT, myname,
(char *) 0, (char *) 0, root);
if (mpi_errno)
return MPIR_ERROR(comm, mpi_errno, myname);
#endif
/* See the overview in Collection Operations for why this is ok */
if (count == 0)
return MPI_SUCCESS;
/* If the operation is predefined, we could check that the datatype's
type signature is compatible with the operation.
*/
#ifdef MPID_Reduce
/* Eventually, this could apply the MPID_Reduce routine in a loop for
counts > 1 */
if (comm->ADIReduce && count == 1) {
/* Call a routine to sort through the datatypes and operations ...
This allows us to provide partial support (e.g., only SUM_DOUBLE)
*/
if (MPIR_ADIReduce(comm->ADIctx, comm, sendbuf, recvbuf, count,
datatype->self, op, root) == MPI_SUCCESS)
return MPI_SUCCESS;
}
#endif
/* Get my rank and switch communicators to the hidden collective */
MPIR_Comm_rank(comm, &rank);
comm = comm->comm_coll;
op_ptr = MPIR_GET_OP_PTR(op);
MPIR_TEST_MPI_OP(op, op_ptr, comm, myname);
uop = op_ptr->op;
/* Here's the algorithm. Relative to the root, look at the bit pattern in
my rank. Starting from the right (lsb), if the bit is 1, send to
the node with that bit zero and exit; if the bit is 0, receive from the
node with that bit set and combine (as long as that node is within the
group)
Note that by receiving with source selection, we guarentee that we get
the same bits with the same input. If we allowed the parent to receive
the children in any order, then timing differences could cause different
results (roundoff error, over/underflows in some cases, etc).
Because of the way these are ordered, if root is 0, then this is correct
for both commutative and non-commutitive operations. If root is not
0, then for non-commutitive, we use a root of zero and then send
the result to the root. To see this, note that the ordering is
mask = 1: (ab)(cd)(ef)(gh) (odds send to evens)
mask = 2: ((ab)(cd))((ef)(gh)) (3,6 send to 0,4)
mask = 4: (((ab)(cd))((ef)(gh))) (4 sends to 0)
Comments on buffering.
If the datatype is not contiguous, we still need to pass contiguous
data to the user routine.
In this case, we should make a copy of the data in some format,
and send/operate on that.
In general, we can't use MPI_PACK, because the alignment of that
is rather vague, and the data may not be re-usable. What we actually
need is a "squeeze" operation that removes the skips.
*/
/* Make a temporary buffer */
MPIR_Type_get_limits(datatype, &lb, &ub);
m_extent = ub - lb;
/* MPI_Type_extent ( datatype, &extent ); */
MPIR_ALLOC(buffer, (void *) MALLOC(m_extent * count), comm,
MPI_ERR_EXHAUSTED, "MPI_REDUCE");
buffer = (void *) ((char *) buffer - 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_ALLOC(recvbuf, (void *) MALLOC(m_extent * count),
comm, MPI_ERR_EXHAUSTED, "MPI_REDUCE");
recvbuf = (void *) ((char *) recvbuf - lb);
}
/* This code isn't correct if the source is a more complex datatype */
memcpy(recvbuf, sendbuf, m_extent * count);
mask = 0x1;
if (op_ptr->commute)
lroot = root;
else
lroot = 0;
relrank = (rank - lroot + size) % size;
/* Lock for collective operation */
MPID_THREAD_LOCK(comm->ADIctx, comm);
MPIR_Op_errno = MPI_SUCCESS;
while ( /*(mask & relrank) == 0 && */ mask < size) {
/* Receive */
if ((mask & relrank) == 0) {
source = (relrank | mask);
if (source < size) {
source = (source + lroot) % size;
mpi_errno = MPI_Recv(buffer, count, datatype->self, source,
MPIR_REDUCE_TAG, comm->self, &status);
if (mpi_errno)
return MPIR_ERROR(comm, mpi_errno, myname);
/* The sender is above us, so the received buffer must be
the second argument (in the noncommutitive case). */
/* error pop/push allows errors found by predefined routines
to be visible. We need a better way to do this */
/* MPIR_ERROR_POP(comm); */
if (op_ptr->commute)
(*uop) (buffer, recvbuf, &count, &datatype->self);
else {
(*uop) (recvbuf, buffer, &count, &datatype->self);
/* short term hack to keep recvbuf up-to-date */
memcpy(recvbuf, buffer, m_extent * count);
}
/* MPIR_ERROR_PUSH(comm); */
}
} else {
/* I've received all that I'm going to. Send my result to
my parent */
source = ((relrank & (~mask)) + lroot) % size;
mpi_errno = MPI_Send(recvbuf, count, datatype->self,
source, MPIR_REDUCE_TAG, comm->self);
if (mpi_errno)
return MPIR_ERROR(comm, mpi_errno, myname);
break;
}
mask <<= 1;
}
FREE((char *) buffer + lb);
if (!op_ptr->commute && root != 0) {
if (rank == 0) {
mpi_errno = MPI_Send(recvbuf, count, datatype->self, root,
MPIR_REDUCE_TAG, comm->self);
} else if (rank == root) {
mpi_errno = MPI_Recv(recvbuf, count, datatype->self, 0, /*size-1, */
MPIR_REDUCE_TAG, comm->self, &status);
}
}
/* Free the temporarily allocated recvbuf */
if (rank != root)
FREE((char *) recvbuf + lb);
/* If the predefined operation detected an error, report it here */
/* Note that only the root gets this result, so this can cause
programs to hang, particularly if this is used to implement
MPI_Allreduce. Use care with this.
*/
if (mpi_errno == MPI_SUCCESS && MPIR_Op_errno) {
/* PRINTF( "Error in performing MPI_Op in reduce\n" ); */
mpi_errno = MPIR_Op_errno;
}
/* Unlock for collective operation */
MPID_THREAD_UNLOCK(comm->ADIctx, comm);
return (mpi_errno);
}
static int intra_Scan(void *sendbuf,
void *recvbuf,
int count,
struct MPIR_DATATYPE *datatype,
MPI_Op op, struct MPIR_COMMUNICATOR *comm)
{
MPI_Status status;
int rank, size;
int mpi_errno = MPI_SUCCESS;
MPI_Aint lb, ub, m_extent; /* Extent in memory */
MPI_User_function *uop;
struct MPIR_OP *op_ptr;
MPIR_ERROR_DECL;
mpi_comm_err_ret = 0;
/* See the overview in Collection Operations for why this is ok */
if (count == 0)
return MPI_SUCCESS;
/* Get my rank & size and switch communicators to the hidden collective */
MPIR_Comm_size(comm, &size);
MPIR_Comm_rank(comm, &rank);
MPIR_Type_get_limits(datatype, &lb, &ub);
m_extent = ub - lb;
comm = comm->comm_coll;
op_ptr = MPIR_GET_OP_PTR(op);
MPIR_TEST_MPI_OP(op, op_ptr, comm, "MPI_SCAN");
uop = op_ptr->op;
/* Lock for collective operation */
MPID_THREAD_LOCK(comm->ADIctx, comm);
/*
This is an O(size) algorithm. A modification of the algorithm in
reduce.c can be used to make this O(log(size))
*/
/* commutative case requires no extra buffering */
MPIR_Op_errno = MPI_SUCCESS;
if (op_ptr->commute) {
/* Do the scan operation */
if (rank > 0) {
mpi_errno = MPI_Recv(recvbuf, count, datatype->self, rank - 1,
MPIR_SCAN_TAG, comm->self, &status);
if (mpi_errno)
return mpi_errno;
/* See reduce for why pop/push */
MPIR_ERROR_POP(comm);
(*uop) (sendbuf, recvbuf, &count, &datatype->self);
MPIR_ERROR_PUSH(comm);
} else {
MPIR_COPYSELF(sendbuf, count, datatype->self, recvbuf,
MPIR_SCAN_TAG, rank, comm->self);
if (mpi_errno)
return mpi_errno;
}
}
/* non-commutative case requires extra buffering */
else {
/* Do the scan operation */
if (rank > 0) {
void *tmpbuf;
MPIR_ALLOC(tmpbuf, (void *) MALLOC(m_extent * count),
comm, MPI_ERR_EXHAUSTED, "MPI_SCAN");
tmpbuf = (void *) ((char *) tmpbuf - lb);
MPIR_COPYSELF(sendbuf, count, datatype->self, recvbuf,
MPIR_SCAN_TAG, rank, comm->self);
if (mpi_errno)
return mpi_errno;
mpi_errno = MPI_Recv(tmpbuf, count, datatype->self, rank - 1,
MPIR_SCAN_TAG, comm->self, &status);
if (mpi_errno)
return mpi_errno;
(*uop) (tmpbuf, recvbuf, &count, &datatype->self);
FREE((char *) tmpbuf + lb);
} else {
MPIR_COPYSELF(sendbuf, count, datatype->self, recvbuf,
MPIR_SCAN_TAG, rank, comm->self);
if (mpi_errno)
return mpi_errno;
}
}
/* send the letter to destination */
if (rank < (size - 1))
mpi_errno =
MPI_Send(recvbuf, count, datatype->self, rank + 1,
MPIR_SCAN_TAG, comm->self);
/* If the predefined operation detected an error, report it here */
if (mpi_errno == MPI_SUCCESS && MPIR_Op_errno)
mpi_errno = MPIR_Op_errno;
/* Unlock for collective operation */
MPID_THREAD_UNLOCK(comm->ADIctx, comm);
return (mpi_errno);
}
int MPIR_intra_Scan ( void *sendbuf, void *recvbuf, int count,
struct MPIR_DATATYPE *datatype, MPI_Op op,
struct MPIR_COMMUNICATOR *comm )
{
MPI_Status status;
int rank, size;
int mpi_errno = MPI_SUCCESS;
MPI_Aint lb, ub, m_extent; /* Extent in memory */
MPI_User_function *uop;
struct MPIR_OP *op_ptr;
MPIR_ERROR_DECL;
int dd; /* displacement, no of hops to send (power of 2) */
int rr; /* "round rank" */
void *tmpbuf;
mpi_comm_err_ret = 0;
/* Nov. 98: Improved O(log(size)) algorithm */
/* See the overview in Collection Operations for why this is ok */
if (count == 0) return MPI_SUCCESS;
/* Get my rank & size and switch communicators to the hidden collective */
MPIR_Comm_size ( comm, &size );
MPIR_Comm_rank ( comm, &rank );
MPIR_Type_get_limits( datatype, &lb, &ub );
m_extent = ub - lb;
comm = comm->comm_coll;
op_ptr = MPIR_GET_OP_PTR(op);
MPIR_TEST_MPI_OP(op,op_ptr,comm,"MPI_SCAN");
uop = op_ptr->op;
/* Lock for collective operation */
MPID_THREAD_DS_LOCK(comm);
MPIR_Op_errno = MPI_SUCCESS;
if (rank>0) {
/* allocate temporary receive buffer
(needed both in commutative and noncommutative case) */
MPIR_ALLOC(tmpbuf,(void *)MALLOC(m_extent * count),
comm, MPI_ERR_EXHAUSTED, "Out of space in MPI_SCAN" );
tmpbuf = (void *)((char*)tmpbuf-lb);
}
MPIR_COPYSELF( sendbuf, count, datatype->self, recvbuf,
MPIR_SCAN_TAG, rank, comm->self );
/* compute partial scans */
rr = rank; dd = 1;
while ((rr&1)==1) {
/* odd "round rank"s receive */
mpi_errno = MPI_Recv(tmpbuf,count,datatype->self,rank-dd,
MPIR_SCAN_TAG,comm->self,&status);
if (mpi_errno) return mpi_errno;
#ifdef WIN32
if(op_ptr->stdcall) op_ptr->op_s(tmpbuf, recvbuf, &count, &datatype->self);
else
#endif
(*uop)(tmpbuf, recvbuf, &count, &datatype->self);
dd <<= 1; /* dd*2 */
rr >>= 1; /* rr/2 */
/* Invariant: recvbuf contains the scan of
(rank-dd)+1, (rank-dd)+2,..., rank */
}
/* rr even, rank==rr*dd+dd-1, recvbuf contains the scan of
rr*dd, rr*dd+1,..., rank */
/* send partial scan forwards */
if (rank+dd<size) {
mpi_errno = MPI_Send(recvbuf,count,datatype->self,rank+dd,MPIR_SCAN_TAG,
comm->self);
if (mpi_errno) return mpi_errno;
}
if (rank-dd>=0) {
mpi_errno = MPI_Recv(tmpbuf,count,datatype->self,rank-dd,
MPIR_SCAN_TAG,comm->self,&status);
if (mpi_errno) return mpi_errno;
#ifdef WIN32
if(op_ptr->stdcall) op_ptr->op_s(tmpbuf, recvbuf, &count, &datatype->self);
else
#endif
(*uop)(tmpbuf, recvbuf, &count, &datatype->self);
/* recvbuf contains the scan of 0,..., rank */
}
/* send result forwards */
do {
dd >>= 1; /* dd/2 */
} while (rank+dd>=size);
while (dd>0) {
mpi_errno = MPI_Send(recvbuf,count,datatype->self,rank+dd,MPIR_SCAN_TAG,
comm->self);
if (mpi_errno) return mpi_errno;
dd >>= 1; /* dd/2 */
}
if (rank>0) {
/* free temporary receive buffer */
FREE((char*)tmpbuf+lb);
}
/* If the predefined operation detected an error, report it here */
if (mpi_errno == MPI_SUCCESS && MPIR_Op_errno)
mpi_errno = MPIR_Op_errno;
/* Unlock for collective operation */
MPID_THREAD_DS_UNLOCK(comm);
return(mpi_errno);
}
int MPIR_intra_Scan ( void *sendbuf, void *recvbuf, int count,
struct MPIR_DATATYPE *datatype, MPI_Op op,
struct MPIR_COMMUNICATOR *comm )
{
MPI_Status status;
int rank, size;
int mpi_errno = MPI_SUCCESS;
MPI_User_function *uop;
struct MPIR_OP *op_ptr;
int mask, dst;
MPI_Aint extent, lb;
void *partial_scan, *tmp_buf;
static char myname[] = "MPI_SCAN";
if (count == 0) return MPI_SUCCESS;
MPIR_Comm_size(comm, &size);
MPIR_Comm_rank(comm, &rank);
/* Switch communicators to the hidden collective */
comm = comm->comm_coll;
/* Lock for collective operation */
MPID_THREAD_LOCK(comm->ADIctx,comm);
op_ptr = MPIR_GET_OP_PTR(op);
MPIR_TEST_MPI_OP(op,op_ptr,comm,myname);
uop = op_ptr->op;
/* need to allocate temporary buffer to store partial scan*/
MPI_Type_extent(datatype->self, &extent);
MPIR_ALLOC(partial_scan,(void *)MALLOC(count*extent), comm,
MPI_ERR_EXHAUSTED, myname);
/* adjust for potential negative lower bound in datatype */
MPI_Type_lb( datatype->self, &lb );
partial_scan = (void *)((char*)partial_scan - lb);
/* need to allocate temporary buffer to store incoming data*/
MPIR_ALLOC(tmp_buf,(void *)MALLOC(count*extent), comm,
MPI_ERR_EXHAUSTED, myname);
/* adjust for potential negative lower bound in datatype */
tmp_buf = (void *)((char*)tmp_buf - lb);
/* Since this is an inclusive scan, copy local contribution into
recvbuf. */
mpi_errno = MPI_Sendrecv ( sendbuf, count, datatype->self,
rank, MPIR_SCAN_TAG,
recvbuf, count, datatype->self,
rank, MPIR_SCAN_TAG,
comm->self, &status );
if (mpi_errno) return mpi_errno;
mpi_errno = MPI_Sendrecv ( sendbuf, count, datatype->self,
rank, MPIR_SCAN_TAG,
partial_scan, count, datatype->self,
rank, MPIR_SCAN_TAG,
comm->self, &status );
if (mpi_errno) return mpi_errno;
mask = 0x1;
while (mask < size) {
dst = rank ^ mask;
if (dst < size) {
/* Send partial_scan to dst. Recv into tmp_buf */
mpi_errno = MPI_Sendrecv(partial_scan, count, datatype->self,
dst, MPIR_SCAN_TAG, tmp_buf,
count, datatype->self, dst,
MPIR_SCAN_TAG, comm->self,
&status);
if (mpi_errno) return mpi_errno;
if (rank > dst) {
(*uop)(tmp_buf, partial_scan, &count, &datatype->self);
(*uop)(tmp_buf, recvbuf, &count, &datatype->self);
}
else {
if (op_ptr->commute)
(*uop)(tmp_buf, partial_scan, &count, &datatype->self);
else {
(*uop)(partial_scan, tmp_buf, &count, &datatype->self);
mpi_errno = MPI_Sendrecv(tmp_buf, count, datatype->self,
rank, MPIR_SCAN_TAG, partial_scan,
count, datatype->self, rank,
MPIR_SCAN_TAG, comm->self,
&status);
if (mpi_errno) return mpi_errno;
}
}
}
mask <<= 1;
}
FREE((char *)partial_scan+lb);
FREE((char *)tmp_buf+lb);
/* Unlock for collective operation */
MPID_THREAD_UNLOCK(comm->ADIctx,comm);
return (mpi_errno);
}
