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 /* is_stream_io () -- Determine if I/O is access="stream" mode */
 497
 498 int
 499 is_stream_io (st_parameter_dt *dtp)
 500 {
 501   return dtp->u.p.current_unit->flags.access == ACCESS_STREAM;
 502 }
 503
 504
 505 /*************************/
 506 /* Initialize everything */
 507
 508 void
 509 init_units (void)
 510 {
 511   gfc_unit *u;
 512   unsigned int i;
 513
 514 #ifndef __GTHREAD_MUTEX_INIT
 515   __GTHREAD_MUTEX_INIT_FUNCTION (&unit_lock);
 516 #endif
 517
 518   if (options.stdin_unit >= 0)
 519     {                           /* STDIN */
 520       u = insert_unit (options.stdin_unit);
 521       u->s = input_stream ();
 522
 523       u->flags.action = ACTION_READ;
 524
 525       u->flags.access = ACCESS_SEQUENTIAL;
 526       u->flags.form = FORM_FORMATTED;
 527       u->flags.status = STATUS_OLD;
 528       u->flags.blank = BLANK_NULL;
 529       u->flags.pad = PAD_YES;
 530       u->flags.position = POSITION_ASIS;
 531
 532       u->recl = options.default_recl;
 533       u->endfile = NO_ENDFILE;
 534
 535       __gthread_mutex_unlock (&u->lock);
 536     }
 537
 538   if (options.stdout_unit >= 0)
 539     {                           /* STDOUT */
 540       u = insert_unit (options.stdout_unit);
 541       u->s = output_stream ();
 542
 543       u->flags.action = ACTION_WRITE;
 544
 545       u->flags.access = ACCESS_SEQUENTIAL;
 546       u->flags.form = FORM_FORMATTED;
 547       u->flags.status = STATUS_OLD;
 548       u->flags.blank = BLANK_NULL;
 549       u->flags.position = POSITION_ASIS;
 550
 551       u->recl = options.default_recl;
 552       u->endfile = AT_ENDFILE;
 553
 554       __gthread_mutex_unlock (&u->lock);
 555     }
 556
 557   if (options.stderr_unit >= 0)
 558     {                           /* STDERR */
 559       u = insert_unit (options.stderr_unit);
 560       u->s = error_stream ();
 561
 562       u->flags.action = ACTION_WRITE;
 563
 564       u->flags.access = ACCESS_SEQUENTIAL;
 565       u->flags.form = FORM_FORMATTED;
 566       u->flags.status = STATUS_OLD;
 567       u->flags.blank = BLANK_NULL;
 568       u->flags.position = POSITION_ASIS;
 569
 570       u->recl = options.default_recl;
 571       u->endfile = AT_ENDFILE;
 572
 573       __gthread_mutex_unlock (&u->lock);
 574     }
 575
 576   /* Calculate the maximum file offset in a portable manner.
 577    * max will be the largest signed number for the type gfc_offset.
 578    *
 579    * set a 1 in the LSB and keep a running sum, stopping at MSB-1 bit. */
 580
 581   max_offset = 0;
 582   for (i = 0; i < sizeof (max_offset) * 8 - 1; i++)
 583     max_offset = max_offset + ((gfc_offset) 1 << i);
 584 }
 585
 586
 587 static int
 588 close_unit_1 (gfc_unit *u, int locked)
 589 {
 590   int i, rc;
 591
 592   rc = (u->s == NULL) ? 0 : sclose (u->s) == FAILURE;
 593
 594   u->closed = 1;
 595   if (!locked)
 596     __gthread_mutex_lock (&unit_lock);
 597
 598   for (i = 0; i < CACHE_SIZE; i++)
 599     if (unit_cache[i] == u)
 600       unit_cache[i] = NULL;
 601
 602   delete_unit (u);
 603
 604   if (u->file)
 605     free_mem (u->file);
 606   u->file = NULL;
 607   u->file_len = 0;
 608
 609   if (!locked)
 610     __gthread_mutex_unlock (&u->lock);
 611
 612   /* If there are any threads waiting in find_unit for this unit,
 613      avoid freeing the memory, the last such thread will free it
 614      instead.  */
 615   if (u->waiting == 0)
 616     free_mem (u);
 617
 618   if (!locked)
 619     __gthread_mutex_unlock (&unit_lock);
 620
 621   return rc;
 622 }
 623
 624 void
 625 unlock_unit (gfc_unit *u)
 626 {
 627   __gthread_mutex_unlock (&u->lock);
 628 }
 629
 630 /* close_unit()-- Close a unit.  The stream is closed, and any memory
 631  * associated with the stream is freed.  Returns nonzero on I/O error.
 632  * Should be called with the u->lock locked. */
 633
 634 int
 635 close_unit (gfc_unit *u)
 636 {
 637   return close_unit_1 (u, 0);
 638 }
 639
 640
 641 /* close_units()-- Delete units on completion.  We just keep deleting
 642  * the root of the treap until there is nothing left.
 643  * Not sure what to do with locking here.  Some other thread might be
 644  * holding some unit's lock and perhaps hold it indefinitely
 645  * (e.g. waiting for input from some pipe) and close_units shouldn't
 646  * delay the program too much.  */
 647
 648 void
 649 close_units (void)
 650 {
 651   __gthread_mutex_lock (&unit_lock);
 652   while (unit_root != NULL)
 653     close_unit_1 (unit_root, 1);
 654   __gthread_mutex_unlock (&unit_lock);
 655 }