gcc/fortran/target-memory.c

   1 /* Simulate storage of variables into target memory.
   2    Copyright (C) 2007
   3    Free Software Foundation, Inc.
   4    Contributed by Paul Thomas and Brooks Moses
   5
   6 This file is part of GCC.
   7
   8 GCC is free software; you can redistribute it and/or modify it under
   9 the terms of the GNU General Public License as published by the Free
  10 Software Foundation; either version 3, or (at your option) any later
  11 version.
  12
  13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
  14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
  15 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  16 for more details.
  17
  18 You should have received a copy of the GNU General Public License
  19 along with GCC; see the file COPYING3.  If not see
  20 <http://www.gnu.org/licenses/>.  */
  21
  22 #include "config.h"
  23 #include "system.h"
  24 #include "flags.h"
  25 #include "machmode.h"
  26 #include "tree.h"
  27 #include "gfortran.h"
  28 #include "arith.h"
  29 #include "trans.h"
  30 #include "trans-const.h"
  31 #include "trans-types.h"
  32 #include "target-memory.h"
  33
  34 /* --------------------------------------------------------------- */
  35 /* Calculate the size of an expression.  */
  36
  37 static size_t
  38 size_array (gfc_expr *e)
  39 {
  40   mpz_t array_size;
  41   size_t elt_size = gfc_target_expr_size (e->value.constructor->expr);
  42
  43   gfc_array_size (e, &array_size);
  44   return (size_t)mpz_get_ui (array_size) * elt_size;
  45 }
  46
  47 static size_t
  48 size_integer (int kind)
  49 {
  50   return GET_MODE_SIZE (TYPE_MODE (gfc_get_int_type (kind)));;
  51 }
  52
  53
  54 static size_t
  55 size_float (int kind)
  56 {
  57   return GET_MODE_SIZE (TYPE_MODE (gfc_get_real_type (kind)));;
  58 }
  59
  60
  61 static size_t
  62 size_complex (int kind)
  63 {
  64   return 2 * size_float (kind);
  65 }
  66
  67
  68 static size_t
  69 size_logical (int kind)
  70 {
  71   return GET_MODE_SIZE (TYPE_MODE (gfc_get_logical_type (kind)));;
  72 }
  73
  74
  75 static size_t
  76 size_character (int length)
  77 {
  78   return length;
  79 }
  80
  81
  82 size_t
  83 gfc_target_expr_size (gfc_expr *e)
  84 {
  85   tree type;
  86
  87   gcc_assert (e != NULL);
  88
  89   if (e->expr_type == EXPR_ARRAY)
  90     return size_array (e);
  91
  92   switch (e->ts.type)
  93     {
  94     case BT_INTEGER:
  95       return size_integer (e->ts.kind);
  96     case BT_REAL:
  97       return size_float (e->ts.kind);
  98     case BT_COMPLEX:
  99       return size_complex (e->ts.kind);
 100     case BT_LOGICAL:
 101       return size_logical (e->ts.kind);
 102     case BT_CHARACTER:
 103       return size_character (e->value.character.length);
 104     case BT_HOLLERITH:
 105       return e->representation.length;
 106     case BT_DERIVED:
 107       type = gfc_typenode_for_spec (&e->ts);
 108       return int_size_in_bytes (type);
 109     default:
 110       gfc_internal_error ("Invalid expression in gfc_target_expr_size.");
 111       return 0;
 112     }
 113 }
 114
 115
 116 /* The encode_* functions export a value into a buffer, and
 117    return the number of bytes of the buffer that have been
 118    used.  */
 119
 120 static int
 121 encode_array (gfc_expr *expr, unsigned char *buffer, size_t buffer_size)
 122 {
 123   mpz_t array_size;
 124   int i;
 125   int ptr = 0;
 126
 127   gfc_array_size (expr, &array_size);
 128   for (i = 0; i < (int)mpz_get_ui (array_size); i++)
 129     {
 130       ptr += gfc_target_encode_expr (gfc_get_array_element (expr, i),
 131                                      &buffer[ptr], buffer_size - ptr);
 132     }
 133
 134   mpz_clear (array_size);
 135   return ptr;
 136 }
 137
 138
 139 static int
 140 encode_integer (int kind, mpz_t integer, unsigned char *buffer,
 141                 size_t buffer_size)
 142 {
 143   return native_encode_expr (gfc_conv_mpz_to_tree (integer, kind),
 144                              buffer, buffer_size);
 145 }
 146
 147
 148 static int
 149 encode_float (int kind, mpfr_t real, unsigned char *buffer, size_t buffer_size)
 150 {
 151   return native_encode_expr (gfc_conv_mpfr_to_tree (real, kind), buffer,
 152                              buffer_size);
 153 }
 154
 155
 156 static int
 157 encode_complex (int kind, mpfr_t real, mpfr_t imaginary, unsigned char *buffer,
 158                 size_t buffer_size)
 159 {
 160   int size;
 161   size = encode_float (kind, real, &buffer[0], buffer_size);
 162   size += encode_float (kind, imaginary, &buffer[size], buffer_size - size);
 163   return size;
 164 }
 165
 166
 167 static int
 168 encode_logical (int kind, int logical, unsigned char *buffer, size_t buffer_size)
 169 {
 170   return native_encode_expr (build_int_cst (gfc_get_logical_type (kind),
 171                                             logical),
 172                              buffer, buffer_size);
 173 }
 174
 175
 176 static int
 177 encode_character (int length, char *string, unsigned char *buffer,
 178                   size_t buffer_size)
 179 {
 180   gcc_assert (buffer_size >= size_character (length));
 181   memcpy (buffer, string, length);
 182   return length;
 183 }
 184
 185
 186 static int
 187 encode_derived (gfc_expr *source, unsigned char *buffer, size_t buffer_size)
 188 {
 189   gfc_constructor *ctr;
 190   gfc_component *cmp;
 191   int ptr;
 192   tree type;
 193
 194   type = gfc_typenode_for_spec (&source->ts);
 195
 196   ctr = source->value.constructor;
 197   cmp = source->ts.derived->components;
 198   for (;ctr; ctr = ctr->next, cmp = cmp->next)
 199     {
 200       gcc_assert (cmp);
 201       if (!ctr->expr)
 202         continue;
 203       ptr = TREE_INT_CST_LOW(DECL_FIELD_OFFSET(cmp->backend_decl))
 204             + TREE_INT_CST_LOW(DECL_FIELD_BIT_OFFSET(cmp->backend_decl))/8;
 205       gfc_target_encode_expr (ctr->expr, &buffer[ptr],
 206                               buffer_size - ptr);
 207     }
 208
 209   return int_size_in_bytes (type);
 210 }
 211
 212
 213 /* Write a constant expression in binary form to a buffer.  */
 214 int
 215 gfc_target_encode_expr (gfc_expr *source, unsigned char *buffer,
 216                         size_t buffer_size)
 217 {
 218   if (source == NULL)
 219     return 0;
 220
 221   if (source->expr_type == EXPR_ARRAY)
 222     return encode_array (source, buffer, buffer_size);
 223
 224   gcc_assert (source->expr_type == EXPR_CONSTANT
 225               || source->expr_type == EXPR_STRUCTURE);
 226
 227   /* If we already have a target-memory representation, we use that rather
 228      than recreating one.  */
 229   if (source->representation.string)
 230     {
 231       memcpy (buffer, source->representation.string,
 232               source->representation.length);
 233       return source->representation.length;
 234     }
 235
 236   switch (source->ts.type)
 237     {
 238     case BT_INTEGER:
 239       return encode_integer (source->ts.kind, source->value.integer, buffer,
 240                              buffer_size);
 241     case BT_REAL:
 242       return encode_float (source->ts.kind, source->value.real, buffer,
 243                            buffer_size);
 244     case BT_COMPLEX:
 245       return encode_complex (source->ts.kind, source->value.complex.r,
 246                              source->value.complex.i, buffer, buffer_size);
 247     case BT_LOGICAL:
 248       return encode_logical (source->ts.kind, source->value.logical, buffer,
 249                              buffer_size);
 250     case BT_CHARACTER:
 251       return encode_character (source->value.character.length,
 252                                source->value.character.string, buffer,
 253                                buffer_size);
 254     case BT_DERIVED:
 255       return encode_derived (source, buffer, buffer_size);
 256     default:
 257       gfc_internal_error ("Invalid expression in gfc_target_encode_expr.");
 258       return 0;
 259     }
 260 }
 261
 262
 263 static int
 264 interpret_array (unsigned char *buffer, size_t buffer_size, gfc_expr *result)
 265 {
 266   int array_size = 1;
 267   int i;
 268   int ptr = 0;
 269   gfc_constructor *head = NULL, *tail = NULL;
 270
 271   /* Calculate array size from its shape and rank.  */
 272   gcc_assert (result->rank > 0 && result->shape);
 273
 274   for (i = 0; i < result->rank; i++)
 275     array_size *= (int)mpz_get_ui (result->shape[i]);
 276
 277   /* Iterate over array elements, producing constructors.  */
 278   for (i = 0; i < array_size; i++)
 279     {
 280       if (head == NULL)
 281         head = tail = gfc_get_constructor ();
 282       else
 283         {
 284           tail->next = gfc_get_constructor ();
 285           tail = tail->next;
 286         }
 287
 288       tail->where = result->where;
 289       tail->expr = gfc_constant_result (result->ts.type,
 290                                           result->ts.kind, &result->where);
 291       tail->expr->ts = result->ts;
 292
 293       if (tail->expr->ts.type == BT_CHARACTER)
 294         tail->expr->value.character.length = result->value.character.length;
 295
 296       ptr += gfc_target_interpret_expr (&buffer[ptr], buffer_size - ptr,
 297                                         tail->expr);
 298     }
 299   result->value.constructor = head;
 300
 301   return ptr;
 302 }
 303
 304
 305 int
 306 gfc_interpret_integer (int kind, unsigned char *buffer, size_t buffer_size,
 307                    mpz_t integer)
 308 {
 309   mpz_init (integer);
 310   gfc_conv_tree_to_mpz (integer,
 311                         native_interpret_expr (gfc_get_int_type (kind),
 312                                                buffer, buffer_size));
 313   return size_integer (kind);
 314 }
 315
 316
 317 int
 318 gfc_interpret_float (int kind, unsigned char *buffer, size_t buffer_size,
 319                  mpfr_t real)
 320 {
 321   mpfr_init (real);
 322   gfc_conv_tree_to_mpfr (real,
 323                          native_interpret_expr (gfc_get_real_type (kind),
 324                                                 buffer, buffer_size));
 325
 326   return size_float (kind);
 327 }
 328
 329
 330 int
 331 gfc_interpret_complex (int kind, unsigned char *buffer, size_t buffer_size,
 332                    mpfr_t real, mpfr_t imaginary)
 333 {
 334   int size;
 335   size = gfc_interpret_float (kind, &buffer[0], buffer_size, real);
 336   size += gfc_interpret_float (kind, &buffer[size], buffer_size - size, imaginary);
 337   return size;
 338 }
 339
 340
 341 int
 342 gfc_interpret_logical (int kind, unsigned char *buffer, size_t buffer_size,
 343                    int *logical)
 344 {
 345   tree t = native_interpret_expr (gfc_get_logical_type (kind), buffer,
 346                                   buffer_size);
 347   *logical = double_int_zero_p (tree_to_double_int (t))
 348              ? 0 : 1;
 349   return size_logical (kind);
 350 }
 351
 352
 353 int
 354 gfc_interpret_character (unsigned char *buffer, size_t buffer_size, gfc_expr *result)
 355 {
 356   if (result->ts.cl && result->ts.cl->length)
 357     result->value.character.length =
 358       (int)mpz_get_ui (result->ts.cl->length->value.integer);
 359
 360   gcc_assert (buffer_size >= size_character (result->value.character.length));
 361   result->value.character.string =
 362     gfc_getmem (result->value.character.length + 1);
 363   memcpy (result->value.character.string, buffer,
 364           result->value.character.length);
 365   result->value.character.string [result->value.character.length] = '\0';
 366
 367   return result->value.character.length;
 368 }
 369
 370
 371 int
 372 gfc_interpret_derived (unsigned char *buffer, size_t buffer_size, gfc_expr *result)
 373 {
 374   gfc_component *cmp;
 375   gfc_constructor *head = NULL, *tail = NULL;
 376   int ptr;
 377   tree type;
 378
 379   /* The attributes of the derived type need to be bolted to the floor.  */
 380   result->expr_type = EXPR_STRUCTURE;
 381
 382   type = gfc_typenode_for_spec (&result->ts);
 383   cmp = result->ts.derived->components;
 384
 385   /* Run through the derived type components.  */
 386   for (;cmp; cmp = cmp->next)
 387     {
 388       if (head == NULL)
 389         head = tail = gfc_get_constructor ();
 390       else
 391         {
 392           tail->next = gfc_get_constructor ();
 393           tail = tail->next;
 394         }
 395
 396       /* The constructor points to the component.  */
 397       tail->n.component = cmp;
 398
 399       tail->expr = gfc_constant_result (cmp->ts.type, cmp->ts.kind,
 400                                         &result->where);
 401       tail->expr->ts = cmp->ts;
 402
 403       /* Copy shape, if needed.  */
 404       if (cmp->as && cmp->as->rank)
 405         {
 406           int n;
 407
 408           tail->expr->expr_type = EXPR_ARRAY;
 409           tail->expr->rank = cmp->as->rank;
 410
 411           tail->expr->shape = gfc_get_shape (tail->expr->rank);
 412           for (n = 0; n < tail->expr->rank; n++)
 413              {
 414                mpz_init_set_ui (tail->expr->shape[n], 1);
 415                mpz_add (tail->expr->shape[n], tail->expr->shape[n],
 416                         cmp->as->upper[n]->value.integer);
 417                mpz_sub (tail->expr->shape[n], tail->expr->shape[n],
 418                         cmp->as->lower[n]->value.integer);
 419              }
 420         }
 421
 422       ptr = TREE_INT_CST_LOW (DECL_FIELD_OFFSET (cmp->backend_decl));
 423       gfc_target_interpret_expr (&buffer[ptr], buffer_size - ptr,
 424                                  tail->expr);
 425
 426       result->value.constructor = head;
 427     }
 428
 429   return int_size_in_bytes (type);
 430 }
 431
 432
 433 /* Read a binary buffer to a constant expression.  */
 434 int
 435 gfc_target_interpret_expr (unsigned char *buffer, size_t buffer_size,
 436                            gfc_expr *result)
 437 {
 438   if (result->expr_type == EXPR_ARRAY)
 439     return interpret_array (buffer, buffer_size, result);
 440
 441   switch (result->ts.type)
 442     {
 443     case BT_INTEGER:
 444       result->representation.length =
 445         gfc_interpret_integer (result->ts.kind, buffer, buffer_size,
 446                                result->value.integer);
 447       break;
 448
 449     case BT_REAL:
 450       result->representation.length =
 451         gfc_interpret_float (result->ts.kind, buffer, buffer_size,
 452                              result->value.real);
 453       break;
 454
 455     case BT_COMPLEX:
 456       result->representation.length =
 457         gfc_interpret_complex (result->ts.kind, buffer, buffer_size,
 458                                result->value.complex.r,
 459                                result->value.complex.i);
 460       break;
 461
 462     case BT_LOGICAL:
 463       result->representation.length =
 464         gfc_interpret_logical (result->ts.kind, buffer, buffer_size,
 465                                &result->value.logical);
 466       break;
 467
 468     case BT_CHARACTER:
 469       result->representation.length =
 470         gfc_interpret_character (buffer, buffer_size, result);
 471       break;
 472
 473     case BT_DERIVED:
 474       result->representation.length =
 475         gfc_interpret_derived (buffer, buffer_size, result);
 476       break;
 477
 478     default:
 479       gfc_internal_error ("Invalid expression in gfc_target_interpret_expr.");
 480       break;
 481     }
 482
 483   if (result->ts.type == BT_CHARACTER)
 484     result->representation.string = result->value.character.string;
 485   else
 486     {
 487       result->representation.string =
 488         gfc_getmem (result->representation.length + 1);
 489       memcpy (result->representation.string, buffer,
 490               result->representation.length);
 491       result->representation.string[result->representation.length] = '\0';
 492     }
 493
 494   return result->representation.length;
 495 }
 496
 497
 498 /* --------------------------------------------------------------- */
 499 /* Two functions used by trans-common.c to write overlapping
 500    equivalence initializers to a buffer.  This is added to the union
 501    and the original initializers freed.  */
 502
 503
 504 /* Writes the values of a constant expression to a char buffer. If another
 505    unequal initializer has already been written to the buffer, this is an
 506    error.  */
 507
 508 static size_t
 509 expr_to_char (gfc_expr *e, unsigned char *data, unsigned char *chk, size_t len)
 510 {
 511   int i;
 512   int ptr;
 513   gfc_constructor *ctr;
 514   gfc_component *cmp;
 515   unsigned char *buffer;
 516
 517   if (e == NULL)
 518     return 0;
 519
 520   /* Take a derived type, one component at a time, using the offsets from the backend
 521      declaration.  */
 522   if (e->ts.type == BT_DERIVED)
 523     {
 524       ctr = e->value.constructor;
 525       cmp = e->ts.derived->components;
 526       for (;ctr; ctr = ctr->next, cmp = cmp->next)
 527         {
 528           gcc_assert (cmp && cmp->backend_decl);
 529           if (!ctr->expr)
 530             continue;
 531             ptr = TREE_INT_CST_LOW(DECL_FIELD_OFFSET(cmp->backend_decl))
 532                         + TREE_INT_CST_LOW(DECL_FIELD_BIT_OFFSET(cmp->backend_decl))/8;
 533           expr_to_char (ctr->expr, &data[ptr], &chk[ptr], len);
 534         }
 535       return len;
 536     }
 537
 538   /* Otherwise, use the target-memory machinery to write a bitwise image, appropriate
 539      to the target, in a buffer and check off the initialized part of the buffer.  */
 540   len = gfc_target_expr_size (e);
 541   buffer = (unsigned char*)alloca (len);
 542   len = gfc_target_encode_expr (e, buffer, len);
 543
 544     for (i = 0; i < (int)len; i++)
 545     {
 546       if (chk[i] && (buffer[i] != data[i]))
 547         {
 548           gfc_error ("Overlapping unequal initializers in EQUIVALENCE "
 549                      "at %L", &e->where);
 550           return 0;
 551         }
 552       chk[i] = 0xFF;
 553     }
 554
 555   memcpy (data, buffer, len);
 556   return len;
 557 }
 558
 559
 560 /* Writes the values from the equivalence initializers to a char* array
 561    that will be written to the constructor to make the initializer for
 562    the union declaration.  */
 563
 564 size_t
 565 gfc_merge_initializers (gfc_typespec ts, gfc_expr *e, unsigned char *data,
 566                         unsigned char *chk, size_t length)
 567 {
 568   size_t len = 0;
 569   gfc_constructor * c;
 570
 571   switch (e->expr_type)
 572     {
 573     case EXPR_CONSTANT:
 574     case EXPR_STRUCTURE:
 575       len = expr_to_char (e, &data[0], &chk[0], length);
 576
 577       break;
 578
 579     case EXPR_ARRAY:
 580       for (c = e->value.constructor; c; c = c->next)
 581         {
 582           size_t elt_size = gfc_target_expr_size (c->expr);
 583
 584           if (c->n.offset)
 585             len = elt_size * (size_t)mpz_get_si (c->n.offset);
 586
 587           len = len + gfc_merge_initializers (ts, c->expr, &data[len],
 588                                               &chk[len], length - len);
 589         }
 590       break;
 591
 592     default:
 593       return 0;
 594     }
 595
 596   return len;
 597 }
 598
 599
 600 /* Transfer the bitpattern of a (integer) BOZ to real or complex variables.
 601    When successful, no BOZ or nothing to do, true is returned.  */
 602
 603 bool
 604 gfc_convert_boz (gfc_expr *expr, gfc_typespec *ts)
 605 {
 606   size_t buffer_size, boz_bit_size, ts_bit_size;
 607   int index;
 608   unsigned char *buffer;
 609
 610   if (!expr->is_boz)
 611     return true;
 612
 613   gcc_assert (expr->expr_type == EXPR_CONSTANT
 614               && expr->ts.type == BT_INTEGER);
 615
 616   /* Don't convert BOZ to logical, character, derived etc.  */
 617   if (ts->type == BT_REAL)
 618     {
 619       buffer_size = size_float (ts->kind);
 620       ts_bit_size = buffer_size * 8;
 621     }
 622   else if (ts->type == BT_COMPLEX)
 623     {
 624       buffer_size = size_complex (ts->kind);
 625       ts_bit_size = buffer_size * 8 / 2;
 626     }
 627   else
 628     return true;
 629
 630   /* Convert BOZ to the smallest possible integer kind.  */
 631   boz_bit_size = mpz_sizeinbase (expr->value.integer, 2);
 632
 633   if (boz_bit_size > ts_bit_size)
 634     {
 635       gfc_error_now ("BOZ constant at %L is too large (%ld vs %ld bits)",
 636                      &expr->where, (long) boz_bit_size, (long) ts_bit_size);
 637       return false;
 638     }
 639
 640   for (index = 0; gfc_integer_kinds[index].kind != 0; ++index)
 641     {
 642         if ((unsigned) gfc_integer_kinds[index].bit_size >= ts_bit_size)
 643           break;
 644     }
 645
 646   expr->ts.kind = gfc_integer_kinds[index].kind;
 647   buffer_size = MAX (buffer_size, size_integer (expr->ts.kind));
 648
 649   buffer = (unsigned char*)alloca (buffer_size);
 650   encode_integer (expr->ts.kind, expr->value.integer, buffer, buffer_size);
 651   mpz_clear (expr->value.integer);
 652
 653   if (ts->type == BT_REAL)
 654     {
 655       mpfr_init (expr->value.real);
 656       gfc_interpret_float (ts->kind, buffer, buffer_size, expr->value.real);
 657     }
 658   else
 659     {
 660       mpfr_init (expr->value.complex.r);
 661       mpfr_init (expr->value.complex.i);
 662       gfc_interpret_complex (ts->kind, buffer, buffer_size,
 663                              expr->value.complex.r, expr->value.complex.i);
 664     }
 665   expr->is_boz = 0;
 666   expr->ts.type = ts->type;
 667   expr->ts.kind = ts->kind;
 668
 669   return true;
 670 }