1 /* Copyright (C) 2002, 2003, 2005, 2007 Free Software Foundation, Inc.
2 Contributed by Andy Vaught
4 This file is part of the GNU Fortran 95 runtime library (libgfortran).
6 Libgfortran is free software; you can redistribute it and/or modify
7 it under the terms of the GNU General Public License as published by
8 the Free Software Foundation; either version 2, or (at your option)
11 In addition to the permissions in the GNU General Public License, the
12 Free Software Foundation gives you unlimited permission to link the
13 compiled version of this file into combinations with other programs,
14 and to distribute those combinations without any restriction coming
15 from the use of this file. (The General Public License restrictions
16 do apply in other respects; for example, they cover modification of
17 the file, and distribution when not linked into a combine
20 Libgfortran is distributed in the hope that it will be useful,
21 but WITHOUT ANY WARRANTY; without even the implied warranty of
22 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
23 GNU General Public License for more details.
25 You should have received a copy of the GNU General Public License
26 along with Libgfortran; see the file COPYING. If not, write to
27 the Free Software Foundation, 51 Franklin Street, Fifth Floor,
28 Boston, MA 02110-1301, USA. */
36 UNIT_LOCK is a master lock, protecting UNIT_ROOT tree and UNIT_CACHE.
37 Concurrent use of different units should be supported, so
38 each unit has its own lock, LOCK.
39 Open should be atomic with its reopening of units and list_read.c
40 in several places needs find_unit another unit while holding stdin
41 unit's lock, so it must be possible to acquire UNIT_LOCK while holding
42 some unit's lock. Therefore to avoid deadlocks, it is forbidden
43 to acquire unit's private locks while holding UNIT_LOCK, except
44 for freshly created units (where no other thread can get at their
45 address yet) or when using just trylock rather than lock operation.
46 In addition to unit's private lock each unit has a WAITERS counter
47 and CLOSED flag. WAITERS counter must be either only
48 atomically incremented/decremented in all places (if atomic builtins
49 are supported), or protected by UNIT_LOCK in all places (otherwise).
50 CLOSED flag must be always protected by unit's LOCK.
51 After finding a unit in UNIT_CACHE or UNIT_ROOT with UNIT_LOCK held,
52 WAITERS must be incremented to avoid concurrent close from freeing
53 the unit between unlocking UNIT_LOCK and acquiring unit's LOCK.
54 Unit freeing is always done under UNIT_LOCK. If close_unit sees any
55 WAITERS, it doesn't free the unit but instead sets the CLOSED flag
56 and the thread that decrements WAITERS to zero while CLOSED flag is
57 set is responsible for freeing it (while holding UNIT_LOCK).
58 flush_all_units operation is iterating over the unit tree with
59 increasing UNIT_NUMBER while holding UNIT_LOCK and attempting to
60 flush each unit (and therefore needs the unit's LOCK held as well).
61 To avoid deadlocks, it just trylocks the LOCK and if unsuccessful,
62 remembers the current unit's UNIT_NUMBER, unlocks UNIT_LOCK, acquires
63 unit's LOCK and after flushing reacquires UNIT_LOCK and restarts with
64 the smallest UNIT_NUMBER above the last one flushed.
66 If find_unit/find_or_create_unit/find_file/get_unit routines return
67 non-NULL, the returned unit has its private lock locked and when the
68 caller is done with it, it must call either unlock_unit or close_unit
69 on it. unlock_unit or close_unit must be always called only with the
72 /* Subroutines related to units */
76 static gfc_unit
*unit_cache
[CACHE_SIZE
];
77 gfc_offset max_offset
;
79 #ifdef __GTHREAD_MUTEX_INIT
80 __gthread_mutex_t unit_lock
= __GTHREAD_MUTEX_INIT
;
82 __gthread_mutex_t unit_lock
;
85 /* We use these filenames for error reporting. */
87 static char stdin_name
[] = "stdin";
88 static char stdout_name
[] = "stdout";
89 static char stderr_name
[] = "stderr";
91 /* This implementation is based on Stefan Nilsson's article in the
92 * July 1997 Doctor Dobb's Journal, "Treaps in Java". */
94 /* pseudo_random()-- Simple linear congruential pseudorandom number
95 * generator. The period of this generator is 44071, which is plenty
96 * for our purposes. */
101 static int x0
= 5341;
103 x0
= (22611 * x0
+ 10) % 44071;
108 /* rotate_left()-- Rotate the treap left */
111 rotate_left (gfc_unit
* t
)
116 t
->right
= t
->right
->left
;
123 /* rotate_right()-- Rotate the treap right */
126 rotate_right (gfc_unit
* t
)
131 t
->left
= t
->left
->right
;
140 compare (int a
, int b
)
151 /* insert()-- Recursive insertion function. Returns the updated treap. */
154 insert (gfc_unit
*new, gfc_unit
*t
)
161 c
= compare (new->unit_number
, t
->unit_number
);
165 t
->left
= insert (new, t
->left
);
166 if (t
->priority
< t
->left
->priority
)
167 t
= rotate_right (t
);
172 t
->right
= insert (new, t
->right
);
173 if (t
->priority
< t
->right
->priority
)
178 internal_error (NULL
, "insert(): Duplicate key found!");
184 /* insert_unit()-- Create a new node, insert it into the treap. */
189 gfc_unit
*u
= get_mem (sizeof (gfc_unit
));
190 memset (u
, '\0', sizeof (gfc_unit
));
192 #ifdef __GTHREAD_MUTEX_INIT
194 __gthread_mutex_t tmp
= __GTHREAD_MUTEX_INIT
;
198 __GTHREAD_MUTEX_INIT_FUNCTION (&u
->lock
);
200 __gthread_mutex_lock (&u
->lock
);
201 u
->priority
= pseudo_random ();
202 unit_root
= insert (u
, unit_root
);
208 delete_root (gfc_unit
* t
)
214 if (t
->right
== NULL
)
217 if (t
->left
->priority
> t
->right
->priority
)
219 temp
= rotate_right (t
);
220 temp
->right
= delete_root (t
);
224 temp
= rotate_left (t
);
225 temp
->left
= delete_root (t
);
232 /* delete_treap()-- Delete an element from a tree. The 'old' value
233 * does not necessarily have to point to the element to be deleted, it
234 * must just point to a treap structure with the key to be deleted.
235 * Returns the new root node of the tree. */
238 delete_treap (gfc_unit
* old
, gfc_unit
* t
)
245 c
= compare (old
->unit_number
, t
->unit_number
);
248 t
->left
= delete_treap (old
, t
->left
);
250 t
->right
= delete_treap (old
, t
->right
);
258 /* delete_unit()-- Delete a unit from a tree */
261 delete_unit (gfc_unit
* old
)
263 unit_root
= delete_treap (old
, unit_root
);
267 /* get_external_unit()-- Given an integer, return a pointer to the unit
268 * structure. Returns NULL if the unit does not exist,
269 * otherwise returns a locked unit. */
272 get_external_unit (int n
, int do_create
)
277 __gthread_mutex_lock (&unit_lock
);
279 for (c
= 0; c
< CACHE_SIZE
; c
++)
280 if (unit_cache
[c
] != NULL
&& unit_cache
[c
]->unit_number
== n
)
289 c
= compare (n
, p
->unit_number
);
298 if (p
== NULL
&& do_create
)
306 for (c
= 0; c
< CACHE_SIZE
- 1; c
++)
307 unit_cache
[c
] = unit_cache
[c
+ 1];
309 unit_cache
[CACHE_SIZE
- 1] = p
;
314 /* Newly created units have their lock held already
315 from insert_unit. Just unlock UNIT_LOCK and return. */
316 __gthread_mutex_unlock (&unit_lock
);
324 if (! __gthread_mutex_trylock (&p
->lock
))
326 /* assert (p->closed == 0); */
327 __gthread_mutex_unlock (&unit_lock
);
331 inc_waiting_locked (p
);
334 __gthread_mutex_unlock (&unit_lock
);
338 __gthread_mutex_lock (&p
->lock
);
341 __gthread_mutex_lock (&unit_lock
);
342 __gthread_mutex_unlock (&p
->lock
);
343 if (predec_waiting_locked (p
) == 0)
348 dec_waiting_unlocked (p
);
357 return get_external_unit (n
, 0);
362 find_or_create_unit (int n
)
364 return get_external_unit (n
, 1);
369 get_internal_unit (st_parameter_dt
*dtp
)
372 gfc_offset start_record
= 0;
374 /* Allocate memory for a unit structure. */
376 iunit
= get_mem (sizeof (gfc_unit
));
379 generate_error (&dtp
->common
, LIBERROR_INTERNAL_UNIT
, NULL
);
383 memset (iunit
, '\0', sizeof (gfc_unit
));
384 #ifdef __GTHREAD_MUTEX_INIT
386 __gthread_mutex_t tmp
= __GTHREAD_MUTEX_INIT
;
390 __GTHREAD_MUTEX_INIT_FUNCTION (&iunit
->lock
);
392 __gthread_mutex_lock (&iunit
->lock
);
394 iunit
->recl
= dtp
->internal_unit_len
;
396 /* For internal units we set the unit number to -1.
397 Otherwise internal units can be mistaken for a pre-connected unit or
398 some other file I/O unit. */
399 iunit
->unit_number
= -1;
401 /* Set up the looping specification from the array descriptor, if any. */
403 if (is_array_io (dtp
))
405 iunit
->rank
= GFC_DESCRIPTOR_RANK (dtp
->internal_unit_desc
);
406 iunit
->ls
= (array_loop_spec
*)
407 get_mem (iunit
->rank
* sizeof (array_loop_spec
));
408 dtp
->internal_unit_len
*=
409 init_loop_spec (dtp
->internal_unit_desc
, iunit
->ls
, &start_record
);
411 start_record
*= iunit
->recl
;
414 /* Set initial values for unit parameters. */
416 iunit
->s
= open_internal (dtp
->internal_unit
- start_record
,
417 dtp
->internal_unit_len
, -start_record
);
418 iunit
->bytes_left
= iunit
->recl
;
419 iunit
->last_record
=0;
421 iunit
->current_record
=0;
424 /* Set flags for the internal unit. */
426 iunit
->flags
.access
= ACCESS_SEQUENTIAL
;
427 iunit
->flags
.action
= ACTION_READWRITE
;
428 iunit
->flags
.form
= FORM_FORMATTED
;
429 iunit
->flags
.pad
= PAD_YES
;
430 iunit
->flags
.status
= STATUS_UNSPECIFIED
;
431 iunit
->endfile
= NO_ENDFILE
;
433 /* Initialize the data transfer parameters. */
435 dtp
->u
.p
.advance_status
= ADVANCE_YES
;
436 dtp
->u
.p
.blank_status
= BLANK_UNSPECIFIED
;
437 dtp
->u
.p
.seen_dollar
= 0;
439 dtp
->u
.p
.pending_spaces
= 0;
440 dtp
->u
.p
.max_pos
= 0;
443 /* This flag tells us the unit is assigned to internal I/O. */
445 dtp
->u
.p
.unit_is_internal
= 1;
451 /* free_internal_unit()-- Free memory allocated for internal units if any. */
453 free_internal_unit (st_parameter_dt
*dtp
)
455 if (!is_internal_unit (dtp
))
458 if (dtp
->u
.p
.current_unit
->ls
!= NULL
)
459 free_mem (dtp
->u
.p
.current_unit
->ls
);
461 sclose (dtp
->u
.p
.current_unit
->s
);
463 if (dtp
->u
.p
.current_unit
!= NULL
)
464 free_mem (dtp
->u
.p
.current_unit
);
468 /* get_unit()-- Returns the unit structure associated with the integer
469 * unit or the internal file. */
472 get_unit (st_parameter_dt
*dtp
, int do_create
)
475 if ((dtp
->common
.flags
& IOPARM_DT_HAS_INTERNAL_UNIT
) != 0)
476 return get_internal_unit(dtp
);
478 /* Has to be an external unit */
480 dtp
->u
.p
.unit_is_internal
= 0;
481 dtp
->internal_unit_desc
= NULL
;
483 return get_external_unit (dtp
->common
.unit
, do_create
);
487 /*************************/
488 /* Initialize everything */
496 #ifndef __GTHREAD_MUTEX_INIT
497 __GTHREAD_MUTEX_INIT_FUNCTION (&unit_lock
);
500 if (options
.stdin_unit
>= 0)
502 u
= insert_unit (options
.stdin_unit
);
503 u
->s
= input_stream ();
505 u
->flags
.action
= ACTION_READ
;
507 u
->flags
.access
= ACCESS_SEQUENTIAL
;
508 u
->flags
.form
= FORM_FORMATTED
;
509 u
->flags
.status
= STATUS_OLD
;
510 u
->flags
.blank
= BLANK_NULL
;
511 u
->flags
.pad
= PAD_YES
;
512 u
->flags
.position
= POSITION_ASIS
;
514 u
->recl
= options
.default_recl
;
515 u
->endfile
= NO_ENDFILE
;
517 u
->file_len
= strlen (stdin_name
);
518 u
->file
= get_mem (u
->file_len
);
519 memmove (u
->file
, stdin_name
, u
->file_len
);
521 __gthread_mutex_unlock (&u
->lock
);
524 if (options
.stdout_unit
>= 0)
526 u
= insert_unit (options
.stdout_unit
);
527 u
->s
= output_stream ();
529 u
->flags
.action
= ACTION_WRITE
;
531 u
->flags
.access
= ACCESS_SEQUENTIAL
;
532 u
->flags
.form
= FORM_FORMATTED
;
533 u
->flags
.status
= STATUS_OLD
;
534 u
->flags
.blank
= BLANK_NULL
;
535 u
->flags
.position
= POSITION_ASIS
;
537 u
->recl
= options
.default_recl
;
538 u
->endfile
= AT_ENDFILE
;
540 u
->file_len
= strlen (stdout_name
);
541 u
->file
= get_mem (u
->file_len
);
542 memmove (u
->file
, stdout_name
, u
->file_len
);
544 __gthread_mutex_unlock (&u
->lock
);
547 if (options
.stderr_unit
>= 0)
549 u
= insert_unit (options
.stderr_unit
);
550 u
->s
= error_stream ();
552 u
->flags
.action
= ACTION_WRITE
;
554 u
->flags
.access
= ACCESS_SEQUENTIAL
;
555 u
->flags
.form
= FORM_FORMATTED
;
556 u
->flags
.status
= STATUS_OLD
;
557 u
->flags
.blank
= BLANK_NULL
;
558 u
->flags
.position
= POSITION_ASIS
;
560 u
->recl
= options
.default_recl
;
561 u
->endfile
= AT_ENDFILE
;
563 u
->file_len
= strlen (stderr_name
);
564 u
->file
= get_mem (u
->file_len
);
565 memmove (u
->file
, stderr_name
, u
->file_len
);
567 __gthread_mutex_unlock (&u
->lock
);
570 /* Calculate the maximum file offset in a portable manner.
571 * max will be the largest signed number for the type gfc_offset.
573 * set a 1 in the LSB and keep a running sum, stopping at MSB-1 bit. */
576 for (i
= 0; i
< sizeof (max_offset
) * 8 - 1; i
++)
577 max_offset
= max_offset
+ ((gfc_offset
) 1 << i
);
582 close_unit_1 (gfc_unit
*u
, int locked
)
586 /* If there are previously written bytes from a write with ADVANCE="no"
587 Reposition the buffer before closing. */
588 if (u
->previous_nonadvancing_write
)
589 finish_last_advance_record (u
);
591 rc
= (u
->s
== NULL
) ? 0 : sclose (u
->s
) == FAILURE
;
595 __gthread_mutex_lock (&unit_lock
);
597 for (i
= 0; i
< CACHE_SIZE
; i
++)
598 if (unit_cache
[i
] == u
)
599 unit_cache
[i
] = NULL
;
609 __gthread_mutex_unlock (&u
->lock
);
611 /* If there are any threads waiting in find_unit for this unit,
612 avoid freeing the memory, the last such thread will free it
618 __gthread_mutex_unlock (&unit_lock
);
624 unlock_unit (gfc_unit
*u
)
626 __gthread_mutex_unlock (&u
->lock
);
629 /* close_unit()-- Close a unit. The stream is closed, and any memory
630 * associated with the stream is freed. Returns nonzero on I/O error.
631 * Should be called with the u->lock locked. */
634 close_unit (gfc_unit
*u
)
636 return close_unit_1 (u
, 0);
640 /* close_units()-- Delete units on completion. We just keep deleting
641 * the root of the treap until there is nothing left.
642 * Not sure what to do with locking here. Some other thread might be
643 * holding some unit's lock and perhaps hold it indefinitely
644 * (e.g. waiting for input from some pipe) and close_units shouldn't
645 * delay the program too much. */
650 __gthread_mutex_lock (&unit_lock
);
651 while (unit_root
!= NULL
)
652 close_unit_1 (unit_root
, 1);
653 __gthread_mutex_unlock (&unit_lock
);
657 /* update_position()-- Update the flags position for later use by inquire. */
660 update_position (gfc_unit
*u
)
662 if (file_position (u
->s
) == 0)
663 u
->flags
.position
= POSITION_REWIND
;
664 else if (file_length (u
->s
) == file_position (u
->s
))
665 u
->flags
.position
= POSITION_APPEND
;
667 u
->flags
.position
= POSITION_ASIS
;
671 /* filename_from_unit()-- If the unit_number exists, return a pointer to the
672 name of the associated file, otherwise return the empty string. The caller
673 must free memory allocated for the filename string. */
676 filename_from_unit (int n
)
686 c
= compare (n
, u
->unit_number
);
695 /* Get the filename. */
698 filename
= (char *) get_mem (u
->file_len
+ 1);
699 unpack_filename (filename
, u
->file
, u
->file_len
);
703 return (char *) NULL
;
707 finish_last_advance_record (gfc_unit
*u
)
711 if (u
->saved_pos
> 0)
712 p
= salloc_w (u
->s
, &u
->saved_pos
);
714 if (!(u
->unit_number
== options
.stdout_unit
715 || u
->unit_number
== options
.stderr_unit
))
719 const char crlf
[] = "\r\n";
725 if (swrite (u
->s
, &crlf
[2-len
], &len
) != 0)
726 os_error ("Completing record after ADVANCE_NO failed");