Hello world,
the attached patch hijacks Jerry's version and adds logic which
should make everything thread-safe. (Jerry, I hope you don't mind
this).
The rest is in the ChangeLog and in the comments.
OK for trunk?
Best regards
Thomas
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.
OK for trunk?
Best regards
Thomas
Jerry DeLisle <[email protected]>
Thomas Koenig <[email protected]>
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.
diff --git a/gcc/fortran/libgfortran.h b/gcc/fortran/libgfortran.h
index 9de5afb6c83..ad3c697f279 100644
--- a/gcc/fortran/libgfortran.h
+++ b/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;
diff --git a/gcc/testsuite/gfortran.dg/pr119136.f90 b/gcc/testsuite/gfortran.dg/pr119136.f90
new file mode 100644
index 00000000000..e579083b9b6
--- /dev/null
+++ b/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
diff --git a/libgfortran/io/async.h b/libgfortran/io/async.h
index 76c087c554a..07f1557a98c 100644
--- a/libgfortran/io/async.h
+++ b/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)
diff --git a/libgfortran/io/io.h b/libgfortran/io/io.h
index 798e760739c..e0025d08d87 100644
--- a/libgfortran/io/io.h
+++ b/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);
diff --git a/libgfortran/io/transfer.c b/libgfortran/io/transfer.c
index 3fc53938b4a..9152c648e86 100644
--- a/libgfortran/io/transfer.c
+++ b/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));
diff --git a/libgfortran/io/unit.c b/libgfortran/io/unit.c
index 62a8c514c18..6c8ee798b22 100644
--- a/libgfortran/io/unit.c
+++ b/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");
}
}
diff --git a/libgfortran/io/unix.c b/libgfortran/io/unix.c
index 129e2dbf091..4a28ec8c615 100644
--- a/libgfortran/io/unix.c
+++ b/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);
}
diff --git a/libgfortran/runtime/error.c b/libgfortran/runtime/error.c
index d2ae7be16f4..e1fafa6f07d 100644
--- a/libgfortran/runtime/error.c
+++ b/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;
