re PR fortran/14943 (read/write code generation is not thread safe)

gcc/fortran/
	PR fortran/14943
	PR fortran/21647
	* Make-lang.in (fortran/trans-io.o): Depend on fortran/ioparm.def.
	* dump-parse-tree.c (gfc_show_code_node): Dump c->block for
	EXEC_{READ,WRITE,IOLENGTH} nodes.
	* io.c (terminate_io, match_io, gfc_match_inquire): Put data
	transfer commands into EXEC_{READ,WRITE,IOLENGTH}'s code->block.
	* resolve.c (resolve_blocks): Handle EXEC_{READ,WRITE,IOLENGTH}.
	* trans-io.c (ioparm_unit, ioparm_err, ioparm_end, ioparm_eor,
	ioparm_list_format, ioparm_library_return, ioparm_iostat,
	ioparm_exist, ioparm_opened, ioparm_number, ioparm_named,
	ioparm_rec, ioparm_nextrec, ioparm_size, ioparm_recl_in,
	ioparm_recl_out, ioparm_iolength, ioparm_file, ioparm_file_len,
	ioparm_status, ioparm_status_len, ioparm_access, ioparm_access_len,
	ioparm_form, ioparm_form_len, ioparm_blank, ioparm_blank_len,
	ioparm_position, ioparm_position_len, ioparm_action,
	ioparm_action_len, ioparm_delim, ioparm_delim_len, ioparm_pad,
	ioparm_pad_len, ioparm_format, ioparm_format_len, ioparm_advance,
	ioparm_advance_len, ioparm_name, ioparm_name_len,
	ioparm_internal_unit, ioparm_internal_unit_len,
	ioparm_internal_unit_desc, ioparm_sequential, ioparm_sequential_len,
	ioparm_direct, ioparm_direct_len, ioparm_formatted,
	ioparm_formatted_len, ioparm_unformatted, ioparm_unformatted_len,
	ioparm_read, ioparm_read_len, ioparm_write, ioparm_write_len,
	ioparm_readwrite, ioparm_readwrite_len, ioparm_namelist_name,
	ioparm_namelist_name_len, ioparm_namelist_read_mode, ioparm_iomsg,
	ioparm_iomsg_len, ioparm_var): Remove.
	(enum ioparam_type, enum iofield_type, enum iofield,
	enum iocall): New enums.
	(gfc_st_parameter_field, gfc_st_parameter): New typedefs.
	(st_parameter, st_parameter_field, iocall): New variables.
	(ADD_FIELD, ADD_STRING): Remove.
	(dt_parm, dt_post_end_block): New variables.
	(gfc_build_st_parameter): New function.
	(gfc_build_io_library_fndecls): Use it.  Initialize iocall
	array rather than ioparm_*, add extra first arguments to
	the function types.
	(set_parameter_const): New function.
	(set_parameter_value): Add type argument, return a bitmask.
	Changed to set a field in automatic structure variable rather
	than set a field in a global _gfortran_ioparm variable.
	(set_parameter_ref): Likewise.  If requested var has different
	size than what field should point to, call with a temporary and
	then copy into the user variable.  Add postblock argument.
	(set_string): Remove var_len argument, add type argument, return
	a bitmask.  Changed to set fields in automatic structure variable
	rather than set a field in a global _gfortran_ioparm variable.
	(set_internal_unit): Remove iunit, iunit_len, iunit_desc arguments,
	add var argument.  Return a bitmask.  Changed to set fields in
	automatic structure variable rather than set a field in a global
	_gfortran_ioparm variable.
	(set_flag): Removed.
	(io_result): Add var argument.  Changed to read common.flags field
	from automatic structure variable and bitwise AND it with 3.
	(set_error_locus): Add var argument.  Changed to set fields in
	automatic structure variable rather than set a field in a global
	_gfortran_{filename,line} variables.
	(gfc_trans_open): Use gfc_start_block rather than gfc_init_block.
	Create a temporary st_parameter_* structure.  Adjust callers of
	all above mentioned functions.  Pass address of the temporary
	variable as first argument to the generated function call.
	Use iocall array rather than ioparm_* separate variables.
	(gfc_trans_close, build_filepos, gfc_trans_inquire): Likewise.
	(build_dt): Likewise.  Change first argument to tree from tree *.
	Don't dereference code->ext.dt if last_dt == INQUIRE.  Emit
	IOLENGTH argument setup here.  Set dt_parm/dt_post_end_block
	variables and gfc_trans_code the nested data transfer commands
	in code->block.
	(gfc_trans_iolength): Just set last_dt and call build_dt immediately.
	(transfer_namelist_element): Pass address of dt_parm variable
	to generated functions.  Use iocall array rather than ioparm_*
	separate variables.
	(gfc_trans_backspace, gfc_trans_endfile, gfc_trans_rewind,
	gfc_trans_flush, gfc_trans_read, gfc_trans_write): Use iocall array
	rather than ioparm_* separate variables.
	(gfc_trans_dt_end): Likewise.  Pass address of dt_parm variable
	as first argument to generated function.  Adjust io_result caller.
	Prepend dt_post_end_block before io_result code.
	(transfer_expr): Use iocall array rather than ioparm_* separate
	variables.  Pass address of dt_parm variables as first argument
	to generated functions.
	* ioparm.def: New file.
gcc/testsuite/
	PR fortran/24774
	* gfortran.dg/inquire_9.f90: New test.

	PR fortran/21647
	* gfortran.fortran-torture/execute/inquire_5.f90: New test.
libgfortran/
	PR fortran/24774
	PR fortran/14943
	PR fortran/21647
	* Makefile.am (AM_CPPFLAGS): Add gcc directories as -I paths,
	add -D_GNU_SOURCE.
	* Makefile.in: Regenerated.
	* acinclude.m4 (LIBGFOR_CHECK_SYNC_FETCH_AND_ADD,
	LIBGFOR_CHECK_GTHR_DEFAULT, LIBGFOR_CHECK_PRAGMA_WEAK): New macros.
	* configure.ac: Add them.
	* configure: Rebuilt.
	* config.h.in: Rebuilt.
	* libtool-version: Bump libgfortran.so SONAME to libgfortran.so.1.
	* libgfortran.h (library_start, show_locus, internal_error,
	generate_error, find_option): Add st_parameter_common * argument.
	(library_end): Change into a dummy macro.
	* io/io.h: Include gthr.h.
	(SUPPORTS_WEAK): Define if HAVE_PRAGMA_WEAK.
	(CHARACTER): Remove define.
	(st_parameter, global_t): Remove typedef.
	(ioparm, g, ionml, current_unit): Remove variables.
	(init_error_stream): Remove prototype.
	(CHARACTER1, CHARACTER2): Define.
	(st_parameter_common, st_parameter_open, st_parameter_close,
	st_parameter_filepos, st_parameter_inquire, st_parameter_dt): New
	typedefs.
	(IOPARM_LIBRETURN_MASK, IOPARM_LIBRETURN_OK, IOPARM_LIBRETURN_ERROR,
	IOPARM_LIBRETURN_END, IOPARM_LIBRETURN_EOR, IOPARM_ERR, IOPARM_END,
	IOPARM_EOR, IOPARM_HAS_IOSTAT, IOPARM_HAS_IOMSG, IOPARM_COMMON_MASK,
	IOPARM_OPEN_HAS_RECL_IN, IOPARM_OPEN_HAS_FILE, IOPARM_OPEN_HAS_STATUS,
	IOPARM_OPEN_HAS_ACCESS, IOPARM_OPEN_HAS_FORM, IOPARM_OPEN_HAS_BLANK,
	IOPARM_OPEN_HAS_POSITION, IOPARM_OPEN_HAS_ACTION,
	IOPARM_OPEN_HAS_DELIM, IOPARM_OPEN_HAS_PAD, IOPARM_CLOSE_HAS_STATUS,
	IOPARM_INQUIRE_HAS_EXIST, IOPARM_INQUIRE_HAS_OPENED,
	IOPARM_INQUIRE_HAS_NUMBER, IOPARM_INQUIRE_HAS_NAMED,
	IOPARM_INQUIRE_HAS_NEXTREC, IOPARM_INQUIRE_HAS_RECL_OUT,
	IOPARM_INQUIRE_HAS_FILE, IOPARM_INQUIRE_HAS_ACCESS,
	IOPARM_INQUIRE_HAS_FORM, IOPARM_INQUIRE_HAS_BLANK,
	IOPARM_INQUIRE_HAS_POSITION, IOPARM_INQUIRE_HAS_ACTION,
	IOPARM_INQUIRE_HAS_DELIM, IOPARM_INQUIRE_HAS_PAD,
	IOPARM_INQUIRE_HAS_NAME, IOPARM_INQUIRE_HAS_SEQUENTIAL,
	IOPARM_INQUIRE_HAS_DIRECT, IOPARM_INQUIRE_HAS_FORMATTED,
	IOPARM_INQUIRE_HAS_UNFORMATTED, IOPARM_INQUIRE_HAS_READ,
	IOPARM_INQUIRE_HAS_WRITE, IOPARM_INQUIRE_HAS_READWRITE,
	IOPARM_DT_LIST_FORMAT, IOPARM_DT_NAMELIST_READ_MODE,
	IOPARM_DT_HAS_REC, IOPARM_DT_HAS_SIZE, IOPARM_DT_HAS_IOLENGTH,
	IOPARM_DT_HAS_FORMAT, IOPARM_DT_HAS_ADVANCE,
	IOPARM_DT_HAS_INTERNAL_UNIT, IOPARM_DT_HAS_NAMELIST_NAME,
	IOPARM_DT_IONML_SET): Define.
	(gfc_unit): Add lock, waiting and close fields.  Change file
	from flexible array member into pointer to char.
	(open_external): Add st_parameter_open * argument.
	(find_file, file_exists): Add file and file_len arguments.
	(flush_all_units): New prototype.
	(max_offset, unit_root, unit_lock): New variable.
	(is_internal_unit, is_array_io, next_array_record,
	parse_format, next_format, unget_format, format_error,
	read_block, write_block, next_record, convert_real,
	read_a, read_f, read_l, read_x, read_radix, read_decimal,
	list_formatted_read, finish_list_read, namelist_read,
	namelist_write, write_a, write_b, write_d, write_e, write_en,
	write_es, write_f, write_i, write_l, write_o, write_x, write_z,
	list_formatted_write, get_unit): Add st_parameter_dt * argument.
	(insert_unit): Remove prototype.
	(find_or_create_unit, unlock_unit): New prototype.
	(new_unit): Return gfc_unit *.  Add st_parameter_open *
	and gfc_unit * arguments.
	(free_fnodes): Remove prototype.
	(free_format_data): New prototype.
	(scratch): Remove.
	(init_at_eol): Remove prototype.
	(free_ionml): New prototype.
	(inc_waiting_locked, predec_waiting_locked, dec_waiting_unlocked):
	New inline functions.
	* io/unit.c (max_offset, unit_root, unit_lock): New variables.
	(insert): Adjust os_error caller.
	(insert_unit): Made static.  Allocate memory here, initialize
	lock and after inserting it return it, locked.
	(delete_unit): Adjust for deletion of g.
	(find_unit_1): New function.
	(find_unit): Use it.
	(find_or_create_unit): New function.
	(get_unit): Add dtp argument, change meaning of the int argument
	as creation request flag.  Adjust for different st_* calling
	conventions, lock internal unit's lock before returning it
	and removal of g.  Call find_unit_1 instead of find_unit.
	(is_internal_unit, is_array_io): Add dtp argument, adjust for
	removal of most of global variables.
	(init_units): Initialize unit_lock.  Adjust insert_unit callers
	and adjust for g removal.
	(close_unit_1): New function.
	(close_unit): Use it.
	(unlock_unit): New function.
	(close_units): Lock unit_lock, use close_unit_1 rather than
	close_unit.
	* io/close.c (st_close): Add clp argument.  Adjust for new
	st_* calling conventions and internal function API changes.
	* io/file_pos.c (st_backspace, st_endfile, st_rewind, st_flush):
	Add fpp argument.  Adjust for new st_* calling conventions and
	internal function API changes.
	(formatted_backspace, unformatted_backspace): Likewise.  Add
	u argument.
	* io/open.c (edit_modes, st_open): Add opp argument.  Adjust for
	new st_* calling conventions and internal function API changes.
	(already_open): Likewise.  If not HAVE_UNLINK_OPEN_FILE, unlink
	scratch file.  Instead of calling close_unit just call sclose,
	free u->file if any and clear a few u fields before calling
	new_unit.
	(new_unit): Return gfc_unit *.  Add opp and u arguments.
	Adjust for new st_* calling conventions and internal function
	API changes.  Don't allocate unit here, rather than work with
	already created unit u already locked on entry.  In case
	of failure, close_unit it.
	* io/unix.c: Include unix.h.
	(BUFFER_SIZE, unix_stream): Moved to unix.h.
	(unit_to_fd): Add unlock_unit call.
	(tempfile): Add opp argument, use its fields rather than ioparm.
	(regular_file): Likewise.
	(open_external): Likewise.  Only unlink file if fd >= 0.
	(init_error_stream): Add error argument, set structure it points
	to rather than filling static variable and returning its address.
	(FIND_FILE0_DECL, FIND_FILE0_ARGS): Define.
	(find_file0): Use them.  Don't crash if u->s == NULL.
	(find_file): Add file and file_len arguments, use them instead
	of ioparm.  Add locking.  Pass either an array of 2 struct stat
	or file and file_len pair to find_file0.
	(flush_all_units_1, flush_all_units): New functions.
	(file_exists): Add file and file_len arguments, use them instead
	of ioparm.
	* io/unix.h: New file.
	* io/lock.c (ioparm, g, ionml): Remove variables.
	(library_start): Add cmp argument, adjust for new st_* calling
	conventions.
	(library_end): Remove.
	(free_ionml): New function.
	* io/inquire.c (inquire_via_unit, inquire_via_filename,
	st_inquire): Add iqp argument, adjust for new st_* calling
	conventions and internal function API changes.
	* io/format.c (FARRAY_SIZE): Decrease to 64.
	(fnode_array, format_data): New typedefs.
	(avail, array, format_string, string, error, saved_token, value,
	format_string_len, reversion_ok, saved_format): Remove variables.
	(colon_node): Add const.
	(free_fnode, free_fnodes): Remove.
	(free_format_data): New function.
	(next_char, unget_char, get_fnode, format_lex, parse_format_list,
	format_error, parse_format, revert, unget_format, next_test): Add
	fmt or dtp arguments, pass it all around, adjust for internal
	function API changes and adjust for removal of global variables.
	(next_format): Likewise.  Constify return type.
	(next_format0): Constify return type.
	* io/transfer.c (current_unit, sf_seen_eor, eor_condition, max_pos,
	skips, pending_spaces, scratch, line_buffer, advance_status,
	transfer): Remove variables.
	(transfer_integer, transfer_real, transfer_logical,
	transfer_character, transfer_complex, transfer_array, current_mode,
	read_sf, read_block, read_block_direct, write_block,
	write_block_direct, unformatted_read, unformatted_write,
	type_name, write_constant_string, require_type,
	formatted_transfer_scalar, us_read, us_write, pre_position,
	data_transfer_init, next_record_r, next_record_w, next_record,
	finalize_transfer, iolength_transfer, iolength_transfer_init,
	st_iolength, st_iolength_done, st_read, st_read_done, st_write,
	st_write_done, st_set_nml_var, st_set_nml_var_dim,
	next_array_record): Add dtp argument, pass it all around, adjust for
	internal function API changes and removal of global variables.
	* io/list_read.c (repeat_count, saved_length, saved_used,
	input_complete, at_eol, comma_flag, last_char, saved_string,
	saved_type, namelist_mode, nml_read_error, value, parse_err_msg,
	nml_err_msg, prev_nl): Remove variables.
	(push_char, free_saved, next_char, unget_char, eat_spaces,
	eat_separator, finish_separator, nml_bad_return, convert_integer,
	parse_repeat, read_logical, read_integer, read_character,
	parse_real, read_complex, read_real, check_type,
	list_formatted_read_scalar, list_formatted_read, finish_list_read,
	find_nml_node, nml_untouch_nodes, nml_match_name, nml_query,
	namelist_read): Add dtp argument, pass it all around, adjust for
	internal function API changes and removal of global variables.
	(nml_parse_qualifier): Likewise.  Add parse_err_msg argument.
	(nml_read_obj): Likewise.  Add pprev_nl, nml_err_msg, clow and
	chigh arguments.
	(nml_get_obj_data): Likewise.  Add pprev_nl and nml_err_msg
	arguments.
	(init_at_eol): Removed.
	* io/read.c (convert_real, read_l, read_a, next_char, read_decimal,
	read_radix, read_f, read_x): Add dtp argument, pass it all around,
	adjust for internal function API changes and removal of global
	variables.
	(set_integer): Adjust internal_error caller.
	* io/write.c (no_leading_blank, nml_delim): Remove variables.
	(write_a, calculate_sign, calculate_G_format, output_float,
	write_l, write_float, write_int, write_decimal, write_i, write_b,
	write_o, write_z, write_d, write_e, write_f, write_en, write_es,
	write_x, write_char, write_logical, write_integer, write_character,
	write_real, write_complex, write_separator,
	list_formatted_write_scalar, list_formatted_write, nml_write_obj,
	namelist_write): Add dtp argument, pass it all around, adjust for
	internal function API changes and removal of global variables.
	(extract_int, extract_uint, extract_real): Adjust internal_error
	callers.
	* runtime/fpu.c (_GNU_SOURCE): Don't define here.
	* runtime/error.c: Include ../io/unix.h.
	(filename, line): Remove variables.
	(st_printf): Pass address of a local variable to init_error_stream.
	(show_locus): Add cmp argument.  Use fields it points to rather than
	filename and line variables.
	(os_error, runtime_error): Remove show_locus calls.
	(internal_error): Add cmp argument.  Pass it down to show_locus.
	(generate_error): Likewise.  Use flags bitmask instead of non-NULL
	check for iostat and iomsg parameter presence, adjust for st_*
	calling convention changes.
	* runtime/stop.c (stop_numeric, stop_string): Remove show_locus
	calls.
	* runtime/pause.c (pause_numeric, pause_string): Likewise.
	* runtime/string.c: Include ../io/io.h.
	(find_option): Add cmp argument.  Pass it down to generate_error.
	* intrinsics/flush.c (recursive_flush): Remove.
	(flush_i4, flush_i8): Use flush_all_units.  Add unlock_unit
	call.
	* intrinsics/rand.c: Include ../io/io.h.
	(rand_seed_lock): New variable.
	(srand, irand): Add locking.
	(init): New constructor function.
	* intrinsics/random.c: Include ../io/io.h.
	(random_lock): New variable.
	(random_r4, random_r8, arandom_r4, arandom_r8): Add locking.
	(random_seed): Likewise.  open failed if fd < 0.  Set i correctly.
	(init): New constructor function.
	* intrinsics/system_clock.c (tp0, t0): Remove.
	(system_clock_4, system_clock_8): Don't subtract tp0/t0 from current
	time, use just integer arithmetics.
	* intrinsics/tty.c (isatty_l4, isatty_l8, ttynam_sub): Add
	unlock_unit calls.

From-SVN: r107328

1 files changed, 222 insertions, 65 deletions

diff --git a/libgfortran/io/unit.c b/libgfortran/io/unit.c
index c22d593..8ac1a7d 100644
--- a/libgfortran/io/unit.c
+++ b/libgfortran/io/unit.c
@@ -34,12 +34,55 @@ Boston, MA 02110-1301, USA.  */
 #include "io.h"
 
 
+/* IO locking rules:
+   UNIT_LOCK is a master lock, protecting UNIT_ROOT tree and UNIT_CACHE.
+   Concurrent use of different units should be supported, so
+   each unit has its own lock, LOCK.
+   Open should be atomic with its reopening of units and list_read.c
+   in several places needs find_unit another unit while holding stdin
+   unit's lock, so it must be possible to acquire UNIT_LOCK while holding
+   some unit's lock.  Therefore to avoid deadlocks, it is forbidden
+   to acquire unit's private locks while holding UNIT_LOCK, except
+   for freshly created units (where no other thread can get at their
+   address yet) or when using just trylock rather than lock operation.
+   In addition to unit's private lock each unit has a WAITERS counter
+   and CLOSED flag.  WAITERS counter must be either only
+   atomically incremented/decremented in all places (if atomic builtins
+   are supported), or protected by UNIT_LOCK in all places (otherwise).
+   CLOSED flag must be always protected by unit's LOCK.
+   After finding a unit in UNIT_CACHE or UNIT_ROOT with UNIT_LOCK held,
+   WAITERS must be incremented to avoid concurrent close from freeing
+   the unit between unlocking UNIT_LOCK and acquiring unit's LOCK.
+   Unit freeing is always done under UNIT_LOCK.  If close_unit sees any
+   WAITERS, it doesn't free the unit but instead sets the CLOSED flag
+   and the thread that decrements WAITERS to zero while CLOSED flag is
+   set is responsible for freeing it (while holding UNIT_LOCK).
+   flush_all_units operation is iterating over the unit tree with
+   increasing UNIT_NUMBER while holding UNIT_LOCK and attempting to
+   flush each unit (and therefore needs the unit's LOCK held as well).
+   To avoid deadlocks, it just trylocks the LOCK and if unsuccessful,
+   remembers the current unit's UNIT_NUMBER, unlocks UNIT_LOCK, acquires
+   unit's LOCK and after flushing reacquires UNIT_LOCK and restarts with
+   the smallest UNIT_NUMBER above the last one flushed.
+
+   If find_unit/find_or_create_unit/find_file/get_unit routines return
+   non-NULL, the returned unit has its private lock locked and when the
+   caller is done with it, it must call either unlock_unit or close_unit
+   on it.  unlock_unit or close_unit must be always called only with the
+   private lock held.  */
+
 /* Subroutines related to units */
 
 
 #define CACHE_SIZE 3
 static gfc_unit internal_unit, *unit_cache[CACHE_SIZE];
-
+gfc_offset max_offset;
+gfc_unit *unit_root;
+#ifdef __GTHREAD_MUTEX_INIT
+__gthread_mutex_t unit_lock = __GTHREAD_MUTEX_INIT;
+#else
+__gthread_mutex_t unit_lock;
+#endif
 
 /* This implementation is based on Stefan Nilsson's article in the
  * July 1997 Doctor Dobb's Journal, "Treaps in Java". */
@@ -104,7 +147,7 @@ compare (int a, int b)
 /* insert()-- Recursive insertion function.  Returns the updated treap. */
 
 static gfc_unit *
-insert (gfc_unit * new, gfc_unit * t)
+insert (gfc_unit *new, gfc_unit *t)
 {
   int c;
 
@@ -128,20 +171,32 @@ insert (gfc_unit * new, gfc_unit * t)
     }
 
   if (c == 0)
-    internal_error ("insert(): Duplicate key found!");
+    internal_error (NULL, "insert(): Duplicate key found!");
 
   return t;
 }
 
 
-/* insert_unit()-- Given a new node, insert it into the treap.  It is
- * an error to insert a key that already exists. */
+/* insert_unit()-- Create a new node, insert it into the treap.  */
 
-void
-insert_unit (gfc_unit * new)
+static gfc_unit *
+insert_unit (int n)
 {
-  new->priority = pseudo_random ();
-  g.unit_root = insert (new, g.unit_root);
+  gfc_unit *u = get_mem (sizeof (gfc_unit));
+  memset (u, '\0', sizeof (gfc_unit));
+  u->unit_number = n;
+#ifdef __GTHREAD_MUTEX_INIT
+  {
+    __gthread_mutex_t tmp = __GTHREAD_MUTEX_INIT;
+    u->lock = tmp;
+  }
+#else
+  __GTHREAD_MUTEX_INIT_FUNCTION (&u->lock);
+#endif
+  __gthread_mutex_lock (&u->lock);
+  u->priority = pseudo_random ();
+  unit_root = insert (u, unit_root);
+  return u;
 }
 
 
@@ -201,27 +256,30 @@ delete_treap (gfc_unit * old, gfc_unit * t)
 static void
 delete_unit (gfc_unit * old)
 {
-  g.unit_root = delete_treap (old, g.unit_root);
+  unit_root = delete_treap (old, unit_root);
 }
 
 
 /* find_unit()-- Given an integer, return a pointer to the unit
- * structure.  Returns NULL if the unit does not exist. */
+ * structure.  Returns NULL if the unit does not exist,
+ * otherwise returns a locked unit. */
 
-gfc_unit *
-find_unit (int n)
+static gfc_unit *
+find_unit_1 (int n, int do_create)
 {
   gfc_unit *p;
-  int c;
+  int c, created = 0;
 
+  __gthread_mutex_lock (&unit_lock);
+retry:
   for (c = 0; c < CACHE_SIZE; c++)
     if (unit_cache[c] != NULL && unit_cache[c]->unit_number == n)
       {
 	p = unit_cache[c];
-	return p;
+	goto found;
       }
 
-  p = g.unit_root;
+  p = unit_root;
   while (p != NULL)
     {
       c = compare (n, p->unit_number);
@@ -233,6 +291,12 @@ find_unit (int n)
 	break;
     }
 
+  if (p == NULL && do_create)
+    {
+      p = insert_unit (n);
+      created = 1;
+    }
+
   if (p != NULL)
     {
       for (c = 0; c < CACHE_SIZE - 1; c++)
@@ -241,35 +305,86 @@ find_unit (int n)
       unit_cache[CACHE_SIZE - 1] = p;
     }
 
+  if (created)
+    {
+      /* Newly created units have their lock held already
+	 from insert_unit.  Just unlock UNIT_LOCK and return.  */
+      __gthread_mutex_unlock (&unit_lock);
+      return p;
+    }
+
+found:
+  if (p != NULL)
+    {
+      /* Fast path.  */
+      if (! __gthread_mutex_trylock (&p->lock))
+	{
+	  /* assert (p->closed == 0); */
+	  __gthread_mutex_unlock (&unit_lock);
+	  return p;
+	}
+
+      inc_waiting_locked (p);
+    }
+
+  __gthread_mutex_unlock (&unit_lock);
+
+  if (p != NULL)
+    {
+      __gthread_mutex_lock (&p->lock);
+      if (p->closed)
+	{
+	  __gthread_mutex_lock (&unit_lock);
+	  __gthread_mutex_unlock (&p->lock);
+	  if (predec_waiting_locked (p) == 0)
+	    free_mem (p);
+	  goto retry;
+	}
+
+      dec_waiting_unlocked (p);
+    }
   return p;
 }
 
+gfc_unit *
+find_unit (int n)
+{
+  return find_unit_1 (n, 0);
+}
+
+gfc_unit *
+find_or_create_unit (int n)
+{
+  return find_unit_1 (n, 1);
+}
+
 /* get_unit()-- Returns the unit structure associated with the integer
  * unit or the internal file. */
 
 gfc_unit *
-get_unit (int read_flag __attribute__ ((unused)))
+get_unit (st_parameter_dt *dtp, int do_create)
 {
-  if (ioparm.internal_unit != NULL)
+  if ((dtp->common.flags & IOPARM_DT_HAS_INTERNAL_UNIT) != 0)
     {
-      internal_unit.recl = ioparm.internal_unit_len;
-      if (is_array_io())
-      {
-        internal_unit.rank = GFC_DESCRIPTOR_RANK(ioparm.internal_unit_desc);
-        internal_unit.ls = (array_loop_spec*)
-          get_mem (internal_unit.rank * sizeof (array_loop_spec));
-        ioparm.internal_unit_len *=
-	  init_loop_spec (ioparm.internal_unit_desc, internal_unit.ls);
-      }
-        
+      __gthread_mutex_lock (&internal_unit.lock);
+      internal_unit.recl = dtp->internal_unit_len;
+      if (is_array_io (dtp))
+	{
+	  internal_unit.rank = GFC_DESCRIPTOR_RANK (dtp->internal_unit_desc);
+	  internal_unit.ls = (array_loop_spec *)
+	    get_mem (internal_unit.rank * sizeof (array_loop_spec));
+	  dtp->internal_unit_len *=
+	    init_loop_spec (dtp->internal_unit_desc, internal_unit.ls);
+	}
+
       internal_unit.s =
-	open_internal (ioparm.internal_unit, ioparm.internal_unit_len);
+	open_internal (dtp->internal_unit, dtp->internal_unit_len);
       internal_unit.bytes_left = internal_unit.recl;
       internal_unit.last_record=0;
       internal_unit.maxrec=0;
       internal_unit.current_record=0;
 
-      if (g.mode==WRITING && !is_array_io())
+      if (dtp->u.p.mode==WRITING && !is_array_io (dtp))
         empty_internal_buffer (internal_unit.s);
 
       /* Set flags for the internal unit */
@@ -284,25 +399,25 @@ get_unit (int read_flag __attribute__ ((unused)))
 
   /* Has to be an external unit */
 
-  return find_unit (ioparm.unit);
+  return find_unit_1 (dtp->common.unit, do_create);
 }
 
 
 /* is_internal_unit()-- Determine if the current unit is internal or not */
 
 int
-is_internal_unit (void)
+is_internal_unit (st_parameter_dt *dtp)
 {
-  return current_unit == &internal_unit;
+  return dtp->u.p.current_unit == &internal_unit;
 }
 
 
 /* is_array_io ()-- Determine if the I/O is to/from an array */
 
 int
-is_array_io (void)
+is_array_io (st_parameter_dt *dtp)
 {
-  return (ioparm.internal_unit_desc != NULL);
+  return dtp->internal_unit_desc != NULL;
 }
 
 
@@ -315,12 +430,22 @@ init_units (void)
   gfc_unit *u;
   unsigned int i;
 
+#ifndef __GTHREAD_MUTEX_INIT
+  __GTHREAD_MUTEX_INIT_FUNCTION (&unit_lock);
+#endif
+
+#ifdef __GTHREAD_MUTEX_INIT
+  {
+    __gthread_mutex_t tmp = __GTHREAD_MUTEX_INIT;
+    internal_unit.lock = tmp;
+  }
+#else
+  __GTHREAD_MUTEX_INIT_FUNCTION (&internal_unit.lock);
+#endif
+
   if (options.stdin_unit >= 0)
     {				/* STDIN */
-      u = get_mem (sizeof (gfc_unit));
-      memset (u, '\0', sizeof (gfc_unit));
-
-      u->unit_number = options.stdin_unit;
+      u = insert_unit (options.stdin_unit);
       u->s = input_stream ();
 
       u->flags.action = ACTION_READ;
@@ -334,15 +459,12 @@ init_units (void)
       u->recl = options.default_recl;
       u->endfile = NO_ENDFILE;
 
-      insert_unit (u);
+      __gthread_mutex_unlock (&u->lock);
     }
 
   if (options.stdout_unit >= 0)
     {				/* STDOUT */
-      u = get_mem (sizeof (gfc_unit));
-      memset (u, '\0', sizeof (gfc_unit));
-
-      u->unit_number = options.stdout_unit;
+      u = insert_unit (options.stdout_unit);
       u->s = output_stream ();
 
       u->flags.action = ACTION_WRITE;
@@ -356,15 +478,12 @@ init_units (void)
       u->recl = options.default_recl;
       u->endfile = AT_ENDFILE;
 
-      insert_unit (u);
+      __gthread_mutex_unlock (&u->lock);
     }
 
   if (options.stderr_unit >= 0)
     {				/* STDERR */
-      u = get_mem (sizeof (gfc_unit));
-      memset (u, '\0', sizeof (gfc_unit));
-
-      u->unit_number = options.stderr_unit;
+      u = insert_unit (options.stderr_unit);
       u->s = error_stream ();
 
       u->flags.action = ACTION_WRITE;
@@ -378,7 +497,7 @@ init_units (void)
       u->recl = options.default_recl;
       u->endfile = AT_ENDFILE;
 
-      insert_unit (u);
+      __gthread_mutex_unlock (&u->lock);
     }
 
   /* Calculate the maximum file offset in a portable manner.
@@ -386,40 +505,78 @@ init_units (void)
    *
    * set a 1 in the LSB and keep a running sum, stopping at MSB-1 bit. */
 
-  g.max_offset = 0;
-  for (i = 0; i < sizeof (g.max_offset) * 8 - 1; i++)
-    g.max_offset = g.max_offset + ((gfc_offset) 1 << i);
-
+  max_offset = 0;
+  for (i = 0; i < sizeof (max_offset) * 8 - 1; i++)
+    max_offset = max_offset + ((gfc_offset) 1 << i);
 }
 
 
-/* close_unit()-- Close a unit.  The stream is closed, and any memory
- * associated with the stream is freed.  Returns nonzero on I/O error. */
-
-int
-close_unit (gfc_unit * u)
+static int
+close_unit_1 (gfc_unit *u, int locked)
 {
   int i, rc;
 
+  rc = (u->s == NULL) ? 0 : sclose (u->s) == FAILURE;
+
+  u->closed = 1;
+  if (!locked)
+    __gthread_mutex_lock (&unit_lock);
+
   for (i = 0; i < CACHE_SIZE; i++)
     if (unit_cache[i] == u)
       unit_cache[i] = NULL;
 
-  rc = (u->s == NULL) ? 0 : sclose (u->s) == FAILURE;
-
   delete_unit (u);
-  free_mem (u);
+
+  if (u->file)
+    free_mem (u->file);
+  u->file = NULL;
+  u->file_len = 0;
+
+  if (!locked)
+    __gthread_mutex_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
+     instead.  */
+  if (u->waiting == 0)
+    free_mem (u);
+
+  if (!locked)
+    __gthread_mutex_unlock (&unit_lock);
 
   return rc;
 }
 
+void
+unlock_unit (gfc_unit *u)
+{
+  __gthread_mutex_unlock (&u->lock);
+}
+
+/* close_unit()-- Close a unit.  The stream is closed, and any memory
+ * associated with the stream is freed.  Returns nonzero on I/O error.
+ * Should be called with the u->lock locked. */
+
+int
+close_unit (gfc_unit *u)
+{
+  return close_unit_1 (u, 0);
+}
+
 
 /* close_units()-- Delete units on completion.  We just keep deleting
- * the root of the treap until there is nothing left. */
+ * the root of the treap until there is nothing left.
+ * Not sure what to do with locking here.  Some other thread might be
+ * holding some unit's lock and perhaps hold it indefinitely
+ * (e.g. waiting for input from some pipe) and close_units shouldn't
+ * delay the program too much.  */
 
 void
 close_units (void)
 {
-  while (g.unit_root != NULL)
-    close_unit (g.unit_root);
+  __gthread_mutex_lock (&unit_lock);
+  while (unit_root != NULL)
+    close_unit_1 (unit_root, 1);
+  __gthread_mutex_unlock (&unit_lock);
 }