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