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