* Re: [patch, fortran] Asynchronous I/O, take 3
@ 2018-07-05 13:43 Dominique d'Humières
2018-07-15 11:19 ` Thomas Koenig
0 siblings, 1 reply; 22+ messages in thread
From: Dominique d'Humières @ 2018-07-05 13:43 UTC (permalink / raw)
To: Nicolas Koenig, Thomas Koenig; +Cc: gfortran, gcc-patches
I have done a full regression testing with the patch at
https://gcc.gnu.org/ml/fortran/2018-07/msg00004.html + Rainer’s patch
at https://gcc.gnu.org/ml/fortran/2018-07/msg00007.html
I am currently testing the patch at
https://gcc.gnu.org/ml/fortran/2018-07/msg00008.html
so far, so good!
IMO the tests should go to gfortran.dg (they pass my tests).
I think there is a spurious STOP in libgomp.fortran/async_io_1.f90 and the last STOP 1 should be STOP 7, as in:
--- libgomp/testsuite/libgomp.fortran/async_io_1.f90 2018-07-03 12:26:41.000000000 +0200
+++ gcc/testsuite/gfortran.dg/asynchronous_6.f90 2018-07-05 12:57:35.000000000 +0200
@@ -21,7 +21,6 @@ program main
write (10,'(A)', asynchronous=yes) 'asdf'
write (10,*, asynchronous=yes) cc
close (10)
- stop
open (20, file='a.dat', asynchronous=yes)
read (20, *, asynchronous=yes) i, j
read (20, *, asynchronous=yes) k, l
@@ -42,6 +41,6 @@ program main
open(20, file='c.dat', asynchronous=yes)
read(20, *, asynchronous=yes) res
wait (20)
- if (any(res /= is)) stop 1
+ if (any(res /= is)) stop 7
close (20,status="delete")
end program
Thanks for the hard work!
Dominique
^ permalink raw reply [flat|nested] 22+ messages in thread
* Re: [patch, fortran] Asynchronous I/O, take 3
2018-07-05 13:43 [patch, fortran] Asynchronous I/O, take 3 Dominique d'Humières
@ 2018-07-15 11:19 ` Thomas Koenig
2018-07-15 14:21 ` Rainer Orth
` (2 more replies)
0 siblings, 3 replies; 22+ messages in thread
From: Thomas Koenig @ 2018-07-15 11:19 UTC (permalink / raw)
To: Dominique d'Humières, Nicolas Koenig; +Cc: gfortran, gcc-patches
[-- Attachment #1: Type: text/plain, Size: 4035 bytes --]
Hi everybody,
> I am currently testing the patch at
> https://gcc.gnu.org/ml/fortran/2018-07/msg00008.html
>
> so far, so good!
> IMO the tests should go to gfortran.dg (they pass my tests).
I put the asycn_io_*.f90 tests into libgomp.fortran because,
under Linux, gfortran.dg does not link in pthreads, so the
tests would not be executed in parallel, and some of them
would fail.
So, here is the final version. I would really like to get this
into trunk, and out of the way, so Nicolas and I can focus on
other things.
So, OK?
Regards
Thomas
2018-07-15 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-07-15 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-01-15 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-07-15 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: p13j.diff --]
[-- Type: text/x-patch, Size: 69128 bytes --]
Index: gcc/fortran/gfortran.texi
===================================================================
--- gcc/fortran/gfortran.texi (Revision 259739)
+++ gcc/fortran/gfortran.texi (Arbeitskopie)
@@ -882,8 +882,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
@@ -1187,6 +1186,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
@@ -1477,6 +1477,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 259739)
+++ gcc/fortran/trans-decl.c (Arbeitskopie)
@@ -699,7 +699,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 259739)
+++ 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 259739)
+++ 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 259739)
+++ 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 259739)
+++ 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 259739)
+++ 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 \
@@ -1550,6 +1552,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@
@@ -5813,6 +5816,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 259739)
+++ libgfortran/gfortran.map (Arbeitskopie)
@@ -1482,3 +1482,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,483 @@
+/* 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"
+
+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);
+}
Index: libgfortran/io/async.h
===================================================================
--- libgfortran/io/async.h (nicht existent)
+++ libgfortran/io/async.h (Arbeitskopie)
@@ -0,0 +1,378 @@
+/* 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
+
+/* 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);
+
+#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)
+
+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;
+
+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 259739)
+++ 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 (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 259739)
+++ 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 (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 (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 (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 (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 (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 (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 (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 259739)
+++ 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 (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 259739)
+++ 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 259739)
+++ 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 259739)
+++ 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 259739)
+++ 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 (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 259739)
+++ 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 (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 259739)
+++ 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 259739)
+++ libgfortran/libgfortran.h (Arbeitskopie)
@@ -743,6 +743,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);
@@ -1748,5 +1751,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 259739)
+++ 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,38 @@ 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];
+ 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;
+ }
+ }
+
/* 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 +579,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 +609,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: 1324 bytes --]
! { dg-do run }
! 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_7.f90 --]
[-- Type: text/x-fortran, Size: 578 bytes --]
! { dg-do run }
! 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
[-- Attachment #5: async_io_6.f90 --]
[-- Type: text/x-fortran, Size: 432 bytes --]
! { dg-do run }
! 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 #6: async_io_5.f90 --]
[-- Type: text/x-fortran, Size: 3686 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.
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 #7: async_io_4.f90 --]
[-- Type: text/x-fortran, Size: 1686 bytes --]
! { dg-do run { target fd_truncate } }
! 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 #8: async_io_3.f90 --]
[-- Type: text/x-fortran, Size: 360 bytes --]
! { 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 #9: async_io_2.f90 --]
[-- Type: text/x-fortran, Size: 371 bytes --]
! { dg-do run }
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
^ permalink raw reply [flat|nested] 22+ messages in thread
* Re: [patch, fortran] Asynchronous I/O, take 3
2018-07-15 11:19 ` Thomas Koenig
@ 2018-07-15 14:21 ` Rainer Orth
2018-07-15 14:52 ` Thomas Koenig
2018-07-15 17:53 ` Jerry DeLisle
2018-07-15 17:37 ` Jerry DeLisle
2018-09-02 22:39 ` Bernhard Reutner-Fischer
2 siblings, 2 replies; 22+ messages in thread
From: Rainer Orth @ 2018-07-15 14:21 UTC (permalink / raw)
To: Thomas Koenig
Cc: Dominique d'Humières, Nicolas Koenig, gfortran, gcc-patches
Hi Thomas,
>> I am currently testing the patch at
>> https://gcc.gnu.org/ml/fortran/2018-07/msg00008.html
>>
>> so far, so good!
>
>> IMO the tests should go to gfortran.dg (they pass my tests).
>
> I put the asycn_io_*.f90 tests into libgomp.fortran because,
> under Linux, gfortran.dg does not link in pthreads, so the
> tests would not be executed in parallel, and some of them
> would fail.
>
> So, here is the final version. I would really like to get this
> into trunk, and out of the way, so Nicolas and I can focus on
> other things.
I've now regtested the patch on i386-pc-solaris2.11 and
sparc-sun-solaris2.11: no regressions and the new tests all PASS.
However, I still don't understand why you insist on the hack with
putting the async_io_*.f90 tests into the libgomp testsuite. Why not
just make the pthread requirement explicit with
{ dg-require-effective-target pthread }
{ dg-additional-options "-pthread" }
and put them in gfortran.dg where they belong?
Rainer
--
-----------------------------------------------------------------------------
Rainer Orth, Center for Biotechnology, Bielefeld University
^ permalink raw reply [flat|nested] 22+ messages in thread
* Re: [patch, fortran] Asynchronous I/O, take 3
2018-07-15 14:21 ` Rainer Orth
@ 2018-07-15 14:52 ` Thomas Koenig
2018-07-15 17:49 ` Rainer Orth
2018-07-15 17:53 ` Jerry DeLisle
1 sibling, 1 reply; 22+ messages in thread
From: Thomas Koenig @ 2018-07-15 14:52 UTC (permalink / raw)
To: Rainer Orth
Cc: Dominique d'Humières, Nicolas Koenig, gfortran, gcc-patches
Hi Rainer,
> I've now regtested the patch on i386-pc-solaris2.11 and
> sparc-sun-solaris2.11: no regressions and the new tests all PASS.
Thanks, that is good news!
> However, I still don't understand why you insist on the hack with
> putting the async_io_*.f90 tests into the libgomp testsuite. Why not
> just make the pthread requirement explicit with
>
> { dg-require-effective-target pthread }
> { dg-additional-options "-pthread" }
>
> and put them in gfortran.dg where they belong?
Because this does not appear to work with Linux. I, like
most gfortran developers, work on Linux, and I would like to
catch any failure during regression-testing on my own system,
if possible.
We have had this discussion with Jakub, and he advised
us to put all the stuff requiring pthreads into libgomp.
It is debatable if this is a good thing, or if we should
at least make one round of tests with -pthread enabled.
However, this is something for the future, and requires knowledge
of dejagnu that I don't currently have :-)
Regards
Thomas
^ permalink raw reply [flat|nested] 22+ messages in thread
* Re: [patch, fortran] Asynchronous I/O, take 3
2018-07-15 11:19 ` Thomas Koenig
2018-07-15 14:21 ` Rainer Orth
@ 2018-07-15 17:37 ` Jerry DeLisle
2018-09-02 22:39 ` Bernhard Reutner-Fischer
2 siblings, 0 replies; 22+ messages in thread
From: Jerry DeLisle @ 2018-07-15 17:37 UTC (permalink / raw)
To: Thomas Koenig, Dominique d'Humières, Nicolas Koenig
Cc: gfortran, gcc-patches
On 07/15/2018 04:19 AM, Thomas Koenig wrote:
> Hi everybody,
>
>> I am currently testing the patch at
>> https://gcc.gnu.org/ml/fortran/2018-07/msg00008.html
>>
>> so far, so good!
>
>> IMO the tests should go to gfortran.dg (they pass my tests).
>
> I put the asycn_io_*.f90 tests into libgomp.fortran because,
> under Linux, gfortran.dg does not link in pthreads, so the
> tests would not be executed in parallel, and some of them
> would fail.
>
> So, here is the final version. I would really like to get this
> into trunk, and out of the way, so Nicolas and I can focus on
> other things.
>
> So, OK?
OK, Go for it.
Jerry
PS and big kudos for all the effort. This is a major improvement!
^ permalink raw reply [flat|nested] 22+ messages in thread
* Re: [patch, fortran] Asynchronous I/O, take 3
2018-07-15 14:52 ` Thomas Koenig
@ 2018-07-15 17:49 ` Rainer Orth
2018-07-15 17:55 ` Jerry DeLisle
2018-07-15 19:46 ` Thomas Koenig
0 siblings, 2 replies; 22+ messages in thread
From: Rainer Orth @ 2018-07-15 17:49 UTC (permalink / raw)
To: Thomas Koenig
Cc: Dominique d'Humières, Nicolas Koenig, gfortran, gcc-patches
Hi Thomas,
>> However, I still don't understand why you insist on the hack with
>> putting the async_io_*.f90 tests into the libgomp testsuite. Why not
>> just make the pthread requirement explicit with
>>
>> { dg-require-effective-target pthread }
>> { dg-additional-options "-pthread" }
>>
>> and put them in gfortran.dg where they belong?
>
> Because this does not appear to work with Linux. I, like
> most gfortran developers, work on Linux, and I would like to
> catch any failure during regression-testing on my own system,
> if possible.
huh, what doesn't work? I've just finished an x86_64-pc-linux-gnu
bootstrap with your patch included, added the above to the
async_io_?.f90 tests, linked them to gfortran.dg and ran the tests there
(both 32 and 64-bit multilibs), all PASSed and I verified that they were
linked with -lpthread.
> We have had this discussion with Jakub, and he advised
> us to put all the stuff requiring pthreads into libgomp.
Do you have a pointer to that previous discussion?
> It is debatable if this is a good thing, or if we should
> at least make one round of tests with -pthread enabled.
> However, this is something for the future, and requires knowledge
> of dejagnu that I don't currently have :-)
First of all, we need to see and understand the failure mode, if any.
Making this work with the testsuite is a secondary matter only, and I
can certainly help with that if necessary.
Rainer
--
-----------------------------------------------------------------------------
Rainer Orth, Center for Biotechnology, Bielefeld University
^ permalink raw reply [flat|nested] 22+ messages in thread
* Re: [patch, fortran] Asynchronous I/O, take 3
2018-07-15 14:21 ` Rainer Orth
2018-07-15 14:52 ` Thomas Koenig
@ 2018-07-15 17:53 ` Jerry DeLisle
1 sibling, 0 replies; 22+ messages in thread
From: Jerry DeLisle @ 2018-07-15 17:53 UTC (permalink / raw)
To: Rainer Orth, Thomas Koenig
Cc: Dominique d'Humières, Nicolas Koenig, gfortran, gcc-patches
On 07/15/2018 07:21 AM, Rainer Orth wrote:
> Hi Thomas,
>
>>> I am currently testing the patch at
>>> https://gcc.gnu.org/ml/fortran/2018-07/msg00008.html
>>>
>>> so far, so good!
>>
>>> IMO the tests should go to gfortran.dg (they pass my tests).
>>
>> I put the asycn_io_*.f90 tests into libgomp.fortran because,
>> under Linux, gfortran.dg does not link in pthreads, so the
>> tests would not be executed in parallel, and some of them
>> would fail.
>>
>> So, here is the final version. I would really like to get this
>> into trunk, and out of the way, so Nicolas and I can focus on
>> other things.
>
> I've now regtested the patch on i386-pc-solaris2.11 and
> sparc-sun-solaris2.11: no regressions and the new tests all PASS.
>
> However, I still don't understand why you insist on the hack with
> putting the async_io_*.f90 tests into the libgomp testsuite. Why not
> just make the pthread requirement explicit with
>
> { dg-require-effective-target pthread }
> { dg-additional-options "-pthread" }
>
> and put them in gfortran.dg where they belong?
>
> Rainer
>
Rainer, your point well understood. However, I would like to get the
patch in and out to the world to get exercised by users so we can catch
anything we miss. We can work on the gfortran.dg incantations as a
follow-on effort. (maybe a separate PR for it)
Jerry
^ permalink raw reply [flat|nested] 22+ messages in thread
* Re: [patch, fortran] Asynchronous I/O, take 3
2018-07-15 17:49 ` Rainer Orth
@ 2018-07-15 17:55 ` Jerry DeLisle
2018-07-15 18:46 ` Rainer Orth
2018-07-15 19:46 ` Thomas Koenig
1 sibling, 1 reply; 22+ messages in thread
From: Jerry DeLisle @ 2018-07-15 17:55 UTC (permalink / raw)
To: Rainer Orth, Thomas Koenig
Cc: Dominique d'Humières, Nicolas Koenig, gfortran, gcc-patches
On 07/15/2018 10:47 AM, Rainer Orth wrote:
> Hi Thomas,
>
>>> However, I still don't understand why you insist on the hack with
>>> putting the async_io_*.f90 tests into the libgomp testsuite. Why not
>>> just make the pthread requirement explicit with
>>>
>>> { dg-require-effective-target pthread }
>>> { dg-additional-options "-pthread" }
>>>
>>> and put them in gfortran.dg where they belong?
>>
>> Because this does not appear to work with Linux. I, like
>> most gfortran developers, work on Linux, and I would like to
>> catch any failure during regression-testing on my own system,
>> if possible.
>
> huh, what doesn't work? I've just finished an x86_64-pc-linux-gnu
> bootstrap with your patch included, added the above to the
> async_io_?.f90 tests, linked them to gfortran.dg and ran the tests there
> (both 32 and 64-bit multilibs), all PASSed and I verified that they were
> linked with -lpthread.
>
>> We have had this discussion with Jakub, and he advised
>> us to put all the stuff requiring pthreads into libgomp.
>
> Do you have a pointer to that previous discussion?
>
>> It is debatable if this is a good thing, or if we should
>> at least make one round of tests with -pthread enabled.
>> However, this is something for the future, and requires knowledge
>> of dejagnu that I don't currently have :-)
>
> First of all, we need to see and understand the failure mode, if any.
> Making this work with the testsuite is a secondary matter only, and I
> can certainly help with that if necessary.
>
> Rainer
>
Hmm, interesting. Which linux are you using?
I will try it here as well.
Jerry
^ permalink raw reply [flat|nested] 22+ messages in thread
* Re: [patch, fortran] Asynchronous I/O, take 3
2018-07-15 17:55 ` Jerry DeLisle
@ 2018-07-15 18:46 ` Rainer Orth
2018-07-15 19:10 ` Jerry DeLisle
0 siblings, 1 reply; 22+ messages in thread
From: Rainer Orth @ 2018-07-15 18:46 UTC (permalink / raw)
To: Jerry DeLisle
Cc: Thomas Koenig, Dominique d'Humières, Nicolas Koenig,
gfortran, gcc-patches
Hi Jerry,
> Hmm, interesting. Which linux are you using?
Fedora 27.
Rainer
--
-----------------------------------------------------------------------------
Rainer Orth, Center for Biotechnology, Bielefeld University
^ permalink raw reply [flat|nested] 22+ messages in thread
* Re: [patch, fortran] Asynchronous I/O, take 3
2018-07-15 18:46 ` Rainer Orth
@ 2018-07-15 19:10 ` Jerry DeLisle
2018-07-15 19:36 ` Rainer Orth
0 siblings, 1 reply; 22+ messages in thread
From: Jerry DeLisle @ 2018-07-15 19:10 UTC (permalink / raw)
To: Rainer Orth
Cc: Thomas Koenig, Dominique d'Humières, Nicolas Koenig,
gfortran, gcc-patches
On 07/15/2018 11:46 AM, Rainer Orth wrote:
> Hi Jerry,
>
>> Hmm, interesting. Which linux are you using?
>
> Fedora 27.
>
> Rainer
>
Works for me. Fedora 28. Do not know for other OS's
Jerry
^ permalink raw reply [flat|nested] 22+ messages in thread
* Re: [patch, fortran] Asynchronous I/O, take 3
2018-07-15 19:10 ` Jerry DeLisle
@ 2018-07-15 19:36 ` Rainer Orth
2018-07-16 11:25 ` Dominique d'Humières
0 siblings, 1 reply; 22+ messages in thread
From: Rainer Orth @ 2018-07-15 19:36 UTC (permalink / raw)
To: Jerry DeLisle
Cc: Thomas Koenig, Dominique d'Humières, Nicolas Koenig,
gfortran, gcc-patches
Hi Jerry,
> On 07/15/2018 11:46 AM, Rainer Orth wrote:
>> Hi Jerry,
>>
>>> Hmm, interesting. Which linux are you using?
>>
>> Fedora 27.
>
> Works for me. Fedora 28. Do not know for other OS's
just tried Solaris 11/x86: works just as well. I could try Mac OS X
10.7, but that build would take quite a while...
Rainer
--
-----------------------------------------------------------------------------
Rainer Orth, Center for Biotechnology, Bielefeld University
^ permalink raw reply [flat|nested] 22+ messages in thread
* Re: [patch, fortran] Asynchronous I/O, take 3
2018-07-15 17:49 ` Rainer Orth
2018-07-15 17:55 ` Jerry DeLisle
@ 2018-07-15 19:46 ` Thomas Koenig
1 sibling, 0 replies; 22+ messages in thread
From: Thomas Koenig @ 2018-07-15 19:46 UTC (permalink / raw)
To: Rainer Orth
Cc: Dominique d'Humières, Nicolas Koenig, gfortran, gcc-patches
Am 15.07.2018 um 19:47 schrieb Rainer Orth:
>> Because this does not appear to work with Linux. I, like
>> most gfortran developers, work on Linux, and I would like to
>> catch any failure during regression-testing on my own system,
>> if possible.
> huh, what doesn't work? I've just finished an x86_64-pc-linux-gnu
> bootstrap with your patch included, added the above to the
> async_io_?.f90 tests, linked them to gfortran.dg and ran the tests there
> (both 32 and 64-bit multilibs), all PASSed and I verified that they were
> linked with -lpthread.
>
>> We have had this discussion with Jakub, and he advised
>> us to put all the stuff requiring pthreads into libgomp.
> Do you have a pointer to that previous discussion?
>
https://gcc.gnu.org/ml/fortran/2018-04/msg00048.html is what I based
my recollection on.
Regards
Thomas
^ permalink raw reply [flat|nested] 22+ messages in thread
* Re: [patch, fortran] Asynchronous I/O, take 3
2018-07-15 19:36 ` Rainer Orth
@ 2018-07-16 11:25 ` Dominique d'Humières
0 siblings, 0 replies; 22+ messages in thread
From: Dominique d'Humières @ 2018-07-16 11:25 UTC (permalink / raw)
To: Rainer Orth
Cc: jvdelisle, Thomas Koenig, Nicolas Koenig, gfortran, gcc-patches
> Le 15 juil. 2018 à 21:35, Rainer Orth <ro@CeBiTec.Uni-Bielefeld.DE> a écrit :
>
> Hi Jerry,
>
>> On 07/15/2018 11:46 AM, Rainer Orth wrote:
>>> Hi Jerry,
>>>
>>>> Hmm, interesting. Which linux are you using?
>>>
>>> Fedora 27.
>>
>> Works for me. Fedora 28. Do not know for other OS's
>
> just tried Solaris 11/x86: works just as well. I could try Mac OS X
> 10.7, but that build would take quite a while…
Works on OSX.
Dominique
>
> Rainer
>
> --
> -----------------------------------------------------------------------------
> Rainer Orth, Center for Biotechnology, Bielefeld University
^ permalink raw reply [flat|nested] 22+ messages in thread
* Re: [patch, fortran] Asynchronous I/O, take 3
2018-07-15 11:19 ` Thomas Koenig
2018-07-15 14:21 ` Rainer Orth
2018-07-15 17:37 ` Jerry DeLisle
@ 2018-09-02 22:39 ` Bernhard Reutner-Fischer
2018-09-03 9:07 ` Janne Blomqvist
2 siblings, 1 reply; 22+ messages in thread
From: Bernhard Reutner-Fischer @ 2018-09-02 22:39 UTC (permalink / raw)
To: Thomas Koenig; +Cc: Dominique d'Humières, nk, gfortran, GCC Patches
On Sun, 15 Jul 2018 at 13:20, Thomas Koenig <tkoenig@netcologne.de> wrote:
> So, here is the final version. I would really like to get this
> into trunk, and out of the way, so Nicolas and I can focus on
> other things.
>
> So, OK?
[I know i'm late as it was already applied]
For me it would be easier to read the locking if struct async_unit had
it's queue_lock named q_lock/qlock instead of plain lock.
The io_lock is named nicely already.
Furthermore there is a mixture of (correctly wrapped) __gthread_ in
struct adv_cond versus unwrapped pthread_mutex_t in struct async_unit
where i'd have expected the latter to also use the __gthread wrappers.
struct adv_cond member pending should not be an int but an unsigned
int or, even better, a bool, i'd say.
transfer_array_inner () is named unintuitively IMHO. Maybe
transfer_array_now, transfer_array_scalar or transfer_array_1.
Index: libgfortran/io/async.c
===================================================================
--- libgfortran/io/async.c (nicht existent)
+++ libgfortran/io/async.c (Arbeitskopie)
[]
+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);
+}
free (NULL) is perfectly valid, please remove the if.
+static void *
+async_io (void *arg)
+{
[]
+ while (true)
+ {
+ /* Main loop. At this point, au->lock is always held. */
dot space space at the end of a sentence please.
[]
+ while (ctq)
+ {
+ if (prev)
+ free (prev);
Likewise, drop if.
+ prev = ctq;
+ if (!au->error.has_error)
I'd flag that as likely.
Likewise, i'd flag finish_thread as unlikely; Being a label you can
hint the predictor that it's rather unlikely jumped to by flagging it
cold:
finish_thread: __attribute__((cold));
+/* Initialize an asyncronous unit, returning zero on success,
+ nonzero on failure. It also sets u->au. */
+
+void
+init_async_unit (gfc_unit *u)
s/asyncronous/asynchronous/
+{
+ async_unit *au;
+ if (!__gthread_active_p ())
+ {
+ u->au = NULL;
+ return;
+ }
+
Excess horizontal space on the empty line above.
+ au = (async_unit *) xmalloc (sizeof (async_unit));
I'd XCNEW (async_unit) and omit all those NULL and 0 stores.
You should use the scalar allocators provided in include/libiberty.h
throughout, so s/xmalloc/XNEW/ and s/free/XDELETE/ and so on.
+/* 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;
boom on OOM. XCNEW (transfer_queue), please.
+ tq->arg = *arg;
+ tq->type = type;
+ tq->has_id = 0;
redundant store to has_id.
+ 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);
XCNEW.
+/* 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);
XCNEW.
+ tq->type = type;
+ tq->has_id = 0;
Redundant store to has_id. Maybe just comment it out if you do want to
emphasis this side-effect of zeroing.
/* tq->has_id = 0; already done by XCNEW */
or the like.
+/* Enqueue a CLOSE statement. */
+
+void
+enqueue_close (async_unit *au)
+{
+ transfer_queue *tq = calloc (sizeof (transfer_queue), 1);
XCNEW.
And i think enqueue_close does not need internal_proto but could be
and should be static.
Or, even better, remove it completely and call
enqueue_done (au, AIO_CLOSE)
in async_close directly.
+/* 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));
XNEW (st_parameter_dt);
+ transfer_queue *tq = xmalloc (sizeof (transfer_queue));
XNEW (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;
ah, that should be bool, not _Bool and hence s/0/false/ and s/1/true/
here and elsewhere when storing to has_id.
since read_flag seems to be a boolean too, i'd
unsigned has_id : 1;
unsiged read_flag : 1;
fwiw.
+ 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;
s/0/false/ please.
+ UNLOCK (&au->lock);
+ SIGNAL (&au->work);
+}
+/* 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)
I'd rename the parameter i to id for clarity.
+ WAIT_SIGNAL_MUTEX (&(au->id.done),
+ (au->id.low >= au->id.waiting || au->empty), &au->lock);
I'd test au->empty first.
Not sure why it's ok to clear has_error in collect_async_errors --
especially without locking -- but i guess you tested such async
failure conditions in both async_wait_id and async_wait.
Index: libgfortran/io/async.h
===================================================================
--- libgfortran/io/async.h (nicht existent)
+++ libgfortran/io/async.h (Arbeitskopie)
@@ -0,0 +1,378 @@
+/* Thread - local storage of the current unit we are looking at. Needed for
+ error reporting. */
dot space space at the end of a sentence.
The layout of struct async_unit does not look too good on a 64bit box.
+bool collect_async_errors (st_parameter_common *, async_unit *);
+internal_proto (collect_async_errors);
superfluous trailing space
Index: libgfortran/io/file_pos.c
===================================================================
--- libgfortran/io/file_pos.c (Revision 259739)
+++ libgfortran/io/file_pos.c (Arbeitskopie)
@@ -267,8 +280,13 @@ st_backspace (st_parameter_filepos *fpp)
done:
if (u != NULL)
- unlock_unit (u);
+ {
+ unlock_unit (u);
+ if (u->au && needs_unlock)
+ UNLOCK (&u->au->io_lock);
+ }
+
library_end ();
}
in st_backspace you first unlock the unit and only afterwards unlock
the async io_lock.
I would settle on first unlocking the async io_lock and only then
unlocking the unit, no?
@@ -376,9 +406,12 @@ st_endfile (st_parameter_filepos *fpp)
}
}
- done:
- unlock_unit (u);
+ done:
+ if (u->au && needs_unlock)
+ UNLOCK (&u->au->io_lock);
+ unlock_unit (u);
+
library_end ();
}
like you do here, in st_endfile.
Here in st_endfile, why do you async_wait before the
LIBERROR_OPTION_CONFLICT handling by
if (u->flags.access == ACCESS_SEQUENTIAL
&& u->endfile == AFTER_ENDFILE)
and not afterwards?
@@ -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 (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);
I would change the condition to if (ASYNC_IO && needs_unlock) for consistency.
+
library_end ();
}
Index: libgfortran/io/inquire.c
===================================================================
--- libgfortran/io/inquire.c (Revision 259739)
+++ 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>
please include async.h *after* unix.h like you do everwhere else.
Index: libgfortran/io/read.c
===================================================================
--- libgfortran/io/read.c (Revision 259739)
+++ 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
Debugging leftover? Please remove the include and the NOTE.
--- libgfortran/io/transfer.c (Revision 259739)
+++ libgfortran/io/transfer.c (Arbeitskopie)
+/* 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)
+ {
Please move this second nested if into the first one.
+ 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;
+ }
+ }
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)
+ {
Likewise:
Please move this second nested if into the first one.
+ 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);
+}
@@ -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");
s/ASYHCRONOUS/ASYNCHRONOUS/
+ return;
+ }
+ dtp->u.p.async = f == ASYNC_YES;
+ }
[]
+void
+data_transfer_init_worker (st_parameter_dt *dtp, int read_flag)
Missing function comment.
+{
+ 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)
Excess braces
+ && dtp->u.p.current_unit->child_dtio == 0)
Surplus horizontal whitespace before ==
+ dtp->u.p.current_unit->last_char = EOF - 1;
[]
+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);
Surplus trailing whitespace.
+ 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);
Don't we have to honour handled errors from async_wait?
Same for st_write_done ().
+ }
+ }
+ else
+ st_read_done_worker (dtp);
--- libgfortran/io/unit.c (Revision 259739)
+++ libgfortran/io/unit.c (Arbeitskopie)
@@ -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);
This should be indented by 2 spaces, not 4.
return -old_size + NEWUNIT_START;
}
--- libgfortran/libgfortran.h (Revision 259739)
+++ libgfortran/libgfortran.h (Arbeitskopie)
@@ -743,6 +743,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);
why is that exported and not just internal_proto() ?
+
extern void generate_warning (st_parameter_common *, const char *);
internal_proto(generate_warning);
@@ -1748,5 +1751,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 */
obsolete comment, please remove.
Thanks for the async support!
cheers,
^ permalink raw reply [flat|nested] 22+ messages in thread
* Re: [patch, fortran] Asynchronous I/O, take 3
2018-09-02 22:39 ` Bernhard Reutner-Fischer
@ 2018-09-03 9:07 ` Janne Blomqvist
2018-09-03 11:49 ` Bernhard Reutner-Fischer
0 siblings, 1 reply; 22+ messages in thread
From: Janne Blomqvist @ 2018-09-03 9:07 UTC (permalink / raw)
To: Bernhard Reutner-Fischer
Cc: Thomas Koenig, Dominique Dhumieres, Nicolas Koenig, Fortran List,
GCC Patches
On Mon, Sep 3, 2018 at 1:39 AM Bernhard Reutner-Fischer <
rep.dot.nop@gmail.com> wrote:
> On Sun, 15 Jul 2018 at 13:20, Thomas Koenig <tkoenig@netcologne.de> wrote:
>
> + au = (async_unit *) xmalloc (sizeof (async_unit));
>
> I'd XCNEW (async_unit) and omit all those NULL and 0 stores.
> You should use the scalar allocators provided in include/libiberty.h
> throughout, so s/xmalloc/XNEW/ and s/free/XDELETE/ and so on.
>
libgfortran uses it's own allocator wrappers in
libgfortran/runtime/memory.c.
Perhaps there is a case for switching to use these macros instead (why???),
but if so, IMHO that should be done as a separate patch, also fixing all
the other uses of the allocator wrappers.
> +/* 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;
>
> boom on OOM. XCNEW (transfer_queue), please.
>
xcalloc, rather.
--
Janne Blomqvist
^ permalink raw reply [flat|nested] 22+ messages in thread
* Re: [patch, fortran] Asynchronous I/O, take 3
2018-09-03 9:07 ` Janne Blomqvist
@ 2018-09-03 11:49 ` Bernhard Reutner-Fischer
0 siblings, 0 replies; 22+ messages in thread
From: Bernhard Reutner-Fischer @ 2018-09-03 11:49 UTC (permalink / raw)
To: Janne Blomqvist
Cc: Thomas Koenig, Dominique d'Humières, nk, gfortran, GCC Patches
On Mon, 3 Sep 2018 at 11:07, Janne Blomqvist <blomqvist.janne@gmail.com> wrote:
>
> On Mon, Sep 3, 2018 at 1:39 AM Bernhard Reutner-Fischer <rep.dot.nop@gmail.com> wrote:
>>
>> On Sun, 15 Jul 2018 at 13:20, Thomas Koenig <tkoenig@netcologne.de> wrote:
>>
>> + au = (async_unit *) xmalloc (sizeof (async_unit));
>>
>> I'd XCNEW (async_unit) and omit all those NULL and 0 stores.
>> You should use the scalar allocators provided in include/libiberty.h
>> throughout, so s/xmalloc/XNEW/ and s/free/XDELETE/ and so on.
>
>
> libgfortran uses it's own allocator wrappers in libgfortran/runtime/memory.c.
>
> Perhaps there is a case for switching to use these macros instead (why???), but if so, IMHO that should be done as a separate patch, also fixing all the other uses of the allocator wrappers.
The macros are shorter to type. Furthermore we use them in the
frontend already so maybe using them also in the runtime too would be
easier to remember.
As to eventually doing so in a separate patch, that's fair enough.
>
>>
>> +/* 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;
>>
>> boom on OOM. XCNEW (transfer_queue), please.
>
>
> xcalloc, rather.
right.
thanks,
^ permalink raw reply [flat|nested] 22+ messages in thread
* Re: [patch, fortran] Asynchronous I/O, take 3
2018-07-04 8:04 ` Rainer Orth
@ 2018-07-04 17:17 ` Thomas Koenig
0 siblings, 0 replies; 22+ messages in thread
From: Thomas Koenig @ 2018-07-04 17:17 UTC (permalink / raw)
To: fortran
[-- Attachment #1: Type: text/plain, Size: 327 bytes --]
Hi Rainer,
thanks a lot for your testing! This is really making a lot
of difference.
This patch should hopefully fix what you have experienced.
I've left out the boilerplate. The tests that failed for you
will be added to the libgomp.fortran directory as async_io_5.f90,
async_io_6.f90 and async_io_7.f90.
Regards
Thomas
[-- Attachment #2: p13i.diff --]
[-- Type: text/x-patch, Size: 69128 bytes --]
Index: gcc/fortran/gfortran.texi
===================================================================
--- gcc/fortran/gfortran.texi (Revision 259739)
+++ gcc/fortran/gfortran.texi (Arbeitskopie)
@@ -882,8 +882,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
@@ -1187,6 +1186,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
@@ -1477,6 +1477,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 259739)
+++ gcc/fortran/trans-decl.c (Arbeitskopie)
@@ -699,7 +699,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 259739)
+++ 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 259739)
+++ 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 259739)
+++ 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 259739)
+++ 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 259739)
+++ 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 \
@@ -1550,6 +1552,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@
@@ -5813,6 +5816,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 259739)
+++ libgfortran/gfortran.map (Arbeitskopie)
@@ -1482,3 +1482,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,483 @@
+/* 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"
+
+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);
+}
Index: libgfortran/io/async.h
===================================================================
--- libgfortran/io/async.h (nicht existent)
+++ libgfortran/io/async.h (Arbeitskopie)
@@ -0,0 +1,378 @@
+/* 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
+
+/* 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);
+
+#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)
+
+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;
+
+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 259739)
+++ 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 (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 259739)
+++ 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 (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 (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 (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 (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 (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 (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 (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 259739)
+++ 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 (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 259739)
+++ 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 259739)
+++ 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 259739)
+++ 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 259739)
+++ 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 (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 259739)
+++ 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 (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 259739)
+++ 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 259739)
+++ libgfortran/libgfortran.h (Arbeitskopie)
@@ -743,6 +743,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);
@@ -1748,5 +1751,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 259739)
+++ 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,38 @@ 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];
+ 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;
+ }
+ }
+
/* 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 +579,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 +609,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] 22+ messages in thread
* Re: [patch, fortran] Asynchronous I/O, take 3
2018-07-03 17:45 ` Thomas König
@ 2018-07-04 8:04 ` Rainer Orth
2018-07-04 17:17 ` Thomas Koenig
0 siblings, 1 reply; 22+ messages in thread
From: Rainer Orth @ 2018-07-04 8:04 UTC (permalink / raw)
To: Thomas König; +Cc: fortran, gcc-patches, nk
[-- Attachment #1: Type: text/plain, Size: 1915 bytes --]
Hi Thomas,
> Ah, I see what was wrong.
>
> The attached patch should fix this.
it almost did the trick indeed. With the new patch, only two failures
remain:
FAIL: gfortran.dg/flush_1.f90 -O0 execution test
FAIL: gfortran.dg/flush_1.f90 -O1 execution test
FAIL: gfortran.dg/flush_1.f90 -O2 execution test
FAIL: gfortran.dg/flush_1.f90 -O3 -fomit-frame-pointer -funroll-loops -fpeel-loops -ftracer -finline-functions execution test
FAIL: gfortran.dg/flush_1.f90 -O3 -g execution test
FAIL: gfortran.dg/flush_1.f90 -Os execution test
FAIL: gfortran.dg/newunit_1.f90 -O0 execution test
FAIL: gfortran.dg/newunit_1.f90 -O1 execution test
FAIL: gfortran.dg/newunit_1.f90 -O2 execution test
FAIL: gfortran.dg/newunit_1.f90 -O3 -fomit-frame-pointer -funroll-loops -fpeel-loops -ftracer -finline-functions execution test
FAIL: gfortran.dg/newunit_1.f90 -O3 -g execution test
FAIL: gfortran.dg/newunit_1.f90 -Os execution test
Program received signal SIGSEGV: Segmentation fault - invalid memory reference.
Backtrace for this error:
Segmentation Fault
Thread 2 received signal SIGSEGV, Segmentation fault.
[Switching to Thread 1 (LWP 1)]
0xfe1b1773 in mutex_lock_impl () from /lib/libc.so.1
(gdb) where
#0 0xfe1b1773 in mutex_lock_impl () from /lib/libc.so.1
#1 0xfe1b1a03 in pthread_mutex_lock () from /lib/libc.so.1
#2 0xfe5d1da4 in __gthread_mutex_lock (__mutex=0x18)
at ../libgcc/gthr-default.h:748
#3 _gfortran_st_flush (fpp=0xfeffda40)
at /vol/gcc/src/hg/trunk/solaris/libgfortran/io/file_pos.c:514
#4 0x0805106f in flush_1 ()
at /vol/gcc/src/hg/trunk/solaris/gcc/testsuite/gfortran.dg/flush_1.f90:11
#5 0x080512a7 in main (argc=1, argv=0xfeffdbfa)
at /vol/gcc/src/hg/trunk/solaris/gcc/testsuite/gfortran.dg/flush_1.f90:28
#6 0x08050de6 in _start ()
I've not yet investigated why they only occur for 32-bit. I tried the
following snippet to fix them
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: faio31+.patch --]
[-- Type: text/x-patch, Size: 364 bytes --]
--- libgfortran/io/file_pos.c.save 2018-07-03 22:48:42.485018736 +0000
+++ libgfortran/io/file_pos.c 2018-07-04 07:51:43.494582145 +0000
@@ -511,7 +511,8 @@ st_flush (st_parameter_filepos *fpp)
else
{
needs_unlock = true;
- LOCK (&u->au->io_lock);
+ if (u->au)
+ LOCK (&u->au->io_lock);
}
/* Make sure format buffer is flushed. */
[-- Attachment #3: Type: text/plain, Size: 801 bytes --]
which did so indeed, but now there's another failure, again 32-bit only:
FAIL: gfortran.dg/eof_4.f90 -O0 execution test
FAIL: gfortran.dg/eof_4.f90 -O1 execution test
FAIL: gfortran.dg/eof_4.f90 -O2 execution test
FAIL: gfortran.dg/eof_4.f90 -O3 -fomit-frame-pointer -funroll-loops -fpeel-loo
ps -ftracer -finline-functions execution test
FAIL: gfortran.dg/eof_4.f90 -O3 -g execution test
FAIL: gfortran.dg/eof_4.f90 -Os execution test
At line 12 of file /vol/gcc/src/hg/trunk/solaris/gcc/testsuite/gfortran.dg/eof_4.f90 (unit = 99)
Fortran runtime error: Cannot open file 'test.dat': File exists
Error termination. Backtrace:
Rainer
--
-----------------------------------------------------------------------------
Rainer Orth, Center for Biotechnology, Bielefeld University
^ permalink raw reply [flat|nested] 22+ messages in thread
* Re: [patch, fortran] Asynchronous I/O, take 3
2018-07-03 14:24 ` Rainer Orth
2018-07-03 14:42 ` Rainer Orth
@ 2018-07-03 17:45 ` Thomas König
2018-07-04 8:04 ` Rainer Orth
1 sibling, 1 reply; 22+ messages in thread
From: Thomas König @ 2018-07-03 17:45 UTC (permalink / raw)
To: Rainer Orth; +Cc: fortran, gcc-patches, nk
[-- Attachment #1: Type: text/plain, Size: 5433 bytes --]
Hi Rainer,
> However, may
> (all?) gfortran tests now SEGV. One example is
>
> Program received signal SIGSEGV: Segmentation fault - invalid memory reference.
>
> Backtrace for this error:
> Segmentation Fault
>
> Thread 2 received signal SIGSEGV, Segmentation fault.
> [Switching to Thread 1 (LWP 1)]
> 0xfe1b1f03 in pthread_mutex_unlock () from /lib/libc.so.1
> (gdb) where
> #0 0xfe1b1f03 in pthread_mutex_unlock () from /lib/libc.so.1
> #1 0xfe5d1b7c in __gthread_mutex_unlock (__mutex=0x18)
> at ../libgcc/gthr-default.h:778
> #2 _gfortran_st_rewind (fpp=0xfeffda9c)
> at /vol/gcc/src/hg/trunk/solaris/libgfortran/io/file_pos.c:486
> #3 0x0805110f in MAIN__ ()
> at /vol/gcc/src/hg/trunk/solaris/gcc/testsuite/gfortran.dg/backslash_2.f90:6
Ah, I see what was wrong.
The attached patch should fix this.
I have also attached a new test case which detects this error
even on Linux systems, plus a ChangeLog which fixes the typo :-)
Again regression-tested.
So, OK for trunk?
Regards
Thomas
2018-07-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-07-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-01-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-07-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.
> Obviously __mutex above hasn't been properly initialized.
>
>> 2018-07-02 Nicolas Koenig <koenigni@gcc.gnu.org>
>> Thomas Koenig <tkoenig@gcc.gnu.org>
>>
>> PR fortran/25829
>> * testsuite/libgfomp.fortran/async_io_1.f90: New test.
>> * testsuite/libgfomp.fortran/async_io_2.f90: New test.
>> * testsuite/libgfomp.fortran/async_io_3.f90: New test.
>
> You seem to have a special fondness for libgfomp ;-)
>
> Rainer
>
[-- Attachment #2: p13h.diff --]
[-- Type: text/x-patch, Size: 69097 bytes --]
Index: gcc/fortran/gfortran.texi
===================================================================
--- gcc/fortran/gfortran.texi (Revision 259739)
+++ gcc/fortran/gfortran.texi (Arbeitskopie)
@@ -882,8 +882,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
@@ -1187,6 +1186,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
@@ -1477,6 +1477,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 259739)
+++ gcc/fortran/trans-decl.c (Arbeitskopie)
@@ -699,7 +699,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 259739)
+++ 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 259739)
+++ 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 259739)
+++ 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 259739)
+++ 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 259739)
+++ 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 \
@@ -1550,6 +1552,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@
@@ -5813,6 +5816,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 259739)
+++ libgfortran/gfortran.map (Arbeitskopie)
@@ -1482,3 +1482,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,483 @@
+/* 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"
+
+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);
+}
Index: libgfortran/io/async.h
===================================================================
--- libgfortran/io/async.h (nicht existent)
+++ libgfortran/io/async.h (Arbeitskopie)
@@ -0,0 +1,378 @@
+/* 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
+
+/* 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);
+
+#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)
+
+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;
+
+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 259739)
+++ 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 (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 259739)
+++ 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 (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 (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 (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 (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 (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 (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,14 @@ st_flush (st_parameter_filepos *fpp)
u = find_unit (fpp->common.unit);
if (u != NULL)
{
+ 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 +527,8 @@ st_flush (st_parameter_filepos *fpp)
generate_error (&fpp->common, LIBERROR_BAD_OPTION,
"Specified UNIT in FLUSH is not connected");
+ if (u->au && needs_unlock)
+ UNLOCK (&u->au->io_lock);
+
library_end ();
}
Index: libgfortran/io/inquire.c
===================================================================
--- libgfortran/io/inquire.c (Revision 259739)
+++ 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 (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 259739)
+++ 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 259739)
+++ 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 259739)
+++ 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 259739)
+++ 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 (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 259739)
+++ 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 (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 259739)
+++ 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 259739)
+++ libgfortran/libgfortran.h (Arbeitskopie)
@@ -743,6 +743,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);
@@ -1748,5 +1751,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 259739)
+++ 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,38 @@ 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];
+ 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;
+ }
+ }
+
/* 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 +579,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 +609,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: 1331 bytes --]
! { dg-do run }
! 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)
stop
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 1
close (20,status="delete")
end program
[-- Attachment #4: async_io_2.f90 --]
[-- Type: text/x-fortran, Size: 371 bytes --]
! { dg-do run }
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: 360 bytes --]
! { 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/x-fortran, Size: 1686 bytes --]
! { dg-do run { target fd_truncate } }
! 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
^ permalink raw reply [flat|nested] 22+ messages in thread
* Re: [patch, fortran] Asynchronous I/O, take 3
2018-07-03 14:24 ` Rainer Orth
@ 2018-07-03 14:42 ` Rainer Orth
2018-07-03 17:45 ` Thomas König
1 sibling, 0 replies; 22+ messages in thread
From: Rainer Orth @ 2018-07-03 14:42 UTC (permalink / raw)
To: Thomas König; +Cc: fortran, gcc-patches, nk
Hi Thomas,
> another test run on i386-pc-solaris2.11 is underway. However, may
> (all?) gfortran tests now SEGV. One example is
the good news is: all three libgomp.fortran/async_io_?.f90 tests now
PASS for both 32 and 64-bit, as do gfortran.dg/f2003_inquire_1.f03 and
gfortran.dg/f2003_io_1.f03.
Rainer
--
-----------------------------------------------------------------------------
Rainer Orth, Center for Biotechnology, Bielefeld University
^ permalink raw reply [flat|nested] 22+ messages in thread
* Re: [patch, fortran] Asynchronous I/O, take 3
2018-07-02 22:17 Thomas König
@ 2018-07-03 14:24 ` Rainer Orth
2018-07-03 14:42 ` Rainer Orth
2018-07-03 17:45 ` Thomas König
0 siblings, 2 replies; 22+ messages in thread
From: Rainer Orth @ 2018-07-03 14:24 UTC (permalink / raw)
To: Thomas König; +Cc: fortran, gcc-patches, nk
Hi Thomas,
> the attached patch is the third take on Nicolas' and my patch
> for implementing asynchronous I/O. Some parts have been reworked, and
> several bugs which caused either incorrect I/O or hangs have been
> fixed in the process.
>
> I have to say that getting out these bugs has been much harder
> than Nicolas and I originally thought, and that this has cost more
> working hours than any other patch I have been involved in.
>
> This has been regression-tested on x86_64-pc-linux-gnu. The new test
> cases have also been tested in a tight loop with
>
> n=1; while ./a.out; do echo -n $n " " ; n=$((n+1)); done
>
> or (for async_io_3.f90, which is supposed to fail)
>
> while true ; do ./a.out > /dev/null 2>&1 ; echo -n $n " " ; n=$((n+1));
> done
>
> and the test cases also come up clean with valgrind --tool=drd
> (which is a _very_ strict tool which, after this experience, I
> wholeheartedly recommend for doing pthreads debugging).
>
> The interface remains as before - link in pthread to get asynchronous
> I/O, which matches what ifort does.
another test run on i386-pc-solaris2.11 is underway. However, may
(all?) gfortran tests now SEGV. One example is
Program received signal SIGSEGV: Segmentation fault - invalid memory reference.
Backtrace for this error:
Segmentation Fault
Thread 2 received signal SIGSEGV, Segmentation fault.
[Switching to Thread 1 (LWP 1)]
0xfe1b1f03 in pthread_mutex_unlock () from /lib/libc.so.1
(gdb) where
#0 0xfe1b1f03 in pthread_mutex_unlock () from /lib/libc.so.1
#1 0xfe5d1b7c in __gthread_mutex_unlock (__mutex=0x18)
at ../libgcc/gthr-default.h:778
#2 _gfortran_st_rewind (fpp=0xfeffda9c)
at /vol/gcc/src/hg/trunk/solaris/libgfortran/io/file_pos.c:486
#3 0x0805110f in MAIN__ ()
at /vol/gcc/src/hg/trunk/solaris/gcc/testsuite/gfortran.dg/backslash_2.f90:6
Obviously __mutex above hasn't been properly initialized.
> 2018-07-02 Nicolas Koenig <koenigni@gcc.gnu.org>
> Thomas Koenig <tkoenig@gcc.gnu.org>
>
> PR fortran/25829
> * testsuite/libgfomp.fortran/async_io_1.f90: New test.
> * testsuite/libgfomp.fortran/async_io_2.f90: New test.
> * testsuite/libgfomp.fortran/async_io_3.f90: New test.
You seem to have a special fondness for libgfomp ;-)
Rainer
--
-----------------------------------------------------------------------------
Rainer Orth, Center for Biotechnology, Bielefeld University
^ permalink raw reply [flat|nested] 22+ messages in thread
* [patch, fortran] Asynchronous I/O, take 3
@ 2018-07-02 22:17 Thomas König
2018-07-03 14:24 ` Rainer Orth
0 siblings, 1 reply; 22+ messages in thread
From: Thomas König @ 2018-07-02 22:17 UTC (permalink / raw)
To: fortran, gcc-patches, nk
[-- Attachment #1: Type: text/plain, Size: 4938 bytes --]
Hello world,
the attached patch is the third take on Nicolas' and my patch
for implementing asynchronous I/O. Some parts have been reworked, and
several bugs which caused either incorrect I/O or hangs have been
fixed in the process.
I have to say that getting out these bugs has been much harder
than Nicolas and I originally thought, and that this has cost more
working hours than any other patch I have been involved in.
This has been regression-tested on x86_64-pc-linux-gnu. The new test
cases have also been tested in a tight loop with
n=1; while ./a.out; do echo -n $n " " ; n=$((n+1)); done
or (for async_io_3.f90, which is supposed to fail)
while true ; do ./a.out > /dev/null 2>&1 ; echo -n $n " " ; n=$((n+1));
done
and the test cases also come up clean with valgrind --tool=drd
(which is a _very_ strict tool which, after this experience, I
wholeheartedly recommend for doing pthreads debugging).
The interface remains as before - link in pthread to get asynchronous
I/O, which matches what ifort does.
So, OK for trunk?
Regards
Thomas
2018-07-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-07-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-01-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-07-02 Nicolas Koenig <koenigni@gcc.gnu.org>
Thomas Koenig <tkoenig@gcc.gnu.org>
PR fortran/25829
* testsuite/libgfomp.fortran/async_io_1.f90: New test.
* testsuite/libgfomp.fortran/async_io_2.f90: New test.
* testsuite/libgfomp.fortran/async_io_3.f90: New test.
[-- Attachment #2: p13g.diff --]
[-- Type: text/x-patch, Size: 69061 bytes --]
Index: gcc/fortran/gfortran.texi
===================================================================
--- gcc/fortran/gfortran.texi (Revision 259739)
+++ gcc/fortran/gfortran.texi (Arbeitskopie)
@@ -882,8 +882,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
@@ -1187,6 +1186,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
@@ -1477,6 +1477,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 259739)
+++ gcc/fortran/trans-decl.c (Arbeitskopie)
@@ -699,7 +699,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 259739)
+++ 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 259739)
+++ 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 259739)
+++ 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 259739)
+++ 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 259739)
+++ 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 \
@@ -1550,6 +1552,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@
@@ -5813,6 +5816,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 259739)
+++ libgfortran/gfortran.map (Arbeitskopie)
@@ -1482,3 +1482,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,483 @@
+/* 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"
+
+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);
+}
Index: libgfortran/io/async.h
===================================================================
--- libgfortran/io/async.h (nicht existent)
+++ libgfortran/io/async.h (Arbeitskopie)
@@ -0,0 +1,378 @@
+/* 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
+
+/* 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);
+
+#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)
+
+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;
+
+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 259739)
+++ 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 (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 259739)
+++ 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 (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 (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 (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 (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 (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 (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,14 @@ st_flush (st_parameter_filepos *fpp)
u = find_unit (fpp->common.unit);
if (u != NULL)
{
+ 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 +527,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 259739)
+++ 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 (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 259739)
+++ 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 259739)
+++ 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 259739)
+++ 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 259739)
+++ 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 (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 259739)
+++ 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 (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 259739)
+++ 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 259739)
+++ libgfortran/libgfortran.h (Arbeitskopie)
@@ -743,6 +743,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);
@@ -1748,5 +1751,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 259739)
+++ 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,38 @@ 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];
+ 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;
+ }
+ }
+
/* 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 +579,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 +609,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: 1331 bytes --]
! { dg-do run }
! 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)
stop
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 1
close (20,status="delete")
end program
[-- Attachment #4: async_io_2.f90 --]
[-- Type: text/x-fortran, Size: 371 bytes --]
! { dg-do run }
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: 360 bytes --]
! { 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" } }
^ permalink raw reply [flat|nested] 22+ messages in thread
end of thread, other threads:[~2018-09-03 11:49 UTC | newest]
Thread overview: 22+ messages (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2018-07-05 13:43 [patch, fortran] Asynchronous I/O, take 3 Dominique d'Humières
2018-07-15 11:19 ` Thomas Koenig
2018-07-15 14:21 ` Rainer Orth
2018-07-15 14:52 ` Thomas Koenig
2018-07-15 17:49 ` Rainer Orth
2018-07-15 17:55 ` Jerry DeLisle
2018-07-15 18:46 ` Rainer Orth
2018-07-15 19:10 ` Jerry DeLisle
2018-07-15 19:36 ` Rainer Orth
2018-07-16 11:25 ` Dominique d'Humières
2018-07-15 19:46 ` Thomas Koenig
2018-07-15 17:53 ` Jerry DeLisle
2018-07-15 17:37 ` Jerry DeLisle
2018-09-02 22:39 ` Bernhard Reutner-Fischer
2018-09-03 9:07 ` Janne Blomqvist
2018-09-03 11:49 ` Bernhard Reutner-Fischer
-- strict thread matches above, loose matches on Subject: below --
2018-07-02 22:17 Thomas König
2018-07-03 14:24 ` Rainer Orth
2018-07-03 14:42 ` Rainer Orth
2018-07-03 17:45 ` Thomas König
2018-07-04 8:04 ` Rainer Orth
2018-07-04 17:17 ` Thomas Koenig
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).