/*
* mpi_test(+Handle,-Status)
*
* Provides information regarding a handle, ie. if a communication operation has been completed.
* If the operation has been completed the predicate succeeds with the completion status,
* otherwise it fails.
* ).
*/
static YAP_Bool
mpi_test(term_t YAP_ARG1,...) {
YAP_Term t1 = YAP_Deref(YAP_ARG1), // Handle
t2 = YAP_Deref(YAP_ARG2); // Status
MPI_Status status;
MPI_Request *handle;
int flag;
// The first argument (handle) must be an integer
if(!YAP_IsIntTerm(t1)) {
return false;
}
CONT_TIMER();
handle=INT2HANDLE(YAP_IntOfTerm(t1));
//
MPI_CALL(MPI_Test( handle , &flag, &status ));
if( flag != true ) {
PAUSE_TIMER();
return false;
}
free_request(handle);
PAUSE_TIMER();
return(YAP_Unify(t2,YAP_MkIntTerm(status.MPI_ERROR)));
}
/** mpi_wait(+Handle,-Status,-Data
*
* Completes a non-blocking operation. IF the operation was a send, the
* function waits until the message is buffered or sent by the runtime
* system. At this point the send buffer is released. If the operation
* was a receive, it waits until the message is copied to the receive
* buffer.
* .
*/
static YAP_Bool
mpi_wait_recv(term_t YAP_ARG1,...) {
YAP_Term t1 = YAP_Deref(YAP_ARG1); // data
MPI_Status status;
MPI_Request *handle;
char *s;
int ret;
size_t len;
YAP_Term out;
// The first argument (handle) must be an integer
if(!YAP_IsIntTerm(t1)) {
return false;
}
CONT_TIMER();
handle=INT2HANDLE(YAP_IntOfTerm(t1));
s=(char*)get_request(handle);
// wait for communication completion
if( MPI_CALL(MPI_Wait( handle , &status )) != MPI_SUCCESS) {
PAUSE_TIMER();
return false;
}
len=YAP_SizeOfExportedTerm(s);
// make sure we only fetch ARG3 after constructing the term
out = string2term(s,(size_t*)&len);
MSG_RECV(len);
free_request(handle);
PAUSE_TIMER();
ret=YAP_Unify(YAP_ARG3,out);
return(ret & YAP_Unify(YAP_ARG2,YAP_MkIntTerm(status.MPI_ERROR)));
}
/*
* Provides information regarding a handle, ie. if a communication operation has been completed.
* If the operation has been completed the predicate succeeds with the completion status,
* otherwise it fails.
*
* mpi_test(+Handle,-Status,-Data).
*/
static YAP_Bool
mpi_test_recv(void) {
YAP_Term t1 = YAP_Deref(YAP_ARG1); // data
MPI_Status status;
MPI_Request *handle;
int flag,len,ret;
char *s;
YAP_Term out;
// The first argument (handle) must be an integer
if(!YAP_IsIntTerm(t1)) {
return false;
}
CONT_TIMER();
handle=INT2HANDLE(YAP_IntOfTerm(t1));
//
if( MPI_CALL(MPI_Test( handle , &flag, &status ))!=MPI_SUCCESS) {
PAUSE_TIMER();
return false;
}
s=(char*)get_request(handle);
len=strlen(s);
out = string2term(s,(size_t*)&len);
// make sure we only fetch ARG3 after constructing the term
ret=YAP_Unify(YAP_ARG3,out);
free_request(handle);
PAUSE_TIMER();
return(ret & YAP_Unify(YAP_ARG2,YAP_MkIntTerm(status.MPI_ERROR)));
}
/*
* Broadcasts a message from the process with rank "root" to
* all other processes of the group.
* mpi_ibcast(+Root,+Data,+Tag).
*/
static YAP_Bool
my_ibcast(YAP_Term t1,YAP_Term t2, YAP_Term t3) {
int root;
int k,worldsize;
size_t len=0;
char *str;
int tag;
BroadcastRequest *b;
//fprintf(stderr,"ibcast1");
//The arguments should be bound
if(YAP_IsVarTerm(t2) || !YAP_IsIntTerm(t1) || !YAP_IsIntTerm(t3)) {
return false;
}
CONT_TIMER();
// fprintf(stderr,"ibcast2");
MPI_CALL(MPI_Comm_size(MPI_COMM_WORLD,&worldsize));
root = YAP_IntOfTerm(t1);
tag = YAP_IntOfTerm(t3);
str = term2string(NULL,&len,t2);
b=new_broadcast();
if ( b==NULL ) {
PAUSE_TIMER();
return false;
}
//fprintf(stderr,"ibcast3");
for(k=0;k<=worldsize-1;++k) {
if(k!=root) {
MPI_Request *handle=(MPI_Request*)malloc(sizeof(MPI_Request));
MSG_SENT(len);
// Use async send
if(MPI_CALL(MPI_Isend(str, len, MPI_CHAR, k, tag, MPI_COMM_WORLD,handle))!=MPI_SUCCESS) {
free(handle);
PAUSE_TIMER();
return false;
}
new_broadcast_request(b,handle,str);
//new_request(handle,str);
USED_BUFFER();
}
}
if(!b->nreq)//release b if no messages were sent (worldsize==1)
free(b);
#if defined(DEBUG) && defined(MALLINFO)
{
struct mallinfo s = mallinfo();
printf("%d: %d=%d/%d\n",getpid(),s.arena,s.uordblks,s.fordblks); //vsc
}
#endif
PAUSE_TIMER();
//fprintf(stderr,"ibcast4");
return true;
}
/*
* Collective communication function that performs a barrier synchronization among all processes.
* mpi_barrier
*/
static YAP_Bool
mpi_barrier(void) {
CONT_TIMER();
int ret=MPI_CALL(MPI_Barrier(MPI_COMM_WORLD));
PAUSE_TIMER();
return (ret==MPI_SUCCESS?true:false);
}
/*
* Blocking communication function. The message is sent immediatly.
* mpi_send(+Data, +Destination, +Tag).
*/
static YAP_Bool
mpi_send(term_t YAP_ARG1,...) {
YAP_Term t1 = YAP_Deref(YAP_ARG1),
t2 = YAP_Deref(YAP_ARG2),
t3 = YAP_Deref(YAP_ARG3);
char *str=NULL;
int dest,tag;
size_t len=0;
int val;
if (YAP_IsVarTerm(t1) || !YAP_IsIntTerm(t2) || !YAP_IsIntTerm(t3)) {
return false;
}
CONT_TIMER();
//
dest = YAP_IntOfTerm(t2);
tag = YAP_IntOfTerm(t3);
// the data is packaged as a string
str=term2string(NULL,&len,t1);
#if defined(DEBUG) && 0
write_msg(__FUNCTION__,__FILE__,__LINE__,"%s(%s,%u, MPI_CHAR,%d,%d)\n",__FUNCTION__,str,len,dest,tag);
#endif
// send the data
val=(MPI_CALL(MPI_Send( str, len, MPI_CHAR, dest, tag, MPI_COMM_WORLD))==MPI_SUCCESS?true:false);
PAUSE_TIMER();
return(val);
}
static YAP_Bool
mpi_gc(void) {
//write_msg(__FUNCTION__,__FILE__,__LINE__,"MPI_gc>: requests=%d\n",requests->n_entries);
CONT_TIMER();
init_hash_traversal(requests);
gc(requests);
init_hash_traversal(broadcasts);
gc(broadcasts);
//write_msg(__FUNCTION__,__FILE__,__LINE__,"MPI_gc<: requests=%d\n",requests->n_entries);
PAUSE_TIMER();
return true;
}
/*
* Completes a non-blocking operation. IF the operation was a send, the
* function waits until the message is buffered or sent by the runtime
* system. At this point the send buffer is released. If the operation
* was a receive, it waits until the message is copied to the receive
* buffer.
* mpi_wait(+Handle,-Status).
*/
static YAP_Bool
mpi_wait(term_t YAP_ARG1,...) {
YAP_Term t1 = YAP_Deref(YAP_ARG1), // Handle
t2 = YAP_Deref(YAP_ARG2); // Status
MPI_Status status;
MPI_Request *handle;
// The first argument must be an integer (an handle)
if(!YAP_IsIntTerm(t1)) {
return false;
}
handle=INT2HANDLE(YAP_IntOfTerm(t1));
CONT_TIMER();
// probe for term' size
if( MPI_CALL(MPI_Wait( handle , &status )) != MPI_SUCCESS ) {
PAUSE_TIMER();
return false;
}
free_request(handle);
PAUSE_TIMER();
return(YAP_Unify(t2,YAP_MkIntTerm(status.MPI_ERROR)));
}
/*
* Non blocking communication function. The message is sent when possible. To check for the status of the message,
* the mpi_wait and mpi_test should be used. Until mpi_wait is called, the memory allocated for the buffer containing
* the message is not released.
*
* mpi_isend(+Data, +Destination, +Tag, -Handle).
*/
static YAP_Bool
mpi_isend(term_t YAP_ARG1,...) {
YAP_Term t1 = YAP_Deref(YAP_ARG1),
t2 = YAP_Deref(YAP_ARG2),
t3 = YAP_Deref(YAP_ARG3),
t4 = YAP_Deref(YAP_ARG4);
char *str=NULL;
int dest,tag;
size_t len=0;
MPI_Request *handle=(MPI_Request*)malloc(sizeof(MPI_Request));
CONT_TIMER();
if ( handle==NULL ) return false;
if (YAP_IsVarTerm(t1) || !YAP_IsIntTerm(t2) || !YAP_IsIntTerm(t3) || !YAP_IsVarTerm(t4)) {
PAUSE_TIMER();
return false;
}
//
dest = YAP_IntOfTerm(t2);
tag = YAP_IntOfTerm(t3);
//
str=term2string(NULL,&len,t1);
MSG_SENT(len);
// send the data
if( MPI_CALL(MPI_Isend( str, len, MPI_CHAR, dest, tag, MPI_COMM_WORLD ,handle)) != MPI_SUCCESS ) {
PAUSE_TIMER();
return false;
}
#ifdef DEBUG
write_msg(__FUNCTION__,__FILE__,__LINE__,"%s(%s,%u, MPI_CHAR,%d,%d)\n",__FUNCTION__,str,len,dest,tag);
#endif
USED_BUFFER(); // informs the prologterm2c module that the buffer is now used and should not be messed
// We must associate the string to each handle
new_request(handle,str);
PAUSE_TIMER();
return(YAP_Unify(YAP_ARG4,YAP_MkIntTerm(HANDLE2INT(handle))));// it should always succeed
}
/*
* Implements a non-blocking receive operation.
* mpi_irecv(?Source,?Tag,-Handle).
*/
static YAP_Bool
mpi_irecv(term_t YAP_ARG1,...) {
YAP_Term t1 = YAP_Deref(YAP_ARG1),
t2 = YAP_Deref(YAP_ARG2),
t3 = YAP_Deref(YAP_ARG3);
int tag, orig;
MPI_Request *mpi_req=(MPI_Request*)malloc(sizeof(MPI_Request));
// The third argument (data) must be unbound
if(!YAP_IsVarTerm(t3)) {
//Yap_Error(INSTANTIATION_ERROR, t_data, "mpi_receive");
return false;
}
/* The first argument (Source) must be bound to an integer
(the rank of the source) or left unbound (i.e. any source
is OK) */
if (YAP_IsVarTerm(t1)) orig = MPI_ANY_SOURCE;
else if( !YAP_IsIntTerm(t1) ) return false;
else orig = YAP_IntOfTerm(t1);
/* The third argument must be bound to an integer (the tag)
or left unbound (i.e. any tag is OK) */
if (YAP_IsVarTerm(t2)) tag = MPI_ANY_TAG;
else if( !YAP_IsIntTerm(t2) ) return false;
else tag = YAP_IntOfTerm( t2 );
CONT_TIMER();
RESET_BUFFER();
if( MPI_CALL(MPI_Irecv( BUFFER_PTR, BLOCK_SIZE, MPI_CHAR, orig, tag,
MPI_COMM_WORLD, mpi_req )) != MPI_SUCCESS ) {
PAUSE_TIMER();
return false;
}
new_request(mpi_req,BUFFER_PTR);
DEL_BUFFER();
PAUSE_TIMER();
return YAP_Unify(t3,YAP_MkIntTerm(HANDLE2INT(mpi_req)));
}
/*
* Broadcasts a message from the process with rank "root" to
* all other processes of the group.
* Note: Collective communication means all processes within a communicator call the same routine.
* To be able to use a regular MPI_Recv to recv the messages, one should use mpi_bcast2
*
* mpi_bcast(+Root,+Data).
*/
static YAP_Bool
mpi_bcast(term_t YAP_ARG1,...) {
YAP_Term t1 = YAP_Deref(YAP_ARG1),
t2 = YAP_Deref(YAP_ARG2);
int root,val;
size_t len=0;
char *str;
int rank;
//The arguments should be bound
if(!YAP_IsIntTerm(t1)) {
return false;
}
MPI_CALL(MPI_Comm_rank(MPI_COMM_WORLD, &rank));
CONT_TIMER();
root = YAP_IntOfTerm(t1);
if (root == rank) {
str=term2string(NULL,&len,t2);
#ifdef DEBUG
write_msg(__FUNCTION__,__FILE__,__LINE__,"mpi_bcast(%s,%u, MPI_CHAR,%d)\n",str,len,root);
#endif
} else {
RESET_BUFFER();
str = BUFFER_PTR;
len = BLOCK_SIZE;
}
// send the data
val=(MPI_CALL(MPI_Bcast( str, len, MPI_CHAR, root, MPI_COMM_WORLD))==MPI_SUCCESS?true:false);
#ifdef MPISTATS
{
int size;
MPI_CALL(MPI_Comm_size(MPI_COMM_WORLD, &size));
MSG_SENT(len*size);
}
#endif
PAUSE_TIMER();
if (root != rank) {
YAP_Term out;
len=YAP_SizeOfExportedTerm(str);
// make sure we only fetch ARG3 after constructing the term
out = string2term(str,(size_t*)&len);
MSG_RECV(len);
if (!YAP_Unify(YAP_ARG2, out))
return false;
}
return(val);
}
/*
* Broadcasts a message from the process with rank "root" to
* all other processes of the group.
* Note: Collective communication means all processes within a communicator call the same routine.
* To be able to use a regular MPI_Recv to recv the messages, one should use mpi_bcast2
* mpi_bcast_int(+Root,+Data,+Tag).
*/
static YAP_Bool
my_bcast(YAP_Term t1,YAP_Term t2, YAP_Term t3) {
int root;
int k,worldsize;
size_t len=0;
char *str;
int tag;
//The arguments should be bound
if(YAP_IsVarTerm(t2) || !YAP_IsIntTerm(t1) || !YAP_IsIntTerm(t3)) {
return false;
}
CONT_TIMER();
MPI_CALL(MPI_Comm_size(MPI_COMM_WORLD,&worldsize));
root = YAP_IntOfTerm(t1);
tag = YAP_IntOfTerm(t3);
str=term2string(NULL,&len,t2);
for(k=0;k<=worldsize-1;++k)
if(k!=root) {
// Use async send?
MSG_SENT(len);
if(MPI_CALL(MPI_Send( str, len, MPI_CHAR, k, tag, MPI_COMM_WORLD))!=MPI_SUCCESS) {
PAUSE_TIMER();
return false;
}
#ifdef DEBUG
write_msg(__FUNCTION__,__FILE__,__LINE__,"bcast2(%s,%u, MPI_CHAR,%d,%d)\n",str,len,k,tag);
#endif
}
PAUSE_TIMER();
return true;
}
/*
* Implements a blocking receive operation.
* mpi_recv(?Source,?Tag,-Data).
*/
static YAP_Bool
mpi_recv(term_t YAP_ARG1,...) {
YAP_Term t1 = YAP_Deref(YAP_ARG1),
t2 = YAP_Deref(YAP_ARG2),
t3 = YAP_Deref(YAP_ARG3),
t4;
int tag, orig;
int len=0;
MPI_Status status;
//The third argument (data) must be unbound
if(!YAP_IsVarTerm(t3)) {
return false;
}
/* The first argument (Source) must be bound to an integer
(the rank of the source) or left unbound (i.e. any source
is OK) */
if (YAP_IsVarTerm(t1)) orig = MPI_ANY_SOURCE;
else if( !YAP_IsIntTerm(t1) ) return false;
else orig = YAP_IntOfTerm(t1);
/* The second argument must be bound to an integer (the tag)
or left unbound (i.e. any tag is OK) */
if (YAP_IsVarTerm(t2)) tag = MPI_ANY_TAG;
else if( !YAP_IsIntTerm(t2) ) return false;
else tag = YAP_IntOfTerm( t2 );
CONT_TIMER();
// probe for term' size
if( MPI_CALL(MPI_Probe( orig, tag, MPI_COMM_WORLD, &status )) != MPI_SUCCESS) {
PAUSE_TIMER();
return false;
}
if( MPI_CALL(MPI_Get_count( &status, MPI_CHAR, &len )) != MPI_SUCCESS ||
status.MPI_TAG==MPI_UNDEFINED ||
status.MPI_SOURCE==MPI_UNDEFINED) {
PAUSE_TIMER();
return false;
}
//realloc memory buffer
change_buffer_size((size_t)(len+1));
BUFFER_LEN=len;
// Already know the source from MPI_Probe()
if( orig == MPI_ANY_SOURCE ) {
orig = status.MPI_SOURCE;
if( !YAP_Unify(t1, YAP_MkIntTerm(orig))) {
PAUSE_TIMER();
return false;
}
}
// Already know the tag from MPI_Probe()
if( tag == MPI_ANY_TAG ) {
tag = status.MPI_TAG;
if( !YAP_Unify(t2, YAP_MkIntTerm(status.MPI_TAG))) {
PAUSE_TIMER();
return false;
}
}
// Receive the message as a string
if( MPI_CALL(MPI_Recv( BUFFER_PTR, BUFFER_LEN, MPI_CHAR, orig, tag,
MPI_COMM_WORLD, &status )) != MPI_SUCCESS ) {
/* Getting in here should never happen; it means that the first
package (containing size) was sent properly, but there was a glitch with
the actual content! */
PAUSE_TIMER();
return false;
}
#ifdef DEBUG
write_msg(__FUNCTION__,__FILE__,__LINE__,"%s(%s,%u, MPI_CHAR,%d,%d)\n",__FUNCTION__,BUFFER_PTR, BUFFER_LEN, orig, tag);
#endif
MSG_RECV(BUFFER_LEN);
t4=string2term(BUFFER_PTR,&BUFFER_LEN);
PAUSE_TIMER();
return(YAP_Unify(YAP_ARG3,t4));
}
