gcc/fortran/target-memory.c

   1 /* Simulate storage of variables into target memory.
   2    Copyright (C) 2007, 2008
   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, int kind)
  77 {
  78   return length * kind;
  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, e->ts.kind);
 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 kind, int length, gfc_char_t *string,
 178                   unsigned char *buffer, size_t buffer_size)
 179 {
 180   char *s;
 181
 182   gcc_assert (buffer_size >= size_character (length, kind));
 183   /* FIXME -- when we support wide character types, we'll need to go
 184      via integers for them.  For now, we keep the simple memcpy().  */
 185   gcc_assert (kind == gfc_default_character_kind);
 186
 187   s = gfc_widechar_to_char (string, length);
 188   memcpy (buffer, s, length);
 189   gfc_free (s);
 190
 191   return length;
 192 }
 193
 194
 195 static int
 196 encode_derived (gfc_expr *source, unsigned char *buffer, size_t buffer_size)
 197 {
 198   gfc_constructor *ctr;
 199   gfc_component *cmp;
 200   int ptr;
 201   tree type;
 202
 203   type = gfc_typenode_for_spec (&source->ts);
 204
 205   ctr = source->value.constructor;
 206   cmp = source->ts.derived->components;
 207   for (;ctr; ctr = ctr->next, cmp = cmp->next)
 208     {
 209       gcc_assert (cmp);
 210       if (!ctr->expr)
 211         continue;
 212       ptr = TREE_INT_CST_LOW(DECL_FIELD_OFFSET(cmp->backend_decl))
 213             + TREE_INT_CST_LOW(DECL_FIELD_BIT_OFFSET(cmp->backend_decl))/8;
 214       gfc_target_encode_expr (ctr->expr, &buffer[ptr],
 215                               buffer_size - ptr);
 216     }
 217
 218   return int_size_in_bytes (type);
 219 }
 220
 221
 222 /* Write a constant expression in binary form to a buffer.  */
 223 int
 224 gfc_target_encode_expr (gfc_expr *source, unsigned char *buffer,
 225                         size_t buffer_size)
 226 {
 227   if (source == NULL)
 228     return 0;
 229
 230   if (source->expr_type == EXPR_ARRAY)
 231     return encode_array (source, buffer, buffer_size);
 232
 233   gcc_assert (source->expr_type == EXPR_CONSTANT
 234               || source->expr_type == EXPR_STRUCTURE);
 235
 236   /* If we already have a target-memory representation, we use that rather
 237      than recreating one.  */
 238   if (source->representation.string)
 239     {
 240       memcpy (buffer, source->representation.string,
 241               source->representation.length);
 242       return source->representation.length;
 243     }
 244
 245   switch (source->ts.type)
 246     {
 247     case BT_INTEGER:
 248       return encode_integer (source->ts.kind, source->value.integer, buffer,
 249                              buffer_size);
 250     case BT_REAL:
 251       return encode_float (source->ts.kind, source->value.real, buffer,
 252                            buffer_size);
 253     case BT_COMPLEX:
 254       return encode_complex (source->ts.kind, source->value.complex.r,
 255                              source->value.complex.i, buffer, buffer_size);
 256     case BT_LOGICAL:
 257       return encode_logical (source->ts.kind, source->value.logical, buffer,
 258                              buffer_size);
 259     case BT_CHARACTER:
 260       return encode_character (source->ts.kind, source->value.character.length,
 261                                source->value.character.string, buffer,
 262                                buffer_size);
 263     case BT_DERIVED:
 264       return encode_derived (source, buffer, buffer_size);
 265     default:
 266       gfc_internal_error ("Invalid expression in gfc_target_encode_expr.");
 267       return 0;
 268     }
 269 }
 270
 271
 272 static int
 273 interpret_array (unsigned char *buffer, size_t buffer_size, gfc_expr *result)
 274 {
 275   int array_size = 1;
 276   int i;
 277   int ptr = 0;
 278   gfc_constructor *head = NULL, *tail = NULL;
 279
 280   /* Calculate array size from its shape and rank.  */
 281   gcc_assert (result->rank > 0 && result->shape);
 282
 283   for (i = 0; i < result->rank; i++)
 284     array_size *= (int)mpz_get_ui (result->shape[i]);
 285
 286   /* Iterate over array elements, producing constructors.  */
 287   for (i = 0; i < array_size; i++)
 288     {
 289       if (head == NULL)
 290         head = tail = gfc_get_constructor ();
 291       else
 292         {
 293           tail->next = gfc_get_constructor ();
 294           tail = tail->next;
 295         }
 296
 297       tail->where = result->where;
 298       tail->expr = gfc_constant_result (result->ts.type,
 299                                           result->ts.kind, &result->where);
 300       tail->expr->ts = result->ts;
 301
 302       if (tail->expr->ts.type == BT_CHARACTER)
 303         tail->expr->value.character.length = result->value.character.length;
 304
 305       ptr += gfc_target_interpret_expr (&buffer[ptr], buffer_size - ptr,
 306                                         tail->expr);
 307     }
 308   result->value.constructor = head;
 309
 310   return ptr;
 311 }
 312
 313
 314 int
 315 gfc_interpret_integer (int kind, unsigned char *buffer, size_t buffer_size,
 316                    mpz_t integer)
 317 {
 318   mpz_init (integer);
 319   gfc_conv_tree_to_mpz (integer,
 320                         native_interpret_expr (gfc_get_int_type (kind),
 321                                                buffer, buffer_size));
 322   return size_integer (kind);
 323 }
 324
 325
 326 int
 327 gfc_interpret_float (int kind, unsigned char *buffer, size_t buffer_size,
 328                  mpfr_t real)
 329 {
 330   mpfr_init (real);
 331   gfc_conv_tree_to_mpfr (real,
 332                          native_interpret_expr (gfc_get_real_type (kind),
 333                                                 buffer, buffer_size));
 334
 335   return size_float (kind);
 336 }
 337
 338
 339 int
 340 gfc_interpret_complex (int kind, unsigned char *buffer, size_t buffer_size,
 341                    mpfr_t real, mpfr_t imaginary)
 342 {
 343   int size;
 344   size = gfc_interpret_float (kind, &buffer[0], buffer_size, real);
 345   size += gfc_interpret_float (kind, &buffer[size], buffer_size - size, imaginary);
 346   return size;
 347 }
 348
 349
 350 int
 351 gfc_interpret_logical (int kind, unsigned char *buffer, size_t buffer_size,
 352                    int *logical)
 353 {
 354   tree t = native_interpret_expr (gfc_get_logical_type (kind), buffer,
 355                                   buffer_size);
 356   *logical = double_int_zero_p (tree_to_double_int (t))
 357              ? 0 : 1;
 358   return size_logical (kind);
 359 }
 360
 361
 362 int
 363 gfc_interpret_character (unsigned char *buffer, size_t buffer_size,
 364                          gfc_expr *result)
 365 {
 366   int i;
 367
 368   if (result->ts.cl && result->ts.cl->length)
 369     result->value.character.length =
 370       (int) mpz_get_ui (result->ts.cl->length->value.integer);
 371
 372   gcc_assert (buffer_size >= size_character (result->value.character.length,
 373                                              result->ts.kind));
 374   result->value.character.string =
 375     gfc_get_wide_string (result->value.character.length + 1);
 376
 377   gcc_assert (result->ts.kind == gfc_default_character_kind);
 378   for (i = 0; i < result->value.character.length; i++)
 379     result->value.character.string[i] = (gfc_char_t) buffer[i];
 380   result->value.character.string[result->value.character.length] = '\0';
 381
 382   return result->value.character.length;
 383 }
 384
 385
 386 int
 387 gfc_interpret_derived (unsigned char *buffer, size_t buffer_size, gfc_expr *result)
 388 {
 389   gfc_component *cmp;
 390   gfc_constructor *head = NULL, *tail = NULL;
 391   int ptr;
 392   tree type;
 393
 394   /* The attributes of the derived type need to be bolted to the floor.  */
 395   result->expr_type = EXPR_STRUCTURE;
 396
 397   type = gfc_typenode_for_spec (&result->ts);
 398   cmp = result->ts.derived->components;
 399
 400   /* Run through the derived type components.  */
 401   for (;cmp; cmp = cmp->next)
 402     {
 403       if (head == NULL)
 404         head = tail = gfc_get_constructor ();
 405       else
 406         {
 407           tail->next = gfc_get_constructor ();
 408           tail = tail->next;
 409         }
 410
 411       /* The constructor points to the component.  */
 412       tail->n.component = cmp;
 413
 414       tail->expr = gfc_constant_result (cmp->ts.type, cmp->ts.kind,
 415                                         &result->where);
 416       tail->expr->ts = cmp->ts;
 417
 418       /* Copy shape, if needed.  */
 419       if (cmp->as && cmp->as->rank)
 420         {
 421           int n;
 422
 423           tail->expr->expr_type = EXPR_ARRAY;
 424           tail->expr->rank = cmp->as->rank;
 425
 426           tail->expr->shape = gfc_get_shape (tail->expr->rank);
 427           for (n = 0; n < tail->expr->rank; n++)
 428              {
 429                mpz_init_set_ui (tail->expr->shape[n], 1);
 430                mpz_add (tail->expr->shape[n], tail->expr->shape[n],
 431                         cmp->as->upper[n]->value.integer);
 432                mpz_sub (tail->expr->shape[n], tail->expr->shape[n],
 433                         cmp->as->lower[n]->value.integer);
 434              }
 435         }
 436
 437       ptr = TREE_INT_CST_LOW (DECL_FIELD_OFFSET (cmp->backend_decl));
 438       gfc_target_interpret_expr (&buffer[ptr], buffer_size - ptr,
 439                                  tail->expr);
 440
 441       result->value.constructor = head;
 442     }
 443
 444   return int_size_in_bytes (type);
 445 }
 446
 447
 448 /* Read a binary buffer to a constant expression.  */
 449 int
 450 gfc_target_interpret_expr (unsigned char *buffer, size_t buffer_size,
 451                            gfc_expr *result)
 452 {
 453   if (result->expr_type == EXPR_ARRAY)
 454     return interpret_array (buffer, buffer_size, result);
 455
 456   switch (result->ts.type)
 457     {
 458     case BT_INTEGER:
 459       result->representation.length =
 460         gfc_interpret_integer (result->ts.kind, buffer, buffer_size,
 461                                result->value.integer);
 462       break;
 463
 464     case BT_REAL:
 465       result->representation.length =
 466         gfc_interpret_float (result->ts.kind, buffer, buffer_size,
 467                              result->value.real);
 468       break;
 469
 470     case BT_COMPLEX:
 471       result->representation.length =
 472         gfc_interpret_complex (result->ts.kind, buffer, buffer_size,
 473                                result->value.complex.r,
 474                                result->value.complex.i);
 475       break;
 476
 477     case BT_LOGICAL:
 478       result->representation.length =
 479         gfc_interpret_logical (result->ts.kind, buffer, buffer_size,
 480                                &result->value.logical);
 481       break;
 482
 483     case BT_CHARACTER:
 484       result->representation.length =
 485         gfc_interpret_character (buffer, buffer_size, result);
 486       break;
 487
 488     case BT_DERIVED:
 489       result->representation.length =
 490         gfc_interpret_derived (buffer, buffer_size, result);
 491       break;
 492
 493     default:
 494       gfc_internal_error ("Invalid expression in gfc_target_interpret_expr.");
 495       break;
 496     }
 497
 498   if (result->ts.type == BT_CHARACTER)
 499     result->representation.string
 500       = gfc_widechar_to_char (result->value.character.string,
 501                               result->value.character.length);
 502   else
 503     {
 504       result->representation.string =
 505         gfc_getmem (result->representation.length + 1);
 506       memcpy (result->representation.string, buffer,
 507               result->representation.length);
 508       result->representation.string[result->representation.length] = '\0';
 509     }
 510
 511   return result->representation.length;
 512 }
 513
 514
 515 /* --------------------------------------------------------------- */
 516 /* Two functions used by trans-common.c to write overlapping
 517    equivalence initializers to a buffer.  This is added to the union
 518    and the original initializers freed.  */
 519
 520
 521 /* Writes the values of a constant expression to a char buffer. If another
 522    unequal initializer has already been written to the buffer, this is an
 523    error.  */
 524
 525 static size_t
 526 expr_to_char (gfc_expr *e, unsigned char *data, unsigned char *chk, size_t len)
 527 {
 528   int i;
 529   int ptr;
 530   gfc_constructor *ctr;
 531   gfc_component *cmp;
 532   unsigned char *buffer;
 533
 534   if (e == NULL)
 535     return 0;
 536
 537   /* Take a derived type, one component at a time, using the offsets from the backend
 538      declaration.  */
 539   if (e->ts.type == BT_DERIVED)
 540     {
 541       ctr = e->value.constructor;
 542       cmp = e->ts.derived->components;
 543       for (;ctr; ctr = ctr->next, cmp = cmp->next)
 544         {
 545           gcc_assert (cmp && cmp->backend_decl);
 546           if (!ctr->expr)
 547             continue;
 548             ptr = TREE_INT_CST_LOW(DECL_FIELD_OFFSET(cmp->backend_decl))
 549                         + TREE_INT_CST_LOW(DECL_FIELD_BIT_OFFSET(cmp->backend_decl))/8;
 550           expr_to_char (ctr->expr, &data[ptr], &chk[ptr], len);
 551         }
 552       return len;
 553     }
 554
 555   /* Otherwise, use the target-memory machinery to write a bitwise image, appropriate
 556      to the target, in a buffer and check off the initialized part of the buffer.  */
 557   len = gfc_target_expr_size (e);
 558   buffer = (unsigned char*)alloca (len);
 559   len = gfc_target_encode_expr (e, buffer, len);
 560
 561     for (i = 0; i < (int)len; i++)
 562     {
 563       if (chk[i] && (buffer[i] != data[i]))
 564         {
 565           gfc_error ("Overlapping unequal initializers in EQUIVALENCE "
 566                      "at %L", &e->where);
 567           return 0;
 568         }
 569       chk[i] = 0xFF;
 570     }
 571
 572   memcpy (data, buffer, len);
 573   return len;
 574 }
 575
 576
 577 /* Writes the values from the equivalence initializers to a char* array
 578    that will be written to the constructor to make the initializer for
 579    the union declaration.  */
 580
 581 size_t
 582 gfc_merge_initializers (gfc_typespec ts, gfc_expr *e, unsigned char *data,
 583                         unsigned char *chk, size_t length)
 584 {
 585   size_t len = 0;
 586   gfc_constructor * c;
 587
 588   switch (e->expr_type)
 589     {
 590     case EXPR_CONSTANT:
 591     case EXPR_STRUCTURE:
 592       len = expr_to_char (e, &data[0], &chk[0], length);
 593
 594       break;
 595
 596     case EXPR_ARRAY:
 597       for (c = e->value.constructor; c; c = c->next)
 598         {
 599           size_t elt_size = gfc_target_expr_size (c->expr);
 600
 601           if (c->n.offset)
 602             len = elt_size * (size_t)mpz_get_si (c->n.offset);
 603
 604           len = len + gfc_merge_initializers (ts, c->expr, &data[len],
 605                                               &chk[len], length - len);
 606         }
 607       break;
 608
 609     default:
 610       return 0;
 611     }
 612
 613   return len;
 614 }
 615
 616
 617 /* Transfer the bitpattern of a (integer) BOZ to real or complex variables.
 618    When successful, no BOZ or nothing to do, true is returned.  */
 619
 620 bool
 621 gfc_convert_boz (gfc_expr *expr, gfc_typespec *ts)
 622 {
 623   size_t buffer_size, boz_bit_size, ts_bit_size;
 624   int index;
 625   unsigned char *buffer;
 626
 627   if (!expr->is_boz)
 628     return true;
 629
 630   gcc_assert (expr->expr_type == EXPR_CONSTANT
 631               && expr->ts.type == BT_INTEGER);
 632
 633   /* Don't convert BOZ to logical, character, derived etc.  */
 634   if (ts->type == BT_REAL)
 635     {
 636       buffer_size = size_float (ts->kind);
 637       ts_bit_size = buffer_size * 8;
 638     }
 639   else if (ts->type == BT_COMPLEX)
 640     {
 641       buffer_size = size_complex (ts->kind);
 642       ts_bit_size = buffer_size * 8 / 2;
 643     }
 644   else
 645     return true;
 646
 647   /* Convert BOZ to the smallest possible integer kind.  */
 648   boz_bit_size = mpz_sizeinbase (expr->value.integer, 2);
 649
 650   if (boz_bit_size > ts_bit_size)
 651     {
 652       gfc_error_now ("BOZ constant at %L is too large (%ld vs %ld bits)",
 653                      &expr->where, (long) boz_bit_size, (long) ts_bit_size);
 654       return false;
 655     }
 656
 657   for (index = 0; gfc_integer_kinds[index].kind != 0; ++index)
 658     {
 659         if ((unsigned) gfc_integer_kinds[index].bit_size >= ts_bit_size)
 660           break;
 661     }
 662
 663   expr->ts.kind = gfc_integer_kinds[index].kind;
 664   buffer_size = MAX (buffer_size, size_integer (expr->ts.kind));
 665
 666   buffer = (unsigned char*)alloca (buffer_size);
 667   encode_integer (expr->ts.kind, expr->value.integer, buffer, buffer_size);
 668   mpz_clear (expr->value.integer);
 669
 670   if (ts->type == BT_REAL)
 671     {
 672       mpfr_init (expr->value.real);
 673       gfc_interpret_float (ts->kind, buffer, buffer_size, expr->value.real);
 674     }
 675   else
 676     {
 677       mpfr_init (expr->value.complex.r);
 678       mpfr_init (expr->value.complex.i);
 679       gfc_interpret_complex (ts->kind, buffer, buffer_size,
 680                              expr->value.complex.r, expr->value.complex.i);
 681     }
 682   expr->is_boz = 0;
 683   expr->ts.type = ts->type;
 684   expr->ts.kind = ts->kind;
 685
 686   return true;
 687 }