Hi Jerry,
Regarding the test case, for it to pass on FreeBSD one needs the following:
! { dg-do run }
! { dg-options "-pthread" { target { x86_64-*-freebsd* } } }
! { dg-shouldfail "Recursive" }
That should not be the case. I think I know what was wrong, and
tried to fix it in the attached patch, which also includes the
test case.
Would it be possible for somebody with FreeBSD access to check
that the test case now also passes there?
Best regards
Thomas
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;
