https://gcc.gnu.org/g:e32c3fb4311bcaf767a87934d6495f05fbae7bc9
commit r16-6515-ge32c3fb4311bcaf767a87934d6495f05fbae7bc9 Author: Thomas Koenig <[email protected]> Date: Sun Jan 4 20:09:39 2026 +0100 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 <[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: --- gcc/fortran/libgfortran.h | 1 + gcc/testsuite/gfortran.dg/pr119136.f90 | 10 ++++++ libgfortran/io/async.h | 56 +++++++++++++++++++++++++++++++ libgfortran/io/io.h | 7 ++-- libgfortran/io/transfer.c | 2 ++ libgfortran/io/unit.c | 60 ++++++++++++++++++++++++++-------- libgfortran/io/unix.c | 12 +++---- libgfortran/runtime/error.c | 4 +++ 8 files changed, 131 insertions(+), 21 deletions(-) diff --git a/gcc/fortran/libgfortran.h b/gcc/fortran/libgfortran.h index 2adfd3c64a9a..a0dd3d891a4e 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 000000000000..e579083b9b6a --- /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 1625939f267a..fcd0dd2bb528 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 91ece4d27d1f..1d33624b7d80 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 ed14204e8efa..7e6795e70f7e 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 866862ac7c6a..9474e9bb8f87 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 26d47a110c19..2e8c790e4750 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 6245aa45f8c2..7192f1341306 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;
