dll_mpich2.c

fortran并行计算包

    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 head_ptr;

    /* Don't bother with a pop up here, it's unlikely to be helpful */
    *msg = 0;

    /* Check first for the communicator list */
    if (dbgr_find_symbol (image, "MPIR_All_communicators", &p_info->commlist_base) != mqs_ok)
	return err_all_communicators;

    /* Check for the receive and send queues */
    if (dbgr_find_symbol( image, "MPID_Recvq_posted_head_ptr", &head_ptr ) != mqs_ok)
	return err_posted;
    p_info->posted_base = fetch_pointer( proc, head_ptr, p_info );

    if (dbgr_find_symbol( image, "MPID_Recvq_unexpected_head_ptr", &head_ptr ) != mqs_ok)
	return err_unexpected;
    p_info->unexpected_base = fetch_pointer( proc, head_ptr, p_info );

    /* Send queues are optional */
    if (dbgr_find_symbol( image, "MPIR_Sendq_head", &p_info->sendq_base) == 
	mqs_ok) {
	p_info->has_sendq = 1;
    }
    else {
	p_info->has_sendq = 0;
    }

    return mqs_ok;
}

/* This routine is called by the debugger to map an error code into a 
   printable string */
char * mqs_dll_error_string (int errcode)
{
    switch (errcode) {
    case err_silent_failure:
	return "";
    case err_no_current_communicator: 
	return "No current communicator in the communicator iterator";
    case err_bad_request:    
	return "Attempting to setup to iterate over an unknown queue of operations";
    case err_no_store: 
	return "Unable to allocate store";
    case err_group_corrupt:
	return "Could not read a communicator's group from the process (probably a store corruption)";
    case err_unexpected: 
      return "Failed to find symbol MPID_Recvq_unexpected_head_ptr";
    case err_posted: 
      return "Failed to find symbol MPID_Recvq_posted_head_ptr";
    }
    return "Unknown error code";
}
/* ------------------------------------------------------------------------ */
/* Queue Display
 *
 */

/* Communicator list.
 * 
 * To avoid problems that might be caused by having the list of communicators
 * change in the process that is being debugged, the communicator access 
 * routines make an internal copy of the communicator list.  
 * 
 */
/* Internal structure we hold for each communicator */
typedef struct communicator_t
{
  struct communicator_t * next;
  group_t *               group;		/* Translations */
  int                     context_id;		/* To catch changes */
  int                     recvcontext_id;       /* May also be needed for 
						   matchine */
  int                     present;
  mqs_communicator        comm_info;		/* Info needed at the higher level */
} communicator_t;


/* update_communicator_list makes a copy of the list of currently active
 * communicators and stores it in the mqs_process structure.   
 */
int mqs_update_communicator_list (mqs_process *proc)
{
    if (communicators_changed (proc))
	return rebuild_communicator_list (proc);
    else
	return mqs_ok;
}
/* These three routines (setup_communicator_iterator, get_communicator,
 * and next_communicator) provide a way to access each communicator in the
 * list that is initialized by update_communicator_list.
 */
int mqs_setup_communicator_iterator (mqs_process *proc)
{
    mpich_process_info *p_info = 
	(mpich_process_info *)dbgr_get_process_info (proc);

    /* Start at the front of the list again */
    p_info->current_communicator = p_info->communicator_list;
    /* Reset the operation iterator too */
    p_info->next_msg = 0;
    
    return p_info->current_communicator == NULL ? mqs_end_of_list : mqs_ok;
}
int mqs_get_communicator (mqs_process *proc, mqs_communicator *comm)
{
    mpich_process_info *p_info = 
	(mpich_process_info *)dbgr_get_process_info (proc);

    if (p_info->current_communicator) {
	*comm = p_info->current_communicator->comm_info;
	return mqs_ok;
    }
    else
	return err_no_current_communicator;
}
int mqs_next_communicator (mqs_process *proc)
{
    mpich_process_info *p_info = 
	(mpich_process_info *)dbgr_get_process_info (proc);
    
    p_info->current_communicator = p_info->current_communicator->next;
  
    return (p_info->current_communicator != NULL) ? mqs_ok : mqs_end_of_list;
}
/* ------------------------------------------------------------------------ */
/* Iterate over the queues attached to the current communicator. */

/* Forward references for routines used to implement the operations */
static int fetch_send (mqs_process *proc, mpich_process_info *p_info,
		       mqs_pending_operation *res);
static int fetch_receive (mqs_process *proc, mpich_process_info *p_info,
			  mqs_pending_operation *res, int look_for_user_buffer);

int mqs_setup_operation_iterator (mqs_process *proc, int op)
{
    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); */

  p_info->what = (mqs_op_class)op;

  switch (op) {
  case mqs_pending_sends:
      if (!p_info->has_sendq)
	  return mqs_no_information;
      else {
	  p_info->next_msg = p_info->sendq_base;
	  return mqs_ok;
      }

  case mqs_pending_receives:
      p_info->next_msg = p_info->posted_base;
      return mqs_ok;
      
  case mqs_unexpected_messages:
      p_info->next_msg = p_info->unexpected_base;
      return mqs_ok;
      
  default:
      return err_bad_request;
  }
}

/* Fetch the next operation on the current communicator, from the 
   selected queue. Since MPICH2 does not (normally) use separate queues 
   for each communicator, we must compare the queue items with the
   current communicator.
*/
int mqs_next_operation (mqs_process *proc, mqs_pending_operation *op)
{
    mpich_process_info *p_info = 
	(mpich_process_info *)dbgr_get_process_info (proc);

    switch (p_info->what) {
    case mqs_pending_receives:
	return fetch_receive (proc,p_info,op,1);
    case mqs_unexpected_messages:
	return fetch_receive (proc,p_info,op,0);
    case mqs_pending_sends:
	return fetch_send (proc,p_info,op);
    default: return err_bad_request;
    }
} 
/* ------------------------------------------------------------------------ */
/* Clean up routines
 * These routines free any memory allocated when the process or image 
 * structures were allocated.
 */
void mqs_destroy_process_info (mqs_process_info *mp_info)
{
    mpich_process_info *p_info = (mpich_process_info *)mp_info;

    /* Need to handle the communicators and groups too */
    mqs_free_communicator_list( p_info->communicator_list );

    dbgr_free (p_info);
} 

void mqs_destroy_image_info (mqs_image_info *info)
{
    dbgr_free (info);
} 

/* ------------------------------------------------------------------------ */

/* ------------------------------------------------------------------------ */
/* Internal Routine 
 * 
 * These routine know about the internal structure of the MPI implementation.
 */

/* Get the next entry in the current receive queue (posted or unexpected) */

static int fetch_receive (mqs_process *proc, mpich_process_info *p_info,
			  mqs_pending_operation *res, int look_for_user_buffer)
{
    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;
    int16_t wanted_context     = comm->recvcontext_id;
    mqs_taddr_t base           = fetch_pointer (proc, p_info->next_msg, p_info);

    while (base != 0) {
	/* Check this entry to see if the context matches */
	int16_t actual_context = fetch_int16( proc, base + i_info->req_context_id_offs, p_info );
	
	if (actual_context == wanted_context) {
	    /* Found a request for this communicator */
	    int tag = fetch_int( proc, base + i_info->req_tag_offs, p_info );
	    int rank = fetch_int16( proc, base + i_info->req_rank_offs, p_info );
	    int is_complete = fetch_int (proc, base + i_info->req_cc_offs, p_info);

	    res->desired_tag = tag;
	    res->desired_local_rank = rank;
	    res->desired_global_rank = -1;   /* Convert to rank in comm world,
						if valid (in mpi-2, may
						not be available) */
	    res->desired_length = -1;
	    
	    res->tag_wild = (tag < 0);
	    /* We don't know the rest of these */
	    res->buffer   = 0;
	    res->system_buffer = 0;
	    res->actual_local_rank = rank;
	    res->actual_global_rank = -1;
	    res->actual_tag = tag;
	    res->actual_length = -1;
	    res->extra_text[0][0] = 0;

	    res->status = (is_complete != 0) ? mqs_st_pending : mqs_st_complete; 

	    /* Don't forget to step the queue ! */
	    p_info->next_msg = base + i_info->req_next_offs;
	    return mqs_ok;
	}
	else {
	    /* Try the next one */
	    base = fetch_pointer (proc, base + i_info->req_next_offs, p_info);
	}
    }
#if 0
  while (base != 0)
    { /* Well, there's a queue, at least ! */
      mqs_tword_t actual_context = fetch_int (proc, base + i_info->context_id_offs, p_info);
      
      if (actual_context == wanted_context)
	{ /* Found a good one */
	  mqs_tword_t tag     = fetch_int (proc, base + i_info->tag_offs, p_info);
	  mqs_tword_t tagmask = fetch_int (proc, base + i_info->tagmask_offs, p_info);
	  mqs_tword_t lsrc    = fetch_int (proc, base + i_info->lsrc_offs, p_info);
	  mqs_tword_t srcmask = fetch_int (proc, base + i_info->srcmask_offs, p_info);
	  mqs_taddr_t ptr     = fetch_pointer (proc, base + i_info->ptr_offs, p_info);
	  
	  /* Fetch the fields from the MPIR_RHANDLE */
	  int is_complete = fetch_int (proc, ptr + i_info->is_complete_offs, p_info);
	  mqs_taddr_t buf     = fetch_pointer (proc, ptr + i_info->buf_offs, p_info);
	  mqs_tword_t len     = fetch_int (proc, ptr + i_info->len_offs, p_info);
	  mqs_tword_t count   = fetch_int (proc, ptr + i_info->count_offs, p_info);

	  /* If we don't have start, then use buf instead... */
	  mqs_taddr_t start;
	  if (i_info->start_offs < 0)
	    start = buf;
	  else
	    start = fetch_pointer (proc, ptr + i_info->start_offs, p_info);

	  /* Hurrah, we should now be able to fill in all the necessary fields in the
	   * result !
	   */
	  res->status = is_complete ? mqs_st_complete : mqs_st_pending; /* We can't discern matched */
	  if (srcmask == 0)
	    {
	      res->desired_local_rank  = -1;
	      res->desired_global_rank = -1;
	    }
	  else
	    {
	      res->desired_local_rank  = lsrc;
	      res->desired_global_rank = translate (comm->group, lsrc);
	      
	    }
	  res->tag_wild       = (tagmask == 0);
	  res->desired_tag    = tag;
	  
	  if (look_for_user_buffer)
	    {
		res->system_buffer  = 0;
	      res->buffer         = buf;
	      res->desired_length = len;
	    }
	  else
	    {
	      res->system_buffer  = 1;
	      /* Correct an oddity. If the buffer length is zero then no buffer
	       * is allocated, but the descriptor is left with random data.
	       */
	      if (count == 0)
		start = 0;
	      
	      res->buffer         = start;
	      res->desired_length = count;
	    }

	  if (is_complete)
	    { /* Fill in the actual results, rather than what we were looking for */
	      mqs_tword_t mpi_source  = fetch_int (proc, ptr + i_info->MPI_SOURCE_offs, p_info);
	      mqs_tword_t mpi_tag  = fetch_int (proc, ptr + i_info->MPI_TAG_offs, p_info);

	      res->actual_length     = count;
	      res->actual_tag        = mpi_tag;
	      res->actual_local_rank = mpi_source;
	      res->actual_global_rank= translate (comm->group, mpi_source);
	    }

	  /* Don't forget to step the queue ! */
	  p_info->next_msg = base + i_info->next_offs;
	  return mqs_ok;
	}
      else
	{ /* Try the next one */