/* Routine to delete an attribute list */
int MPIR_Attr_delete_list(int handle, MPIR_Attribute ** attr)
{
MPIR_Attribute *p, *new_p;
int mpi_errno = MPI_SUCCESS;
p = *attr;
while (p) {
/* delete the attribute by first executing the delete routine, if any,
* determine the the next attribute, and recover the attributes
* storage */
new_p = p->next;
/* Check the sentinals first */
/* --BEGIN ERROR HANDLING-- */
if (p->pre_sentinal != 0 || p->post_sentinal != 0) {
MPIR_ERR_SET(mpi_errno, MPI_ERR_OTHER, "**attrsentinal");
/* We could keep trying to free the attributes, but for now
* we'll just bag it */
return mpi_errno;
}
/* --END ERROR HANDLING-- */
/* For this attribute, find the delete function for the
* corresponding keyval */
/* Still to do: capture any error returns but continue to
* process attributes */
mpi_errno = MPIR_Call_attr_delete(handle, p);
/* We must also remove the keyval reference. If the keyval
* was freed earlier (reducing the refcount), the actual
* release and free will happen here. We must free the keyval
* even if the attr delete failed, as we then remove the
* attribute.
*/
{
int in_use;
/* Decrement the use of the keyval */
MPII_Keyval_release_ref(p->keyval, &in_use);
if (!in_use) {
MPIR_Handle_obj_free(&MPII_Keyval_mem, p->keyval);
}
}
MPIR_Handle_obj_free(&MPID_Attr_mem, p);
p = new_p;
}
/* We must zero out the attribute list pointer or we could attempt to use it
* later. This normally can't happen because the communicator usually
* disappears after a call to MPI_Comm_free. But if the attribute keyval
* has an associated delete function that returns an error then we don't
* actually free the communicator despite having freed all the attributes
* associated with the communicator.
*
* This function is also used for Win and Type objects, but the idea is the
* same in those cases as well. */
*attr = NULL;
return mpi_errno;
}
int MPIR_Group_create( int nproc, MPIR_Group **new_group_ptr )
{
int mpi_errno = MPI_SUCCESS;
*new_group_ptr = (MPIR_Group *)MPIR_Handle_obj_alloc( &MPIR_Group_mem );
/* --BEGIN ERROR HANDLING-- */
if (!*new_group_ptr) {
mpi_errno = MPIR_Err_create_code( MPI_SUCCESS, MPIR_ERR_RECOVERABLE, "MPIR_Group_create", __LINE__, MPI_ERR_OTHER, "**nomem", 0 );
return mpi_errno;
}
/* --END ERROR HANDLING-- */
MPIR_Object_set_ref( *new_group_ptr, 1 );
(*new_group_ptr)->lrank_to_lpid =
(MPII_Group_pmap_t *)MPL_malloc( nproc * sizeof(MPII_Group_pmap_t) );
/* --BEGIN ERROR HANDLING-- */
if (!(*new_group_ptr)->lrank_to_lpid) {
MPIR_Handle_obj_free( &MPIR_Group_mem, *new_group_ptr );
*new_group_ptr = NULL;
MPIR_CHKMEM_SETERR(mpi_errno,nproc*sizeof(MPII_Group_pmap_t),
"newgroup->lrank_to_lpid");
return mpi_errno;
}
/* --END ERROR HANDLING-- */
(*new_group_ptr)->size = nproc;
/* Make sure that there is no question that the list of ranks sorted
by pids is marked as uninitialized */
(*new_group_ptr)->idx_of_first_lpid = -1;
(*new_group_ptr)->is_local_dense_monotonic = FALSE;
return mpi_errno;
}
int MPIR_Group_release(MPIR_Group *group_ptr)
{
int mpi_errno = MPI_SUCCESS;
int inuse;
MPIR_Group_release_ref(group_ptr, &inuse);
if (!inuse) {
/* Only if refcount is 0 do we actually free. */
MPL_free(group_ptr->lrank_to_lpid);
MPIR_Handle_obj_free( &MPIR_Group_mem, group_ptr );
}
return mpi_errno;
}
int MPIR_Comm_delete_attr_impl(MPIR_Comm * comm_ptr, MPII_Keyval * keyval_ptr)
{
int mpi_errno = MPI_SUCCESS;
MPIR_Attribute *p, **old_p;
/* Look for attribute. They are ordered by keyval handle */
old_p = &comm_ptr->attributes;
p = comm_ptr->attributes;
while (p) {
if (p->keyval->handle == keyval_ptr->handle) {
break;
}
old_p = &p->next;
p = p->next;
}
/* We can't unlock yet, because we must not free the attribute until
* we know whether the delete function has returned with a 0 status
* code */
if (p) {
int in_use;
/* Run the delete function, if any, and then free the
* attribute storage. Note that due to an ambiguity in the
* standard, if the usr function returns something other than
* MPI_SUCCESS, we should either return the user return code,
* or an mpich error code. The precedent set by the Intel
* test suite says we should return the user return code. So
* we must not ERR_POP here. */
mpi_errno = MPIR_Call_attr_delete(comm_ptr->handle, p);
if (mpi_errno)
goto fn_fail;
/* We found the attribute. Remove it from the list */
*old_p = p->next;
/* Decrement the use of the keyval */
MPII_Keyval_release_ref(p->keyval, &in_use);
if (!in_use) {
MPIR_Handle_obj_free(&MPII_Keyval_mem, p->keyval);
}
MPID_Attr_free(p);
}
fn_exit:
return mpi_errno;
fn_fail:
goto fn_exit;
}
int MPID_Win_free(MPIR_Win ** win_ptr)
{
int mpi_errno = MPI_SUCCESS;
int in_use;
MPIR_Comm *comm_ptr;
MPIR_Errflag_t errflag = MPIR_ERR_NONE;
MPIR_FUNC_VERBOSE_STATE_DECL(MPID_STATE_MPID_WIN_FREE);
MPIR_FUNC_VERBOSE_RMA_ENTER(MPID_STATE_MPID_WIN_FREE);
MPIR_ERR_CHKANDJUMP(((*win_ptr)->states.access_state != MPIDI_RMA_NONE &&
(*win_ptr)->states.access_state != MPIDI_RMA_FENCE_ISSUED &&
(*win_ptr)->states.access_state != MPIDI_RMA_FENCE_GRANTED) ||
((*win_ptr)->states.exposure_state != MPIDI_RMA_NONE),
mpi_errno, MPI_ERR_RMA_SYNC, "**rmasync");
/* 1. Here we must wait until all passive locks are released on this target,
* because for some UNLOCK messages, we do not send ACK back to origin,
* we must wait until lock is released so that we can free window.
* 2. We also need to wait until AT completion counter being zero, because
* this counter is increment everytime we meet a GET-like operation, it is
* possible that when target entering Win_free, passive epoch is not finished
* yet and there are still GETs doing on this target.
* 3. We also need to wait until lock queue becomes empty. It is possible
* that some lock requests is still waiting in the queue when target is
* entering Win_free. */
while ((*win_ptr)->current_lock_type != MPID_LOCK_NONE ||
(*win_ptr)->at_completion_counter != 0 ||
(*win_ptr)->target_lock_queue_head != NULL ||
(*win_ptr)->current_target_lock_data_bytes != 0 || (*win_ptr)->sync_request_cnt != 0) {
mpi_errno = wait_progress_engine();
if (mpi_errno != MPI_SUCCESS)
MPIR_ERR_POP(mpi_errno);
}
mpi_errno = MPID_Barrier((*win_ptr)->comm_ptr, &errflag);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
/* Free window resources in lower layer. */
if (MPIDI_CH3U_Win_hooks.win_free != NULL) {
mpi_errno = MPIDI_CH3U_Win_hooks.win_free(win_ptr);
if (mpi_errno != MPI_SUCCESS)
MPIR_ERR_POP(mpi_errno);
}
/* dequeue window from the global list */
MPIR_Assert((*win_ptr)->active == FALSE);
DL_DELETE(MPIDI_RMA_Win_inactive_list_head, (*win_ptr));
if (MPIDI_RMA_Win_inactive_list_head == NULL && MPIDI_RMA_Win_active_list_head == NULL) {
/* this is the last window, de-register RMA progress hook */
mpi_errno = MPID_Progress_deregister_hook(MPIDI_CH3I_RMA_Progress_hook_id);
if (mpi_errno != MPI_SUCCESS) {
MPIR_ERR_POP(mpi_errno);
}
}
comm_ptr = (*win_ptr)->comm_ptr;
mpi_errno = MPIR_Comm_free_impl(comm_ptr);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
if ((*win_ptr)->basic_info_table != NULL)
MPL_free((*win_ptr)->basic_info_table);
MPL_free((*win_ptr)->op_pool_start);
MPL_free((*win_ptr)->target_pool_start);
MPL_free((*win_ptr)->slots);
MPL_free((*win_ptr)->target_lock_entry_pool_start);
MPIR_Assert((*win_ptr)->current_target_lock_data_bytes == 0);
/* Free the attached buffer for windows created with MPI_Win_allocate() */
if ((*win_ptr)->create_flavor == MPI_WIN_FLAVOR_ALLOCATE ||
(*win_ptr)->create_flavor == MPI_WIN_FLAVOR_SHARED) {
if ((*win_ptr)->shm_allocated == FALSE && (*win_ptr)->size > 0) {
MPL_free((*win_ptr)->base);
}
}
MPIR_Object_release_ref(*win_ptr, &in_use);
/* MPI windows don't have reference count semantics, so this should always be true */
MPIR_Assert(!in_use);
MPIR_Handle_obj_free(&MPIR_Win_mem, *win_ptr);
fn_exit:
MPIR_FUNC_VERBOSE_RMA_EXIT(MPID_STATE_MPID_WIN_FREE);
return mpi_errno;
fn_fail:
goto fn_exit;
}
static int sched_cb_gcn_allocate_cid(MPIR_Comm * comm, int tag, void *state)
{
int mpi_errno = MPI_SUCCESS;
struct gcn_state *st = state, *tmp;
MPIR_Context_id_t newctxid;
MPIR_Errflag_t errflag = MPIR_ERR_NONE;
if (st->own_eager_mask) {
newctxid = find_and_allocate_context_id(st->local_mask);
if (st->ctx0)
*st->ctx0 = newctxid;
if (st->ctx1)
*st->ctx1 = newctxid;
st->own_eager_mask = 0;
eager_in_use = 0;
}
else if (st->own_mask) {
newctxid = find_and_allocate_context_id(st->local_mask);
if (st->ctx0)
*st->ctx0 = newctxid;
if (st->ctx1)
*st->ctx1 = newctxid;
/* reset flag for the next try */
mask_in_use = 0;
/* If we found a ctx, remove element form list */
if (newctxid > 0) {
if (next_gcn == st) {
next_gcn = st->next;
}
else {
for (tmp = next_gcn; tmp->next != st; tmp = tmp->next);
tmp->next = st->next;
}
}
}
if (*st->ctx0 == 0) {
if (st->local_mask[ALL_OWN_MASK_FLAG] == 1) {
/* --BEGIN ERROR HANDLING-- */
int nfree = 0;
int ntotal = 0;
int minfree;
context_mask_stats(&nfree, &ntotal);
minfree = nfree;
MPID_Allreduce(MPI_IN_PLACE, &minfree, 1, MPI_INT,
MPI_MIN, st->comm_ptr, &errflag);
if (minfree > 0) {
MPIR_ERR_SETANDJUMP3(mpi_errno, MPI_ERR_OTHER,
"**toomanycommfrag", "**toomanycommfrag %d %d %d",
nfree, ntotal, minfree);
}
else {
MPIR_ERR_SETANDJUMP3(mpi_errno, MPI_ERR_OTHER,
"**toomanycomm", "**toomanycomm %d %d %d",
nfree, ntotal, minfree);
}
/* --END ERROR HANDLING-- */
}
else {
/* do not own mask, try again */
if (st->first_iter == 1) {
st->first_iter = 0;
/* Set the Tag for the idup-operations. We have two problems here:
* 1.) The tag should not be used by another (blocking) context_id allocation.
* Therefore, we set tag_up as lower bound for the operation. tag_ub is used by
* most of the other blocking operations, but tag is always >0, so this
* should be fine.
* 2.) We need odering between multiple idup operations on the same communicator.
* The problem here is that the iallreduce operations of the first iteration
* are not necessarily completed in the same order as they are issued, also on the
* same communicator. To avoid deadlocks, we cannot add the elements to the
* list bevfore the first iallreduce is completed. The "tag" is created for the
* scheduling - by calling MPIR_Sched_next_tag(comm_ptr, &tag) - and the same
* for a idup operation on all processes. So we use it here. */
/* FIXME I'm not sure if there can be an overflows for this tag */
st->tag = (uint64_t) tag + MPIR_Process.attrs.tag_ub;
add_gcn_to_list(st);
}
mpi_errno = MPIR_Sched_cb(&sched_cb_gcn_copy_mask, st, st->s);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
MPIR_SCHED_BARRIER(st->s);
}
}
else {
/* Successfully allocated a context id */
mpi_errno = MPIR_Sched_cb(&sched_cb_gcn_bcast, st, st->s);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
MPIR_SCHED_BARRIER(st->s);
}
fn_exit:
return mpi_errno;
fn_fail:
/* make sure that the pending allocations are scheduled */
if (!st->first_iter) {
if (next_gcn == st) {
next_gcn = st->next;
}
else {
for (tmp = next_gcn; tmp && tmp->next != st; tmp = tmp->next);
tmp->next = st->next;
}
}
/* In the case of failure, the new communicator was half created.
* So we need to clean the memory allocated for it. */
MPIR_Comm_map_free(st->new_comm);
MPIR_Handle_obj_free(&MPIR_Comm_mem, st->new_comm);
MPL_free(st);
goto fn_exit;
}
int MPIDU_Type_indexed(int count,
const int *blocklength_array,
const void *displacement_array,
int dispinbytes,
MPI_Datatype oldtype,
MPI_Datatype *newtype)
{
int mpi_errno = MPI_SUCCESS;
int is_builtin, old_is_contig;
int i;
MPI_Aint contig_count;
MPI_Aint el_sz, el_ct, old_ct, old_sz;
MPI_Aint old_lb, old_ub, old_extent, old_true_lb, old_true_ub;
MPI_Aint min_lb = 0, max_ub = 0, eff_disp;
MPI_Datatype el_type;
MPIDU_Datatype *new_dtp;
if (count == 0) return MPIDU_Type_zerolen(newtype);
/* sanity check that blocklens are all non-negative */
for (i = 0; i < count; ++i) {
DLOOP_Assert(blocklength_array[i] >= 0);
}
/* allocate new datatype object and handle */
new_dtp = (MPIDU_Datatype *) MPIR_Handle_obj_alloc(&MPIDU_Datatype_mem);
/* --BEGIN ERROR HANDLING-- */
if (!new_dtp)
{
mpi_errno = MPIR_Err_create_code(MPI_SUCCESS,
MPIR_ERR_RECOVERABLE,
"MPIDU_Type_indexed",
__LINE__,
MPI_ERR_OTHER,
"**nomem",
0);
return mpi_errno;
}
/* --END ERROR HANDLING-- */
/* handle is filled in by MPIR_Handle_obj_alloc() */
MPIR_Object_set_ref(new_dtp, 1);
new_dtp->is_permanent = 0;
new_dtp->is_committed = 0;
new_dtp->attributes = NULL;
new_dtp->cache_id = 0;
new_dtp->name[0] = 0;
new_dtp->contents = NULL;
new_dtp->dataloop = NULL;
new_dtp->dataloop_size = -1;
new_dtp->dataloop_depth = -1;
new_dtp->hetero_dloop = NULL;
new_dtp->hetero_dloop_size = -1;
new_dtp->hetero_dloop_depth = -1;
is_builtin = (HANDLE_GET_KIND(oldtype) == HANDLE_KIND_BUILTIN);
if (is_builtin)
{
/* builtins are handled differently than user-defined types because
* they have no associated dataloop or datatype structure.
*/
el_sz = MPIDU_Datatype_get_basic_size(oldtype);
old_sz = el_sz;
el_ct = 1;
el_type = oldtype;
old_lb = 0;
old_true_lb = 0;
old_ub = (MPI_Aint) el_sz;
old_true_ub = (MPI_Aint) el_sz;
old_extent = (MPI_Aint) el_sz;
old_is_contig = 1;
new_dtp->has_sticky_ub = 0;
new_dtp->has_sticky_lb = 0;
MPIR_Assign_trunc(new_dtp->alignsize, el_sz, MPI_Aint);
new_dtp->builtin_element_size = el_sz;
new_dtp->basic_type = el_type;
new_dtp->max_contig_blocks = count;
}
else
{
/* user-defined base type (oldtype) */
MPIDU_Datatype *old_dtp;
MPIDU_Datatype_get_ptr(oldtype, old_dtp);
/* Ensure that "builtin_element_size" fits into an int datatype. */
MPIR_Ensure_Aint_fits_in_int(old_dtp->builtin_element_size);
el_sz = old_dtp->builtin_element_size;
old_sz = old_dtp->size;
el_ct = old_dtp->n_builtin_elements;
el_type = old_dtp->basic_type;
old_lb = old_dtp->lb;
old_true_lb = old_dtp->true_lb;
old_ub = old_dtp->ub;
old_true_ub = old_dtp->true_ub;
old_extent = old_dtp->extent;
old_is_contig = old_dtp->is_contig;
new_dtp->has_sticky_lb = old_dtp->has_sticky_lb;
new_dtp->has_sticky_ub = old_dtp->has_sticky_ub;
new_dtp->builtin_element_size = (MPI_Aint) el_sz;
new_dtp->basic_type = el_type;
new_dtp->max_contig_blocks = 0;
for(i=0; i<count; i++)
new_dtp->max_contig_blocks
+= old_dtp->max_contig_blocks
* ((MPI_Aint ) blocklength_array[i]);
}
/* find the first nonzero blocklength element */
i = 0;
while (i < count && blocklength_array[i] == 0) i++;
if (i == count) {
MPIR_Handle_obj_free(&MPIDU_Datatype_mem, new_dtp);
return MPIDU_Type_zerolen(newtype);
}
/* priming for loop */
old_ct = blocklength_array[i];
eff_disp = (dispinbytes) ? ((MPI_Aint *) displacement_array)[i] :
(((MPI_Aint) ((int *) displacement_array)[i]) * old_extent);
MPIDU_DATATYPE_BLOCK_LB_UB((MPI_Aint) blocklength_array[i],
eff_disp,
old_lb,
old_ub,
old_extent,
min_lb,
max_ub);
/* determine min lb, max ub, and count of old types in remaining
* nonzero size blocks
*/
for (i++; i < count; i++)
{
MPI_Aint tmp_lb, tmp_ub;
if (blocklength_array[i] > 0) {
old_ct += blocklength_array[i]; /* add more oldtypes */
eff_disp = (dispinbytes) ? ((MPI_Aint *) displacement_array)[i] :
(((MPI_Aint) ((int *) displacement_array)[i]) * old_extent);
/* calculate ub and lb for this block */
MPIDU_DATATYPE_BLOCK_LB_UB((MPI_Aint)(blocklength_array[i]),
eff_disp,
old_lb,
old_ub,
old_extent,
tmp_lb,
tmp_ub);
if (tmp_lb < min_lb) min_lb = tmp_lb;
if (tmp_ub > max_ub) max_ub = tmp_ub;
}
}
new_dtp->size = old_ct * old_sz;
new_dtp->lb = min_lb;
new_dtp->ub = max_ub;
new_dtp->true_lb = min_lb + (old_true_lb - old_lb);
new_dtp->true_ub = max_ub + (old_true_ub - old_ub);
new_dtp->extent = max_ub - min_lb;
new_dtp->n_builtin_elements = old_ct * el_ct;
/* new type is only contig for N types if it's all one big
* block, its size and extent are the same, and the old type
* was also contiguous.
*/
new_dtp->is_contig = 0;
if(old_is_contig)
{
MPI_Aint *blklens = MPL_malloc(count *sizeof(MPI_Aint));
for (i=0; i<count; i++)
blklens[i] = blocklength_array[i];
contig_count = MPIDU_Type_indexed_count_contig(count,
blklens,
displacement_array,
dispinbytes,
old_extent);
new_dtp->max_contig_blocks = contig_count;
if( (contig_count == 1) &&
((MPI_Aint) new_dtp->size == new_dtp->extent))
{
new_dtp->is_contig = 1;
}
MPL_free(blklens);
}
*newtype = new_dtp->handle;
return mpi_errno;
}
/*@
MPI_Win_free_keyval - Frees an attribute key for MPI RMA windows
Input Parameters:
. win_keyval - key value (integer)
.N ThreadSafe
.N Fortran
.N Errors
.N MPI_SUCCESS
.N MPI_ERR_WIN
.N MPI_ERR_OTHER
.N MPI_ERR_KEYVAL
@*/
int MPI_Win_free_keyval(int *win_keyval)
{
#ifdef HAVE_ERROR_CHECKING
static const char FCNAME[] = "MPI_Win_free_keyval";
#endif
int mpi_errno = MPI_SUCCESS;
MPII_Keyval *keyval_ptr = NULL;
int in_use;
MPIR_FUNC_TERSE_STATE_DECL(MPID_STATE_MPI_WIN_FREE_KEYVAL);
MPIR_ERRTEST_INITIALIZED_ORDIE();
MPID_THREAD_CS_ENTER(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX);
MPIR_FUNC_TERSE_ENTER(MPID_STATE_MPI_WIN_FREE_KEYVAL);
/* Validate parameters, especially handles needing to be converted */
# ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
MPIR_ERRTEST_ARGNULL(*win_keyval, "win_keyval", mpi_errno);
MPIR_ERRTEST_KEYVAL(*win_keyval, MPIR_WIN, "window", mpi_errno);
MPIR_ERRTEST_KEYVAL_PERM(*win_keyval, mpi_errno);
}
MPID_END_ERROR_CHECKS;
}
# endif
/* Convert MPI object handles to object pointers */
MPII_Keyval_get_ptr( *win_keyval, keyval_ptr );
/* Validate parameters and objects (post conversion) */
# ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
MPII_Keyval_valid_ptr( keyval_ptr, mpi_errno );
if (mpi_errno) goto fn_fail;
}
MPID_END_ERROR_CHECKS;
}
# endif /* HAVE_ERROR_CHECKING */
/* ... body of routine ... */
if (!keyval_ptr->was_freed) {
keyval_ptr->was_freed = 1;
MPII_Keyval_release_ref( keyval_ptr, &in_use);
if (!in_use) {
MPIR_Handle_obj_free( &MPII_Keyval_mem, keyval_ptr );
}
}
*win_keyval = MPI_KEYVAL_INVALID;
/* ... end of body of routine ... */
#ifdef HAVE_ERROR_CHECKING
fn_exit:
#endif
MPIR_FUNC_TERSE_EXIT(MPID_STATE_MPI_WIN_FREE_KEYVAL);
MPID_THREAD_CS_EXIT(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX);
return mpi_errno;
/* --BEGIN ERROR HANDLING-- */
# ifdef HAVE_ERROR_CHECKING
fn_fail:
{
mpi_errno = MPIR_Err_create_code(
mpi_errno, MPIR_ERR_RECOVERABLE, FCNAME, __LINE__, MPI_ERR_OTHER,
"**mpi_win_free_keyval",
"**mpi_win_free_keyval %p", win_keyval);
}
mpi_errno = MPIR_Err_return_comm( NULL, FCNAME, mpi_errno );
goto fn_exit;
# endif
/* --END ERROR HANDLING-- */
}
void MPID_Attr_free(MPIR_Attribute * attr_ptr)
{
MPIR_Handle_obj_free(&MPID_Attr_mem, attr_ptr);
}
/*@
MPI_Type_delete_attr - Deletes an attribute value associated with a key on
a datatype
Input Parameters:
+ datatype - MPI datatype to which attribute is attached (handle)
- type_keyval - The key value of the deleted attribute (integer)
.N ThreadSafe
.N Fortran
.N Errors
.N MPI_SUCCESS
.N MPI_ERR_OTHER
.N MPI_ERR_KEYVAL
@*/
int MPI_Type_delete_attr(MPI_Datatype datatype, int type_keyval)
{
static const char FCNAME[] = "MPI_Type_delete_attr";
int mpi_errno = MPI_SUCCESS;
MPIR_Datatype *type_ptr = NULL;
MPIR_Attribute *p, **old_p;
MPII_Keyval *keyval_ptr = 0;
MPIR_FUNC_TERSE_STATE_DECL(MPID_STATE_MPI_TYPE_DELETE_ATTR);
MPIR_ERRTEST_INITIALIZED_ORDIE();
/* The thread lock prevents a valid attr delete on the same datatype
but in a different thread from causing problems */
MPID_THREAD_CS_ENTER(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX);
MPIR_FUNC_TERSE_ENTER(MPID_STATE_MPI_TYPE_DELETE_ATTR);
/* Validate parameters, especially handles needing to be converted */
# ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
MPIR_ERRTEST_DATATYPE(datatype, "datatype", mpi_errno);
MPIR_ERRTEST_KEYVAL(type_keyval, MPIR_DATATYPE, "datatype", mpi_errno);
MPIR_ERRTEST_KEYVAL_PERM(type_keyval, mpi_errno);
}
MPID_END_ERROR_CHECKS;
}
# endif
/* Validate parameters and objects (post conversion) */
MPID_Datatype_get_ptr( datatype, type_ptr );
MPII_Keyval_get_ptr( type_keyval, keyval_ptr );
/* Validate parameters and objects (post conversion) */
# ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
/* Validate type_ptr */
MPIR_Datatype_valid_ptr( type_ptr, mpi_errno );
/* If type_ptr is not valid, it will be reset to null */
/* Validate keyval_ptr */
if (mpi_errno) goto fn_fail;
}
MPID_END_ERROR_CHECKS;
}
# endif /* HAVE_ERROR_CHECKING */
/* ... body of routine ... */
/* Look for attribute. They are ordered by keyval handle */
old_p = &type_ptr->attributes;
p = type_ptr->attributes;
while (p)
{
if (p->keyval->handle == keyval_ptr->handle)
{
break;
}
old_p = &p->next;
p = p->next;
}
/* We can't unlock yet, because we must not free the attribute until
we know whether the delete function has returned with a 0 status
code */
if (p)
{
/* Run the delete function, if any, and then free the attribute
storage */
mpi_errno = MPIR_Call_attr_delete( datatype, p );
/* --BEGIN ERROR HANDLING-- */
if (!mpi_errno)
{
int in_use;
/* We found the attribute. Remove it from the list */
*old_p = p->next;
/* Decrement the use of the keyval */
MPII_Keyval_release_ref( p->keyval, &in_use);
if (!in_use)
{
MPIR_Handle_obj_free( &MPII_Keyval_mem, p->keyval );
}
MPID_Attr_free(p);
}
/* --END ERROR HANDLING-- */
}
if (mpi_errno != MPI_SUCCESS) goto fn_fail;
/* ... end of body of routine ... */
fn_exit:
MPIR_FUNC_TERSE_EXIT(MPID_STATE_MPI_TYPE_DELETE_ATTR);
MPID_THREAD_CS_EXIT(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX);
return mpi_errno;
fn_fail:
/* --BEGIN ERROR HANDLING-- */
# ifdef HAVE_ERROR_CHECKING
{
mpi_errno = MPIR_Err_create_code(
mpi_errno, MPIR_ERR_RECOVERABLE, FCNAME, __LINE__, MPI_ERR_OTHER,
"**mpi_type_delete_attr",
"**mpi_type_delete_attr %D %d", datatype, type_keyval);
}
# endif
mpi_errno = MPIR_Err_return_comm( NULL, FCNAME, mpi_errno );
goto fn_exit;
/* --END ERROR HANDLING-- */
}
/*@
MPI_Finalize - Terminates MPI execution environment
Notes:
All processes must call this routine before exiting. The number of
processes running `after` this routine is called is undefined;
it is best not to perform much more than a 'return rc' after calling
'MPI_Finalize'.
Thread and Signal Safety:
The MPI standard requires that 'MPI_Finalize' be called `only` by the same
thread that initialized MPI with either 'MPI_Init' or 'MPI_Init_thread'.
.N Fortran
.N Errors
.N MPI_SUCCESS
@*/
int MPI_Finalize( void )
{
static const char FCNAME[] = "MPI_Finalize";
int mpi_errno = MPI_SUCCESS;
#if defined(HAVE_USLEEP) && defined(USE_COVERAGE)
int rank=0;
#endif
MPIR_FUNC_TERSE_FINALIZE_STATE_DECL(MPID_STATE_MPI_FINALIZE);
MPIR_ERRTEST_INITIALIZED_ORDIE();
/* Note: Only one thread may ever call MPI_Finalize (MPI_Finalize may
be called at most once in any program) */
MPID_THREAD_CS_ENTER(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX);
MPIR_FUNC_TERSE_FINALIZE_ENTER(MPID_STATE_MPI_FINALIZE);
/* ... body of routine ... */
/* If the user requested for asynchronous progress, we need to
* shutdown the progress thread */
if (MPIR_async_thread_initialized) {
mpi_errno = MPIR_Finalize_async_thread();
if (mpi_errno) goto fn_fail;
}
#if defined(HAVE_USLEEP) && defined(USE_COVERAGE)
/* We need to get the rank before freeing MPI_COMM_WORLD */
rank = MPIR_Process.comm_world->rank;
#endif
/* Remove the attributes, executing the attribute delete routine.
Do this only if the attribute functions are defined. */
/* The standard (MPI-2, section 4.8) says that the attributes on
MPI_COMM_SELF are deleted before almost anything else happens */
/* Note that the attributes need to be removed from the communicators
so that they aren't freed twice. (The communicators are released
in MPID_Finalize) */
if (MPIR_Process.attr_free && MPIR_Process.comm_self->attributes) {
mpi_errno = MPIR_Process.attr_free( MPI_COMM_SELF,
&MPIR_Process.comm_self->attributes);
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
MPIR_Process.comm_self->attributes = 0;
}
if (MPIR_Process.attr_free && MPIR_Process.comm_world->attributes) {
mpi_errno = MPIR_Process.attr_free( MPI_COMM_WORLD,
&MPIR_Process.comm_world->attributes);
if (mpi_errno) MPIR_ERR_POP(mpi_errno);
MPIR_Process.comm_world->attributes = 0;
}
/*
* Now that we're finalizing, we need to take control of the error handlers
* At this point, we will release any user-defined error handlers on
* comm self and comm world
*/
if (MPIR_Process.comm_world->errhandler &&
! (HANDLE_GET_KIND(MPIR_Process.comm_world->errhandler->handle) ==
HANDLE_KIND_BUILTIN) ) {
int in_use;
MPIR_Errhandler_release_ref( MPIR_Process.comm_world->errhandler,
&in_use);
if (!in_use) {
MPIR_Handle_obj_free( &MPIR_Errhandler_mem,
MPIR_Process.comm_world->errhandler );
}
/* always set to NULL to avoid a double-release later in finalize */
MPIR_Process.comm_world->errhandler = NULL;
}
if (MPIR_Process.comm_self->errhandler &&
! (HANDLE_GET_KIND(MPIR_Process.comm_self->errhandler->handle) ==
HANDLE_KIND_BUILTIN) ) {
int in_use;
MPIR_Errhandler_release_ref( MPIR_Process.comm_self->errhandler,
&in_use);
if (!in_use) {
MPIR_Handle_obj_free( &MPIR_Errhandler_mem,
MPIR_Process.comm_self->errhandler );
}
/* always set to NULL to avoid a double-release later in finalize */
MPIR_Process.comm_self->errhandler = NULL;
}
/* FIXME: Why is this not one of the finalize callbacks?. Do we need
pre and post MPID_Finalize callbacks? */
MPII_Timer_finalize();
/* Call the high-priority callbacks */
MPIR_Call_finalize_callbacks( MPIR_FINALIZE_CALLBACK_PRIO+1,
MPIR_FINALIZE_CALLBACK_MAX_PRIO );
/* Signal the debugger that we are about to exit. */
/* FIXME: Should this also be a finalize callback? */
#ifdef HAVE_DEBUGGER_SUPPORT
MPIR_Debugger_set_aborting( (char *)0 );
#endif
mpi_errno = MPID_Finalize();
if (mpi_errno) {
MPIR_ERR_POP(mpi_errno);
}
/* Call the low-priority (post Finalize) callbacks */
MPIR_Call_finalize_callbacks( 0, MPIR_FINALIZE_CALLBACK_PRIO-1 );
/* At this point, if there has been a failure, exit before
completing the finalize */
if (mpi_errno != MPI_SUCCESS) goto fn_fail;
/* Users did not call MPI_T_init_thread(), so we free memories allocated to
* MPIR_T during MPI_Init here. Otherwise, free them in MPI_T_finalize() */
if (!MPIR_T_is_initialized())
MPIR_T_env_finalize();
/* FIXME: Many of these debugging items could/should be callbacks,
added to the finalize callback list */
/* FIXME: the memory tracing code block should be a finalize callback */
/* If memory debugging is enabled, check the memory here, after all
finalize callbacks */
MPID_THREAD_CS_EXIT(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX);
OPA_store_int(&MPIR_Process.mpich_state, MPICH_MPI_STATE__POST_FINALIZED);
#if defined(MPICH_IS_THREADED)
MPIR_Thread_CS_Finalize();
#endif
/* We place the memory tracing at the very end because any of the other
steps may have allocated memory that they still need to release*/
#ifdef USE_MEMORY_TRACING
/* FIXME: We'd like to arrange for the mem dump output to
go to separate files or to be sorted by rank (note that
the rank is at the head of the line) */
{
if (MPIR_CVAR_MEMDUMP) {
/* The second argument is the min id to print; memory allocated
after MPI_Init is given an id of one. This allows us to
ignore, if desired, memory leaks in the MPID_Init call */
MPL_trdump( (void *)0, -1 );
}
}
#endif
#if defined(HAVE_USLEEP) && defined(USE_COVERAGE)
/* If performing coverage analysis, make each process sleep for
rank * 100 ms, to give time for the coverage tool to write out
any files. It would be better if the coverage tool and runtime
was more careful about file updates, though the lack of OS support
for atomic file updates makes this harder. */
/*
On some systems, a 0.1 second delay appears to be too short for
the file system. This code allows the use of the environment
variable MPICH_FINALDELAY, which is the delay in milliseconds.
It must be an integer value.
*/
{
int microseconds = 100000;
char *delayStr = getenv( "MPICH_FINALDELAY" );
if (delayStr) {
/* Because this is a maintainer item, we won't check for
errors in the delayStr */
microseconds = 1000 * atoi( delayStr );
}
usleep( rank * microseconds );
}
#endif
/* ... end of body of routine ... */
fn_exit:
MPIR_FUNC_TERSE_FINALIZE_EXIT(MPID_STATE_MPI_FINALIZE);
return mpi_errno;
fn_fail:
/* --BEGIN ERROR HANDLING-- */
# ifdef HAVE_ERROR_CHECKING
{
mpi_errno = MPIR_Err_create_code(mpi_errno, MPIR_ERR_RECOVERABLE,
FCNAME, __LINE__, MPI_ERR_OTHER, "**mpi_finalize", 0);
}
# endif
mpi_errno = MPIR_Err_return_comm( 0, FCNAME, mpi_errno );
if (OPA_load_int(&MPIR_Process.mpich_state) < MPICH_MPI_STATE__POST_FINALIZED) {
MPID_THREAD_CS_EXIT(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX);
}
goto fn_exit;
/* --END ERROR HANDLING-- */
}
