Hello world,
I just realized that it is possible to run a check by #undef - ing
__GTHREADS_CXX0X in async.h. Doing so promptly found another
syntax error, which this version of the patch fixes.
As this should definitely restore bootstrap, I plan to commit
this tonight unless there are objections. Further fallout can be
handled later.
ChangeLog identical to the one below.
Best regards
Thomas
the attached patch hopefully fixes the bootstrap problem on
systems without threading support. I have tested it as far
as I could, but I could not find any way to test it. It looks
OK to me, but...
I also tested it on a system where there is no pthreads in
libc, that should hopefully also be fixed.
Anybody up for testing on one of the systems that I do not have
access to? OK for trunk?
Best regards
Thomas
PR libfortran/123446
PR libfortran/119136
libgfortran/ChangeLog:
* io/async.h: DEBUG_ASYNC needs gtreads support.
(LOCK_UNIT): Only lock when there is pthreads support and it is
active.
Otherwise, just set unit->self to 1.
(UNLOCK_UNIT): Only unlock when there is pthreads support and it is
active.
Otherwise, just set unit->self to 0.
(TRYLOCK_UNIT): Only try locking when thee is pthreads support and
it is
active. Otherwise, return unit->self.
(OWN_THREAD_ID): New macro.
* io/io.h: gfc_unit's self is an int when there is no gthreads
support.
* io/unit.c (check_for_recursive): Check for equality of unit which
locked to OWN_THREAD_ID.
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..265f248950d 100644
--- a/libgfortran/io/async.h
+++ b/libgfortran/io/async.h
@@ -29,6 +29,9 @@
__gthread_cond_t and __gthread_equal / __gthread_self. Check
this. */
+/* #undef __GTHREADS_CXX0X - uncomment for checking non-threading
+ systems. */
+
#if defined(__GTHREAD_HAS_COND) && defined(__GTHREADS_CXX0X)
#define ASYNC_IO 1
#else
@@ -42,6 +45,9 @@
#undef DEBUG_ASYNC
#ifdef DEBUG_ASYNC
+#ifndef __GTHREADS_CXX0X
+#error "gthreads support required for DEBUG_ASYNC"
+#endif
/* Define this if you want to use ANSI color escape sequences in your
debugging output. */
@@ -175,6 +181,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 +209,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 +245,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; \
@@ -334,15 +375,77 @@
#define DEBUG_LINE(...) __VA_ARGS__
-#else
+#else /* DEBUG_ASYNC */
+
#define DEBUG_PRINTF(...) {}
#define CHECK_LOCK(au, mutex, status) {}
#define NOTE(str, ...) {}
#define DEBUG_LINE(...)
#define T_ERROR(func, ...) func(__VA_ARGS__)
#define LOCK(mutex) INTERN_LOCK (mutex)
+
+#ifdef __GTHREADS_CXX0X
+
+/* When pthreads are not active, we do not touch the lock for locking /
+ unlocking; the only use for this is checking for recursion. */
+
+#define LOCK_UNIT(unit) do { \
+ if (__gthread_active_p ()) { \
+ LOCK (&(unit)->lock); (unit)->self = __gthread_self (); \
+ } else { \
+ (unit)->self = 1; \
+ } \
+ } while(0)
+#else
+
+#define LOCK_UNIT(unit) do { \
+ (unit)->self = 1; \
+ } while(0)
+
+#endif
+
#define UNLOCK(mutex) INTERN_UNLOCK (mutex)
+
+#ifdef __GTHREADS_CXX0X
+
+#define UNLOCK_UNIT(unit) do { \
+ if (__gthread_active_p ()) { \
+ (unit)->self = 0 ; UNLOCK(&(unit)->lock); \
+ } else { \
+ (unit)->self = 0; \
+ } \
+} while(0)
+#else
+#define UNLOCK_UNIT(unit) do { \
+ (unit)->self = 0; \
+ } while(0)
+
+#endif
+
#define TRYLOCK(mutex) (__gthread_mutex_trylock (mutex))
+
+#ifdef __GTHREADS_CXX0X
+#define TRYLOCK_UNIT(unit) ({ \
+ int res; \
+ if (__gthread_active_p ()) { \
+ res = __gthread_mutex_trylock (&(unit)->lock); \
+ if (!res) \
+ (unit)->self = __gthread_self (); \
+ } \
+ else { \
+ res = (unit)->self; \
+ (unit)->self = 1; \
+ } \
+ res; \
+ })
+#else
+#define TRYLOCK_UNIT(unit) ({ \
+ int res = (unit)->self; \
+ (unit)->self = 1; \
+ res; \
+ })
+#endif
+
#ifdef __GTHREAD_RWLOCK_INIT
#define RDLOCK(rwlock) INTERN_RDLOCK (rwlock)
#define WRLOCK(rwlock) INTERN_WRLOCK (rwlock)
@@ -448,6 +551,15 @@ DEBUG_LINE (extern __gthread_rwlock_t debug_queue_rwlock;)
extern __thread gfc_unit *thread_unit;
#endif
+/* When threading is not active, or there is no thread system, we fake the ID
+ to be 1. */
+
+#ifdef __GTHREADS_CXX0X
+#define OWN_THREAD_ID (__gthread_active_p () ? __gthread_self () : 1)
+#else
+#define OWN_THREAD_ID 1
+#endif
+
enum aio_do {
AIO_INVALID = 0,
AIO_DATA_TRANSFER_INIT,
@@ -527,7 +639,7 @@ bool async_wait_id (st_parameter_common *, async_unit *, int);
internal_proto (async_wait_id);
bool collect_async_errors (st_parameter_common *, async_unit *);
-internal_proto (collect_async_errors);
+internal_proto (collect_async_errors);
void async_close (async_unit *);
internal_proto (async_close);
diff --git a/libgfortran/io/io.h b/libgfortran/io/io.h
index 798e760739c..029fb6b9414 100644
--- a/libgfortran/io/io.h
+++ b/libgfortran/io/io.h
@@ -728,6 +728,11 @@ typedef struct gfc_unit
int last_char;
bool has_size;
GFC_IO_INT size_used;
+#ifdef __GTHREADS_CXX0X
+ __gthread_t self;
+#else
+ int self;
+#endif
}
gfc_unit;
@@ -782,8 +787,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..8cf85f6fb15 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,42 @@ 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. When threading is not active, or
+ there is no thread system, we fake the ID to be 1. */
+ if (__atomic_load_n (&p->self, __ATOMIC_RELAXED) == OWN_THREAD_ID)
+ 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 +447,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 +462,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 +713,7 @@ init_units (void)
fbuf_init (u, 0);
- UNLOCK (&u->lock);
+ UNLOCK_UNIT (u);
}
if (options.stdout_unit >= 0)
@@ -709,7 +744,7 @@ init_units (void)
fbuf_init (u, 0);
- UNLOCK (&u->lock);
+ UNLOCK_UNIT (u);
}
if (options.stderr_unit >= 0)
@@ -740,13 +775,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 +820,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 +840,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;
