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   gfc_offset start_record = 0;
 373
 374   /* Allocate memory for a unit structure.  */
 375
 376   iunit = get_mem (sizeof (gfc_unit));
 377   if (iunit == NULL)
 378     {
 379       generate_error (&dtp->common, LIBERROR_INTERNAL_UNIT, NULL);
 380       return NULL;
 381     }
 382
 383   memset (iunit, '\0', sizeof (gfc_unit));
 384 #ifdef __GTHREAD_MUTEX_INIT
 385   {
 386     __gthread_mutex_t tmp = __GTHREAD_MUTEX_INIT;
 387     iunit->lock = tmp;
 388   }
 389 #else
 390   __GTHREAD_MUTEX_INIT_FUNCTION (&iunit->lock);
 391 #endif
 392   __gthread_mutex_lock (&iunit->lock);
 393
 394   iunit->recl = dtp->internal_unit_len;
 395
 396   /* For internal units we set the unit number to -1.
 397      Otherwise internal units can be mistaken for a pre-connected unit or
 398      some other file I/O unit.  */
 399   iunit->unit_number = -1;
 400
 401   /* Set up the looping specification from the array descriptor, if any.  */
 402
 403   if (is_array_io (dtp))
 404     {
 405       iunit->rank = GFC_DESCRIPTOR_RANK (dtp->internal_unit_desc);
 406       iunit->ls = (array_loop_spec *)
 407         get_mem (iunit->rank * sizeof (array_loop_spec));
 408       dtp->internal_unit_len *=
 409         init_loop_spec (dtp->internal_unit_desc, iunit->ls, &start_record);
 410
 411       start_record *= iunit->recl;
 412     }
 413
 414   /* Set initial values for unit parameters.  */
 415
 416   iunit->s = open_internal (dtp->internal_unit - start_record,
 417                             dtp->internal_unit_len, -start_record);
 418   iunit->bytes_left = iunit->recl;
 419   iunit->last_record=0;
 420   iunit->maxrec=0;
 421   iunit->current_record=0;
 422   iunit->read_bad = 0;
 423
 424   /* Set flags for the internal unit.  */
 425
 426   iunit->flags.access = ACCESS_SEQUENTIAL;
 427   iunit->flags.action = ACTION_READWRITE;
 428   iunit->flags.form = FORM_FORMATTED;
 429   iunit->flags.pad = PAD_YES;
 430   iunit->flags.status = STATUS_UNSPECIFIED;
 431   iunit->endfile = NO_ENDFILE;
 432
 433   /* Initialize the data transfer parameters.  */
 434
 435   dtp->u.p.advance_status = ADVANCE_YES;
 436   dtp->u.p.blank_status = BLANK_UNSPECIFIED;
 437   dtp->u.p.seen_dollar = 0;
 438   dtp->u.p.skips = 0;
 439   dtp->u.p.pending_spaces = 0;
 440   dtp->u.p.max_pos = 0;
 441   dtp->u.p.at_eof = 0;
 442
 443   /* This flag tells us the unit is assigned to internal I/O.  */
 444
 445   dtp->u.p.unit_is_internal = 1;
 446
 447   return iunit;
 448 }
 449
 450
 451 /* free_internal_unit()-- Free memory allocated for internal units if any.  */
 452 void
 453 free_internal_unit (st_parameter_dt *dtp)
 454 {
 455   if (!is_internal_unit (dtp))
 456     return;
 457
 458   if (dtp->u.p.current_unit->ls != NULL)
 459       free_mem (dtp->u.p.current_unit->ls);
 460
 461   sclose (dtp->u.p.current_unit->s);
 462
 463   if (dtp->u.p.current_unit != NULL)
 464     free_mem (dtp->u.p.current_unit);
 465 }
 466
 467
 468 /* get_unit()-- Returns the unit structure associated with the integer
 469  * unit or the internal file. */
 470
 471 gfc_unit *
 472 get_unit (st_parameter_dt *dtp, int do_create)
 473 {
 474
 475   if ((dtp->common.flags & IOPARM_DT_HAS_INTERNAL_UNIT) != 0)
 476     return get_internal_unit(dtp);
 477
 478   /* Has to be an external unit */
 479
 480   dtp->u.p.unit_is_internal = 0;
 481   dtp->internal_unit_desc = NULL;
 482
 483   return get_external_unit (dtp->common.unit, do_create);
 484 }
 485
 486
 487 /*************************/
 488 /* Initialize everything */
 489
 490 void
 491 init_units (void)
 492 {
 493   gfc_unit *u;
 494   unsigned int i;
 495
 496 #ifndef __GTHREAD_MUTEX_INIT
 497   __GTHREAD_MUTEX_INIT_FUNCTION (&unit_lock);
 498 #endif
 499
 500   if (options.stdin_unit >= 0)
 501     {                           /* STDIN */
 502       u = insert_unit (options.stdin_unit);
 503       u->s = input_stream ();
 504
 505       u->flags.action = ACTION_READ;
 506
 507       u->flags.access = ACCESS_SEQUENTIAL;
 508       u->flags.form = FORM_FORMATTED;
 509       u->flags.status = STATUS_OLD;
 510       u->flags.blank = BLANK_NULL;
 511       u->flags.pad = PAD_YES;
 512       u->flags.position = POSITION_ASIS;
 513
 514       u->recl = options.default_recl;
 515       u->endfile = NO_ENDFILE;
 516
 517       u->file_len = strlen (stdin_name);
 518       u->file = get_mem (u->file_len);
 519       memmove (u->file, stdin_name, u->file_len);
 520
 521       __gthread_mutex_unlock (&u->lock);
 522     }
 523
 524   if (options.stdout_unit >= 0)
 525     {                           /* STDOUT */
 526       u = insert_unit (options.stdout_unit);
 527       u->s = output_stream ();
 528
 529       u->flags.action = ACTION_WRITE;
 530
 531       u->flags.access = ACCESS_SEQUENTIAL;
 532       u->flags.form = FORM_FORMATTED;
 533       u->flags.status = STATUS_OLD;
 534       u->flags.blank = BLANK_NULL;
 535       u->flags.position = POSITION_ASIS;
 536
 537       u->recl = options.default_recl;
 538       u->endfile = AT_ENDFILE;
 539
 540       u->file_len = strlen (stdout_name);
 541       u->file = get_mem (u->file_len);
 542       memmove (u->file, stdout_name, u->file_len);
 543
 544       __gthread_mutex_unlock (&u->lock);
 545     }
 546
 547   if (options.stderr_unit >= 0)
 548     {                           /* STDERR */
 549       u = insert_unit (options.stderr_unit);
 550       u->s = error_stream ();
 551
 552       u->flags.action = ACTION_WRITE;
 553
 554       u->flags.access = ACCESS_SEQUENTIAL;
 555       u->flags.form = FORM_FORMATTED;
 556       u->flags.status = STATUS_OLD;
 557       u->flags.blank = BLANK_NULL;
 558       u->flags.position = POSITION_ASIS;
 559
 560       u->recl = options.default_recl;
 561       u->endfile = AT_ENDFILE;
 562
 563       u->file_len = strlen (stderr_name);
 564       u->file = get_mem (u->file_len);
 565       memmove (u->file, stderr_name, u->file_len);
 566
 567       __gthread_mutex_unlock (&u->lock);
 568     }
 569
 570   /* Calculate the maximum file offset in a portable manner.
 571    * max will be the largest signed number for the type gfc_offset.
 572    *
 573    * set a 1 in the LSB and keep a running sum, stopping at MSB-1 bit. */
 574
 575   max_offset = 0;
 576   for (i = 0; i < sizeof (max_offset) * 8 - 1; i++)
 577     max_offset = max_offset + ((gfc_offset) 1 << i);
 578 }
 579
 580
 581 static int
 582 close_unit_1 (gfc_unit *u, int locked)
 583 {
 584   int i, rc;
 585
 586   /* If there are previously written bytes from a write with ADVANCE="no"
 587      Reposition the buffer before closing.  */
 588   if (u->previous_nonadvancing_write)
 589     finish_last_advance_record (u);
 590
 591   rc = (u->s == NULL) ? 0 : sclose (u->s) == FAILURE;
 592
 593   u->closed = 1;
 594   if (!locked)
 595     __gthread_mutex_lock (&unit_lock);
 596
 597   for (i = 0; i < CACHE_SIZE; i++)
 598     if (unit_cache[i] == u)
 599       unit_cache[i] = NULL;
 600
 601   delete_unit (u);
 602
 603   if (u->file)
 604     free_mem (u->file);
 605   u->file = NULL;
 606   u->file_len = 0;
 607
 608   if (!locked)
 609     __gthread_mutex_unlock (&u->lock);
 610
 611   /* If there are any threads waiting in find_unit for this unit,
 612      avoid freeing the memory, the last such thread will free it
 613      instead.  */
 614   if (u->waiting == 0)
 615     free_mem (u);
 616
 617   if (!locked)
 618     __gthread_mutex_unlock (&unit_lock);
 619
 620   return rc;
 621 }
 622
 623 void
 624 unlock_unit (gfc_unit *u)
 625 {
 626   __gthread_mutex_unlock (&u->lock);
 627 }
 628
 629 /* close_unit()-- Close a unit.  The stream is closed, and any memory
 630  * associated with the stream is freed.  Returns nonzero on I/O error.
 631  * Should be called with the u->lock locked. */
 632
 633 int
 634 close_unit (gfc_unit *u)
 635 {
 636   return close_unit_1 (u, 0);
 637 }
 638
 639
 640 /* close_units()-- Delete units on completion.  We just keep deleting
 641  * the root of the treap until there is nothing left.
 642  * Not sure what to do with locking here.  Some other thread might be
 643  * holding some unit's lock and perhaps hold it indefinitely
 644  * (e.g. waiting for input from some pipe) and close_units shouldn't
 645  * delay the program too much.  */
 646
 647 void
 648 close_units (void)
 649 {
 650   __gthread_mutex_lock (&unit_lock);
 651   while (unit_root != NULL)
 652     close_unit_1 (unit_root, 1);
 653   __gthread_mutex_unlock (&unit_lock);
 654 }
 655
 656
 657 /* update_position()-- Update the flags position for later use by inquire.  */
 658
 659 void
 660 update_position (gfc_unit *u)
 661 {
 662   if (file_position (u->s) == 0)
 663     u->flags.position = POSITION_REWIND;
 664   else if (file_length (u->s) == file_position (u->s))
 665     u->flags.position = POSITION_APPEND;
 666   else
 667     u->flags.position = POSITION_ASIS;
 668 }
 669
 670
 671 /* filename_from_unit()-- If the unit_number exists, return a pointer to the
 672    name of the associated file, otherwise return the empty string.  The caller
 673    must free memory allocated for the filename string.  */
 674
 675 char *
 676 filename_from_unit (int n)
 677 {
 678   char *filename;
 679   gfc_unit *u;
 680   int c;
 681
 682   /* Find the unit.  */
 683   u = unit_root;
 684   while (u != NULL)
 685     {
 686       c = compare (n, u->unit_number);
 687       if (c < 0)
 688         u = u->left;
 689       if (c > 0)
 690         u = u->right;
 691       if (c == 0)
 692         break;
 693     }
 694
 695   /* Get the filename.  */
 696   if (u != NULL)
 697     {
 698       filename = (char *) get_mem (u->file_len + 1);
 699       unpack_filename (filename, u->file, u->file_len);
 700       return filename;
 701     }
 702   else
 703     return (char *) NULL;
 704 }
 705
 706 void
 707 finish_last_advance_record (gfc_unit *u)
 708 {
 709   char *p;
 710
 711   if (u->saved_pos > 0)
 712     p = salloc_w (u->s, &u->saved_pos);
 713
 714   if (!(u->unit_number == options.stdout_unit
 715         || u->unit_number == options.stderr_unit))
 716     {
 717       size_t len;
 718
 719       const char crlf[] = "\r\n";
 720 #ifdef HAVE_CRLF
 721       len = 2;
 722 #else
 723       len = 1;
 724 #endif
 725       if (swrite (u->s, &crlf[2-len], &len) != 0)
 726         os_error ("Completing record after ADVANCE_NO failed");
 727     }
 728 }
 729