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 /* destroy_unit_mutex()-- Destroy the mutex and free memory of unit.  */
 208
 209 static void
 210 destroy_unit_mutex (gfc_unit * u)
 211 {
 212 #ifdef __GTHREAD_MUTEX_DESTROY_FUNCTION
 213   __GTHREAD_MUTEX_DESTROY_FUNCTION (&u->lock);
 214 #else
 215 #ifdef __CYGWIN__
 216   pthread_mutex_destroy (&u->lock);
 217 #endif
 218 #endif
 219   free_mem (u);
 220 }
 221
 222
 223 static gfc_unit *
 224 delete_root (gfc_unit * t)
 225 {
 226   gfc_unit *temp;
 227
 228   if (t->left == NULL)
 229     return t->right;
 230   if (t->right == NULL)
 231     return t->left;
 232
 233   if (t->left->priority > t->right->priority)
 234     {
 235       temp = rotate_right (t);
 236       temp->right = delete_root (t);
 237     }
 238   else
 239     {
 240       temp = rotate_left (t);
 241       temp->left = delete_root (t);
 242     }
 243
 244   return temp;
 245 }
 246
 247
 248 /* delete_treap()-- Delete an element from a tree.  The 'old' value
 249  * does not necessarily have to point to the element to be deleted, it
 250  * must just point to a treap structure with the key to be deleted.
 251  * Returns the new root node of the tree. */
 252
 253 static gfc_unit *
 254 delete_treap (gfc_unit * old, gfc_unit * t)
 255 {
 256   int c;
 257
 258   if (t == NULL)
 259     return NULL;
 260
 261   c = compare (old->unit_number, t->unit_number);
 262
 263   if (c < 0)
 264     t->left = delete_treap (old, t->left);
 265   if (c > 0)
 266     t->right = delete_treap (old, t->right);
 267   if (c == 0)
 268     t = delete_root (t);
 269
 270   return t;
 271 }
 272
 273
 274 /* delete_unit()-- Delete a unit from a tree */
 275
 276 static void
 277 delete_unit (gfc_unit * old)
 278 {
 279   unit_root = delete_treap (old, unit_root);
 280 }
 281
 282
 283 /* get_external_unit()-- Given an integer, return a pointer to the unit
 284  * structure.  Returns NULL if the unit does not exist,
 285  * otherwise returns a locked unit. */
 286
 287 static gfc_unit *
 288 get_external_unit (int n, int do_create)
 289 {
 290   gfc_unit *p;
 291   int c, created = 0;
 292
 293   __gthread_mutex_lock (&unit_lock);
 294 retry:
 295   for (c = 0; c < CACHE_SIZE; c++)
 296     if (unit_cache[c] != NULL && unit_cache[c]->unit_number == n)
 297       {
 298         p = unit_cache[c];
 299         goto found;
 300       }
 301
 302   p = unit_root;
 303   while (p != NULL)
 304     {
 305       c = compare (n, p->unit_number);
 306       if (c < 0)
 307         p = p->left;
 308       if (c > 0)
 309         p = p->right;
 310       if (c == 0)
 311         break;
 312     }
 313
 314   if (p == NULL && do_create)
 315     {
 316       p = insert_unit (n);
 317       created = 1;
 318     }
 319
 320   if (p != NULL)
 321     {
 322       for (c = 0; c < CACHE_SIZE - 1; c++)
 323         unit_cache[c] = unit_cache[c + 1];
 324
 325       unit_cache[CACHE_SIZE - 1] = p;
 326     }
 327
 328   if (created)
 329     {
 330       /* Newly created units have their lock held already
 331          from insert_unit.  Just unlock UNIT_LOCK and return.  */
 332       __gthread_mutex_unlock (&unit_lock);
 333       return p;
 334     }
 335
 336 found:
 337   if (p != NULL)
 338     {
 339       /* Fast path.  */
 340       if (! __gthread_mutex_trylock (&p->lock))
 341         {
 342           /* assert (p->closed == 0); */
 343           __gthread_mutex_unlock (&unit_lock);
 344           return p;
 345         }
 346
 347       inc_waiting_locked (p);
 348     }
 349
 350   __gthread_mutex_unlock (&unit_lock);
 351
 352   if (p != NULL)
 353     {
 354       __gthread_mutex_lock (&p->lock);
 355       if (p->closed)
 356         {
 357           __gthread_mutex_lock (&unit_lock);
 358           __gthread_mutex_unlock (&p->lock);
 359           if (predec_waiting_locked (p) == 0)
 360             destroy_unit_mutex (p);
 361           goto retry;
 362         }
 363
 364       dec_waiting_unlocked (p);
 365     }
 366   return p;
 367 }
 368
 369
 370 gfc_unit *
 371 find_unit (int n)
 372 {
 373   return get_external_unit (n, 0);
 374 }
 375
 376
 377 gfc_unit *
 378 find_or_create_unit (int n)
 379 {
 380   return get_external_unit (n, 1);
 381 }
 382
 383
 384 gfc_unit *
 385 get_internal_unit (st_parameter_dt *dtp)
 386 {
 387   gfc_unit * iunit;
 388   gfc_offset start_record = 0;
 389
 390   /* Allocate memory for a unit structure.  */
 391
 392   iunit = get_mem (sizeof (gfc_unit));
 393   if (iunit == NULL)
 394     {
 395       generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL);
 396       return NULL;
 397     }
 398
 399   memset (iunit, '\0', sizeof (gfc_unit));
 400 #ifdef __GTHREAD_MUTEX_INIT
 401   {
 402     __gthread_mutex_t tmp = __GTHREAD_MUTEX_INIT;
 403     iunit->lock = tmp;
 404   }
 405 #else
 406   __GTHREAD_MUTEX_INIT_FUNCTION (&iunit->lock);
 407 #endif
 408   __gthread_mutex_lock (&iunit->lock);
 409
 410   iunit->recl = dtp->internal_unit_len;
 411
 412   /* For internal units we set the unit number to -1.
 413      Otherwise internal units can be mistaken for a pre-connected unit or
 414      some other file I/O unit.  */
 415   iunit->unit_number = -1;
 416
 417   /* Set up the looping specification from the array descriptor, if any.  */
 418
 419   if (is_array_io (dtp))
 420     {
 421       iunit->rank = GFC_DESCRIPTOR_RANK (dtp->internal_unit_desc);
 422       iunit->ls = (array_loop_spec *)
 423         get_mem (iunit->rank * sizeof (array_loop_spec));
 424       dtp->internal_unit_len *=
 425         init_loop_spec (dtp->internal_unit_desc, iunit->ls, &start_record);
 426
 427       start_record *= iunit->recl;
 428     }
 429
 430   /* Set initial values for unit parameters.  */
 431
 432   iunit->s = open_internal (dtp->internal_unit - start_record,
 433                             dtp->internal_unit_len, -start_record);
 434   iunit->bytes_left = iunit->recl;
 435   iunit->last_record=0;
 436   iunit->maxrec=0;
 437   iunit->current_record=0;
 438   iunit->read_bad = 0;
 439
 440   /* Set flags for the internal unit.  */
 441
 442   iunit->flags.access = ACCESS_SEQUENTIAL;
 443   iunit->flags.action = ACTION_READWRITE;
 444   iunit->flags.form = FORM_FORMATTED;
 445   iunit->flags.pad = PAD_YES;
 446   iunit->flags.status = STATUS_UNSPECIFIED;
 447   iunit->endfile = NO_ENDFILE;
 448
 449   /* Initialize the data transfer parameters.  */
 450
 451   dtp->u.p.advance_status = ADVANCE_YES;
 452   dtp->u.p.blank_status = BLANK_UNSPECIFIED;
 453   dtp->u.p.seen_dollar = 0;
 454   dtp->u.p.skips = 0;
 455   dtp->u.p.pending_spaces = 0;
 456   dtp->u.p.max_pos = 0;
 457   dtp->u.p.at_eof = 0;
 458
 459   /* This flag tells us the unit is assigned to internal I/O.  */
 460
 461   dtp->u.p.unit_is_internal = 1;
 462
 463   return iunit;
 464 }
 465
 466
 467 /* free_internal_unit()-- Free memory allocated for internal units if any.  */
 468 void
 469 free_internal_unit (st_parameter_dt *dtp)
 470 {
 471   if (!is_internal_unit (dtp))
 472     return;
 473
 474   if (dtp->u.p.current_unit != NULL)
 475     {
 476       if (dtp->u.p.current_unit->ls != NULL)
 477         free_mem (dtp->u.p.current_unit->ls);
 478
 479       if (dtp->u.p.current_unit->s)
 480         free_mem (dtp->u.p.current_unit->s);
 481
 482       destroy_unit_mutex (dtp->u.p.current_unit);
 483     }
 484 }
 485
 486
 487
 488 /* get_unit()-- Returns the unit structure associated with the integer
 489  * unit or the internal file. */
 490
 491 gfc_unit *
 492 get_unit (st_parameter_dt *dtp, int do_create)
 493 {
 494
 495   if ((dtp->common.flags & IOPARM_DT_HAS_INTERNAL_UNIT) != 0)
 496     return get_internal_unit(dtp);
 497
 498   /* Has to be an external unit */
 499
 500   dtp->u.p.unit_is_internal = 0;
 501   dtp->internal_unit_desc = NULL;
 502
 503   return get_external_unit (dtp->common.unit, do_create);
 504 }
 505
 506
 507 /*************************/
 508 /* Initialize everything */
 509
 510 void
 511 init_units (void)
 512 {
 513   gfc_unit *u;
 514   unsigned int i;
 515
 516 #ifndef __GTHREAD_MUTEX_INIT
 517   __GTHREAD_MUTEX_INIT_FUNCTION (&unit_lock);
 518 #endif
 519
 520   if (options.stdin_unit >= 0)
 521     {                           /* STDIN */
 522       u = insert_unit (options.stdin_unit);
 523       u->s = input_stream ();
 524
 525       u->flags.action = ACTION_READ;
 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.pad = PAD_YES;
 532       u->flags.position = POSITION_ASIS;
 533
 534       u->recl = options.default_recl;
 535       u->endfile = NO_ENDFILE;
 536
 537       u->file_len = strlen (stdin_name);
 538       u->file = get_mem (u->file_len);
 539       memmove (u->file, stdin_name, u->file_len);
 540
 541       __gthread_mutex_unlock (&u->lock);
 542     }
 543
 544   if (options.stdout_unit >= 0)
 545     {                           /* STDOUT */
 546       u = insert_unit (options.stdout_unit);
 547       u->s = output_stream ();
 548
 549       u->flags.action = ACTION_WRITE;
 550
 551       u->flags.access = ACCESS_SEQUENTIAL;
 552       u->flags.form = FORM_FORMATTED;
 553       u->flags.status = STATUS_OLD;
 554       u->flags.blank = BLANK_NULL;
 555       u->flags.position = POSITION_ASIS;
 556
 557       u->recl = options.default_recl;
 558       u->endfile = AT_ENDFILE;
 559
 560       u->file_len = strlen (stdout_name);
 561       u->file = get_mem (u->file_len);
 562       memmove (u->file, stdout_name, u->file_len);
 563
 564       __gthread_mutex_unlock (&u->lock);
 565     }
 566
 567   if (options.stderr_unit >= 0)
 568     {                           /* STDERR */
 569       u = insert_unit (options.stderr_unit);
 570       u->s = error_stream ();
 571
 572       u->flags.action = ACTION_WRITE;
 573
 574       u->flags.access = ACCESS_SEQUENTIAL;
 575       u->flags.form = FORM_FORMATTED;
 576       u->flags.status = STATUS_OLD;
 577       u->flags.blank = BLANK_NULL;
 578       u->flags.position = POSITION_ASIS;
 579
 580       u->recl = options.default_recl;
 581       u->endfile = AT_ENDFILE;
 582
 583       u->file_len = strlen (stderr_name);
 584       u->file = get_mem (u->file_len);
 585       memmove (u->file, stderr_name, u->file_len);
 586
 587       __gthread_mutex_unlock (&u->lock);
 588     }
 589
 590   /* Calculate the maximum file offset in a portable manner.
 591    * max will be the largest signed number for the type gfc_offset.
 592    *
 593    * set a 1 in the LSB and keep a running sum, stopping at MSB-1 bit. */
 594
 595   max_offset = 0;
 596   for (i = 0; i < sizeof (max_offset) * 8 - 1; i++)
 597     max_offset = max_offset + ((gfc_offset) 1 << i);
 598 }
 599
 600
 601 static int
 602 close_unit_1 (gfc_unit *u, int locked)
 603 {
 604   int i, rc;
 605
 606   /* If there are previously written bytes from a write with ADVANCE="no"
 607      Reposition the buffer before closing.  */
 608   if (u->previous_nonadvancing_write)
 609     finish_last_advance_record (u);
 610
 611   rc = (u->s == NULL) ? 0 : sclose (u->s) == FAILURE;
 612
 613   u->closed = 1;
 614   if (!locked)
 615     __gthread_mutex_lock (&unit_lock);
 616
 617   for (i = 0; i < CACHE_SIZE; i++)
 618     if (unit_cache[i] == u)
 619       unit_cache[i] = NULL;
 620
 621   delete_unit (u);
 622
 623   if (u->file)
 624     free_mem (u->file);
 625   u->file = NULL;
 626   u->file_len = 0;
 627
 628   if (!locked)
 629     __gthread_mutex_unlock (&u->lock);
 630
 631   /* If there are any threads waiting in find_unit for this unit,
 632      avoid freeing the memory, the last such thread will free it
 633      instead.  */
 634   if (u->waiting == 0)
 635     destroy_unit_mutex (u);
 636
 637   if (!locked)
 638     __gthread_mutex_unlock (&unit_lock);
 639
 640   return rc;
 641 }
 642
 643 void
 644 unlock_unit (gfc_unit *u)
 645 {
 646   __gthread_mutex_unlock (&u->lock);
 647 }
 648
 649 /* close_unit()-- Close a unit.  The stream is closed, and any memory
 650  * associated with the stream is freed.  Returns nonzero on I/O error.
 651  * Should be called with the u->lock locked. */
 652
 653 int
 654 close_unit (gfc_unit *u)
 655 {
 656   return close_unit_1 (u, 0);
 657 }
 658
 659
 660 /* close_units()-- Delete units on completion.  We just keep deleting
 661  * the root of the treap until there is nothing left.
 662  * Not sure what to do with locking here.  Some other thread might be
 663  * holding some unit's lock and perhaps hold it indefinitely
 664  * (e.g. waiting for input from some pipe) and close_units shouldn't
 665  * delay the program too much.  */
 666
 667 void
 668 close_units (void)
 669 {
 670   __gthread_mutex_lock (&unit_lock);
 671   while (unit_root != NULL)
 672     close_unit_1 (unit_root, 1);
 673   __gthread_mutex_unlock (&unit_lock);
 674 }
 675
 676
 677 /* update_position()-- Update the flags position for later use by inquire.  */
 678
 679 void
 680 update_position (gfc_unit *u)
 681 {
 682   if (file_position (u->s) == 0)
 683     u->flags.position = POSITION_REWIND;
 684   else if (file_length (u->s) == file_position (u->s))
 685     u->flags.position = POSITION_APPEND;
 686   else
 687     u->flags.position = POSITION_ASIS;
 688 }
 689
 690
 691 /* filename_from_unit()-- If the unit_number exists, return a pointer to the
 692    name of the associated file, otherwise return the empty string.  The caller
 693    must free memory allocated for the filename string.  */
 694
 695 char *
 696 filename_from_unit (int n)
 697 {
 698   char *filename;
 699   gfc_unit *u;
 700   int c;
 701
 702   /* Find the unit.  */
 703   u = unit_root;
 704   while (u != NULL)
 705     {
 706       c = compare (n, u->unit_number);
 707       if (c < 0)
 708         u = u->left;
 709       if (c > 0)
 710         u = u->right;
 711       if (c == 0)
 712         break;
 713     }
 714
 715   /* Get the filename.  */
 716   if (u != NULL)
 717     {
 718       filename = (char *) get_mem (u->file_len + 1);
 719       unpack_filename (filename, u->file, u->file_len);
 720       return filename;
 721     }
 722   else
 723     return (char *) NULL;
 724 }
 725
 726 void
 727 finish_last_advance_record (gfc_unit *u)
 728 {
 729   char *p;
 730
 731   if (u->saved_pos > 0)
 732     p = salloc_w (u->s, &u->saved_pos);
 733
 734   if (!(u->unit_number == options.stdout_unit
 735         || u->unit_number == options.stderr_unit))
 736     {
 737       size_t len;
 738
 739       const char crlf[] = "\r\n";
 740 #ifdef HAVE_CRLF
 741       len = 2;
 742 #else
 743       len = 1;
 744 #endif
 745       if (swrite (u->s, &crlf[2-len], &len) != 0)
 746         os_error ("Completing record after ADVANCE_NO failed");
 747     }
 748 }
 749