ftp.nice.ch/pub/next/unix/developer/pcn.2.0.s.tar.gz#/src/runtime/utils.c

This is utils.c in view mode; [Download] [Up]

/*
 * PCN Abstract Machine Emulator
 * Authors:     Steve Tuecke and Ian Foster
 *              Argonne National Laboratory
 *
 * Please see the DISCLAIMER file in the top level directory of the
 * distribution regarding the provisions under which this software
 * is distributed.
 *
 * utils.c - Various utilities: Error reporting, print stats, display terms
 */

#include "pcn.h"


/*
 * _p_do_exit()
 *
 * Calling this will cause an orderly exit of the parallel program.
 * It will exit with that passed exit_code.
 */
void _p_do_exit(exit_code)
int_t exit_code;
{
#ifdef PARALLEL    

    if (_p_host)
    {
	_p_host_handle_exit(exit_code);
    }
    else
    {
	_p_node_handle_exit(exit_code, TRUE);
    }
#else  /* PARALLEL */

#ifdef GAUGE    
    /* Take a final profile snapshot, and coalesce the node profiles */
    _p_host_final_profile();
#endif /* GAUGE */

#ifdef UPSHOT
    /* Dump the upshot log */
    _p_write_upshot_log();
#endif

    _p_shutdown_pcn();

    exit((int) exit_code);

#endif /* PARALLEL */    
} /* _p_do_exit() */


/*
 * exit_from_*()
 *
 * These are wrappers around _p_do_exit() that can be called from
 * various places (PCN, C, and Fortran).
 */
void exit_from_pcn(exit_code)
int_t *exit_code;
{
    _p_do_exit(*exit_code);
}

void exit_from_c(exit_code)
int exit_code;
{
    _p_do_exit((int_t) exit_code);
}

void EXIT_FROM_FORTRAN_(exit_code)
int *exit_code;
{
    _p_do_exit((int_t) *exit_code);
}

void EXIT_FROM_FORTRAN(exit_code)
int *exit_code;
{
    _p_do_exit((int_t) *exit_code);
}

void exit_from_fortran_(exit_code)
int *exit_code;
{
    _p_do_exit((int_t) *exit_code);
}

void exit_from_fortran(exit_code)
int *exit_code;
{
    _p_do_exit((int_t) *exit_code);
}


/*
 * _p_size_with_trailer()
 *
 * For the data structure pointed to by 'target', return how
 * many cells this data structure requires, including the trailer cell.
 */
u_int_t _p_size_with_trailer(tag, size)
u_int_t tag;
u_int_t size;
{
    u_int_t i;
    
    switch(tag)
    {
    case UNDEF_TAG:
	i = UndefSizeWithTrailer();
	break;
    case TUPLE_TAG:
	i = TupleSizeWithTrailer(size);
	break;
    case INT_TAG:
	i = IntSizeWithTrailer(size);
	break;
    case STRING_TAG:
	i = StringSizeWithTrailer(size);
	break;
    case DOUBLE_TAG:
	i = DoubleSizeWithTrailer(size);
	break;
    case RREF_TAG:
#ifdef PARALLEL	
	i = RrefSizeWithTrailer();
#else
	_p_fatal_error("_p_size_with_trailer(): Illegal remote reference tag found");
#endif	
	break;
    default:
	_p_fatal_error("_p_size_with_trailer(): Illegal tag found");
	break;
    }

    return (i);
} /* _p_size_with_trailer() */


/*
 * _p_size_without_trailer()
 *
 * For the data structure pointed to by 'target', return how
 * many cells this data structure requires, excluding the trailer cell.
 */
u_int_t _p_size_without_trailer(tag, size)
u_int_t tag;
u_int_t size;
{
    u_int_t i;
    
    switch(tag)
    {
    case UNDEF_TAG:
	i = UndefSizeWithoutTrailer();
	break;
    case TUPLE_TAG:
	i = TupleSizeWithoutTrailer(size);
	break;
    case INT_TAG:
	i = IntSizeWithoutTrailer(size);
	break;
    case STRING_TAG:
	i = StringSizeWithoutTrailer(size);
	break;
    case DOUBLE_TAG:
	i = DoubleSizeWithoutTrailer(size);
	break;
    case RREF_TAG:
#ifdef PARALLEL	
	i = RrefSizeWithoutTrailer();
#else
	_p_fatal_error("_p_size_without_trailer(): Illegal remote reference tag found");
#endif	
	break;
    default:
	_p_fatal_error("_p_size_without_trailer(): Illegal tag found");
	break;
    }

    return (i);
} /* _p_size_without_trailer() */


/*
 * _p_hash_index_for_procedure_name()
 *
 * This procedure uses the 'module_name', 'proc_name' (strings), and
 * 'table_size' (pointer to integer) to return the appropriate
 * hash table index for this procedure name in 'hash_index'.
 */
void _p_em_hash_index_for_procedure_name(module_name, proc_name, table_size,
				      hash_index)
char_t *module_name;
char_t *proc_name;
int_t *table_size;
int_t *hash_index;
{
    u_int_t y = 0;
    int_t i;
    while ((i = (int_t) (*module_name++)) != 0)
    {
	y <<= 1;
	y += i;
    }
    while ((i = (int_t) (*proc_name++)) != 0)
    {
	y <<= 1;
	y += i;
    }
    *hash_index = (int_t) (y % *table_size);
} /* _p_hash_index_for_procedure_name() */


/*
 * _p_hash_string()
 *
 * This procedure takes 'string' and the hash 'table_size'
 * and returns the appropriate hash table index for
 * this string name in 'table_index'.
 */
void _p_hash_string(string, table_size, table_index)
char_t *string;
int_t *table_size;
int_t *table_index;
{
    u_int_t y = 0;
    int_t i;
    while ((i = (int_t) (*string++)) != 0)
    {
	y <<= 1;
	y += i;
    }
    *table_index = (int_t) y;
} /* _p_hash_string() */


/*
 * _p_proc_lookup()
 *
 * Lookup the passed procedure (module_name and proc_name) in
 * the export table and return a pointer to that procedure's
 * proc_header.
 *
 * Return NULL if it is not found, else a pointer to the procecure's header.
 */
proc_header_t *_p_proc_lookup(module_name, proc_name)
char *module_name;
char *proc_name;
{
    int_t hash_index;
    proc_header_t *proc_header;

    _p_em_hash_index_for_procedure_name(module_name, proc_name,
					&_p_exported_table_size,
					&hash_index);

    for (proc_header = _p_exported_table[hash_index];
	 proc_header != (proc_header_t *) NULL;
	 proc_header = proc_header->next)
    {
	if (   strcmp(module_name, proc_header->module_name) == 0
	    && strcmp(proc_name, proc_header->proc_name) == 0)
	{
	    break;
	}
    }

#ifdef DYNAMIC_PAM_LOADING
    if (proc_header == (proc_header_t *) NULL)
    {
	/*
	 * Also search the non-exported list when dynamic loading is
	 * available, so that we can always find procedures that we're
	 * loading over.
	 */
	for (proc_header = _p_exported_table[_p_exported_table_size];
	     proc_header != (proc_header_t *) NULL;
	     proc_header = proc_header->next)
	{
	    if (   strcmp(module_name, proc_header->module_name) == 0
		&& strcmp(proc_name, proc_header->proc_name) == 0)
	    {
		break;
	    }
	}
    }
#endif
    
    return (proc_header);
} /* _p_proc_lookup() */


/*
 * process_susp_queue()
 *
 * Process the suspension queue, 'susp_queue'.
 * Put any process records onto the active queue.
 * Send off value messages for (most) value notes in the queue.
 *
 * In uniprocessor version, process_susp_queue() doesn't have
 * to deal with value notes, so it can just be concatenated to the
 * end of the active queue.
 *
 * If 'check_value_return' is TRUE, then do not send off a value
 * message for value notes that points at 'value_return_irt' and
 * 'value_return_node'.  Why would be want to do this?  To cancel
 * an outstanding read request.  Suppose node 0 has a rref to
 * an undef on node 1. Now suppose that a process on
 * node 0 does a data check on that rref -- this will cause
 * node 0 to allocate an irt for a return value message which
 * points to the rref, and then generate a read
 * message to node 1, which will queue up a value note
 * with that read request.  Now suppose a second process on node 0
 * defines a term to that rref.  This will cause a define message
 * to be sent to node 1 with the term.  But when node 1 processes
 * that define message, it will find the value note back to the
 * original rref on node 0 which is no longer there.  Therefore,
 * node 1 does not want to generate a value message back to node 0
 * with the term, but instead just want to cancel the irt that was
 * allocated on node 0 for the read request.  The 'value_return_*'
 * variables allow us to catch this situation -- they are
 * the irt and node associated with the read request that was
 * previously generated on the rref that was subsequently defined.
 *
 * If 'check_value_return' is FALSE, then always send off value
 * messages for value notes in the queue.
 */
static void process_susp_queue(susp_queue, new_value,
			       check_value_return, value_return_irt,
			       value_return_node)
proc_record_t *susp_queue;
cell_t *new_value;
bool_t check_value_return;
u_int_t value_return_irt, value_return_node;
{
#ifdef PARALLEL
    u_int_t node;
    u_int_t location;
    cell_t **cancel_list_entry;

    if (_p_multiprocessing)
    {
	proc_record_t *first_pr = susp_queue;
	proc_record_t *this_pr = first_pr->next;
	proc_record_t *next_pr;
	
	first_pr->next = (proc_record_t *) NULL;
	while (this_pr != (proc_record_t *) NULL)
	{
	    next_pr = this_pr->next;
	    if (IsValueNote(this_pr))
	    {
		node = ((value_note_t *) this_pr)->node;
		location = ((value_note_t *) this_pr)->location;
		if (check_value_return
		    && value_return_irt == location
		    && value_return_node == node )
		{
		    /*
		     * If this value note is back to the rref
		     * that generated this define in the first
		     * place, then do not send off a value
		     * message.  Instead, queue this value
		     * note on the appropriate cancel list
		     * so that it will get cancelled during the next gc.
		     */
		    cancel_list_entry = _p_cancel_lists + node;
		    ((value_note_t *)this_pr)->next
			= (value_note_t *) *cancel_list_entry;
		    *cancel_list_entry = (cell_t *) this_pr;
		    _p_cancels++;
		}
		else
		{
		    /*
		     * Else send off a value message for this value note
		     */
		    _p_send_value(((value_note_t *) this_pr)->node,
				  ((value_note_t *) this_pr)->location,
				  new_value);
		    _p_free_value_note(this_pr);
		}
	    }
	    else
	    {
		EnqueueProcess(this_pr, _p_active_qf, _p_active_qb);
	    }
	    this_pr = next_pr;
	}
    }
    else
    {
#endif /* PARALLEL */	
	if (_p_active_qf == (proc_record_t *) NULL)
	    _p_active_qf = susp_queue->next;
	else
	    _p_active_qb->next = susp_queue->next;
	
	_p_active_qb = susp_queue;
	susp_queue->next = (proc_record_t *) NULL;
#ifdef PARALLEL
    }
#endif /* PARALLEL */	
} /* process_susp_queue() */


/*
 * _p_define()
 *
 * Define the undefined variable 'to' to be the same as 'from'.
 *
 * If 'send_define_for_rref' is TRUE and if 'to' is a rref, then
 * a define message will be generated for this rref, which
 * will have the side effect of cancelling the irt entry that
 * this rref points to.  But if 'send_define_to_rref'
 * is FALSE and if 'to' is a rref, then we need
 * to queue up the rref on the appropriate _p_cancel_lists
 * entry so that a cancel message will get sent for this rref later.
 *
 * Normally this should be called with 'send_define_for_rref'
 * set to TRUE.  The exception to this is when
 * a value message arrives for this rref, we do not want to
 * generate an extraneous define message, since we know that
 * the thing that this rref points to is what generated the value
 * message in the first place -- so that define message that
 * would normally be generated here would be extraneous.
 *
 * If there is a suspension queue hung of this undef or rref, then
 * pass 'check_value_return', 'value_return_irt', and 'value_return_node'
 * through to process_susp_queue() -- see that procedure's comment
 * for an explanation of how these variables are used.
 *
 * Return:	TRUE if the definition was succesfull,
 *		FALSE if 'to' is already defined
 */
bool_t _p_define(to, from, send_define_for_rref,
		 check_value_return, value_return_irt, value_return_node)
cell_t *to, *from;
bool_t send_define_for_rref;
bool_t check_value_return;
u_int_t value_return_irt, value_return_node;
{
    u_int_t tag = ((data_header_t *) to)->tag;
    
    if (tag == UNDEF_TAG || tag == RREF_TAG)
    {
	if (SuspensionsAt(to))
	{
	    proc_record_t *susp_queue = SuspendedProcs(to);
	    process_susp_queue(susp_queue, from,
			       check_value_return, value_return_irt,
			       value_return_node);
	}

	*((cell_t **) to) = from;
	
	if (tag == UNDEF_TAG)
	{
	    /*
	     * Zero out the second cell of the undef so that it
	     * does not cause any gc problems.
	     */
	    *(to + 1) = 0;
	}
#ifdef PARALLEL		
	else if (tag == RREF_TAG)
	{
            if (send_define_for_rref)
            {
		int_t j;
		
		_p_send_define((rref_t *) to, from);
		
		/*
		 * Zero out the rest of this rref so that it
		 * does not cause any gc problems.
		 */
		for (j = RrefSizeWithTrailer() - 1; j > 0; j--)
		    *(++to) = (cell_t) 0;
	    }
	    else
	    {
                /*
                 * Put this rref on the cancel list, so that a cancel
                 * message will be sent to the appropriate node during
                 * the next GC.
                 *
                 * Note: This relies on the specific layout of rref_t.
                 */
		cell_t **cancel_list_entry
		    = _p_cancel_lists + ((rref_t *)to)->node;
                *(to + 1) = 0;
                *((cell_t **)(to + 4)) = *cancel_list_entry;
                *cancel_list_entry = (to + 1);
                _p_cancels++;
	    }
	}
#endif /* PARALLEL */		

	return (TRUE);
    }
    else
    {
	return (FALSE);
    }
} /* _p_define() */


/*
 * _p_bad_define()
 *
 * Print a "Bad define" message.  The 'where' argument should be a string
 * of the procedure from which _p_bad_define was called.
 */
void _p_bad_define(where)
char *where;
{
    fprintf(_p_stdout,
	    "(%lu,%lu) Warning: Node %lu: %s: left-hand side of definition already defined in %s:%s\n",
	    (unsigned long) _p_my_id, (unsigned long) _p_reduction,
	    (unsigned long) _p_my_id, where,
	    _p_current_proc->proc->module_name,
	    _p_current_proc->proc->proc_name);
} /* _p_bad_define() */


/*
 * _p_print_banner()
 *
 * Print out the PCN banner to _p_stdout.
 */
void _p_print_banner()
{
    fprintf(_p_stdout,
	    "PCN%s: Version %s%s; Node %lu; %lu node%s, %lu heap.\n",
	    PDB_BANNER_STR, VERSION_STR, _p_user_banner,
	    (unsigned long) _p_my_id,
	    (unsigned long) _p_nodes, (_p_nodes == 1 ? "" : "s"),
	    (unsigned long) _p_heap_size);
    fprintf(_p_stdout, "(See the file: %s)\n", DISCLAIMER_FILE);
    fflush(_p_stdout);
} /* _p_print_banner() */


#ifdef PCN_RENAME_TO_LINK
int _p_rename_to_link(oldname, newname)
char *oldname, *newname;
{
    int rc;
    if ((rc = link((char *) oldname, (char *) newname)) == 0)
    {
	rc = unlink((char *) oldname);
    }
    return (rc);
} /* _p_rename_to_link() */
#endif /* PCN_RENAME_TO_LINK */


#ifdef DEBUG
static char *invalid_function = "invalid foreign function";
/*
 * _p_foreign_lookup()
 *
 * Look up the pointer to the function (func) in the name foreign functions
 * array, and return a pointer to the string of the function's name.
 */
char *_p_foreign_lookup(func)
u_int_t func;
{
    int i;

    for (i = 0; i < _p_foreign_table_size; i++)
    {
	if (func == (u_int_t) _p_foreign_table[i].foreign_ptr)
	    return (_p_foreign_table[i].foreign_name);
    }
    return (invalid_function);
    
} /* _p_foreign_lookup() */
#endif /* DEBUG */

These are the contents of the former NiCE NeXT User Group NeXTSTEP/OpenStep software archive, currently hosted by Marcel Waldvogel and Netfuture.ch.