Skip to content

R
riscv-gcc-1
Commit b1f45884 by Nicolas Koenig
Options

re PR fortran/25829 ([F03] Asynchronous IO support) 

2018-07-25  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-25  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-07-25  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-25  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.


Co-Authored-By: Thomas Koenig <tkoenig@gcc.gnu.org>

From-SVN: r262978
parent 16d0ab7f
Showing with 391 additions and 93 deletions
gcc/fortran/ChangeLog
2018-07-25 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-20 Martin Sebor <msebor@redhat.com>
PR middle-end/82063
......
gcc/fortran/gfortran.texi
......@@ -879,8 +879,7 @@ than @code{(/.../)}. Type-specification for array constructors like
@item Extensions to the specification and initialization expressions,
including the support for intrinsics with real and complex arguments.
@item Support for the asynchronous input/output syntax; however, the
data transfer is currently always synchronously performed.
@item Support for the asynchronous input/output.
@item
@cindex @code{FLUSH} statement
......@@ -1183,6 +1182,7 @@ might in some way or another become visible to the programmer.
* Files opened without an explicit ACTION= specifier::
* File operations on symbolic links::
* File format of unformatted sequential files::
* Asynchronous I/O::
@end menu
......@@ -1486,6 +1486,20 @@ program main
end program main
@end smallexample
@node Asynchronous I/O
@section Asynchronous I/O
@cindex input/output, asynchronous
@cindex asynchronous I/O
Asynchronous I/O is supported if the program is linked against the
POSIX thread library. If that is not the case, all I/O is performed
as synchronous.
On some systems, such as Darwin or Solaris, the POSIX thread library
is always linked in, so asynchronous I/O is always performed. On other
sytems, such as Linux, it is necessary to specify @option{-pthread},
@option{-lpthread} or @option{-fopenmp} during the linking step.
@c ---------------------------------------------------------------------
@c Extensions
@c ---------------------------------------------------------------------
......
gcc/fortran/trans-decl.c
......@@ -698,7 +698,8 @@ gfc_finish_var_decl (tree decl, gfc_symbol * sym)
&& CLASS_DATA (sym)->ts.u.derived->attr.has_dtio_procs)))
TREE_STATIC (decl) = 1;
if (sym->attr.volatile_)
/* Treat asynchronous variables the same as volatile, for now. */
if (sym->attr.volatile_ || sym->attr.asynchronous)
{
TREE_THIS_VOLATILE (decl) = 1;
TREE_SIDE_EFFECTS (decl) = 1;
......
gcc/fortran/trans-io.c
......@@ -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);
......
gcc/testsuite/ChangeLog
2018-07-25 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-07-25 Jakub Jelinek <jakub@redhat.com>
PR c++/85515
......
gcc/testsuite/gfortran.dg/f2003_inquire_1.f03
......@@ -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
......
gcc/testsuite/gfortran.dg/f2003_io_1.f03
......@@ -13,6 +13,7 @@ open(10, file='mydata_f2003_io_1', asynchronous="yes", blank="null")
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)
......
libgfortran/ChangeLog
2018-07-25 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-06-09 Jerry DeLisle <jvdelisle@gcc.gnu.org>
PR libgfortran/86070
......
libgfortran/Makefile.am
......@@ -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 \
......
libgfortran/Makefile.in
......@@ -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) $(am__objects_6) \
@LIBGFOR_MINIMAL_FALSE@ inquire.lo intrinsics.lo list_read.lo \
@LIBGFOR_MINIMAL_FALSE@ lock.lo open.lo read.lo transfer.lo \
@LIBGFOR_MINIMAL_FALSE@ transfer128.lo unit.lo unix.lo write.lo \
@LIBGFOR_MINIMAL_FALSE@ fbuf.lo
@LIBGFOR_MINIMAL_FALSE@ fbuf.lo async.lo
am__objects_49 = size_from_kind.lo $(am__objects_48)
@LIBGFOR_MINIMAL_FALSE@am__objects_50 = access.lo c99_functions.lo \
@LIBGFOR_MINIMAL_FALSE@ chdir.lo chmod.lo clock.lo cpu_time.lo \
......@@ -650,7 +651,8 @@ gfor_io_headers = \
io/io.h \
io/fbuf.h \
io/format.h \
io/unix.h
io/unix.h \
io/async.h
gfor_helper_src = intrinsics/associated.c intrinsics/abort.c \
intrinsics/args.c intrinsics/cshift0.c intrinsics/eoshift0.c \
......@@ -1551,6 +1553,7 @@ distclean-compile:
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/any_l8.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/args.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/associated.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/async.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/backtrace.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/bessel_r10.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/bessel_r16.Plo@am__quote@
......@@ -5814,6 +5817,13 @@ fbuf.lo: io/fbuf.c
@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
@am__fastdepCC_FALSE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o fbuf.lo `test -f 'io/fbuf.c' || echo '$(srcdir)/'`io/fbuf.c
async.lo: io/async.c
@am__fastdepCC_TRUE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT async.lo -MD -MP -MF $(DEPDIR)/async.Tpo -c -o async.lo `test -f 'io/async.c' || echo '$(srcdir)/'`io/async.c
@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/async.Tpo $(DEPDIR)/async.Plo
@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='io/async.c' object='async.lo' libtool=yes @AMDEPBACKSLASH@
@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
@am__fastdepCC_FALSE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o async.lo `test -f 'io/async.c' || echo '$(srcdir)/'`io/async.c
associated.lo: intrinsics/associated.c
@am__fastdepCC_TRUE@ $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT associated.lo -MD -MP -MF $(DEPDIR)/associated.Tpo -c -o associated.lo `test -f 'intrinsics/associated.c' || echo '$(srcdir)/'`intrinsics/associated.c
@am__fastdepCC_TRUE@ $(am__mv) $(DEPDIR)/associated.Tpo $(DEPDIR)/associated.Plo
......
libgfortran/gfortran.map
......@@ -1483,3 +1483,8 @@ GFORTRAN_C99_8 {
y1f;
ynf;
};
GFORTRAN_9 {
global:
_gfortran_st_wait_async;
};
libgfortran/io/close.c
......@@ -24,6 +24,7 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
#include "io.h"
#include "unix.h"
#include "async.h"
#include <limits.h>
typedef enum
......@@ -57,13 +58,21 @@ 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 ();
return;
}
u = find_unit (clp->common.unit);
if (u != NULL)
{
if (close_share (u) < 0)
......
libgfortran/io/file_pos.c
......@@ -25,6 +25,7 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
#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,7 +280,12 @@ 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,8 +406,11 @@ 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,12 +499,24 @@ void
st_flush (st_parameter_filepos *fpp)
{
gfc_unit *u;
bool needs_unlock = false;
library_start (&fpp->common);
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 ();
}
libgfortran/io/inquire.c
......@@ -26,6 +26,7 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
/* 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_unit *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_unit *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)
......
libgfortran/io/io.h
......@@ -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_parameter_dt *) 0)->u.pad)
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);
libgfortran/io/open.c
......@@ -26,6 +26,7 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
#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, unit_flags *flags)
else
u->fbuf = NULL;
/* Check if asynchrounous. */
if (flags->async == ASYNC_YES)
init_async_unit (u);
else
u->au = NULL;
return u;
cleanup:
......
libgfortran/io/read.c
......@@ -30,6 +30,7 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
#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
......
libgfortran/io/unit.c
......@@ -27,6 +27,7 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
#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;
}
......
libgfortran/io/unix.c
......@@ -27,6 +27,7 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
#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_len)
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,31 +1808,31 @@ 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;
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);
}
......
libgfortran/libgfortran.h
......@@ -738,6 +738,9 @@ internal_proto(translate_error);
extern void generate_error (st_parameter_common *, int, const char *);
iexport_proto(generate_error);
extern bool generate_error_common (st_parameter_common *, int, const char *);
iexport_proto(generate_error_common);
extern void generate_warning (st_parameter_common *, const char *);
internal_proto(generate_warning);
......@@ -1743,5 +1746,7 @@ void cshift1_16_c16 (gfc_array_c16 * const restrict,
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 */
libgfortran/runtime/error.c
......@@ -24,6 +24,9 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
#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,36 +579,56 @@ generate_error (st_parameter_common *cmp, int family, const char *message)
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);
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);
......
libgomp/ChangeLog
2018-07-25 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.
2018-07-17 Jakub Jelinek <jakub@redhat.com>
PR middle-end/86542
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment