OSDN Git Service

eca1b1eb98b303e6770bac84b620a504d57f0da1
[pf3gnuchains/gcc-fork.git] / libgfortran / io / unit.c
1 /* Copyright (C) 2002, 2003, 2005 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 "config.h"
31 #include <stdlib.h>
32 #include <string.h>
33 #include "libgfortran.h"
34 #include "io.h"
35
36
37 /* IO locking rules:
38    UNIT_LOCK is a master lock, protecting UNIT_ROOT tree and UNIT_CACHE.
39    Concurrent use of different units should be supported, so
40    each unit has its own lock, LOCK.
41    Open should be atomic with its reopening of units and list_read.c
42    in several places needs find_unit another unit while holding stdin
43    unit's lock, so it must be possible to acquire UNIT_LOCK while holding
44    some unit's lock.  Therefore to avoid deadlocks, it is forbidden
45    to acquire unit's private locks while holding UNIT_LOCK, except
46    for freshly created units (where no other thread can get at their
47    address yet) or when using just trylock rather than lock operation.
48    In addition to unit's private lock each unit has a WAITERS counter
49    and CLOSED flag.  WAITERS counter must be either only
50    atomically incremented/decremented in all places (if atomic builtins
51    are supported), or protected by UNIT_LOCK in all places (otherwise).
52    CLOSED flag must be always protected by unit's LOCK.
53    After finding a unit in UNIT_CACHE or UNIT_ROOT with UNIT_LOCK held,
54    WAITERS must be incremented to avoid concurrent close from freeing
55    the unit between unlocking UNIT_LOCK and acquiring unit's LOCK.
56    Unit freeing is always done under UNIT_LOCK.  If close_unit sees any
57    WAITERS, it doesn't free the unit but instead sets the CLOSED flag
58    and the thread that decrements WAITERS to zero while CLOSED flag is
59    set is responsible for freeing it (while holding UNIT_LOCK).
60    flush_all_units operation is iterating over the unit tree with
61    increasing UNIT_NUMBER while holding UNIT_LOCK and attempting to
62    flush each unit (and therefore needs the unit's LOCK held as well).
63    To avoid deadlocks, it just trylocks the LOCK and if unsuccessful,
64    remembers the current unit's UNIT_NUMBER, unlocks UNIT_LOCK, acquires
65    unit's LOCK and after flushing reacquires UNIT_LOCK and restarts with
66    the smallest UNIT_NUMBER above the last one flushed.
67
68    If find_unit/find_or_create_unit/find_file/get_unit routines return
69    non-NULL, the returned unit has its private lock locked and when the
70    caller is done with it, it must call either unlock_unit or close_unit
71    on it.  unlock_unit or close_unit must be always called only with the
72    private lock held.  */
73
74 /* Subroutines related to units */
75
76
77 #define CACHE_SIZE 3
78 static gfc_unit *unit_cache[CACHE_SIZE];
79 gfc_offset max_offset;
80 gfc_unit *unit_root;
81 #ifdef __GTHREAD_MUTEX_INIT
82 __gthread_mutex_t unit_lock = __GTHREAD_MUTEX_INIT;
83 #else
84 __gthread_mutex_t unit_lock;
85 #endif
86
87 /* This implementation is based on Stefan Nilsson's article in the
88  * July 1997 Doctor Dobb's Journal, "Treaps in Java". */
89
90 /* pseudo_random()-- Simple linear congruential pseudorandom number
91  * generator.  The period of this generator is 44071, which is plenty
92  * for our purposes.  */
93
94 static int
95 pseudo_random (void)
96 {
97   static int x0 = 5341;
98
99   x0 = (22611 * x0 + 10) % 44071;
100   return x0;
101 }
102
103
104 /* rotate_left()-- Rotate the treap left */
105
106 static gfc_unit *
107 rotate_left (gfc_unit * t)
108 {
109   gfc_unit *temp;
110
111   temp = t->right;
112   t->right = t->right->left;
113   temp->left = t;
114
115   return temp;
116 }
117
118
119 /* rotate_right()-- Rotate the treap right */
120
121 static gfc_unit *
122 rotate_right (gfc_unit * t)
123 {
124   gfc_unit *temp;
125
126   temp = t->left;
127   t->left = t->left->right;
128   temp->right = t;
129
130   return temp;
131 }
132
133
134
135 static int
136 compare (int a, int b)
137 {
138   if (a < b)
139     return -1;
140   if (a > b)
141     return 1;
142
143   return 0;
144 }
145
146
147 /* insert()-- Recursive insertion function.  Returns the updated treap. */
148
149 static gfc_unit *
150 insert (gfc_unit *new, gfc_unit *t)
151 {
152   int c;
153
154   if (t == NULL)
155     return new;
156
157   c = compare (new->unit_number, t->unit_number);
158
159   if (c < 0)
160     {
161       t->left = insert (new, t->left);
162       if (t->priority < t->left->priority)
163         t = rotate_right (t);
164     }
165
166   if (c > 0)
167     {
168       t->right = insert (new, t->right);
169       if (t->priority < t->right->priority)
170         t = rotate_left (t);
171     }
172
173   if (c == 0)
174     internal_error (NULL, "insert(): Duplicate key found!");
175
176   return t;
177 }
178
179
180 /* insert_unit()-- Create a new node, insert it into the treap.  */
181
182 static gfc_unit *
183 insert_unit (int n)
184 {
185   gfc_unit *u = get_mem (sizeof (gfc_unit));
186   memset (u, '\0', sizeof (gfc_unit));
187   u->unit_number = n;
188 #ifdef __GTHREAD_MUTEX_INIT
189   {
190     __gthread_mutex_t tmp = __GTHREAD_MUTEX_INIT;
191     u->lock = tmp;
192   }
193 #else
194   __GTHREAD_MUTEX_INIT_FUNCTION (&u->lock);
195 #endif
196   __gthread_mutex_lock (&u->lock);
197   u->priority = pseudo_random ();
198   unit_root = insert (u, unit_root);
199   return u;
200 }
201
202
203 static gfc_unit *
204 delete_root (gfc_unit * t)
205 {
206   gfc_unit *temp;
207
208   if (t->left == NULL)
209     return t->right;
210   if (t->right == NULL)
211     return t->left;
212
213   if (t->left->priority > t->right->priority)
214     {
215       temp = rotate_right (t);
216       temp->right = delete_root (t);
217     }
218   else
219     {
220       temp = rotate_left (t);
221       temp->left = delete_root (t);
222     }
223
224   return temp;
225 }
226
227
228 /* delete_treap()-- Delete an element from a tree.  The 'old' value
229  * does not necessarily have to point to the element to be deleted, it
230  * must just point to a treap structure with the key to be deleted.
231  * Returns the new root node of the tree. */
232
233 static gfc_unit *
234 delete_treap (gfc_unit * old, gfc_unit * t)
235 {
236   int c;
237
238   if (t == NULL)
239     return NULL;
240
241   c = compare (old->unit_number, t->unit_number);
242
243   if (c < 0)
244     t->left = delete_treap (old, t->left);
245   if (c > 0)
246     t->right = delete_treap (old, t->right);
247   if (c == 0)
248     t = delete_root (t);
249
250   return t;
251 }
252
253
254 /* delete_unit()-- Delete a unit from a tree */
255
256 static void
257 delete_unit (gfc_unit * old)
258 {
259   unit_root = delete_treap (old, unit_root);
260 }
261
262
263 /* get_external_unit()-- Given an integer, return a pointer to the unit
264  * structure.  Returns NULL if the unit does not exist,
265  * otherwise returns a locked unit. */
266
267 static gfc_unit *
268 get_external_unit (int n, int do_create)
269 {
270   gfc_unit *p;
271   int c, created = 0;
272
273   __gthread_mutex_lock (&unit_lock);
274 retry:
275   for (c = 0; c < CACHE_SIZE; c++)
276     if (unit_cache[c] != NULL && unit_cache[c]->unit_number == n)
277       {
278         p = unit_cache[c];
279         goto found;
280       }
281
282   p = unit_root;
283   while (p != NULL)
284     {
285       c = compare (n, p->unit_number);
286       if (c < 0)
287         p = p->left;
288       if (c > 0)
289         p = p->right;
290       if (c == 0)
291         break;
292     }
293
294   if (p == NULL && do_create)
295     {
296       p = insert_unit (n);
297       created = 1;
298     }
299
300   if (p != NULL)
301     {
302       for (c = 0; c < CACHE_SIZE - 1; c++)
303         unit_cache[c] = unit_cache[c + 1];
304
305       unit_cache[CACHE_SIZE - 1] = p;
306     }
307
308   if (created)
309     {
310       /* Newly created units have their lock held already
311          from insert_unit.  Just unlock UNIT_LOCK and return.  */
312       __gthread_mutex_unlock (&unit_lock);
313       return p;
314     }
315
316 found:
317   if (p != NULL)
318     {
319       /* Fast path.  */
320       if (! __gthread_mutex_trylock (&p->lock))
321         {
322           /* assert (p->closed == 0); */
323           __gthread_mutex_unlock (&unit_lock);
324           return p;
325         }
326
327       inc_waiting_locked (p);
328     }
329
330   __gthread_mutex_unlock (&unit_lock);
331
332   if (p != NULL)
333     {
334       __gthread_mutex_lock (&p->lock);
335       if (p->closed)
336         {
337           __gthread_mutex_lock (&unit_lock);
338           __gthread_mutex_unlock (&p->lock);
339           if (predec_waiting_locked (p) == 0)
340             free_mem (p);
341           goto retry;
342         }
343
344       dec_waiting_unlocked (p);
345     }
346   return p;
347 }
348
349
350 gfc_unit *
351 find_unit (int n)
352 {
353   return get_external_unit (n, 0);
354 }
355
356
357 gfc_unit *
358 find_or_create_unit (int n)
359 {
360   return get_external_unit (n, 1);
361 }
362
363
364 gfc_unit *
365 get_internal_unit (st_parameter_dt *dtp)
366 {
367   gfc_unit * iunit;
368
369   /* Allocate memory for a unit structure.  */
370
371   iunit = get_mem (sizeof (gfc_unit));
372   if (iunit == NULL)
373     {
374       generate_error (&dtp->common, ERROR_INTERNAL_UNIT, NULL);
375       return NULL;
376     }
377
378   memset (iunit, '\0', sizeof (gfc_unit));
379 #ifdef __GTHREAD_MUTEX_INIT
380   {
381     __gthread_mutex_t tmp = __GTHREAD_MUTEX_INIT;
382     iunit->lock = tmp;
383   }
384 #else
385   __GTHREAD_MUTEX_INIT_FUNCTION (&iunit->lock);
386 #endif
387   __gthread_mutex_lock (&iunit->lock);
388
389   iunit->recl = dtp->internal_unit_len;
390   
391   /* For internal units we set the unit number to -1.
392      Otherwise internal units can be mistaken for a pre-connected unit or
393      some other file I/O unit.  */
394   iunit->unit_number = -1;
395
396   /* Set up the looping specification from the array descriptor, if any.  */
397
398   if (is_array_io (dtp))
399     {
400       iunit->rank = GFC_DESCRIPTOR_RANK (dtp->internal_unit_desc);
401       iunit->ls = (array_loop_spec *)
402         get_mem (iunit->rank * sizeof (array_loop_spec));
403       dtp->internal_unit_len *=
404         init_loop_spec (dtp->internal_unit_desc, iunit->ls);
405     }
406
407   /* Set initial values for unit parameters.  */
408
409   iunit->s = open_internal (dtp->internal_unit, dtp->internal_unit_len);
410   iunit->bytes_left = iunit->recl;
411   iunit->last_record=0;
412   iunit->maxrec=0;
413   iunit->current_record=0;
414   iunit->read_bad = 0;
415
416   /* Set flags for the internal unit.  */
417
418   iunit->flags.access = ACCESS_SEQUENTIAL;
419   iunit->flags.action = ACTION_READWRITE;
420   iunit->flags.form = FORM_FORMATTED;
421   iunit->flags.pad = PAD_YES;
422   iunit->flags.status = STATUS_UNSPECIFIED;
423   iunit->endfile = NO_ENDFILE;
424
425   /* Initialize the data transfer parameters.  */
426
427   dtp->u.p.advance_status = ADVANCE_YES;
428   dtp->u.p.blank_status = BLANK_UNSPECIFIED;
429   dtp->u.p.seen_dollar = 0;
430   dtp->u.p.skips = 0;
431   dtp->u.p.pending_spaces = 0;
432   dtp->u.p.max_pos = 0;
433
434   /* This flag tells us the unit is assigned to internal I/O.  */
435   
436   dtp->u.p.unit_is_internal = 1;
437
438   return iunit;
439 }
440
441
442 /* free_internal_unit()-- Free memory allocated for internal units if any.  */
443 void
444 free_internal_unit (st_parameter_dt *dtp)
445 {
446   if (!is_internal_unit (dtp))
447     return;
448
449   if (dtp->u.p.current_unit->ls != NULL)
450       free_mem (dtp->u.p.current_unit->ls);
451   
452   sclose (dtp->u.p.current_unit->s);
453
454   if (dtp->u.p.current_unit != NULL)
455     free_mem (dtp->u.p.current_unit);
456 }
457
458
459 /* get_unit()-- Returns the unit structure associated with the integer
460  * unit or the internal file. */
461
462 gfc_unit *
463 get_unit (st_parameter_dt *dtp, int do_create)
464 {
465
466   if ((dtp->common.flags & IOPARM_DT_HAS_INTERNAL_UNIT) != 0)
467     return get_internal_unit(dtp);
468
469   /* Has to be an external unit */
470
471   dtp->u.p.unit_is_internal = 0;
472   dtp->internal_unit_desc = NULL;
473
474   return get_external_unit (dtp->common.unit, do_create);
475 }
476
477
478 /* is_internal_unit()-- Determine if the current unit is internal or not */
479
480 int
481 is_internal_unit (st_parameter_dt *dtp)
482 {
483   return dtp->u.p.unit_is_internal;
484 }
485
486
487 /* is_array_io ()-- Determine if the I/O is to/from an array */
488
489 int
490 is_array_io (st_parameter_dt *dtp)
491 {
492   return dtp->internal_unit_desc != NULL;
493 }
494
495
496 /*************************/
497 /* Initialize everything */
498
499 void
500 init_units (void)
501 {
502   gfc_unit *u;
503   unsigned int i;
504
505 #ifndef __GTHREAD_MUTEX_INIT
506   __GTHREAD_MUTEX_INIT_FUNCTION (&unit_lock);
507 #endif
508
509   if (options.stdin_unit >= 0)
510     {                           /* STDIN */
511       u = insert_unit (options.stdin_unit);
512       u->s = input_stream ();
513
514       u->flags.action = ACTION_READ;
515
516       u->flags.access = ACCESS_SEQUENTIAL;
517       u->flags.form = FORM_FORMATTED;
518       u->flags.status = STATUS_OLD;
519       u->flags.blank = BLANK_NULL;
520       u->flags.pad = PAD_YES;
521       u->flags.position = POSITION_ASIS;
522
523       u->recl = options.default_recl;
524       u->endfile = NO_ENDFILE;
525
526       __gthread_mutex_unlock (&u->lock);
527     }
528
529   if (options.stdout_unit >= 0)
530     {                           /* STDOUT */
531       u = insert_unit (options.stdout_unit);
532       u->s = output_stream ();
533
534       u->flags.action = ACTION_WRITE;
535
536       u->flags.access = ACCESS_SEQUENTIAL;
537       u->flags.form = FORM_FORMATTED;
538       u->flags.status = STATUS_OLD;
539       u->flags.blank = BLANK_NULL;
540       u->flags.position = POSITION_ASIS;
541
542       u->recl = options.default_recl;
543       u->endfile = AT_ENDFILE;
544
545       __gthread_mutex_unlock (&u->lock);
546     }
547
548   if (options.stderr_unit >= 0)
549     {                           /* STDERR */
550       u = insert_unit (options.stderr_unit);
551       u->s = error_stream ();
552
553       u->flags.action = ACTION_WRITE;
554
555       u->flags.access = ACCESS_SEQUENTIAL;
556       u->flags.form = FORM_FORMATTED;
557       u->flags.status = STATUS_OLD;
558       u->flags.blank = BLANK_NULL;
559       u->flags.position = POSITION_ASIS;
560
561       u->recl = options.default_recl;
562       u->endfile = AT_ENDFILE;
563
564       __gthread_mutex_unlock (&u->lock);
565     }
566
567   /* Calculate the maximum file offset in a portable manner.
568    * max will be the largest signed number for the type gfc_offset.
569    *
570    * set a 1 in the LSB and keep a running sum, stopping at MSB-1 bit. */
571
572   max_offset = 0;
573   for (i = 0; i < sizeof (max_offset) * 8 - 1; i++)
574     max_offset = max_offset + ((gfc_offset) 1 << i);
575 }
576
577
578 static int
579 close_unit_1 (gfc_unit *u, int locked)
580 {
581   int i, rc;
582
583   rc = (u->s == NULL) ? 0 : sclose (u->s) == FAILURE;
584
585   u->closed = 1;
586   if (!locked)
587     __gthread_mutex_lock (&unit_lock);
588
589   for (i = 0; i < CACHE_SIZE; i++)
590     if (unit_cache[i] == u)
591       unit_cache[i] = NULL;
592
593   delete_unit (u);
594
595   if (u->file)
596     free_mem (u->file);
597   u->file = NULL;
598   u->file_len = 0;
599
600   if (!locked)
601     __gthread_mutex_unlock (&u->lock);
602
603   /* If there are any threads waiting in find_unit for this unit,
604      avoid freeing the memory, the last such thread will free it
605      instead.  */
606   if (u->waiting == 0)
607     free_mem (u);
608
609   if (!locked)
610     __gthread_mutex_unlock (&unit_lock);
611
612   return rc;
613 }
614
615 void
616 unlock_unit (gfc_unit *u)
617 {
618   __gthread_mutex_unlock (&u->lock);
619 }
620
621 /* close_unit()-- Close a unit.  The stream is closed, and any memory
622  * associated with the stream is freed.  Returns nonzero on I/O error.
623  * Should be called with the u->lock locked. */
624
625 int
626 close_unit (gfc_unit *u)
627 {
628   return close_unit_1 (u, 0);
629 }
630
631
632 /* close_units()-- Delete units on completion.  We just keep deleting
633  * the root of the treap until there is nothing left.
634  * Not sure what to do with locking here.  Some other thread might be
635  * holding some unit's lock and perhaps hold it indefinitely
636  * (e.g. waiting for input from some pipe) and close_units shouldn't
637  * delay the program too much.  */
638
639 void
640 close_units (void)
641 {
642   __gthread_mutex_lock (&unit_lock);
643   while (unit_root != NULL)
644     close_unit_1 (unit_root, 1);
645   __gthread_mutex_unlock (&unit_lock);
646 }