Generate a runtime error on recursive I/O, thread-safe

This patch is a version of Jerry's patch with one additional feature.
When locking a unit, the thread ID of the locking thread also stored
in the gfc_unit structure. When the unit is found to be locked, it can
be either have been locked by the same thread (bad, recursive I/O) or
by another thread (harmless).

Regression-tested fully (make -j8 check in the gcc build directory) on
Linux, which links in pthreads by default.  Steve checked on FreeBSD,
which does not do so.

Jerry DeLisle  <jvdelisle@gcc.gnu.org>
Thomas Koenig <tkoenig@gcc.gnu.org>

PR libfortran/119136

gcc/fortran/ChangeLog:

	* libgfortran.h: Add enum for new LIBERROR_RECURSIVE_IO.

libgfortran/ChangeLog:

	* io/async.h (UNLOCK_UNIT): New macro.
	(TRYLOCK_UNIT): New macro.
	(LOCK_UNIT): New macro.
	* io/io.h: Delete prototype for unused stash_internal_unit.
	(check_for_recursive): Add prototype for this new function.
	* io/transfer.c (data_transfer_init): Add call to new
	check_for_recursive.
	* io/unit.c (delete_unit): Fix comment.
	(check_for_recursive): Add new function.
	(init_units): Use new macros.
	(close_unit_1): Likewise.
	(unlock_unit): Likewise.
	* io/unix.c (flush_all_units_1): Likewise.
	(flush_all_units): Likewise.
	* runtime/error.c (translate_error): : Add translation for
	"Recursive I/O not allowed runtime error message.

gcc/testsuite/ChangeLog:

	* gfortran.dg/pr119136.f90: New test.

gcc/fortran/libgfortran.h

@@ -143,6 +143,7 @@ typedef enum
   LIBERROR_INQUIRE_INTERNAL_UNIT, /* Must be different from STAT_STOPPED_IMAGE.  */
   LIBERROR_BAD_WAIT_ID,
   LIBERROR_NO_MEMORY,
+  LIBERROR_RECURSIVE_IO,
   LIBERROR_LAST			/* Not a real error, the last error # + 1.  */
 }
 libgfortran_error_codes;

gcc/testsuite/gfortran.dg/pr119136.f90

@@ -0,0 +1,10 @@
+! { dg-do run }
+! { dg-shouldfail "Recursive" }
+  print *, foo_io()
+contains
+  function foo_io()
+    integer :: foo_io(2)
+    print * , "foo"
+    foo_io = [42, 42]
+  end function
+end

libgfortran/io/async.h

@@ -175,6 +175,11 @@
     INTERN_UNLOCK (mutex);						\
   }while (0)
 
+#define UNLOCK_UNIT(unit) do { \
+  unit->self = 0;							\
+  UNLOCK(&(unit)->lock);						\
+  } while(0)
+
 #define TRYLOCK(mutex) ({						\
 			 char status[200];				\
 			 int res;					\
@@ -198,6 +203,30 @@
 			 res;						\
     })
 
+#define TRYLOCK_UNIT(unit) ({					\
+			 char status[200];				\
+			 int res;					\
+			 aio_lock_debug *curr;				\
+			 __gthread_mutex_t *mutex = &(unit)->lock;	\
+			 res = __gthread_mutex_trylock (mutex);		\
+			 INTERN_LOCK (&debug_queue_lock);		\
+			 if (res) {					\
+			   if ((curr = IN_DEBUG_QUEUE (mutex))) {	\
+			     sprintf (status, DEBUG_RED "%s():%d" DEBUG_NORM, curr->func, curr->line);	\
+			   } else					\
+			     sprintf (status, DEBUG_RED "unknown" DEBUG_NORM);	\
+			 }						\
+			 else {						\
+			   sprintf (status, DEBUG_GREEN "unlocked" DEBUG_NORM);	\
+			   MUTEX_DEBUG_ADD (mutex);			\
+			 }						\
+			 DEBUG_PRINTF ("%s%-44s prev: %-35s %20s():%-5d %18p\n", aio_prefix, \
+				      DEBUG_DARKRED "TRYLOCK: " DEBUG_NORM #unit, status, __FUNCTION__, __LINE__, \
+				      (void *) mutex);			\
+			 INTERN_UNLOCK (&debug_queue_lock);		\
+			 res;						\
+    })
+
 #define LOCK(mutex) do {						\
     char status[200];							\
     CHECK_LOCK (mutex, status);						\
@@ -210,6 +239,12 @@
     DEBUG_PRINTF ("%s" DEBUG_RED "ACQ:" DEBUG_NORM " %-30s %78p\n", aio_prefix, #mutex, mutex); \
   } while (0)
 
+
+#define LOCK_UNIT(unit) do {		\
+    LOCK (&(unit)->lock);		\
+    (unit)->self = __gthread_self ();	\
+  } while (0)
+
 #ifdef __GTHREAD_RWLOCK_INIT
 #define RWLOCK_DEBUG_ADD(rwlock) do {		\
     aio_rwlock_debug *n;				\
@@ -341,8 +376,29 @@
 #define DEBUG_LINE(...)
 #define T_ERROR(func, ...) func(__VA_ARGS__)
 #define LOCK(mutex) INTERN_LOCK (mutex)
+#define LOCK_UNIT(unit) do {				    \
+    if (__gthread_active_p ()) {			    \
+      LOCK (&(unit)->lock); (unit)->self = __gthread_self ();	\
+    }								\
+  } while(0)
 #define UNLOCK(mutex) INTERN_UNLOCK (mutex)
+#define UNLOCK_UNIT(unit) do {						\
+    if (__gthread_active_p ()) {					\
+      (unit)->self = 0 ; UNLOCK(&(unit)->lock);				\
+    }									\
+  } while(0)
 #define TRYLOCK(mutex) (__gthread_mutex_trylock (mutex))
+#define TRYLOCK_UNIT(unit) ({					\
+      int res;							\
+      if (__gthread_active_p ()) {				\
+	res = __gthread_mutex_trylock (&(unit)->lock);		\
+	if (!res)						\
+	  (unit)->self = __gthread_self ();			\
+      }								\
+      else							\
+	res = 0;						\
+      res;							\
+    })
 #ifdef __GTHREAD_RWLOCK_INIT
 #define RDLOCK(rwlock) INTERN_RDLOCK (rwlock)
 #define WRLOCK(rwlock) INTERN_WRLOCK (rwlock)

libgfortran/io/io.h

@@ -728,6 +728,9 @@ typedef struct gfc_unit
   int last_char;
   bool has_size;
   GFC_IO_INT size_used;
+#ifdef __GTHREADS_CXX0X
+  __gthread_t self;
+#endif
 }
 gfc_unit;
 
@@ -782,8 +785,8 @@ internal_proto(close_unit);
 extern gfc_unit *set_internal_unit (st_parameter_dt *, gfc_unit *, int);
 internal_proto(set_internal_unit);
 
-extern void stash_internal_unit (st_parameter_dt *);
-internal_proto(stash_internal_unit);
+extern void check_for_recursive (st_parameter_dt *dtp);
+internal_proto(check_for_recursive);
 
 extern gfc_unit *find_unit (int);
 internal_proto(find_unit);

libgfortran/io/transfer.c

@@ -3129,6 +3129,8 @@ data_transfer_init (st_parameter_dt *dtp, int read_flag)
 
   NOTE ("data_transfer_init");
 
+  check_for_recursive (dtp);
+
   ionml = ((cf & IOPARM_DT_IONML_SET) != 0) ? dtp->u.p.ionml : NULL;
 
   memset (&dtp->u.p, 0, sizeof (dtp->u.p));

libgfortran/io/unit.c

@@ -247,7 +247,7 @@ insert_unit (int n)
 #else
   __GTHREAD_MUTEX_INIT_FUNCTION (&u->lock);
 #endif
-  LOCK (&u->lock);
+  LOCK_UNIT (u);
   u->priority = pseudo_random ();
   unit_root = insert (u, unit_root);
   return u;
@@ -324,8 +324,7 @@ delete_unit (gfc_unit *old)
 }
 
 /* get_gfc_unit_from_root()-- Given an integer, return a pointer
-   to the unit structure. Returns NULL if the unit does not exist,
-   otherwise returns a locked unit. */
+   to the unit structure. Returns NULL if the unit does not exist.  */
 
 static inline gfc_unit *
 get_gfc_unit_from_unit_root (int n)
@@ -346,6 +345,41 @@ get_gfc_unit_from_unit_root (int n)
   return p;
 }
 
+/* Recursive I/O is not allowed. Check to see if the UNIT exists and if
+   so, check if the UNIT is locked already.  This check does not apply
+   to DTIO.  */
+void
+check_for_recursive (st_parameter_dt *dtp)
+{
+  gfc_unit *p;
+
+  p = get_gfc_unit_from_unit_root(dtp->common.unit);
+  if (p != NULL)
+    {
+      if (!(dtp->common.flags & IOPARM_DT_HAS_INTERNAL_UNIT))
+      /* The unit p is external.  */
+	{
+	  /* Check if this is a parent I/O.  */
+	  if (p->child_dtio == 0)
+	    {
+	      if (TRYLOCK_UNIT(p))
+		{
+		  /* The lock failed.  This unit is locked either our own
+		     thread, which is illegal recursive I/O, or somebody by
+		     else, in which case we are doing OpenMP or similar; this
+		     is harmless and permitted.  */
+		  __gthread_t locker = __atomic_load_n (&p->self, __ATOMIC_RELAXED);
+		  if (locker == __gthread_self ())
+		    generate_error (&dtp->common, LIBERROR_RECURSIVE_IO, NULL);
+		  return;
+		}
+	      else
+		UNLOCK(&p->lock);
+	    }
+	}
+    }
+}
+
 /* get_gfc_unit()-- Given an integer, return a pointer to the unit
    structure.  Returns NULL if the unit does not exist,
    otherwise returns a locked unit. */
@@ -412,7 +446,7 @@ found:
   if (p != NULL && (p->child_dtio == 0))
     {
       /* Fast path.  */
-      if (! TRYLOCK (&p->lock))
+      if (! TRYLOCK_UNIT (p))
 	{
 	  /* assert (p->closed == 0); */
 	  RWUNLOCK (&unit_rwlock);
@@ -427,11 +461,11 @@ found:
 
   if (p != NULL && (p->child_dtio == 0))
     {
-      LOCK (&p->lock);
+      LOCK_UNIT (p);
       if (p->closed)
 	{
 	  WRLOCK (&unit_rwlock);
-	  UNLOCK (&p->lock);
+	  UNLOCK_UNIT (p);
 	  if (predec_waiting_locked (p) == 0)
 	    destroy_unit_mutex (p);
 	  goto retry;
@@ -678,7 +712,7 @@ init_units (void)
 
       fbuf_init (u, 0);
 
-      UNLOCK (&u->lock);
+      UNLOCK_UNIT (u);
     }
 
   if (options.stdout_unit >= 0)
@@ -709,7 +743,7 @@ init_units (void)
 
       fbuf_init (u, 0);
 
-      UNLOCK (&u->lock);
+      UNLOCK_UNIT (u);
     }
 
   if (options.stderr_unit >= 0)
@@ -740,13 +774,13 @@ init_units (void)
       fbuf_init (u, 256);  /* 256 bytes should be enough, probably not doing
                               any kind of exotic formatting to stderr.  */
 
-      UNLOCK (&u->lock);
+      UNLOCK_UNIT (u);
     }
   /* The default internal units.  */
   u = insert_unit (GFC_INTERNAL_UNIT);
-  UNLOCK (&u->lock);
+  UNLOCK_UNIT (u);
   u = insert_unit (GFC_INTERNAL_UNIT4);
-  UNLOCK (&u->lock);
+  UNLOCK_UNIT (u);
 }
 
 
@@ -785,7 +819,7 @@ close_unit_1 (gfc_unit *u, int locked)
     newunit_free (u->unit_number);
 
   if (!locked)
-    UNLOCK (&u->lock);
+    UNLOCK_UNIT (u);
 
   /* If there are any threads waiting in find_unit for this unit,
      avoid freeing the memory, the last such thread will free it
@@ -805,7 +839,7 @@ unlock_unit (gfc_unit *u)
   if (u)
     {
       NOTE ("unlock_unit = %d", u->unit_number);
-      UNLOCK (&u->lock);
+      UNLOCK_UNIT (u);
       NOTE ("unlock_unit done");
     }
 }

libgfortran/io/unix.c

@@ -1791,11 +1791,11 @@ retry:
   RWUNLOCK (&unit_rwlock);
   if (u != NULL)
     {
-      LOCK (&u->lock);
+      LOCK_UNIT (u);
       if (u->closed)
 	{
 	  RDLOCK (&unit_rwlock);
-	  UNLOCK (&u->lock);
+	  UNLOCK_UNIT (u);
 	  if (predec_waiting_locked (u) == 0)
 	    free (u);
 	  goto retry;
@@ -1825,7 +1825,7 @@ flush_all_units_1 (gfc_unit *u, int min_unit)
 	    return u;
 	  if (u->s)
 	    sflush (u->s);
-	  UNLOCK (&u->lock);
+	  UNLOCK_UNIT (u);
 	}
       u = u->right;
     }
@@ -1848,7 +1848,7 @@ flush_all_units (void)
       if (u == NULL)
 	return;
 
-      LOCK (&u->lock);
+      LOCK_UNIT (u);
 
       min_unit = u->unit_number + 1;
 
@@ -1856,13 +1856,13 @@ flush_all_units (void)
 	{
 	  sflush (u->s);
 	  WRLOCK (&unit_rwlock);
-	  UNLOCK (&u->lock);
+	  UNLOCK_UNIT (u);
 	  (void) predec_waiting_locked (u);
 	}
       else
 	{
 	  WRLOCK (&unit_rwlock);
-	  UNLOCK (&u->lock);
+	  UNLOCK_UNIT (u);
 	  if (predec_waiting_locked (u) == 0)
 	    free (u);
 	}

libgfortran/runtime/error.c

@@ -633,6 +633,10 @@ translate_error (int code)
       p = "Bad ID in WAIT statement";
       break;
 
+    case LIBERROR_RECURSIVE_IO:
+      p = "Recursive I/O not allowed";
+      break;
+
     default:
       p = "Unknown error code";
       break;