* Build fail on gthr-simple.h targets (Re: AsyncI/O patch committed)
[not found] <4dd07fa7-65e3-a4ea-b9cd-36eb4c75e875@koenigni.com>
@ 2018-07-26 13:31 ` Ulrich Weigand
2018-07-26 13:40 ` Build fail on gthr-single.h " Ulrich Weigand
2018-07-26 20:54 ` Build fail on gthr-simple.h " Thomas Koenig
0 siblings, 2 replies; 20+ messages in thread
From: Ulrich Weigand @ 2018-07-26 13:31 UTC (permalink / raw)
To: Nicolas Koenig; +Cc: gfortran, gcc-patches
Nicholas Koenig wrote:
> Hello everyone,
>
> I have committed the async I/O patch as r262978.
>
> The test cases are in libgomp.fortran for now, maybe that can be changed
> later.
It looks like this broke building libgfortran on spu, and presumably
any platform that uses gthr-simple instead of gthr-posix.
The problem is that io/asynch.h unconditionally uses a couple of
features that are not provided by gthr-simplex, in particular
__gthread_cond_t
and
__gthread_equal / __gthread_self
According to the documentation in gthr.h, the former is only available
if __GTHREAD_HAS_COND is defined, and the latter are only available if
__GTHREADS_CXX0X is defined. Neither is true for gthr-simple.h.
To fix the build error, either libgfortran should only use those features
conditionally on those defines, or else the gthr.h logic needs to be
changed and (stubs for) those features provided in gthr-simple.h as well.
Bye,
Ulrich
--
Dr. Ulrich Weigand
GNU/Linux compilers and toolchain
Ulrich.Weigand@de.ibm.com
^ permalink raw reply [flat|nested] 20+ messages in thread
* Re: Build fail on gthr-single.h targets (Re: AsyncI/O patch committed)
2018-07-26 13:31 ` Build fail on gthr-simple.h targets (Re: AsyncI/O patch committed) Ulrich Weigand
@ 2018-07-26 13:40 ` Ulrich Weigand
2018-07-26 20:54 ` Build fail on gthr-simple.h " Thomas Koenig
1 sibling, 0 replies; 20+ messages in thread
From: Ulrich Weigand @ 2018-07-26 13:40 UTC (permalink / raw)
To: Ulrich Weigand; +Cc: Nicolas Koenig, gfortran, gcc-patches
I wrote:
> Nicholas Koenig wrote:
>
> > Hello everyone,
> >
> > I have committed the async I/O patch as r262978.
> >
> > The test cases are in libgomp.fortran for now, maybe that can be changed
> > later.
>
> It looks like this broke building libgfortran on spu, and presumably
> any platform that uses gthr-simple instead of gthr-posix.
The file is called gthr-single.h, not gthr-simple.h ... sorry for the typo.
Bye,
Ulrich
--
Dr. Ulrich Weigand
GNU/Linux compilers and toolchain
Ulrich.Weigand@de.ibm.com
^ permalink raw reply [flat|nested] 20+ messages in thread
* Re: Build fail on gthr-simple.h targets (Re: AsyncI/O patch committed)
2018-07-26 13:31 ` Build fail on gthr-simple.h targets (Re: AsyncI/O patch committed) Ulrich Weigand
2018-07-26 13:40 ` Build fail on gthr-single.h " Ulrich Weigand
@ 2018-07-26 20:54 ` Thomas Koenig
2018-07-27 7:31 ` Thomas Koenig
1 sibling, 1 reply; 20+ messages in thread
From: Thomas Koenig @ 2018-07-26 20:54 UTC (permalink / raw)
To: Ulrich Weigand, Nicolas Koenig; +Cc: gfortran, gcc-patches, dje.gcc
[-- Attachment #1: Type: text/plain, Size: 2068 bytes --]
Hi Ulrich,
> The problem is that io/asynch.h unconditionally uses a couple of
> features that are not provided by gthr-simplex, in particular
> __gthread_cond_t
> and
> __gthread_equal / __gthread_self
>
> According to the documentation in gthr.h, the former is only available
> if __GTHREAD_HAS_COND is defined, and the latter are only available if
> __GTHREADS_CXX0X is defined. Neither is true for gthr-simple.h.
Thanks for the analysis, and the pointer to the macros.
Because the functionality depends on these features, it is best to
remove them if it is not present. So, here is a patch which does
just that.
This was reg-tested on Linux, which showed that the functionality is
still there. I tried bootstrapping on AIX on gcc119, but this failed
due to an unrelated issue (problem with compiling the inline
libraries).
Would it be possible to check if this restores bootstrap in the next
10 hours or so? If so, I would like to commit this. Otherwise, Nicolas
and I will not be able to fix this for a week or so, and it would be
best to revert the async I/O patch :-(
Regards
Thomas
2018-07-25 Thomas Koenig <tkoenig@gcc.gnu.org>
* io/async.h: Test for feature macros for __gthread_cond_t and
__gthread_equal. Define ASYNC_IO if both are present.
(SIGNAL): Define as no-op if ASYNC_IO is not defined.
(WAIT_SIGNAL_MUTEX): Likewise.
(REVOLE_SIGNAL): Likewise.
(transfer_args): Define as useless struct if ASYNC_IO is not
defined.
(adv_cond): Likewise.
(async_unit): Likewise.
* io/async.c (init_async_unit): If ASYNC_IO is not defined,
define alternate function which does nothing.
(enqueue_transfer): Likewise.
(enqueue_done_id): Likewise.
(enqueue_done): Likewise.
(enqueue_close): Likewise.
(enqueue_data_transfer_init): Likewise.
(collect_async_errors): Likewise.
(async_wait_id): Likewise.
(async_wait): Likewise.
(async_close): Likewise.
[-- Attachment #2: p-rep-1.diff --]
[-- Type: text/x-patch, Size: 3551 bytes --]
Index: io/async.h
===================================================================
--- io/async.h (revision 262978)
+++ io/async.h (working copy)
@@ -25,6 +25,16 @@
#ifndef ASYNC_H
#define ASYNC_H
+/* Async I/O will not work on targets which do not support
+ __gthread_cond_t and __gthread_equal / __gthread_self. Check
+ this. */
+
+#if defined(__GTHREAD_HAS_COND) && defined(__GTHREADS_CXX0X)
+#define ASYNC_IO 1
+#else
+#undef ASYNC_IO
+#endif
+
/* Defining DEBUG_ASYNC will enable somewhat verbose debugging
output for async I/O. */
@@ -217,6 +227,8 @@
#define INTERN_UNLOCK(mutex) T_ERROR (__gthread_mutex_unlock, mutex);
+#if ASYNC_IO
+
#define SIGNAL(advcond) do{ \
INTERN_LOCK (&(advcond)->lock); \
(advcond)->pending = 1; \
@@ -257,6 +269,15 @@
INTERN_UNLOCK (&(advcond)->lock); \
} while (0)
+#else
+
+#define SIGNAL(advcond) do{} while(0)
+#define WAIT_SIGNAL_MUTEX(advcond, condition, mutex) do{} while(0)
+#define REVOKE_SIGNAL(advcond) do{} while(0)
+
+#endif
+
+#if ASYNC_IO
DEBUG_LINE (extern __thread const char *aio_prefix);
DEBUG_LINE (typedef struct aio_lock_debug{
@@ -274,6 +295,7 @@ DEBUG_LINE (extern __gthread_mutex_t debug_queue_l
error reporting. */
extern __thread gfc_unit *thread_unit;
+#endif
enum aio_do {
AIO_INVALID = 0,
@@ -285,6 +307,8 @@ enum aio_do {
AIO_CLOSE
};
+#if ASYNC_IO
+
typedef union transfer_args
{
struct
@@ -342,6 +366,23 @@ typedef struct async_unit
} async_unit;
+#else
+typedef union transfer_args
+{
+ int x;
+};
+
+struct adv_cond
+{
+ int x;
+};
+
+typedef struct async_unit
+{
+ int x;
+};
+#endif
+
void init_async_unit (gfc_unit *);
internal_proto (init_async_unit);
Index: io/async.c
===================================================================
--- io/async.c (revision 262978)
+++ io/async.c (working copy)
@@ -36,6 +36,7 @@
#include <sys/types.h>
#include "async.h"
+#if ASYNC_IO
DEBUG_LINE (__thread const char *aio_prefix = MPREFIX);
@@ -481,3 +482,88 @@ async_close (async_unit *au)
T_ERROR (__gthread_join, au->thread, NULL);
free_async_unit (au);
}
+
+#else
+
+/* Do-nothing function, which will not be called. */
+
+void
+init_async_unit (gfc_unit *u)
+{
+ u->au = NULL;
+ return;
+}
+
+/* Do-nothing function, which will not be called. */
+
+void
+enqueue_transfer (async_unit *au, transfer_args *arg, enum aio_do type)
+{
+ return;
+}
+
+/* Do-nothing function, which will not be called. */
+
+int
+enqueue_done_id (async_unit *au, enum aio_do type)
+{
+ return 0;
+}
+
+/* Do-nothing function, which will not be called. */
+
+void
+enqueue_done (async_unit *au, enum aio_do type)
+{
+ return;
+}
+
+/* Do-nothing function, which will not be called. */
+
+void
+enqueue_close (async_unit *au)
+{
+ return;
+}
+
+/* Do-nothing function, which will not be called. */
+
+void
+enqueue_data_transfer_init (async_unit *au, st_parameter_dt *dt, int read_flag)
+{
+ return;
+}
+
+/* Do-nothing function, which will not be called. */
+
+bool
+collect_async_errors (st_parameter_common *cmp, async_unit *au)
+{
+ return false;
+}
+
+/* Do-nothing function, which will not be called. */
+
+bool
+async_wait_id (st_parameter_common *cmp, async_unit *au, int i)
+{
+ return false;
+}
+
+/* Do-nothing function, which will not be called. */
+
+bool
+async_wait (st_parameter_common *cmp, async_unit *au)
+{
+ return false;
+}
+
+/* Do-nothing function, which will not be called. */
+
+void
+async_close (async_unit *au)
+{
+ return;
+}
+
+#endif
^ permalink raw reply [flat|nested] 20+ messages in thread
* Re: Build fail on gthr-simple.h targets (Re: AsyncI/O patch committed)
2018-07-26 20:54 ` Build fail on gthr-simple.h " Thomas Koenig
@ 2018-07-27 7:31 ` Thomas Koenig
2018-07-27 12:26 ` David Edelsohn
0 siblings, 1 reply; 20+ messages in thread
From: Thomas Koenig @ 2018-07-27 7:31 UTC (permalink / raw)
To: Ulrich Weigand, Nicolas Koenig; +Cc: gfortran, gcc-patches, dje.gcc
Am 26.07.2018 um 22:54 schrieb Thomas Koenig:
> Hi Ulrich,
>
>> The problem is that io/asynch.h unconditionally uses a couple of
>> features that are not provided by gthr-simplex, in particular
>> Â Â __gthread_cond_t
>> and
>> Â Â __gthread_equal / __gthread_self
>>
>> According to the documentation in gthr.h, the former is only available
>> if __GTHREAD_HAS_COND is defined, and the latter are only available if
>> __GTHREADS_CXX0X is defined. Neither is true for gthr-simple.h.
>
> Thanks for the analysis, and the pointer to the macros.
>
> Because the functionality depends on these features, it is best to
> remove them if it is not present. So, here is a patch which does
> just that.
>
> This was reg-tested on Linux, which showed that the functionality is
> still there. I tried bootstrapping on AIX on gcc119, but this failed
> due to an unrelated issue (problem with compiling the inline
> libraries).
>
OK, this does not work.
We have found a method of checking on Linux, and this does not work.
We have also found a way of working in the next couple of days, so
expect an update in one or two days.
If that is too much time, feel free to revert the async patch
in the meantime.
Regards
Thomas
^ permalink raw reply [flat|nested] 20+ messages in thread
* Re: Build fail on gthr-simple.h targets (Re: AsyncI/O patch committed)
2018-07-27 7:31 ` Thomas Koenig
@ 2018-07-27 12:26 ` David Edelsohn
[not found] ` <5B6021C0.5060507@arm.com>
0 siblings, 1 reply; 20+ messages in thread
From: David Edelsohn @ 2018-07-27 12:26 UTC (permalink / raw)
To: Thomas Koenig; +Cc: Ulrich Weigand, Nicolas Koenig, Fortran List, GCC Patches
Thomas,
Correct, the proposed patch does not fix the build failure on AIX.
Please see the information on the GCC Compile Farm wiki page for
instructions to bootstrap on gcc119.
https://gcc.gnu.org/wiki/CompileFarm#Projects_Ideas - at the bottom of
Project ideas.
Thanks, David
On Fri, Jul 27, 2018 at 3:30 AM Thomas Koenig <tkoenig@netcologne.de> wrote:
>
> Am 26.07.2018 um 22:54 schrieb Thomas Koenig:
> > Hi Ulrich,
> >
> >> The problem is that io/asynch.h unconditionally uses a couple of
> >> features that are not provided by gthr-simplex, in particular
> >> __gthread_cond_t
> >> and
> >> __gthread_equal / __gthread_self
> >>
> >> According to the documentation in gthr.h, the former is only available
> >> if __GTHREAD_HAS_COND is defined, and the latter are only available if
> >> __GTHREADS_CXX0X is defined. Neither is true for gthr-simple.h.
> >
> > Thanks for the analysis, and the pointer to the macros.
> >
> > Because the functionality depends on these features, it is best to
> > remove them if it is not present. So, here is a patch which does
> > just that.
> >
> > This was reg-tested on Linux, which showed that the functionality is
> > still there. I tried bootstrapping on AIX on gcc119, but this failed
> > due to an unrelated issue (problem with compiling the inline
> > libraries).
> >
>
> OK, this does not work.
>
> We have found a method of checking on Linux, and this does not work.
> We have also found a way of working in the next couple of days, so
> expect an update in one or two days.
>
> If that is too much time, feel free to revert the async patch
> in the meantime.
>
> Regards
>
> Thomas
^ permalink raw reply [flat|nested] 20+ messages in thread
* Async I/O patch with compilation fix
[not found] ` <5B6021C0.5060507@arm.com>
@ 2018-08-02 11:35 ` Nicolas Koenig
2018-08-02 15:43 ` Christophe Lyon
0 siblings, 1 reply; 20+ messages in thread
From: Nicolas Koenig @ 2018-08-02 11:35 UTC (permalink / raw)
To: Andre Vieira (lists), gcc-patches
Cc: fortran, tkoenig, Ulrich Weigand, dje.gcc, clyon
[-- Attachment #1: Type: text/plain, Size: 3902 bytes --]
Hello everyone,
Here is an updated version of the patch that hopefully fixes the compilation
problems by disabling async I/O if conditions are not supported by the target.
I would appreciate if people could test it on systems on which it failed
before. As for the array_constructor_8.f90 failure reported in the PR, why
it fails is beyond me, it doesn't even use I/O. Maybe/Probably something
unrelated?
Nicolas
2018-08-02 Nicolas Koenig <koenigni@gcc.gnu.org>
Thomas Koenig <tkoenig@gcc.gnu.org>
PR fortran/25829
* gfortran.texi: Add description of asynchronous I/O.
* trans-decl.c (gfc_finish_var_decl): Treat asynchronous variables
as volatile.
* trans-io.c (gfc_build_io_library_fndecls): Rename st_wait to
st_wait_async and change argument spec from ".X" to ".w".
(gfc_trans_wait): Pass ID argument via reference.
2018-08-02 Nicolas Koenig <koenigni@gcc.gnu.org>
Thomas Koenig <tkoenig@gcc.gnu.org>
PR fortran/25829
* gfortran.dg/f2003_inquire_1.f03: Add write statement.
* gfortran.dg/f2003_io_1.f03: Add wait statement.
2018-08-02 Nicolas Koenig <koenigni@gcc.gnu.org>
Thomas Koenig <tkoenig@gcc.gnu.org>
PR fortran/25829
* Makefile.am: Add async.c to gfor_io_src.
Add async.h to gfor_io_headers.
* Makefile.in: Regenerated.
* gfortran.map: Add _gfortran_st_wait_async.
* io/async.c: New file.
* io/async.h: New file.
* io/close.c: Include async.h.
(st_close): Call async_wait for an asynchronous unit.
* io/file_pos.c (st_backspace): Likewise.
(st_endfile): Likewise.
(st_rewind): Likewise.
(st_flush): Likewise.
* io/inquire.c: Add handling for asynchronous PENDING
and ID arguments.
* io/io.h (st_parameter_dt): Add async bit.
(st_parameter_wait): Correct.
(gfc_unit): Add au pointer.
(st_wait_async): Add prototype.
(transfer_array_inner): Likewise.
(st_write_done_worker): Likewise.
* io/open.c: Include async.h.
(new_unit): Initialize asynchronous unit.
* io/transfer.c (async_opt): New struct.
(wrap_scalar_transfer): New function.
(transfer_integer): Call wrap_scalar_transfer to do the work.
(transfer_real): Likewise.
(transfer_real_write): Likewise.
(transfer_character): Likewise.
(transfer_character_wide): Likewise.
(transfer_complex): Likewise.
(transfer_array_inner): New function.
(transfer_array): Call transfer_array_inner.
(transfer_derived): Call wrap_scalar_transfer.
(data_transfer_init): Check for asynchronous I/O.
Perform a wait operation on any pending asynchronous I/O
if the data transfer is synchronous. Copy PDT and enqueue
thread for data transfer.
(st_read_done_worker): New function.
(st_read_done): Enqueue transfer or call st_read_done_worker.
(st_write_done_worker): New function.
(st_write_done): Enqueue transfer or call st_read_done_worker.
(st_wait): Document as no-op for compatibility reasons.
(st_wait_async): New function.
* io/unit.c (insert_unit): Use macros LOCK, UNLOCK and TRYLOCK;
add NOTE where necessary.
(get_gfc_unit): Likewise.
(init_units): Likewise.
(close_unit_1): Likewise. Call async_close if asynchronous.
(close_unit): Use macros LOCK and UNLOCK.
(finish_last_advance_record): Likewise.
(newunit_alloc): Likewise.
* io/unix.c (find_file): Likewise.
(flush_all_units_1): Likewise.
(flush_all_units): Likewise.
* libgfortran.h (generate_error_common): Add prototype.
* runtime/error.c: Include io.h and async.h.
(generate_error_common): New function.
2018-08-02 Nicolas Koenig <koenigni@gcc.gnu.org>
Thomas Koenig <tkoenig@gcc.gnu.org>
PR fortran/25829
* testsuite/libgomp.fortran/async_io_1.f90: New test.
* testsuite/libgomp.fortran/async_io_2.f90: New test.
* testsuite/libgomp.fortran/async_io_3.f90: New test.
* testsuite/libgomp.fortran/async_io_4.f90: New test.
* testsuite/libgomp.fortran/async_io_5.f90: New test.
* testsuite/libgomp.fortran/async_io_6.f90: New test.
* testsuite/libgomp.fortran/async_io_7.f90: New test.
[-- Attachment #2: pa.diff --]
[-- Type: text/x-diff, Size: 45529 bytes --]
Index: gcc/fortran/gfortran.texi
===================================================================
--- gcc/fortran/gfortran.texi (revision 263244)
+++ gcc/fortran/gfortran.texi (working copy)
@@ -879,8 +879,7 @@ than @code{(/.../)}. Type-specification for array
@item Extensions to the specification and initialization expressions,
including the support for intrinsics with real and complex arguments.
-@item Support for the asynchronous input/output syntax; however, the
-data transfer is currently always synchronously performed.
+@item Support for the asynchronous input/output.
@item
@cindex @code{FLUSH} statement
@@ -1183,6 +1182,7 @@ might in some way or another become visible to the
* Files opened without an explicit ACTION= specifier::
* File operations on symbolic links::
* File format of unformatted sequential files::
+* Asynchronous I/O::
@end menu
@@ -1486,6 +1486,20 @@ program main
end program main
@end smallexample
+@node Asynchronous I/O
+@section Asynchronous I/O
+@cindex input/output, asynchronous
+@cindex asynchronous I/O
+
+Asynchronous I/O is supported if the program is linked against the
+POSIX thread library. If that is not the case, all I/O is performed
+as synchronous.
+
+On some systems, such as Darwin or Solaris, the POSIX thread library
+is always linked in, so asynchronous I/O is always performed. On other
+sytems, such as Linux, it is necessary to specify @option{-pthread},
+@option{-lpthread} or @option{-fopenmp} during the linking step.
+
@c ---------------------------------------------------------------------
@c Extensions
@c ---------------------------------------------------------------------
Index: gcc/fortran/trans-decl.c
===================================================================
--- gcc/fortran/trans-decl.c (revision 263244)
+++ gcc/fortran/trans-decl.c (working copy)
@@ -698,7 +698,8 @@ gfc_finish_var_decl (tree decl, gfc_symbol * sym)
&& CLASS_DATA (sym)->ts.u.derived->attr.has_dtio_procs)))
TREE_STATIC (decl) = 1;
- if (sym->attr.volatile_)
+ /* Treat asynchronous variables the same as volatile, for now. */
+ if (sym->attr.volatile_ || sym->attr.asynchronous)
{
TREE_THIS_VOLATILE (decl) = 1;
TREE_SIDE_EFFECTS (decl) = 1;
Index: gcc/fortran/trans-io.c
===================================================================
--- gcc/fortran/trans-io.c (revision 263244)
+++ gcc/fortran/trans-io.c (working copy)
@@ -438,10 +438,9 @@ gfc_build_io_library_fndecls (void)
get_identifier (PREFIX("st_iolength")), ".w",
void_type_node, 1, dt_parm_type);
- /* TODO: Change when asynchronous I/O is implemented. */
parm_type = build_pointer_type (st_parameter[IOPARM_ptype_wait].type);
iocall[IOCALL_WAIT] = gfc_build_library_function_decl_with_spec (
- get_identifier (PREFIX("st_wait")), ".X",
+ get_identifier (PREFIX("st_wait_async")), ".w",
void_type_node, 1, parm_type);
parm_type = build_pointer_type (st_parameter[IOPARM_ptype_filepos].type);
@@ -1527,7 +1526,7 @@ gfc_trans_wait (gfc_code * code)
mask |= IOPARM_common_err;
if (p->id)
- mask |= set_parameter_value (&block, var, IOPARM_wait_id, p->id);
+ mask |= set_parameter_ref (&block, &post_block, var, IOPARM_wait_id, p->id);
set_parameter_const (&block, var, IOPARM_common_flags, mask);
Index: gcc/testsuite/gfortran.dg/f2003_inquire_1.f03
===================================================================
--- gcc/testsuite/gfortran.dg/f2003_inquire_1.f03 (revision 263244)
+++ gcc/testsuite/gfortran.dg/f2003_inquire_1.f03 (working copy)
@@ -7,10 +7,12 @@ logical :: vpending
open(10, file='mydata_f2003_inquire_1', asynchronous="yes", blank="null", &
& decimal="comma", encoding="utf-8", sign="plus")
+write (10,*, asynchronous="yes", id=vid) 'asdf'
+wait (10)
+
inquire(unit=10, round=sround, sign=ssign, size=vsize, id=vid, &
& pending=vpending, asynchronous=sasynchronous, decimal=sdecimal, &
& encoding=sencoding)
-
if (ssign.ne."PLUS") STOP 1
if (sasynchronous.ne."YES") STOP 2
if (sdecimal.ne."COMMA") STOP 3
Index: gcc/testsuite/gfortran.dg/f2003_io_1.f03
===================================================================
--- gcc/testsuite/gfortran.dg/f2003_io_1.f03 (revision 263244)
+++ gcc/testsuite/gfortran.dg/f2003_io_1.f03 (working copy)
@@ -13,6 +13,7 @@ open(10, file='mydata_f2003_io_1', asynchronous="y
write(10,'(10f8.3)', asynchronous="yes", decimal="comma", id=j) a
rewind(10)
read(10,'(10f8.3)', asynchronous="yes", decimal="comma", blank="zero") b
+wait(10)
if (any(b.ne.23.45)) STOP 1
c = 3.14
@@ -24,6 +25,7 @@ rewind(10)
write(10,'(10f8.3)', asynchronous="yes", decimal="point") a
rewind(10)
read(10,'(10f8.3)', asynchronous="yes", decimal="point") b
+wait (10)
if (any(b.ne.23.45)) STOP 3
wait(unit=10, err=25, iostat=istat, iomsg=msg, end=35, id=j)
Index: libgfortran/Makefile.am
===================================================================
--- libgfortran/Makefile.am (revision 263244)
+++ libgfortran/Makefile.am (working copy)
@@ -100,7 +100,8 @@ io/transfer128.c \
io/unit.c \
io/unix.c \
io/write.c \
-io/fbuf.c
+io/fbuf.c \
+io/async.c
endif
@@ -108,7 +109,8 @@ gfor_io_headers= \
io/io.h \
io/fbuf.h \
io/format.h \
-io/unix.h
+io/unix.h \
+io/async.h
gfor_helper_src= \
intrinsics/associated.c \
Index: libgfortran/Makefile.in
===================================================================
--- libgfortran/Makefile.in (revision 263244)
+++ libgfortran/Makefile.in (working copy)
@@ -70,7 +70,8 @@ target_triplet = @target@
@LIBGFOR_MINIMAL_FALSE@io/unit.c \
@LIBGFOR_MINIMAL_FALSE@io/unix.c \
@LIBGFOR_MINIMAL_FALSE@io/write.c \
-@LIBGFOR_MINIMAL_FALSE@io/fbuf.c
+@LIBGFOR_MINIMAL_FALSE@io/fbuf.c \
+@LIBGFOR_MINIMAL_FALSE@io/async.c
@LIBGFOR_MINIMAL_FALSE@am__append_3 = \
@LIBGFOR_MINIMAL_FALSE@intrinsics/access.c \
@@ -352,7 +353,7 @@ am__objects_47 = $(am__objects_4) $(am__objects_5)
@LIBGFOR_MINIMAL_FALSE@ inquire.lo intrinsics.lo list_read.lo \
@LIBGFOR_MINIMAL_FALSE@ lock.lo open.lo read.lo transfer.lo \
@LIBGFOR_MINIMAL_FALSE@ transfer128.lo unit.lo unix.lo write.lo \
-@LIBGFOR_MINIMAL_FALSE@ fbuf.lo
+@LIBGFOR_MINIMAL_FALSE@ fbuf.lo async.lo
am__objects_49 = size_from_kind.lo $(am__objects_48)
@LIBGFOR_MINIMAL_FALSE@am__objects_50 = access.lo c99_functions.lo \
@LIBGFOR_MINIMAL_FALSE@ chdir.lo chmod.lo clock.lo cpu_time.lo \
@@ -650,7 +651,8 @@ gfor_io_headers = \
io/io.h \
io/fbuf.h \
io/format.h \
-io/unix.h
+io/unix.h \
+io/async.h
gfor_helper_src = intrinsics/associated.c intrinsics/abort.c \
intrinsics/args.c intrinsics/cshift0.c intrinsics/eoshift0.c \
@@ -1551,6 +1553,7 @@ distclean-compile:
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/any_l8.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/args.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/associated.Plo@am__quote@
+@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/async.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/backtrace.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/bessel_r10.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/bessel_r16.Plo@am__quote@
@@ -5814,6 +5817,13 @@ fbuf.lo: io/fbuf.c
@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
@am__fastdepCC_FALSE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o fbuf.lo `test -f 'io/fbuf.c' || echo '$(srcdir)/'`io/fbuf.c
+async.lo: io/async.c
+@am__fastdepCC_TRUE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT async.lo -MD -MP -MF $(DEPDIR)/async.Tpo -c -o async.lo `test -f 'io/async.c' || echo '$(srcdir)/'`io/async.c
+@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/async.Tpo $(DEPDIR)/async.Plo
+@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='io/async.c' object='async.lo' libtool=yes @AMDEPBACKSLASH@
+@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
+@am__fastdepCC_FALSE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o async.lo `test -f 'io/async.c' || echo '$(srcdir)/'`io/async.c
+
associated.lo: intrinsics/associated.c
@am__fastdepCC_TRUE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT associated.lo -MD -MP -MF $(DEPDIR)/associated.Tpo -c -o associated.lo `test -f 'intrinsics/associated.c' || echo '$(srcdir)/'`intrinsics/associated.c
@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/associated.Tpo $(DEPDIR)/associated.Plo
Index: libgfortran/gfortran.map
===================================================================
--- libgfortran/gfortran.map (revision 263244)
+++ libgfortran/gfortran.map (working copy)
@@ -1483,3 +1483,8 @@ GFORTRAN_C99_8 {
y1f;
ynf;
};
+
+GFORTRAN_9 {
+ global:
+ _gfortran_st_wait_async;
+};
Index: libgfortran/io/close.c
===================================================================
--- libgfortran/io/close.c (revision 263244)
+++ libgfortran/io/close.c (working copy)
@@ -24,6 +24,7 @@ see the files COPYING3 and COPYING.RUNTIME respect
#include "io.h"
#include "unix.h"
+#include "async.h"
#include <limits.h>
typedef enum
@@ -57,6 +58,15 @@ st_close (st_parameter_close *clp)
find_option (&clp->common, clp->status, clp->status_len,
status_opt, "Bad STATUS parameter in CLOSE statement");
+ u = find_unit (clp->common.unit);
+
+ if (ASYNC_IO && u && u->au)
+ if (async_wait (&(clp->common), u->au))
+ {
+ library_end ();
+ return;
+ }
+
if ((clp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
{
library_end ();
@@ -63,7 +73,6 @@ st_close (st_parameter_close *clp)
return;
}
- u = find_unit (clp->common.unit);
if (u != NULL)
{
if (close_share (u) < 0)
Index: libgfortran/io/file_pos.c
===================================================================
--- libgfortran/io/file_pos.c (revision 263244)
+++ libgfortran/io/file_pos.c (working copy)
@@ -25,6 +25,7 @@ see the files COPYING3 and COPYING.RUNTIME respect
#include "io.h"
#include "fbuf.h"
#include "unix.h"
+#include "async.h"
#include <string.h>
/* file_pos.c-- Implement the file positioning statements, i.e. BACKSPACE,
@@ -187,6 +188,7 @@ void
st_backspace (st_parameter_filepos *fpp)
{
gfc_unit *u;
+ bool needs_unlock = false;
library_start (&fpp->common);
@@ -214,6 +216,17 @@ st_backspace (st_parameter_filepos *fpp)
goto done;
}
+ if (ASYNC_IO && u->au)
+ {
+ if (async_wait (&(fpp->common), u->au))
+ return;
+ else
+ {
+ needs_unlock = true;
+ LOCK (&u->au->io_lock);
+ }
+ }
+
/* Make sure format buffer is flushed and reset. */
if (u->flags.form == FORM_FORMATTED)
{
@@ -267,8 +280,13 @@ st_backspace (st_parameter_filepos *fpp)
done:
if (u != NULL)
- unlock_unit (u);
+ {
+ unlock_unit (u);
+ if (ASYNC_IO && u->au && needs_unlock)
+ UNLOCK (&u->au->io_lock);
+ }
+
library_end ();
}
@@ -280,6 +298,7 @@ void
st_endfile (st_parameter_filepos *fpp)
{
gfc_unit *u;
+ bool needs_unlock = false;
library_start (&fpp->common);
@@ -294,6 +313,17 @@ st_endfile (st_parameter_filepos *fpp)
goto done;
}
+ if (ASYNC_IO && u->au)
+ {
+ if (async_wait (&(fpp->common), u->au))
+ return;
+ else
+ {
+ needs_unlock = true;
+ LOCK (&u->au->io_lock);
+ }
+ }
+
if (u->flags.access == ACCESS_SEQUENTIAL
&& u->endfile == AFTER_ENDFILE)
{
@@ -376,9 +406,12 @@ st_endfile (st_parameter_filepos *fpp)
}
}
- done:
- unlock_unit (u);
+ done:
+ if (ASYNC_IO && u->au && needs_unlock)
+ UNLOCK (&u->au->io_lock);
+ unlock_unit (u);
+
library_end ();
}
@@ -390,6 +423,7 @@ void
st_rewind (st_parameter_filepos *fpp)
{
gfc_unit *u;
+ bool needs_unlock = true;
library_start (&fpp->common);
@@ -401,6 +435,17 @@ st_rewind (st_parameter_filepos *fpp)
"Cannot REWIND a file opened for DIRECT access");
else
{
+ if (ASYNC_IO && u->au)
+ {
+ if (async_wait (&(fpp->common), u->au))
+ return;
+ else
+ {
+ needs_unlock = true;
+ LOCK (&u->au->io_lock);
+ }
+ }
+
/* If there are previously written bytes from a write with ADVANCE="no",
add a record marker before performing the ENDFILE. */
@@ -436,6 +481,10 @@ st_rewind (st_parameter_filepos *fpp)
}
/* Update position for INQUIRE. */
u->flags.position = POSITION_REWIND;
+
+ if (ASYNC_IO && u->au && needs_unlock)
+ UNLOCK (&u->au->io_lock);
+
unlock_unit (u);
}
@@ -450,6 +499,7 @@ void
st_flush (st_parameter_filepos *fpp)
{
gfc_unit *u;
+ bool needs_unlock = false;
library_start (&fpp->common);
@@ -456,6 +506,17 @@ st_flush (st_parameter_filepos *fpp)
u = find_unit (fpp->common.unit);
if (u != NULL)
{
+ if (ASYNC_IO && u->au)
+ {
+ if (async_wait (&(fpp->common), u->au))
+ return;
+ else
+ {
+ needs_unlock = true;
+ LOCK (&u->au->io_lock);
+ }
+ }
+
/* Make sure format buffer is flushed. */
if (u->flags.form == FORM_FORMATTED)
fbuf_flush (u, u->mode);
@@ -469,5 +530,8 @@ st_flush (st_parameter_filepos *fpp)
generate_error (&fpp->common, LIBERROR_BAD_OPTION,
"Specified UNIT in FLUSH is not connected");
+ if (needs_unlock)
+ UNLOCK (&u->au->io_lock);
+
library_end ();
}
Index: libgfortran/io/inquire.c
===================================================================
--- libgfortran/io/inquire.c (revision 263244)
+++ libgfortran/io/inquire.c (working copy)
@@ -26,6 +26,7 @@ see the files COPYING3 and COPYING.RUNTIME respect
/* Implement the non-IOLENGTH variant of the INQUIRY statement */
#include "io.h"
+#include "async.h"
#include "unix.h"
#include <string.h>
@@ -281,12 +282,6 @@ inquire_via_unit (st_parameter_inquire *iqp, gfc_u
{
GFC_INTEGER_4 cf2 = iqp->flags2;
- if ((cf2 & IOPARM_INQUIRE_HAS_PENDING) != 0)
- *iqp->pending = 0;
-
- if ((cf2 & IOPARM_INQUIRE_HAS_ID) != 0)
- *iqp->id = 0;
-
if ((cf2 & IOPARM_INQUIRE_HAS_ENCODING) != 0)
{
if (u == NULL || u->flags.form != FORM_FORMATTED)
@@ -332,21 +327,43 @@ inquire_via_unit (st_parameter_inquire *iqp, gfc_u
if (u == NULL)
p = undefined;
else
- switch (u->flags.async)
{
- case ASYNC_YES:
- p = yes;
- break;
- case ASYNC_NO:
- p = no;
- break;
- default:
- internal_error (&iqp->common, "inquire_via_unit(): Bad async");
+ switch (u->flags.async)
+ {
+ case ASYNC_YES:
+ p = yes;
+ break;
+ case ASYNC_NO:
+ p = no;
+ break;
+ default:
+ internal_error (&iqp->common, "inquire_via_unit(): Bad async");
+ }
}
-
cf_strcpy (iqp->asynchronous, iqp->asynchronous_len, p);
}
+ if ((cf2 & IOPARM_INQUIRE_HAS_PENDING) != 0)
+ {
+ if (!ASYNC_IO || u->au == NULL)
+ *(iqp->pending) = 0;
+ else
+ {
+ LOCK (&(u->au->lock));
+ if ((cf2 & IOPARM_INQUIRE_HAS_ID) != 0)
+ {
+ int id;
+ id = *(iqp->id);
+ *(iqp->pending) = id > u->au->id.low;
+ }
+ else
+ {
+ *(iqp->pending) = ! u->au->empty;
+ }
+ UNLOCK (&(u->au->lock));
+ }
+ }
+
if ((cf2 & IOPARM_INQUIRE_HAS_SIGN) != 0)
{
if (u == NULL)
Index: libgfortran/io/io.h
===================================================================
--- libgfortran/io/io.h (revision 263244)
+++ libgfortran/io/io.h (working copy)
@@ -531,7 +531,9 @@ typedef struct st_parameter_dt
/* A flag used to identify when a non-standard expanded namelist read
has occurred. */
unsigned expanded_read : 1;
- /* 13 unused bits. */
+ /* Flag to indicate if the statement has async="YES". */
+ unsigned async : 1;
+ /* 12 unused bits. */
int child_saved_iostat;
int nml_delim;
@@ -590,7 +592,7 @@ extern char check_st_parameter_dt[sizeof (((st_par
typedef struct
{
st_parameter_common common;
- CHARACTER1 (id);
+ GFC_INTEGER_4 *id;
}
st_parameter_wait;
@@ -659,6 +661,9 @@ typedef struct gfc_unit
int continued;
+ /* Contains the pointer to the async unit. */
+ struct async_unit *au;
+
__gthread_mutex_t lock;
/* Number of threads waiting to acquire this unit's lock.
When non-zero, close_unit doesn't only removes the unit
@@ -815,11 +820,18 @@ extern void next_record (st_parameter_dt *, int);
internal_proto(next_record);
extern void st_wait (st_parameter_wait *);
-export_proto(st_wait);
+export_proto (st_wait);
+extern void st_wait_async (st_parameter_wait *);
+export_proto (st_wait_async);
+
extern void hit_eof (st_parameter_dt *);
internal_proto(hit_eof);
+extern void transfer_array_inner (st_parameter_dt *, gfc_array_char *, int,
+ gfc_charlen_type);
+internal_proto (transfer_array_inner);
+
/* read.c */
extern void set_integer (void *, GFC_INTEGER_LARGEST, int);
@@ -988,3 +1000,14 @@ memset4 (gfc_char4_t *p, gfc_char4_t c, int k)
#endif
+extern void
+st_write_done_worker (st_parameter_dt *);
+internal_proto (st_write_done_worker);
+
+extern void
+st_read_done_worker (st_parameter_dt *);
+internal_proto (st_read_done_worker);
+
+extern void
+data_transfer_init_worker (st_parameter_dt *, int);
+internal_proto (data_transfer_init_worker);
Index: libgfortran/io/open.c
===================================================================
--- libgfortran/io/open.c (revision 263244)
+++ libgfortran/io/open.c (working copy)
@@ -26,6 +26,7 @@ see the files COPYING3 and COPYING.RUNTIME respect
#include "io.h"
#include "fbuf.h"
#include "unix.h"
+#include "async.h"
#ifdef HAVE_UNISTD_H
#include <unistd.h>
@@ -651,8 +652,12 @@ new_unit (st_parameter_open *opp, gfc_unit *u, uni
else
u->fbuf = NULL;
-
-
+ /* Check if asynchrounous. */
+ if (flags->async == ASYNC_YES)
+ init_async_unit (u);
+ else
+ u->au = NULL;
+
return u;
cleanup:
Index: libgfortran/io/read.c
===================================================================
--- libgfortran/io/read.c (revision 263244)
+++ libgfortran/io/read.c (working copy)
@@ -30,6 +30,7 @@ see the files COPYING3 and COPYING.RUNTIME respect
#include <string.h>
#include <ctype.h>
#include <assert.h>
+#include "async.h"
typedef unsigned char uchar;
@@ -42,6 +43,7 @@ typedef unsigned char uchar;
void
set_integer (void *dest, GFC_INTEGER_LARGEST value, int length)
{
+ NOTE ("set_integer: %lld %p", (long long int) value, dest);
switch (length)
{
#ifdef HAVE_GFC_INTEGER_16
Index: libgfortran/io/transfer.c
===================================================================
--- libgfortran/io/transfer.c (revision 263244)
+++ libgfortran/io/transfer.c (working copy)
@@ -31,6 +31,7 @@ see the files COPYING3 and COPYING.RUNTIME respect
#include "fbuf.h"
#include "format.h"
#include "unix.h"
+#include "async.h"
#include <string.h>
#include <errno.h>
@@ -184,6 +185,12 @@ static const st_option pad_opt[] = {
{NULL, 0}
};
+static const st_option async_opt[] = {
+ {"yes", ASYNC_YES},
+ {"no", ASYNC_NO},
+ {NULL, 0}
+};
+
typedef enum
{ FORMATTED_SEQUENTIAL, UNFORMATTED_SEQUENTIAL,
FORMATTED_DIRECT, UNFORMATTED_DIRECT, FORMATTED_STREAM, UNFORMATTED_STREAM
@@ -1594,7 +1601,8 @@ formatted_transfer_scalar_read (st_parameter_dt *d
read_f (dtp, f, p, kind);
break;
default:
- internal_error (&dtp->common, "formatted_transfer(): Bad type");
+ internal_error (&dtp->common,
+ "formatted_transfer (): Bad type");
}
break;
@@ -2066,7 +2074,7 @@ formatted_transfer_scalar_write (st_parameter_dt *
break;
default:
internal_error (&dtp->common,
- "formatted_transfer(): Bad type");
+ "formatted_transfer (): Bad type");
}
break;
@@ -2281,7 +2289,39 @@ formatted_transfer (st_parameter_dt *dtp, bt type,
}
}
+/* Wrapper function for I/O of scalar types. If this should be an async I/O
+ request, queue it. For a synchronous write on an async unit, perform the
+ wait operation and return an error. For all synchronous writes, call the
+ right transfer function. */
+static void
+wrap_scalar_transfer (st_parameter_dt *dtp, bt type, void *p, int kind,
+ size_t size, size_t n_elem)
+{
+ if (dtp->u.p.current_unit && dtp->u.p.current_unit->au)
+ {
+ if (dtp->u.p.async)
+ {
+ transfer_args args;
+ args.scalar.transfer = dtp->u.p.transfer;
+ args.scalar.arg_bt = type;
+ args.scalar.data = p;
+ args.scalar.i = kind;
+ args.scalar.s1 = size;
+ args.scalar.s2 = n_elem;
+ enqueue_transfer (dtp->u.p.current_unit->au, &args,
+ AIO_TRANSFER_SCALAR);
+ return;
+ }
+ }
+ /* Come here if there was no asynchronous I/O to be scheduled. */
+ if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
+ return;
+
+ dtp->u.p.transfer (dtp, type, p, kind, size, 1);
+}
+
+
/* Data transfer entry points. The type of the data entity is
implicit in the subroutine call. This prevents us from having to
share a common enum with the compiler. */
@@ -2289,9 +2329,7 @@ formatted_transfer (st_parameter_dt *dtp, bt type,
void
transfer_integer (st_parameter_dt *dtp, void *p, int kind)
{
- if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
- return;
- dtp->u.p.transfer (dtp, BT_INTEGER, p, kind, kind, 1);
+ wrap_scalar_transfer (dtp, BT_INTEGER, p, kind, kind, 1);
}
void
@@ -2307,7 +2345,7 @@ transfer_real (st_parameter_dt *dtp, void *p, int
if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
return;
size = size_from_real_kind (kind);
- dtp->u.p.transfer (dtp, BT_REAL, p, kind, size, 1);
+ wrap_scalar_transfer (dtp, BT_REAL, p, kind, size, 1);
}
void
@@ -2319,9 +2357,7 @@ transfer_real_write (st_parameter_dt *dtp, void *p
void
transfer_logical (st_parameter_dt *dtp, void *p, int kind)
{
- if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
- return;
- dtp->u.p.transfer (dtp, BT_LOGICAL, p, kind, kind, 1);
+ wrap_scalar_transfer (dtp, BT_LOGICAL, p, kind, kind, 1);
}
void
@@ -2345,7 +2381,7 @@ transfer_character (st_parameter_dt *dtp, void *p,
p = empty_string;
/* Set kind here to 1. */
- dtp->u.p.transfer (dtp, BT_CHARACTER, p, 1, len, 1);
+ wrap_scalar_transfer (dtp, BT_CHARACTER, p, 1, len, 1);
}
void
@@ -2369,7 +2405,7 @@ transfer_character_wide (st_parameter_dt *dtp, voi
p = empty_string;
/* Here we pass the actual kind value. */
- dtp->u.p.transfer (dtp, BT_CHARACTER, p, kind, len, 1);
+ wrap_scalar_transfer (dtp, BT_CHARACTER, p, kind, len, 1);
}
void
@@ -2385,7 +2421,7 @@ transfer_complex (st_parameter_dt *dtp, void *p, i
if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
return;
size = size_from_complex_kind (kind);
- dtp->u.p.transfer (dtp, BT_COMPLEX, p, kind, size, 1);
+ wrap_scalar_transfer (dtp, BT_COMPLEX, p, kind, size, 1);
}
void
@@ -2395,8 +2431,8 @@ transfer_complex_write (st_parameter_dt *dtp, void
}
void
-transfer_array (st_parameter_dt *dtp, gfc_array_char *desc, int kind,
- gfc_charlen_type charlen)
+transfer_array_inner (st_parameter_dt *dtp, gfc_array_char *desc, int kind,
+ gfc_charlen_type charlen)
{
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
@@ -2407,7 +2443,7 @@ void
bt iotype;
/* Adjust item_count before emitting error message. */
-
+
if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
return;
@@ -2471,6 +2507,36 @@ void
}
void
+transfer_array (st_parameter_dt *dtp, gfc_array_char *desc, int kind,
+ gfc_charlen_type charlen)
+{
+ if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
+ return;
+
+ if (dtp->u.p.current_unit && dtp->u.p.current_unit->au)
+ {
+ if (dtp->u.p.async)
+ {
+ transfer_args args;
+ size_t sz = sizeof (gfc_array_char)
+ + sizeof (descriptor_dimension)
+ * GFC_DESCRIPTOR_RANK (desc);
+ args.array.desc = xmalloc (sz);
+ NOTE ("desc = %p", (void *) args.array.desc);
+ memcpy (args.array.desc, desc, sz);
+ args.array.kind = kind;
+ args.array.charlen = charlen;
+ enqueue_transfer (dtp->u.p.current_unit->au, &args,
+ AIO_TRANSFER_ARRAY);
+ return;
+ }
+ }
+ /* Come here if there was no asynchronous I/O to be scheduled. */
+ transfer_array_inner (dtp, desc, kind, charlen);
+}
+
+
+void
transfer_array_write (st_parameter_dt *dtp, gfc_array_char *desc, int kind,
gfc_charlen_type charlen)
{
@@ -2492,7 +2558,7 @@ transfer_derived (st_parameter_dt *parent, void *d
else
parent->u.p.fdtio_ptr = (formatted_dtio) dtio_proc;
}
- parent->u.p.transfer (parent, BT_CLASS, dtio_source, 0, 0, 1);
+ wrap_scalar_transfer (parent, BT_CLASS, dtio_source, 0, 0, 1);
}
@@ -2667,7 +2733,10 @@ data_transfer_init (st_parameter_dt *dtp, int read
unit_flags u_flags; /* Used for creating a unit if needed. */
GFC_INTEGER_4 cf = dtp->common.flags;
namelist_info *ionml;
+ async_unit *au;
+ NOTE ("data_transfer_init");
+
ionml = ((cf & IOPARM_DT_IONML_SET) != 0) ? dtp->u.p.ionml : NULL;
memset (&dtp->u.p, 0, sizeof (dtp->u.p));
@@ -2693,9 +2762,9 @@ data_transfer_init (st_parameter_dt *dtp, int read
}
else if (dtp->u.p.current_unit->s == NULL)
{ /* Open the unit with some default flags. */
- st_parameter_open opp;
- unit_convert conv;
-
+ st_parameter_open opp;
+ unit_convert conv;
+ NOTE ("Open the unit with some default flags.");
memset (&u_flags, '\0', sizeof (u_flags));
u_flags.access = ACCESS_SEQUENTIAL;
u_flags.action = ACTION_READWRITE;
@@ -2770,6 +2839,42 @@ data_transfer_init (st_parameter_dt *dtp, int read
else if (dtp->u.p.current_unit->internal_unit_kind > 0)
dtp->u.p.unit_is_internal = 1;
+ if ((cf & IOPARM_DT_HAS_ASYNCHRONOUS) != 0)
+ {
+ int f;
+ f = find_option (&dtp->common, dtp->asynchronous, dtp->asynchronous_len,
+ async_opt, "Bad ASYNCHRONOUS in data transfer "
+ "statement");
+ if (f == ASYNC_YES && dtp->u.p.current_unit->flags.async != ASYNC_YES)
+ {
+ generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
+ "ASYNCHRONOUS transfer without "
+ "ASYHCRONOUS='YES' in OPEN");
+ return;
+ }
+ dtp->u.p.async = f == ASYNC_YES;
+ }
+
+ au = dtp->u.p.current_unit->au;
+ if (au)
+ {
+ if (dtp->u.p.async)
+ {
+ /* If this is an asynchronous I/O statement, collect errors and
+ return if there are any. */
+ if (collect_async_errors (&dtp->common, au))
+ return;
+ }
+ else
+ {
+ /* Synchronous statement: Perform a wait operation for any pending
+ asynchronous I/O. This needs to be done before all other error
+ checks. See F2008, 9.6.4.1. */
+ if (async_wait (&(dtp->common), au))
+ return;
+ }
+ }
+
/* Check the action. */
if (read_flag && dtp->u.p.current_unit->flags.action == ACTION_WRITE)
@@ -3009,6 +3114,57 @@ data_transfer_init (st_parameter_dt *dtp, int read
if (dtp->u.p.current_unit->pad_status == PAD_UNSPECIFIED)
dtp->u.p.current_unit->pad_status = dtp->u.p.current_unit->flags.pad;
+ /* Set up the subroutine that will handle the transfers. */
+
+ if (read_flag)
+ {
+ if (dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED)
+ dtp->u.p.transfer = unformatted_read;
+ else
+ {
+ if ((cf & IOPARM_DT_LIST_FORMAT) != 0)
+ dtp->u.p.transfer = list_formatted_read;
+ else
+ dtp->u.p.transfer = formatted_transfer;
+ }
+ }
+ else
+ {
+ if (dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED)
+ dtp->u.p.transfer = unformatted_write;
+ else
+ {
+ if ((cf & IOPARM_DT_LIST_FORMAT) != 0)
+ dtp->u.p.transfer = list_formatted_write;
+ else
+ dtp->u.p.transfer = formatted_transfer;
+ }
+ }
+
+ if (au)
+ {
+ NOTE ("enqueue_data_transfer");
+ enqueue_data_transfer_init (au, dtp, read_flag);
+ }
+ else
+ {
+ NOTE ("invoking data_transfer_init_worker");
+ data_transfer_init_worker (dtp, read_flag);
+ }
+}
+
+void
+data_transfer_init_worker (st_parameter_dt *dtp, int read_flag)
+{
+ GFC_INTEGER_4 cf = dtp->common.flags;
+
+ NOTE ("starting worker...");
+
+ if (read_flag && dtp->u.p.current_unit->flags.form != FORM_UNFORMATTED
+ && ((cf & IOPARM_DT_LIST_FORMAT) != 0)
+ && dtp->u.p.current_unit->child_dtio == 0)
+ dtp->u.p.current_unit->last_char = EOF - 1;
+
/* Check to see if we might be reading what we wrote before */
if (dtp->u.p.mode != dtp->u.p.current_unit->mode
@@ -3135,38 +3291,6 @@ data_transfer_init (st_parameter_dt *dtp, int read
pre_position (dtp);
-
- /* Set up the subroutine that will handle the transfers. */
-
- if (read_flag)
- {
- if (dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED)
- dtp->u.p.transfer = unformatted_read;
- else
- {
- if ((cf & IOPARM_DT_LIST_FORMAT) != 0)
- {
- if (dtp->u.p.current_unit->child_dtio == 0)
- dtp->u.p.current_unit->last_char = EOF - 1;
- dtp->u.p.transfer = list_formatted_read;
- }
- else
- dtp->u.p.transfer = formatted_transfer;
- }
- }
- else
- {
- if (dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED)
- dtp->u.p.transfer = unformatted_write;
- else
- {
- if ((cf & IOPARM_DT_LIST_FORMAT) != 0)
- dtp->u.p.transfer = list_formatted_write;
- else
- dtp->u.p.transfer = formatted_transfer;
- }
- }
-
/* Make sure that we don't do a read after a nonadvancing write. */
if (read_flag)
@@ -4099,7 +4223,7 @@ extern void st_read_done (st_parameter_dt *);
export_proto(st_read_done);
void
-st_read_done (st_parameter_dt *dtp)
+st_read_done_worker (st_parameter_dt *dtp)
{
finalize_transfer (dtp);
@@ -4127,6 +4251,30 @@ void
free_format_data (dtp->u.p.fmt);
free_format (dtp);
}
+ }
+}
+
+void
+st_read_done (st_parameter_dt *dtp)
+{
+ if (dtp->u.p.current_unit)
+ {
+ if (dtp->u.p.current_unit->au)
+ {
+ if (dtp->common.flags & IOPARM_DT_HAS_ID)
+ *dtp->id = enqueue_done_id (dtp->u.p.current_unit->au, AIO_READ_DONE);
+ else
+ {
+ enqueue_done (dtp->u.p.current_unit->au, AIO_READ_DONE);
+ /* An asynchronous unit without ASYNCHRONOUS="YES" - make this
+ synchronous by performing a wait operation. */
+ if (!dtp->u.p.async)
+ async_wait (&dtp->common, dtp->u.p.current_unit->au);
+ }
+ }
+ else
+ st_read_done_worker (dtp);
+
unlock_unit (dtp->u.p.current_unit);
}
@@ -4134,7 +4282,7 @@ void
}
extern void st_write (st_parameter_dt *);
-export_proto(st_write);
+export_proto (st_write);
void
st_write (st_parameter_dt *dtp)
@@ -4143,11 +4291,9 @@ st_write (st_parameter_dt *dtp)
data_transfer_init (dtp, 0);
}
-extern void st_write_done (st_parameter_dt *);
-export_proto(st_write_done);
void
-st_write_done (st_parameter_dt *dtp)
+st_write_done_worker (st_parameter_dt *dtp)
{
finalize_transfer (dtp);
@@ -4196,19 +4342,68 @@ void
free_format_data (dtp->u.p.fmt);
free_format (dtp);
}
+ }
+}
+
+extern void st_write_done (st_parameter_dt *);
+export_proto(st_write_done);
+
+void
+st_write_done (st_parameter_dt *dtp)
+{
+ if (dtp->u.p.current_unit)
+ {
+ if (dtp->u.p.current_unit->au)
+ {
+ if (dtp->common.flags & IOPARM_DT_HAS_ID)
+ *dtp->id = enqueue_done_id (dtp->u.p.current_unit->au,
+ AIO_WRITE_DONE);
+ else
+ {
+ enqueue_done (dtp->u.p.current_unit->au, AIO_WRITE_DONE);
+ /* An asynchronous unit without ASYNCHRONOUS="YES" - make this
+ synchronous by performing a wait operation. */
+ if (!dtp->u.p.async)
+ async_wait (&dtp->common, dtp->u.p.current_unit->au);
+ }
+ }
+ else
+ st_write_done_worker (dtp);
+
unlock_unit (dtp->u.p.current_unit);
}
+
library_end ();
}
+/* Wait operation. We need to keep around the do-nothing version
+ of st_wait for compatibility with previous versions, which had marked
+ the argument as unused (and thus liable to be removed).
-/* F2003: This is a stub for the runtime portion of the WAIT statement. */
+ TODO: remove at next bump in version number. */
+
void
st_wait (st_parameter_wait *wtp __attribute__((unused)))
{
+ return;
}
+void
+st_wait_async (st_parameter_wait *wtp)
+{
+ gfc_unit *u = find_unit (wtp->common.unit);
+ if (ASYNC_IO && u->au)
+ {
+ if (wtp->common.flags & IOPARM_WAIT_HAS_ID)
+ async_wait_id (&(wtp->common), u->au, *wtp->id);
+ else
+ async_wait (&(wtp->common), u->au);
+ }
+ unlock_unit (u);
+}
+
+
/* Receives the scalar information for namelist objects and stores it
in a linked list of namelist_info types. */
Index: libgfortran/io/unit.c
===================================================================
--- libgfortran/io/unit.c (revision 263244)
+++ libgfortran/io/unit.c (working copy)
@@ -27,6 +27,7 @@ see the files COPYING3 and COPYING.RUNTIME respect
#include "fbuf.h"
#include "format.h"
#include "unix.h"
+#include "async.h"
#include <string.h>
#include <assert.h>
@@ -240,7 +241,7 @@ insert_unit (int n)
#else
__GTHREAD_MUTEX_INIT_FUNCTION (&u->lock);
#endif
- __gthread_mutex_lock (&u->lock);
+ LOCK (&u->lock);
u->priority = pseudo_random ();
unit_root = insert (u, unit_root);
return u;
@@ -327,7 +328,9 @@ get_gfc_unit (int n, int do_create)
gfc_unit *p;
int c, created = 0;
- __gthread_mutex_lock (&unit_lock);
+ NOTE ("Unit n=%d, do_create = %d", n, do_create);
+ LOCK (&unit_lock);
+
retry:
for (c = 0; c < CACHE_SIZE; c++)
if (unit_cache[c] != NULL && unit_cache[c]->unit_number == n)
@@ -366,7 +369,7 @@ retry:
{
/* Newly created units have their lock held already
from insert_unit. Just unlock UNIT_LOCK and return. */
- __gthread_mutex_unlock (&unit_lock);
+ UNLOCK (&unit_lock);
return p;
}
@@ -374,10 +377,10 @@ found:
if (p != NULL && (p->child_dtio == 0))
{
/* Fast path. */
- if (! __gthread_mutex_trylock (&p->lock))
+ if (! TRYLOCK (&p->lock))
{
/* assert (p->closed == 0); */
- __gthread_mutex_unlock (&unit_lock);
+ UNLOCK (&unit_lock);
return p;
}
@@ -385,15 +388,15 @@ found:
}
- __gthread_mutex_unlock (&unit_lock);
+ UNLOCK (&unit_lock);
if (p != NULL && (p->child_dtio == 0))
{
- __gthread_mutex_lock (&p->lock);
+ LOCK (&p->lock);
if (p->closed)
{
- __gthread_mutex_lock (&unit_lock);
- __gthread_mutex_unlock (&p->lock);
+ LOCK (&unit_lock);
+ UNLOCK (&p->lock);
if (predec_waiting_locked (p) == 0)
destroy_unit_mutex (p);
goto retry;
@@ -640,7 +643,7 @@ init_units (void)
fbuf_init (u, 0);
- __gthread_mutex_unlock (&u->lock);
+ UNLOCK (&u->lock);
}
if (options.stdout_unit >= 0)
@@ -671,7 +674,7 @@ init_units (void)
fbuf_init (u, 0);
- __gthread_mutex_unlock (&u->lock);
+ UNLOCK (&u->lock);
}
if (options.stderr_unit >= 0)
@@ -702,13 +705,13 @@ init_units (void)
fbuf_init (u, 256); /* 256 bytes should be enough, probably not doing
any kind of exotic formatting to stderr. */
- __gthread_mutex_unlock (&u->lock);
+ UNLOCK (&u->lock);
}
/* The default internal units. */
u = insert_unit (GFC_INTERNAL_UNIT);
- __gthread_mutex_unlock (&u->lock);
+ UNLOCK (&u->lock);
u = insert_unit (GFC_INTERNAL_UNIT4);
- __gthread_mutex_unlock (&u->lock);
+ UNLOCK (&u->lock);
}
@@ -717,6 +720,9 @@ close_unit_1 (gfc_unit *u, int locked)
{
int i, rc;
+ if (ASYNC_IO && u->au)
+ async_close (u->au);
+
/* If there are previously written bytes from a write with ADVANCE="no"
Reposition the buffer before closing. */
if (u->previous_nonadvancing_write)
@@ -726,7 +732,7 @@ close_unit_1 (gfc_unit *u, int locked)
u->closed = 1;
if (!locked)
- __gthread_mutex_lock (&unit_lock);
+ LOCK (&unit_lock);
for (i = 0; i < CACHE_SIZE; i++)
if (unit_cache[i] == u)
@@ -744,7 +750,7 @@ close_unit_1 (gfc_unit *u, int locked)
newunit_free (u->unit_number);
if (!locked)
- __gthread_mutex_unlock (&u->lock);
+ UNLOCK (&u->lock);
/* If there are any threads waiting in find_unit for this unit,
avoid freeing the memory, the last such thread will free it
@@ -753,7 +759,7 @@ close_unit_1 (gfc_unit *u, int locked)
destroy_unit_mutex (u);
if (!locked)
- __gthread_mutex_unlock (&unit_lock);
+ UNLOCK (&unit_lock);
return rc;
}
@@ -761,7 +767,9 @@ close_unit_1 (gfc_unit *u, int locked)
void
unlock_unit (gfc_unit *u)
{
- __gthread_mutex_unlock (&u->lock);
+ NOTE ("unlock_unit = %d", u->unit_number);
+ UNLOCK (&u->lock);
+ NOTE ("unlock_unit done");
}
/* close_unit()-- Close a unit. The stream is closed, and any memory
@@ -785,10 +793,10 @@ close_unit (gfc_unit *u)
void
close_units (void)
{
- __gthread_mutex_lock (&unit_lock);
+ LOCK (&unit_lock);
while (unit_root != NULL)
close_unit_1 (unit_root, 1);
- __gthread_mutex_unlock (&unit_lock);
+ UNLOCK (&unit_lock);
free (newunits);
@@ -895,7 +903,7 @@ finish_last_advance_record (gfc_unit *u)
int
newunit_alloc (void)
{
- __gthread_mutex_lock (&unit_lock);
+ LOCK (&unit_lock);
if (!newunits)
{
newunits = xcalloc (16, 1);
@@ -909,7 +917,7 @@ newunit_alloc (void)
{
newunits[ii] = true;
newunit_lwi = ii + 1;
- __gthread_mutex_unlock (&unit_lock);
+ UNLOCK (&unit_lock);
return -ii + NEWUNIT_START;
}
}
@@ -922,7 +930,7 @@ newunit_alloc (void)
memset (newunits + old_size, 0, old_size);
newunits[old_size] = true;
newunit_lwi = old_size + 1;
- __gthread_mutex_unlock (&unit_lock);
+ UNLOCK (&unit_lock);
return -old_size + NEWUNIT_START;
}
Index: libgfortran/io/unix.c
===================================================================
--- libgfortran/io/unix.c (revision 263244)
+++ libgfortran/io/unix.c (working copy)
@@ -27,6 +27,7 @@ see the files COPYING3 and COPYING.RUNTIME respect
#include "io.h"
#include "unix.h"
+#include "async.h"
#include <limits.h>
#ifdef HAVE_UNISTD_H
@@ -1742,7 +1743,7 @@ find_file (const char *file, gfc_charlen_type file
id = id_from_path (path);
#endif
- __gthread_mutex_lock (&unit_lock);
+ LOCK (&unit_lock);
retry:
u = find_file0 (unit_root, FIND_FILE0_ARGS);
if (u != NULL)
@@ -1751,20 +1752,20 @@ retry:
if (! __gthread_mutex_trylock (&u->lock))
{
/* assert (u->closed == 0); */
- __gthread_mutex_unlock (&unit_lock);
+ UNLOCK (&unit_lock);
goto done;
}
inc_waiting_locked (u);
}
- __gthread_mutex_unlock (&unit_lock);
+ UNLOCK (&unit_lock);
if (u != NULL)
{
- __gthread_mutex_lock (&u->lock);
+ LOCK (&u->lock);
if (u->closed)
{
- __gthread_mutex_lock (&unit_lock);
- __gthread_mutex_unlock (&u->lock);
+ LOCK (&unit_lock);
+ UNLOCK (&u->lock);
if (predec_waiting_locked (u) == 0)
free (u);
goto retry;
@@ -1794,7 +1795,7 @@ flush_all_units_1 (gfc_unit *u, int min_unit)
return u;
if (u->s)
sflush (u->s);
- __gthread_mutex_unlock (&u->lock);
+ UNLOCK (&u->lock);
}
u = u->right;
}
@@ -1807,17 +1808,17 @@ flush_all_units (void)
gfc_unit *u;
int min_unit = 0;
- __gthread_mutex_lock (&unit_lock);
+ LOCK (&unit_lock);
do
{
u = flush_all_units_1 (unit_root, min_unit);
if (u != NULL)
inc_waiting_locked (u);
- __gthread_mutex_unlock (&unit_lock);
+ UNLOCK (&unit_lock);
if (u == NULL)
return;
- __gthread_mutex_lock (&u->lock);
+ LOCK (&u->lock);
min_unit = u->unit_number + 1;
@@ -1824,14 +1825,14 @@ flush_all_units (void)
if (u->closed == 0)
{
sflush (u->s);
- __gthread_mutex_lock (&unit_lock);
- __gthread_mutex_unlock (&u->lock);
+ LOCK (&unit_lock);
+ UNLOCK (&u->lock);
(void) predec_waiting_locked (u);
}
else
{
- __gthread_mutex_lock (&unit_lock);
- __gthread_mutex_unlock (&u->lock);
+ LOCK (&unit_lock);
+ UNLOCK (&u->lock);
if (predec_waiting_locked (u) == 0)
free (u);
}
Index: libgfortran/libgfortran.h
===================================================================
--- libgfortran/libgfortran.h (revision 263244)
+++ libgfortran/libgfortran.h (working copy)
@@ -738,6 +738,9 @@ internal_proto(translate_error);
extern void generate_error (st_parameter_common *, int, const char *);
iexport_proto(generate_error);
+extern bool generate_error_common (st_parameter_common *, int, const char *);
+iexport_proto(generate_error_common);
+
extern void generate_warning (st_parameter_common *, const char *);
internal_proto(generate_warning);
@@ -1743,5 +1746,7 @@ void cshift1_16_c16 (gfc_array_c16 * const restric
internal_proto(cshift1_16_c16);
#endif
+/* Define this if we support asynchronous I/O on this platform. This
+ currently requires weak symbols. */
#endif /* LIBGFOR_H */
Index: libgfortran/runtime/error.c
===================================================================
--- libgfortran/runtime/error.c (revision 263244)
+++ libgfortran/runtime/error.c (working copy)
@@ -24,6 +24,9 @@ see the files COPYING3 and COPYING.RUNTIME respect
#include "libgfortran.h"
+#include "io.h"
+#include "async.h"
+
#include <assert.h>
#include <string.h>
#include <errno.h>
@@ -526,24 +529,41 @@ translate_error (int code)
}
-/* generate_error()-- Come here when an error happens. This
- * subroutine is called if it is possible to continue on after the error.
- * If an IOSTAT or IOMSG variable exists, we set it. If IOSTAT or
- * ERR labels are present, we return, otherwise we terminate the program
- * after printing a message. The error code is always required but the
- * message parameter can be NULL, in which case a string describing
- * the most recent operating system error is used. */
+/* Worker function for generate_error and generate_error_async. Return true
+ if a straight return is to be done, zero if the program should abort. */
-void
-generate_error (st_parameter_common *cmp, int family, const char *message)
+bool
+generate_error_common (st_parameter_common *cmp, int family, const char *message)
{
char errmsg[STRERR_MAXSZ];
+#if ASYNC_IO
+ gfc_unit *u;
+
+ NOTE ("Entering generate_error_common");
+
+ u = thread_unit;
+ if (u && u->au)
+ {
+ if (u->au->error.has_error)
+ return true;
+
+ if (__gthread_equal (u->au->thread, __gthread_self ()))
+ {
+ u->au->error.has_error = 1;
+ u->au->error.cmp = cmp;
+ u->au->error.family = family;
+ u->au->error.message = message;
+ return true;
+ }
+ }
+#endif
+
/* If there was a previous error, don't mask it with another
error message, EOF or EOR condition. */
if ((cmp->flags & IOPARM_LIBRETURN_MASK) == IOPARM_LIBRETURN_ERROR)
- return;
+ return true;
/* Set the error status. */
if ((cmp->flags & IOPARM_HAS_IOSTAT))
@@ -562,29 +582,30 @@ translate_error (int code)
switch (family)
{
case LIBERROR_EOR:
- cmp->flags |= IOPARM_LIBRETURN_EOR;
+ cmp->flags |= IOPARM_LIBRETURN_EOR; NOTE("EOR");
if ((cmp->flags & IOPARM_EOR))
- return;
+ return true;
break;
case LIBERROR_END:
- cmp->flags |= IOPARM_LIBRETURN_END;
+ cmp->flags |= IOPARM_LIBRETURN_END; NOTE("END");
if ((cmp->flags & IOPARM_END))
- return;
+ return true;
break;
default:
- cmp->flags |= IOPARM_LIBRETURN_ERROR;
+ cmp->flags |= IOPARM_LIBRETURN_ERROR; NOTE("ERROR");
if ((cmp->flags & IOPARM_ERR))
- return;
+ return true;
break;
}
/* Return if the user supplied an iostat variable. */
if ((cmp->flags & IOPARM_HAS_IOSTAT))
- return;
+ return true;
- /* Terminate the program */
+ /* Return code, caller is responsible for terminating
+ the program if necessary. */
recursion_check ();
show_locus (cmp);
@@ -591,8 +612,27 @@ translate_error (int code)
estr_write ("Fortran runtime error: ");
estr_write (message);
estr_write ("\n");
- exit_error (2);
+ return false;
}
+
+/* generate_error()-- Come here when an error happens. This
+ * subroutine is called if it is possible to continue on after the error.
+ * If an IOSTAT or IOMSG variable exists, we set it. If IOSTAT or
+ * ERR labels are present, we return, otherwise we terminate the program
+ * after printing a message. The error code is always required but the
+ * message parameter can be NULL, in which case a string describing
+ * the most recent operating system error is used.
+ * If the error is for an asynchronous unit and if the program is currently
+ * executing the asynchronous thread, just mark the error and return. */
+
+void
+generate_error (st_parameter_common *cmp, int family, const char *message)
+{
+ if (generate_error_common (cmp, family, message))
+ return;
+
+ exit_error(2);
+}
iexport(generate_error);
[-- Attachment #3: async_io_1.f90 --]
[-- Type: text/plain, Size: 1426 bytes --]
! { dg-do run }
!TODO: Move these testcases to gfortran testsuite
! once compilation with pthreads is supported there
! Check basic functionality of async I/O
program main
implicit none
integer:: i=1, j=2, k, l
real :: a, b, c, d
character(3), parameter:: yes="yes"
character(4) :: str
complex :: cc, dd
integer, dimension(4):: is = [0, 1, 2, 3]
integer, dimension(4):: res
character(10) :: inq
open (10, file='a.dat', asynchronous=yes)
cc = (1.5, 0.5)
inquire (10,asynchronous=inq)
if (inq /= "YES") stop 1
write (10,*,asynchronous=yes) 4, 3
write (10,*,asynchronous=yes) 2, 1
write (10,*,asynchronous=yes) 1.0, 3.0
write (10,'(A)', asynchronous=yes) 'asdf'
write (10,*, asynchronous=yes) cc
close (10)
open (20, file='a.dat', asynchronous=yes)
read (20, *, asynchronous=yes) i, j
read (20, *, asynchronous=yes) k, l
read (20, *, asynchronous=yes) a, b
read (20,'(A4)',asynchronous=yes) str
read (20,*, asynchronous=yes) dd
wait (20)
if (i /= 4 .or. j /= 3) stop 2
if (k /= 2 .or. l /= 1) stop 3
if (a /= 1.0 .or. b /= 3.0) stop 4
if (str /= 'asdf') stop 5
if (cc /= dd) stop 6
close (20,status="delete")
open(10, file='c.dat', asynchronous=yes)
write(10, *, asynchronous=yes) is
close(10)
open(20, file='c.dat', asynchronous=yes)
read(20, *, asynchronous=yes) res
wait (20)
if (any(res /= is)) stop 7
close (20,status="delete")
end program
[-- Attachment #4: async_io_2.f90 --]
[-- Type: text/plain, Size: 473 bytes --]
! { dg-do run }
!TODO: Move these testcases to gfortran testsuite
! once compilation with pthreads is supported there
program main
implicit none
integer :: i, ios
character(len=100) :: iom
open (10,file="tst.dat")
write (10,'(A4)') 'asdf'
close(10)
i = 234
open(10,file="tst.dat", asynchronous="yes")
read (10,'(I4)',asynchronous="yes") i
iom = ' '
wait (10,iostat=ios,iomsg=iom)
if (iom == ' ') stop 1
close(10,status="delete")
end program main
[-- Attachment #5: async_io_3.f90 --]
[-- Type: text/plain, Size: 462 bytes --]
!TODO: Move these testcases to gfortran testsuite
! once compilation with pthreads is supported there
! { dg-do run }
program main
integer :: i
open (10,file="tst.dat")
write (10,'(A4)') 'asdf'
close(10)
i = 234
open(10,file="tst.dat", asynchronous="yes")
read (10,'(I4)',asynchronous="yes") i
wait(10)
end program main
! { dg-output "Fortran runtime error: Bad value during integer read" }
! { dg-final { remote_file build delete "tst.dat" } }
[-- Attachment #6: async_io_4.f90 --]
[-- Type: text/plain, Size: 1788 bytes --]
! { dg-do run { target fd_truncate } }
!TODO: Move these testcases to gfortran testsuite
! once compilation with pthreads is supported there
! Test BACKSPACE for synchronous and asynchronous I/O
program main
integer i, n, nr
real x(10), y(10)
! PR libfortran/20068
open (20, status='scratch', asynchronous="yes")
write (20,*, asynchronous="yes" ) 1
write (20,*, asynchronous="yes") 2
write (20,*, asynchronous="yes") 3
rewind (20)
i = 41
read (20,*, asynchronous="yes") i
wait (20)
if (i .ne. 1) STOP 1
write (*,*) ' '
backspace (20)
i = 42
read (20,*, asynchronous="yes") i
close (20)
if (i .ne. 1) STOP 2
! PR libfortran/20125
open (20, status='scratch', asynchronous="yes")
write (20,*, asynchronous="yes") 7
backspace (20)
read (20,*, asynchronous="yes") i
wait (20)
if (i .ne. 7) STOP 3
close (20)
open (20, status='scratch', form='unformatted')
write (20) 8
backspace (20)
read (20) i
if (i .ne. 8) STOP 4
close (20)
! PR libfortran/20471
do n = 1, 10
x(n) = sqrt(real(n))
end do
open (3, form='unformatted', status='scratch')
write (3) (x(n),n=1,10)
backspace (3)
rewind (3)
read (3) (y(n),n=1,10)
do n = 1, 10
if (abs(x(n)-y(n)) > 0.00001) STOP 5
end do
close (3)
! PR libfortran/20156
open (3, form='unformatted', status='scratch')
do i = 1, 5
x(1) = i
write (3) n, (x(n),n=1,10)
end do
nr = 0
rewind (3)
20 continue
read (3,end=30,err=90) n, (x(n),n=1,10)
nr = nr + 1
goto 20
30 continue
if (nr .ne. 5) STOP 6
do i = 1, nr+1
backspace (3)
end do
do i = 1, nr
read(3,end=70,err=90) n, (x(n),n=1,10)
if (abs(x(1) - i) .gt. 0.001) STOP 7
end do
close (3)
stop
70 continue
STOP 8
90 continue
STOP 9
end program
[-- Attachment #7: async_io_5.f90 --]
[-- Type: text/plain, Size: 3788 bytes --]
! { dg-do run }
!TODO: Move these testcases to gfortran testsuite
! once compilation with pthreads is supported there
! PR55818 Reading a REAL from a file which doesn't end in a new line fails
! Test case from PR reporter.
implicit none
integer :: stat
!integer :: var ! << works
real :: var ! << fails
character(len=10) :: cvar ! << fails
complex :: cval
logical :: lvar
open(99, file="test.dat", access="stream", form="unformatted", status="new")
write(99) "1", new_line("")
write(99) "2", new_line("")
write(99) "3"
close(99)
! Test character kind
open(99, file="test.dat")
read (99,*, iostat=stat) cvar
if (stat /= 0 .or. cvar /= "1") STOP 1
read (99,*, iostat=stat) cvar
if (stat /= 0 .or. cvar /= "2") STOP 2
read (99,*, iostat=stat) cvar ! << FAILS: stat /= 0
if (stat /= 0 .or. cvar /= "3") STOP 3 ! << aborts here
! Test real kind
rewind(99)
read (99,*, iostat=stat) var
if (stat /= 0 .or. var /= 1.0) STOP 4
read (99,*, iostat=stat) var
if (stat /= 0 .or. var /= 2.0) STOP 5
read (99,*, iostat=stat) var ! << FAILS: stat /= 0
if (stat /= 0 .or. var /= 3.0) STOP 6
close(99, status="delete")
! Test real kind with exponents
open(99, file="test.dat", access="stream", form="unformatted", status="new")
write(99) "1.0e3", new_line("")
write(99) "2.0e-03", new_line("")
write(99) "3.0e2"
close(99)
open(99, file="test.dat")
read (99,*, iostat=stat) var
if (stat /= 0) STOP 7
read (99,*, iostat=stat) var
if (stat /= 0) STOP 8
read (99,*) var ! << FAILS: stat /= 0
if (stat /= 0) STOP 9
close(99, status="delete")
! Test logical kind
open(99, file="test.dat", access="stream", form="unformatted", status="new")
write(99) "Tru", new_line("")
write(99) "fal", new_line("")
write(99) "t"
close(99)
open(99, file="test.dat")
read (99,*, iostat=stat) lvar
if (stat /= 0 .or. (.not.lvar)) STOP 10
read (99,*, iostat=stat) lvar
if (stat /= 0 .or. lvar) STOP 11
read (99,*) lvar ! << FAILS: stat /= 0
if (stat /= 0 .or. (.not.lvar)) STOP 12
close(99, status="delete")
! Test combinations of Inf and Nan
open(99, file="test.dat", access="stream", form="unformatted", status="new")
write(99) "infinity", new_line("")
write(99) "nan", new_line("")
write(99) "infinity"
close(99)
open(99, file="test.dat")
read (99,*, iostat=stat) var
if (stat /= 0) STOP 13
read (99,*, iostat=stat) var
if (stat /= 0) STOP 14
read (99,*) var ! << FAILS: stat /= 0
if (stat /= 0) STOP 1! << aborts here
close(99, status="delete")
open(99, file="test.dat", access="stream", form="unformatted", status="new")
write(99) "infinity", new_line("")
write(99) "inf", new_line("")
write(99) "nan"
close(99)
open(99, file="test.dat")
read (99,*, iostat=stat) var
if (stat /= 0) STOP 15
read (99,*, iostat=stat) var
if (stat /= 0) STOP 16
read (99,*) var ! << FAILS: stat /= 0
if (stat /= 0) STOP 2! << aborts here
close(99, status="delete")
open(99, file="test.dat", access="stream", form="unformatted", status="new")
write(99) "infinity", new_line("")
write(99) "nan", new_line("")
write(99) "inf"
close(99)
open(99, file="test.dat")
read (99,*, iostat=stat) var
if (stat /= 0) STOP 17
read (99,*, iostat=stat) var
if (stat /= 0) STOP 18
read (99,*) var ! << FAILS: stat /= 0
if (stat /= 0) STOP 3! << aborts here
close(99, status="delete")
! Test complex kind
open(99, file="test.dat", access="stream", form="unformatted", status="new")
write(99) "(1,2)", new_line("")
write(99) "(2,3)", new_line("")
write(99) "(4,5)"
close(99)
open(99, file="test.dat")
read (99,*, iostat=stat) cval
if (stat /= 0 .or. cval /= cmplx(1,2)) STOP 19
read (99,*, iostat=stat) cval
if (stat /= 0 .or. cval /= cmplx(2,3)) STOP 20
read (99,*, iostat=stat) cval ! << FAILS: stat /= 0, value is okay
if (stat /= 0 .or. cval /= cmplx(4,5)) STOP 21
close(99, status="delete")
end
[-- Attachment #8: async_io_6.f90 --]
[-- Type: text/plain, Size: 534 bytes --]
! { dg-do run }
!TODO: Move these testcases to gfortran testsuite
! once compilation with pthreads is supported there
! PR 22390 Implement flush statement
program flush_1
character(len=256) msg
integer ios
open (unit=10, access='SEQUENTIAL', status='SCRATCH')
write (10, *) 42
flush 10
write (10, *) 42
flush(10)
write (10, *) 42
flush(unit=10, iostat=ios)
if (ios /= 0) STOP 1
write (10, *) 42
flush (unit=10, err=20)
goto 30
20 STOP 2
30 continue
call flush(10)
end program flush_1
[-- Attachment #9: async_io_7.f90 --]
[-- Type: text/plain, Size: 680 bytes --]
! { dg-do run }
!TODO: Move these testcases to gfortran testsuite
! once compilation with pthreads is supported there
! PR40008 F2008: Add NEWUNIT= for OPEN statement
! Contributed by Jerry DeLisle <jvdelisle@gcc.gnu.org>
program newunit_1
character(len=25) :: str
integer(1) :: myunit, myunit2
myunit = 25
str = "bad"
open(newunit=myunit, status="scratch")
open(newunit = myunit2, file="newunit_1file")
write(myunit,'(e24.15e2)') 1.0d0
write(myunit2,*) "abcdefghijklmnop"
flush(myunit)
rewind(myunit)
rewind(myunit2)
read(myunit2,'(a)') str
if (str.ne." abcdefghijklmnop") STOP 1
close(myunit)
close(myunit2, status="delete")
end program newunit_1
^ permalink raw reply [flat|nested] 20+ messages in thread
* Re: Async I/O patch with compilation fix
2018-08-02 11:35 ` Async I/O patch with compilation fix Nicolas Koenig
@ 2018-08-02 15:43 ` Christophe Lyon
2018-08-02 17:08 ` Nicolas Koenig
0 siblings, 1 reply; 20+ messages in thread
From: Christophe Lyon @ 2018-08-02 15:43 UTC (permalink / raw)
To: koenigni
Cc: Andre Simoes Dias Vieira, gcc Patches, fortran, Thomas Koenig,
Ulrich Weigand, David Edelsohn, clyon
On Thu, 2 Aug 2018 at 13:35, Nicolas Koenig <koenigni@student.ethz.ch> wrote:
>
>
> Hello everyone,
>
> Here is an updated version of the patch that hopefully fixes the compilation
> problems by disabling async I/O if conditions are not supported by the target.
>
> I would appreciate if people could test it on systems on which it failed
> before. As for the array_constructor_8.f90 failure reported in the PR, why
> it fails is beyond me, it doesn't even use I/O. Maybe/Probably something
> unrelated?
>
Hi,
I'm probably missing something obvious, but after applying this patch
on top of r263136, the builds fail while building libgfortran:
/tmp/9271913_1.tmpdir/aci-gcc-fsf/sources/gcc-fsf/gccsrc/libgfortran/runtime/error.c:28:10:
fatal error: async.h: No such file or directory
#include "async.h"
^~~~~~~~~
compilation terminated.
make[3]: *** [error.lo] Error 1
> Nicolas
>
>
> 2018-08-02 Nicolas Koenig <koenigni@gcc.gnu.org>
> Thomas Koenig <tkoenig@gcc.gnu.org>
>
> PR fortran/25829
> * gfortran.texi: Add description of asynchronous I/O.
> * trans-decl.c (gfc_finish_var_decl): Treat asynchronous variables
> as volatile.
> * trans-io.c (gfc_build_io_library_fndecls): Rename st_wait to
> st_wait_async and change argument spec from ".X" to ".w".
> (gfc_trans_wait): Pass ID argument via reference.
>
> 2018-08-02 Nicolas Koenig <koenigni@gcc.gnu.org>
> Thomas Koenig <tkoenig@gcc.gnu.org>
>
> PR fortran/25829
> * gfortran.dg/f2003_inquire_1.f03: Add write statement.
> * gfortran.dg/f2003_io_1.f03: Add wait statement.
>
> 2018-08-02 Nicolas Koenig <koenigni@gcc.gnu.org>
> Thomas Koenig <tkoenig@gcc.gnu.org>
>
> PR fortran/25829
> * Makefile.am: Add async.c to gfor_io_src.
> Add async.h to gfor_io_headers.
> * Makefile.in: Regenerated.
> * gfortran.map: Add _gfortran_st_wait_async.
> * io/async.c: New file.
> * io/async.h: New file.
> * io/close.c: Include async.h.
> (st_close): Call async_wait for an asynchronous unit.
> * io/file_pos.c (st_backspace): Likewise.
> (st_endfile): Likewise.
> (st_rewind): Likewise.
> (st_flush): Likewise.
> * io/inquire.c: Add handling for asynchronous PENDING
> and ID arguments.
> * io/io.h (st_parameter_dt): Add async bit.
> (st_parameter_wait): Correct.
> (gfc_unit): Add au pointer.
> (st_wait_async): Add prototype.
> (transfer_array_inner): Likewise.
> (st_write_done_worker): Likewise.
> * io/open.c: Include async.h.
> (new_unit): Initialize asynchronous unit.
> * io/transfer.c (async_opt): New struct.
> (wrap_scalar_transfer): New function.
> (transfer_integer): Call wrap_scalar_transfer to do the work.
> (transfer_real): Likewise.
> (transfer_real_write): Likewise.
> (transfer_character): Likewise.
> (transfer_character_wide): Likewise.
> (transfer_complex): Likewise.
> (transfer_array_inner): New function.
> (transfer_array): Call transfer_array_inner.
> (transfer_derived): Call wrap_scalar_transfer.
> (data_transfer_init): Check for asynchronous I/O.
> Perform a wait operation on any pending asynchronous I/O
> if the data transfer is synchronous. Copy PDT and enqueue
> thread for data transfer.
> (st_read_done_worker): New function.
> (st_read_done): Enqueue transfer or call st_read_done_worker.
> (st_write_done_worker): New function.
> (st_write_done): Enqueue transfer or call st_read_done_worker.
> (st_wait): Document as no-op for compatibility reasons.
> (st_wait_async): New function.
> * io/unit.c (insert_unit): Use macros LOCK, UNLOCK and TRYLOCK;
> add NOTE where necessary.
> (get_gfc_unit): Likewise.
> (init_units): Likewise.
> (close_unit_1): Likewise. Call async_close if asynchronous.
> (close_unit): Use macros LOCK and UNLOCK.
> (finish_last_advance_record): Likewise.
> (newunit_alloc): Likewise.
> * io/unix.c (find_file): Likewise.
> (flush_all_units_1): Likewise.
> (flush_all_units): Likewise.
> * libgfortran.h (generate_error_common): Add prototype.
> * runtime/error.c: Include io.h and async.h.
> (generate_error_common): New function.
>
> 2018-08-02 Nicolas Koenig <koenigni@gcc.gnu.org>
> Thomas Koenig <tkoenig@gcc.gnu.org>
>
> PR fortran/25829
> * testsuite/libgomp.fortran/async_io_1.f90: New test.
> * testsuite/libgomp.fortran/async_io_2.f90: New test.
> * testsuite/libgomp.fortran/async_io_3.f90: New test.
> * testsuite/libgomp.fortran/async_io_4.f90: New test.
> * testsuite/libgomp.fortran/async_io_5.f90: New test.
> * testsuite/libgomp.fortran/async_io_6.f90: New test.
> * testsuite/libgomp.fortran/async_io_7.f90: New test.
^ permalink raw reply [flat|nested] 20+ messages in thread
* Re: Async I/O patch with compilation fix
2018-08-02 15:43 ` Christophe Lyon
@ 2018-08-02 17:08 ` Nicolas Koenig
2018-08-03 8:46 ` Christophe Lyon
0 siblings, 1 reply; 20+ messages in thread
From: Nicolas Koenig @ 2018-08-02 17:08 UTC (permalink / raw)
To: Christophe Lyon
Cc: Andre Simoes Dias Vieira, gcc Patches, fortran, Thomas Koenig,
Ulrich Weigand, David Edelsohn, clyon
[-- Attachment #1: Type: text/plain, Size: 5563 bytes --]
On Thu, Aug 02, 2018 at 05:42:46PM +0200, Christophe Lyon wrote:
> On Thu, 2 Aug 2018 at 13:35, Nicolas Koenig <koenigni@student.ethz.ch> wrote:
> >
> >
> > Hello everyone,
> >
> > Here is an updated version of the patch that hopefully fixes the compilation
> > problems by disabling async I/O if conditions are not supported by the target.
> >
> > I would appreciate if people could test it on systems on which it failed
> > before. As for the array_constructor_8.f90 failure reported in the PR, why
> > it fails is beyond me, it doesn't even use I/O. Maybe/Probably something
> > unrelated?
> >
>
> Hi,
> I'm probably missing something obvious, but after applying this patch
> on top of r263136, the builds fail while building libgfortran:
> /tmp/9271913_1.tmpdir/aci-gcc-fsf/sources/gcc-fsf/gccsrc/libgfortran/runtime/error.c:28:10:
> fatal error: async.h: No such file or directory
> #include "async.h"
> ^~~~~~~~~
> compilation terminated.
> make[3]: *** [error.lo] Error 1
>
Hi,
It wasn't you who missed something obvious. Typing `svn add` is hard.
Here is a version of the patch with the two new files.
Nicolas
> > Nicolas
> >
> >
> > 2018-08-02 Nicolas Koenig <koenigni@gcc.gnu.org>
> > Thomas Koenig <tkoenig@gcc.gnu.org>
> >
> > PR fortran/25829
> > * gfortran.texi: Add description of asynchronous I/O.
> > * trans-decl.c (gfc_finish_var_decl): Treat asynchronous variables
> > as volatile.
> > * trans-io.c (gfc_build_io_library_fndecls): Rename st_wait to
> > st_wait_async and change argument spec from ".X" to ".w".
> > (gfc_trans_wait): Pass ID argument via reference.
> >
> > 2018-08-02 Nicolas Koenig <koenigni@gcc.gnu.org>
> > Thomas Koenig <tkoenig@gcc.gnu.org>
> >
> > PR fortran/25829
> > * gfortran.dg/f2003_inquire_1.f03: Add write statement.
> > * gfortran.dg/f2003_io_1.f03: Add wait statement.
> >
> > 2018-08-02 Nicolas Koenig <koenigni@gcc.gnu.org>
> > Thomas Koenig <tkoenig@gcc.gnu.org>
> >
> > PR fortran/25829
> > * Makefile.am: Add async.c to gfor_io_src.
> > Add async.h to gfor_io_headers.
> > * Makefile.in: Regenerated.
> > * gfortran.map: Add _gfortran_st_wait_async.
> > * io/async.c: New file.
> > * io/async.h: New file.
> > * io/close.c: Include async.h.
> > (st_close): Call async_wait for an asynchronous unit.
> > * io/file_pos.c (st_backspace): Likewise.
> > (st_endfile): Likewise.
> > (st_rewind): Likewise.
> > (st_flush): Likewise.
> > * io/inquire.c: Add handling for asynchronous PENDING
> > and ID arguments.
> > * io/io.h (st_parameter_dt): Add async bit.
> > (st_parameter_wait): Correct.
> > (gfc_unit): Add au pointer.
> > (st_wait_async): Add prototype.
> > (transfer_array_inner): Likewise.
> > (st_write_done_worker): Likewise.
> > * io/open.c: Include async.h.
> > (new_unit): Initialize asynchronous unit.
> > * io/transfer.c (async_opt): New struct.
> > (wrap_scalar_transfer): New function.
> > (transfer_integer): Call wrap_scalar_transfer to do the work.
> > (transfer_real): Likewise.
> > (transfer_real_write): Likewise.
> > (transfer_character): Likewise.
> > (transfer_character_wide): Likewise.
> > (transfer_complex): Likewise.
> > (transfer_array_inner): New function.
> > (transfer_array): Call transfer_array_inner.
> > (transfer_derived): Call wrap_scalar_transfer.
> > (data_transfer_init): Check for asynchronous I/O.
> > Perform a wait operation on any pending asynchronous I/O
> > if the data transfer is synchronous. Copy PDT and enqueue
> > thread for data transfer.
> > (st_read_done_worker): New function.
> > (st_read_done): Enqueue transfer or call st_read_done_worker.
> > (st_write_done_worker): New function.
> > (st_write_done): Enqueue transfer or call st_read_done_worker.
> > (st_wait): Document as no-op for compatibility reasons.
> > (st_wait_async): New function.
> > * io/unit.c (insert_unit): Use macros LOCK, UNLOCK and TRYLOCK;
> > add NOTE where necessary.
> > (get_gfc_unit): Likewise.
> > (init_units): Likewise.
> > (close_unit_1): Likewise. Call async_close if asynchronous.
> > (close_unit): Use macros LOCK and UNLOCK.
> > (finish_last_advance_record): Likewise.
> > (newunit_alloc): Likewise.
> > * io/unix.c (find_file): Likewise.
> > (flush_all_units_1): Likewise.
> > (flush_all_units): Likewise.
> > * libgfortran.h (generate_error_common): Add prototype.
> > * runtime/error.c: Include io.h and async.h.
> > (generate_error_common): New function.
> >
> > 2018-08-02 Nicolas Koenig <koenigni@gcc.gnu.org>
> > Thomas Koenig <tkoenig@gcc.gnu.org>
> >
> > PR fortran/25829
> > * testsuite/libgomp.fortran/async_io_1.f90: New test.
> > * testsuite/libgomp.fortran/async_io_2.f90: New test.
> > * testsuite/libgomp.fortran/async_io_3.f90: New test.
> > * testsuite/libgomp.fortran/async_io_4.f90: New test.
> > * testsuite/libgomp.fortran/async_io_5.f90: New test.
> > * testsuite/libgomp.fortran/async_io_6.f90: New test.
> > * testsuite/libgomp.fortran/async_io_7.f90: New test.
[-- Attachment #2: pb.diff --]
[-- Type: text/x-diff, Size: 71179 bytes --]
Index: gcc/fortran/gfortran.texi
===================================================================
--- gcc/fortran/gfortran.texi (revision 263244)
+++ gcc/fortran/gfortran.texi (working copy)
@@ -879,8 +879,7 @@ than @code{(/.../)}. Type-specification for array
@item Extensions to the specification and initialization expressions,
including the support for intrinsics with real and complex arguments.
-@item Support for the asynchronous input/output syntax; however, the
-data transfer is currently always synchronously performed.
+@item Support for the asynchronous input/output.
@item
@cindex @code{FLUSH} statement
@@ -1183,6 +1182,7 @@ might in some way or another become visible to the
* Files opened without an explicit ACTION= specifier::
* File operations on symbolic links::
* File format of unformatted sequential files::
+* Asynchronous I/O::
@end menu
@@ -1486,6 +1486,20 @@ program main
end program main
@end smallexample
+@node Asynchronous I/O
+@section Asynchronous I/O
+@cindex input/output, asynchronous
+@cindex asynchronous I/O
+
+Asynchronous I/O is supported if the program is linked against the
+POSIX thread library. If that is not the case, all I/O is performed
+as synchronous.
+
+On some systems, such as Darwin or Solaris, the POSIX thread library
+is always linked in, so asynchronous I/O is always performed. On other
+sytems, such as Linux, it is necessary to specify @option{-pthread},
+@option{-lpthread} or @option{-fopenmp} during the linking step.
+
@c ---------------------------------------------------------------------
@c Extensions
@c ---------------------------------------------------------------------
Index: gcc/fortran/trans-decl.c
===================================================================
--- gcc/fortran/trans-decl.c (revision 263244)
+++ gcc/fortran/trans-decl.c (working copy)
@@ -698,7 +698,8 @@ gfc_finish_var_decl (tree decl, gfc_symbol * sym)
&& CLASS_DATA (sym)->ts.u.derived->attr.has_dtio_procs)))
TREE_STATIC (decl) = 1;
- if (sym->attr.volatile_)
+ /* Treat asynchronous variables the same as volatile, for now. */
+ if (sym->attr.volatile_ || sym->attr.asynchronous)
{
TREE_THIS_VOLATILE (decl) = 1;
TREE_SIDE_EFFECTS (decl) = 1;
Index: gcc/fortran/trans-io.c
===================================================================
--- gcc/fortran/trans-io.c (revision 263244)
+++ gcc/fortran/trans-io.c (working copy)
@@ -438,10 +438,9 @@ gfc_build_io_library_fndecls (void)
get_identifier (PREFIX("st_iolength")), ".w",
void_type_node, 1, dt_parm_type);
- /* TODO: Change when asynchronous I/O is implemented. */
parm_type = build_pointer_type (st_parameter[IOPARM_ptype_wait].type);
iocall[IOCALL_WAIT] = gfc_build_library_function_decl_with_spec (
- get_identifier (PREFIX("st_wait")), ".X",
+ get_identifier (PREFIX("st_wait_async")), ".w",
void_type_node, 1, parm_type);
parm_type = build_pointer_type (st_parameter[IOPARM_ptype_filepos].type);
@@ -1527,7 +1526,7 @@ gfc_trans_wait (gfc_code * code)
mask |= IOPARM_common_err;
if (p->id)
- mask |= set_parameter_value (&block, var, IOPARM_wait_id, p->id);
+ mask |= set_parameter_ref (&block, &post_block, var, IOPARM_wait_id, p->id);
set_parameter_const (&block, var, IOPARM_common_flags, mask);
Index: gcc/testsuite/gfortran.dg/f2003_inquire_1.f03
===================================================================
--- gcc/testsuite/gfortran.dg/f2003_inquire_1.f03 (revision 263244)
+++ gcc/testsuite/gfortran.dg/f2003_inquire_1.f03 (working copy)
@@ -7,10 +7,12 @@ logical :: vpending
open(10, file='mydata_f2003_inquire_1', asynchronous="yes", blank="null", &
& decimal="comma", encoding="utf-8", sign="plus")
+write (10,*, asynchronous="yes", id=vid) 'asdf'
+wait (10)
+
inquire(unit=10, round=sround, sign=ssign, size=vsize, id=vid, &
& pending=vpending, asynchronous=sasynchronous, decimal=sdecimal, &
& encoding=sencoding)
-
if (ssign.ne."PLUS") STOP 1
if (sasynchronous.ne."YES") STOP 2
if (sdecimal.ne."COMMA") STOP 3
Index: gcc/testsuite/gfortran.dg/f2003_io_1.f03
===================================================================
--- gcc/testsuite/gfortran.dg/f2003_io_1.f03 (revision 263244)
+++ gcc/testsuite/gfortran.dg/f2003_io_1.f03 (working copy)
@@ -13,6 +13,7 @@ open(10, file='mydata_f2003_io_1', asynchronous="y
write(10,'(10f8.3)', asynchronous="yes", decimal="comma", id=j) a
rewind(10)
read(10,'(10f8.3)', asynchronous="yes", decimal="comma", blank="zero") b
+wait(10)
if (any(b.ne.23.45)) STOP 1
c = 3.14
@@ -24,6 +25,7 @@ rewind(10)
write(10,'(10f8.3)', asynchronous="yes", decimal="point") a
rewind(10)
read(10,'(10f8.3)', asynchronous="yes", decimal="point") b
+wait (10)
if (any(b.ne.23.45)) STOP 3
wait(unit=10, err=25, iostat=istat, iomsg=msg, end=35, id=j)
Index: libgfortran/Makefile.am
===================================================================
--- libgfortran/Makefile.am (revision 263244)
+++ libgfortran/Makefile.am (working copy)
@@ -100,7 +100,8 @@ io/transfer128.c \
io/unit.c \
io/unix.c \
io/write.c \
-io/fbuf.c
+io/fbuf.c \
+io/async.c
endif
@@ -108,7 +109,8 @@ gfor_io_headers= \
io/io.h \
io/fbuf.h \
io/format.h \
-io/unix.h
+io/unix.h \
+io/async.h
gfor_helper_src= \
intrinsics/associated.c \
Index: libgfortran/Makefile.in
===================================================================
--- libgfortran/Makefile.in (revision 263244)
+++ libgfortran/Makefile.in (working copy)
@@ -70,7 +70,8 @@ target_triplet = @target@
@LIBGFOR_MINIMAL_FALSE@io/unit.c \
@LIBGFOR_MINIMAL_FALSE@io/unix.c \
@LIBGFOR_MINIMAL_FALSE@io/write.c \
-@LIBGFOR_MINIMAL_FALSE@io/fbuf.c
+@LIBGFOR_MINIMAL_FALSE@io/fbuf.c \
+@LIBGFOR_MINIMAL_FALSE@io/async.c
@LIBGFOR_MINIMAL_FALSE@am__append_3 = \
@LIBGFOR_MINIMAL_FALSE@intrinsics/access.c \
@@ -352,7 +353,7 @@ am__objects_47 = $(am__objects_4) $(am__objects_5)
@LIBGFOR_MINIMAL_FALSE@ inquire.lo intrinsics.lo list_read.lo \
@LIBGFOR_MINIMAL_FALSE@ lock.lo open.lo read.lo transfer.lo \
@LIBGFOR_MINIMAL_FALSE@ transfer128.lo unit.lo unix.lo write.lo \
-@LIBGFOR_MINIMAL_FALSE@ fbuf.lo
+@LIBGFOR_MINIMAL_FALSE@ fbuf.lo async.lo
am__objects_49 = size_from_kind.lo $(am__objects_48)
@LIBGFOR_MINIMAL_FALSE@am__objects_50 = access.lo c99_functions.lo \
@LIBGFOR_MINIMAL_FALSE@ chdir.lo chmod.lo clock.lo cpu_time.lo \
@@ -650,7 +651,8 @@ gfor_io_headers = \
io/io.h \
io/fbuf.h \
io/format.h \
-io/unix.h
+io/unix.h \
+io/async.h
gfor_helper_src = intrinsics/associated.c intrinsics/abort.c \
intrinsics/args.c intrinsics/cshift0.c intrinsics/eoshift0.c \
@@ -1551,6 +1553,7 @@ distclean-compile:
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/any_l8.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/args.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/associated.Plo@am__quote@
+@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/async.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/backtrace.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/bessel_r10.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/bessel_r16.Plo@am__quote@
@@ -5814,6 +5817,13 @@ fbuf.lo: io/fbuf.c
@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
@am__fastdepCC_FALSE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o fbuf.lo `test -f 'io/fbuf.c' || echo '$(srcdir)/'`io/fbuf.c
+async.lo: io/async.c
+@am__fastdepCC_TRUE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT async.lo -MD -MP -MF $(DEPDIR)/async.Tpo -c -o async.lo `test -f 'io/async.c' || echo '$(srcdir)/'`io/async.c
+@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/async.Tpo $(DEPDIR)/async.Plo
+@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='io/async.c' object='async.lo' libtool=yes @AMDEPBACKSLASH@
+@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
+@am__fastdepCC_FALSE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o async.lo `test -f 'io/async.c' || echo '$(srcdir)/'`io/async.c
+
associated.lo: intrinsics/associated.c
@am__fastdepCC_TRUE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT associated.lo -MD -MP -MF $(DEPDIR)/associated.Tpo -c -o associated.lo `test -f 'intrinsics/associated.c' || echo '$(srcdir)/'`intrinsics/associated.c
@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/associated.Tpo $(DEPDIR)/associated.Plo
Index: libgfortran/gfortran.map
===================================================================
--- libgfortran/gfortran.map (revision 263244)
+++ libgfortran/gfortran.map (working copy)
@@ -1483,3 +1483,8 @@ GFORTRAN_C99_8 {
y1f;
ynf;
};
+
+GFORTRAN_9 {
+ global:
+ _gfortran_st_wait_async;
+};
Index: libgfortran/io/async.c
===================================================================
--- libgfortran/io/async.c (nonexistent)
+++ libgfortran/io/async.c (working copy)
@@ -0,0 +1,569 @@
+/* Copyright (C) 2018 Free Software Foundation, Inc.
+ Contributed by Nicolas Koenig
+
+ This file is part of the GNU Fortran runtime library (libgfortran).
+
+ Libgfortran is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 3, or (at your option)
+ any later version.
+
+ Libgfortran is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ Under Section 7 of GPL version 3, you are granted additional
+ permissions described in the GCC Runtime Library Exception, version
+ 3.1, as published by the Free Software Foundation.
+
+ You should have received a copy of the GNU General Public License and
+ a copy of the GCC Runtime Library Exception along with this program;
+ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
+ <http://www.gnu.org/licenses/>. */
+
+#include "libgfortran.h"
+
+#define _GTHREAD_USE_COND_INIT_FUNC
+#include "../../libgcc/gthr.h"
+#include "io.h"
+#include "fbuf.h"
+#include "format.h"
+#include "unix.h"
+#include <string.h>
+#include <assert.h>
+
+#include <sys/types.h>
+
+#include "async.h"
+#if ASYNC_IO
+
+DEBUG_LINE (__thread const char *aio_prefix = MPREFIX);
+
+DEBUG_LINE (__gthread_mutex_t debug_queue_lock = __GTHREAD_MUTEX_INIT;)
+DEBUG_LINE (aio_lock_debug *aio_debug_head = NULL;)
+
+/* Current unit for asynchronous I/O. Needed for error reporting. */
+
+__thread gfc_unit *thread_unit = NULL;
+
+/* Queue entry for the asynchronous I/O entry. */
+typedef struct transfer_queue
+{
+ enum aio_do type;
+ struct transfer_queue *next;
+ struct st_parameter_dt *new_pdt;
+ transfer_args arg;
+ _Bool has_id;
+ int read_flag;
+} transfer_queue;
+
+struct error {
+ st_parameter_dt *dtp;
+ int id;
+};
+
+/* Helper function to exchange the old vs. a new PDT. */
+
+static void
+update_pdt (st_parameter_dt **old, st_parameter_dt *new) {
+ st_parameter_dt *temp;
+ NOTE ("Changing pdts, current_unit = %p", (void *) (new->u.p.current_unit));
+ temp = *old;
+ *old = new;
+ if (temp)
+ free (temp);
+}
+
+/* Destroy an adv_cond structure. */
+
+static void
+destroy_adv_cond (struct adv_cond *ac)
+{
+ T_ERROR (__gthread_mutex_destroy, &ac->lock);
+ T_ERROR (__gthread_cond_destroy, &ac->signal);
+}
+
+/* Function invoked as start routine for a new asynchronous I/O unit.
+ Contains the main loop for accepting requests and handling them. */
+
+static void *
+async_io (void *arg)
+{
+ DEBUG_LINE (aio_prefix = TPREFIX);
+ transfer_queue *ctq = NULL, *prev = NULL;
+ gfc_unit *u = (gfc_unit *) arg;
+ async_unit *au = u->au;
+ LOCK (&au->lock);
+ thread_unit = u;
+ au->thread = __gthread_self ();
+ while (true)
+ {
+ /* Main loop. At this point, au->lock is always held. */
+ WAIT_SIGNAL_MUTEX (&au->work, au->tail != NULL, &au->lock);
+ LOCK (&au->lock);
+ ctq = au->head;
+ prev = NULL;
+ /* Loop over the queue entries until they are finished. */
+ while (ctq)
+ {
+ if (prev)
+ free (prev);
+ prev = ctq;
+ if (!au->error.has_error)
+ {
+ UNLOCK (&au->lock);
+
+ switch (ctq->type)
+ {
+ case AIO_WRITE_DONE:
+ NOTE ("Finalizing write");
+ st_write_done_worker (au->pdt);
+ UNLOCK (&au->io_lock);
+ break;
+
+ case AIO_READ_DONE:
+ NOTE ("Finalizing read");
+ st_read_done_worker (au->pdt);
+ UNLOCK (&au->io_lock);
+ break;
+
+ case AIO_DATA_TRANSFER_INIT:
+ NOTE ("Data transfer init");
+ LOCK (&au->io_lock);
+ update_pdt (&au->pdt, ctq->new_pdt);
+ data_transfer_init_worker (au->pdt, ctq->read_flag);
+ break;
+
+ case AIO_TRANSFER_SCALAR:
+ NOTE ("Starting scalar transfer");
+ ctq->arg.scalar.transfer (au->pdt, ctq->arg.scalar.arg_bt,
+ ctq->arg.scalar.data,
+ ctq->arg.scalar.i,
+ ctq->arg.scalar.s1,
+ ctq->arg.scalar.s2);
+ break;
+
+ case AIO_TRANSFER_ARRAY:
+ NOTE ("Starting array transfer");
+ NOTE ("ctq->arg.array.desc = %p",
+ (void *) (ctq->arg.array.desc));
+ transfer_array_inner (au->pdt, ctq->arg.array.desc,
+ ctq->arg.array.kind,
+ ctq->arg.array.charlen);
+ free (ctq->arg.array.desc);
+ break;
+
+ case AIO_CLOSE:
+ NOTE ("Received AIO_CLOSE");
+ goto finish_thread;
+
+ default:
+ internal_error (NULL, "Invalid queue type");
+ break;
+ }
+ LOCK (&au->lock);
+ if (unlikely (au->error.has_error))
+ au->error.last_good_id = au->id.low - 1;
+ }
+ else
+ {
+ if (ctq->type == AIO_WRITE_DONE || ctq->type == AIO_READ_DONE)
+ {
+ UNLOCK (&au->io_lock);
+ }
+ else if (ctq->type == AIO_CLOSE)
+ {
+ NOTE ("Received AIO_CLOSE during error condition");
+ UNLOCK (&au->lock);
+ goto finish_thread;
+ }
+ }
+
+ NOTE ("Next ctq, current id: %d", au->id.low);
+ if (ctq->has_id && au->id.waiting == au->id.low++)
+ SIGNAL (&au->id.done);
+
+ ctq = ctq->next;
+ }
+ au->tail = NULL;
+ au->head = NULL;
+ au->empty = 1;
+ UNLOCK (&au->lock);
+ SIGNAL (&au->emptysignal);
+ LOCK (&au->lock);
+ }
+ finish_thread:
+ au->tail = NULL;
+ au->head = NULL;
+ au->empty = 1;
+ SIGNAL (&au->emptysignal);
+ free (ctq);
+ return NULL;
+}
+
+/* Free an asynchronous unit. */
+
+static void
+free_async_unit (async_unit *au)
+{
+ if (au->tail)
+ internal_error (NULL, "Trying to free nonempty asynchronous unit");
+
+ destroy_adv_cond (&au->work);
+ destroy_adv_cond (&au->emptysignal);
+ destroy_adv_cond (&au->id.done);
+ T_ERROR (__gthread_mutex_destroy, &au->lock);
+ free (au);
+}
+
+/* Initialize an adv_cond structure. */
+
+static void
+init_adv_cond (struct adv_cond *ac)
+{
+ ac->pending = 0;
+ __GTHREAD_MUTEX_INIT_FUNCTION (&ac->lock);
+ __gthread_cond_init_function (&ac->signal);
+}
+
+/* Initialize an asyncronous unit, returning zero on success,
+ nonzero on failure. It also sets u->au. */
+
+void
+init_async_unit (gfc_unit *u)
+{
+ async_unit *au;
+ if (!__gthread_active_p ())
+ {
+ u->au = NULL;
+ return;
+ }
+
+ au = (async_unit *) xmalloc (sizeof (async_unit));
+ u->au = au;
+ init_adv_cond (&au->work);
+ init_adv_cond (&au->emptysignal);
+ __GTHREAD_MUTEX_INIT_FUNCTION (&au->lock);
+ __GTHREAD_MUTEX_INIT_FUNCTION (&au->io_lock);
+ LOCK (&au->lock);
+ T_ERROR (__gthread_create, &au->thread, &async_io, (void *) u);
+ au->pdt = NULL;
+ au->head = NULL;
+ au->tail = NULL;
+ au->empty = true;
+ au->id.waiting = -1;
+ au->id.low = 0;
+ au->id.high = 0;
+ au->error.fatal_error = 0;
+ au->error.has_error = 0;
+ au->error.last_good_id = 0;
+ init_adv_cond (&au->id.done);
+ UNLOCK (&au->lock);
+}
+
+/* Enqueue a transfer statement. */
+
+void
+enqueue_transfer (async_unit *au, transfer_args *arg, enum aio_do type)
+{
+ transfer_queue *tq = calloc (sizeof (transfer_queue), 1);
+ tq->arg = *arg;
+ tq->type = type;
+ tq->has_id = 0;
+ LOCK (&au->lock);
+ if (!au->tail)
+ au->head = tq;
+ else
+ au->tail->next = tq;
+ au->tail = tq;
+ REVOKE_SIGNAL (&(au->emptysignal));
+ au->empty = false;
+ UNLOCK (&au->lock);
+ SIGNAL (&au->work);
+}
+
+/* Enqueue an st_write_done or st_read_done which contains an ID. */
+
+int
+enqueue_done_id (async_unit *au, enum aio_do type)
+{
+ int ret;
+ transfer_queue *tq = calloc (sizeof (transfer_queue), 1);
+
+ tq->type = type;
+ tq->has_id = 1;
+ LOCK (&au->lock);
+ if (!au->tail)
+ au->head = tq;
+ else
+ au->tail->next = tq;
+ au->tail = tq;
+ REVOKE_SIGNAL (&(au->emptysignal));
+ au->empty = false;
+ ret = au->id.high++;
+ NOTE ("Enqueue id: %d", ret);
+ UNLOCK (&au->lock);
+ SIGNAL (&au->work);
+ return ret;
+}
+
+/* Enqueue an st_write_done or st_read_done without an ID. */
+
+void
+enqueue_done (async_unit *au, enum aio_do type)
+{
+ transfer_queue *tq = calloc (sizeof (transfer_queue), 1);
+ tq->type = type;
+ tq->has_id = 0;
+ LOCK (&au->lock);
+ if (!au->tail)
+ au->head = tq;
+ else
+ au->tail->next = tq;
+ au->tail = tq;
+ REVOKE_SIGNAL (&(au->emptysignal));
+ au->empty = false;
+ UNLOCK (&au->lock);
+ SIGNAL (&au->work);
+}
+
+/* Enqueue a CLOSE statement. */
+
+void
+enqueue_close (async_unit *au)
+{
+ transfer_queue *tq = calloc (sizeof (transfer_queue), 1);
+
+ tq->type = AIO_CLOSE;
+ LOCK (&au->lock);
+ if (!au->tail)
+ au->head = tq;
+ else
+ au->tail->next = tq;
+ au->tail = tq;
+ REVOKE_SIGNAL (&(au->emptysignal));
+ au->empty = false;
+ UNLOCK (&au->lock);
+ SIGNAL (&au->work);
+}
+
+/* The asynchronous unit keeps the currently active PDT around.
+ This function changes that to the current one. */
+
+void
+enqueue_data_transfer_init (async_unit *au, st_parameter_dt *dt, int read_flag)
+{
+ st_parameter_dt *new = xmalloc (sizeof (st_parameter_dt));
+ transfer_queue *tq = xmalloc (sizeof (transfer_queue));
+
+ memcpy ((void *) new, (void *) dt, sizeof (st_parameter_dt));
+
+ NOTE ("dt->internal_unit_desc = %p", dt->internal_unit_desc);
+ NOTE ("common.flags & mask = %d", dt->common.flags & IOPARM_LIBRETURN_MASK);
+ tq->next = NULL;
+ tq->type = AIO_DATA_TRANSFER_INIT;
+ tq->read_flag = read_flag;
+ tq->has_id = 0;
+ tq->new_pdt = new;
+ LOCK (&au->lock);
+
+ if (!au->tail)
+ au->head = tq;
+ else
+ au->tail->next = tq;
+ au->tail = tq;
+ REVOKE_SIGNAL (&(au->emptysignal));
+ au->empty = 0;
+ UNLOCK (&au->lock);
+ SIGNAL (&au->work);
+}
+
+/* Collect the errors that may have happened asynchronously. Return true if
+ an error has been encountered. */
+
+bool
+collect_async_errors (st_parameter_common *cmp, async_unit *au)
+{
+ bool has_error = au->error.has_error;
+
+ if (has_error)
+ {
+ if (generate_error_common (cmp, au->error.family, au->error.message))
+ {
+ au->error.has_error = 0;
+ au->error.cmp = NULL;
+ }
+ else
+ {
+ /* The program will exit later. */
+ au->error.fatal_error = true;
+ }
+ }
+ return has_error;
+}
+
+/* Perform a wait operation on an asynchronous unit with an ID specified,
+ which means collecting the errors that may have happened asynchronously.
+ Return true if an error has been encountered. */
+
+bool
+async_wait_id (st_parameter_common *cmp, async_unit *au, int i)
+{
+ bool ret;
+
+ if (au == NULL)
+ return false;
+
+ if (cmp == NULL)
+ cmp = au->error.cmp;
+
+ if (au->error.has_error)
+ {
+ if (i <= au->error.last_good_id)
+ return false;
+
+ return collect_async_errors (cmp, au);
+ }
+
+ LOCK (&au->lock);
+ NOTE ("Waiting for id %d", i);
+ if (au->id.waiting < i)
+ au->id.waiting = i;
+ UNLOCK (&au->lock);
+ SIGNAL (&(au->work));
+ LOCK (&au->lock);
+ WAIT_SIGNAL_MUTEX (&(au->id.done),
+ (au->id.low >= au->id.waiting || au->empty), &au->lock);
+ LOCK (&au->lock);
+ ret = collect_async_errors (cmp, au);
+ UNLOCK (&au->lock);
+ return ret;
+}
+
+/* Perform a wait operation an an asynchronous unit without an ID. */
+
+bool
+async_wait (st_parameter_common *cmp, async_unit *au)
+{
+ bool ret;
+
+ if (au == NULL)
+ return false;
+
+ if (cmp == NULL)
+ cmp = au->error.cmp;
+
+ SIGNAL (&(au->work));
+ LOCK (&(au->lock));
+
+ if (au->empty)
+ {
+ ret = collect_async_errors (cmp, au);
+ UNLOCK (&au->lock);
+ return ret;
+ }
+
+ WAIT_SIGNAL_MUTEX (&(au->emptysignal), (au->empty), &au->lock);
+ ret = collect_async_errors (cmp, au);
+ return ret;
+}
+
+/* Close an asynchronous unit. */
+
+void
+async_close (async_unit *au)
+{
+ if (au == NULL)
+ return;
+
+ NOTE ("Closing async unit");
+ enqueue_close (au);
+ T_ERROR (__gthread_join, au->thread, NULL);
+ free_async_unit (au);
+}
+
+#else
+
+/* Only set u->au to NULL so no async I/O will happen. */
+
+void
+init_async_unit (gfc_unit *u)
+{
+ u->au = NULL;
+ return;
+}
+
+/* Do-nothing function, which will not be called. */
+
+void
+enqueue_transfer (async_unit *au, transfer_args *arg, enum aio_do type)
+{
+ return;
+}
+
+/* Do-nothing function, which will not be called. */
+
+int
+enqueue_done_id (async_unit *au, enum aio_do type)
+{
+ return 0;
+}
+
+/* Do-nothing function, which will not be called. */
+
+void
+enqueue_done (async_unit *au, enum aio_do type)
+{
+ return;
+}
+
+/* Do-nothing function, which will not be called. */
+
+void
+enqueue_close (async_unit *au)
+{
+ return;
+}
+
+/* Do-nothing function, which will not be called. */
+
+void
+enqueue_data_transfer_init (async_unit *au, st_parameter_dt *dt, int read_flag)
+{
+ return;
+}
+
+/* Do-nothing function, which will not be called. */
+
+bool
+collect_async_errors (st_parameter_common *cmp, async_unit *au)
+{
+ return false;
+}
+
+/* Do-nothing function, which will not be called. */
+
+bool
+async_wait_id (st_parameter_common *cmp, async_unit *au, int i)
+{
+ return false;
+}
+
+/* Do-nothing function, which will not be called. */
+
+bool
+async_wait (st_parameter_common *cmp, async_unit *au)
+{
+ return false;
+}
+
+/* Do-nothing function, which will not be called. */
+
+void
+async_close (async_unit *au)
+{
+ return;
+}
+
+#endif
Index: libgfortran/io/async.h
===================================================================
--- libgfortran/io/async.h (nonexistent)
+++ libgfortran/io/async.h (working copy)
@@ -0,0 +1,400 @@
+/* Copyright (C) 2018 Free Software Foundation, Inc.
+ Contributed by Nicolas Koenig
+
+ This file is part of the GNU Fortran runtime library (libgfortran).
+
+ Libgfortran is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 3, or (at your option)
+ any later version.
+
+ Libgfortran is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ Under Section 7 of GPL version 3, you are granted additional
+ permissions described in the GCC Runtime Library Exception, version
+ 3.1, as published by the Free Software Foundation.
+
+ You should have received a copy of the GNU General Public License and
+ a copy of the GCC Runtime Library Exception along with this program;
+ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
+ <http://www.gnu.org/licenses/>. */
+
+#ifndef ASYNC_H
+#define ASYNC_H
+
+/* Async I/O will not work on targets which do not support
+ __gthread_cond_t and __gthread_equal / __gthread_self. Check
+ this. */
+
+#if defined(__GTHREAD_HAS_COND) && defined(__GTHREADS_CXX0X)
+#define ASYNC_IO 1
+#else
+#define ASYNC_IO 0
+#endif
+
+/* Defining DEBUG_ASYNC will enable somewhat verbose debugging
+ output for async I/O. */
+
+#define DEBUG_ASYNC
+#undef DEBUG_ASYNC
+
+#ifdef DEBUG_ASYNC
+
+/* Define this if you want to use ANSI color escape sequences in your
+ debugging output. */
+
+#define DEBUG_COLOR
+
+#ifdef DEBUG_COLOR
+#define MPREFIX "\033[30;46mM:\033[0m "
+#define TPREFIX "\033[37;44mT:\033[0m "
+#define RPREFIX "\033[37;41mR:\033[0m "
+#define DEBUG_RED "\033[31m"
+#define DEBUG_ORANGE "\033[33m"
+#define DEBUG_GREEN "\033[32m"
+#define DEBUG_DARKRED "\033[31;2m"
+#define DEBUG_PURPLE "\033[35m"
+#define DEBUG_NORM "\033[0m"
+#define DEBUG_REVERSE_RED "\033[41;37m"
+#define DEBUG_BLUE "\033[34m"
+
+#else
+
+#define MPREFIX "M: "
+#define TPREFIX "T: "
+#define RPREFIX ""
+#define DEBUG_RED ""
+#define DEBUG_ORANGE ""
+#define DEBUG_GREEN ""
+#define DEBUG_DARKRED ""
+#define DEBUG_PURPLE ""
+#define DEBUG_NORM ""
+#define DEBUG_REVERSE_RED ""
+#define DEBUG_BLUE ""
+
+#endif
+
+#define DEBUG_PRINTF(...) fprintf (stderr,__VA_ARGS__)
+
+#define IN_DEBUG_QUEUE(mutex) ({ \
+ __label__ end; \
+ aio_lock_debug *curr = aio_debug_head; \
+ while (curr) { \
+ if (curr->m == mutex) { \
+ goto end; \
+ } \
+ curr = curr->next; \
+ } \
+ end:; \
+ curr; \
+ })
+
+#define TAIL_DEBUG_QUEUE ({ \
+ aio_lock_debug *curr = aio_debug_head; \
+ while (curr && curr->next) { \
+ curr = curr->next; \
+ } \
+ curr; \
+ })
+
+#define CHECK_LOCK(mutex, status) do { \
+ aio_lock_debug *curr; \
+ INTERN_LOCK (&debug_queue_lock); \
+ if (__gthread_mutex_trylock (mutex)) { \
+ 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 { \
+ __gthread_mutex_unlock (mutex); \
+ sprintf (status, DEBUG_GREEN "unlocked" DEBUG_NORM); \
+ } \
+ INTERN_UNLOCK (&debug_queue_lock); \
+ }while (0)
+
+#define T_ERROR(func, ...) do { \
+ int t_error_temp; \
+ t_error_temp = func(__VA_ARGS__); \
+ if (t_error_temp) \
+ ERROR (t_error_temp, "args: " #__VA_ARGS__ "\n"); \
+ } while (0)
+
+#define NOTE(str, ...) do{ \
+ char note_str[200]; \
+ sprintf (note_str, "%s" DEBUG_PURPLE "NOTE: " DEBUG_NORM str, aio_prefix, ##__VA_ARGS__); \
+ DEBUG_PRINTF ("%-90s %20s():%-5d\n", note_str, __FUNCTION__, __LINE__); \
+ }while (0);
+
+#define ERROR(errnum, str, ...) do{ \
+ char note_str[200]; \
+ sprintf (note_str, "%s" DEBUG_REVERSE_RED "ERROR:" DEBUG_NORM " [%d] " str, aio_prefix, \
+ errnum, ##__VA_ARGS__); \
+ DEBUG_PRINTF ("%-68s %s():%-5d\n", note_str, __FUNCTION__, __LINE__); \
+ }while (0)
+
+#define MUTEX_DEBUG_ADD(mutex) do { \
+ aio_lock_debug *n; \
+ n = malloc (sizeof(aio_lock_debug)); \
+ n->prev = TAIL_DEBUG_QUEUE; \
+ if (n->prev) \
+ n->prev->next = n; \
+ n->next = NULL; \
+ n->line = __LINE__; \
+ n->func = __FUNCTION__; \
+ n->m = mutex; \
+ if (!aio_debug_head) { \
+ aio_debug_head = n; \
+ } \
+ } while (0)
+
+#define UNLOCK(mutex) do { \
+ aio_lock_debug *curr; \
+ DEBUG_PRINTF ("%s%-75s %20s():%-5d %18p\n", aio_prefix, DEBUG_GREEN "UNLOCK: " DEBUG_NORM #mutex, \
+ __FUNCTION__, __LINE__, (void *) mutex); \
+ INTERN_LOCK (&debug_queue_lock); \
+ curr = IN_DEBUG_QUEUE (mutex); \
+ if (curr) \
+ { \
+ if (curr->prev) \
+ curr->prev->next = curr->next; \
+ if (curr->next) { \
+ curr->next->prev = curr->prev; \
+ if (curr == aio_debug_head) \
+ aio_debug_head = curr->next; \
+ } else { \
+ if (curr == aio_debug_head) \
+ aio_debug_head = NULL; \
+ } \
+ free (curr); \
+ } \
+ INTERN_UNLOCK (&debug_queue_lock); \
+ INTERN_UNLOCK (mutex); \
+ }while (0)
+
+#define TRYLOCK(mutex) ({ \
+ char status[200]; \
+ int res; \
+ aio_lock_debug *curr; \
+ 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 #mutex, status, __FUNCTION__, __LINE__, \
+ (void *) mutex); \
+ INTERN_UNLOCK (&debug_queue_lock); \
+ res; \
+ })
+
+#define LOCK(mutex) do { \
+ char status[200]; \
+ CHECK_LOCK (mutex, status); \
+ DEBUG_PRINTF ("%s%-42s prev: %-35s %20s():%-5d %18p\n", aio_prefix, \
+ DEBUG_RED "LOCK: " DEBUG_NORM #mutex, status, __FUNCTION__, __LINE__, (void *) mutex); \
+ INTERN_LOCK (mutex); \
+ INTERN_LOCK (&debug_queue_lock); \
+ MUTEX_DEBUG_ADD (mutex); \
+ INTERN_UNLOCK (&debug_queue_lock); \
+ DEBUG_PRINTF ("%s" DEBUG_RED "ACQ:" DEBUG_NORM " %-30s %78p\n", aio_prefix, #mutex, mutex); \
+ } while (0)
+
+#define DEBUG_LINE(...) __VA_ARGS__
+
+#else
+#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)
+#define UNLOCK(mutex) INTERN_UNLOCK (mutex)
+#define TRYLOCK(mutex) (__gthread_mutex_trylock (mutex))
+#endif
+
+#define INTERN_LOCK(mutex) T_ERROR (__gthread_mutex_lock, mutex);
+
+#define INTERN_UNLOCK(mutex) T_ERROR (__gthread_mutex_unlock, mutex);
+
+#if ASYNC_IO
+
+#define SIGNAL(advcond) do{ \
+ INTERN_LOCK (&(advcond)->lock); \
+ (advcond)->pending = 1; \
+ DEBUG_PRINTF ("%s%-75s %20s():%-5d %18p\n", aio_prefix, DEBUG_ORANGE "SIGNAL: " DEBUG_NORM \
+ #advcond, __FUNCTION__, __LINE__, (void *) advcond); \
+ T_ERROR (__gthread_cond_broadcast, &(advcond)->signal); \
+ INTERN_UNLOCK (&(advcond)->lock); \
+ } while (0)
+
+#define WAIT_SIGNAL_MUTEX(advcond, condition, mutex) do{ \
+ __label__ finish; \
+ INTERN_LOCK (&((advcond)->lock)); \
+ DEBUG_PRINTF ("%s%-75s %20s():%-5d %18p\n", aio_prefix, DEBUG_BLUE "WAITING: " DEBUG_NORM \
+ #advcond, __FUNCTION__, __LINE__, (void *) advcond); \
+ if ((advcond)->pending || (condition)){ \
+ UNLOCK (mutex); \
+ goto finish; \
+ } \
+ UNLOCK (mutex); \
+ while (!__gthread_cond_wait(&(advcond)->signal, &(advcond)->lock)) { \
+ { int cond; \
+ LOCK (mutex); cond = condition; UNLOCK (mutex); \
+ if (cond){ \
+ DEBUG_PRINTF ("%s%-75s %20s():%-5d %18p\n", aio_prefix, DEBUG_ORANGE "REC: " DEBUG_NORM \
+ #advcond, __FUNCTION__, __LINE__, (void *)advcond); \
+ break; \
+ } \
+ } \
+ } \
+ finish: \
+ (advcond)->pending = 0; \
+ INTERN_UNLOCK (&((advcond)->lock)); \
+ } while (0)
+
+#define REVOKE_SIGNAL(advcond) do{ \
+ INTERN_LOCK (&(advcond)->lock); \
+ (advcond)->pending = 0; \
+ INTERN_UNLOCK (&(advcond)->lock); \
+ } while (0)
+
+#else
+
+#define SIGNAL(advcond) do{} while(0)
+#define WAIT_SIGNAL_MUTEX(advcond, condition, mutex) do{} while(0)
+#define REVOKE_SIGNAL(advcond) do{} while(0)
+
+#endif
+
+#if ASYNC_IO
+DEBUG_LINE (extern __thread const char *aio_prefix);
+
+DEBUG_LINE (typedef struct aio_lock_debug{
+ __gthread_mutex_t *m;
+ int line;
+ const char *func;
+ struct aio_lock_debug *next;
+ struct aio_lock_debug *prev;
+} aio_lock_debug;)
+
+DEBUG_LINE (extern aio_lock_debug *aio_debug_head;)
+DEBUG_LINE (extern __gthread_mutex_t debug_queue_lock;)
+
+/* Thread - local storage of the current unit we are looking at. Needed for
+ error reporting. */
+
+extern __thread gfc_unit *thread_unit;
+#endif
+
+enum aio_do {
+ AIO_INVALID = 0,
+ AIO_DATA_TRANSFER_INIT,
+ AIO_TRANSFER_SCALAR,
+ AIO_TRANSFER_ARRAY,
+ AIO_WRITE_DONE,
+ AIO_READ_DONE,
+ AIO_CLOSE
+};
+
+typedef union transfer_args
+{
+ struct
+ {
+ void (*transfer) (struct st_parameter_dt *, bt, void *, int, size_t, size_t);
+ bt arg_bt;
+ void *data;
+ int i;
+ size_t s1;
+ size_t s2;
+ } scalar;
+ struct
+ {
+ gfc_array_char *desc;
+ int kind;
+ gfc_charlen_type charlen;
+ } array;
+} transfer_args;
+
+struct adv_cond
+{
+ int pending;
+ __gthread_mutex_t lock;
+ __gthread_cond_t signal;
+};
+
+typedef struct async_unit
+{
+ pthread_mutex_t lock; /* Lock for manipulating the queue structure. */
+ pthread_mutex_t io_lock; /* Lock for doing actual I/O. */
+ struct adv_cond work;
+ struct adv_cond emptysignal;
+ struct st_parameter_dt *pdt;
+ pthread_t thread;
+ struct transfer_queue *head;
+ struct transfer_queue *tail;
+ struct
+ {
+ int waiting;
+ int low;
+ int high;
+ struct adv_cond done;
+ } id;
+
+ bool empty;
+
+ struct {
+ const char *message;
+ st_parameter_common *cmp;
+ bool has_error;
+ int last_good_id;
+ int family;
+ bool fatal_error;
+ } error;
+
+} async_unit;
+
+void init_async_unit (gfc_unit *);
+internal_proto (init_async_unit);
+
+bool async_wait (st_parameter_common *, async_unit *);
+internal_proto (async_wait);
+
+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);
+
+void async_close (async_unit *);
+internal_proto (async_close);
+
+void enqueue_transfer (async_unit * au, transfer_args * arg, enum aio_do);
+internal_proto (enqueue_transfer);
+
+void enqueue_done (async_unit *, enum aio_do type);
+internal_proto (enqueue_done);
+
+int enqueue_done_id (async_unit *, enum aio_do type);
+internal_proto (enqueue_done_id);
+
+void enqueue_init (async_unit *);
+internal_proto (enqueue_init);
+
+void enqueue_data_transfer_init (async_unit *, st_parameter_dt *, int);
+internal_proto (enqueue_data_transfer_init);
+
+void enqueue_close (async_unit *);
+internal_proto (enqueue_close);
+
+#endif
Index: libgfortran/io/close.c
===================================================================
--- libgfortran/io/close.c (revision 263244)
+++ libgfortran/io/close.c (working copy)
@@ -24,6 +24,7 @@ see the files COPYING3 and COPYING.RUNTIME respect
#include "io.h"
#include "unix.h"
+#include "async.h"
#include <limits.h>
typedef enum
@@ -57,6 +58,15 @@ st_close (st_parameter_close *clp)
find_option (&clp->common, clp->status, clp->status_len,
status_opt, "Bad STATUS parameter in CLOSE statement");
+ u = find_unit (clp->common.unit);
+
+ if (ASYNC_IO && u && u->au)
+ if (async_wait (&(clp->common), u->au))
+ {
+ library_end ();
+ return;
+ }
+
if ((clp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
{
library_end ();
@@ -63,7 +73,6 @@ st_close (st_parameter_close *clp)
return;
}
- u = find_unit (clp->common.unit);
if (u != NULL)
{
if (close_share (u) < 0)
Index: libgfortran/io/file_pos.c
===================================================================
--- libgfortran/io/file_pos.c (revision 263244)
+++ libgfortran/io/file_pos.c (working copy)
@@ -25,6 +25,7 @@ see the files COPYING3 and COPYING.RUNTIME respect
#include "io.h"
#include "fbuf.h"
#include "unix.h"
+#include "async.h"
#include <string.h>
/* file_pos.c-- Implement the file positioning statements, i.e. BACKSPACE,
@@ -187,6 +188,7 @@ void
st_backspace (st_parameter_filepos *fpp)
{
gfc_unit *u;
+ bool needs_unlock = false;
library_start (&fpp->common);
@@ -214,6 +216,17 @@ st_backspace (st_parameter_filepos *fpp)
goto done;
}
+ if (ASYNC_IO && u->au)
+ {
+ if (async_wait (&(fpp->common), u->au))
+ return;
+ else
+ {
+ needs_unlock = true;
+ LOCK (&u->au->io_lock);
+ }
+ }
+
/* Make sure format buffer is flushed and reset. */
if (u->flags.form == FORM_FORMATTED)
{
@@ -267,8 +280,13 @@ st_backspace (st_parameter_filepos *fpp)
done:
if (u != NULL)
- unlock_unit (u);
+ {
+ unlock_unit (u);
+ if (ASYNC_IO && u->au && needs_unlock)
+ UNLOCK (&u->au->io_lock);
+ }
+
library_end ();
}
@@ -280,6 +298,7 @@ void
st_endfile (st_parameter_filepos *fpp)
{
gfc_unit *u;
+ bool needs_unlock = false;
library_start (&fpp->common);
@@ -294,6 +313,17 @@ st_endfile (st_parameter_filepos *fpp)
goto done;
}
+ if (ASYNC_IO && u->au)
+ {
+ if (async_wait (&(fpp->common), u->au))
+ return;
+ else
+ {
+ needs_unlock = true;
+ LOCK (&u->au->io_lock);
+ }
+ }
+
if (u->flags.access == ACCESS_SEQUENTIAL
&& u->endfile == AFTER_ENDFILE)
{
@@ -376,9 +406,12 @@ st_endfile (st_parameter_filepos *fpp)
}
}
- done:
- unlock_unit (u);
+ done:
+ if (ASYNC_IO && u->au && needs_unlock)
+ UNLOCK (&u->au->io_lock);
+ unlock_unit (u);
+
library_end ();
}
@@ -390,6 +423,7 @@ void
st_rewind (st_parameter_filepos *fpp)
{
gfc_unit *u;
+ bool needs_unlock = true;
library_start (&fpp->common);
@@ -401,6 +435,17 @@ st_rewind (st_parameter_filepos *fpp)
"Cannot REWIND a file opened for DIRECT access");
else
{
+ if (ASYNC_IO && u->au)
+ {
+ if (async_wait (&(fpp->common), u->au))
+ return;
+ else
+ {
+ needs_unlock = true;
+ LOCK (&u->au->io_lock);
+ }
+ }
+
/* If there are previously written bytes from a write with ADVANCE="no",
add a record marker before performing the ENDFILE. */
@@ -436,6 +481,10 @@ st_rewind (st_parameter_filepos *fpp)
}
/* Update position for INQUIRE. */
u->flags.position = POSITION_REWIND;
+
+ if (ASYNC_IO && u->au && needs_unlock)
+ UNLOCK (&u->au->io_lock);
+
unlock_unit (u);
}
@@ -450,6 +499,7 @@ void
st_flush (st_parameter_filepos *fpp)
{
gfc_unit *u;
+ bool needs_unlock = false;
library_start (&fpp->common);
@@ -456,6 +506,17 @@ st_flush (st_parameter_filepos *fpp)
u = find_unit (fpp->common.unit);
if (u != NULL)
{
+ if (ASYNC_IO && u->au)
+ {
+ if (async_wait (&(fpp->common), u->au))
+ return;
+ else
+ {
+ needs_unlock = true;
+ LOCK (&u->au->io_lock);
+ }
+ }
+
/* Make sure format buffer is flushed. */
if (u->flags.form == FORM_FORMATTED)
fbuf_flush (u, u->mode);
@@ -469,5 +530,8 @@ st_flush (st_parameter_filepos *fpp)
generate_error (&fpp->common, LIBERROR_BAD_OPTION,
"Specified UNIT in FLUSH is not connected");
+ if (needs_unlock)
+ UNLOCK (&u->au->io_lock);
+
library_end ();
}
Index: libgfortran/io/inquire.c
===================================================================
--- libgfortran/io/inquire.c (revision 263244)
+++ libgfortran/io/inquire.c (working copy)
@@ -26,6 +26,7 @@ see the files COPYING3 and COPYING.RUNTIME respect
/* Implement the non-IOLENGTH variant of the INQUIRY statement */
#include "io.h"
+#include "async.h"
#include "unix.h"
#include <string.h>
@@ -281,12 +282,6 @@ inquire_via_unit (st_parameter_inquire *iqp, gfc_u
{
GFC_INTEGER_4 cf2 = iqp->flags2;
- if ((cf2 & IOPARM_INQUIRE_HAS_PENDING) != 0)
- *iqp->pending = 0;
-
- if ((cf2 & IOPARM_INQUIRE_HAS_ID) != 0)
- *iqp->id = 0;
-
if ((cf2 & IOPARM_INQUIRE_HAS_ENCODING) != 0)
{
if (u == NULL || u->flags.form != FORM_FORMATTED)
@@ -332,21 +327,43 @@ inquire_via_unit (st_parameter_inquire *iqp, gfc_u
if (u == NULL)
p = undefined;
else
- switch (u->flags.async)
{
- case ASYNC_YES:
- p = yes;
- break;
- case ASYNC_NO:
- p = no;
- break;
- default:
- internal_error (&iqp->common, "inquire_via_unit(): Bad async");
+ switch (u->flags.async)
+ {
+ case ASYNC_YES:
+ p = yes;
+ break;
+ case ASYNC_NO:
+ p = no;
+ break;
+ default:
+ internal_error (&iqp->common, "inquire_via_unit(): Bad async");
+ }
}
-
cf_strcpy (iqp->asynchronous, iqp->asynchronous_len, p);
}
+ if ((cf2 & IOPARM_INQUIRE_HAS_PENDING) != 0)
+ {
+ if (!ASYNC_IO || u->au == NULL)
+ *(iqp->pending) = 0;
+ else
+ {
+ LOCK (&(u->au->lock));
+ if ((cf2 & IOPARM_INQUIRE_HAS_ID) != 0)
+ {
+ int id;
+ id = *(iqp->id);
+ *(iqp->pending) = id > u->au->id.low;
+ }
+ else
+ {
+ *(iqp->pending) = ! u->au->empty;
+ }
+ UNLOCK (&(u->au->lock));
+ }
+ }
+
if ((cf2 & IOPARM_INQUIRE_HAS_SIGN) != 0)
{
if (u == NULL)
Index: libgfortran/io/io.h
===================================================================
--- libgfortran/io/io.h (revision 263244)
+++ libgfortran/io/io.h (working copy)
@@ -531,7 +531,9 @@ typedef struct st_parameter_dt
/* A flag used to identify when a non-standard expanded namelist read
has occurred. */
unsigned expanded_read : 1;
- /* 13 unused bits. */
+ /* Flag to indicate if the statement has async="YES". */
+ unsigned async : 1;
+ /* 12 unused bits. */
int child_saved_iostat;
int nml_delim;
@@ -590,7 +592,7 @@ extern char check_st_parameter_dt[sizeof (((st_par
typedef struct
{
st_parameter_common common;
- CHARACTER1 (id);
+ GFC_INTEGER_4 *id;
}
st_parameter_wait;
@@ -659,6 +661,9 @@ typedef struct gfc_unit
int continued;
+ /* Contains the pointer to the async unit. */
+ struct async_unit *au;
+
__gthread_mutex_t lock;
/* Number of threads waiting to acquire this unit's lock.
When non-zero, close_unit doesn't only removes the unit
@@ -815,11 +820,18 @@ extern void next_record (st_parameter_dt *, int);
internal_proto(next_record);
extern void st_wait (st_parameter_wait *);
-export_proto(st_wait);
+export_proto (st_wait);
+extern void st_wait_async (st_parameter_wait *);
+export_proto (st_wait_async);
+
extern void hit_eof (st_parameter_dt *);
internal_proto(hit_eof);
+extern void transfer_array_inner (st_parameter_dt *, gfc_array_char *, int,
+ gfc_charlen_type);
+internal_proto (transfer_array_inner);
+
/* read.c */
extern void set_integer (void *, GFC_INTEGER_LARGEST, int);
@@ -988,3 +1000,14 @@ memset4 (gfc_char4_t *p, gfc_char4_t c, int k)
#endif
+extern void
+st_write_done_worker (st_parameter_dt *);
+internal_proto (st_write_done_worker);
+
+extern void
+st_read_done_worker (st_parameter_dt *);
+internal_proto (st_read_done_worker);
+
+extern void
+data_transfer_init_worker (st_parameter_dt *, int);
+internal_proto (data_transfer_init_worker);
Index: libgfortran/io/open.c
===================================================================
--- libgfortran/io/open.c (revision 263244)
+++ libgfortran/io/open.c (working copy)
@@ -26,6 +26,7 @@ see the files COPYING3 and COPYING.RUNTIME respect
#include "io.h"
#include "fbuf.h"
#include "unix.h"
+#include "async.h"
#ifdef HAVE_UNISTD_H
#include <unistd.h>
@@ -651,8 +652,12 @@ new_unit (st_parameter_open *opp, gfc_unit *u, uni
else
u->fbuf = NULL;
-
-
+ /* Check if asynchrounous. */
+ if (flags->async == ASYNC_YES)
+ init_async_unit (u);
+ else
+ u->au = NULL;
+
return u;
cleanup:
Index: libgfortran/io/read.c
===================================================================
--- libgfortran/io/read.c (revision 263244)
+++ libgfortran/io/read.c (working copy)
@@ -30,6 +30,7 @@ see the files COPYING3 and COPYING.RUNTIME respect
#include <string.h>
#include <ctype.h>
#include <assert.h>
+#include "async.h"
typedef unsigned char uchar;
@@ -42,6 +43,7 @@ typedef unsigned char uchar;
void
set_integer (void *dest, GFC_INTEGER_LARGEST value, int length)
{
+ NOTE ("set_integer: %lld %p", (long long int) value, dest);
switch (length)
{
#ifdef HAVE_GFC_INTEGER_16
Index: libgfortran/io/transfer.c
===================================================================
--- libgfortran/io/transfer.c (revision 263244)
+++ libgfortran/io/transfer.c (working copy)
@@ -31,6 +31,7 @@ see the files COPYING3 and COPYING.RUNTIME respect
#include "fbuf.h"
#include "format.h"
#include "unix.h"
+#include "async.h"
#include <string.h>
#include <errno.h>
@@ -184,6 +185,12 @@ static const st_option pad_opt[] = {
{NULL, 0}
};
+static const st_option async_opt[] = {
+ {"yes", ASYNC_YES},
+ {"no", ASYNC_NO},
+ {NULL, 0}
+};
+
typedef enum
{ FORMATTED_SEQUENTIAL, UNFORMATTED_SEQUENTIAL,
FORMATTED_DIRECT, UNFORMATTED_DIRECT, FORMATTED_STREAM, UNFORMATTED_STREAM
@@ -1594,7 +1601,8 @@ formatted_transfer_scalar_read (st_parameter_dt *d
read_f (dtp, f, p, kind);
break;
default:
- internal_error (&dtp->common, "formatted_transfer(): Bad type");
+ internal_error (&dtp->common,
+ "formatted_transfer (): Bad type");
}
break;
@@ -2066,7 +2074,7 @@ formatted_transfer_scalar_write (st_parameter_dt *
break;
default:
internal_error (&dtp->common,
- "formatted_transfer(): Bad type");
+ "formatted_transfer (): Bad type");
}
break;
@@ -2281,7 +2289,39 @@ formatted_transfer (st_parameter_dt *dtp, bt type,
}
}
+/* Wrapper function for I/O of scalar types. If this should be an async I/O
+ request, queue it. For a synchronous write on an async unit, perform the
+ wait operation and return an error. For all synchronous writes, call the
+ right transfer function. */
+static void
+wrap_scalar_transfer (st_parameter_dt *dtp, bt type, void *p, int kind,
+ size_t size, size_t n_elem)
+{
+ if (dtp->u.p.current_unit && dtp->u.p.current_unit->au)
+ {
+ if (dtp->u.p.async)
+ {
+ transfer_args args;
+ args.scalar.transfer = dtp->u.p.transfer;
+ args.scalar.arg_bt = type;
+ args.scalar.data = p;
+ args.scalar.i = kind;
+ args.scalar.s1 = size;
+ args.scalar.s2 = n_elem;
+ enqueue_transfer (dtp->u.p.current_unit->au, &args,
+ AIO_TRANSFER_SCALAR);
+ return;
+ }
+ }
+ /* Come here if there was no asynchronous I/O to be scheduled. */
+ if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
+ return;
+
+ dtp->u.p.transfer (dtp, type, p, kind, size, 1);
+}
+
+
/* Data transfer entry points. The type of the data entity is
implicit in the subroutine call. This prevents us from having to
share a common enum with the compiler. */
@@ -2289,9 +2329,7 @@ formatted_transfer (st_parameter_dt *dtp, bt type,
void
transfer_integer (st_parameter_dt *dtp, void *p, int kind)
{
- if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
- return;
- dtp->u.p.transfer (dtp, BT_INTEGER, p, kind, kind, 1);
+ wrap_scalar_transfer (dtp, BT_INTEGER, p, kind, kind, 1);
}
void
@@ -2307,7 +2345,7 @@ transfer_real (st_parameter_dt *dtp, void *p, int
if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
return;
size = size_from_real_kind (kind);
- dtp->u.p.transfer (dtp, BT_REAL, p, kind, size, 1);
+ wrap_scalar_transfer (dtp, BT_REAL, p, kind, size, 1);
}
void
@@ -2319,9 +2357,7 @@ transfer_real_write (st_parameter_dt *dtp, void *p
void
transfer_logical (st_parameter_dt *dtp, void *p, int kind)
{
- if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
- return;
- dtp->u.p.transfer (dtp, BT_LOGICAL, p, kind, kind, 1);
+ wrap_scalar_transfer (dtp, BT_LOGICAL, p, kind, kind, 1);
}
void
@@ -2345,7 +2381,7 @@ transfer_character (st_parameter_dt *dtp, void *p,
p = empty_string;
/* Set kind here to 1. */
- dtp->u.p.transfer (dtp, BT_CHARACTER, p, 1, len, 1);
+ wrap_scalar_transfer (dtp, BT_CHARACTER, p, 1, len, 1);
}
void
@@ -2369,7 +2405,7 @@ transfer_character_wide (st_parameter_dt *dtp, voi
p = empty_string;
/* Here we pass the actual kind value. */
- dtp->u.p.transfer (dtp, BT_CHARACTER, p, kind, len, 1);
+ wrap_scalar_transfer (dtp, BT_CHARACTER, p, kind, len, 1);
}
void
@@ -2385,7 +2421,7 @@ transfer_complex (st_parameter_dt *dtp, void *p, i
if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
return;
size = size_from_complex_kind (kind);
- dtp->u.p.transfer (dtp, BT_COMPLEX, p, kind, size, 1);
+ wrap_scalar_transfer (dtp, BT_COMPLEX, p, kind, size, 1);
}
void
@@ -2395,8 +2431,8 @@ transfer_complex_write (st_parameter_dt *dtp, void
}
void
-transfer_array (st_parameter_dt *dtp, gfc_array_char *desc, int kind,
- gfc_charlen_type charlen)
+transfer_array_inner (st_parameter_dt *dtp, gfc_array_char *desc, int kind,
+ gfc_charlen_type charlen)
{
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
@@ -2407,7 +2443,7 @@ void
bt iotype;
/* Adjust item_count before emitting error message. */
-
+
if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
return;
@@ -2471,6 +2507,36 @@ void
}
void
+transfer_array (st_parameter_dt *dtp, gfc_array_char *desc, int kind,
+ gfc_charlen_type charlen)
+{
+ if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
+ return;
+
+ if (dtp->u.p.current_unit && dtp->u.p.current_unit->au)
+ {
+ if (dtp->u.p.async)
+ {
+ transfer_args args;
+ size_t sz = sizeof (gfc_array_char)
+ + sizeof (descriptor_dimension)
+ * GFC_DESCRIPTOR_RANK (desc);
+ args.array.desc = xmalloc (sz);
+ NOTE ("desc = %p", (void *) args.array.desc);
+ memcpy (args.array.desc, desc, sz);
+ args.array.kind = kind;
+ args.array.charlen = charlen;
+ enqueue_transfer (dtp->u.p.current_unit->au, &args,
+ AIO_TRANSFER_ARRAY);
+ return;
+ }
+ }
+ /* Come here if there was no asynchronous I/O to be scheduled. */
+ transfer_array_inner (dtp, desc, kind, charlen);
+}
+
+
+void
transfer_array_write (st_parameter_dt *dtp, gfc_array_char *desc, int kind,
gfc_charlen_type charlen)
{
@@ -2492,7 +2558,7 @@ transfer_derived (st_parameter_dt *parent, void *d
else
parent->u.p.fdtio_ptr = (formatted_dtio) dtio_proc;
}
- parent->u.p.transfer (parent, BT_CLASS, dtio_source, 0, 0, 1);
+ wrap_scalar_transfer (parent, BT_CLASS, dtio_source, 0, 0, 1);
}
@@ -2667,7 +2733,10 @@ data_transfer_init (st_parameter_dt *dtp, int read
unit_flags u_flags; /* Used for creating a unit if needed. */
GFC_INTEGER_4 cf = dtp->common.flags;
namelist_info *ionml;
+ async_unit *au;
+ NOTE ("data_transfer_init");
+
ionml = ((cf & IOPARM_DT_IONML_SET) != 0) ? dtp->u.p.ionml : NULL;
memset (&dtp->u.p, 0, sizeof (dtp->u.p));
@@ -2693,9 +2762,9 @@ data_transfer_init (st_parameter_dt *dtp, int read
}
else if (dtp->u.p.current_unit->s == NULL)
{ /* Open the unit with some default flags. */
- st_parameter_open opp;
- unit_convert conv;
-
+ st_parameter_open opp;
+ unit_convert conv;
+ NOTE ("Open the unit with some default flags.");
memset (&u_flags, '\0', sizeof (u_flags));
u_flags.access = ACCESS_SEQUENTIAL;
u_flags.action = ACTION_READWRITE;
@@ -2770,6 +2839,42 @@ data_transfer_init (st_parameter_dt *dtp, int read
else if (dtp->u.p.current_unit->internal_unit_kind > 0)
dtp->u.p.unit_is_internal = 1;
+ if ((cf & IOPARM_DT_HAS_ASYNCHRONOUS) != 0)
+ {
+ int f;
+ f = find_option (&dtp->common, dtp->asynchronous, dtp->asynchronous_len,
+ async_opt, "Bad ASYNCHRONOUS in data transfer "
+ "statement");
+ if (f == ASYNC_YES && dtp->u.p.current_unit->flags.async != ASYNC_YES)
+ {
+ generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
+ "ASYNCHRONOUS transfer without "
+ "ASYHCRONOUS='YES' in OPEN");
+ return;
+ }
+ dtp->u.p.async = f == ASYNC_YES;
+ }
+
+ au = dtp->u.p.current_unit->au;
+ if (au)
+ {
+ if (dtp->u.p.async)
+ {
+ /* If this is an asynchronous I/O statement, collect errors and
+ return if there are any. */
+ if (collect_async_errors (&dtp->common, au))
+ return;
+ }
+ else
+ {
+ /* Synchronous statement: Perform a wait operation for any pending
+ asynchronous I/O. This needs to be done before all other error
+ checks. See F2008, 9.6.4.1. */
+ if (async_wait (&(dtp->common), au))
+ return;
+ }
+ }
+
/* Check the action. */
if (read_flag && dtp->u.p.current_unit->flags.action == ACTION_WRITE)
@@ -3009,6 +3114,57 @@ data_transfer_init (st_parameter_dt *dtp, int read
if (dtp->u.p.current_unit->pad_status == PAD_UNSPECIFIED)
dtp->u.p.current_unit->pad_status = dtp->u.p.current_unit->flags.pad;
+ /* Set up the subroutine that will handle the transfers. */
+
+ if (read_flag)
+ {
+ if (dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED)
+ dtp->u.p.transfer = unformatted_read;
+ else
+ {
+ if ((cf & IOPARM_DT_LIST_FORMAT) != 0)
+ dtp->u.p.transfer = list_formatted_read;
+ else
+ dtp->u.p.transfer = formatted_transfer;
+ }
+ }
+ else
+ {
+ if (dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED)
+ dtp->u.p.transfer = unformatted_write;
+ else
+ {
+ if ((cf & IOPARM_DT_LIST_FORMAT) != 0)
+ dtp->u.p.transfer = list_formatted_write;
+ else
+ dtp->u.p.transfer = formatted_transfer;
+ }
+ }
+
+ if (au)
+ {
+ NOTE ("enqueue_data_transfer");
+ enqueue_data_transfer_init (au, dtp, read_flag);
+ }
+ else
+ {
+ NOTE ("invoking data_transfer_init_worker");
+ data_transfer_init_worker (dtp, read_flag);
+ }
+}
+
+void
+data_transfer_init_worker (st_parameter_dt *dtp, int read_flag)
+{
+ GFC_INTEGER_4 cf = dtp->common.flags;
+
+ NOTE ("starting worker...");
+
+ if (read_flag && dtp->u.p.current_unit->flags.form != FORM_UNFORMATTED
+ && ((cf & IOPARM_DT_LIST_FORMAT) != 0)
+ && dtp->u.p.current_unit->child_dtio == 0)
+ dtp->u.p.current_unit->last_char = EOF - 1;
+
/* Check to see if we might be reading what we wrote before */
if (dtp->u.p.mode != dtp->u.p.current_unit->mode
@@ -3135,38 +3291,6 @@ data_transfer_init (st_parameter_dt *dtp, int read
pre_position (dtp);
-
- /* Set up the subroutine that will handle the transfers. */
-
- if (read_flag)
- {
- if (dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED)
- dtp->u.p.transfer = unformatted_read;
- else
- {
- if ((cf & IOPARM_DT_LIST_FORMAT) != 0)
- {
- if (dtp->u.p.current_unit->child_dtio == 0)
- dtp->u.p.current_unit->last_char = EOF - 1;
- dtp->u.p.transfer = list_formatted_read;
- }
- else
- dtp->u.p.transfer = formatted_transfer;
- }
- }
- else
- {
- if (dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED)
- dtp->u.p.transfer = unformatted_write;
- else
- {
- if ((cf & IOPARM_DT_LIST_FORMAT) != 0)
- dtp->u.p.transfer = list_formatted_write;
- else
- dtp->u.p.transfer = formatted_transfer;
- }
- }
-
/* Make sure that we don't do a read after a nonadvancing write. */
if (read_flag)
@@ -4099,7 +4223,7 @@ extern void st_read_done (st_parameter_dt *);
export_proto(st_read_done);
void
-st_read_done (st_parameter_dt *dtp)
+st_read_done_worker (st_parameter_dt *dtp)
{
finalize_transfer (dtp);
@@ -4127,6 +4251,30 @@ void
free_format_data (dtp->u.p.fmt);
free_format (dtp);
}
+ }
+}
+
+void
+st_read_done (st_parameter_dt *dtp)
+{
+ if (dtp->u.p.current_unit)
+ {
+ if (dtp->u.p.current_unit->au)
+ {
+ if (dtp->common.flags & IOPARM_DT_HAS_ID)
+ *dtp->id = enqueue_done_id (dtp->u.p.current_unit->au, AIO_READ_DONE);
+ else
+ {
+ enqueue_done (dtp->u.p.current_unit->au, AIO_READ_DONE);
+ /* An asynchronous unit without ASYNCHRONOUS="YES" - make this
+ synchronous by performing a wait operation. */
+ if (!dtp->u.p.async)
+ async_wait (&dtp->common, dtp->u.p.current_unit->au);
+ }
+ }
+ else
+ st_read_done_worker (dtp);
+
unlock_unit (dtp->u.p.current_unit);
}
@@ -4134,7 +4282,7 @@ void
}
extern void st_write (st_parameter_dt *);
-export_proto(st_write);
+export_proto (st_write);
void
st_write (st_parameter_dt *dtp)
@@ -4143,11 +4291,9 @@ st_write (st_parameter_dt *dtp)
data_transfer_init (dtp, 0);
}
-extern void st_write_done (st_parameter_dt *);
-export_proto(st_write_done);
void
-st_write_done (st_parameter_dt *dtp)
+st_write_done_worker (st_parameter_dt *dtp)
{
finalize_transfer (dtp);
@@ -4196,19 +4342,68 @@ void
free_format_data (dtp->u.p.fmt);
free_format (dtp);
}
+ }
+}
+
+extern void st_write_done (st_parameter_dt *);
+export_proto(st_write_done);
+
+void
+st_write_done (st_parameter_dt *dtp)
+{
+ if (dtp->u.p.current_unit)
+ {
+ if (dtp->u.p.current_unit->au)
+ {
+ if (dtp->common.flags & IOPARM_DT_HAS_ID)
+ *dtp->id = enqueue_done_id (dtp->u.p.current_unit->au,
+ AIO_WRITE_DONE);
+ else
+ {
+ enqueue_done (dtp->u.p.current_unit->au, AIO_WRITE_DONE);
+ /* An asynchronous unit without ASYNCHRONOUS="YES" - make this
+ synchronous by performing a wait operation. */
+ if (!dtp->u.p.async)
+ async_wait (&dtp->common, dtp->u.p.current_unit->au);
+ }
+ }
+ else
+ st_write_done_worker (dtp);
+
unlock_unit (dtp->u.p.current_unit);
}
+
library_end ();
}
+/* Wait operation. We need to keep around the do-nothing version
+ of st_wait for compatibility with previous versions, which had marked
+ the argument as unused (and thus liable to be removed).
-/* F2003: This is a stub for the runtime portion of the WAIT statement. */
+ TODO: remove at next bump in version number. */
+
void
st_wait (st_parameter_wait *wtp __attribute__((unused)))
{
+ return;
}
+void
+st_wait_async (st_parameter_wait *wtp)
+{
+ gfc_unit *u = find_unit (wtp->common.unit);
+ if (ASYNC_IO && u->au)
+ {
+ if (wtp->common.flags & IOPARM_WAIT_HAS_ID)
+ async_wait_id (&(wtp->common), u->au, *wtp->id);
+ else
+ async_wait (&(wtp->common), u->au);
+ }
+ unlock_unit (u);
+}
+
+
/* Receives the scalar information for namelist objects and stores it
in a linked list of namelist_info types. */
Index: libgfortran/io/unit.c
===================================================================
--- libgfortran/io/unit.c (revision 263244)
+++ libgfortran/io/unit.c (working copy)
@@ -27,6 +27,7 @@ see the files COPYING3 and COPYING.RUNTIME respect
#include "fbuf.h"
#include "format.h"
#include "unix.h"
+#include "async.h"
#include <string.h>
#include <assert.h>
@@ -240,7 +241,7 @@ insert_unit (int n)
#else
__GTHREAD_MUTEX_INIT_FUNCTION (&u->lock);
#endif
- __gthread_mutex_lock (&u->lock);
+ LOCK (&u->lock);
u->priority = pseudo_random ();
unit_root = insert (u, unit_root);
return u;
@@ -327,7 +328,9 @@ get_gfc_unit (int n, int do_create)
gfc_unit *p;
int c, created = 0;
- __gthread_mutex_lock (&unit_lock);
+ NOTE ("Unit n=%d, do_create = %d", n, do_create);
+ LOCK (&unit_lock);
+
retry:
for (c = 0; c < CACHE_SIZE; c++)
if (unit_cache[c] != NULL && unit_cache[c]->unit_number == n)
@@ -366,7 +369,7 @@ retry:
{
/* Newly created units have their lock held already
from insert_unit. Just unlock UNIT_LOCK and return. */
- __gthread_mutex_unlock (&unit_lock);
+ UNLOCK (&unit_lock);
return p;
}
@@ -374,10 +377,10 @@ found:
if (p != NULL && (p->child_dtio == 0))
{
/* Fast path. */
- if (! __gthread_mutex_trylock (&p->lock))
+ if (! TRYLOCK (&p->lock))
{
/* assert (p->closed == 0); */
- __gthread_mutex_unlock (&unit_lock);
+ UNLOCK (&unit_lock);
return p;
}
@@ -385,15 +388,15 @@ found:
}
- __gthread_mutex_unlock (&unit_lock);
+ UNLOCK (&unit_lock);
if (p != NULL && (p->child_dtio == 0))
{
- __gthread_mutex_lock (&p->lock);
+ LOCK (&p->lock);
if (p->closed)
{
- __gthread_mutex_lock (&unit_lock);
- __gthread_mutex_unlock (&p->lock);
+ LOCK (&unit_lock);
+ UNLOCK (&p->lock);
if (predec_waiting_locked (p) == 0)
destroy_unit_mutex (p);
goto retry;
@@ -640,7 +643,7 @@ init_units (void)
fbuf_init (u, 0);
- __gthread_mutex_unlock (&u->lock);
+ UNLOCK (&u->lock);
}
if (options.stdout_unit >= 0)
@@ -671,7 +674,7 @@ init_units (void)
fbuf_init (u, 0);
- __gthread_mutex_unlock (&u->lock);
+ UNLOCK (&u->lock);
}
if (options.stderr_unit >= 0)
@@ -702,13 +705,13 @@ init_units (void)
fbuf_init (u, 256); /* 256 bytes should be enough, probably not doing
any kind of exotic formatting to stderr. */
- __gthread_mutex_unlock (&u->lock);
+ UNLOCK (&u->lock);
}
/* The default internal units. */
u = insert_unit (GFC_INTERNAL_UNIT);
- __gthread_mutex_unlock (&u->lock);
+ UNLOCK (&u->lock);
u = insert_unit (GFC_INTERNAL_UNIT4);
- __gthread_mutex_unlock (&u->lock);
+ UNLOCK (&u->lock);
}
@@ -717,6 +720,9 @@ close_unit_1 (gfc_unit *u, int locked)
{
int i, rc;
+ if (ASYNC_IO && u->au)
+ async_close (u->au);
+
/* If there are previously written bytes from a write with ADVANCE="no"
Reposition the buffer before closing. */
if (u->previous_nonadvancing_write)
@@ -726,7 +732,7 @@ close_unit_1 (gfc_unit *u, int locked)
u->closed = 1;
if (!locked)
- __gthread_mutex_lock (&unit_lock);
+ LOCK (&unit_lock);
for (i = 0; i < CACHE_SIZE; i++)
if (unit_cache[i] == u)
@@ -744,7 +750,7 @@ close_unit_1 (gfc_unit *u, int locked)
newunit_free (u->unit_number);
if (!locked)
- __gthread_mutex_unlock (&u->lock);
+ UNLOCK (&u->lock);
/* If there are any threads waiting in find_unit for this unit,
avoid freeing the memory, the last such thread will free it
@@ -753,7 +759,7 @@ close_unit_1 (gfc_unit *u, int locked)
destroy_unit_mutex (u);
if (!locked)
- __gthread_mutex_unlock (&unit_lock);
+ UNLOCK (&unit_lock);
return rc;
}
@@ -761,7 +767,9 @@ close_unit_1 (gfc_unit *u, int locked)
void
unlock_unit (gfc_unit *u)
{
- __gthread_mutex_unlock (&u->lock);
+ NOTE ("unlock_unit = %d", u->unit_number);
+ UNLOCK (&u->lock);
+ NOTE ("unlock_unit done");
}
/* close_unit()-- Close a unit. The stream is closed, and any memory
@@ -785,10 +793,10 @@ close_unit (gfc_unit *u)
void
close_units (void)
{
- __gthread_mutex_lock (&unit_lock);
+ LOCK (&unit_lock);
while (unit_root != NULL)
close_unit_1 (unit_root, 1);
- __gthread_mutex_unlock (&unit_lock);
+ UNLOCK (&unit_lock);
free (newunits);
@@ -895,7 +903,7 @@ finish_last_advance_record (gfc_unit *u)
int
newunit_alloc (void)
{
- __gthread_mutex_lock (&unit_lock);
+ LOCK (&unit_lock);
if (!newunits)
{
newunits = xcalloc (16, 1);
@@ -909,7 +917,7 @@ newunit_alloc (void)
{
newunits[ii] = true;
newunit_lwi = ii + 1;
- __gthread_mutex_unlock (&unit_lock);
+ UNLOCK (&unit_lock);
return -ii + NEWUNIT_START;
}
}
@@ -922,7 +930,7 @@ newunit_alloc (void)
memset (newunits + old_size, 0, old_size);
newunits[old_size] = true;
newunit_lwi = old_size + 1;
- __gthread_mutex_unlock (&unit_lock);
+ UNLOCK (&unit_lock);
return -old_size + NEWUNIT_START;
}
Index: libgfortran/io/unix.c
===================================================================
--- libgfortran/io/unix.c (revision 263244)
+++ libgfortran/io/unix.c (working copy)
@@ -27,6 +27,7 @@ see the files COPYING3 and COPYING.RUNTIME respect
#include "io.h"
#include "unix.h"
+#include "async.h"
#include <limits.h>
#ifdef HAVE_UNISTD_H
@@ -1742,7 +1743,7 @@ find_file (const char *file, gfc_charlen_type file
id = id_from_path (path);
#endif
- __gthread_mutex_lock (&unit_lock);
+ LOCK (&unit_lock);
retry:
u = find_file0 (unit_root, FIND_FILE0_ARGS);
if (u != NULL)
@@ -1751,20 +1752,20 @@ retry:
if (! __gthread_mutex_trylock (&u->lock))
{
/* assert (u->closed == 0); */
- __gthread_mutex_unlock (&unit_lock);
+ UNLOCK (&unit_lock);
goto done;
}
inc_waiting_locked (u);
}
- __gthread_mutex_unlock (&unit_lock);
+ UNLOCK (&unit_lock);
if (u != NULL)
{
- __gthread_mutex_lock (&u->lock);
+ LOCK (&u->lock);
if (u->closed)
{
- __gthread_mutex_lock (&unit_lock);
- __gthread_mutex_unlock (&u->lock);
+ LOCK (&unit_lock);
+ UNLOCK (&u->lock);
if (predec_waiting_locked (u) == 0)
free (u);
goto retry;
@@ -1794,7 +1795,7 @@ flush_all_units_1 (gfc_unit *u, int min_unit)
return u;
if (u->s)
sflush (u->s);
- __gthread_mutex_unlock (&u->lock);
+ UNLOCK (&u->lock);
}
u = u->right;
}
@@ -1807,17 +1808,17 @@ flush_all_units (void)
gfc_unit *u;
int min_unit = 0;
- __gthread_mutex_lock (&unit_lock);
+ LOCK (&unit_lock);
do
{
u = flush_all_units_1 (unit_root, min_unit);
if (u != NULL)
inc_waiting_locked (u);
- __gthread_mutex_unlock (&unit_lock);
+ UNLOCK (&unit_lock);
if (u == NULL)
return;
- __gthread_mutex_lock (&u->lock);
+ LOCK (&u->lock);
min_unit = u->unit_number + 1;
@@ -1824,14 +1825,14 @@ flush_all_units (void)
if (u->closed == 0)
{
sflush (u->s);
- __gthread_mutex_lock (&unit_lock);
- __gthread_mutex_unlock (&u->lock);
+ LOCK (&unit_lock);
+ UNLOCK (&u->lock);
(void) predec_waiting_locked (u);
}
else
{
- __gthread_mutex_lock (&unit_lock);
- __gthread_mutex_unlock (&u->lock);
+ LOCK (&unit_lock);
+ UNLOCK (&u->lock);
if (predec_waiting_locked (u) == 0)
free (u);
}
Index: libgfortran/libgfortran.h
===================================================================
--- libgfortran/libgfortran.h (revision 263244)
+++ libgfortran/libgfortran.h (working copy)
@@ -738,6 +738,9 @@ internal_proto(translate_error);
extern void generate_error (st_parameter_common *, int, const char *);
iexport_proto(generate_error);
+extern bool generate_error_common (st_parameter_common *, int, const char *);
+iexport_proto(generate_error_common);
+
extern void generate_warning (st_parameter_common *, const char *);
internal_proto(generate_warning);
@@ -1743,5 +1746,7 @@ void cshift1_16_c16 (gfc_array_c16 * const restric
internal_proto(cshift1_16_c16);
#endif
+/* Define this if we support asynchronous I/O on this platform. This
+ currently requires weak symbols. */
#endif /* LIBGFOR_H */
Index: libgfortran/runtime/error.c
===================================================================
--- libgfortran/runtime/error.c (revision 263244)
+++ libgfortran/runtime/error.c (working copy)
@@ -24,6 +24,9 @@ see the files COPYING3 and COPYING.RUNTIME respect
#include "libgfortran.h"
+#include "io.h"
+#include "async.h"
+
#include <assert.h>
#include <string.h>
#include <errno.h>
@@ -526,24 +529,41 @@ translate_error (int code)
}
-/* generate_error()-- Come here when an error happens. This
- * subroutine is called if it is possible to continue on after the error.
- * If an IOSTAT or IOMSG variable exists, we set it. If IOSTAT or
- * ERR labels are present, we return, otherwise we terminate the program
- * after printing a message. The error code is always required but the
- * message parameter can be NULL, in which case a string describing
- * the most recent operating system error is used. */
+/* Worker function for generate_error and generate_error_async. Return true
+ if a straight return is to be done, zero if the program should abort. */
-void
-generate_error (st_parameter_common *cmp, int family, const char *message)
+bool
+generate_error_common (st_parameter_common *cmp, int family, const char *message)
{
char errmsg[STRERR_MAXSZ];
+#if ASYNC_IO
+ gfc_unit *u;
+
+ NOTE ("Entering generate_error_common");
+
+ u = thread_unit;
+ if (u && u->au)
+ {
+ if (u->au->error.has_error)
+ return true;
+
+ if (__gthread_equal (u->au->thread, __gthread_self ()))
+ {
+ u->au->error.has_error = 1;
+ u->au->error.cmp = cmp;
+ u->au->error.family = family;
+ u->au->error.message = message;
+ return true;
+ }
+ }
+#endif
+
/* If there was a previous error, don't mask it with another
error message, EOF or EOR condition. */
if ((cmp->flags & IOPARM_LIBRETURN_MASK) == IOPARM_LIBRETURN_ERROR)
- return;
+ return true;
/* Set the error status. */
if ((cmp->flags & IOPARM_HAS_IOSTAT))
@@ -562,29 +582,30 @@ translate_error (int code)
switch (family)
{
case LIBERROR_EOR:
- cmp->flags |= IOPARM_LIBRETURN_EOR;
+ cmp->flags |= IOPARM_LIBRETURN_EOR; NOTE("EOR");
if ((cmp->flags & IOPARM_EOR))
- return;
+ return true;
break;
case LIBERROR_END:
- cmp->flags |= IOPARM_LIBRETURN_END;
+ cmp->flags |= IOPARM_LIBRETURN_END; NOTE("END");
if ((cmp->flags & IOPARM_END))
- return;
+ return true;
break;
default:
- cmp->flags |= IOPARM_LIBRETURN_ERROR;
+ cmp->flags |= IOPARM_LIBRETURN_ERROR; NOTE("ERROR");
if ((cmp->flags & IOPARM_ERR))
- return;
+ return true;
break;
}
/* Return if the user supplied an iostat variable. */
if ((cmp->flags & IOPARM_HAS_IOSTAT))
- return;
+ return true;
- /* Terminate the program */
+ /* Return code, caller is responsible for terminating
+ the program if necessary. */
recursion_check ();
show_locus (cmp);
@@ -591,8 +612,27 @@ translate_error (int code)
estr_write ("Fortran runtime error: ");
estr_write (message);
estr_write ("\n");
- exit_error (2);
+ return false;
}
+
+/* generate_error()-- Come here when an error happens. This
+ * subroutine is called if it is possible to continue on after the error.
+ * If an IOSTAT or IOMSG variable exists, we set it. If IOSTAT or
+ * ERR labels are present, we return, otherwise we terminate the program
+ * after printing a message. The error code is always required but the
+ * message parameter can be NULL, in which case a string describing
+ * the most recent operating system error is used.
+ * If the error is for an asynchronous unit and if the program is currently
+ * executing the asynchronous thread, just mark the error and return. */
+
+void
+generate_error (st_parameter_common *cmp, int family, const char *message)
+{
+ if (generate_error_common (cmp, family, message))
+ return;
+
+ exit_error(2);
+}
iexport(generate_error);
^ permalink raw reply [flat|nested] 20+ messages in thread
* Re: Async I/O patch with compilation fix
2018-08-02 17:08 ` Nicolas Koenig
@ 2018-08-03 8:46 ` Christophe Lyon
2018-08-03 22:43 ` Thomas König
2018-08-17 15:41 ` Thomas Koenig
0 siblings, 2 replies; 20+ messages in thread
From: Christophe Lyon @ 2018-08-03 8:46 UTC (permalink / raw)
To: koenigni
Cc: Andre Simoes Dias Vieira, gcc Patches, fortran, Thomas Koenig,
Ulrich Weigand, David Edelsohn, clyon
On Thu, 2 Aug 2018 at 19:05, Nicolas Koenig <koenigni@student.ethz.ch> wrote:
>
> On Thu, Aug 02, 2018 at 05:42:46PM +0200, Christophe Lyon wrote:
> > On Thu, 2 Aug 2018 at 13:35, Nicolas Koenig <koenigni@student.ethz.ch> wrote:
> > >
> > >
> > > Hello everyone,
> > >
> > > Here is an updated version of the patch that hopefully fixes the compilation
> > > problems by disabling async I/O if conditions are not supported by the target.
> > >
> > > I would appreciate if people could test it on systems on which it failed
> > > before. As for the array_constructor_8.f90 failure reported in the PR, why
> > > it fails is beyond me, it doesn't even use I/O. Maybe/Probably something
> > > unrelated?
> > >
> >
> > Hi,
> > I'm probably missing something obvious, but after applying this patch
> > on top of r263136, the builds fail while building libgfortran:
> > /tmp/9271913_1.tmpdir/aci-gcc-fsf/sources/gcc-fsf/gccsrc/libgfortran/runtime/error.c:28:10:
> > fatal error: async.h: No such file or directory
> > #include "async.h"
> > ^~~~~~~~~
> > compilation terminated.
> > make[3]: *** [error.lo] Error 1
> >
>
> Hi,
>
> It wasn't you who missed something obvious. Typing `svn add` is hard.
> Here is a version of the patch with the two new files.
>
OK,
I applied this patch, and again I still see regressions on
armeb-none-linux-gnueabihf
--with-cpu cortex-a9
--with-fpu neon-fp16
FAIL: gfortran.dg/array_constructor_8.f90 -O3 -fomit-frame-pointer
-funroll-loops -fpeel-loops -ftracer -finline-functions execution
test
FAIL: gfortran.dg/array_constructor_8.f90 -O3 -g execution test
gfortran.log contains:
STOP 2
STOP 2
Christophe
> Nicolas
>
> > > Nicolas
> > >
> > >
> > > 2018-08-02 Nicolas Koenig <koenigni@gcc.gnu.org>
> > > Thomas Koenig <tkoenig@gcc.gnu.org>
> > >
> > > PR fortran/25829
> > > * gfortran.texi: Add description of asynchronous I/O.
> > > * trans-decl.c (gfc_finish_var_decl): Treat asynchronous variables
> > > as volatile.
> > > * trans-io.c (gfc_build_io_library_fndecls): Rename st_wait to
> > > st_wait_async and change argument spec from ".X" to ".w".
> > > (gfc_trans_wait): Pass ID argument via reference.
> > >
> > > 2018-08-02 Nicolas Koenig <koenigni@gcc.gnu.org>
> > > Thomas Koenig <tkoenig@gcc.gnu.org>
> > >
> > > PR fortran/25829
> > > * gfortran.dg/f2003_inquire_1.f03: Add write statement.
> > > * gfortran.dg/f2003_io_1.f03: Add wait statement.
> > >
> > > 2018-08-02 Nicolas Koenig <koenigni@gcc.gnu.org>
> > > Thomas Koenig <tkoenig@gcc.gnu.org>
> > >
> > > PR fortran/25829
> > > * Makefile.am: Add async.c to gfor_io_src.
> > > Add async.h to gfor_io_headers.
> > > * Makefile.in: Regenerated.
> > > * gfortran.map: Add _gfortran_st_wait_async.
> > > * io/async.c: New file.
> > > * io/async.h: New file.
> > > * io/close.c: Include async.h.
> > > (st_close): Call async_wait for an asynchronous unit.
> > > * io/file_pos.c (st_backspace): Likewise.
> > > (st_endfile): Likewise.
> > > (st_rewind): Likewise.
> > > (st_flush): Likewise.
> > > * io/inquire.c: Add handling for asynchronous PENDING
> > > and ID arguments.
> > > * io/io.h (st_parameter_dt): Add async bit.
> > > (st_parameter_wait): Correct.
> > > (gfc_unit): Add au pointer.
> > > (st_wait_async): Add prototype.
> > > (transfer_array_inner): Likewise.
> > > (st_write_done_worker): Likewise.
> > > * io/open.c: Include async.h.
> > > (new_unit): Initialize asynchronous unit.
> > > * io/transfer.c (async_opt): New struct.
> > > (wrap_scalar_transfer): New function.
> > > (transfer_integer): Call wrap_scalar_transfer to do the work.
> > > (transfer_real): Likewise.
> > > (transfer_real_write): Likewise.
> > > (transfer_character): Likewise.
> > > (transfer_character_wide): Likewise.
> > > (transfer_complex): Likewise.
> > > (transfer_array_inner): New function.
> > > (transfer_array): Call transfer_array_inner.
> > > (transfer_derived): Call wrap_scalar_transfer.
> > > (data_transfer_init): Check for asynchronous I/O.
> > > Perform a wait operation on any pending asynchronous I/O
> > > if the data transfer is synchronous. Copy PDT and enqueue
> > > thread for data transfer.
> > > (st_read_done_worker): New function.
> > > (st_read_done): Enqueue transfer or call st_read_done_worker.
> > > (st_write_done_worker): New function.
> > > (st_write_done): Enqueue transfer or call st_read_done_worker.
> > > (st_wait): Document as no-op for compatibility reasons.
> > > (st_wait_async): New function.
> > > * io/unit.c (insert_unit): Use macros LOCK, UNLOCK and TRYLOCK;
> > > add NOTE where necessary.
> > > (get_gfc_unit): Likewise.
> > > (init_units): Likewise.
> > > (close_unit_1): Likewise. Call async_close if asynchronous.
> > > (close_unit): Use macros LOCK and UNLOCK.
> > > (finish_last_advance_record): Likewise.
> > > (newunit_alloc): Likewise.
> > > * io/unix.c (find_file): Likewise.
> > > (flush_all_units_1): Likewise.
> > > (flush_all_units): Likewise.
> > > * libgfortran.h (generate_error_common): Add prototype.
> > > * runtime/error.c: Include io.h and async.h.
> > > (generate_error_common): New function.
> > >
> > > 2018-08-02 Nicolas Koenig <koenigni@gcc.gnu.org>
> > > Thomas Koenig <tkoenig@gcc.gnu.org>
> > >
> > > PR fortran/25829
> > > * testsuite/libgomp.fortran/async_io_1.f90: New test.
> > > * testsuite/libgomp.fortran/async_io_2.f90: New test.
> > > * testsuite/libgomp.fortran/async_io_3.f90: New test.
> > > * testsuite/libgomp.fortran/async_io_4.f90: New test.
> > > * testsuite/libgomp.fortran/async_io_5.f90: New test.
> > > * testsuite/libgomp.fortran/async_io_6.f90: New test.
> > > * testsuite/libgomp.fortran/async_io_7.f90: New test.
^ permalink raw reply [flat|nested] 20+ messages in thread
* Re: Async I/O patch with compilation fix
2018-08-03 8:46 ` Christophe Lyon
@ 2018-08-03 22:43 ` Thomas König
2018-08-06 11:33 ` Christophe Lyon
2018-08-17 15:41 ` Thomas Koenig
1 sibling, 1 reply; 20+ messages in thread
From: Thomas König @ 2018-08-03 22:43 UTC (permalink / raw)
To: Christophe Lyon
Cc: koenigni, Andre Simoes Dias Vieira, gcc Patches, fortran,
Thomas Koenig, Ulrich Weigand, David Edelsohn, clyon
Hi Cristophe,
this is seriously weird - there is not even an I/O statement in that test case.
One question: Is this real hardware or an emulator?
Also, Could you try a few things?
Run the test case manually. Do you still fail?
Is there an error if the executable is run under valgrind?
If you have two compilers, one with the patch and one without: Is there a difference in the generated files for
-dump-tree-original, -fdump-tree-optimized and -S?
Regards, Thomas
^ permalink raw reply [flat|nested] 20+ messages in thread
* Re: Async I/O patch with compilation fix
2018-08-03 22:43 ` Thomas König
@ 2018-08-06 11:33 ` Christophe Lyon
0 siblings, 0 replies; 20+ messages in thread
From: Christophe Lyon @ 2018-08-06 11:33 UTC (permalink / raw)
To: tk
Cc: koenigni, Andre Simoes Dias Vieira, gcc Patches, fortran,
Thomas Koenig, Ulrich Weigand, David Edelsohn, clyon
On Sat, 4 Aug 2018 at 00:42, Thomas König <tk@tkoenig.net> wrote:
>
> Hi Cristophe,
>
> this is seriously weird - there is not even an I/O statement in that test case.
>
> One question: Is this real hardware or an emulator?
I'm using QEMU
> Also, Could you try a few things?
>
> Run the test case manually. Do you still fail?
Yes.
> Is there an error if the executable is run under valgrind?
I don't know how to do that with qemu, nor if valgrind supports armeb?
> If you have two compilers, one with the patch and one without: Is there a difference in the generated files for
>
> -dump-tree-original, -fdump-tree-optimized and -S?
I posted a few comments in the associated PR:
- the .s files are the same with /without the patch, so I suppose the
problem comes from the runtime libraries
- I've attached both execution traces and output from objdump on the
statically linked executable, so as to hopefully include all the code
executed
> Regards, Thomas
^ permalink raw reply [flat|nested] 20+ messages in thread
* Re: Async I/O patch with compilation fix
2018-08-03 8:46 ` Christophe Lyon
2018-08-03 22:43 ` Thomas König
@ 2018-08-17 15:41 ` Thomas Koenig
2018-08-18 22:44 ` Christophe Lyon
1 sibling, 1 reply; 20+ messages in thread
From: Thomas Koenig @ 2018-08-17 15:41 UTC (permalink / raw)
To: Christophe Lyon, koenigni
Cc: Andre Simoes Dias Vieira, gcc Patches, fortran, Ulrich Weigand,
David Edelsohn, clyon
[-- Attachment #1: Type: text/plain, Size: 990 bytes --]
Hi Christophe,
sorry that this took so long, but a holiday followed by a
business trip seven timezones away can do that :-)
> I applied this patch, and again I still see regressions on
> armeb-none-linux-gnueabihf
> --with-cpu cortex-a9
> --with-fpu neon-fp16
The info that you supplied in the PR indicates some sort of library
problem exposed by the patch, possibly by including gthr.h.
All Nicolas and I could come up with was to remove the async I/O
functionality from armeb-* and by xfailing the tests.
This is done by
+#if defined(__GTHREAD_HAS_COND) && defined(__GTHREADS_CXX0X) &&
!defined(__ARMEB__)
+#define ASYNC_IO 1
+#else
+#define ASYNC_IO 0
+#endif
If somebody comes up with something more fine-grained for the
feature test, we can put this in now or later.
Regression-tested on x86_64-pc-linux-gnu (which showed that
xfail lines in the testsuite aren't wildly inaccurate).
So, I'd appreciate testing. If this passes, this will be
committed ASAP.
Regards
Thomas
[-- Attachment #2: pc.diff --]
[-- Type: text/x-patch, Size: 71208 bytes --]
Index: gcc/fortran/gfortran.texi
===================================================================
--- gcc/fortran/gfortran.texi (Revision 263618)
+++ gcc/fortran/gfortran.texi (Arbeitskopie)
@@ -879,8 +879,7 @@ than @code{(/.../)}. Type-specification for array
@item Extensions to the specification and initialization expressions,
including the support for intrinsics with real and complex arguments.
-@item Support for the asynchronous input/output syntax; however, the
-data transfer is currently always synchronously performed.
+@item Support for the asynchronous input/output.
@item
@cindex @code{FLUSH} statement
@@ -1183,6 +1182,7 @@ might in some way or another become visible to the
* Files opened without an explicit ACTION= specifier::
* File operations on symbolic links::
* File format of unformatted sequential files::
+* Asynchronous I/O::
@end menu
@@ -1486,6 +1486,20 @@ program main
end program main
@end smallexample
+@node Asynchronous I/O
+@section Asynchronous I/O
+@cindex input/output, asynchronous
+@cindex asynchronous I/O
+
+Asynchronous I/O is supported if the program is linked against the
+POSIX thread library. If that is not the case, all I/O is performed
+as synchronous.
+
+On some systems, such as Darwin or Solaris, the POSIX thread library
+is always linked in, so asynchronous I/O is always performed. On other
+sytems, such as Linux, it is necessary to specify @option{-pthread},
+@option{-lpthread} or @option{-fopenmp} during the linking step.
+
@c ---------------------------------------------------------------------
@c Extensions
@c ---------------------------------------------------------------------
Index: gcc/fortran/trans-decl.c
===================================================================
--- gcc/fortran/trans-decl.c (Revision 263618)
+++ gcc/fortran/trans-decl.c (Arbeitskopie)
@@ -698,7 +698,8 @@ gfc_finish_var_decl (tree decl, gfc_symbol * sym)
&& CLASS_DATA (sym)->ts.u.derived->attr.has_dtio_procs)))
TREE_STATIC (decl) = 1;
- if (sym->attr.volatile_)
+ /* Treat asynchronous variables the same as volatile, for now. */
+ if (sym->attr.volatile_ || sym->attr.asynchronous)
{
TREE_THIS_VOLATILE (decl) = 1;
TREE_SIDE_EFFECTS (decl) = 1;
Index: gcc/fortran/trans-io.c
===================================================================
--- gcc/fortran/trans-io.c (Revision 263618)
+++ gcc/fortran/trans-io.c (Arbeitskopie)
@@ -438,10 +438,9 @@ gfc_build_io_library_fndecls (void)
get_identifier (PREFIX("st_iolength")), ".w",
void_type_node, 1, dt_parm_type);
- /* TODO: Change when asynchronous I/O is implemented. */
parm_type = build_pointer_type (st_parameter[IOPARM_ptype_wait].type);
iocall[IOCALL_WAIT] = gfc_build_library_function_decl_with_spec (
- get_identifier (PREFIX("st_wait")), ".X",
+ get_identifier (PREFIX("st_wait_async")), ".w",
void_type_node, 1, parm_type);
parm_type = build_pointer_type (st_parameter[IOPARM_ptype_filepos].type);
@@ -1527,7 +1526,7 @@ gfc_trans_wait (gfc_code * code)
mask |= IOPARM_common_err;
if (p->id)
- mask |= set_parameter_value (&block, var, IOPARM_wait_id, p->id);
+ mask |= set_parameter_ref (&block, &post_block, var, IOPARM_wait_id, p->id);
set_parameter_const (&block, var, IOPARM_common_flags, mask);
Index: gcc/testsuite/gfortran.dg/f2003_inquire_1.f03
===================================================================
--- gcc/testsuite/gfortran.dg/f2003_inquire_1.f03 (Revision 263618)
+++ gcc/testsuite/gfortran.dg/f2003_inquire_1.f03 (Arbeitskopie)
@@ -7,10 +7,12 @@ logical :: vpending
open(10, file='mydata_f2003_inquire_1', asynchronous="yes", blank="null", &
& decimal="comma", encoding="utf-8", sign="plus")
+write (10,*, asynchronous="yes", id=vid) 'asdf'
+wait (10)
+
inquire(unit=10, round=sround, sign=ssign, size=vsize, id=vid, &
& pending=vpending, asynchronous=sasynchronous, decimal=sdecimal, &
& encoding=sencoding)
-
if (ssign.ne."PLUS") STOP 1
if (sasynchronous.ne."YES") STOP 2
if (sdecimal.ne."COMMA") STOP 3
Index: gcc/testsuite/gfortran.dg/f2003_io_1.f03
===================================================================
--- gcc/testsuite/gfortran.dg/f2003_io_1.f03 (Revision 263618)
+++ gcc/testsuite/gfortran.dg/f2003_io_1.f03 (Arbeitskopie)
@@ -13,6 +13,7 @@ open(10, file='mydata_f2003_io_1', asynchronous="y
write(10,'(10f8.3)', asynchronous="yes", decimal="comma", id=j) a
rewind(10)
read(10,'(10f8.3)', asynchronous="yes", decimal="comma", blank="zero") b
+wait(10)
if (any(b.ne.23.45)) STOP 1
c = 3.14
@@ -24,6 +25,7 @@ rewind(10)
write(10,'(10f8.3)', asynchronous="yes", decimal="point") a
rewind(10)
read(10,'(10f8.3)', asynchronous="yes", decimal="point") b
+wait (10)
if (any(b.ne.23.45)) STOP 3
wait(unit=10, err=25, iostat=istat, iomsg=msg, end=35, id=j)
Index: libgfortran/Makefile.am
===================================================================
--- libgfortran/Makefile.am (Revision 263618)
+++ libgfortran/Makefile.am (Arbeitskopie)
@@ -100,7 +100,8 @@ io/transfer128.c \
io/unit.c \
io/unix.c \
io/write.c \
-io/fbuf.c
+io/fbuf.c \
+io/async.c
endif
@@ -108,7 +109,8 @@ gfor_io_headers= \
io/io.h \
io/fbuf.h \
io/format.h \
-io/unix.h
+io/unix.h \
+io/async.h
gfor_helper_src= \
intrinsics/associated.c \
Index: libgfortran/Makefile.in
===================================================================
--- libgfortran/Makefile.in (Revision 263618)
+++ libgfortran/Makefile.in (Arbeitskopie)
@@ -70,7 +70,8 @@ target_triplet = @target@
@LIBGFOR_MINIMAL_FALSE@io/unit.c \
@LIBGFOR_MINIMAL_FALSE@io/unix.c \
@LIBGFOR_MINIMAL_FALSE@io/write.c \
-@LIBGFOR_MINIMAL_FALSE@io/fbuf.c
+@LIBGFOR_MINIMAL_FALSE@io/fbuf.c \
+@LIBGFOR_MINIMAL_FALSE@io/async.c
@LIBGFOR_MINIMAL_FALSE@am__append_3 = \
@LIBGFOR_MINIMAL_FALSE@intrinsics/access.c \
@@ -352,7 +353,7 @@ am__objects_47 = $(am__objects_4) $(am__objects_5)
@LIBGFOR_MINIMAL_FALSE@ inquire.lo intrinsics.lo list_read.lo \
@LIBGFOR_MINIMAL_FALSE@ lock.lo open.lo read.lo transfer.lo \
@LIBGFOR_MINIMAL_FALSE@ transfer128.lo unit.lo unix.lo write.lo \
-@LIBGFOR_MINIMAL_FALSE@ fbuf.lo
+@LIBGFOR_MINIMAL_FALSE@ fbuf.lo async.lo
am__objects_49 = size_from_kind.lo $(am__objects_48)
@LIBGFOR_MINIMAL_FALSE@am__objects_50 = access.lo c99_functions.lo \
@LIBGFOR_MINIMAL_FALSE@ chdir.lo chmod.lo clock.lo cpu_time.lo \
@@ -650,7 +651,8 @@ gfor_io_headers = \
io/io.h \
io/fbuf.h \
io/format.h \
-io/unix.h
+io/unix.h \
+io/async.h
gfor_helper_src = intrinsics/associated.c intrinsics/abort.c \
intrinsics/args.c intrinsics/cshift0.c intrinsics/eoshift0.c \
@@ -1551,6 +1553,7 @@ distclean-compile:
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/any_l8.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/args.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/associated.Plo@am__quote@
+@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/async.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/backtrace.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/bessel_r10.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/bessel_r16.Plo@am__quote@
@@ -5814,6 +5817,13 @@ fbuf.lo: io/fbuf.c
@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
@am__fastdepCC_FALSE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o fbuf.lo `test -f 'io/fbuf.c' || echo '$(srcdir)/'`io/fbuf.c
+async.lo: io/async.c
+@am__fastdepCC_TRUE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT async.lo -MD -MP -MF $(DEPDIR)/async.Tpo -c -o async.lo `test -f 'io/async.c' || echo '$(srcdir)/'`io/async.c
+@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/async.Tpo $(DEPDIR)/async.Plo
+@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='io/async.c' object='async.lo' libtool=yes @AMDEPBACKSLASH@
+@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
+@am__fastdepCC_FALSE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o async.lo `test -f 'io/async.c' || echo '$(srcdir)/'`io/async.c
+
associated.lo: intrinsics/associated.c
@am__fastdepCC_TRUE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT associated.lo -MD -MP -MF $(DEPDIR)/associated.Tpo -c -o associated.lo `test -f 'intrinsics/associated.c' || echo '$(srcdir)/'`intrinsics/associated.c
@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/associated.Tpo $(DEPDIR)/associated.Plo
Index: libgfortran/gfortran.map
===================================================================
--- libgfortran/gfortran.map (Revision 263618)
+++ libgfortran/gfortran.map (Arbeitskopie)
@@ -1483,3 +1483,8 @@ GFORTRAN_C99_8 {
y1f;
ynf;
};
+
+GFORTRAN_9 {
+ global:
+ _gfortran_st_wait_async;
+};
Index: libgfortran/io/async.c
===================================================================
--- libgfortran/io/async.c (nicht existent)
+++ libgfortran/io/async.c (Arbeitskopie)
@@ -0,0 +1,569 @@
+/* Copyright (C) 2018 Free Software Foundation, Inc.
+ Contributed by Nicolas Koenig
+
+ This file is part of the GNU Fortran runtime library (libgfortran).
+
+ Libgfortran is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 3, or (at your option)
+ any later version.
+
+ Libgfortran is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ Under Section 7 of GPL version 3, you are granted additional
+ permissions described in the GCC Runtime Library Exception, version
+ 3.1, as published by the Free Software Foundation.
+
+ You should have received a copy of the GNU General Public License and
+ a copy of the GCC Runtime Library Exception along with this program;
+ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
+ <http://www.gnu.org/licenses/>. */
+
+#include "libgfortran.h"
+
+#define _GTHREAD_USE_COND_INIT_FUNC
+#include "../../libgcc/gthr.h"
+#include "io.h"
+#include "fbuf.h"
+#include "format.h"
+#include "unix.h"
+#include <string.h>
+#include <assert.h>
+
+#include <sys/types.h>
+
+#include "async.h"
+#if ASYNC_IO
+
+DEBUG_LINE (__thread const char *aio_prefix = MPREFIX);
+
+DEBUG_LINE (__gthread_mutex_t debug_queue_lock = __GTHREAD_MUTEX_INIT;)
+DEBUG_LINE (aio_lock_debug *aio_debug_head = NULL;)
+
+/* Current unit for asynchronous I/O. Needed for error reporting. */
+
+__thread gfc_unit *thread_unit = NULL;
+
+/* Queue entry for the asynchronous I/O entry. */
+typedef struct transfer_queue
+{
+ enum aio_do type;
+ struct transfer_queue *next;
+ struct st_parameter_dt *new_pdt;
+ transfer_args arg;
+ _Bool has_id;
+ int read_flag;
+} transfer_queue;
+
+struct error {
+ st_parameter_dt *dtp;
+ int id;
+};
+
+/* Helper function to exchange the old vs. a new PDT. */
+
+static void
+update_pdt (st_parameter_dt **old, st_parameter_dt *new) {
+ st_parameter_dt *temp;
+ NOTE ("Changing pdts, current_unit = %p", (void *) (new->u.p.current_unit));
+ temp = *old;
+ *old = new;
+ if (temp)
+ free (temp);
+}
+
+/* Destroy an adv_cond structure. */
+
+static void
+destroy_adv_cond (struct adv_cond *ac)
+{
+ T_ERROR (__gthread_mutex_destroy, &ac->lock);
+ T_ERROR (__gthread_cond_destroy, &ac->signal);
+}
+
+/* Function invoked as start routine for a new asynchronous I/O unit.
+ Contains the main loop for accepting requests and handling them. */
+
+static void *
+async_io (void *arg)
+{
+ DEBUG_LINE (aio_prefix = TPREFIX);
+ transfer_queue *ctq = NULL, *prev = NULL;
+ gfc_unit *u = (gfc_unit *) arg;
+ async_unit *au = u->au;
+ LOCK (&au->lock);
+ thread_unit = u;
+ au->thread = __gthread_self ();
+ while (true)
+ {
+ /* Main loop. At this point, au->lock is always held. */
+ WAIT_SIGNAL_MUTEX (&au->work, au->tail != NULL, &au->lock);
+ LOCK (&au->lock);
+ ctq = au->head;
+ prev = NULL;
+ /* Loop over the queue entries until they are finished. */
+ while (ctq)
+ {
+ if (prev)
+ free (prev);
+ prev = ctq;
+ if (!au->error.has_error)
+ {
+ UNLOCK (&au->lock);
+
+ switch (ctq->type)
+ {
+ case AIO_WRITE_DONE:
+ NOTE ("Finalizing write");
+ st_write_done_worker (au->pdt);
+ UNLOCK (&au->io_lock);
+ break;
+
+ case AIO_READ_DONE:
+ NOTE ("Finalizing read");
+ st_read_done_worker (au->pdt);
+ UNLOCK (&au->io_lock);
+ break;
+
+ case AIO_DATA_TRANSFER_INIT:
+ NOTE ("Data transfer init");
+ LOCK (&au->io_lock);
+ update_pdt (&au->pdt, ctq->new_pdt);
+ data_transfer_init_worker (au->pdt, ctq->read_flag);
+ break;
+
+ case AIO_TRANSFER_SCALAR:
+ NOTE ("Starting scalar transfer");
+ ctq->arg.scalar.transfer (au->pdt, ctq->arg.scalar.arg_bt,
+ ctq->arg.scalar.data,
+ ctq->arg.scalar.i,
+ ctq->arg.scalar.s1,
+ ctq->arg.scalar.s2);
+ break;
+
+ case AIO_TRANSFER_ARRAY:
+ NOTE ("Starting array transfer");
+ NOTE ("ctq->arg.array.desc = %p",
+ (void *) (ctq->arg.array.desc));
+ transfer_array_inner (au->pdt, ctq->arg.array.desc,
+ ctq->arg.array.kind,
+ ctq->arg.array.charlen);
+ free (ctq->arg.array.desc);
+ break;
+
+ case AIO_CLOSE:
+ NOTE ("Received AIO_CLOSE");
+ goto finish_thread;
+
+ default:
+ internal_error (NULL, "Invalid queue type");
+ break;
+ }
+ LOCK (&au->lock);
+ if (unlikely (au->error.has_error))
+ au->error.last_good_id = au->id.low - 1;
+ }
+ else
+ {
+ if (ctq->type == AIO_WRITE_DONE || ctq->type == AIO_READ_DONE)
+ {
+ UNLOCK (&au->io_lock);
+ }
+ else if (ctq->type == AIO_CLOSE)
+ {
+ NOTE ("Received AIO_CLOSE during error condition");
+ UNLOCK (&au->lock);
+ goto finish_thread;
+ }
+ }
+
+ NOTE ("Next ctq, current id: %d", au->id.low);
+ if (ctq->has_id && au->id.waiting == au->id.low++)
+ SIGNAL (&au->id.done);
+
+ ctq = ctq->next;
+ }
+ au->tail = NULL;
+ au->head = NULL;
+ au->empty = 1;
+ UNLOCK (&au->lock);
+ SIGNAL (&au->emptysignal);
+ LOCK (&au->lock);
+ }
+ finish_thread:
+ au->tail = NULL;
+ au->head = NULL;
+ au->empty = 1;
+ SIGNAL (&au->emptysignal);
+ free (ctq);
+ return NULL;
+}
+
+/* Free an asynchronous unit. */
+
+static void
+free_async_unit (async_unit *au)
+{
+ if (au->tail)
+ internal_error (NULL, "Trying to free nonempty asynchronous unit");
+
+ destroy_adv_cond (&au->work);
+ destroy_adv_cond (&au->emptysignal);
+ destroy_adv_cond (&au->id.done);
+ T_ERROR (__gthread_mutex_destroy, &au->lock);
+ free (au);
+}
+
+/* Initialize an adv_cond structure. */
+
+static void
+init_adv_cond (struct adv_cond *ac)
+{
+ ac->pending = 0;
+ __GTHREAD_MUTEX_INIT_FUNCTION (&ac->lock);
+ __gthread_cond_init_function (&ac->signal);
+}
+
+/* Initialize an asyncronous unit, returning zero on success,
+ nonzero on failure. It also sets u->au. */
+
+void
+init_async_unit (gfc_unit *u)
+{
+ async_unit *au;
+ if (!__gthread_active_p ())
+ {
+ u->au = NULL;
+ return;
+ }
+
+ au = (async_unit *) xmalloc (sizeof (async_unit));
+ u->au = au;
+ init_adv_cond (&au->work);
+ init_adv_cond (&au->emptysignal);
+ __GTHREAD_MUTEX_INIT_FUNCTION (&au->lock);
+ __GTHREAD_MUTEX_INIT_FUNCTION (&au->io_lock);
+ LOCK (&au->lock);
+ T_ERROR (__gthread_create, &au->thread, &async_io, (void *) u);
+ au->pdt = NULL;
+ au->head = NULL;
+ au->tail = NULL;
+ au->empty = true;
+ au->id.waiting = -1;
+ au->id.low = 0;
+ au->id.high = 0;
+ au->error.fatal_error = 0;
+ au->error.has_error = 0;
+ au->error.last_good_id = 0;
+ init_adv_cond (&au->id.done);
+ UNLOCK (&au->lock);
+}
+
+/* Enqueue a transfer statement. */
+
+void
+enqueue_transfer (async_unit *au, transfer_args *arg, enum aio_do type)
+{
+ transfer_queue *tq = calloc (sizeof (transfer_queue), 1);
+ tq->arg = *arg;
+ tq->type = type;
+ tq->has_id = 0;
+ LOCK (&au->lock);
+ if (!au->tail)
+ au->head = tq;
+ else
+ au->tail->next = tq;
+ au->tail = tq;
+ REVOKE_SIGNAL (&(au->emptysignal));
+ au->empty = false;
+ UNLOCK (&au->lock);
+ SIGNAL (&au->work);
+}
+
+/* Enqueue an st_write_done or st_read_done which contains an ID. */
+
+int
+enqueue_done_id (async_unit *au, enum aio_do type)
+{
+ int ret;
+ transfer_queue *tq = calloc (sizeof (transfer_queue), 1);
+
+ tq->type = type;
+ tq->has_id = 1;
+ LOCK (&au->lock);
+ if (!au->tail)
+ au->head = tq;
+ else
+ au->tail->next = tq;
+ au->tail = tq;
+ REVOKE_SIGNAL (&(au->emptysignal));
+ au->empty = false;
+ ret = au->id.high++;
+ NOTE ("Enqueue id: %d", ret);
+ UNLOCK (&au->lock);
+ SIGNAL (&au->work);
+ return ret;
+}
+
+/* Enqueue an st_write_done or st_read_done without an ID. */
+
+void
+enqueue_done (async_unit *au, enum aio_do type)
+{
+ transfer_queue *tq = calloc (sizeof (transfer_queue), 1);
+ tq->type = type;
+ tq->has_id = 0;
+ LOCK (&au->lock);
+ if (!au->tail)
+ au->head = tq;
+ else
+ au->tail->next = tq;
+ au->tail = tq;
+ REVOKE_SIGNAL (&(au->emptysignal));
+ au->empty = false;
+ UNLOCK (&au->lock);
+ SIGNAL (&au->work);
+}
+
+/* Enqueue a CLOSE statement. */
+
+void
+enqueue_close (async_unit *au)
+{
+ transfer_queue *tq = calloc (sizeof (transfer_queue), 1);
+
+ tq->type = AIO_CLOSE;
+ LOCK (&au->lock);
+ if (!au->tail)
+ au->head = tq;
+ else
+ au->tail->next = tq;
+ au->tail = tq;
+ REVOKE_SIGNAL (&(au->emptysignal));
+ au->empty = false;
+ UNLOCK (&au->lock);
+ SIGNAL (&au->work);
+}
+
+/* The asynchronous unit keeps the currently active PDT around.
+ This function changes that to the current one. */
+
+void
+enqueue_data_transfer_init (async_unit *au, st_parameter_dt *dt, int read_flag)
+{
+ st_parameter_dt *new = xmalloc (sizeof (st_parameter_dt));
+ transfer_queue *tq = xmalloc (sizeof (transfer_queue));
+
+ memcpy ((void *) new, (void *) dt, sizeof (st_parameter_dt));
+
+ NOTE ("dt->internal_unit_desc = %p", dt->internal_unit_desc);
+ NOTE ("common.flags & mask = %d", dt->common.flags & IOPARM_LIBRETURN_MASK);
+ tq->next = NULL;
+ tq->type = AIO_DATA_TRANSFER_INIT;
+ tq->read_flag = read_flag;
+ tq->has_id = 0;
+ tq->new_pdt = new;
+ LOCK (&au->lock);
+
+ if (!au->tail)
+ au->head = tq;
+ else
+ au->tail->next = tq;
+ au->tail = tq;
+ REVOKE_SIGNAL (&(au->emptysignal));
+ au->empty = 0;
+ UNLOCK (&au->lock);
+ SIGNAL (&au->work);
+}
+
+/* Collect the errors that may have happened asynchronously. Return true if
+ an error has been encountered. */
+
+bool
+collect_async_errors (st_parameter_common *cmp, async_unit *au)
+{
+ bool has_error = au->error.has_error;
+
+ if (has_error)
+ {
+ if (generate_error_common (cmp, au->error.family, au->error.message))
+ {
+ au->error.has_error = 0;
+ au->error.cmp = NULL;
+ }
+ else
+ {
+ /* The program will exit later. */
+ au->error.fatal_error = true;
+ }
+ }
+ return has_error;
+}
+
+/* Perform a wait operation on an asynchronous unit with an ID specified,
+ which means collecting the errors that may have happened asynchronously.
+ Return true if an error has been encountered. */
+
+bool
+async_wait_id (st_parameter_common *cmp, async_unit *au, int i)
+{
+ bool ret;
+
+ if (au == NULL)
+ return false;
+
+ if (cmp == NULL)
+ cmp = au->error.cmp;
+
+ if (au->error.has_error)
+ {
+ if (i <= au->error.last_good_id)
+ return false;
+
+ return collect_async_errors (cmp, au);
+ }
+
+ LOCK (&au->lock);
+ NOTE ("Waiting for id %d", i);
+ if (au->id.waiting < i)
+ au->id.waiting = i;
+ UNLOCK (&au->lock);
+ SIGNAL (&(au->work));
+ LOCK (&au->lock);
+ WAIT_SIGNAL_MUTEX (&(au->id.done),
+ (au->id.low >= au->id.waiting || au->empty), &au->lock);
+ LOCK (&au->lock);
+ ret = collect_async_errors (cmp, au);
+ UNLOCK (&au->lock);
+ return ret;
+}
+
+/* Perform a wait operation an an asynchronous unit without an ID. */
+
+bool
+async_wait (st_parameter_common *cmp, async_unit *au)
+{
+ bool ret;
+
+ if (au == NULL)
+ return false;
+
+ if (cmp == NULL)
+ cmp = au->error.cmp;
+
+ SIGNAL (&(au->work));
+ LOCK (&(au->lock));
+
+ if (au->empty)
+ {
+ ret = collect_async_errors (cmp, au);
+ UNLOCK (&au->lock);
+ return ret;
+ }
+
+ WAIT_SIGNAL_MUTEX (&(au->emptysignal), (au->empty), &au->lock);
+ ret = collect_async_errors (cmp, au);
+ return ret;
+}
+
+/* Close an asynchronous unit. */
+
+void
+async_close (async_unit *au)
+{
+ if (au == NULL)
+ return;
+
+ NOTE ("Closing async unit");
+ enqueue_close (au);
+ T_ERROR (__gthread_join, au->thread, NULL);
+ free_async_unit (au);
+}
+
+#else
+
+/* Only set u->au to NULL so no async I/O will happen. */
+
+void
+init_async_unit (gfc_unit *u)
+{
+ u->au = NULL;
+ return;
+}
+
+/* Do-nothing function, which will not be called. */
+
+void
+enqueue_transfer (async_unit *au, transfer_args *arg, enum aio_do type)
+{
+ return;
+}
+
+/* Do-nothing function, which will not be called. */
+
+int
+enqueue_done_id (async_unit *au, enum aio_do type)
+{
+ return 0;
+}
+
+/* Do-nothing function, which will not be called. */
+
+void
+enqueue_done (async_unit *au, enum aio_do type)
+{
+ return;
+}
+
+/* Do-nothing function, which will not be called. */
+
+void
+enqueue_close (async_unit *au)
+{
+ return;
+}
+
+/* Do-nothing function, which will not be called. */
+
+void
+enqueue_data_transfer_init (async_unit *au, st_parameter_dt *dt, int read_flag)
+{
+ return;
+}
+
+/* Do-nothing function, which will not be called. */
+
+bool
+collect_async_errors (st_parameter_common *cmp, async_unit *au)
+{
+ return false;
+}
+
+/* Do-nothing function, which will not be called. */
+
+bool
+async_wait_id (st_parameter_common *cmp, async_unit *au, int i)
+{
+ return false;
+}
+
+/* Do-nothing function, which will not be called. */
+
+bool
+async_wait (st_parameter_common *cmp, async_unit *au)
+{
+ return false;
+}
+
+/* Do-nothing function, which will not be called. */
+
+void
+async_close (async_unit *au)
+{
+ return;
+}
+
+#endif
Index: libgfortran/io/async.h
===================================================================
--- libgfortran/io/async.h (nicht existent)
+++ libgfortran/io/async.h (Arbeitskopie)
@@ -0,0 +1,400 @@
+/* Copyright (C) 2018 Free Software Foundation, Inc.
+ Contributed by Nicolas Koenig
+
+ This file is part of the GNU Fortran runtime library (libgfortran).
+
+ Libgfortran is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 3, or (at your option)
+ any later version.
+
+ Libgfortran is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ Under Section 7 of GPL version 3, you are granted additional
+ permissions described in the GCC Runtime Library Exception, version
+ 3.1, as published by the Free Software Foundation.
+
+ You should have received a copy of the GNU General Public License and
+ a copy of the GCC Runtime Library Exception along with this program;
+ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
+ <http://www.gnu.org/licenses/>. */
+
+#ifndef ASYNC_H
+#define ASYNC_H
+
+/* Async I/O will not work on targets which do not support
+ __gthread_cond_t and __gthread_equal / __gthread_self. Check
+ this. */
+
+#if defined(__GTHREAD_HAS_COND) && defined(__GTHREADS_CXX0X) && !defined(__ARMEB__)
+#define ASYNC_IO 1
+#else
+#define ASYNC_IO 0
+#endif
+
+/* Defining DEBUG_ASYNC will enable somewhat verbose debugging
+ output for async I/O. */
+
+#define DEBUG_ASYNC
+#undef DEBUG_ASYNC
+
+#ifdef DEBUG_ASYNC
+
+/* Define this if you want to use ANSI color escape sequences in your
+ debugging output. */
+
+#define DEBUG_COLOR
+
+#ifdef DEBUG_COLOR
+#define MPREFIX "\033[30;46mM:\033[0m "
+#define TPREFIX "\033[37;44mT:\033[0m "
+#define RPREFIX "\033[37;41mR:\033[0m "
+#define DEBUG_RED "\033[31m"
+#define DEBUG_ORANGE "\033[33m"
+#define DEBUG_GREEN "\033[32m"
+#define DEBUG_DARKRED "\033[31;2m"
+#define DEBUG_PURPLE "\033[35m"
+#define DEBUG_NORM "\033[0m"
+#define DEBUG_REVERSE_RED "\033[41;37m"
+#define DEBUG_BLUE "\033[34m"
+
+#else
+
+#define MPREFIX "M: "
+#define TPREFIX "T: "
+#define RPREFIX ""
+#define DEBUG_RED ""
+#define DEBUG_ORANGE ""
+#define DEBUG_GREEN ""
+#define DEBUG_DARKRED ""
+#define DEBUG_PURPLE ""
+#define DEBUG_NORM ""
+#define DEBUG_REVERSE_RED ""
+#define DEBUG_BLUE ""
+
+#endif
+
+#define DEBUG_PRINTF(...) fprintf (stderr,__VA_ARGS__)
+
+#define IN_DEBUG_QUEUE(mutex) ({ \
+ __label__ end; \
+ aio_lock_debug *curr = aio_debug_head; \
+ while (curr) { \
+ if (curr->m == mutex) { \
+ goto end; \
+ } \
+ curr = curr->next; \
+ } \
+ end:; \
+ curr; \
+ })
+
+#define TAIL_DEBUG_QUEUE ({ \
+ aio_lock_debug *curr = aio_debug_head; \
+ while (curr && curr->next) { \
+ curr = curr->next; \
+ } \
+ curr; \
+ })
+
+#define CHECK_LOCK(mutex, status) do { \
+ aio_lock_debug *curr; \
+ INTERN_LOCK (&debug_queue_lock); \
+ if (__gthread_mutex_trylock (mutex)) { \
+ 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 { \
+ __gthread_mutex_unlock (mutex); \
+ sprintf (status, DEBUG_GREEN "unlocked" DEBUG_NORM); \
+ } \
+ INTERN_UNLOCK (&debug_queue_lock); \
+ }while (0)
+
+#define T_ERROR(func, ...) do { \
+ int t_error_temp; \
+ t_error_temp = func(__VA_ARGS__); \
+ if (t_error_temp) \
+ ERROR (t_error_temp, "args: " #__VA_ARGS__ "\n"); \
+ } while (0)
+
+#define NOTE(str, ...) do{ \
+ char note_str[200]; \
+ sprintf (note_str, "%s" DEBUG_PURPLE "NOTE: " DEBUG_NORM str, aio_prefix, ##__VA_ARGS__); \
+ DEBUG_PRINTF ("%-90s %20s():%-5d\n", note_str, __FUNCTION__, __LINE__); \
+ }while (0);
+
+#define ERROR(errnum, str, ...) do{ \
+ char note_str[200]; \
+ sprintf (note_str, "%s" DEBUG_REVERSE_RED "ERROR:" DEBUG_NORM " [%d] " str, aio_prefix, \
+ errnum, ##__VA_ARGS__); \
+ DEBUG_PRINTF ("%-68s %s():%-5d\n", note_str, __FUNCTION__, __LINE__); \
+ }while (0)
+
+#define MUTEX_DEBUG_ADD(mutex) do { \
+ aio_lock_debug *n; \
+ n = malloc (sizeof(aio_lock_debug)); \
+ n->prev = TAIL_DEBUG_QUEUE; \
+ if (n->prev) \
+ n->prev->next = n; \
+ n->next = NULL; \
+ n->line = __LINE__; \
+ n->func = __FUNCTION__; \
+ n->m = mutex; \
+ if (!aio_debug_head) { \
+ aio_debug_head = n; \
+ } \
+ } while (0)
+
+#define UNLOCK(mutex) do { \
+ aio_lock_debug *curr; \
+ DEBUG_PRINTF ("%s%-75s %20s():%-5d %18p\n", aio_prefix, DEBUG_GREEN "UNLOCK: " DEBUG_NORM #mutex, \
+ __FUNCTION__, __LINE__, (void *) mutex); \
+ INTERN_LOCK (&debug_queue_lock); \
+ curr = IN_DEBUG_QUEUE (mutex); \
+ if (curr) \
+ { \
+ if (curr->prev) \
+ curr->prev->next = curr->next; \
+ if (curr->next) { \
+ curr->next->prev = curr->prev; \
+ if (curr == aio_debug_head) \
+ aio_debug_head = curr->next; \
+ } else { \
+ if (curr == aio_debug_head) \
+ aio_debug_head = NULL; \
+ } \
+ free (curr); \
+ } \
+ INTERN_UNLOCK (&debug_queue_lock); \
+ INTERN_UNLOCK (mutex); \
+ }while (0)
+
+#define TRYLOCK(mutex) ({ \
+ char status[200]; \
+ int res; \
+ aio_lock_debug *curr; \
+ 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 #mutex, status, __FUNCTION__, __LINE__, \
+ (void *) mutex); \
+ INTERN_UNLOCK (&debug_queue_lock); \
+ res; \
+ })
+
+#define LOCK(mutex) do { \
+ char status[200]; \
+ CHECK_LOCK (mutex, status); \
+ DEBUG_PRINTF ("%s%-42s prev: %-35s %20s():%-5d %18p\n", aio_prefix, \
+ DEBUG_RED "LOCK: " DEBUG_NORM #mutex, status, __FUNCTION__, __LINE__, (void *) mutex); \
+ INTERN_LOCK (mutex); \
+ INTERN_LOCK (&debug_queue_lock); \
+ MUTEX_DEBUG_ADD (mutex); \
+ INTERN_UNLOCK (&debug_queue_lock); \
+ DEBUG_PRINTF ("%s" DEBUG_RED "ACQ:" DEBUG_NORM " %-30s %78p\n", aio_prefix, #mutex, mutex); \
+ } while (0)
+
+#define DEBUG_LINE(...) __VA_ARGS__
+
+#else
+#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)
+#define UNLOCK(mutex) INTERN_UNLOCK (mutex)
+#define TRYLOCK(mutex) (__gthread_mutex_trylock (mutex))
+#endif
+
+#define INTERN_LOCK(mutex) T_ERROR (__gthread_mutex_lock, mutex);
+
+#define INTERN_UNLOCK(mutex) T_ERROR (__gthread_mutex_unlock, mutex);
+
+#if ASYNC_IO
+
+#define SIGNAL(advcond) do{ \
+ INTERN_LOCK (&(advcond)->lock); \
+ (advcond)->pending = 1; \
+ DEBUG_PRINTF ("%s%-75s %20s():%-5d %18p\n", aio_prefix, DEBUG_ORANGE "SIGNAL: " DEBUG_NORM \
+ #advcond, __FUNCTION__, __LINE__, (void *) advcond); \
+ T_ERROR (__gthread_cond_broadcast, &(advcond)->signal); \
+ INTERN_UNLOCK (&(advcond)->lock); \
+ } while (0)
+
+#define WAIT_SIGNAL_MUTEX(advcond, condition, mutex) do{ \
+ __label__ finish; \
+ INTERN_LOCK (&((advcond)->lock)); \
+ DEBUG_PRINTF ("%s%-75s %20s():%-5d %18p\n", aio_prefix, DEBUG_BLUE "WAITING: " DEBUG_NORM \
+ #advcond, __FUNCTION__, __LINE__, (void *) advcond); \
+ if ((advcond)->pending || (condition)){ \
+ UNLOCK (mutex); \
+ goto finish; \
+ } \
+ UNLOCK (mutex); \
+ while (!__gthread_cond_wait(&(advcond)->signal, &(advcond)->lock)) { \
+ { int cond; \
+ LOCK (mutex); cond = condition; UNLOCK (mutex); \
+ if (cond){ \
+ DEBUG_PRINTF ("%s%-75s %20s():%-5d %18p\n", aio_prefix, DEBUG_ORANGE "REC: " DEBUG_NORM \
+ #advcond, __FUNCTION__, __LINE__, (void *)advcond); \
+ break; \
+ } \
+ } \
+ } \
+ finish: \
+ (advcond)->pending = 0; \
+ INTERN_UNLOCK (&((advcond)->lock)); \
+ } while (0)
+
+#define REVOKE_SIGNAL(advcond) do{ \
+ INTERN_LOCK (&(advcond)->lock); \
+ (advcond)->pending = 0; \
+ INTERN_UNLOCK (&(advcond)->lock); \
+ } while (0)
+
+#else
+
+#define SIGNAL(advcond) do{} while(0)
+#define WAIT_SIGNAL_MUTEX(advcond, condition, mutex) do{} while(0)
+#define REVOKE_SIGNAL(advcond) do{} while(0)
+
+#endif
+
+#if ASYNC_IO
+DEBUG_LINE (extern __thread const char *aio_prefix);
+
+DEBUG_LINE (typedef struct aio_lock_debug{
+ __gthread_mutex_t *m;
+ int line;
+ const char *func;
+ struct aio_lock_debug *next;
+ struct aio_lock_debug *prev;
+} aio_lock_debug;)
+
+DEBUG_LINE (extern aio_lock_debug *aio_debug_head;)
+DEBUG_LINE (extern __gthread_mutex_t debug_queue_lock;)
+
+/* Thread - local storage of the current unit we are looking at. Needed for
+ error reporting. */
+
+extern __thread gfc_unit *thread_unit;
+#endif
+
+enum aio_do {
+ AIO_INVALID = 0,
+ AIO_DATA_TRANSFER_INIT,
+ AIO_TRANSFER_SCALAR,
+ AIO_TRANSFER_ARRAY,
+ AIO_WRITE_DONE,
+ AIO_READ_DONE,
+ AIO_CLOSE
+};
+
+typedef union transfer_args
+{
+ struct
+ {
+ void (*transfer) (struct st_parameter_dt *, bt, void *, int, size_t, size_t);
+ bt arg_bt;
+ void *data;
+ int i;
+ size_t s1;
+ size_t s2;
+ } scalar;
+ struct
+ {
+ gfc_array_char *desc;
+ int kind;
+ gfc_charlen_type charlen;
+ } array;
+} transfer_args;
+
+struct adv_cond
+{
+ int pending;
+ __gthread_mutex_t lock;
+ __gthread_cond_t signal;
+};
+
+typedef struct async_unit
+{
+ pthread_mutex_t lock; /* Lock for manipulating the queue structure. */
+ pthread_mutex_t io_lock; /* Lock for doing actual I/O. */
+ struct adv_cond work;
+ struct adv_cond emptysignal;
+ struct st_parameter_dt *pdt;
+ pthread_t thread;
+ struct transfer_queue *head;
+ struct transfer_queue *tail;
+ struct
+ {
+ int waiting;
+ int low;
+ int high;
+ struct adv_cond done;
+ } id;
+
+ bool empty;
+
+ struct {
+ const char *message;
+ st_parameter_common *cmp;
+ bool has_error;
+ int last_good_id;
+ int family;
+ bool fatal_error;
+ } error;
+
+} async_unit;
+
+void init_async_unit (gfc_unit *);
+internal_proto (init_async_unit);
+
+bool async_wait (st_parameter_common *, async_unit *);
+internal_proto (async_wait);
+
+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);
+
+void async_close (async_unit *);
+internal_proto (async_close);
+
+void enqueue_transfer (async_unit * au, transfer_args * arg, enum aio_do);
+internal_proto (enqueue_transfer);
+
+void enqueue_done (async_unit *, enum aio_do type);
+internal_proto (enqueue_done);
+
+int enqueue_done_id (async_unit *, enum aio_do type);
+internal_proto (enqueue_done_id);
+
+void enqueue_init (async_unit *);
+internal_proto (enqueue_init);
+
+void enqueue_data_transfer_init (async_unit *, st_parameter_dt *, int);
+internal_proto (enqueue_data_transfer_init);
+
+void enqueue_close (async_unit *);
+internal_proto (enqueue_close);
+
+#endif
Index: libgfortran/io/close.c
===================================================================
--- libgfortran/io/close.c (Revision 263618)
+++ libgfortran/io/close.c (Arbeitskopie)
@@ -24,6 +24,7 @@ see the files COPYING3 and COPYING.RUNTIME respect
#include "io.h"
#include "unix.h"
+#include "async.h"
#include <limits.h>
typedef enum
@@ -57,6 +58,15 @@ st_close (st_parameter_close *clp)
find_option (&clp->common, clp->status, clp->status_len,
status_opt, "Bad STATUS parameter in CLOSE statement");
+ u = find_unit (clp->common.unit);
+
+ if (ASYNC_IO && u && u->au)
+ if (async_wait (&(clp->common), u->au))
+ {
+ library_end ();
+ return;
+ }
+
if ((clp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
{
library_end ();
@@ -63,7 +73,6 @@ st_close (st_parameter_close *clp)
return;
}
- u = find_unit (clp->common.unit);
if (u != NULL)
{
if (close_share (u) < 0)
Index: libgfortran/io/file_pos.c
===================================================================
--- libgfortran/io/file_pos.c (Revision 263618)
+++ libgfortran/io/file_pos.c (Arbeitskopie)
@@ -25,6 +25,7 @@ see the files COPYING3 and COPYING.RUNTIME respect
#include "io.h"
#include "fbuf.h"
#include "unix.h"
+#include "async.h"
#include <string.h>
/* file_pos.c-- Implement the file positioning statements, i.e. BACKSPACE,
@@ -187,6 +188,7 @@ void
st_backspace (st_parameter_filepos *fpp)
{
gfc_unit *u;
+ bool needs_unlock = false;
library_start (&fpp->common);
@@ -214,6 +216,17 @@ st_backspace (st_parameter_filepos *fpp)
goto done;
}
+ if (ASYNC_IO && u->au)
+ {
+ if (async_wait (&(fpp->common), u->au))
+ return;
+ else
+ {
+ needs_unlock = true;
+ LOCK (&u->au->io_lock);
+ }
+ }
+
/* Make sure format buffer is flushed and reset. */
if (u->flags.form == FORM_FORMATTED)
{
@@ -267,8 +280,13 @@ st_backspace (st_parameter_filepos *fpp)
done:
if (u != NULL)
- unlock_unit (u);
+ {
+ unlock_unit (u);
+ if (ASYNC_IO && u->au && needs_unlock)
+ UNLOCK (&u->au->io_lock);
+ }
+
library_end ();
}
@@ -280,6 +298,7 @@ void
st_endfile (st_parameter_filepos *fpp)
{
gfc_unit *u;
+ bool needs_unlock = false;
library_start (&fpp->common);
@@ -294,6 +313,17 @@ st_endfile (st_parameter_filepos *fpp)
goto done;
}
+ if (ASYNC_IO && u->au)
+ {
+ if (async_wait (&(fpp->common), u->au))
+ return;
+ else
+ {
+ needs_unlock = true;
+ LOCK (&u->au->io_lock);
+ }
+ }
+
if (u->flags.access == ACCESS_SEQUENTIAL
&& u->endfile == AFTER_ENDFILE)
{
@@ -376,9 +406,12 @@ st_endfile (st_parameter_filepos *fpp)
}
}
- done:
- unlock_unit (u);
+ done:
+ if (ASYNC_IO && u->au && needs_unlock)
+ UNLOCK (&u->au->io_lock);
+ unlock_unit (u);
+
library_end ();
}
@@ -390,6 +423,7 @@ void
st_rewind (st_parameter_filepos *fpp)
{
gfc_unit *u;
+ bool needs_unlock = true;
library_start (&fpp->common);
@@ -401,6 +435,17 @@ st_rewind (st_parameter_filepos *fpp)
"Cannot REWIND a file opened for DIRECT access");
else
{
+ if (ASYNC_IO && u->au)
+ {
+ if (async_wait (&(fpp->common), u->au))
+ return;
+ else
+ {
+ needs_unlock = true;
+ LOCK (&u->au->io_lock);
+ }
+ }
+
/* If there are previously written bytes from a write with ADVANCE="no",
add a record marker before performing the ENDFILE. */
@@ -436,6 +481,10 @@ st_rewind (st_parameter_filepos *fpp)
}
/* Update position for INQUIRE. */
u->flags.position = POSITION_REWIND;
+
+ if (ASYNC_IO && u->au && needs_unlock)
+ UNLOCK (&u->au->io_lock);
+
unlock_unit (u);
}
@@ -450,6 +499,7 @@ void
st_flush (st_parameter_filepos *fpp)
{
gfc_unit *u;
+ bool needs_unlock = false;
library_start (&fpp->common);
@@ -456,6 +506,17 @@ st_flush (st_parameter_filepos *fpp)
u = find_unit (fpp->common.unit);
if (u != NULL)
{
+ if (ASYNC_IO && u->au)
+ {
+ if (async_wait (&(fpp->common), u->au))
+ return;
+ else
+ {
+ needs_unlock = true;
+ LOCK (&u->au->io_lock);
+ }
+ }
+
/* Make sure format buffer is flushed. */
if (u->flags.form == FORM_FORMATTED)
fbuf_flush (u, u->mode);
@@ -469,5 +530,8 @@ st_flush (st_parameter_filepos *fpp)
generate_error (&fpp->common, LIBERROR_BAD_OPTION,
"Specified UNIT in FLUSH is not connected");
+ if (needs_unlock)
+ UNLOCK (&u->au->io_lock);
+
library_end ();
}
Index: libgfortran/io/inquire.c
===================================================================
--- libgfortran/io/inquire.c (Revision 263618)
+++ libgfortran/io/inquire.c (Arbeitskopie)
@@ -26,6 +26,7 @@ see the files COPYING3 and COPYING.RUNTIME respect
/* Implement the non-IOLENGTH variant of the INQUIRY statement */
#include "io.h"
+#include "async.h"
#include "unix.h"
#include <string.h>
@@ -281,12 +282,6 @@ inquire_via_unit (st_parameter_inquire *iqp, gfc_u
{
GFC_INTEGER_4 cf2 = iqp->flags2;
- if ((cf2 & IOPARM_INQUIRE_HAS_PENDING) != 0)
- *iqp->pending = 0;
-
- if ((cf2 & IOPARM_INQUIRE_HAS_ID) != 0)
- *iqp->id = 0;
-
if ((cf2 & IOPARM_INQUIRE_HAS_ENCODING) != 0)
{
if (u == NULL || u->flags.form != FORM_FORMATTED)
@@ -332,21 +327,43 @@ inquire_via_unit (st_parameter_inquire *iqp, gfc_u
if (u == NULL)
p = undefined;
else
- switch (u->flags.async)
{
- case ASYNC_YES:
- p = yes;
- break;
- case ASYNC_NO:
- p = no;
- break;
- default:
- internal_error (&iqp->common, "inquire_via_unit(): Bad async");
+ switch (u->flags.async)
+ {
+ case ASYNC_YES:
+ p = yes;
+ break;
+ case ASYNC_NO:
+ p = no;
+ break;
+ default:
+ internal_error (&iqp->common, "inquire_via_unit(): Bad async");
+ }
}
-
cf_strcpy (iqp->asynchronous, iqp->asynchronous_len, p);
}
+ if ((cf2 & IOPARM_INQUIRE_HAS_PENDING) != 0)
+ {
+ if (!ASYNC_IO || u->au == NULL)
+ *(iqp->pending) = 0;
+ else
+ {
+ LOCK (&(u->au->lock));
+ if ((cf2 & IOPARM_INQUIRE_HAS_ID) != 0)
+ {
+ int id;
+ id = *(iqp->id);
+ *(iqp->pending) = id > u->au->id.low;
+ }
+ else
+ {
+ *(iqp->pending) = ! u->au->empty;
+ }
+ UNLOCK (&(u->au->lock));
+ }
+ }
+
if ((cf2 & IOPARM_INQUIRE_HAS_SIGN) != 0)
{
if (u == NULL)
Index: libgfortran/io/io.h
===================================================================
--- libgfortran/io/io.h (Revision 263618)
+++ libgfortran/io/io.h (Arbeitskopie)
@@ -531,7 +531,9 @@ typedef struct st_parameter_dt
/* A flag used to identify when a non-standard expanded namelist read
has occurred. */
unsigned expanded_read : 1;
- /* 13 unused bits. */
+ /* Flag to indicate if the statement has async="YES". */
+ unsigned async : 1;
+ /* 12 unused bits. */
int child_saved_iostat;
int nml_delim;
@@ -590,7 +592,7 @@ extern char check_st_parameter_dt[sizeof (((st_par
typedef struct
{
st_parameter_common common;
- CHARACTER1 (id);
+ GFC_INTEGER_4 *id;
}
st_parameter_wait;
@@ -659,6 +661,9 @@ typedef struct gfc_unit
int continued;
+ /* Contains the pointer to the async unit. */
+ struct async_unit *au;
+
__gthread_mutex_t lock;
/* Number of threads waiting to acquire this unit's lock.
When non-zero, close_unit doesn't only removes the unit
@@ -815,11 +820,18 @@ extern void next_record (st_parameter_dt *, int);
internal_proto(next_record);
extern void st_wait (st_parameter_wait *);
-export_proto(st_wait);
+export_proto (st_wait);
+extern void st_wait_async (st_parameter_wait *);
+export_proto (st_wait_async);
+
extern void hit_eof (st_parameter_dt *);
internal_proto(hit_eof);
+extern void transfer_array_inner (st_parameter_dt *, gfc_array_char *, int,
+ gfc_charlen_type);
+internal_proto (transfer_array_inner);
+
/* read.c */
extern void set_integer (void *, GFC_INTEGER_LARGEST, int);
@@ -988,3 +1000,14 @@ memset4 (gfc_char4_t *p, gfc_char4_t c, int k)
#endif
+extern void
+st_write_done_worker (st_parameter_dt *);
+internal_proto (st_write_done_worker);
+
+extern void
+st_read_done_worker (st_parameter_dt *);
+internal_proto (st_read_done_worker);
+
+extern void
+data_transfer_init_worker (st_parameter_dt *, int);
+internal_proto (data_transfer_init_worker);
Index: libgfortran/io/open.c
===================================================================
--- libgfortran/io/open.c (Revision 263618)
+++ libgfortran/io/open.c (Arbeitskopie)
@@ -26,6 +26,7 @@ see the files COPYING3 and COPYING.RUNTIME respect
#include "io.h"
#include "fbuf.h"
#include "unix.h"
+#include "async.h"
#ifdef HAVE_UNISTD_H
#include <unistd.h>
@@ -651,8 +652,12 @@ new_unit (st_parameter_open *opp, gfc_unit *u, uni
else
u->fbuf = NULL;
-
-
+ /* Check if asynchrounous. */
+ if (flags->async == ASYNC_YES)
+ init_async_unit (u);
+ else
+ u->au = NULL;
+
return u;
cleanup:
Index: libgfortran/io/read.c
===================================================================
--- libgfortran/io/read.c (Revision 263618)
+++ libgfortran/io/read.c (Arbeitskopie)
@@ -30,6 +30,7 @@ see the files COPYING3 and COPYING.RUNTIME respect
#include <string.h>
#include <ctype.h>
#include <assert.h>
+#include "async.h"
typedef unsigned char uchar;
@@ -42,6 +43,7 @@ typedef unsigned char uchar;
void
set_integer (void *dest, GFC_INTEGER_LARGEST value, int length)
{
+ NOTE ("set_integer: %lld %p", (long long int) value, dest);
switch (length)
{
#ifdef HAVE_GFC_INTEGER_16
Index: libgfortran/io/transfer.c
===================================================================
--- libgfortran/io/transfer.c (Revision 263618)
+++ libgfortran/io/transfer.c (Arbeitskopie)
@@ -31,6 +31,7 @@ see the files COPYING3 and COPYING.RUNTIME respect
#include "fbuf.h"
#include "format.h"
#include "unix.h"
+#include "async.h"
#include <string.h>
#include <errno.h>
@@ -184,6 +185,12 @@ static const st_option pad_opt[] = {
{NULL, 0}
};
+static const st_option async_opt[] = {
+ {"yes", ASYNC_YES},
+ {"no", ASYNC_NO},
+ {NULL, 0}
+};
+
typedef enum
{ FORMATTED_SEQUENTIAL, UNFORMATTED_SEQUENTIAL,
FORMATTED_DIRECT, UNFORMATTED_DIRECT, FORMATTED_STREAM, UNFORMATTED_STREAM
@@ -1594,7 +1601,8 @@ formatted_transfer_scalar_read (st_parameter_dt *d
read_f (dtp, f, p, kind);
break;
default:
- internal_error (&dtp->common, "formatted_transfer(): Bad type");
+ internal_error (&dtp->common,
+ "formatted_transfer (): Bad type");
}
break;
@@ -2066,7 +2074,7 @@ formatted_transfer_scalar_write (st_parameter_dt *
break;
default:
internal_error (&dtp->common,
- "formatted_transfer(): Bad type");
+ "formatted_transfer (): Bad type");
}
break;
@@ -2281,7 +2289,39 @@ formatted_transfer (st_parameter_dt *dtp, bt type,
}
}
+/* Wrapper function for I/O of scalar types. If this should be an async I/O
+ request, queue it. For a synchronous write on an async unit, perform the
+ wait operation and return an error. For all synchronous writes, call the
+ right transfer function. */
+static void
+wrap_scalar_transfer (st_parameter_dt *dtp, bt type, void *p, int kind,
+ size_t size, size_t n_elem)
+{
+ if (dtp->u.p.current_unit && dtp->u.p.current_unit->au)
+ {
+ if (dtp->u.p.async)
+ {
+ transfer_args args;
+ args.scalar.transfer = dtp->u.p.transfer;
+ args.scalar.arg_bt = type;
+ args.scalar.data = p;
+ args.scalar.i = kind;
+ args.scalar.s1 = size;
+ args.scalar.s2 = n_elem;
+ enqueue_transfer (dtp->u.p.current_unit->au, &args,
+ AIO_TRANSFER_SCALAR);
+ return;
+ }
+ }
+ /* Come here if there was no asynchronous I/O to be scheduled. */
+ if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
+ return;
+
+ dtp->u.p.transfer (dtp, type, p, kind, size, 1);
+}
+
+
/* Data transfer entry points. The type of the data entity is
implicit in the subroutine call. This prevents us from having to
share a common enum with the compiler. */
@@ -2289,9 +2329,7 @@ formatted_transfer (st_parameter_dt *dtp, bt type,
void
transfer_integer (st_parameter_dt *dtp, void *p, int kind)
{
- if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
- return;
- dtp->u.p.transfer (dtp, BT_INTEGER, p, kind, kind, 1);
+ wrap_scalar_transfer (dtp, BT_INTEGER, p, kind, kind, 1);
}
void
@@ -2307,7 +2345,7 @@ transfer_real (st_parameter_dt *dtp, void *p, int
if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
return;
size = size_from_real_kind (kind);
- dtp->u.p.transfer (dtp, BT_REAL, p, kind, size, 1);
+ wrap_scalar_transfer (dtp, BT_REAL, p, kind, size, 1);
}
void
@@ -2319,9 +2357,7 @@ transfer_real_write (st_parameter_dt *dtp, void *p
void
transfer_logical (st_parameter_dt *dtp, void *p, int kind)
{
- if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
- return;
- dtp->u.p.transfer (dtp, BT_LOGICAL, p, kind, kind, 1);
+ wrap_scalar_transfer (dtp, BT_LOGICAL, p, kind, kind, 1);
}
void
@@ -2345,7 +2381,7 @@ transfer_character (st_parameter_dt *dtp, void *p,
p = empty_string;
/* Set kind here to 1. */
- dtp->u.p.transfer (dtp, BT_CHARACTER, p, 1, len, 1);
+ wrap_scalar_transfer (dtp, BT_CHARACTER, p, 1, len, 1);
}
void
@@ -2369,7 +2405,7 @@ transfer_character_wide (st_parameter_dt *dtp, voi
p = empty_string;
/* Here we pass the actual kind value. */
- dtp->u.p.transfer (dtp, BT_CHARACTER, p, kind, len, 1);
+ wrap_scalar_transfer (dtp, BT_CHARACTER, p, kind, len, 1);
}
void
@@ -2385,7 +2421,7 @@ transfer_complex (st_parameter_dt *dtp, void *p, i
if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
return;
size = size_from_complex_kind (kind);
- dtp->u.p.transfer (dtp, BT_COMPLEX, p, kind, size, 1);
+ wrap_scalar_transfer (dtp, BT_COMPLEX, p, kind, size, 1);
}
void
@@ -2395,8 +2431,8 @@ transfer_complex_write (st_parameter_dt *dtp, void
}
void
-transfer_array (st_parameter_dt *dtp, gfc_array_char *desc, int kind,
- gfc_charlen_type charlen)
+transfer_array_inner (st_parameter_dt *dtp, gfc_array_char *desc, int kind,
+ gfc_charlen_type charlen)
{
index_type count[GFC_MAX_DIMENSIONS];
index_type extent[GFC_MAX_DIMENSIONS];
@@ -2407,7 +2443,7 @@ void
bt iotype;
/* Adjust item_count before emitting error message. */
-
+
if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
return;
@@ -2471,6 +2507,36 @@ void
}
void
+transfer_array (st_parameter_dt *dtp, gfc_array_char *desc, int kind,
+ gfc_charlen_type charlen)
+{
+ if ((dtp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
+ return;
+
+ if (dtp->u.p.current_unit && dtp->u.p.current_unit->au)
+ {
+ if (dtp->u.p.async)
+ {
+ transfer_args args;
+ size_t sz = sizeof (gfc_array_char)
+ + sizeof (descriptor_dimension)
+ * GFC_DESCRIPTOR_RANK (desc);
+ args.array.desc = xmalloc (sz);
+ NOTE ("desc = %p", (void *) args.array.desc);
+ memcpy (args.array.desc, desc, sz);
+ args.array.kind = kind;
+ args.array.charlen = charlen;
+ enqueue_transfer (dtp->u.p.current_unit->au, &args,
+ AIO_TRANSFER_ARRAY);
+ return;
+ }
+ }
+ /* Come here if there was no asynchronous I/O to be scheduled. */
+ transfer_array_inner (dtp, desc, kind, charlen);
+}
+
+
+void
transfer_array_write (st_parameter_dt *dtp, gfc_array_char *desc, int kind,
gfc_charlen_type charlen)
{
@@ -2492,7 +2558,7 @@ transfer_derived (st_parameter_dt *parent, void *d
else
parent->u.p.fdtio_ptr = (formatted_dtio) dtio_proc;
}
- parent->u.p.transfer (parent, BT_CLASS, dtio_source, 0, 0, 1);
+ wrap_scalar_transfer (parent, BT_CLASS, dtio_source, 0, 0, 1);
}
@@ -2667,7 +2733,10 @@ data_transfer_init (st_parameter_dt *dtp, int read
unit_flags u_flags; /* Used for creating a unit if needed. */
GFC_INTEGER_4 cf = dtp->common.flags;
namelist_info *ionml;
+ async_unit *au;
+ NOTE ("data_transfer_init");
+
ionml = ((cf & IOPARM_DT_IONML_SET) != 0) ? dtp->u.p.ionml : NULL;
memset (&dtp->u.p, 0, sizeof (dtp->u.p));
@@ -2693,9 +2762,9 @@ data_transfer_init (st_parameter_dt *dtp, int read
}
else if (dtp->u.p.current_unit->s == NULL)
{ /* Open the unit with some default flags. */
- st_parameter_open opp;
- unit_convert conv;
-
+ st_parameter_open opp;
+ unit_convert conv;
+ NOTE ("Open the unit with some default flags.");
memset (&u_flags, '\0', sizeof (u_flags));
u_flags.access = ACCESS_SEQUENTIAL;
u_flags.action = ACTION_READWRITE;
@@ -2770,6 +2839,42 @@ data_transfer_init (st_parameter_dt *dtp, int read
else if (dtp->u.p.current_unit->internal_unit_kind > 0)
dtp->u.p.unit_is_internal = 1;
+ if ((cf & IOPARM_DT_HAS_ASYNCHRONOUS) != 0)
+ {
+ int f;
+ f = find_option (&dtp->common, dtp->asynchronous, dtp->asynchronous_len,
+ async_opt, "Bad ASYNCHRONOUS in data transfer "
+ "statement");
+ if (f == ASYNC_YES && dtp->u.p.current_unit->flags.async != ASYNC_YES)
+ {
+ generate_error (&dtp->common, LIBERROR_OPTION_CONFLICT,
+ "ASYNCHRONOUS transfer without "
+ "ASYHCRONOUS='YES' in OPEN");
+ return;
+ }
+ dtp->u.p.async = f == ASYNC_YES;
+ }
+
+ au = dtp->u.p.current_unit->au;
+ if (au)
+ {
+ if (dtp->u.p.async)
+ {
+ /* If this is an asynchronous I/O statement, collect errors and
+ return if there are any. */
+ if (collect_async_errors (&dtp->common, au))
+ return;
+ }
+ else
+ {
+ /* Synchronous statement: Perform a wait operation for any pending
+ asynchronous I/O. This needs to be done before all other error
+ checks. See F2008, 9.6.4.1. */
+ if (async_wait (&(dtp->common), au))
+ return;
+ }
+ }
+
/* Check the action. */
if (read_flag && dtp->u.p.current_unit->flags.action == ACTION_WRITE)
@@ -3009,6 +3114,57 @@ data_transfer_init (st_parameter_dt *dtp, int read
if (dtp->u.p.current_unit->pad_status == PAD_UNSPECIFIED)
dtp->u.p.current_unit->pad_status = dtp->u.p.current_unit->flags.pad;
+ /* Set up the subroutine that will handle the transfers. */
+
+ if (read_flag)
+ {
+ if (dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED)
+ dtp->u.p.transfer = unformatted_read;
+ else
+ {
+ if ((cf & IOPARM_DT_LIST_FORMAT) != 0)
+ dtp->u.p.transfer = list_formatted_read;
+ else
+ dtp->u.p.transfer = formatted_transfer;
+ }
+ }
+ else
+ {
+ if (dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED)
+ dtp->u.p.transfer = unformatted_write;
+ else
+ {
+ if ((cf & IOPARM_DT_LIST_FORMAT) != 0)
+ dtp->u.p.transfer = list_formatted_write;
+ else
+ dtp->u.p.transfer = formatted_transfer;
+ }
+ }
+
+ if (au)
+ {
+ NOTE ("enqueue_data_transfer");
+ enqueue_data_transfer_init (au, dtp, read_flag);
+ }
+ else
+ {
+ NOTE ("invoking data_transfer_init_worker");
+ data_transfer_init_worker (dtp, read_flag);
+ }
+}
+
+void
+data_transfer_init_worker (st_parameter_dt *dtp, int read_flag)
+{
+ GFC_INTEGER_4 cf = dtp->common.flags;
+
+ NOTE ("starting worker...");
+
+ if (read_flag && dtp->u.p.current_unit->flags.form != FORM_UNFORMATTED
+ && ((cf & IOPARM_DT_LIST_FORMAT) != 0)
+ && dtp->u.p.current_unit->child_dtio == 0)
+ dtp->u.p.current_unit->last_char = EOF - 1;
+
/* Check to see if we might be reading what we wrote before */
if (dtp->u.p.mode != dtp->u.p.current_unit->mode
@@ -3135,38 +3291,6 @@ data_transfer_init (st_parameter_dt *dtp, int read
pre_position (dtp);
-
- /* Set up the subroutine that will handle the transfers. */
-
- if (read_flag)
- {
- if (dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED)
- dtp->u.p.transfer = unformatted_read;
- else
- {
- if ((cf & IOPARM_DT_LIST_FORMAT) != 0)
- {
- if (dtp->u.p.current_unit->child_dtio == 0)
- dtp->u.p.current_unit->last_char = EOF - 1;
- dtp->u.p.transfer = list_formatted_read;
- }
- else
- dtp->u.p.transfer = formatted_transfer;
- }
- }
- else
- {
- if (dtp->u.p.current_unit->flags.form == FORM_UNFORMATTED)
- dtp->u.p.transfer = unformatted_write;
- else
- {
- if ((cf & IOPARM_DT_LIST_FORMAT) != 0)
- dtp->u.p.transfer = list_formatted_write;
- else
- dtp->u.p.transfer = formatted_transfer;
- }
- }
-
/* Make sure that we don't do a read after a nonadvancing write. */
if (read_flag)
@@ -4099,7 +4223,7 @@ extern void st_read_done (st_parameter_dt *);
export_proto(st_read_done);
void
-st_read_done (st_parameter_dt *dtp)
+st_read_done_worker (st_parameter_dt *dtp)
{
finalize_transfer (dtp);
@@ -4127,6 +4251,30 @@ void
free_format_data (dtp->u.p.fmt);
free_format (dtp);
}
+ }
+}
+
+void
+st_read_done (st_parameter_dt *dtp)
+{
+ if (dtp->u.p.current_unit)
+ {
+ if (dtp->u.p.current_unit->au)
+ {
+ if (dtp->common.flags & IOPARM_DT_HAS_ID)
+ *dtp->id = enqueue_done_id (dtp->u.p.current_unit->au, AIO_READ_DONE);
+ else
+ {
+ enqueue_done (dtp->u.p.current_unit->au, AIO_READ_DONE);
+ /* An asynchronous unit without ASYNCHRONOUS="YES" - make this
+ synchronous by performing a wait operation. */
+ if (!dtp->u.p.async)
+ async_wait (&dtp->common, dtp->u.p.current_unit->au);
+ }
+ }
+ else
+ st_read_done_worker (dtp);
+
unlock_unit (dtp->u.p.current_unit);
}
@@ -4134,7 +4282,7 @@ void
}
extern void st_write (st_parameter_dt *);
-export_proto(st_write);
+export_proto (st_write);
void
st_write (st_parameter_dt *dtp)
@@ -4143,11 +4291,9 @@ st_write (st_parameter_dt *dtp)
data_transfer_init (dtp, 0);
}
-extern void st_write_done (st_parameter_dt *);
-export_proto(st_write_done);
void
-st_write_done (st_parameter_dt *dtp)
+st_write_done_worker (st_parameter_dt *dtp)
{
finalize_transfer (dtp);
@@ -4196,19 +4342,68 @@ void
free_format_data (dtp->u.p.fmt);
free_format (dtp);
}
+ }
+}
+
+extern void st_write_done (st_parameter_dt *);
+export_proto(st_write_done);
+
+void
+st_write_done (st_parameter_dt *dtp)
+{
+ if (dtp->u.p.current_unit)
+ {
+ if (dtp->u.p.current_unit->au)
+ {
+ if (dtp->common.flags & IOPARM_DT_HAS_ID)
+ *dtp->id = enqueue_done_id (dtp->u.p.current_unit->au,
+ AIO_WRITE_DONE);
+ else
+ {
+ enqueue_done (dtp->u.p.current_unit->au, AIO_WRITE_DONE);
+ /* An asynchronous unit without ASYNCHRONOUS="YES" - make this
+ synchronous by performing a wait operation. */
+ if (!dtp->u.p.async)
+ async_wait (&dtp->common, dtp->u.p.current_unit->au);
+ }
+ }
+ else
+ st_write_done_worker (dtp);
+
unlock_unit (dtp->u.p.current_unit);
}
+
library_end ();
}
+/* Wait operation. We need to keep around the do-nothing version
+ of st_wait for compatibility with previous versions, which had marked
+ the argument as unused (and thus liable to be removed).
-/* F2003: This is a stub for the runtime portion of the WAIT statement. */
+ TODO: remove at next bump in version number. */
+
void
st_wait (st_parameter_wait *wtp __attribute__((unused)))
{
+ return;
}
+void
+st_wait_async (st_parameter_wait *wtp)
+{
+ gfc_unit *u = find_unit (wtp->common.unit);
+ if (ASYNC_IO && u->au)
+ {
+ if (wtp->common.flags & IOPARM_WAIT_HAS_ID)
+ async_wait_id (&(wtp->common), u->au, *wtp->id);
+ else
+ async_wait (&(wtp->common), u->au);
+ }
+ unlock_unit (u);
+}
+
+
/* Receives the scalar information for namelist objects and stores it
in a linked list of namelist_info types. */
Index: libgfortran/io/unit.c
===================================================================
--- libgfortran/io/unit.c (Revision 263618)
+++ libgfortran/io/unit.c (Arbeitskopie)
@@ -27,6 +27,7 @@ see the files COPYING3 and COPYING.RUNTIME respect
#include "fbuf.h"
#include "format.h"
#include "unix.h"
+#include "async.h"
#include <string.h>
#include <assert.h>
@@ -240,7 +241,7 @@ insert_unit (int n)
#else
__GTHREAD_MUTEX_INIT_FUNCTION (&u->lock);
#endif
- __gthread_mutex_lock (&u->lock);
+ LOCK (&u->lock);
u->priority = pseudo_random ();
unit_root = insert (u, unit_root);
return u;
@@ -327,7 +328,9 @@ get_gfc_unit (int n, int do_create)
gfc_unit *p;
int c, created = 0;
- __gthread_mutex_lock (&unit_lock);
+ NOTE ("Unit n=%d, do_create = %d", n, do_create);
+ LOCK (&unit_lock);
+
retry:
for (c = 0; c < CACHE_SIZE; c++)
if (unit_cache[c] != NULL && unit_cache[c]->unit_number == n)
@@ -366,7 +369,7 @@ retry:
{
/* Newly created units have their lock held already
from insert_unit. Just unlock UNIT_LOCK and return. */
- __gthread_mutex_unlock (&unit_lock);
+ UNLOCK (&unit_lock);
return p;
}
@@ -374,10 +377,10 @@ found:
if (p != NULL && (p->child_dtio == 0))
{
/* Fast path. */
- if (! __gthread_mutex_trylock (&p->lock))
+ if (! TRYLOCK (&p->lock))
{
/* assert (p->closed == 0); */
- __gthread_mutex_unlock (&unit_lock);
+ UNLOCK (&unit_lock);
return p;
}
@@ -385,15 +388,15 @@ found:
}
- __gthread_mutex_unlock (&unit_lock);
+ UNLOCK (&unit_lock);
if (p != NULL && (p->child_dtio == 0))
{
- __gthread_mutex_lock (&p->lock);
+ LOCK (&p->lock);
if (p->closed)
{
- __gthread_mutex_lock (&unit_lock);
- __gthread_mutex_unlock (&p->lock);
+ LOCK (&unit_lock);
+ UNLOCK (&p->lock);
if (predec_waiting_locked (p) == 0)
destroy_unit_mutex (p);
goto retry;
@@ -640,7 +643,7 @@ init_units (void)
fbuf_init (u, 0);
- __gthread_mutex_unlock (&u->lock);
+ UNLOCK (&u->lock);
}
if (options.stdout_unit >= 0)
@@ -671,7 +674,7 @@ init_units (void)
fbuf_init (u, 0);
- __gthread_mutex_unlock (&u->lock);
+ UNLOCK (&u->lock);
}
if (options.stderr_unit >= 0)
@@ -702,13 +705,13 @@ init_units (void)
fbuf_init (u, 256); /* 256 bytes should be enough, probably not doing
any kind of exotic formatting to stderr. */
- __gthread_mutex_unlock (&u->lock);
+ UNLOCK (&u->lock);
}
/* The default internal units. */
u = insert_unit (GFC_INTERNAL_UNIT);
- __gthread_mutex_unlock (&u->lock);
+ UNLOCK (&u->lock);
u = insert_unit (GFC_INTERNAL_UNIT4);
- __gthread_mutex_unlock (&u->lock);
+ UNLOCK (&u->lock);
}
@@ -717,6 +720,9 @@ close_unit_1 (gfc_unit *u, int locked)
{
int i, rc;
+ if (ASYNC_IO && u->au)
+ async_close (u->au);
+
/* If there are previously written bytes from a write with ADVANCE="no"
Reposition the buffer before closing. */
if (u->previous_nonadvancing_write)
@@ -726,7 +732,7 @@ close_unit_1 (gfc_unit *u, int locked)
u->closed = 1;
if (!locked)
- __gthread_mutex_lock (&unit_lock);
+ LOCK (&unit_lock);
for (i = 0; i < CACHE_SIZE; i++)
if (unit_cache[i] == u)
@@ -744,7 +750,7 @@ close_unit_1 (gfc_unit *u, int locked)
newunit_free (u->unit_number);
if (!locked)
- __gthread_mutex_unlock (&u->lock);
+ UNLOCK (&u->lock);
/* If there are any threads waiting in find_unit for this unit,
avoid freeing the memory, the last such thread will free it
@@ -753,7 +759,7 @@ close_unit_1 (gfc_unit *u, int locked)
destroy_unit_mutex (u);
if (!locked)
- __gthread_mutex_unlock (&unit_lock);
+ UNLOCK (&unit_lock);
return rc;
}
@@ -761,7 +767,9 @@ close_unit_1 (gfc_unit *u, int locked)
void
unlock_unit (gfc_unit *u)
{
- __gthread_mutex_unlock (&u->lock);
+ NOTE ("unlock_unit = %d", u->unit_number);
+ UNLOCK (&u->lock);
+ NOTE ("unlock_unit done");
}
/* close_unit()-- Close a unit. The stream is closed, and any memory
@@ -785,10 +793,10 @@ close_unit (gfc_unit *u)
void
close_units (void)
{
- __gthread_mutex_lock (&unit_lock);
+ LOCK (&unit_lock);
while (unit_root != NULL)
close_unit_1 (unit_root, 1);
- __gthread_mutex_unlock (&unit_lock);
+ UNLOCK (&unit_lock);
free (newunits);
@@ -895,7 +903,7 @@ finish_last_advance_record (gfc_unit *u)
int
newunit_alloc (void)
{
- __gthread_mutex_lock (&unit_lock);
+ LOCK (&unit_lock);
if (!newunits)
{
newunits = xcalloc (16, 1);
@@ -909,7 +917,7 @@ newunit_alloc (void)
{
newunits[ii] = true;
newunit_lwi = ii + 1;
- __gthread_mutex_unlock (&unit_lock);
+ UNLOCK (&unit_lock);
return -ii + NEWUNIT_START;
}
}
@@ -922,7 +930,7 @@ newunit_alloc (void)
memset (newunits + old_size, 0, old_size);
newunits[old_size] = true;
newunit_lwi = old_size + 1;
- __gthread_mutex_unlock (&unit_lock);
+ UNLOCK (&unit_lock);
return -old_size + NEWUNIT_START;
}
Index: libgfortran/io/unix.c
===================================================================
--- libgfortran/io/unix.c (Revision 263618)
+++ libgfortran/io/unix.c (Arbeitskopie)
@@ -27,6 +27,7 @@ see the files COPYING3 and COPYING.RUNTIME respect
#include "io.h"
#include "unix.h"
+#include "async.h"
#include <limits.h>
#ifdef HAVE_UNISTD_H
@@ -1742,7 +1743,7 @@ find_file (const char *file, gfc_charlen_type file
id = id_from_path (path);
#endif
- __gthread_mutex_lock (&unit_lock);
+ LOCK (&unit_lock);
retry:
u = find_file0 (unit_root, FIND_FILE0_ARGS);
if (u != NULL)
@@ -1751,20 +1752,20 @@ retry:
if (! __gthread_mutex_trylock (&u->lock))
{
/* assert (u->closed == 0); */
- __gthread_mutex_unlock (&unit_lock);
+ UNLOCK (&unit_lock);
goto done;
}
inc_waiting_locked (u);
}
- __gthread_mutex_unlock (&unit_lock);
+ UNLOCK (&unit_lock);
if (u != NULL)
{
- __gthread_mutex_lock (&u->lock);
+ LOCK (&u->lock);
if (u->closed)
{
- __gthread_mutex_lock (&unit_lock);
- __gthread_mutex_unlock (&u->lock);
+ LOCK (&unit_lock);
+ UNLOCK (&u->lock);
if (predec_waiting_locked (u) == 0)
free (u);
goto retry;
@@ -1794,7 +1795,7 @@ flush_all_units_1 (gfc_unit *u, int min_unit)
return u;
if (u->s)
sflush (u->s);
- __gthread_mutex_unlock (&u->lock);
+ UNLOCK (&u->lock);
}
u = u->right;
}
@@ -1807,17 +1808,17 @@ flush_all_units (void)
gfc_unit *u;
int min_unit = 0;
- __gthread_mutex_lock (&unit_lock);
+ LOCK (&unit_lock);
do
{
u = flush_all_units_1 (unit_root, min_unit);
if (u != NULL)
inc_waiting_locked (u);
- __gthread_mutex_unlock (&unit_lock);
+ UNLOCK (&unit_lock);
if (u == NULL)
return;
- __gthread_mutex_lock (&u->lock);
+ LOCK (&u->lock);
min_unit = u->unit_number + 1;
@@ -1824,14 +1825,14 @@ flush_all_units (void)
if (u->closed == 0)
{
sflush (u->s);
- __gthread_mutex_lock (&unit_lock);
- __gthread_mutex_unlock (&u->lock);
+ LOCK (&unit_lock);
+ UNLOCK (&u->lock);
(void) predec_waiting_locked (u);
}
else
{
- __gthread_mutex_lock (&unit_lock);
- __gthread_mutex_unlock (&u->lock);
+ LOCK (&unit_lock);
+ UNLOCK (&u->lock);
if (predec_waiting_locked (u) == 0)
free (u);
}
Index: libgfortran/libgfortran.h
===================================================================
--- libgfortran/libgfortran.h (Revision 263618)
+++ libgfortran/libgfortran.h (Arbeitskopie)
@@ -738,6 +738,9 @@ internal_proto(translate_error);
extern void generate_error (st_parameter_common *, int, const char *);
iexport_proto(generate_error);
+extern bool generate_error_common (st_parameter_common *, int, const char *);
+iexport_proto(generate_error_common);
+
extern void generate_warning (st_parameter_common *, const char *);
internal_proto(generate_warning);
@@ -1743,5 +1746,7 @@ void cshift1_16_c16 (gfc_array_c16 * const restric
internal_proto(cshift1_16_c16);
#endif
+/* Define this if we support asynchronous I/O on this platform. This
+ currently requires weak symbols. */
#endif /* LIBGFOR_H */
Index: libgfortran/runtime/error.c
===================================================================
--- libgfortran/runtime/error.c (Revision 263618)
+++ libgfortran/runtime/error.c (Arbeitskopie)
@@ -24,6 +24,9 @@ see the files COPYING3 and COPYING.RUNTIME respect
#include "libgfortran.h"
+#include "io.h"
+#include "async.h"
+
#include <assert.h>
#include <string.h>
#include <errno.h>
@@ -526,24 +529,41 @@ translate_error (int code)
}
-/* generate_error()-- Come here when an error happens. This
- * subroutine is called if it is possible to continue on after the error.
- * If an IOSTAT or IOMSG variable exists, we set it. If IOSTAT or
- * ERR labels are present, we return, otherwise we terminate the program
- * after printing a message. The error code is always required but the
- * message parameter can be NULL, in which case a string describing
- * the most recent operating system error is used. */
+/* Worker function for generate_error and generate_error_async. Return true
+ if a straight return is to be done, zero if the program should abort. */
-void
-generate_error (st_parameter_common *cmp, int family, const char *message)
+bool
+generate_error_common (st_parameter_common *cmp, int family, const char *message)
{
char errmsg[STRERR_MAXSZ];
+#if ASYNC_IO
+ gfc_unit *u;
+
+ NOTE ("Entering generate_error_common");
+
+ u = thread_unit;
+ if (u && u->au)
+ {
+ if (u->au->error.has_error)
+ return true;
+
+ if (__gthread_equal (u->au->thread, __gthread_self ()))
+ {
+ u->au->error.has_error = 1;
+ u->au->error.cmp = cmp;
+ u->au->error.family = family;
+ u->au->error.message = message;
+ return true;
+ }
+ }
+#endif
+
/* If there was a previous error, don't mask it with another
error message, EOF or EOR condition. */
if ((cmp->flags & IOPARM_LIBRETURN_MASK) == IOPARM_LIBRETURN_ERROR)
- return;
+ return true;
/* Set the error status. */
if ((cmp->flags & IOPARM_HAS_IOSTAT))
@@ -562,29 +582,30 @@ translate_error (int code)
switch (family)
{
case LIBERROR_EOR:
- cmp->flags |= IOPARM_LIBRETURN_EOR;
+ cmp->flags |= IOPARM_LIBRETURN_EOR; NOTE("EOR");
if ((cmp->flags & IOPARM_EOR))
- return;
+ return true;
break;
case LIBERROR_END:
- cmp->flags |= IOPARM_LIBRETURN_END;
+ cmp->flags |= IOPARM_LIBRETURN_END; NOTE("END");
if ((cmp->flags & IOPARM_END))
- return;
+ return true;
break;
default:
- cmp->flags |= IOPARM_LIBRETURN_ERROR;
+ cmp->flags |= IOPARM_LIBRETURN_ERROR; NOTE("ERROR");
if ((cmp->flags & IOPARM_ERR))
- return;
+ return true;
break;
}
/* Return if the user supplied an iostat variable. */
if ((cmp->flags & IOPARM_HAS_IOSTAT))
- return;
+ return true;
- /* Terminate the program */
+ /* Return code, caller is responsible for terminating
+ the program if necessary. */
recursion_check ();
show_locus (cmp);
@@ -591,8 +612,27 @@ translate_error (int code)
estr_write ("Fortran runtime error: ");
estr_write (message);
estr_write ("\n");
- exit_error (2);
+ return false;
}
+
+/* generate_error()-- Come here when an error happens. This
+ * subroutine is called if it is possible to continue on after the error.
+ * If an IOSTAT or IOMSG variable exists, we set it. If IOSTAT or
+ * ERR labels are present, we return, otherwise we terminate the program
+ * after printing a message. The error code is always required but the
+ * message parameter can be NULL, in which case a string describing
+ * the most recent operating system error is used.
+ * If the error is for an asynchronous unit and if the program is currently
+ * executing the asynchronous thread, just mark the error and return. */
+
+void
+generate_error (st_parameter_common *cmp, int family, const char *message)
+{
+ if (generate_error_common (cmp, family, message))
+ return;
+
+ exit_error(2);
+}
iexport(generate_error);
[-- Attachment #3: async_io_1.f90 --]
[-- Type: text/x-fortran, Size: 1417 bytes --]
! { dg-do run }
! Check basic functionality of async I/O
! { dg-xfail-run-if "armeb, bug in array_constructor_8.f90" { armeb-*-* } { "-O0" } { "" } }
program main
implicit none
integer:: i=1, j=2, k, l
real :: a, b, c, d
character(3), parameter:: yes="yes"
character(4) :: str
complex :: cc, dd
integer, dimension(4):: is = [0, 1, 2, 3]
integer, dimension(4):: res
character(10) :: inq
open (10, file='a.dat', asynchronous=yes)
cc = (1.5, 0.5)
inquire (10,asynchronous=inq)
if (inq /= "YES") stop 1
write (10,*,asynchronous=yes) 4, 3
write (10,*,asynchronous=yes) 2, 1
write (10,*,asynchronous=yes) 1.0, 3.0
write (10,'(A)', asynchronous=yes) 'asdf'
write (10,*, asynchronous=yes) cc
close (10)
open (20, file='a.dat', asynchronous=yes)
read (20, *, asynchronous=yes) i, j
read (20, *, asynchronous=yes) k, l
read (20, *, asynchronous=yes) a, b
read (20,'(A4)',asynchronous=yes) str
read (20,*, asynchronous=yes) dd
wait (20)
if (i /= 4 .or. j /= 3) stop 2
if (k /= 2 .or. l /= 1) stop 3
if (a /= 1.0 .or. b /= 3.0) stop 4
if (str /= 'asdf') stop 5
if (cc /= dd) stop 6
close (20,status="delete")
open(10, file='c.dat', asynchronous=yes)
write(10, *, asynchronous=yes) is
close(10)
open(20, file='c.dat', asynchronous=yes)
read(20, *, asynchronous=yes) res
wait (20)
if (any(res /= is)) stop 7
close (20,status="delete")
end program
[-- Attachment #4: async_io_2.f90 --]
[-- Type: text/x-fortran, Size: 465 bytes --]
! { dg-do run }
! { dg-xfail-run-if "armeb, bug in array_constructor_8.f90" { armeb-*-* } { "-O0" } { "" } }
program main
implicit none
integer :: i, ios
character(len=100) :: iom
open (10,file="tst.dat")
write (10,'(A4)') 'asdf'
close(10)
i = 234
open(10,file="tst.dat", asynchronous="yes")
read (10,'(I4)',asynchronous="yes") i
iom = ' '
wait (10,iostat=ios,iomsg=iom)
if (iom == ' ') stop 1
close(10,status="delete")
end program main
[-- Attachment #5: async_io_3.f90 --]
[-- Type: text/x-fortran, Size: 453 bytes --]
! { dg-do run }
! { dg-xfail-run-if "armeb, bug in array_constructor_8.f90" { armeb-*-* } { "-O0" } { "" } }
program main
integer :: i
open (10,file="tst.dat")
write (10,'(A4)') 'asdf'
close(10)
i = 234
open(10,file="tst.dat", asynchronous="yes")
read (10,'(I4)',asynchronous="yes") i
wait(10)
end program main
! { dg-output "Fortran runtime error: Bad value during integer read" }
! { dg-final { remote_file build delete "tst.dat" } }
[-- Attachment #6: async_io_4.f90 --]
[-- Type: text/x-fortran, Size: 1780 bytes --]
! { dg-do run { target fd_truncate } }
! Test BACKSPACE for synchronous and asynchronous I/O
! { dg-xfail-run-if "armeb, bug in array_constructor_8.f90" { armeb-*-* } { "-O0" } { "" } }
program main
integer i, n, nr
real x(10), y(10)
! PR libfortran/20068
open (20, status='scratch', asynchronous="yes")
write (20,*, asynchronous="yes" ) 1
write (20,*, asynchronous="yes") 2
write (20,*, asynchronous="yes") 3
rewind (20)
i = 41
read (20,*, asynchronous="yes") i
wait (20)
if (i .ne. 1) STOP 1
write (*,*) ' '
backspace (20)
i = 42
read (20,*, asynchronous="yes") i
close (20)
if (i .ne. 1) STOP 2
! PR libfortran/20125
open (20, status='scratch', asynchronous="yes")
write (20,*, asynchronous="yes") 7
backspace (20)
read (20,*, asynchronous="yes") i
wait (20)
if (i .ne. 7) STOP 3
close (20)
open (20, status='scratch', form='unformatted')
write (20) 8
backspace (20)
read (20) i
if (i .ne. 8) STOP 4
close (20)
! PR libfortran/20471
do n = 1, 10
x(n) = sqrt(real(n))
end do
open (3, form='unformatted', status='scratch')
write (3) (x(n),n=1,10)
backspace (3)
rewind (3)
read (3) (y(n),n=1,10)
do n = 1, 10
if (abs(x(n)-y(n)) > 0.00001) STOP 5
end do
close (3)
! PR libfortran/20156
open (3, form='unformatted', status='scratch')
do i = 1, 5
x(1) = i
write (3) n, (x(n),n=1,10)
end do
nr = 0
rewind (3)
20 continue
read (3,end=30,err=90) n, (x(n),n=1,10)
nr = nr + 1
goto 20
30 continue
if (nr .ne. 5) STOP 6
do i = 1, nr+1
backspace (3)
end do
do i = 1, nr
read(3,end=70,err=90) n, (x(n),n=1,10)
if (abs(x(1) - i) .gt. 0.001) STOP 7
end do
close (3)
stop
70 continue
STOP 8
90 continue
STOP 9
end program
[-- Attachment #7: async_io_5.f90 --]
[-- Type: text/x-fortran, Size: 3779 bytes --]
! { dg-do run }
! PR55818 Reading a REAL from a file which doesn't end in a new line fails
! Test case from PR reporter.
! { dg-xfail-run-if "armeb, bug in array_constructor_8.f90" { armeb-*-* } { "-O0" } { "" } }
implicit none
integer :: stat
!integer :: var ! << works
real :: var ! << fails
character(len=10) :: cvar ! << fails
complex :: cval
logical :: lvar
open(99, file="test.dat", access="stream", form="unformatted", status="new")
write(99) "1", new_line("")
write(99) "2", new_line("")
write(99) "3"
close(99)
! Test character kind
open(99, file="test.dat")
read (99,*, iostat=stat) cvar
if (stat /= 0 .or. cvar /= "1") STOP 1
read (99,*, iostat=stat) cvar
if (stat /= 0 .or. cvar /= "2") STOP 2
read (99,*, iostat=stat) cvar ! << FAILS: stat /= 0
if (stat /= 0 .or. cvar /= "3") STOP 3 ! << aborts here
! Test real kind
rewind(99)
read (99,*, iostat=stat) var
if (stat /= 0 .or. var /= 1.0) STOP 4
read (99,*, iostat=stat) var
if (stat /= 0 .or. var /= 2.0) STOP 5
read (99,*, iostat=stat) var ! << FAILS: stat /= 0
if (stat /= 0 .or. var /= 3.0) STOP 6
close(99, status="delete")
! Test real kind with exponents
open(99, file="test.dat", access="stream", form="unformatted", status="new")
write(99) "1.0e3", new_line("")
write(99) "2.0e-03", new_line("")
write(99) "3.0e2"
close(99)
open(99, file="test.dat")
read (99,*, iostat=stat) var
if (stat /= 0) STOP 7
read (99,*, iostat=stat) var
if (stat /= 0) STOP 8
read (99,*) var ! << FAILS: stat /= 0
if (stat /= 0) STOP 9
close(99, status="delete")
! Test logical kind
open(99, file="test.dat", access="stream", form="unformatted", status="new")
write(99) "Tru", new_line("")
write(99) "fal", new_line("")
write(99) "t"
close(99)
open(99, file="test.dat")
read (99,*, iostat=stat) lvar
if (stat /= 0 .or. (.not.lvar)) STOP 10
read (99,*, iostat=stat) lvar
if (stat /= 0 .or. lvar) STOP 11
read (99,*) lvar ! << FAILS: stat /= 0
if (stat /= 0 .or. (.not.lvar)) STOP 12
close(99, status="delete")
! Test combinations of Inf and Nan
open(99, file="test.dat", access="stream", form="unformatted", status="new")
write(99) "infinity", new_line("")
write(99) "nan", new_line("")
write(99) "infinity"
close(99)
open(99, file="test.dat")
read (99,*, iostat=stat) var
if (stat /= 0) STOP 13
read (99,*, iostat=stat) var
if (stat /= 0) STOP 14
read (99,*) var ! << FAILS: stat /= 0
if (stat /= 0) STOP 1! << aborts here
close(99, status="delete")
open(99, file="test.dat", access="stream", form="unformatted", status="new")
write(99) "infinity", new_line("")
write(99) "inf", new_line("")
write(99) "nan"
close(99)
open(99, file="test.dat")
read (99,*, iostat=stat) var
if (stat /= 0) STOP 15
read (99,*, iostat=stat) var
if (stat /= 0) STOP 16
read (99,*) var ! << FAILS: stat /= 0
if (stat /= 0) STOP 2! << aborts here
close(99, status="delete")
open(99, file="test.dat", access="stream", form="unformatted", status="new")
write(99) "infinity", new_line("")
write(99) "nan", new_line("")
write(99) "inf"
close(99)
open(99, file="test.dat")
read (99,*, iostat=stat) var
if (stat /= 0) STOP 17
read (99,*, iostat=stat) var
if (stat /= 0) STOP 18
read (99,*) var ! << FAILS: stat /= 0
if (stat /= 0) STOP 3! << aborts here
close(99, status="delete")
! Test complex kind
open(99, file="test.dat", access="stream", form="unformatted", status="new")
write(99) "(1,2)", new_line("")
write(99) "(2,3)", new_line("")
write(99) "(4,5)"
close(99)
open(99, file="test.dat")
read (99,*, iostat=stat) cval
if (stat /= 0 .or. cval /= cmplx(1,2)) STOP 19
read (99,*, iostat=stat) cval
if (stat /= 0 .or. cval /= cmplx(2,3)) STOP 20
read (99,*, iostat=stat) cval ! << FAILS: stat /= 0, value is okay
if (stat /= 0 .or. cval /= cmplx(4,5)) STOP 21
close(99, status="delete")
end
[-- Attachment #8: async_io_6.f90 --]
[-- Type: text/x-fortran, Size: 525 bytes --]
! { dg-do run }
! PR 22390 Implement flush statement
! { dg-xfail-run-if "armeb, bug in array_constructor_8.f90" { armeb-*-* } { "-O0" } { "" } }
program flush_1
character(len=256) msg
integer ios
open (unit=10, access='SEQUENTIAL', status='SCRATCH')
write (10, *) 42
flush 10
write (10, *) 42
flush(10)
write (10, *) 42
flush(unit=10, iostat=ios)
if (ios /= 0) STOP 1
write (10, *) 42
flush (unit=10, err=20)
goto 30
20 STOP 2
30 continue
call flush(10)
end program flush_1
[-- Attachment #9: async_io_7.f90 --]
[-- Type: text/x-fortran, Size: 671 bytes --]
! { dg-do run }
! PR40008 F2008: Add NEWUNIT= for OPEN statement
! Contributed by Jerry DeLisle <jvdelisle@gcc.gnu.org>
! { dg-xfail-run-if "armeb, bug in array_constructor_8.f90" { armeb-*-* } { "-O0" } { "" } }
program newunit_1
character(len=25) :: str
integer(1) :: myunit, myunit2
myunit = 25
str = "bad"
open(newunit=myunit, status="scratch")
open(newunit = myunit2, file="newunit_1file")
write(myunit,'(e24.15e2)') 1.0d0
write(myunit2,*) "abcdefghijklmnop"
flush(myunit)
rewind(myunit)
rewind(myunit2)
read(myunit2,'(a)') str
if (str.ne." abcdefghijklmnop") STOP 1
close(myunit)
close(myunit2, status="delete")
end program newunit_1
^ permalink raw reply [flat|nested] 20+ messages in thread
* Re: Async I/O patch with compilation fix
2018-08-17 15:41 ` Thomas Koenig
@ 2018-08-18 22:44 ` Christophe Lyon
2018-08-19 13:40 ` Thomas Koenig
0 siblings, 1 reply; 20+ messages in thread
From: Christophe Lyon @ 2018-08-18 22:44 UTC (permalink / raw)
To: Thomas Koenig
Cc: koenigni, Andre Simoes Dias Vieira, gcc Patches, fortran,
Ulrich Weigand, David Edelsohn, clyon
On Fri, 17 Aug 2018 at 17:41, Thomas Koenig <tkoenig@netcologne.de> wrote:
>
> Hi Christophe,
>
Hi,
> sorry that this took so long, but a holiday followed by a
> business trip seven timezones away can do that :-)
>
Sorry, I am on holidays too, and not back yet :)
> > I applied this patch, and again I still see regressions on
> > armeb-none-linux-gnueabihf
> > --with-cpu cortex-a9
> > --with-fpu neon-fp16
>
> The info that you supplied in the PR indicates some sort of library
> problem exposed by the patch, possibly by including gthr.h.
>
> All Nicolas and I could come up with was to remove the async I/O
> functionality from armeb-* and by xfailing the tests.
>
> This is done by
>
> +#if defined(__GTHREAD_HAS_COND) && defined(__GTHREADS_CXX0X) &&
> !defined(__ARMEB__)
> +#define ASYNC_IO 1
> +#else
> +#define ASYNC_IO 0
> +#endif
>
> If somebody comes up with something more fine-grained for the
> feature test, we can put this in now or later.
>
> Regression-tested on x86_64-pc-linux-gnu (which showed that
> xfail lines in the testsuite aren't wildly inaccurate).
>
> So, I'd appreciate testing. If this passes, this will be
> committed ASAP.
>
I tried this version of the patch, and I'm still seeing the regression
on array_constructor_8.f90.
I didn't try to run the new tests (I only applied the patch part)
I'll try to investigate the PR a bit more when I'm back at the office
(e/o August)
Christophe
> Regards
>
> Thomas
>
^ permalink raw reply [flat|nested] 20+ messages in thread
* Re: Async I/O patch with compilation fix
2018-08-18 22:44 ` Christophe Lyon
@ 2018-08-19 13:40 ` Thomas Koenig
[not found] ` <CAKdteObsx+RK2t-OteU_w6L_Pv7FGLpAcLrHaPY4NDAamV-z7g@mail.gmail.com>
0 siblings, 1 reply; 20+ messages in thread
From: Thomas Koenig @ 2018-08-19 13:40 UTC (permalink / raw)
To: Christophe Lyon
Cc: koenigni, Andre Simoes Dias Vieira, gcc Patches, fortran,
Ulrich Weigand, David Edelsohn, clyon
Hi Christophe,
> Hi,
>> This is done by
>>
>> +#if defined(__GTHREAD_HAS_COND) && defined(__GTHREADS_CXX0X) &&
>> !defined(__ARMEB__)
>> +#define ASYNC_IO 1
>> +#else
>> +#define ASYNC_IO 0
>> +#endif
> I tried this version of the patch, and I'm still seeing the regression
> on array_constructor_8.f90.
Urgh...
Could you run
gcc -dM foo.h
with an empty foo.h in your target environment to see if
__ARMEB__ is actually defined? If it is not, what other
macro or combination of macros could be used?
At the moment, and with the data you posted in the PR, it seems that
this might be a library problem. Calling different library functions
with or without the patch seems to be an indication of that.
Currently, this patch holds up other major work :-(
What I would propose is to commit the patch as given in
https://gcc.gnu.org/ml/fortran/2018-08/msg00007.html
and open a PR for the strange armeb failure (if the test
for the macros above does not a promising approach).
Let us then fix this PR before the 9.0 release.
Regards
Thomas
^ permalink raw reply [flat|nested] 20+ messages in thread
* Re: Async I/O patch with compilation fix
[not found] ` <CAKdteObsx+RK2t-OteU_w6L_Pv7FGLpAcLrHaPY4NDAamV-z7g@mail.gmail.com>
@ 2018-08-21 19:43 ` Thomas Koenig
2018-08-22 18:49 ` David Edelsohn
0 siblings, 1 reply; 20+ messages in thread
From: Thomas Koenig @ 2018-08-21 19:43 UTC (permalink / raw)
To: Christophe Lyon
Cc: koenigni, Andre Simoes Dias Vieira, gcc Patches, fortran,
Ulrich Weigand, David Edelsohn, clyon
Hi everybody,
Nicolas has committed the patch as r263750.
PR 87048 now traces the armeb regression, which is
assumed to resurface now. Let's really try and fix
that one before 9.0 :-)
Regards
Thomas
^ permalink raw reply [flat|nested] 20+ messages in thread
* Re: Async I/O patch with compilation fix
2018-08-21 19:43 ` Thomas Koenig
@ 2018-08-22 18:49 ` David Edelsohn
2018-08-22 21:31 ` Thomas Koenig
0 siblings, 1 reply; 20+ messages in thread
From: David Edelsohn @ 2018-08-22 18:49 UTC (permalink / raw)
To: Thomas Koenig
Cc: Christophe Lyon, Decius Caecilius Metellus, Andre Vieira (lists),
GCC Patches, Fortran List, Ulrich Weigand, clyon
Thomas,
This patch broke bootstrap on AIX again. This is completely unacceptable.
In file included from
*/nasfarm/edelsohn/src/src/libgfortran/runtime/error.c:28*:
*/nasfarm/edelsohn/src/src/libgfortran/io/async.h:333:3:* *error: *unknown
type name '*__gthread_cond_t*'
333 | *__gthread_cond_t* signal;
| *^~~~~~~~~~~~~~~~*
make[1]: *** [Makefile:2594: error.lo] Error 1
- David
On Tue, Aug 21, 2018 at 3:42 PM Thomas Koenig <tkoenig@netcologne.de> wrote:
> Hi everybody,
>
> Nicolas has committed the patch as r263750.
>
> PR 87048 now traces the armeb regression, which is
> assumed to resurface now. Let's really try and fix
> that one before 9.0 :-)
>
> Regards
>
> Thomas
>
^ permalink raw reply [flat|nested] 20+ messages in thread
* Re: Async I/O patch with compilation fix
2018-08-22 18:49 ` David Edelsohn
@ 2018-08-22 21:31 ` Thomas Koenig
2018-08-23 12:25 ` David Edelsohn
2018-08-23 12:53 ` David Edelsohn
0 siblings, 2 replies; 20+ messages in thread
From: Thomas Koenig @ 2018-08-22 21:31 UTC (permalink / raw)
To: David Edelsohn
Cc: Christophe Lyon, Decius Caecilius Metellus, Andre Vieira (lists),
GCC Patches, Fortran List, Ulrich Weigand, clyon
[-- Attachment #1: Type: text/plain, Size: 1830 bytes --]
Hi David,
> This patch broke bootstrap on AIX again. This is completely unacceptable.
Again, sorry for the breakage.
I faced quite some challenges trying to get bootstrap to
work on gcc119. Despite quite a few e-mails (plus hints in a PR)
that I received, none of the hints for bootstrap I got actually got
it to work. I finally gave up after four or five different failures,
and the patch was committed because every test
that _could_ be run did show no failure.
Had we received instructions that work for bootstrapping on AIX,
we would have tested the patch there.
If it were possible to add instructions that do work for AIX
bootstrapping to the compile farm wiki, that would be great.
If you (or somebody else who has the requisite AIX fu) could test
patches that are known to be difficult, that would also be
great.
As long as we have no other solution, it is probably best to #ifdef out
AIX any additional pthread-related functionality for libgfortran that
might be coming along. That can always be integrated later, if somebody
can re-implement POSIX condition variables for libgfortran from what
AIX provides.
Let's talk about how to proceed at the GNU cauldron, over a beer.
Both Nicolas and I will be there.
In the meantime, I have committed the following patch (r263788) as
obvious after regression-testing on Linux both with ASYNC_IO set
to 1 and to 0. Let me know how that works out.
2018-08-22 Thomas Koenig <tkoenig@gcc.gnu.org>
* async.h: Set ASYNC_IO to zero if _AIX is defined.
(struct adv_cond): If ASYNC_IO is zero, the struct has no members.
(async_unit): If ASYNC_IO is zero, remove unneeded members.
2018-08-22 Thomas Koenig <tkoenig@gcc.gnu.org>
* gfortran.texi: Mention that asynchronous I/O does
not work on systems which lack condition variables, such
as AIX.
Regards
Thomas
[-- Attachment #2: paix.diff --]
[-- Type: text/x-patch, Size: 2158 bytes --]
Index: gcc/fortran/gfortran.texi
===================================================================
--- gcc/fortran/gfortran.texi (Revision 263752)
+++ gcc/fortran/gfortran.texi (Arbeitskopie)
@@ -1509,7 +1509,8 @@
Asynchronous I/O is supported if the program is linked against the
POSIX thread library. If that is not the case, all I/O is performed
-as synchronous.
+as synchronous. On systems which do not support pthread condition
+variables, such as AIX, I/O is also performed as synchronous.
On some systems, such as Darwin or Solaris, the POSIX thread library
is always linked in, so asynchronous I/O is always performed. On other
Index: libgfortran/io/async.h
===================================================================
--- libgfortran/io/async.h (Revision 263752)
+++ libgfortran/io/async.h (Arbeitskopie)
@@ -29,7 +29,7 @@
__gthread_cond_t and __gthread_equal / __gthread_self. Check
this. */
-#if defined(__GTHREAD_HAS_COND) && defined(__GTHREADS_CXX0X)
+#if defined(__GTHREAD_HAS_COND) && defined(__GTHREADS_CXX0X) && !defined(_AIX)
#define ASYNC_IO 1
#else
#define ASYNC_IO 0
@@ -328,21 +328,18 @@
struct adv_cond
{
+#if ASYNC_IO
int pending;
__gthread_mutex_t lock;
__gthread_cond_t signal;
+#endif
};
typedef struct async_unit
{
+ pthread_mutex_t io_lock; /* Lock for doing actual I/O. */
pthread_mutex_t lock; /* Lock for manipulating the queue structure. */
- pthread_mutex_t io_lock; /* Lock for doing actual I/O. */
- struct adv_cond work;
- struct adv_cond emptysignal;
- struct st_parameter_dt *pdt;
- pthread_t thread;
- struct transfer_queue *head;
- struct transfer_queue *tail;
+ bool empty;
struct
{
int waiting;
@@ -351,7 +348,13 @@
struct adv_cond done;
} id;
- bool empty;
+#if ASYNC_IO
+ struct adv_cond work;
+ struct adv_cond emptysignal;
+ struct st_parameter_dt *pdt;
+ pthread_t thread;
+ struct transfer_queue *head;
+ struct transfer_queue *tail;
struct {
const char *message;
@@ -361,7 +364,7 @@
int family;
bool fatal_error;
} error;
-
+#endif
} async_unit;
void init_async_unit (gfc_unit *);
^ permalink raw reply [flat|nested] 20+ messages in thread
* Re: Async I/O patch with compilation fix
2018-08-22 21:31 ` Thomas Koenig
@ 2018-08-23 12:25 ` David Edelsohn
2018-08-23 17:42 ` Thomas Koenig
2018-08-23 12:53 ` David Edelsohn
1 sibling, 1 reply; 20+ messages in thread
From: David Edelsohn @ 2018-08-23 12:25 UTC (permalink / raw)
To: Thomas Koenig
Cc: Christophe Lyon, Decius Caecilius Metellus, Andre Vieira (lists),
GCC Patches, Fortran List, Ulrich Weigand, clyon
Thomas,
After your complaint about bootstrap on gcc119, I tried it again. My
bootstrap worked correctly. I used exactly the public instructions.
Others have been able to bootstrap on gcc119. The problem is local to
you. Does your environment have any special variables?
You can see the bootstrap in /scratch/dje/GCC
Second, the patch that you applied is unacceptable. ASYNC_IO already is
set to zero for AIX. I refuse to accept this patch as correct or complete.
Third, the problem from the beginning has been __gthread_cond_t. The
earlier patch had
struct adv_cond
{
int pending;
__gthread_mutex_t lock;
__gthread_cond_t signal;
};
with __gthread_cond_t clearly not protected by #if ASYNC_IO. This is
visible by inspection. Without a bootstrap, this patch should have been
visually checked that all uses of __gthread_cond_t were protected.
Similarly one can test this / confirm this on any system by setting
ASYNC_IO to 0 and ensuring that __gthread_cond_t is not declared. This
simply is sloppy work.
Please fix this correctly. The current kludge is not acceptable.
Thanks, David
On Wed, Aug 22, 2018 at 5:30 PM Thomas Koenig <tkoenig@netcologne.de> wrote:
> Hi David,
>
> > This patch broke bootstrap on AIX again. This is completely
> unacceptable.
>
> Again, sorry for the breakage.
>
> I faced quite some challenges trying to get bootstrap to
> work on gcc119. Despite quite a few e-mails (plus hints in a PR)
> that I received, none of the hints for bootstrap I got actually got
> it to work. I finally gave up after four or five different failures,
> and the patch was committed because every test
> that _could_ be run did show no failure.
>
> Had we received instructions that work for bootstrapping on AIX,
> we would have tested the patch there.
>
> If it were possible to add instructions that do work for AIX
> bootstrapping to the compile farm wiki, that would be great.
>
> If you (or somebody else who has the requisite AIX fu) could test
> patches that are known to be difficult, that would also be
> great.
>
> As long as we have no other solution, it is probably best to #ifdef out
> AIX any additional pthread-related functionality for libgfortran that
> might be coming along. That can always be integrated later, if somebody
> can re-implement POSIX condition variables for libgfortran from what
> AIX provides.
>
> Let's talk about how to proceed at the GNU cauldron, over a beer.
> Both Nicolas and I will be there.
>
> In the meantime, I have committed the following patch (r263788) as
> obvious after regression-testing on Linux both with ASYNC_IO set
> to 1 and to 0. Let me know how that works out.
>
> 2018-08-22 Thomas Koenig <tkoenig@gcc.gnu.org>
>
> * async.h: Set ASYNC_IO to zero if _AIX is defined.
> (struct adv_cond): If ASYNC_IO is zero, the struct has no members.
> (async_unit): If ASYNC_IO is zero, remove unneeded members.
>
> 2018-08-22 Thomas Koenig <tkoenig@gcc.gnu.org>
>
> * gfortran.texi: Mention that asynchronous I/O does
> not work on systems which lack condition variables, such
> as AIX.
>
> Regards
>
> Thomas
>
^ permalink raw reply [flat|nested] 20+ messages in thread
* Re: Async I/O patch with compilation fix
2018-08-22 21:31 ` Thomas Koenig
2018-08-23 12:25 ` David Edelsohn
@ 2018-08-23 12:53 ` David Edelsohn
1 sibling, 0 replies; 20+ messages in thread
From: David Edelsohn @ 2018-08-23 12:53 UTC (permalink / raw)
To: Thomas Koenig
Cc: Christophe Lyon, Decius Caecilius Metellus, Andre Vieira (lists),
GCC Patches, Fortran List, Ulrich Weigand, clyon
Thomas,
Once the plural.c file has been re-generated incorrectly using the local
Yacc, it must be deleted and checked out again. Did you pull it fresh from
the repository in your AIX tree after the incorrect checkout?
Thanks, David
On Wed, Aug 22, 2018 at 5:30 PM Thomas Koenig <tkoenig@netcologne.de> wrote:
> Hi David,
>
> > This patch broke bootstrap on AIX again. This is completely
> unacceptable.
>
> Again, sorry for the breakage.
>
> I faced quite some challenges trying to get bootstrap to
> work on gcc119. Despite quite a few e-mails (plus hints in a PR)
> that I received, none of the hints for bootstrap I got actually got
> it to work. I finally gave up after four or five different failures,
> and the patch was committed because every test
> that _could_ be run did show no failure.
>
> Had we received instructions that work for bootstrapping on AIX,
> we would have tested the patch there.
>
> If it were possible to add instructions that do work for AIX
> bootstrapping to the compile farm wiki, that would be great.
>
> If you (or somebody else who has the requisite AIX fu) could test
> patches that are known to be difficult, that would also be
> great.
>
> As long as we have no other solution, it is probably best to #ifdef out
> AIX any additional pthread-related functionality for libgfortran that
> might be coming along. That can always be integrated later, if somebody
> can re-implement POSIX condition variables for libgfortran from what
> AIX provides.
>
> Let's talk about how to proceed at the GNU cauldron, over a beer.
> Both Nicolas and I will be there.
>
> In the meantime, I have committed the following patch (r263788) as
> obvious after regression-testing on Linux both with ASYNC_IO set
> to 1 and to 0. Let me know how that works out.
>
> 2018-08-22 Thomas Koenig <tkoenig@gcc.gnu.org>
>
> * async.h: Set ASYNC_IO to zero if _AIX is defined.
> (struct adv_cond): If ASYNC_IO is zero, the struct has no members.
> (async_unit): If ASYNC_IO is zero, remove unneeded members.
>
> 2018-08-22 Thomas Koenig <tkoenig@gcc.gnu.org>
>
> * gfortran.texi: Mention that asynchronous I/O does
> not work on systems which lack condition variables, such
> as AIX.
>
> Regards
>
> Thomas
>
^ permalink raw reply [flat|nested] 20+ messages in thread
* Re: Async I/O patch with compilation fix
2018-08-23 12:25 ` David Edelsohn
@ 2018-08-23 17:42 ` Thomas Koenig
0 siblings, 0 replies; 20+ messages in thread
From: Thomas Koenig @ 2018-08-23 17:42 UTC (permalink / raw)
To: David Edelsohn
Cc: Christophe Lyon, Decius Caecilius Metellus, Andre Vieira (lists),
GCC Patches, Fortran List, Ulrich Weigand, clyon
David,
I will take the "thank you for restoring bootstrap for AIX" as implied
in your e-mail.
> Second, the patch that you applied is unacceptable. ASYNC_IO already is
> set to zero for AIX.
There is a clear procedure for this something that you deem
"unacceptable": Submit a patch (for which I promise a fast
review) or, if you feel that the patch is simple and obvious,
commit it yourself and announce it to the fortran and gcc-patches
mailing list.
Thomas
^ permalink raw reply [flat|nested] 20+ messages in thread
end of thread, other threads:[~2018-08-23 17:42 UTC | newest]
Thread overview: 20+ messages (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
[not found] <4dd07fa7-65e3-a4ea-b9cd-36eb4c75e875@koenigni.com>
2018-07-26 13:31 ` Build fail on gthr-simple.h targets (Re: AsyncI/O patch committed) Ulrich Weigand
2018-07-26 13:40 ` Build fail on gthr-single.h " Ulrich Weigand
2018-07-26 20:54 ` Build fail on gthr-simple.h " Thomas Koenig
2018-07-27 7:31 ` Thomas Koenig
2018-07-27 12:26 ` David Edelsohn
[not found] ` <5B6021C0.5060507@arm.com>
2018-08-02 11:35 ` Async I/O patch with compilation fix Nicolas Koenig
2018-08-02 15:43 ` Christophe Lyon
2018-08-02 17:08 ` Nicolas Koenig
2018-08-03 8:46 ` Christophe Lyon
2018-08-03 22:43 ` Thomas König
2018-08-06 11:33 ` Christophe Lyon
2018-08-17 15:41 ` Thomas Koenig
2018-08-18 22:44 ` Christophe Lyon
2018-08-19 13:40 ` Thomas Koenig
[not found] ` <CAKdteObsx+RK2t-OteU_w6L_Pv7FGLpAcLrHaPY4NDAamV-z7g@mail.gmail.com>
2018-08-21 19:43 ` Thomas Koenig
2018-08-22 18:49 ` David Edelsohn
2018-08-22 21:31 ` Thomas Koenig
2018-08-23 12:25 ` David Edelsohn
2018-08-23 17:42 ` Thomas Koenig
2018-08-23 12:53 ` David Edelsohn
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).