trans-decl.c (create_main_function): Move call of _gfortran_caf_init right before cal to MAIN__().

2018-09-02  Thomas Koenig  <tkoenig@gcc.gnu.org>
	    Nicolas Koenig  <koenigni@gcc.gnu.org>

	* trans-decl.c (create_main_function): Move call of
	_gfortran_caf_init right before cal to MAIN__().

2018-09-02  Thomas Koenig  <tkoenig@gcc.gnu.org>
	    Nicolas Koenig <koenigni@gcc.gnu.org>

	* caf/multi.c: Some cleanup.
	(image_num): Rename to _gfortrani_caf_this_image.
	(sim): New static variable.
	(cim): Likewise.
	(cond_t): New type.
	(init_image): Some reformatting.
	(_gfortran_caf_init): Handle arrays of conditions and number for
	sync images.
	(cond_init): New function.
	(cond_wait): New function.
	(cond_signal): New function.
	(A): Macro to simplify array access.
	(_gfortran_caf_sync_images): New function.
	* libgfortran.h (caf_num_images): New static variable.
	(_gfortrani_caf_this_image): New static variable.
	* runtime/compile_options.c (set_options): Return early if
	we are in a dependent image.
	* runtime/environ.c (static_variable_table): Add
	GFORTRAN_CAF_IMAGES with default of 4.
	* runtime/main.c (set_args): Return early if we are in a
	dependent variable.


Co-Authored-By: Nicolas Koenig <koenigni@gcc.gnu.org>

From-SVN: r264040

8 files changed, 209 insertions, 64 deletions

diff --git a/gcc/fortran/ChangeLog.dev b/gcc/fortran/ChangeLog.dev
index fec5078..82c9afd4 100644
--- a/gcc/fortran/ChangeLog.dev
+++ b/gcc/fortran/ChangeLog.dev
@@ -1,3 +1,9 @@
+2018-09-02  Thomas Koenig  <tkoenig@gcc.gnu.org>
+	    Nicolas Koenig  <koenigni@gcc.gnu.org>
+
+	* trans-decl.c (create_main_function): Move call of
+	_gfortran_caf_init right before cal to MAIN__().
+
 2018-08-26  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
 
 	* Development log for native coarray fortran.
diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index eea6b81..64178f0 100644
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -5969,20 +5969,6 @@ create_main_function (tree fndecl)
 
   /* Call some libgfortran initialization routines, call then MAIN__().  */
 
-  /* Call _gfortran_caf_init (*argc, ***argv).  */
-  if (flag_coarray == GFC_FCOARRAY_LIB)
-    {
-      tree pint_type, pppchar_type;
-      pint_type = build_pointer_type (integer_type_node);
-      pppchar_type
-	= build_pointer_type (build_pointer_type (pchar_type_node));
-
-      tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_init, 2,
-		gfc_build_addr_expr (pint_type, argc),
-		gfc_build_addr_expr (pppchar_type, argv));
-      gfc_add_expr_to_block (&body, tmp);
-    }
-
   /* Call _gfortran_set_args (argc, argv).  */
   TREE_USED (argc) = 1;
   TREE_USED (argv) = 1;
@@ -6088,6 +6074,20 @@ create_main_function (tree fndecl)
       gfc_add_expr_to_block (&body, tmp);
     }
 
+  /* Call _gfortran_caf_init (*argc, ***argv).  */
+  if (flag_coarray == GFC_FCOARRAY_LIB)
+    {
+      tree pint_type, pppchar_type;
+      pint_type = build_pointer_type (integer_type_node);
+      pppchar_type
+	= build_pointer_type (build_pointer_type (pchar_type_node));
+
+      tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_init, 2,
+		gfc_build_addr_expr (pint_type, argc),
+		gfc_build_addr_expr (pppchar_type, argv));
+      gfc_add_expr_to_block (&body, tmp);
+    }
+
   /* Call MAIN__().  */
   tmp = build_call_expr_loc (input_location,
 			 fndecl, 0);
diff --git a/libgfortran/ChangeLog.dev b/libgfortran/ChangeLog.dev
index 9ae6ef0..2256372 100644
--- a/libgfortran/ChangeLog.dev
+++ b/libgfortran/ChangeLog.dev
@@ -1,5 +1,30 @@
+2018-09-02  Thomas Koenig  <tkoenig@gcc.gnu.org>
+	    Nicolas Koenig <koenigni@gcc.gnu.org>
+
+	* caf/multi.c: Some cleanup.
+	(image_num): Rename to _gfortrani_caf_this_image.
+	(sim): New static variable.
+	(cim): Likewise.
+	(cond_t): New type.
+	(init_image): Some reformatting.
+	(_gfortran_caf_init): Handle arrays of conditions and number for
+	sync images.
+	(cond_init): New function.
+	(cond_wait): New function.
+	(cond_signal): New function.
+	(A): Macro to simplify array access.
+	(_gfortran_caf_sync_images): New function.
+	* libgfortran.h (caf_num_images): New static variable.
+	(_gfortrani_caf_this_image): New static variable.
+	* runtime/compile_options.c (set_options): Return early if
+	we are in a dependent image.
+	* runtime/environ.c (static_variable_table): Add
+	GFORTRAN_CAF_IMAGES with default of 4.
+	* runtime/main.c (set_args): Return early if we are in a
+	dependent variable.
+
 2018-08-28  Nicolas Koenig  <koenigni@gcc.gnu.org>
-	
+
 	* caf/multi.c: New file
 
 2018-08-26  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
diff --git a/libgfortran/caf/multi.c b/libgfortran/caf/multi.c
index b0405c3..d980436e 100644
--- a/libgfortran/caf/multi.c
+++ b/libgfortran/caf/multi.c
@@ -26,17 +26,23 @@ a copy of the GCC Runtime Library Exception along with this program;
 see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
 <http://www.gnu.org/licenses/>.  */
 
-#include"libcaf.h"
-#include<pthread.h> // gthreads needed here?
-#include<stdlib.h>
-#include<stdio.h>
+#include "libcaf.h"
+#include <pthread.h>
+#include <stdlib.h>
+#include <stdio.h>
 
-// types
+/* Currently compile programs which call this with
+
+$ gfortran -static-libgfortran -fcoarray=lib foo.f90 -pthread -lcaf_multi
+
+*/
 
 int main(int argc, char **argv);
 
+/* Types.  */
+
 typedef struct {
-  int image_num;
+  int this_image;
   int argc;
   char **argv;
 } init_args;
@@ -45,65 +51,76 @@ typedef struct {
   void **base_array;
 } caf_multi_token_t;
 
-// static vars
+typedef struct cond_t {
+  pthread_cond_t cond;
+  int signalled;
+  pthread_mutex_t mutex;
+} cond_t;
+
+/* Static variables.  */
 
-__thread int image_num = -1;
-int num_images = -1;
+__thread int _gfortrani_caf_this_image = -1;
+int caf_num_images = -1;
 pthread_barrier_t sync_all_barrier;
 pthread_t *tidlist;
 
-// functions
+static int *sim;
+static cond_t *cim;
+
+static int cond_init(cond_t *cond);
 
 static void *
-init_image (void *p) {
+init_image (void *p)
+{
   init_args args = *(init_args *) p; 
   free(p);
 
-  image_num = args.image_num;
+  _gfortrani_caf_this_image = args.this_image;
 
-  pthread_barrier_wait(&sync_all_barrier);
+  pthread_barrier_wait (&sync_all_barrier);
+
+ /* XXX: Must be called since there is no other way to set the
+ options for the images since _gfortran_set_option is called after
+ _gfortran_caf_init and options is a local variable in main. It would
+ be better to switch to calling MAIN__ once we have the new
+ interface.  */
 
-  main(args.argc, args.argv); //XXX: Must be called since there is no other
-  			      //     way to set the options for the images
-			      //     since _gfortran_set_option is called
-			      //     after _gfortran_caf_init and options
-			      //     is a local variable in main. It would
-			      //     be better to switch to calling MAIN
-			      //     once we have the new interface.
+  main (args.argc, args.argv);
 
   return NULL;
 }
 
 void
-_gfortran_caf_init (int *argcptr, char ***argvptr) {
-  if (image_num > 0) // to ensure the function is only
-    return	     // executed once after calling main
-		     // recursively
-
-  int i;
-  int nimages = 4; //XXX
+_gfortran_caf_init (int *argcptr, char ***argvptr)
+{
   init_args *args;
-  pthread_t tid;
   
-  num_images = nimages;
-   
-  pthread_barrier_init(&sync_all_barrier, NULL, nimages);  
+  /* Ensure the function is only executed once after calling main
+     recursively.  */
+  if (_gfortrani_caf_this_image > 0)
+    return; 
+
+  pthread_barrier_init (&sync_all_barrier, NULL, caf_num_images);  
   
-  tidlist = malloc(nimages*sizeof(pthread_t));
+  tidlist = calloc (caf_num_images, sizeof(pthread_t));
+  sim = calloc(caf_num_images * caf_num_images, sizeof(int));
+  cim = calloc(caf_num_images * caf_num_images, sizeof(cond_t));
+
+  for (int i = 0; i < caf_num_images; i++)
+    cond_init(cim + i);
 
-  for(i = 1; i < num_images; i++) {
-    args = malloc(sizeof(init_args)); 
-    args->image_num = i;
+  for (int i = 1; i < caf_num_images; i++) {
+    args = malloc (sizeof (init_args)); 
+    args->this_image = i;
     args->argc = *argcptr;
     args->argv = *argvptr;
-    pthread_create(&tid, NULL, init_image, args);
-    tidlist[i] = tid;
+    pthread_create (tidlist + i, NULL, init_image, args);
   }
   
-  tidlist[0] = pthread_self();
-  image_num = 0;
+  tidlist[0] = pthread_self ();
+  _gfortrani_caf_this_image = 0;
 
-  pthread_barrier_wait(&sync_all_barrier);
+  pthread_barrier_wait (&sync_all_barrier);
 }
 
 /*
@@ -123,7 +140,7 @@ _gfortran_caf_register (size_t size, caf_register_t type, caf_token_t *token,
 	  *t = malloc(sizeof(caf_multi_token_t)); 
 	  (*t)->base_array = malloc(get_num_images()*size);
 	}
-      data->base_addr = (*t)->base_array+image_num*size;
+      data->base_addr = (*t)->base_array+this_image*size;
       pthread_mutex_unlock(&lock);
     }
   else
@@ -158,15 +175,15 @@ void
 _gfortran_caf_finalize(void) 
 { 
   int i;
-  if (image_num != 0)
+  if (_gfortrani_caf_this_image != 0)
     pthread_exit(NULL);
-  for (i = 1; i<num_images; i++)
+  for (i = 1; i < caf_num_images; i++)
     pthread_join(tidlist[i], NULL);
 }
 
 int
 _gfortran_caf_this_image(int distance) {
-  return image_num+1;
+  return _gfortrani_caf_this_image+1;
 }
 
 
@@ -174,11 +191,95 @@ int
 _gfortran_caf_num_images (int distance __attribute__ ((unused)),
 			  int failed __attribute__ ((unused)))
 {
-  return num_images;
+  return caf_num_images;
+}
+
+static int
+cond_init(cond_t *cond)
+{
+  pthread_mutex_init (&cond->mutex, NULL);
+  pthread_cond_init (&cond->cond, NULL);
+  cond->signalled = 0;
+  return 0;
 }
 
-// Probably has a race condition, if a thread reaches the barrier before
-// all have left, but I'm not certain how that works
+static int
+cond_wait (cond_t * cond)
+{
+  while (!cond->signalled)
+    pthread_cond_wait (&cond->cond, &cond->mutex);
+
+  cond->signalled = 0;
+  pthread_mutex_unlock (&cond->mutex);
+  return 0;
+}
+
+static int
+cond_signal (cond_t *cond)
+{
+  cond->signalled = 1;
+  pthread_cond_signal (&cond->cond);
+  pthread_mutex_unlock (&cond->mutex);
+  return 0;
+}
+
+#define A(i,j) (sim[(i) + caf_num_images * (j)])
+
+void
+_gfortran_caf_sync_images (int count __attribute__ ((unused)),
+			   int images[] __attribute__ ((unused)),
+			   int *stat,
+			   char *errmsg __attribute__ ((unused)),
+			   size_t errmsg_len __attribute__ ((unused)))
+{
+  pthread_mutex_t *my_mutex;
+
+  for (int i=0; i < count; i++)
+    {
+      if (images[i] - 1 != _gfortrani_caf_this_image)
+	{
+	  cond_t *other_thread = cim + images[i] - 1;
+	  pthread_mutex_lock (&other_thread->mutex);
+	  A(_gfortrani_caf_this_image, images[i] - 1) ++;
+	  cond_signal(other_thread);
+	}
+    }
+
+  while (1)
+    {
+      int x;
+      int do_wait = 0;
+
+      my_mutex =  &(cim[_gfortrani_caf_this_image].mutex);
+      pthread_mutex_lock (my_mutex);
+
+      for (int i = 0; i < count; i++)
+	{
+	  if (images[i] - 1 != _gfortrani_caf_this_image)
+	    {
+	      x = A(images[i] - 1,_gfortrani_caf_this_image)
+		< A(_gfortrani_caf_this_image, images[i] - 1);
+	      if (x)
+		{
+		  do_wait = 1;
+		  break;
+		}
+	    }
+	}
+
+      if (do_wait)
+	  cond_wait(cim + _gfortrani_caf_this_image);
+      else
+	break;
+    }
+  pthread_mutex_unlock (my_mutex);
+}
+
+#undef A
+
+/* Probably has a race condition, if a thread reaches the barrier
+   before all have left, but I'm not certain how that works.  */
+
 void
 _gfortran_caf_sync_all (int *stat,
 			char *errmsg __attribute__ ((unused)),
diff --git a/libgfortran/libgfortran.h b/libgfortran/libgfortran.h
index b5a742a..64ae8d7 100644
--- a/libgfortran/libgfortran.h
+++ b/libgfortran/libgfortran.h
@@ -1746,7 +1746,8 @@ void cshift1_16_c16 (gfc_array_c16 * const restrict,
 internal_proto(cshift1_16_c16);
 #endif
 
-/* Define this if we support asynchronous I/O on this platform.  This
-   currently requires weak symbols.  */
+extern int caf_num_images;
+internal_proto(caf_num_images);
+extern __thread int _gfortrani_caf_this_image;
 
 #endif  /* LIBGFOR_H  */
diff --git a/libgfortran/runtime/compile_options.c b/libgfortran/runtime/compile_options.c
index 1d37e77..ef8777e 100644
--- a/libgfortran/runtime/compile_options.c
+++ b/libgfortran/runtime/compile_options.c
@@ -145,6 +145,12 @@ export_proto(set_options);
 void
 set_options (int num, int options[])
 {
+  /* Do not set options if we're not in the main program
+     of a pthread coarray application.  */
+
+  if (_gfortrani_caf_this_image > 0)
+    return;
+
   if (num >= 1)
     compile_options.warn_std = options[0];
   if (num >= 2)
diff --git a/libgfortran/runtime/environ.c b/libgfortran/runtime/environ.c
index 22faad3..c65754b 100644
--- a/libgfortran/runtime/environ.c
+++ b/libgfortran/runtime/environ.c
@@ -217,6 +217,9 @@ static variable variable_table[] = {
   /* Print out a backtrace if possible on runtime error */
   { "GFORTRAN_ERROR_BACKTRACE", -1, &options.backtrace, init_boolean },
 
+  /* Number of images to start with -fcoarray=pthread.  */
+  { "GFORTRAN_CAF_IMAGES", 4, &caf_num_images, init_integer },
+
   { NULL, 0, NULL, NULL }
 };
 
diff --git a/libgfortran/runtime/main.c b/libgfortran/runtime/main.c
index f434e5b..81e52f7 100644
--- a/libgfortran/runtime/main.c
+++ b/libgfortran/runtime/main.c
@@ -43,6 +43,9 @@ static char **argv_save;
 void
 set_args (int argc, char **argv)
 {
+  if (_gfortrani_caf_this_image > 0)
+    return;
+
   argc_save = argc;
   argv_save = argv;
 }