/* Routine to delete an attribute list */
int MPIR_Attr_delete_list( int handle, MPID_Attribute **attr )
{
MPID_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 */
MPIR_Keyval_release_ref( p->keyval, &in_use);
if (!in_use) {
MPIU_Handle_obj_free( &MPID_Keyval_mem, p->keyval );
}
}
MPIU_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, MPID_Group **new_group_ptr )
{
int mpi_errno = MPI_SUCCESS;
*new_group_ptr = (MPID_Group *)MPIU_Handle_obj_alloc( &MPID_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-- */
MPIU_Object_set_ref( *new_group_ptr, 1 );
(*new_group_ptr)->lrank_to_lpid =
(MPID_Group_pmap_t *)MPIU_Malloc( nproc * sizeof(MPID_Group_pmap_t) );
/* --BEGIN ERROR HANDLING-- */
if (!(*new_group_ptr)->lrank_to_lpid) {
MPIU_Handle_obj_free( &MPID_Group_mem, *new_group_ptr );
*new_group_ptr = NULL;
MPIU_CHKMEM_SETERR(mpi_errno,nproc*sizeof(MPID_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;
}
void MPIDI_CH3_Request_destroy(MPID_Request * req)
{
MPIDI_STATE_DECL(MPID_STATE_MPIDI_CH3_REQUEST_DESTROY);
MPIDI_FUNC_ENTER(MPID_STATE_MPIDI_CH3_REQUEST_DESTROY);
MPIU_DBG_MSG_P(CH3_CHANNEL,VERBOSE,
"freeing request, handle=0x%08x", req->handle);
#ifdef MPICH_DBG_OUTPUT
/*MPIU_Assert(HANDLE_GET_MPI_KIND(req->handle) == MPID_REQUEST);*/
if (HANDLE_GET_MPI_KIND(req->handle) != MPID_REQUEST)
{
int mpi_errno = MPIR_Err_create_code(MPI_SUCCESS, MPIR_ERR_FATAL,
FCNAME, __LINE__, MPI_ERR_OTHER,
"**invalid_handle", "**invalid_handle %d", req->handle);
MPID_Abort(MPIR_Process.comm_world, mpi_errno, -1, NULL);
}
/* XXX DJG FIXME should we be checking this? */
/*MPIU_Assert(req->ref_count == 0);*/
if (req->ref_count != 0)
{
int mpi_errno = MPIR_Err_create_code(MPI_SUCCESS, MPIR_ERR_FATAL,
FCNAME, __LINE__, MPI_ERR_OTHER,
"**invalid_refcount", "**invalid_refcount %d", req->ref_count);
MPID_Abort(MPIR_Process.comm_world, mpi_errno, -1, NULL);
}
#endif
/* FIXME: We need a better way to handle these so that we
do not always need to initialize these fields and check them
when we destroy a request */
/* FIXME: We need a way to call these routines ONLY when the
related ref count has become zero. */
if (req->comm != NULL) {
MPIR_Comm_release(req->comm, 0);
}
if (req->greq_fns != NULL) {
MPIU_Free(req->greq_fns);
}
if (req->dev.datatype_ptr != NULL) {
MPID_Datatype_release(req->dev.datatype_ptr);
}
if (req->dev.segment_ptr != NULL) {
MPID_Segment_free(req->dev.segment_ptr);
}
if (MPIDI_Request_get_srbuf_flag(req)) {
MPIDI_CH3U_SRBuf_free(req);
}
MPIU_Handle_obj_free(&MPID_Request_mem, req);
MPIDI_FUNC_EXIT(MPID_STATE_MPIDI_CH3_REQUEST_DESTROY);
}
void MPIU_Info_free( MPID_Info *info_ptr )
{
MPID_Info *curr_ptr, *last_ptr;
curr_ptr = info_ptr->next;
last_ptr = NULL;
MPIU_Handle_obj_free(&MPID_Info_mem, info_ptr);
/* printf( "Returning info %x\n", info_ptr->id ); */
/* First, free the string storage */
while (curr_ptr) {
MPIU_Free(curr_ptr->key);
MPIU_Free(curr_ptr->value);
last_ptr = curr_ptr;
curr_ptr = curr_ptr->next;
MPIU_Handle_obj_free(&MPID_Info_mem, last_ptr);
}
}
int MPIR_Group_release(MPID_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. */
MPIU_Free(group_ptr->lrank_to_lpid);
MPIU_Handle_obj_free( &MPID_Group_mem, group_ptr );
}
return mpi_errno;
}
void MPIR_Comm_free_keyval_impl(int keyval)
{
int in_use;
MPID_Keyval *keyval_ptr;
MPID_Keyval_get_ptr(keyval, keyval_ptr);
if (!keyval_ptr->was_freed) {
keyval_ptr->was_freed = 1;
MPIR_Keyval_release_ref( keyval_ptr, &in_use);
if (!in_use) {
MPIU_Handle_obj_free( &MPID_Keyval_mem, keyval_ptr );
}
}
return;
}
int MPIDI_Win_free(MPID_Win **win_ptr)
{
int mpi_errno=MPI_SUCCESS;
int in_use;
MPID_Comm *comm_ptr;
MPIDI_STATE_DECL(MPID_STATE_MPIDI_WIN_FREE);
MPIDI_RMA_FUNC_ENTER(MPID_STATE_MPIDI_WIN_FREE);
MPIU_ERR_CHKANDJUMP((*win_ptr)->epoch_state != MPIDI_EPOCH_NONE,
mpi_errno, MPI_ERR_RMA_SYNC, "**rmasync");
mpi_errno = MPIDI_CH3I_Wait_for_pt_ops_finish(*win_ptr);
if(mpi_errno) MPIU_ERR_POP(mpi_errno);
comm_ptr = (*win_ptr)->comm_ptr;
mpi_errno = MPIR_Comm_free_impl(comm_ptr);
if (mpi_errno) MPIU_ERR_POP(mpi_errno);
MPIU_Free((*win_ptr)->targets);
MPIU_Free((*win_ptr)->base_addrs);
MPIU_Free((*win_ptr)->sizes);
MPIU_Free((*win_ptr)->disp_units);
MPIU_Free((*win_ptr)->all_win_handles);
MPIU_Free((*win_ptr)->pt_rma_puts_accs);
/* 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) {
MPIU_Free((*win_ptr)->base);
}
}
MPIU_Object_release_ref(*win_ptr, &in_use);
/* MPI windows don't have reference count semantics, so this should always be true */
MPIU_Assert(!in_use);
MPIU_Handle_obj_free( &MPID_Win_mem, *win_ptr );
fn_exit:
MPIDI_RMA_FUNC_EXIT(MPID_STATE_MPIDI_WIN_FREE);
return mpi_errno;
fn_fail:
goto fn_exit;
}
/*@
MPID_Type_struct - create a struct datatype
Input Parameters:
+ count - number of blocks in vector
. blocklength_array - number of elements in each block
. displacement_array - offsets of blocks from start of type in bytes
- oldtype_array - types (using handle) of datatypes on which vector is based
Output Parameters:
. newtype - handle of new struct datatype
Return Value:
MPI_SUCCESS on success, MPI errno on failure.
@*/
int MPID_Type_struct(int count,
const int *blocklength_array,
const MPI_Aint *displacement_array,
const MPI_Datatype *oldtype_array,
MPI_Datatype *newtype)
{
int mpi_errno = MPI_SUCCESS;
int i, old_are_contig = 1, definitely_not_contig = 0;
int found_sticky_lb = 0, found_sticky_ub = 0, found_true_lb = 0,
found_true_ub = 0, found_el_type = 0, found_lb=0, found_ub=0;
MPI_Aint el_sz = 0;
MPI_Aint size = 0;
MPI_Datatype el_type = MPI_DATATYPE_NULL;
MPI_Aint true_lb_disp = 0, true_ub_disp = 0, sticky_lb_disp = 0,
sticky_ub_disp = 0, lb_disp = 0, ub_disp = 0;
MPID_Datatype *new_dtp;
if (count == 0) return MPID_Type_zerolen(newtype);
#ifdef MPID_STRUCT_DEBUG
MPIDI_Datatype_printf(oldtype_array[0], 1, displacement_array[0],
blocklength_array[0], 1);
for (i=1; i < count; i++)
{
MPIDI_Datatype_printf(oldtype_array[i], 1, displacement_array[i],
blocklength_array[i], 0);
}
#endif
/* allocate new datatype object and handle */
new_dtp = (MPID_Datatype *) MPIU_Handle_obj_alloc(&MPID_Datatype_mem);
/* --BEGIN ERROR HANDLING-- */
if (!new_dtp)
{
mpi_errno = MPIR_Err_create_code(MPI_SUCCESS, MPIR_ERR_RECOVERABLE,
"MPID_Type_struct",
__LINE__, MPI_ERR_OTHER,
"**nomem", 0);
return mpi_errno;
}
/* --END ERROR HANDLING-- */
/* handle is filled in by MPIU_Handle_obj_alloc() */
MPIU_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;
/* check for junk struct with all zero blocks */
for (i=0; i < count; i++) if (blocklength_array[i] != 0) break;
if (i == count)
{
MPIU_Handle_obj_free(&MPID_Datatype_mem, new_dtp);
return MPID_Type_zerolen(newtype);
}
new_dtp->max_contig_blocks = 0;
for (i=0; i < count; i++)
{
int is_builtin =
(HANDLE_GET_KIND(oldtype_array[i]) == HANDLE_KIND_BUILTIN);
MPI_Aint tmp_lb, tmp_ub, tmp_true_lb, tmp_true_ub;
MPI_Aint tmp_el_sz;
MPI_Datatype tmp_el_type;
MPID_Datatype *old_dtp = NULL;
/* Interpreting typemap to not include 0 blklen things, including
* MPI_LB and MPI_UB. -- Rob Ross, 10/31/2005
*/
if (blocklength_array[i] == 0) continue;
if (is_builtin)
{
tmp_el_sz = MPID_Datatype_get_basic_size(oldtype_array[i]);
tmp_el_type = oldtype_array[i];
MPID_DATATYPE_BLOCK_LB_UB((MPI_Aint)(blocklength_array[i]),
displacement_array[i],
0,
tmp_el_sz,
tmp_el_sz,
tmp_lb,
tmp_ub);
tmp_true_lb = tmp_lb;
tmp_true_ub = tmp_ub;
size += tmp_el_sz * blocklength_array[i];
new_dtp->max_contig_blocks++;
}
else
{
MPID_Datatype_get_ptr(oldtype_array[i], old_dtp);
/* Ensure that "builtin_element_size" fits into an int datatype. */
MPID_Ensure_Aint_fits_in_int(old_dtp->builtin_element_size);
tmp_el_sz = old_dtp->builtin_element_size;
tmp_el_type = old_dtp->basic_type;
MPID_DATATYPE_BLOCK_LB_UB((MPI_Aint) blocklength_array[i],
displacement_array[i],
old_dtp->lb,
old_dtp->ub,
old_dtp->extent,
tmp_lb,
tmp_ub);
tmp_true_lb = tmp_lb + (old_dtp->true_lb - old_dtp->lb);
tmp_true_ub = tmp_ub + (old_dtp->true_ub - old_dtp->ub);
size += old_dtp->size * blocklength_array[i];
new_dtp->max_contig_blocks += old_dtp->max_contig_blocks;
}
/* element size and type */
if (oldtype_array[i] != MPI_LB && oldtype_array[i] != MPI_UB)
{
if (found_el_type == 0)
{
el_sz = tmp_el_sz;
el_type = tmp_el_type;
found_el_type = 1;
}
else if (el_sz != tmp_el_sz)
{
el_sz = -1;
el_type = MPI_DATATYPE_NULL;
}
else if (el_type != tmp_el_type)
{
/* Q: should we set el_sz = -1 even though the same? */
el_type = MPI_DATATYPE_NULL;
}
}
/* keep lowest sticky lb */
if ((oldtype_array[i] == MPI_LB) ||
(!is_builtin && old_dtp->has_sticky_lb))
{
if (!found_sticky_lb)
{
found_sticky_lb = 1;
sticky_lb_disp = tmp_lb;
}
else if (sticky_lb_disp > tmp_lb)
{
sticky_lb_disp = tmp_lb;
}
}
/* keep highest sticky ub */
if ((oldtype_array[i] == MPI_UB) ||
(!is_builtin && old_dtp->has_sticky_ub))
{
if (!found_sticky_ub)
{
found_sticky_ub = 1;
sticky_ub_disp = tmp_ub;
}
else if (sticky_ub_disp < tmp_ub)
{
sticky_ub_disp = tmp_ub;
}
}
/* keep lowest lb/true_lb and highest ub/true_ub
*
* note: checking for contiguity at the same time, to avoid
* yet another pass over the arrays
*/
if (oldtype_array[i] != MPI_UB && oldtype_array[i] != MPI_LB)
{
if (!found_true_lb)
{
found_true_lb = 1;
true_lb_disp = tmp_true_lb;
}
else if (true_lb_disp > tmp_true_lb)
{
/* element starts before previous */
true_lb_disp = tmp_true_lb;
definitely_not_contig = 1;
}
if (!found_lb)
{
found_lb = 1;
lb_disp = tmp_lb;
}
else if (lb_disp > tmp_lb)
{
/* lb before previous */
lb_disp = tmp_lb;
definitely_not_contig = 1;
}
if (!found_true_ub)
{
found_true_ub = 1;
true_ub_disp = tmp_true_ub;
}
else if (true_ub_disp < tmp_true_ub)
{
true_ub_disp = tmp_true_ub;
}
else {
/* element ends before previous ended */
definitely_not_contig = 1;
}
if (!found_ub)
{
found_ub = 1;
ub_disp = tmp_ub;
}
else if (ub_disp < tmp_ub)
{
ub_disp = tmp_ub;
}
else {
/* ub before previous */
definitely_not_contig = 1;
}
}
if (!is_builtin && !old_dtp->is_contig)
{
old_are_contig = 0;
}
}
new_dtp->n_builtin_elements = -1; /* TODO */
new_dtp->builtin_element_size = el_sz;
new_dtp->basic_type = el_type;
new_dtp->has_sticky_lb = found_sticky_lb;
new_dtp->true_lb = true_lb_disp;
new_dtp->lb = (found_sticky_lb) ? sticky_lb_disp : lb_disp;
new_dtp->has_sticky_ub = found_sticky_ub;
new_dtp->true_ub = true_ub_disp;
new_dtp->ub = (found_sticky_ub) ? sticky_ub_disp : ub_disp;
new_dtp->alignsize = MPID_Type_struct_alignsize(count,
oldtype_array,
displacement_array);
new_dtp->extent = new_dtp->ub - new_dtp->lb;
if ((!found_sticky_lb) && (!found_sticky_ub))
{
/* account for padding */
MPI_Aint epsilon = (new_dtp->alignsize > 0) ?
new_dtp->extent % ((MPI_Aint)(new_dtp->alignsize)) : 0;
if (epsilon)
{
new_dtp->ub += ((MPI_Aint)(new_dtp->alignsize) - epsilon);
new_dtp->extent = new_dtp->ub - new_dtp->lb;
}
}
new_dtp->size = size;
/* new type is contig for N types if its size and extent are the
* same, and the old type was also contiguous, and we didn't see
* something noncontiguous based on true ub/ub.
*/
if (((MPI_Aint)(new_dtp->size) == new_dtp->extent) &&
old_are_contig && (! definitely_not_contig))
{
new_dtp->is_contig = 1;
}
else
{
new_dtp->is_contig = 0;
}
*newtype = new_dtp->handle;
return mpi_errno;
}
/*@
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
MPID_MPI_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) */
MPIU_THREAD_CS_ENTER(ALLFUNC,);
MPID_MPI_FINALIZE_FUNC_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);
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);
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
*/
/* no MPI_OBJ CS needed here */
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) {
MPIU_Handle_obj_free( &MPID_Errhandler_mem,
MPIR_Process.comm_world->errhandler );
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) {
MPIU_Handle_obj_free( &MPID_Errhandler_mem,
MPIR_Process.comm_self->errhandler );
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? */
MPIU_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_DebuggerSetAborting( (char *)0 );
#endif
mpi_errno = MPID_Finalize();
if (mpi_errno) {
MPIU_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;
/* 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 */
MPIU_THREAD_CS_EXIT(ALLFUNC,);
MPIR_Process.initialized = MPICH_POST_FINALIZED;
MPIU_THREAD_CS_FINALIZE;
/* 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_PARAM_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 */
MPIU_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:
MPID_MPI_FINALIZE_FUNC_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 (MPIR_Process.initialized < MPICH_POST_FINALIZED) {
MPIU_THREAD_CS_EXIT(ALLFUNC,);
}
static int sched_cb_gcn_allocate_cid(MPID_Comm * comm, int tag, void *state)
{
int mpi_errno = MPI_SUCCESS;
struct gcn_state *st = state, *tmp;
MPIU_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;
MPIR_Allreduce_impl(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 MPID_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 = MPID_Sched_cb(&sched_cb_gcn_copy_mask, st, st->s);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
MPID_SCHED_BARRIER(st->s);
}
}
else {
/* Successfully allocated a context id */
mpi_errno = MPID_Sched_cb(&sched_cb_gcn_bcast, st, st->s);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
MPID_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);
MPIU_Handle_obj_free(&MPID_Comm_mem, st->new_comm);
MPIU_Free(st);
goto fn_exit;
}
int MPIDI_Win_free(MPID_Win **win_ptr)
{
int mpi_errno=MPI_SUCCESS, total_pt_rma_puts_accs;
int in_use;
MPID_Comm *comm_ptr;
int errflag = FALSE;
MPIDI_STATE_DECL(MPID_STATE_MPIDI_WIN_FREE);
MPIDI_RMA_FUNC_ENTER(MPID_STATE_MPIDI_WIN_FREE);
comm_ptr = (*win_ptr)->comm_ptr;
MPIU_INSTR_DURATION_START(winfree_rs);
mpi_errno = MPIR_Reduce_scatter_block_impl((*win_ptr)->pt_rma_puts_accs,
&total_pt_rma_puts_accs, 1,
MPI_INT, MPI_SUM, comm_ptr, &errflag);
if (mpi_errno) { MPIU_ERR_POP(mpi_errno); }
MPIU_ERR_CHKANDJUMP(errflag, mpi_errno, MPI_ERR_OTHER, "**coll_fail");
MPIU_INSTR_DURATION_END(winfree_rs);
if (total_pt_rma_puts_accs != (*win_ptr)->my_pt_rma_puts_accs)
{
MPID_Progress_state progress_state;
/* poke the progress engine until the two are equal */
MPIU_INSTR_DURATION_START(winfree_complete);
MPID_Progress_start(&progress_state);
while (total_pt_rma_puts_accs != (*win_ptr)->my_pt_rma_puts_accs)
{
mpi_errno = MPID_Progress_wait(&progress_state);
/* --BEGIN ERROR HANDLING-- */
if (mpi_errno != MPI_SUCCESS)
{
MPID_Progress_end(&progress_state);
MPIU_ERR_SETANDJUMP(mpi_errno,MPI_ERR_OTHER,"**winnoprogress");
}
/* --END ERROR HANDLING-- */
}
MPID_Progress_end(&progress_state);
MPIU_INSTR_DURATION_END(winfree_complete);
}
mpi_errno = MPIR_Comm_free_impl(comm_ptr);
if (mpi_errno) MPIU_ERR_POP(mpi_errno);
MPIU_Free((*win_ptr)->base_addrs);
MPIU_Free((*win_ptr)->disp_units);
MPIU_Free((*win_ptr)->all_win_handles);
MPIU_Free((*win_ptr)->pt_rma_puts_accs);
MPIU_Object_release_ref(*win_ptr, &in_use);
/* MPI windows don't have reference count semantics, so this should always be true */
MPIU_Assert(!in_use);
MPIU_Handle_obj_free( &MPID_Win_mem, *win_ptr );
fn_exit:
MPIDI_RMA_FUNC_EXIT(MPID_STATE_MPIDI_WIN_FREE);
return mpi_errno;
fn_fail:
goto fn_exit;
}
int MPIR_Comm_delete_internal(MPID_Comm * comm_ptr)
{
int in_use;
int mpi_errno = MPI_SUCCESS;
MPID_MPI_STATE_DECL(MPID_STATE_COMM_DELETE_INTERNAL);
MPID_MPI_FUNC_ENTER(MPID_STATE_COMM_DELETE_INTERNAL);
MPIU_Assert(MPIU_Object_get_ref(comm_ptr) == 0); /* sanity check */
/* Remove the attributes, executing the attribute delete routine.
* Do this only if the attribute functions are defined.
* This must be done first, because if freeing the attributes
* returns an error, the communicator is not freed */
if (MPIR_Process.attr_free && comm_ptr->attributes) {
/* Temporarily add a reference to this communicator because
* the attr_free code requires a valid communicator */
MPIU_Object_add_ref(comm_ptr);
mpi_errno = MPIR_Process.attr_free(comm_ptr->handle, &comm_ptr->attributes);
/* Release the temporary reference added before the call to
* attr_free */
MPIU_Object_release_ref(comm_ptr, &in_use);
}
/* If the attribute delete functions return failure, the
* communicator must not be freed. That is the reason for the
* test on mpi_errno here. */
if (mpi_errno == MPI_SUCCESS) {
/* If this communicator is our parent, and we're disconnecting
* from the parent, mark that fact */
if (MPIR_Process.comm_parent == comm_ptr)
MPIR_Process.comm_parent = NULL;
/* Notify the device that the communicator is about to be
* destroyed */
mpi_errno = MPID_Dev_comm_destroy_hook(comm_ptr);
if (mpi_errno)
MPIR_ERR_POP(mpi_errno);
/* Free info hints */
if (comm_ptr->info != NULL) {
MPIU_Info_free(comm_ptr->info);
}
/* release our reference to the collops structure, comes after the
* destroy_hook to allow the device to manage these vtables in a custom
* fashion */
if (comm_ptr->coll_fns && --comm_ptr->coll_fns->ref_count == 0) {
MPIU_Free(comm_ptr->coll_fns);
comm_ptr->coll_fns = NULL;
}
if (comm_ptr->comm_kind == MPID_INTERCOMM && comm_ptr->local_comm)
MPIR_Comm_release(comm_ptr->local_comm);
/* Free the local and remote groups, if they exist */
if (comm_ptr->local_group)
MPIR_Group_release(comm_ptr->local_group);
if (comm_ptr->remote_group)
MPIR_Group_release(comm_ptr->remote_group);
/* free the intra/inter-node communicators, if they exist */
if (comm_ptr->node_comm)
MPIR_Comm_release(comm_ptr->node_comm);
if (comm_ptr->node_roots_comm)
MPIR_Comm_release(comm_ptr->node_roots_comm);
if (comm_ptr->intranode_table != NULL)
MPIU_Free(comm_ptr->intranode_table);
if (comm_ptr->internode_table != NULL)
MPIU_Free(comm_ptr->internode_table);
/* Free the context value. This should come after freeing the
* intra/inter-node communicators since those free calls won't
* release this context ID and releasing this before then could lead
* to races once we make threading finer grained. */
/* This must be the recvcontext_id (i.e. not the (send)context_id)
* because in the case of intercommunicators the send context ID is
* allocated out of the remote group's bit vector, not ours. */
MPIR_Free_contextid(comm_ptr->recvcontext_id);
/* We need to release the error handler */
if (comm_ptr->errhandler &&
!(HANDLE_GET_KIND(comm_ptr->errhandler->handle) == HANDLE_KIND_BUILTIN)) {
int errhInuse;
MPIR_Errhandler_release_ref(comm_ptr->errhandler, &errhInuse);
if (!errhInuse) {
MPIU_Handle_obj_free(&MPID_Errhandler_mem, comm_ptr->errhandler);
}
}
/* Remove from the list of active communicators if
* we are supporting message-queue debugging. We make this
* conditional on having debugger support since the
* operation is not constant-time */
MPIR_COMML_FORGET(comm_ptr);
/* Check for predefined communicators - these should not
* be freed */
if (!(HANDLE_GET_KIND(comm_ptr->handle) == HANDLE_KIND_BUILTIN))
MPIU_Handle_obj_free(&MPID_Comm_mem, comm_ptr);
}
else {
/* If the user attribute free function returns an error,
* then do not free the communicator */
MPIR_Comm_add_ref(comm_ptr);
}
fn_exit:
MPID_MPI_FUNC_EXIT(MPID_STATE_COMM_DELETE_INTERNAL);
return mpi_errno;
fn_fail:
goto fn_exit;
}
/*@
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;
MPID_Datatype *type_ptr = NULL;
MPID_Attribute *p, **old_p;
MPID_Keyval *keyval_ptr = 0;
MPID_MPI_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 */
MPIU_THREAD_CS_ENTER(ALLFUNC,);
MPID_MPI_FUNC_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, MPID_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 );
MPID_Keyval_get_ptr( type_keyval, keyval_ptr );
/* Validate parameters and objects (post conversion) */
# ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
/* Validate type_ptr */
MPID_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 */
MPIR_Keyval_release_ref( p->keyval, &in_use);
if (!in_use)
{
MPIU_Handle_obj_free( &MPID_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:
MPID_MPI_FUNC_EXIT(MPID_STATE_MPI_TYPE_DELETE_ATTR);
MPIU_THREAD_CS_EXIT(ALLFUNC,);
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_Win_free - Free an MPI RMA window
Input Parameters:
. win - window object (handle)
Notes:
If successfully freed, 'win' is set to 'MPI_WIN_NULL'.
.N ThreadSafe
.N Fortran
.N Errors
.N MPI_SUCCESS
.N MPI_ERR_WIN
.N MPI_ERR_OTHER
@*/
int MPI_Win_free(MPI_Win *win)
{
static const char FCNAME[] = "MPI_Win_free";
int mpi_errno = MPI_SUCCESS;
MPID_Win *win_ptr = NULL;
MPID_MPI_STATE_DECL(MPID_STATE_MPI_WIN_FREE);
MPIR_ERRTEST_INITIALIZED_ORDIE();
MPID_THREAD_CS_ENTER(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX);
MPID_MPI_RMA_FUNC_ENTER(MPID_STATE_MPI_WIN_FREE);
/* Validate parameters, especially handles needing to be converted */
# ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
MPIR_ERRTEST_WIN(*win, mpi_errno);
}
MPID_END_ERROR_CHECKS;
}
# endif
/* Convert MPI object handles to object pointers */
MPID_Win_get_ptr( *win, win_ptr );
/* Validate parameters and objects (post conversion) */
# ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
/* Validate win_ptr */
MPID_Win_valid_ptr( win_ptr, mpi_errno );
if (mpi_errno) goto fn_fail;
/* TODO: Check for unterminated passive target epoch */
/* TODO: check for unterminated active mode epoch */
if (mpi_errno) goto fn_fail;
}
MPID_END_ERROR_CHECKS;
}
# endif /* HAVE_ERROR_CHECKING */
/* ... body of routine ... */
if (MPIR_Process.attr_free && win_ptr->attributes)
{
mpi_errno = MPIR_Process.attr_free( win_ptr->handle,
&win_ptr->attributes );
}
/*
* If the user attribute free function returns an error,
* then do not free the window
*/
if (mpi_errno != MPI_SUCCESS) goto fn_fail;
/* We need to release the error handler */
if (win_ptr->errhandler &&
! (HANDLE_GET_KIND(win_ptr->errhandler->handle) ==
HANDLE_KIND_BUILTIN) ) {
int in_use;
MPIR_Errhandler_release_ref( win_ptr->errhandler,&in_use);
if (!in_use) {
MPIU_Handle_obj_free( &MPID_Errhandler_mem, win_ptr->errhandler );
}
}
mpi_errno = MPID_Win_free(&win_ptr);
if (mpi_errno) goto fn_fail;
*win = MPI_WIN_NULL;
/* ... end of body of routine ... */
fn_exit:
MPID_MPI_RMA_FUNC_EXIT(MPID_STATE_MPI_WIN_FREE);
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_win_free", "**mpi_win_free %p", win);
}
# endif
mpi_errno = MPIR_Err_return_win( win_ptr, FCNAME, mpi_errno );
goto fn_exit;
/* --END ERROR HANDLING-- */
}
/*@
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;
MPID_Keyval *keyval_ptr = NULL;
int in_use;
MPID_MPI_STATE_DECL(MPID_STATE_MPI_WIN_FREE_KEYVAL);
MPIR_ERRTEST_INITIALIZED_ORDIE();
MPID_THREAD_CS_ENTER(GLOBAL, MPIR_THREAD_GLOBAL_ALLFUNC_MUTEX);
MPID_MPI_FUNC_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, MPID_WIN, "window", mpi_errno);
MPIR_ERRTEST_KEYVAL_PERM(*win_keyval, mpi_errno);
}
MPID_END_ERROR_CHECKS;
}
# endif
/* Convert MPI object handles to object pointers */
MPID_Keyval_get_ptr( *win_keyval, keyval_ptr );
/* Validate parameters and objects (post conversion) */
# ifdef HAVE_ERROR_CHECKING
{
MPID_BEGIN_ERROR_CHECKS;
{
MPID_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;
MPIR_Keyval_release_ref( keyval_ptr, &in_use);
if (!in_use) {
MPIU_Handle_obj_free( &MPID_Keyval_mem, keyval_ptr );
}
}
*win_keyval = MPI_KEYVAL_INVALID;
/* ... end of body of routine ... */
#ifdef HAVE_ERROR_CHECKING
fn_exit:
#endif
MPID_MPI_FUNC_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(MPID_Attribute *attr_ptr)
{
MPIU_Handle_obj_free(&MPID_Attr_mem, attr_ptr);
}
int MPID_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, contig_count;
int 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;
MPID_Datatype *new_dtp;
if (count == 0) return MPID_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 = (MPID_Datatype *) MPIU_Handle_obj_alloc(&MPID_Datatype_mem);
/* --BEGIN ERROR HANDLING-- */
if (!new_dtp)
{
mpi_errno = MPIR_Err_create_code(MPI_SUCCESS,
MPIR_ERR_RECOVERABLE,
"MPID_Type_indexed",
__LINE__,
MPI_ERR_OTHER,
"**nomem",
0);
return mpi_errno;
}
/* --END ERROR HANDLING-- */
/* handle is filled in by MPIU_Handle_obj_alloc() */
MPIU_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 = MPID_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;
new_dtp->alignsize = el_sz; /* ??? */
new_dtp->element_size = (MPI_Aint) el_sz;
new_dtp->eltype = el_type;
new_dtp->max_contig_blocks = count;
}
else
{
/* user-defined base type (oldtype) */
MPID_Datatype *old_dtp;
MPID_Datatype_get_ptr(oldtype, old_dtp);
/* Ensure that "element_size" fits into an int datatype. */
MPID_Ensure_Aint_fits_in_int(old_dtp->element_size);
el_sz = old_dtp->element_size;
old_sz = old_dtp->size;
el_ct = old_dtp->n_elements;
el_type = old_dtp->eltype;
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->element_size = (MPI_Aint) el_sz;
new_dtp->eltype = 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) {
MPIU_Handle_obj_free(&MPID_Datatype_mem, new_dtp);
return MPID_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);
MPID_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 */
MPID_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_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)
{
contig_count = MPID_Type_indexed_count_contig(count,
blocklength_array,
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;
}
}
*newtype = new_dtp->handle;
return mpi_errno;
}
