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