OSDN Git Service

a293baba07744ae35023e34ac1b865b9909dc444
[pf3gnuchains/gcc-fork.git] / libgfortran / io / unit.c
1 /* Copyright (C) 2002, 2003, 2005, 2007 Free Software Foundation, Inc.
2    Contributed by Andy Vaught
3
4 This file is part of the GNU Fortran 95 runtime library (libgfortran).
5
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)
9 any later version.
10
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
18 executable.)
19
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.
24
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.  */
29
30 #include "io.h"
31 #include <stdlib.h>
32 #include <string.h>
33
34
35 /* IO locking rules:
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.
65
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
70    private lock held.  */
71
72 /* Subroutines related to units */
73
74
75 #define CACHE_SIZE 3
76 static gfc_unit *unit_cache[CACHE_SIZE];
77 gfc_offset max_offset;
78 gfc_unit *unit_root;
79 #ifdef __GTHREAD_MUTEX_INIT
80 __gthread_mutex_t unit_lock = __GTHREAD_MUTEX_INIT;
81 #else
82 __gthread_mutex_t unit_lock;
83 #endif
84
85 /* We use these filenames for error reporting.  */
86
87 static char stdin_name[] = "stdin";
88 static char stdout_name[] = "stdout";
89 static char stderr_name[] = "stderr";
90
91 /* This implementation is based on Stefan Nilsson's article in the
92  * July 1997 Doctor Dobb's Journal, "Treaps in Java". */
93
94 /* pseudo_random()-- Simple linear congruential pseudorandom number
95  * generator.  The period of this generator is 44071, which is plenty
96  * for our purposes.  */
97
98 static int
99 pseudo_random (void)
100 {
101   static int x0 = 5341;
102
103   x0 = (22611 * x0 + 10) % 44071;
104   return x0;
105 }
106
107
108 /* rotate_left()-- Rotate the treap left */
109
110 static gfc_unit *
111 rotate_left (gfc_unit * t)
112 {
113   gfc_unit *temp;
114
115   temp = t->right;
116   t->right = t->right->left;
117   temp->left = t;
118
119   return temp;
120 }
121
122
123 /* rotate_right()-- Rotate the treap right */
124
125 static gfc_unit *
126 rotate_right (gfc_unit * t)
127 {
128   gfc_unit *temp;
129
130   temp = t->left;
131   t->left = t->left->right;
132   temp->right = t;
133
134   return temp;
135 }
136
137
138
139 static int
140 compare (int a, int b)
141 {
142   if (a < b)
143     return -1;
144   if (a > b)
145     return 1;
146
147   return 0;
148 }
149
150
151 /* insert()-- Recursive insertion function.  Returns the updated treap. */
152
153 static gfc_unit *
154 insert (gfc_unit *new, gfc_unit *t)
155 {
156   int c;
157
158   if (t == NULL)
159     return new;
160
161   c = compare (new->unit_number, t->unit_number);
162
163   if (c < 0)
164     {
165       t->left = insert (new, t->left);
166       if (t->priority < t->left->priority)
167         t = rotate_right (t);
168     }
169
170   if (c > 0)
171     {
172       t->right = insert (new, t->right);
173       if (t->priority < t->right->priority)
174         t = rotate_left (t);
175     }
176
177   if (c == 0)
178     internal_error (NULL, "insert(): Duplicate key found!");
179
180   return t;
181 }
182
183
184 /* insert_unit()-- Create a new node, insert it into the treap.  */
185
186 static gfc_unit *
187 insert_unit (int n)
188 {
189   gfc_unit *u = get_mem (sizeof (gfc_unit));
190   memset (u, '\0', sizeof (gfc_unit));
191   u->unit_number = n;
192 #ifdef __GTHREAD_MUTEX_INIT
193   {
194     __gthread_mutex_t tmp = __GTHREAD_MUTEX_INIT;
195     u->lock = tmp;
196   }
197 #else
198   __GTHREAD_MUTEX_INIT_FUNCTION (&u->lock);
199 #endif
200   __gthread_mutex_lock (&u->lock);
201   u->priority = pseudo_random ();
202   unit_root = insert (u, unit_root);
203   return u;
204 }
205
206
207 static gfc_unit *
208 delete_root (gfc_unit * t)
209 {
210   gfc_unit *temp;
211
212   if (t->left == NULL)
213     return t->right;
214   if (t->right == NULL)
215     return t->left;
216
217   if (t->left->priority > t->right->priority)
218     {
219       temp = rotate_right (t);
220       temp->right = delete_root (t);
221     }
222   else
223     {
224       temp = rotate_left (t);
225       temp->left = delete_root (t);
226     }
227
228   return temp;
229 }
230
231
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. */
236
237 static gfc_unit *
238 delete_treap (gfc_unit * old, gfc_unit * t)
239 {
240   int c;
241
242   if (t == NULL)
243     return NULL;
244
245   c = compare (old->unit_number, t->unit_number);
246
247   if (c < 0)
248     t->left = delete_treap (old, t->left);
249   if (c > 0)
250     t->right = delete_treap (old, t->right);
251   if (c == 0)
252     t = delete_root (t);
253
254   return t;
255 }
256
257
258 /* delete_unit()-- Delete a unit from a tree */
259
260 static void
261 delete_unit (gfc_unit * old)
262 {
263   unit_root = delete_treap (old, unit_root);
264 }
265
266
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. */
270
271 static gfc_unit *
272 get_external_unit (int n, int do_create)
273 {
274   gfc_unit *p;
275   int c, created = 0;
276
277   __gthread_mutex_lock (&unit_lock);
278 retry:
279   for (c = 0; c < CACHE_SIZE; c++)
280     if (unit_cache[c] != NULL && unit_cache[c]->unit_number == n)
281       {
282         p = unit_cache[c];
283         goto found;
284       }
285
286   p = unit_root;
287   while (p != NULL)
288     {
289       c = compare (n, p->unit_number);
290       if (c < 0)
291         p = p->left;
292       if (c > 0)
293         p = p->right;
294       if (c == 0)
295         break;
296     }
297
298   if (p == NULL && do_create)
299     {
300       p = insert_unit (n);
301       created = 1;
302     }
303
304   if (p != NULL)
305     {
306       for (c = 0; c < CACHE_SIZE - 1; c++)
307         unit_cache[c] = unit_cache[c + 1];
308
309       unit_cache[CACHE_SIZE - 1] = p;
310     }
311
312   if (created)
313     {
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);
317       return p;
318     }
319
320 found:
321   if (p != NULL)
322     {
323       /* Fast path.  */
324       if (! __gthread_mutex_trylock (&p->lock))
325         {
326           /* assert (p->closed == 0); */
327           __gthread_mutex_unlock (&unit_lock);
328           return p;
329         }
330
331       inc_waiting_locked (p);
332     }
333
334   __gthread_mutex_unlock (&unit_lock);
335
336   if (p != NULL)
337     {
338       __gthread_mutex_lock (&p->lock);
339       if (p->closed)
340         {
341           __gthread_mutex_lock (&unit_lock);
342           __gthread_mutex_unlock (&p->lock);
343           if (predec_waiting_locked (p) == 0)
344             free_mem (p);
345           goto retry;
346         }
347
348       dec_waiting_unlocked (p);
349     }
350   return p;
351 }
352
353
354 gfc_unit *
355 find_unit (int n)
356 {
357   return get_external_unit (n, 0);
358 }
359
360
361 gfc_unit *
362 find_or_create_unit (int n)
363 {
364   return get_external_unit (n, 1);
365 }
366
367
368 gfc_unit *
369 get_internal_unit (st_parameter_dt *dtp)
370 {
371   gfc_unit * iunit;
372
373   /* Allocate memory for a unit structure.  */
374
375   iunit = get_mem (sizeof (gfc_unit));
376   if (iunit == NULL)
377     {
378       generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL);
379       return NULL;
380     }
381
382   memset (iunit, '\0', sizeof (gfc_unit));
383 #ifdef __GTHREAD_MUTEX_INIT
384   {
385     __gthread_mutex_t tmp = __GTHREAD_MUTEX_INIT;
386     iunit->lock = tmp;
387   }
388 #else
389   __GTHREAD_MUTEX_INIT_FUNCTION (&iunit->lock);
390 #endif
391   __gthread_mutex_lock (&iunit->lock);
392
393   iunit->recl = dtp->internal_unit_len;
394   
395   /* For internal units we set the unit number to -1.
396      Otherwise internal units can be mistaken for a pre-connected unit or
397      some other file I/O unit.  */
398   iunit->unit_number = -1;
399
400   /* Set up the looping specification from the array descriptor, if any.  */
401
402   if (is_array_io (dtp))
403     {
404       iunit->rank = GFC_DESCRIPTOR_RANK (dtp->internal_unit_desc);
405       iunit->ls = (array_loop_spec *)
406         get_mem (iunit->rank * sizeof (array_loop_spec));
407       dtp->internal_unit_len *=
408         init_loop_spec (dtp->internal_unit_desc, iunit->ls);
409     }
410
411   /* Set initial values for unit parameters.  */
412
413   iunit->s = open_internal (dtp->internal_unit, dtp->internal_unit_len);
414   iunit->bytes_left = iunit->recl;
415   iunit->last_record=0;
416   iunit->maxrec=0;
417   iunit->current_record=0;
418   iunit->read_bad = 0;
419
420   /* Set flags for the internal unit.  */
421
422   iunit->flags.access = ACCESS_SEQUENTIAL;
423   iunit->flags.action = ACTION_READWRITE;
424   iunit->flags.form = FORM_FORMATTED;
425   iunit->flags.pad = PAD_YES;
426   iunit->flags.status = STATUS_UNSPECIFIED;
427   iunit->endfile = NO_ENDFILE;
428
429   /* Initialize the data transfer parameters.  */
430
431   dtp->u.p.advance_status = ADVANCE_YES;
432   dtp->u.p.blank_status = BLANK_UNSPECIFIED;
433   dtp->u.p.seen_dollar = 0;
434   dtp->u.p.skips = 0;
435   dtp->u.p.pending_spaces = 0;
436   dtp->u.p.max_pos = 0;
437   dtp->u.p.at_eof = 0;
438
439   /* This flag tells us the unit is assigned to internal I/O.  */
440   
441   dtp->u.p.unit_is_internal = 1;
442
443   return iunit;
444 }
445
446
447 /* free_internal_unit()-- Free memory allocated for internal units if any.  */
448 void
449 free_internal_unit (st_parameter_dt *dtp)
450 {
451   if (!is_internal_unit (dtp))
452     return;
453
454   if (dtp->u.p.current_unit->ls != NULL)
455       free_mem (dtp->u.p.current_unit->ls);
456   
457   sclose (dtp->u.p.current_unit->s);
458
459   if (dtp->u.p.current_unit != NULL)
460     free_mem (dtp->u.p.current_unit);
461 }
462
463
464 /* get_unit()-- Returns the unit structure associated with the integer
465  * unit or the internal file. */
466
467 gfc_unit *
468 get_unit (st_parameter_dt *dtp, int do_create)
469 {
470
471   if ((dtp->common.flags & IOPARM_DT_HAS_INTERNAL_UNIT) != 0)
472     return get_internal_unit(dtp);
473
474   /* Has to be an external unit */
475
476   dtp->u.p.unit_is_internal = 0;
477   dtp->internal_unit_desc = NULL;
478
479   return get_external_unit (dtp->common.unit, do_create);
480 }
481
482
483 /*************************/
484 /* Initialize everything */
485
486 void
487 init_units (void)
488 {
489   gfc_unit *u;
490   unsigned int i;
491
492 #ifndef __GTHREAD_MUTEX_INIT
493   __GTHREAD_MUTEX_INIT_FUNCTION (&unit_lock);
494 #endif
495
496   if (options.stdin_unit >= 0)
497     {                           /* STDIN */
498       u = insert_unit (options.stdin_unit);
499       u->s = input_stream ();
500
501       u->flags.action = ACTION_READ;
502
503       u->flags.access = ACCESS_SEQUENTIAL;
504       u->flags.form = FORM_FORMATTED;
505       u->flags.status = STATUS_OLD;
506       u->flags.blank = BLANK_NULL;
507       u->flags.pad = PAD_YES;
508       u->flags.position = POSITION_ASIS;
509
510       u->recl = options.default_recl;
511       u->endfile = NO_ENDFILE;
512
513       u->file_len = strlen (stdin_name);
514       u->file = get_mem (u->file_len);
515       memmove (u->file, stdin_name, u->file_len);
516     
517       __gthread_mutex_unlock (&u->lock);
518     }
519
520   if (options.stdout_unit >= 0)
521     {                           /* STDOUT */
522       u = insert_unit (options.stdout_unit);
523       u->s = output_stream ();
524
525       u->flags.action = ACTION_WRITE;
526
527       u->flags.access = ACCESS_SEQUENTIAL;
528       u->flags.form = FORM_FORMATTED;
529       u->flags.status = STATUS_OLD;
530       u->flags.blank = BLANK_NULL;
531       u->flags.position = POSITION_ASIS;
532
533       u->recl = options.default_recl;
534       u->endfile = AT_ENDFILE;
535     
536       u->file_len = strlen (stdout_name);
537       u->file = get_mem (u->file_len);
538       memmove (u->file, stdout_name, u->file_len);
539
540       __gthread_mutex_unlock (&u->lock);
541     }
542
543   if (options.stderr_unit >= 0)
544     {                           /* STDERR */
545       u = insert_unit (options.stderr_unit);
546       u->s = error_stream ();
547
548       u->flags.action = ACTION_WRITE;
549
550       u->flags.access = ACCESS_SEQUENTIAL;
551       u->flags.form = FORM_FORMATTED;
552       u->flags.status = STATUS_OLD;
553       u->flags.blank = BLANK_NULL;
554       u->flags.position = POSITION_ASIS;
555
556       u->recl = options.default_recl;
557       u->endfile = AT_ENDFILE;
558
559       u->file_len = strlen (stderr_name);
560       u->file = get_mem (u->file_len);
561       memmove (u->file, stderr_name, u->file_len);
562
563       __gthread_mutex_unlock (&u->lock);
564     }
565
566   /* Calculate the maximum file offset in a portable manner.
567    * max will be the largest signed number for the type gfc_offset.
568    *
569    * set a 1 in the LSB and keep a running sum, stopping at MSB-1 bit. */
570
571   max_offset = 0;
572   for (i = 0; i < sizeof (max_offset) * 8 - 1; i++)
573     max_offset = max_offset + ((gfc_offset) 1 << i);
574 }
575
576
577 static int
578 close_unit_1 (gfc_unit *u, int locked)
579 {
580   int i, rc;
581
582   /* If there are previously written bytes from a write with ADVANCE="no"
583      Reposition the buffer before closing.  */
584   if (u->saved_pos > 0)
585     {
586       char *p;
587
588       p = salloc_w (u->s, &u->saved_pos);
589
590       if (!(u->unit_number == options.stdout_unit
591             || u->unit_number == options.stderr_unit))
592         {
593           size_t len;
594
595           const char crlf[] = "\r\n";
596 #ifdef HAVE_CRLF
597           len = 2;
598 #else
599           len = 1;
600 #endif
601           if (swrite (u->s, &crlf[2-len], &len) != 0)
602             os_error ("Close after ADVANCE_NO failed");
603         }
604     }
605
606   rc = (u->s == NULL) ? 0 : sclose (u->s) == FAILURE;
607
608   u->closed = 1;
609   if (!locked)
610     __gthread_mutex_lock (&unit_lock);
611
612   for (i = 0; i < CACHE_SIZE; i++)
613     if (unit_cache[i] == u)
614       unit_cache[i] = NULL;
615
616   delete_unit (u);
617
618   if (u->file)
619     free_mem (u->file);
620   u->file = NULL;
621   u->file_len = 0;
622
623   if (!locked)
624     __gthread_mutex_unlock (&u->lock);
625
626   /* If there are any threads waiting in find_unit for this unit,
627      avoid freeing the memory, the last such thread will free it
628      instead.  */
629   if (u->waiting == 0)
630     free_mem (u);
631
632   if (!locked)
633     __gthread_mutex_unlock (&unit_lock);
634
635   return rc;
636 }
637
638 void
639 unlock_unit (gfc_unit *u)
640 {
641   __gthread_mutex_unlock (&u->lock);
642 }
643
644 /* close_unit()-- Close a unit.  The stream is closed, and any memory
645  * associated with the stream is freed.  Returns nonzero on I/O error.
646  * Should be called with the u->lock locked. */
647
648 int
649 close_unit (gfc_unit *u)
650 {
651   return close_unit_1 (u, 0);
652 }
653
654
655 /* close_units()-- Delete units on completion.  We just keep deleting
656  * the root of the treap until there is nothing left.
657  * Not sure what to do with locking here.  Some other thread might be
658  * holding some unit's lock and perhaps hold it indefinitely
659  * (e.g. waiting for input from some pipe) and close_units shouldn't
660  * delay the program too much.  */
661
662 void
663 close_units (void)
664 {
665   __gthread_mutex_lock (&unit_lock);
666   while (unit_root != NULL)
667     close_unit_1 (unit_root, 1);
668   __gthread_mutex_unlock (&unit_lock);
669 }
670
671
672 /* update_position()-- Update the flags position for later use by inquire.  */
673
674 void
675 update_position (gfc_unit *u)
676 {
677   if (file_position (u->s) == 0)
678     u->flags.position = POSITION_REWIND;
679   else if (file_length (u->s) == file_position (u->s))
680     u->flags.position = POSITION_APPEND;
681   else
682     u->flags.position = POSITION_ASIS;
683 }
684
685
686 /* filename_from_unit()-- If the unit_number exists, return a pointer to the
687    name of the associated file, otherwise return the empty string.  The caller
688    must free memory allocated for the filename string.  */
689
690 char *
691 filename_from_unit (int n)
692 {
693   char *filename;
694   gfc_unit *u;
695   int c;
696
697   /* Find the unit.  */
698   u = unit_root;
699   while (u != NULL)
700     {
701       c = compare (n, u->unit_number);
702       if (c < 0)
703         u = u->left;
704       if (c > 0)
705         u = u->right;
706       if (c == 0)
707         break;
708     }
709
710   /* Get the filename.  */
711   if (u != NULL)
712     {
713       filename = (char *) get_mem (u->file_len + 1);
714       unpack_filename (filename, u->file, u->file_len);
715       return filename;
716     }
717   else
718     return (char *) NULL;
719 }
720