dll_mpich2.c

fortran并行计算包

	  base = fetch_pointer (proc, base + i_info->next_offs, p_info);
	}
    }
#endif  
  p_info->next_msg = 0;
  return mqs_end_of_list;
}  /* fetch_receive */

/* Get the next entry in the send queue, if there is one.  The assumption is 
   that the MPI implementation is quiescent while these queue probes are
   taking place, so we can simply keep track of the location of the "next"
   entry. (in the next_msg field) */
static int fetch_send (mqs_process *proc, mpich_process_info *p_info,
		       mqs_pending_operation *res)
{
    mqs_image * image        = dbgr_get_image (proc);
    mpich_image_info *i_info = (mpich_image_info *)dbgr_get_image_info (image);
    communicator_t   *comm   = p_info->current_communicator;
    int wanted_context       = comm->context_id;
    mqs_taddr_t base         = fetch_pointer (proc, p_info->next_msg, p_info);
    
    if (!p_info->has_sendq)
	return mqs_no_information;
    
    /* Say what operation it is. We can only see non blocking send operations
     * in MPICH. Other MPI systems may be able to show more here. 
     */
    /* FIXME: handle size properly (declared as 64 in mpi_interface.h) */
    strncpy ((char *)res->extra_text[0],"Non-blocking send",20);
    res->extra_text[1][0] = 0;
    
    while (base != 0) {
	/* Check this entry to see if the context matches */
	int actual_context = fetch_int( proc, base + i_info->sendq_context_id_offs, p_info );
	
	if (actual_context == wanted_context) {

	    
	    /* Don't forget to step the queue ! */
	    p_info->next_msg = base + i_info->sendq_next_offs;
	    return mqs_ok;
	}
	else {
	    /* Try the next one */
	    base = fetch_pointer (proc, base + i_info->sendq_next_offs, p_info);
	}
    }
#if 0
  while (base != 0)
    { /* Well, there's a queue, at least ! */
      /* Check if it's one we're interested in ? */
      mqs_taddr_t commp = fetch_pointer (proc, base+i_info->db_comm_offs, p_info);
      mqs_taddr_t next  = base+i_info->db_next_offs;

      if (commp == comm->comm_info.unique_id)
	{ /* Found one */
	  mqs_tword_t target = fetch_int (proc, base+i_info->db_target_offs,      p_info);
	  mqs_tword_t tag    = fetch_int (proc, base+i_info->db_tag_offs,         p_info);
	  mqs_tword_t length = fetch_int (proc, base+i_info->db_byte_length_offs, p_info);
	  mqs_taddr_t data   = fetch_pointer (proc, base+i_info->db_data_offs,    p_info);
	  mqs_taddr_t shandle= fetch_pointer (proc, base+i_info->db_shandle_offs, p_info);
	  mqs_tword_t complete=fetch_int (proc, shandle+i_info->is_complete_offs, p_info);

	  /* Ok, fill in the results */
	  res->status = complete ? mqs_st_complete : mqs_st_pending; /* We can't discern matched */
	  res->actual_local_rank = res->desired_local_rank = target;
	  res->actual_global_rank= res->desired_global_rank= translate (comm->group, target);
	  res->tag_wild   = 0;
	  res->actual_tag = res->desired_tag = tag;
	  res->desired_length = res->actual_length = length;
	  res->system_buffer  = 0;
	  res->buffer = data;

	  p_info->next_msg = next;
	  return mqs_ok;
	}
      
      base = fetch_pointer (proc, next, p_info);
    }

  p_info->next_msg = 0;
#endif
  return mqs_end_of_list;
} /* fetch_send */

/* ------------------------------------------------------------------------ */
/* Communicator */
static communicator_t * find_communicator (mpich_process_info *p_info,
				   mqs_taddr_t comm_base, int recv_ctx);
static group_t * find_or_create_group (mqs_process *proc,
				       mqs_tword_t np,
				       mqs_taddr_t table);
static int translate (group_t *this, int idx);
static int reverse_translate (group_t * this, int idx);
static void group_decref (group_t * group);


static int communicators_changed (mqs_process *proc)
{
    mpich_process_info *p_info = 
	(mpich_process_info *)dbgr_get_process_info (proc);
    mqs_image * image          = dbgr_get_image (proc);
    mpich_image_info *i_info   = 
	(mpich_image_info *)dbgr_get_image_info (image);
    mqs_tword_t new_seq = fetch_int (proc, 
				     p_info->commlist_base+i_info->sequence_number_offs,
				     p_info);
    int  res = (new_seq != p_info->communicator_sequence);
    
    /* Save the sequence number for next time */
    p_info->communicator_sequence = new_seq;
    
    return res;
}

/***********************************************************************
 * Find a matching communicator on our list. We check the recv context
 * as well as the address since the communicator structures may be
 * being re-allocated from a free list, in which case the same
 * address will be re-used a lot, which could confuse us.
 */
static communicator_t * find_communicator (mpich_process_info *p_info,
					   mqs_taddr_t comm_base, int recv_ctx)
{
  communicator_t * comm = p_info->communicator_list;

  for (; comm; comm=comm->next)
    {
      if (comm->comm_info.unique_id == comm_base &&
	  comm->recvcontext_id == recv_ctx)
	return comm;
    }

  return NULL;
} /* find_communicator */
/* This is the comparison function used in the qsort call in 
   rebuild_communicator_list */
static int compare_comms (const void *a, const void *b)
{
  communicator_t * ca = *(communicator_t **)a;
  communicator_t * cb = *(communicator_t **)b;

  return cb->recvcontext_id - ca->recvcontext_id;
} /* compare_comms */
static int rebuild_communicator_list (mqs_process *proc)
{
    mpich_process_info *p_info = 
	(mpich_process_info *)dbgr_get_process_info (proc);
    mqs_image * image          = dbgr_get_image (proc);
    mpich_image_info *i_info   = 
	(mpich_image_info *)dbgr_get_image_info (image);
    mqs_taddr_t comm_base = fetch_pointer (proc, 
					   p_info->commlist_base+i_info->comm_head_offs,
					   p_info);

    communicator_t **commp;
    int commcount = 0;
    
    /* Iterate over the list in the process comparing with the list
     * we already have saved. This is n**2, because we search for each
     * communicator on the existing list. I don't think it matters, though
     * because there aren't that many communicators to worry about, and
     * we only ever do this if something changed.
     */
    while (comm_base) {
	/* We do have one to look at, so extract the info */
	int recv_ctx = fetch_int (proc, comm_base+i_info->comm_recvcontext_id_offs, p_info);
	communicator_t *old = find_communicator (p_info, comm_base, recv_ctx);

	char *name = "--unnamed--";
	char namebuffer[64];
	/* In MPICH2, the name is preallocated and of size MPI_MAX_OBJECT_NAME */
	if (dbgr_fetch_data( proc, comm_base+i_info->comm_name_offs,64,
			     namebuffer) == mqs_ok && namebuffer[0] != 0) {
	    name = namebuffer;
	}

	if (old) {
	    old->present = 1;		/* We do want this communicator */
	    strncpy (old->comm_info.name, name, 64); /* Make sure the name is up to date,
						    * it might have changed and we can't tell.
						    */
	}
	else {
	    mqs_taddr_t group_base = fetch_pointer (proc, comm_base+i_info->lrank_to_grank_offs,
					      p_info);
	    int np     = fetch_int (proc, comm_base+i_info->comm_rsize_offs,p_info);
	    group_t *g = find_or_create_group (proc, np, group_base);
	    communicator_t *nc;

#if 0	    
	    if (!g)
		return err_group_corrupt;
#endif

	    nc = (communicator_t *)dbgr_malloc (sizeof (communicator_t));
	    
	    /* Save the results */
	    nc->next = p_info->communicator_list;
	    p_info->communicator_list = nc;
	    nc->present = 1;
	    nc->group   = g;
	    nc->context_id = recv_ctx;
	    
	    strncpy (nc->comm_info.name, name, 64);
	    nc->comm_info.unique_id = comm_base;
	    nc->comm_info.size      = np;
	    nc->comm_info.local_rank = fetch_int (proc, comm_base+i_info->comm_rank_offs,p_info);
#if 0
	    nc->comm_info.local_rank= reverse_translate (g, dbgr_get_global_rank (proc));
#endif
	}
	/* Step to the next communicator on the list */
	comm_base = fetch_pointer (proc, comm_base+i_info->comm_next_offs, p_info);
    }

    /* Now iterate over the list tidying up any communicators which
     * no longer exist, and cleaning the flags on any which do.
     */
    commp = &p_info->communicator_list;

    for (; *commp; commp = &(*commp)->next) {
	communicator_t *comm = *commp;

	if (comm->present) {
	    comm->present = 0;
	    commcount++;
	}
	else {
	    /* It needs to be deleted */
	    *commp = comm->next;			/* Remove from the list */
	    group_decref (comm->group);		/* Group is no longer referenced from here */
	    dbgr_free (comm);
	}
    }
    
    if (commcount) {
	/* Sort the list so that it is displayed in some semi-sane order. */
	communicator_t ** comm_array = (communicator_t **) dbgr_malloc (
					commcount * sizeof (communicator_t *));
	communicator_t *comm = p_info->communicator_list;
	int i;
	for (i=0; i<commcount; i++, comm=comm->next)
	    comm_array [i] = comm;
	
	/* Do the sort */
	qsort (comm_array, commcount, sizeof (communicator_t *), compare_comms);

	/* Re build the list */
	p_info->communicator_list = NULL;
	for (i=0; i<commcount; i++) {
	    comm = comm_array[i];
	    comm->next = p_info->communicator_list;
	    p_info->communicator_list = comm;
	}

	dbgr_free (comm_array);
    }

    return mqs_ok;
} /* rebuild_communicator_list */

/* Internal routine to free the communicator list */
static void mqs_free_communicator_list( struct communicator_t *comm )
{
    while (comm) {
	communicator_t *next = comm->next;
	
	/* Release the group data structures */
	/* group_decref (comm->group);		 */
	dbgr_free (comm);
      
	comm = next;
    }
}

/* ------------------------------------------------------------------------ */
/* Internal routine to fetch data from the process */
static mqs_taddr_t fetch_pointer (mqs_process * proc, mqs_taddr_t addr, 
				  mpich_process_info *p_info)
{
    int asize = p_info->sizes.pointer_size;
    char data [8];			/* ASSUME a pointer fits in 8 bytes */
    mqs_taddr_t res = 0;

    if (mqs_ok == dbgr_fetch_data (proc, addr, asize, data))
	dbgr_target_to_host (proc, data, 
			     ((char *)&res) + (host_is_big_endian ? sizeof(mqs_taddr_t)-asize : 0), 
			     asize);
    
    return res;
} 
static mqs_tword_t fetch_int (mqs_process * proc, mqs_taddr_t addr, 
			      mpich_process_info *p_info)
{
    int isize = p_info->sizes.int_size;
    char buffer[8];			/* ASSUME an integer fits in 8 bytes */
    mqs_tword_t res = 0;

    if (mqs_ok == dbgr_fetch_data (proc, addr, isize, buffer))
	dbgr_target_to_host (proc, buffer, 
			     ((char *)&res) + (host_is_big_endian ? sizeof(mqs_tword_t)-isize : 0), 
			     isize);
    
    return res;
} 
static mqs_tword_t fetch_int16 (mqs_process * proc, mqs_taddr_t addr, 
				mpich_process_info *p_info)
{
    char buffer[8];			/* ASSUME an integer fits in 8 bytes */
    int16_t res = 0;

    if (mqs_ok == dbgr_fetch_data (proc, addr, 2, buffer))
	dbgr_target_to_host (proc, buffer, 
			     ((char *)&res) + (host_is_big_endian ? sizeof(mqs_tword_t)-2 : 0), 
			     2);
    
    return res;
} 

/* ------------------------------------------------------------------------- */
/* With each communicator we need to translate ranks to/from their
   MPI_COMM_WORLD equivalents.  This code is not yet implemented */
/* ------------------------------------------------------------------------- */
static int translate (group_t *this, int idx) 
{ 	
    return -1;
}
static int reverse_translate (group_t * this, int idx) 
{ 	
    return -1;
}
static group_t * find_or_create_group (mqs_process *proc,
				       mqs_tword_t np,
				       mqs_taddr_t table)
{
    return 0;
}
static void group_decref (group_t * group)
{
    if (--(group->ref_count) == 0) {
	dbgr_free (group->local_to_global);
	dbgr_free (group);
    }
} /* group_decref */