errutil.c

fortran并行计算包

/* -*- Mode: C; c-basic-offset:4 ; -*- */
/*
 *
 *  (C) 2001 by Argonne National Laboratory.
 *      See COPYRIGHT in top-level directory.
 */

/* style: allow:fprintf:4 sig:0 */

/* stdarg is required to handle the variable argument lists for 
   MPIR_Err_create_code */
#include <stdarg.h>
/* Define USE_ERR_CODE_VALIST to get the prototype for the valist version
   of MPIR_Err_create_code in mpierror.h (without this definition,
   the prototype is not included.  The "valist" version of the function
   is used in only a few places, here and potentially in ROMIO) */
#define USE_ERR_CODE_VALIST

#include "mpiimpl.h"
/* errcodes.h contains the macros used to access fields within an error
   code and a description of the bits in an error code.  A brief
   version of that description is included below */

#include "errcodes.h"

/* defmsg is generated automatically from the source files and contains
   all of the error messages, both the generic and specific.  Depending 
   on the value of MPICH_ERROR_MSG_LEVEL, different amounts of message
   information will be included from the file defmsg.h */
#include "defmsg.h" 

/* stdio is needed for vsprintf and vsnprintf */
#include <stdio.h>

/* TEMP TO KEEP COMPILER HAPPY */
void MPIR_Err_print_stack_string_ext(int errcode, char *str, int maxlen, 
				     MPIR_Err_get_class_string_func_t fn);

/*
 * Structure of this file
 *
 * This file contains several groups of routines user for error handling
 * and reporting.  
 *
 * The first group provides memory for the MPID_Errhandler objects 
 * and the routines to free and manipulate them
 *
 * MPIR_Err_return_xxx - For each of the MPI types on which an 
 * error handler can be defined, there is an MPIR_Err_return_xxx routine
 * that determines what error handler function to call and whether to 
 * abort the program.  The comm and win versions are here; ROMIO
 * provides its own routines for invoking the error handlers for Files.
 *
 * The next group of code handles the error messages.  There are three
 * options, controlled by the value of MPICH_ERROR_MSG_LEVEL. 
 *
 * MPICH_ERROR_MSG_NONE - No text messages at all
 * MPICH_ERROR_MSG_CLASS - Only messages for the MPI error classes
 * MPICH_ERROR_MSG_GENERIC - Only predefiend messages for the MPI error codes
 * MPICH_ERROR_MSG_ALL - Instance specific error messages (and error message
 *                       stack)
 *
 * In only the latter (MPICH_ERROR_MSG_ALL) case are instance-specific
 * messages maintained (including the error message "stack" that you may
 * see mentioned in various places.  In the other cases, an error code 
 * identifies a fixed message string (unless MPICH_ERROR_MSG_NONE,
 * when there are no strings) from the "generic" strings defined in defmsg.h
 *
 * A major subgroup in this section is the code to handle the instance-specific
 * messages (MPICH_ERROR_MSG_ALL only).  
 *
 * An MPI error code is made up of a number of fields (see errcodes.h)
 * These ar 
 *   is-dynamic? specific-msg-sequence# specific-msg-index 
 *                                            generic-code is-fatal? class
 *
 * There are macros (defined in errcodes.h) that define these fields, 
 * their sizes, and masks and shifts that may be used to extract them.
 */

/* A few prototypes.  These routines are called from the MPIR_Err_return 
   routines.  checkValidErrcode depends on the MPICH_ERROR_MSG_LEVEL */

static int checkValidErrcode( int error_class, const char fcname[], 
			      int *errcode );
static void handleFatalError( MPID_Comm *comm_ptr, 
			      const char fcname[], int errcode );

#if MPICH_ERROR_MSG_LEVEL >= MPICH_ERROR_MSG_ALL
static int ErrGetInstanceString( int errorcode, char *msg, int num_remaining, 
				 MPIR_Err_get_class_string_func_t fn );
static void MPIR_Err_stack_init( void );
static int checkForUserErrcode( int errcode );
#else
/* We only need special handling for user error codes when we support the
   error message stack */
#define checkForUserErrcode(_a) _a
#endif


/* ------------------------------------------------------------------------- */
/* Provide the MPID_Errhandler space and the routines to free and set them
   from C++  */
/* ------------------------------------------------------------------------- */
/*
 * Error handlers.  These are handled just like the other opaque objects
 * in MPICH
 */

#ifndef MPID_ERRHANDLER_PREALLOC 
#define MPID_ERRHANDLER_PREALLOC 8
#endif

/* Preallocated errorhandler objects */
MPID_Errhandler MPID_Errhandler_builtin[2] = 
          { { MPI_ERRORS_ARE_FATAL, 0},
	    { MPI_ERRORS_RETURN, 0} }; 
MPID_Errhandler MPID_Errhandler_direct[MPID_ERRHANDLER_PREALLOC] = { {0} };
MPIU_Object_alloc_t MPID_Errhandler_mem = { 0, 0, 0, 0, MPID_ERRHANDLER, 
					    sizeof(MPID_Errhandler), 
					    MPID_Errhandler_direct,
					    MPID_ERRHANDLER_PREALLOC, };

void MPID_Errhandler_free(MPID_Errhandler *errhan_ptr)
{
    MPIU_Handle_obj_free(&MPID_Errhandler_mem, errhan_ptr);
}

#ifdef HAVE_CXX_BINDING
/* This routine is used to install a callback used by the C++ binding
 to invoke the (C++) error handler.  The callback routine is a C routine,
 defined in the C++ binding. */
void MPIR_Errhandler_set_cxx( MPI_Errhandler errhand, void (*errcall)(void) )
{
    MPID_Errhandler *errhand_ptr;
    
    MPID_Errhandler_get_ptr( errhand, errhand_ptr );
    errhand_ptr->language		= MPID_LANG_CXX;
    MPIR_Process.cxx_call_errfn	= (void (*)( int, int *, int *, 
					    void (*)(void) ))errcall;
}
#endif

/* ------------------------------------------------------------------------- */
/* 
   Nesting level for routines.
   Note that since these use per-thread data, no locks or atomic update
   routines are required.

   In a single-threaded environment, these are replaced with
   MPIR_Thread.nest_count ++, --.  These are defined in the mpiimpl.h file.
 */
/* ------------------------------------------------------------------------- */

/* These routines export the nest increment and decrement for use in ROMIO */
void MPIR_Nest_incr_export( void )
{
    MPICH_PerThread_t *p;
    MPIR_GetPerThread(&p);
    p->nest_count++;
}
void MPIR_Nest_decr_export( void )
{
    MPICH_PerThread_t *p;
    MPIR_GetPerThread(&p);
    p->nest_count--;
}

/* ------------------------------------------------------------------------- */
/* These routines are called on error exit from most top-level MPI routines
   to invoke the appropriate error handler.  Also included is the routine
   to call if MPI has not been initialized (MPIR_Err_preinit) and to 
   determine if an error code represents a fatal error (MPIR_Err_is_fatal). */
/* ------------------------------------------------------------------------- */
/* Special error handler to call if we are not yet initialized, or if we
   have finalized */
void MPIR_Err_preOrPostInit( void )
{
    if (MPIR_Process.initialized == MPICH_PRE_INIT) {
	MPIU_Error_printf("Attempting to use an MPI routine before initializing MPICH\n");
    }
    else if (MPIR_Process.initialized == MPICH_POST_FINALIZED) {
	MPIU_Error_printf("Attempting to use an MPI routine after finalizing MPICH\n");
    }
    else {
	MPIU_Error_printf("Internal Error: Unknown state of MPI (neither initialized nor finalized)\n" );
    }
    exit(1);
}

/* Return true if the error code indicates a fatal error */
int MPIR_Err_is_fatal(int errcode)
{
    return (errcode & ERROR_FATAL_MASK) ? TRUE : FALSE;
}

/*
 * This is the routine that is invoked by most MPI routines to 
 * report an error 
 */
int MPIR_Err_return_comm( MPID_Comm  *comm_ptr, const char fcname[], 
			  int errcode )
{
    const int error_class = ERROR_GET_CLASS(errcode);
    int rc;
    MPIU_THREADPRIV_DECL;

    MPIU_THREADPRIV_GET; 

    rc = checkValidErrcode( error_class, fcname, &errcode );
    
    /* First, check the nesting level */
    if (MPIR_Nest_value()) return errcode;
    
    if (!comm_ptr || comm_ptr->errhandler == NULL) {
	/* Try to replace with the default handler, which is the one on 
	   MPI_COMM_WORLD.  This gives us correct behavior for the
	   case where the error handler on MPI_COMM_WORLD has been changed. */
	if (MPIR_Process.comm_world)
	{
	    comm_ptr = MPIR_Process.comm_world;
	}
    }

    if (MPIR_Err_is_fatal(errcode) ||
	comm_ptr == NULL || comm_ptr->errhandler == NULL || 
	comm_ptr->errhandler->handle == MPI_ERRORS_ARE_FATAL) {
	/* Calls MPID_Abort */
	handleFatalError( comm_ptr, fcname, errcode );
    }

    /* Check for the special case of a user-provided error code */
    errcode = checkForUserErrcode( errcode );
    
    if (comm_ptr->errhandler->handle == MPI_ERRORS_RETURN)
    {
	return errcode;
    }
    else
    {
	/* The user error handler may make calls to MPI routines, so the
	 * nesting counter must be incremented before the handler is called */
	MPIR_Nest_incr();
    
	/* We pass a final 0 (for a null pointer) to these routines
	   because MPICH-1 expected that */
	switch (comm_ptr->errhandler->language)
	{
	case MPID_LANG_C:
	    (*comm_ptr->errhandler->errfn.C_Comm_Handler_function)( 
		&comm_ptr->handle, &errcode, 0 );
	    break;
#ifdef HAVE_CXX_BINDING
	case MPID_LANG_CXX:
	    (*MPIR_Process.cxx_call_errfn)( 0, &comm_ptr->handle, &errcode, 
		    (void (*)(void))*comm_ptr->errhandler->errfn.C_Comm_Handler_function );
	    /* The C++ code throws an exception if the error handler 
	     returns something other than MPI_SUCCESS. There is no "return"
	     of an error code. */
	    errcode = MPI_SUCCESS;
	    break;
#endif
#ifdef HAVE_FORTRAN_BINDING
	case MPID_LANG_FORTRAN90:
	case MPID_LANG_FORTRAN:
	    (*comm_ptr->errhandler->errfn.F77_Handler_function)( 
		(MPI_Fint *)&comm_ptr->handle, &errcode );
	    break;
#endif
	}

	MPIR_Nest_decr();
    }
    return errcode;
}

/* 
 * MPI routines that detect errors on window objects use this to report errors
 */
int MPIR_Err_return_win( MPID_Win  *win_ptr, const char fcname[], int errcode )
{
    const int error_class = ERROR_GET_CLASS(errcode);
    int rc ;
    MPIU_THREADPRIV_DECL;

    MPIU_THREADPRIV_GET;

    if (win_ptr == NULL || win_ptr->errhandler == NULL)
	return MPIR_Err_return_comm(NULL, fcname, errcode);

    rc = checkValidErrcode( error_class, fcname, &errcode );

    /* First, check the nesting level */
    if (MPIR_Nest_value()) return errcode;

    if (MPIR_Err_is_fatal(errcode) ||
	win_ptr == NULL || win_ptr->errhandler == NULL || 
	win_ptr->errhandler->handle == MPI_ERRORS_ARE_FATAL) {
	/* Calls MPID_Abort */
	handleFatalError( NULL, fcname, errcode );
    }

    /* Check for the special case of a user-provided error code */
    errcode = checkForUserErrcode( errcode );
    
    if (win_ptr->errhandler->handle == MPI_ERRORS_RETURN)
    {
	return errcode;
    }
    else
    {
	/* Now, invoke the error handler for the window */

	/* The user error handler may make calls to MPI routines, so the
	 * nesting counter must be incremented before the handler is called */
	MPIR_Nest_incr();
    
	/* We pass a final 0 (for a null pointer) to these routines
	   because MPICH-1 expected that */
	switch (win_ptr->errhandler->language)
	{
	    case MPID_LANG_C:
		(*win_ptr->errhandler->errfn.C_Win_Handler_function)( 
		    &win_ptr->handle, &errcode, 0 );
		break;
#ifdef HAVE_CXX_BINDING
	    case MPID_LANG_CXX:
	    (*MPIR_Process.cxx_call_errfn)( 2, &win_ptr->handle, &errcode, 
		    (void (*)(void))*win_ptr->errhandler->errfn.C_Win_Handler_function );
	    /* The C++ code throws an exception if the error handler 
	     returns something other than MPI_SUCCESS. There is no "return"
	     of an error code. */
	    errcode = MPI_SUCCESS;
	    break;
#endif
#ifdef HAVE_FORTRAN_BINDING
	    case MPID_LANG_FORTRAN90:
	    case MPID_LANG_FORTRAN:
		(*win_ptr->errhandler->errfn.F77_Handler_function)( 
		    (MPI_Fint *)&win_ptr->handle, &errcode );
		break;
#endif
	}

	MPIR_Nest_decr();
    }
    return errcode;
}


/* ------------------------------------------------------------------------- */
/* ------------------------------------------------------------------------- */
static int convertErrcodeToIndexes( int errcode, int *ring_idx, int *ring_id,
				    int *generic_idx );
static int checkErrcodeIsValid( int errcode );
static const char *ErrcodeInvalidReasonStr( int reason );
static const char *get_class_msg( int error_class );


void MPIR_Err_init( void )
{
#   if MPICH_ERROR_MSG_LEVEL >= MPICH_ERROR_MSG_ALL
    MPIR_Err_stack_init();
#   endif
}


/* ------------------------------------------------------------------------- */
/* The following block of code manages the instance-specific error messages  */
/* ------------------------------------------------------------------------- */

 
/* Check for a valid error code.  If the code is not valid, attempt to
   print out something sensible; reset the error code to have class 
   ERR_UNKNOWN */
/* FIXME: Now that error codes are chained, this does not produce a valid 
   error code since there is no valid ring index corresponding to this code */
static int checkValidErrcode( int error_class, const char fcname[], 
			      int *errcode_p )
{
    int errcode = *errcode_p;
    int rc = 0;

    if (error_class > MPICH_ERR_LAST_CLASS)
    {
	if (errcode & ~ERROR_CLASS_MASK)
	{
	    MPIU_Error_printf("INTERNAL ERROR: Invalid error class (%d) encountered while returning from\n"
			      "%s.  Please file a bug report.\n", error_class, fcname);
	    /* Note that we don't try to print the error stack; if the 
	       error code is invalid, it can't be used to find
	       the error stack.  We could consider dumping the 
	       contents of the error ring instead (without trying
	       to interpret them) */
	}
	else
	{
	    MPIU_Error_printf("INTERNAL ERROR: Invalid error class (%d) encountered while returning from\n"
			      "%s.  Please file a bug report.  No error stack is available.\n", error_class, fcname);
	}
	/* FIXME: We probably want to set this to MPI_ERR_UNKNOWN
	   and discard the rest of the bits */
	errcode = (errcode & ~ERROR_CLASS_MASK) | MPI_ERR_UNKNOWN;
	rc = 1;
    }
    *errcode_p = errcode;
    return rc;
}

/* Check that an encoded error code is valid. Return 0 if valid, positive, 
   non-zero if invalid.  Value indicates reason; see 
   ErrcodeInvalidReasonStr() */

#if MPICH_ERROR_MSG_LEVEL <= MPICH_ERROR_MSG_GENERIC
/* This is the shortened version when there are no error messages */
static int checkErrcodeIsValid( int errcode )
{
    /* MPICH_ERR_LAST_CLASS is the last of the *predefined* error classes. */
    /* FIXME: Should this check against dynamically-created error classes? */
    if (errcode < 0 || errcode >= MPICH_ERR_LAST_CLASS) {
	return 3;
    }
    return 0;
}
static const char *ErrcodeInvalidReasonStr( int reason )
{
    const char *str = 0;

    /* FIXME: These strings need to be internationalized */
    switch (reason) {
    case 3:
	str = "Message class is out of range";
	break;
    default:
	str = "Unknown reason for invalid errcode";
	break;
    }
    return str;
}
#endif

/* This routine is called when there is a fatal error */
static void handleFatalError( MPID_Comm *comm_ptr, 
			      const char fcname[], int errcode )
{
    /* Define length of the the maximum error message line (or string with 
       newlines?).  This definition is used only within this routine.  */
    /* FIXME: This should really be the same as MPI_MAX_ERROR_STRING, or in the
       worst case, defined in terms of that */
#define MAX_ERRMSG_STRING 4096
    char error_msg[ MAX_ERRMSG_STRING ];
    int len;

    /* FIXME: Not internationalized */
    MPIU_Snprintf(error_msg, MAX_ERRMSG_STRING, "Fatal error in %s: ", fcname);
    len = (int)strlen(error_msg);
    MPIR_Err_get_string(errcode, &error_msg[len], MAX_ERRMSG_STRING-len, NULL);
    /* The third argument is a return code, a value of 1 usually indicates
       an error */
    MPID_Abort(comm_ptr, MPI_SUCCESS, 1, error_msg);
}

#if MPICH_ERROR_MSG_LEVEL >= MPICH_ERROR_MSG_GENERIC
/* 
 * Given a message string abbreviation (e.g., one that starts "**"), return 
 * the corresponding index.  For the generic (non
 * parameterized messages), use idx = FindGenericMsgIndex( "**msg" );
 */
static int FindGenericMsgIndex( const char *msg )
{
    int i, c;
    for (i=0; i<generic_msgs_len; i++) {
	/* Check the sentinals to insure that the values are ok first */
	if (generic_err_msgs[i].sentinal1 != 0xacebad03 ||
	    generic_err_msgs[i].sentinal2 != 0xcb0bfa11) {
	    /* Something bad has happened! Don't risk trying the
	       short_name pointer; it may have been corrupted */
	    break;
	}
	c = strcmp( generic_err_msgs[i].short_name, msg );
	if (c == 0) return i;
	if (c > 0)
	{
	    /* don't return here if the string partially matches */
	    if (strncmp(generic_err_msgs[i].short_name, msg, strlen(msg)) != 0)
		return -1;
	}
    }
    return -1;
}

/* 
   Here is an alternate search routine based on bisection.
   int i_low, i_mid, i_high, c;
   i_low = 0; i_high = generic_msg_len - 1;
   while (i_high - i_low >= 0) {
       i_mid = (i_high + i_low) / 2;
       c = strcmp( generic_err_msgs[i].short_name, msg );
       if (c == 0) return i_mid;
       if (c < 0) { i_low = i_mid + 1; }
       else       { i_high = i_mid - 1; }
   }
   return -1;
*/
#endif

#if MPICH_ERROR_MSG_LEVEL == MPICH_ERROR_MSG_ALL
/* 
 * Given a message string abbreviation (e.g., one that starts "**"), return 
 * the corresponding index.  For the specific
 * (parameterized messages), use idx = FindSpecificMsgIndex( "**msg" );
 */
static int FindSpecificMsgIndex( const char *msg )
{
    int i, c;
    for (i=0; i<specific_msgs_len; i++) {
	/* Check the sentinals to insure that the values are ok first */
	if (specific_err_msgs[i].sentinal1 != 0xacebad03 ||