1 /* Copyright (C) 2002, 2003, 2005, 2007, 2008, 2009 Free Software Foundation, Inc.
2 Contributed by Andy Vaught
3 F2003 I/O support contributed by Jerry DeLisle
5 This file is part of the GNU Fortran 95 runtime library (libgfortran).
7 Libgfortran is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 3, or (at your option)
12 Libgfortran is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 Under Section 7 of GPL version 3, you are granted additional
18 permissions described in the GCC Runtime Library Exception, version
19 3.1, as published by the Free Software Foundation.
21 You should have received a copy of the GNU General Public License and
22 a copy of the GCC Runtime Library Exception along with this program;
23 see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
24 <http://www.gnu.org/licenses/>. */
32 UNIT_LOCK is a master lock, protecting UNIT_ROOT tree and UNIT_CACHE.
33 Concurrent use of different units should be supported, so
34 each unit has its own lock, LOCK.
35 Open should be atomic with its reopening of units and list_read.c
36 in several places needs find_unit another unit while holding stdin
37 unit's lock, so it must be possible to acquire UNIT_LOCK while holding
38 some unit's lock. Therefore to avoid deadlocks, it is forbidden
39 to acquire unit's private locks while holding UNIT_LOCK, except
40 for freshly created units (where no other thread can get at their
41 address yet) or when using just trylock rather than lock operation.
42 In addition to unit's private lock each unit has a WAITERS counter
43 and CLOSED flag. WAITERS counter must be either only
44 atomically incremented/decremented in all places (if atomic builtins
45 are supported), or protected by UNIT_LOCK in all places (otherwise).
46 CLOSED flag must be always protected by unit's LOCK.
47 After finding a unit in UNIT_CACHE or UNIT_ROOT with UNIT_LOCK held,
48 WAITERS must be incremented to avoid concurrent close from freeing
49 the unit between unlocking UNIT_LOCK and acquiring unit's LOCK.
50 Unit freeing is always done under UNIT_LOCK. If close_unit sees any
51 WAITERS, it doesn't free the unit but instead sets the CLOSED flag
52 and the thread that decrements WAITERS to zero while CLOSED flag is
53 set is responsible for freeing it (while holding UNIT_LOCK).
54 flush_all_units operation is iterating over the unit tree with
55 increasing UNIT_NUMBER while holding UNIT_LOCK and attempting to
56 flush each unit (and therefore needs the unit's LOCK held as well).
57 To avoid deadlocks, it just trylocks the LOCK and if unsuccessful,
58 remembers the current unit's UNIT_NUMBER, unlocks UNIT_LOCK, acquires
59 unit's LOCK and after flushing reacquires UNIT_LOCK and restarts with
60 the smallest UNIT_NUMBER above the last one flushed.
62 If find_unit/find_or_create_unit/find_file/get_unit routines return
63 non-NULL, the returned unit has its private lock locked and when the
64 caller is done with it, it must call either unlock_unit or close_unit
65 on it. unlock_unit or close_unit must be always called only with the
68 /* Subroutines related to units */
72 static gfc_unit
*unit_cache
[CACHE_SIZE
];
73 gfc_offset max_offset
;
75 #ifdef __GTHREAD_MUTEX_INIT
76 __gthread_mutex_t unit_lock
= __GTHREAD_MUTEX_INIT
;
78 __gthread_mutex_t unit_lock
;
81 /* We use these filenames for error reporting. */
83 static char stdin_name
[] = "stdin";
84 static char stdout_name
[] = "stdout";
85 static char stderr_name
[] = "stderr";
87 /* This implementation is based on Stefan Nilsson's article in the
88 * July 1997 Doctor Dobb's Journal, "Treaps in Java". */
90 /* pseudo_random()-- Simple linear congruential pseudorandom number
91 * generator. The period of this generator is 44071, which is plenty
92 * for our purposes. */
99 x0
= (22611 * x0
+ 10) % 44071;
104 /* rotate_left()-- Rotate the treap left */
107 rotate_left (gfc_unit
* t
)
112 t
->right
= t
->right
->left
;
119 /* rotate_right()-- Rotate the treap right */
122 rotate_right (gfc_unit
* t
)
127 t
->left
= t
->left
->right
;
136 compare (int a
, int b
)
147 /* insert()-- Recursive insertion function. Returns the updated treap. */
150 insert (gfc_unit
*new, gfc_unit
*t
)
157 c
= compare (new->unit_number
, t
->unit_number
);
161 t
->left
= insert (new, t
->left
);
162 if (t
->priority
< t
->left
->priority
)
163 t
= rotate_right (t
);
168 t
->right
= insert (new, t
->right
);
169 if (t
->priority
< t
->right
->priority
)
174 internal_error (NULL
, "insert(): Duplicate key found!");
180 /* insert_unit()-- Create a new node, insert it into the treap. */
185 gfc_unit
*u
= get_mem (sizeof (gfc_unit
));
186 memset (u
, '\0', sizeof (gfc_unit
));
188 #ifdef __GTHREAD_MUTEX_INIT
190 __gthread_mutex_t tmp
= __GTHREAD_MUTEX_INIT
;
194 __GTHREAD_MUTEX_INIT_FUNCTION (&u
->lock
);
196 __gthread_mutex_lock (&u
->lock
);
197 u
->priority
= pseudo_random ();
198 unit_root
= insert (u
, unit_root
);
203 /* destroy_unit_mutex()-- Destroy the mutex and free memory of unit. */
206 destroy_unit_mutex (gfc_unit
* u
)
208 __gthread_mutex_destroy (&u
->lock
);
214 delete_root (gfc_unit
* t
)
220 if (t
->right
== NULL
)
223 if (t
->left
->priority
> t
->right
->priority
)
225 temp
= rotate_right (t
);
226 temp
->right
= delete_root (t
);
230 temp
= rotate_left (t
);
231 temp
->left
= delete_root (t
);
238 /* delete_treap()-- Delete an element from a tree. The 'old' value
239 * does not necessarily have to point to the element to be deleted, it
240 * must just point to a treap structure with the key to be deleted.
241 * Returns the new root node of the tree. */
244 delete_treap (gfc_unit
* old
, gfc_unit
* t
)
251 c
= compare (old
->unit_number
, t
->unit_number
);
254 t
->left
= delete_treap (old
, t
->left
);
256 t
->right
= delete_treap (old
, t
->right
);
264 /* delete_unit()-- Delete a unit from a tree */
267 delete_unit (gfc_unit
* old
)
269 unit_root
= delete_treap (old
, unit_root
);
273 /* get_external_unit()-- Given an integer, return a pointer to the unit
274 * structure. Returns NULL if the unit does not exist,
275 * otherwise returns a locked unit. */
278 get_external_unit (int n
, int do_create
)
283 __gthread_mutex_lock (&unit_lock
);
285 for (c
= 0; c
< CACHE_SIZE
; c
++)
286 if (unit_cache
[c
] != NULL
&& unit_cache
[c
]->unit_number
== n
)
295 c
= compare (n
, p
->unit_number
);
304 if (p
== NULL
&& do_create
)
312 for (c
= 0; c
< CACHE_SIZE
- 1; c
++)
313 unit_cache
[c
] = unit_cache
[c
+ 1];
315 unit_cache
[CACHE_SIZE
- 1] = p
;
320 /* Newly created units have their lock held already
321 from insert_unit. Just unlock UNIT_LOCK and return. */
322 __gthread_mutex_unlock (&unit_lock
);
330 if (! __gthread_mutex_trylock (&p
->lock
))
332 /* assert (p->closed == 0); */
333 __gthread_mutex_unlock (&unit_lock
);
337 inc_waiting_locked (p
);
340 __gthread_mutex_unlock (&unit_lock
);
344 __gthread_mutex_lock (&p
->lock
);
347 __gthread_mutex_lock (&unit_lock
);
348 __gthread_mutex_unlock (&p
->lock
);
349 if (predec_waiting_locked (p
) == 0)
350 destroy_unit_mutex (p
);
354 dec_waiting_unlocked (p
);
363 return get_external_unit (n
, 0);
368 find_or_create_unit (int n
)
370 return get_external_unit (n
, 1);
375 get_internal_unit (st_parameter_dt
*dtp
)
378 gfc_offset start_record
= 0;
380 /* Allocate memory for a unit structure. */
382 iunit
= get_mem (sizeof (gfc_unit
));
385 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
389 memset (iunit
, '\0', sizeof (gfc_unit
));
390 #ifdef __GTHREAD_MUTEX_INIT
392 __gthread_mutex_t tmp
= __GTHREAD_MUTEX_INIT
;
396 __GTHREAD_MUTEX_INIT_FUNCTION (&iunit
->lock
);
398 __gthread_mutex_lock (&iunit
->lock
);
400 iunit
->recl
= dtp
->internal_unit_len
;
402 /* For internal units we set the unit number to -1.
403 Otherwise internal units can be mistaken for a pre-connected unit or
404 some other file I/O unit. */
405 iunit
->unit_number
= -1;
407 /* Set up the looping specification from the array descriptor, if any. */
409 if (is_array_io (dtp
))
411 iunit
->rank
= GFC_DESCRIPTOR_RANK (dtp
->internal_unit_desc
);
412 iunit
->ls
= (array_loop_spec
*)
413 get_mem (iunit
->rank
* sizeof (array_loop_spec
));
414 dtp
->internal_unit_len
*=
415 init_loop_spec (dtp
->internal_unit_desc
, iunit
->ls
, &start_record
);
417 start_record
*= iunit
->recl
;
420 /* Set initial values for unit parameters. */
422 iunit
->s
= open_internal (dtp
->internal_unit
- start_record
,
423 dtp
->internal_unit_len
, -start_record
);
424 iunit
->bytes_left
= iunit
->recl
;
425 iunit
->last_record
=0;
427 iunit
->current_record
=0;
429 iunit
->endfile
= NO_ENDFILE
;
431 /* Set flags for the internal unit. */
433 iunit
->flags
.access
= ACCESS_SEQUENTIAL
;
434 iunit
->flags
.action
= ACTION_READWRITE
;
435 iunit
->flags
.blank
= BLANK_NULL
;
436 iunit
->flags
.form
= FORM_FORMATTED
;
437 iunit
->flags
.pad
= PAD_YES
;
438 iunit
->flags
.status
= STATUS_UNSPECIFIED
;
439 iunit
->flags
.sign
= SIGN_SUPPRESS
;
440 iunit
->flags
.decimal
= DECIMAL_POINT
;
441 iunit
->flags
.encoding
= ENCODING_DEFAULT
;
442 iunit
->flags
.async
= ASYNC_NO
;
444 /* Initialize the data transfer parameters. */
446 dtp
->u
.p
.advance_status
= ADVANCE_YES
;
447 dtp
->u
.p
.seen_dollar
= 0;
449 dtp
->u
.p
.pending_spaces
= 0;
450 dtp
->u
.p
.max_pos
= 0;
453 /* This flag tells us the unit is assigned to internal I/O. */
455 dtp
->u
.p
.unit_is_internal
= 1;
461 /* free_internal_unit()-- Free memory allocated for internal units if any. */
463 free_internal_unit (st_parameter_dt
*dtp
)
465 if (!is_internal_unit (dtp
))
468 if (dtp
->u
.p
.current_unit
!= NULL
)
470 if (dtp
->u
.p
.current_unit
->ls
!= NULL
)
471 free_mem (dtp
->u
.p
.current_unit
->ls
);
473 if (dtp
->u
.p
.current_unit
->s
)
474 free_mem (dtp
->u
.p
.current_unit
->s
);
476 destroy_unit_mutex (dtp
->u
.p
.current_unit
);
482 /* get_unit()-- Returns the unit structure associated with the integer
483 * unit or the internal file. */
486 get_unit (st_parameter_dt
*dtp
, int do_create
)
489 if ((dtp
->common
.flags
& IOPARM_DT_HAS_INTERNAL_UNIT
) != 0)
490 return get_internal_unit(dtp
);
492 /* Has to be an external unit */
494 dtp
->u
.p
.unit_is_internal
= 0;
495 dtp
->internal_unit_desc
= NULL
;
497 return get_external_unit (dtp
->common
.unit
, do_create
);
501 /*************************/
502 /* Initialize everything */
510 #ifndef __GTHREAD_MUTEX_INIT
511 __GTHREAD_MUTEX_INIT_FUNCTION (&unit_lock
);
514 if (options
.stdin_unit
>= 0)
516 u
= insert_unit (options
.stdin_unit
);
517 u
->s
= input_stream ();
519 u
->flags
.action
= ACTION_READ
;
521 u
->flags
.access
= ACCESS_SEQUENTIAL
;
522 u
->flags
.form
= FORM_FORMATTED
;
523 u
->flags
.status
= STATUS_OLD
;
524 u
->flags
.blank
= BLANK_NULL
;
525 u
->flags
.pad
= PAD_YES
;
526 u
->flags
.position
= POSITION_ASIS
;
527 u
->flags
.sign
= SIGN_SUPPRESS
;
528 u
->flags
.decimal
= DECIMAL_POINT
;
529 u
->flags
.encoding
= ENCODING_DEFAULT
;
530 u
->flags
.async
= ASYNC_NO
;
532 u
->recl
= options
.default_recl
;
533 u
->endfile
= NO_ENDFILE
;
535 u
->file_len
= strlen (stdin_name
);
536 u
->file
= get_mem (u
->file_len
);
537 memmove (u
->file
, stdin_name
, u
->file_len
);
541 __gthread_mutex_unlock (&u
->lock
);
544 if (options
.stdout_unit
>= 0)
546 u
= insert_unit (options
.stdout_unit
);
547 u
->s
= output_stream ();
549 u
->flags
.action
= ACTION_WRITE
;
551 u
->flags
.access
= ACCESS_SEQUENTIAL
;
552 u
->flags
.form
= FORM_FORMATTED
;
553 u
->flags
.status
= STATUS_OLD
;
554 u
->flags
.blank
= BLANK_NULL
;
555 u
->flags
.position
= POSITION_ASIS
;
556 u
->flags
.sign
= SIGN_SUPPRESS
;
557 u
->flags
.decimal
= DECIMAL_POINT
;
558 u
->flags
.encoding
= ENCODING_DEFAULT
;
559 u
->flags
.async
= ASYNC_NO
;
561 u
->recl
= options
.default_recl
;
562 u
->endfile
= AT_ENDFILE
;
564 u
->file_len
= strlen (stdout_name
);
565 u
->file
= get_mem (u
->file_len
);
566 memmove (u
->file
, stdout_name
, u
->file_len
);
570 __gthread_mutex_unlock (&u
->lock
);
573 if (options
.stderr_unit
>= 0)
575 u
= insert_unit (options
.stderr_unit
);
576 u
->s
= error_stream ();
578 u
->flags
.action
= ACTION_WRITE
;
580 u
->flags
.access
= ACCESS_SEQUENTIAL
;
581 u
->flags
.form
= FORM_FORMATTED
;
582 u
->flags
.status
= STATUS_OLD
;
583 u
->flags
.blank
= BLANK_NULL
;
584 u
->flags
.position
= POSITION_ASIS
;
585 u
->flags
.sign
= SIGN_SUPPRESS
;
586 u
->flags
.decimal
= DECIMAL_POINT
;
587 u
->flags
.encoding
= ENCODING_DEFAULT
;
588 u
->flags
.async
= ASYNC_NO
;
590 u
->recl
= options
.default_recl
;
591 u
->endfile
= AT_ENDFILE
;
593 u
->file_len
= strlen (stderr_name
);
594 u
->file
= get_mem (u
->file_len
);
595 memmove (u
->file
, stderr_name
, u
->file_len
);
597 fbuf_init (u
, 256); /* 256 bytes should be enough, probably not doing
598 any kind of exotic formatting to stderr. */
600 __gthread_mutex_unlock (&u
->lock
);
603 /* Calculate the maximum file offset in a portable manner.
604 * max will be the largest signed number for the type gfc_offset.
606 * set a 1 in the LSB and keep a running sum, stopping at MSB-1 bit. */
609 for (i
= 0; i
< sizeof (max_offset
) * 8 - 1; i
++)
610 max_offset
= max_offset
+ ((gfc_offset
) 1 << i
);
615 close_unit_1 (gfc_unit
*u
, int locked
)
619 /* If there are previously written bytes from a write with ADVANCE="no"
620 Reposition the buffer before closing. */
621 if (u
->previous_nonadvancing_write
)
622 finish_last_advance_record (u
);
624 rc
= (u
->s
== NULL
) ? 0 : sclose (u
->s
) == -1;
628 __gthread_mutex_lock (&unit_lock
);
630 for (i
= 0; i
< CACHE_SIZE
; i
++)
631 if (unit_cache
[i
] == u
)
632 unit_cache
[i
] = NULL
;
641 free_format_hash_table (u
);
645 __gthread_mutex_unlock (&u
->lock
);
647 /* If there are any threads waiting in find_unit for this unit,
648 avoid freeing the memory, the last such thread will free it
651 destroy_unit_mutex (u
);
654 __gthread_mutex_unlock (&unit_lock
);
660 unlock_unit (gfc_unit
*u
)
662 __gthread_mutex_unlock (&u
->lock
);
665 /* close_unit()-- Close a unit. The stream is closed, and any memory
666 * associated with the stream is freed. Returns nonzero on I/O error.
667 * Should be called with the u->lock locked. */
670 close_unit (gfc_unit
*u
)
672 return close_unit_1 (u
, 0);
676 /* close_units()-- Delete units on completion. We just keep deleting
677 * the root of the treap until there is nothing left.
678 * Not sure what to do with locking here. Some other thread might be
679 * holding some unit's lock and perhaps hold it indefinitely
680 * (e.g. waiting for input from some pipe) and close_units shouldn't
681 * delay the program too much. */
686 __gthread_mutex_lock (&unit_lock
);
687 while (unit_root
!= NULL
)
688 close_unit_1 (unit_root
, 1);
689 __gthread_mutex_unlock (&unit_lock
);
693 /* update_position()-- Update the flags position for later use by inquire. */
696 update_position (gfc_unit
*u
)
698 if (stell (u
->s
) == 0)
699 u
->flags
.position
= POSITION_REWIND
;
700 else if (file_length (u
->s
) == stell (u
->s
))
701 u
->flags
.position
= POSITION_APPEND
;
703 u
->flags
.position
= POSITION_ASIS
;
707 /* High level interface to truncate a file safely, i.e. flush format
708 buffers, check that it's a regular file, and generate error if that
709 occurs. Just like POSIX ftruncate, returns 0 on success, -1 on
713 unit_truncate (gfc_unit
* u
, gfc_offset pos
, st_parameter_common
* common
)
717 /* Make sure format buffer is flushed. */
718 if (u
->flags
.form
== FORM_FORMATTED
)
720 if (u
->mode
== READING
)
721 pos
+= fbuf_reset (u
);
723 fbuf_flush (u
, u
->mode
);
726 /* Don't try to truncate a special file, just pretend that it
728 if (is_special (u
->s
) || !is_seekable (u
->s
))
734 /* struncate() should flush the stream buffer if necessary, so don't
735 bother calling sflush() here. */
736 ret
= struncate (u
->s
, pos
);
740 generate_error (common
, LIBERROR_OS
, NULL
);
741 u
->endfile
= NO_ENDFILE
;
742 u
->flags
.position
= POSITION_ASIS
;
746 u
->endfile
= AT_ENDFILE
;
747 u
->flags
.position
= POSITION_APPEND
;
754 /* filename_from_unit()-- If the unit_number exists, return a pointer to the
755 name of the associated file, otherwise return the empty string. The caller
756 must free memory allocated for the filename string. */
759 filename_from_unit (int n
)
769 c
= compare (n
, u
->unit_number
);
778 /* Get the filename. */
781 filename
= (char *) get_mem (u
->file_len
+ 1);
782 unpack_filename (filename
, u
->file
, u
->file_len
);
786 return (char *) NULL
;
790 finish_last_advance_record (gfc_unit
*u
)
793 if (u
->saved_pos
> 0)
794 fbuf_seek (u
, u
->saved_pos
, SEEK_CUR
);
796 if (!(u
->unit_number
== options
.stdout_unit
797 || u
->unit_number
== options
.stderr_unit
))
804 char *p
= fbuf_alloc (u
, len
);
806 os_error ("Completing record after ADVANCE_NO failed");
813 fbuf_flush (u
, u
->mode
);