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   dtp->u.p.at_eof = 0;
 434
 435   /* This flag tells us the unit is assigned to internal I/O.  */
 436
 437   dtp->u.p.unit_is_internal = 1;
 438
 439   return iunit;
 440 }
 441
 442
 443 /* free_internal_unit()-- Free memory allocated for internal units if any.  */
 444 void
 445 free_internal_unit (st_parameter_dt *dtp)
 446 {
 447   if (!is_internal_unit (dtp))
 448     return;
 449
 450   if (dtp->u.p.current_unit->ls != NULL)
 451       free_mem (dtp->u.p.current_unit->ls);
 452
 453   sclose (dtp->u.p.current_unit->s);
 454
 455   if (dtp->u.p.current_unit != NULL)
 456     free_mem (dtp->u.p.current_unit);
 457 }
 458
 459
 460 /* get_unit()-- Returns the unit structure associated with the integer
 461  * unit or the internal file. */
 462
 463 gfc_unit *
 464 get_unit (st_parameter_dt *dtp, int do_create)
 465 {
 466
 467   if ((dtp->common.flags & IOPARM_DT_HAS_INTERNAL_UNIT) != 0)
 468     return get_internal_unit(dtp);
 469
 470   /* Has to be an external unit */
 471
 472   dtp->u.p.unit_is_internal = 0;
 473   dtp->internal_unit_desc = NULL;
 474
 475   return get_external_unit (dtp->common.unit, do_create);
 476 }
 477
 478
 479 /* is_internal_unit()-- Determine if the current unit is internal or not */
 480
 481 int
 482 is_internal_unit (st_parameter_dt *dtp)
 483 {
 484   return dtp->u.p.unit_is_internal;
 485 }
 486
 487
 488 /* is_array_io ()-- Determine if the I/O is to/from an array */
 489
 490 int
 491 is_array_io (st_parameter_dt *dtp)
 492 {
 493   return dtp->internal_unit_desc != NULL;
 494 }
 495
 496
 497 /* is_stream_io () -- Determine if I/O is access="stream" mode */
 498
 499 int
 500 is_stream_io (st_parameter_dt *dtp)
 501 {
 502   return dtp->u.p.current_unit->flags.access == ACCESS_STREAM;
 503 }
 504
 505
 506 /*************************/
 507 /* Initialize everything */
 508
 509 void
 510 init_units (void)
 511 {
 512   gfc_unit *u;
 513   unsigned int i;
 514
 515 #ifndef __GTHREAD_MUTEX_INIT
 516   __GTHREAD_MUTEX_INIT_FUNCTION (&unit_lock);
 517 #endif
 518
 519   if (options.stdin_unit >= 0)
 520     {                           /* STDIN */
 521       u = insert_unit (options.stdin_unit);
 522       u->s = input_stream ();
 523
 524       u->flags.action = ACTION_READ;
 525
 526       u->flags.access = ACCESS_SEQUENTIAL;
 527       u->flags.form = FORM_FORMATTED;
 528       u->flags.status = STATUS_OLD;
 529       u->flags.blank = BLANK_NULL;
 530       u->flags.pad = PAD_YES;
 531       u->flags.position = POSITION_ASIS;
 532
 533       u->recl = options.default_recl;
 534       u->endfile = NO_ENDFILE;
 535
 536       __gthread_mutex_unlock (&u->lock);
 537     }
 538
 539   if (options.stdout_unit >= 0)
 540     {                           /* STDOUT */
 541       u = insert_unit (options.stdout_unit);
 542       u->s = output_stream ();
 543
 544       u->flags.action = ACTION_WRITE;
 545
 546       u->flags.access = ACCESS_SEQUENTIAL;
 547       u->flags.form = FORM_FORMATTED;
 548       u->flags.status = STATUS_OLD;
 549       u->flags.blank = BLANK_NULL;
 550       u->flags.position = POSITION_ASIS;
 551
 552       u->recl = options.default_recl;
 553       u->endfile = AT_ENDFILE;
 554
 555       __gthread_mutex_unlock (&u->lock);
 556     }
 557
 558   if (options.stderr_unit >= 0)
 559     {                           /* STDERR */
 560       u = insert_unit (options.stderr_unit);
 561       u->s = error_stream ();
 562
 563       u->flags.action = ACTION_WRITE;
 564
 565       u->flags.access = ACCESS_SEQUENTIAL;
 566       u->flags.form = FORM_FORMATTED;
 567       u->flags.status = STATUS_OLD;
 568       u->flags.blank = BLANK_NULL;
 569       u->flags.position = POSITION_ASIS;
 570
 571       u->recl = options.default_recl;
 572       u->endfile = AT_ENDFILE;
 573
 574       __gthread_mutex_unlock (&u->lock);
 575     }
 576
 577   /* Calculate the maximum file offset in a portable manner.
 578    * max will be the largest signed number for the type gfc_offset.
 579    *
 580    * set a 1 in the LSB and keep a running sum, stopping at MSB-1 bit. */
 581
 582   max_offset = 0;
 583   for (i = 0; i < sizeof (max_offset) * 8 - 1; i++)
 584     max_offset = max_offset + ((gfc_offset) 1 << i);
 585 }
 586
 587
 588 static int
 589 close_unit_1 (gfc_unit *u, int locked)
 590 {
 591   int i, rc;
 592
 593   /* If there are previously written bytes from a write with ADVANCE="no"
 594      Reposition the buffer before closing.  */
 595   if (u->saved_pos > 0)
 596     {
 597       char *p;
 598
 599       p = salloc_w (u->s, &u->saved_pos);
 600
 601       if (!(u->unit_number == options.stdout_unit
 602             || u->unit_number == options.stderr_unit))
 603         {
 604           size_t len;
 605
 606           const char crlf[] = "\r\n";
 607 #ifdef HAVE_CRLF
 608           len = 2;
 609 #else
 610           len = 1;
 611 #endif
 612           if (swrite (u->s, &crlf[2-len], &len) != 0)
 613             os_error ("Close after ADVANCE_NO failed");
 614         }
 615     }
 616
 617   rc = (u->s == NULL) ? 0 : sclose (u->s) == FAILURE;
 618
 619   u->closed = 1;
 620   if (!locked)
 621     __gthread_mutex_lock (&unit_lock);
 622
 623   for (i = 0; i < CACHE_SIZE; i++)
 624     if (unit_cache[i] == u)
 625       unit_cache[i] = NULL;
 626
 627   delete_unit (u);
 628
 629   if (u->file)
 630     free_mem (u->file);
 631   u->file = NULL;
 632   u->file_len = 0;
 633
 634   if (!locked)
 635     __gthread_mutex_unlock (&u->lock);
 636
 637   /* If there are any threads waiting in find_unit for this unit,
 638      avoid freeing the memory, the last such thread will free it
 639      instead.  */
 640   if (u->waiting == 0)
 641     free_mem (u);
 642
 643   if (!locked)
 644     __gthread_mutex_unlock (&unit_lock);
 645
 646   return rc;
 647 }
 648
 649 void
 650 unlock_unit (gfc_unit *u)
 651 {
 652   __gthread_mutex_unlock (&u->lock);
 653 }
 654
 655 /* close_unit()-- Close a unit.  The stream is closed, and any memory
 656  * associated with the stream is freed.  Returns nonzero on I/O error.
 657  * Should be called with the u->lock locked. */
 658
 659 int
 660 close_unit (gfc_unit *u)
 661 {
 662   return close_unit_1 (u, 0);
 663 }
 664
 665
 666 /* close_units()-- Delete units on completion.  We just keep deleting
 667  * the root of the treap until there is nothing left.
 668  * Not sure what to do with locking here.  Some other thread might be
 669  * holding some unit's lock and perhaps hold it indefinitely
 670  * (e.g. waiting for input from some pipe) and close_units shouldn't
 671  * delay the program too much.  */
 672
 673 void
 674 close_units (void)
 675 {
 676   __gthread_mutex_lock (&unit_lock);
 677   while (unit_root != NULL)
 678     close_unit_1 (unit_root, 1);
 679   __gthread_mutex_unlock (&unit_lock);
 680 }