add MPI_Comm_spawn support

diff --git a/Simple.pm b/Simple.pm
index 3733eb7d425c102e80147dfc4979116fb7abd71d..12106702cdb9c380cbdce136393e5f8ff28670e6 100644 (file)
--- a/Simple.pm
+++ b/Simple.pm
@@ -18,7 +18,7 @@ sub import {
     foreach (qw(Init Finalize COMM_WORLD ANY_SOURCE Comm_rank Comm_size
                Recv Send Barrier Bcast Gather
                Scatter Allgather Alltoall Reduce
-               Comm_compare Comm_dup Comm_free Comm_split
+               Comm_compare Comm_dup Comm_free Comm_split Comm_spawn
               )) {
        *{$call.'::MPI_'.$_} = \&$_;
     }
@@ -501,6 +501,24 @@ sub Reduce {
   Bcast($rt, 0, $comm);
 }
 
+=head2 MPI_Comm_spawn
+
+ $intercomm = MPI_Comm_spawn($maxprocs,$comm,$root,$command,@arguments);
+
+Spawns C<$maxprocs> binaries running C<$command> with arguments
+C<@arguments>. Will die on any failures to launch commands. Returns a
+communicator which communicates between the parents and the children.
+
+
+=cut
+
+
+sub Comm_spawn {
+    my ($maxprocs,$comm,$root,$command,@arguments) = @_;
+    return _Comm_spawn($command,@arguments,$maxprocs,$root,$comm);
+}
+
+
 1; # I am the ANTI-POD!
 
 =head1 PHILOSOPHY

diff --git a/Simple.xs b/Simple.xs
index 288ad5930eae4ddeac2d4fe6f7a3eea054ef921c..802eca85f6391107a9209589511b4f8b7c1a2ee1 100644 (file)
--- a/Simple.xs
+++ b/Simple.xs
@@ -95,6 +95,47 @@ int _Comm_size (SV* comm) {
   return tsize;
 }
 
+/* spawns a command running on other hosts */
+SV* _Comm_spawn(SV* command, AV* argv, int maxprocs, int root, SV* comm) {
+  MPI_Comm intercomm;
+  int* array_of_errcodes;
+  int error;
+  char** argv_new;
+  I32 len;
+  I32 key;
+  int i;
+  int size;
+  
+  /* create the argv needed to pass to MPI_comm_spawn */
+  len = av_len(argv);
+  Newx(argv_new,len < 0 ? 1 : len+2,char*);
+  for (key = 0; key <= len; key++) {
+    argv_new[key]=SvPV_nolen(*av_fetch(argv,key,0));
+  }
+  Newx(argv_new[len < 0 ? 0:len+1],1,char);
+  argv_new[len < 0 ? 0:len+1][0] = 0;
+
+  /* eventually we should handle MPI_INFO, but since I don't need it
+     yet, not bothering. */
+  error = MPI_comm_spawn(SvPV_nolen(command),
+                        argv_new,maxprocs,
+                        MPI_INFO_NULL,root,
+                        (MPI_Comm)SvIVX(comm),
+                        &intercomm,&array_of_errcodes);
+  Safefree(argv_new[len < 0 ? 0:len+1]);
+  Safefree(argv_new);
+  if (error != 0)
+    croak("Unable to spawn process");
+  /* figure out how many processes were spawned, and check to see if there were errors */
+  MPI_Comm_size(intercomm, &size);
+  for(i = 0; i < size; i++) {
+    if (array_of_errcodes[i] != 0)
+      croak("Process did not spawn properly");
+  }
+  return newSViv((IV)intercomm);
+  
+}
+
 /* returns SV whose IV slot is a cast pointer to the MPI_COMM_WORLD object */
 SV* COMM_WORLD () {
   return newSViv((IV)MPI_COMM_WORLD);