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 (ctr->expr && cmp);
 202       ptr = TREE_INT_CST_LOW (DECL_FIELD_OFFSET (cmp->backend_decl));
 203       gfc_target_encode_expr (ctr->expr, &buffer[ptr],
 204                               buffer_size - ptr);
 205     }
 206
 207   return int_size_in_bytes (type);
 208 }
 209
 210
 211 /* Write a constant expression in binary form to a buffer.  */
 212 int
 213 gfc_target_encode_expr (gfc_expr *source, unsigned char *buffer,
 214                         size_t buffer_size)
 215 {
 216   if (source == NULL)
 217     return 0;
 218
 219   if (source->expr_type == EXPR_ARRAY)
 220     return encode_array (source, buffer, buffer_size);
 221
 222   gcc_assert (source->expr_type == EXPR_CONSTANT
 223               || source->expr_type == EXPR_STRUCTURE);
 224
 225   /* If we already have a target-memory representation, we use that rather
 226      than recreating one.  */
 227   if (source->representation.string)
 228     {
 229       memcpy (buffer, source->representation.string,
 230               source->representation.length);
 231       return source->representation.length;
 232     }
 233
 234   switch (source->ts.type)
 235     {
 236     case BT_INTEGER:
 237       return encode_integer (source->ts.kind, source->value.integer, buffer,
 238                              buffer_size);
 239     case BT_REAL:
 240       return encode_float (source->ts.kind, source->value.real, buffer,
 241                            buffer_size);
 242     case BT_COMPLEX:
 243       return encode_complex (source->ts.kind, source->value.complex.r,
 244                              source->value.complex.i, buffer, buffer_size);
 245     case BT_LOGICAL:
 246       return encode_logical (source->ts.kind, source->value.logical, buffer,
 247                              buffer_size);
 248     case BT_CHARACTER:
 249       return encode_character (source->value.character.length,
 250                                source->value.character.string, buffer,
 251                                buffer_size);
 252     case BT_DERIVED:
 253       return encode_derived (source, buffer, buffer_size);
 254     default:
 255       gfc_internal_error ("Invalid expression in gfc_target_encode_expr.");
 256       return 0;
 257     }
 258 }
 259
 260
 261 static int
 262 interpret_array (unsigned char *buffer, size_t buffer_size, gfc_expr *result)
 263 {
 264   int array_size = 1;
 265   int i;
 266   int ptr = 0;
 267   gfc_constructor *head = NULL, *tail = NULL;
 268
 269   /* Calculate array size from its shape and rank.  */
 270   gcc_assert (result->rank > 0 && result->shape);
 271
 272   for (i = 0; i < result->rank; i++)
 273     array_size *= (int)mpz_get_ui (result->shape[i]);
 274
 275   /* Iterate over array elements, producing constructors.  */
 276   for (i = 0; i < array_size; i++)
 277     {
 278       if (head == NULL)
 279         head = tail = gfc_get_constructor ();
 280       else
 281         {
 282           tail->next = gfc_get_constructor ();
 283           tail = tail->next;
 284         }
 285
 286       tail->where = result->where;
 287       tail->expr = gfc_constant_result (result->ts.type,
 288                                           result->ts.kind, &result->where);
 289       tail->expr->ts = result->ts;
 290
 291       if (tail->expr->ts.type == BT_CHARACTER)
 292         tail->expr->value.character.length = result->value.character.length;
 293
 294       ptr += gfc_target_interpret_expr (&buffer[ptr], buffer_size - ptr,
 295                                         tail->expr);
 296     }
 297   result->value.constructor = head;
 298
 299   return ptr;
 300 }
 301
 302
 303 int
 304 gfc_interpret_integer (int kind, unsigned char *buffer, size_t buffer_size,
 305                    mpz_t integer)
 306 {
 307   mpz_init (integer);
 308   gfc_conv_tree_to_mpz (integer,
 309                         native_interpret_expr (gfc_get_int_type (kind),
 310                                                buffer, buffer_size));
 311   return size_integer (kind);
 312 }
 313
 314
 315 int
 316 gfc_interpret_float (int kind, unsigned char *buffer, size_t buffer_size,
 317                  mpfr_t real)
 318 {
 319   mpfr_init (real);
 320   gfc_conv_tree_to_mpfr (real,
 321                          native_interpret_expr (gfc_get_real_type (kind),
 322                                                 buffer, buffer_size));
 323
 324   return size_float (kind);
 325 }
 326
 327
 328 int
 329 gfc_interpret_complex (int kind, unsigned char *buffer, size_t buffer_size,
 330                    mpfr_t real, mpfr_t imaginary)
 331 {
 332   int size;
 333   size = gfc_interpret_float (kind, &buffer[0], buffer_size, real);
 334   size += gfc_interpret_float (kind, &buffer[size], buffer_size - size, imaginary);
 335   return size;
 336 }
 337
 338
 339 int
 340 gfc_interpret_logical (int kind, unsigned char *buffer, size_t buffer_size,
 341                    int *logical)
 342 {
 343   tree t = native_interpret_expr (gfc_get_logical_type (kind), buffer,
 344                                   buffer_size);
 345   *logical = double_int_zero_p (tree_to_double_int (t))
 346              ? 0 : 1;
 347   return size_logical (kind);
 348 }
 349
 350
 351 int
 352 gfc_interpret_character (unsigned char *buffer, size_t buffer_size, gfc_expr *result)
 353 {
 354   if (result->ts.cl && result->ts.cl->length)
 355     result->value.character.length =
 356       (int)mpz_get_ui (result->ts.cl->length->value.integer);
 357
 358   gcc_assert (buffer_size >= size_character (result->value.character.length));
 359   result->value.character.string =
 360     gfc_getmem (result->value.character.length + 1);
 361   memcpy (result->value.character.string, buffer,
 362           result->value.character.length);
 363   result->value.character.string [result->value.character.length] = '\0';
 364
 365   return result->value.character.length;
 366 }
 367
 368
 369 int
 370 gfc_interpret_derived (unsigned char *buffer, size_t buffer_size, gfc_expr *result)
 371 {
 372   gfc_component *cmp;
 373   gfc_constructor *head = NULL, *tail = NULL;
 374   int ptr;
 375   tree type;
 376
 377   /* The attributes of the derived type need to be bolted to the floor.  */
 378   result->expr_type = EXPR_STRUCTURE;
 379
 380   type = gfc_typenode_for_spec (&result->ts);
 381   cmp = result->ts.derived->components;
 382
 383   /* Run through the derived type components.  */
 384   for (;cmp; cmp = cmp->next)
 385     {
 386       if (head == NULL)
 387         head = tail = gfc_get_constructor ();
 388       else
 389         {
 390           tail->next = gfc_get_constructor ();
 391           tail = tail->next;
 392         }
 393
 394       /* The constructor points to the component.  */
 395       tail->n.component = cmp;
 396
 397       tail->expr = gfc_constant_result (cmp->ts.type, cmp->ts.kind,
 398                                         &result->where);
 399       tail->expr->ts = cmp->ts;
 400
 401       /* Copy shape, if needed.  */
 402       if (cmp->as && cmp->as->rank)
 403         {
 404           int n;
 405
 406           tail->expr->expr_type = EXPR_ARRAY;
 407           tail->expr->rank = cmp->as->rank;
 408
 409           tail->expr->shape = gfc_get_shape (tail->expr->rank);
 410           for (n = 0; n < tail->expr->rank; n++)
 411              {
 412                mpz_init_set_ui (tail->expr->shape[n], 1);
 413                mpz_add (tail->expr->shape[n], tail->expr->shape[n],
 414                         cmp->as->upper[n]->value.integer);
 415                mpz_sub (tail->expr->shape[n], tail->expr->shape[n],
 416                         cmp->as->lower[n]->value.integer);
 417              }
 418         }
 419
 420       ptr = TREE_INT_CST_LOW (DECL_FIELD_OFFSET (cmp->backend_decl));
 421       gfc_target_interpret_expr (&buffer[ptr], buffer_size - ptr,
 422                                  tail->expr);
 423
 424       result->value.constructor = head;
 425     }
 426
 427   return int_size_in_bytes (type);
 428 }
 429
 430
 431 /* Read a binary buffer to a constant expression.  */
 432 int
 433 gfc_target_interpret_expr (unsigned char *buffer, size_t buffer_size,
 434                            gfc_expr *result)
 435 {
 436   if (result->expr_type == EXPR_ARRAY)
 437     return interpret_array (buffer, buffer_size, result);
 438
 439   switch (result->ts.type)
 440     {
 441     case BT_INTEGER:
 442       result->representation.length =
 443         gfc_interpret_integer (result->ts.kind, buffer, buffer_size,
 444                                result->value.integer);
 445       break;
 446
 447     case BT_REAL:
 448       result->representation.length =
 449         gfc_interpret_float (result->ts.kind, buffer, buffer_size,
 450                              result->value.real);
 451       break;
 452
 453     case BT_COMPLEX:
 454       result->representation.length =
 455         gfc_interpret_complex (result->ts.kind, buffer, buffer_size,
 456                                result->value.complex.r,
 457                                result->value.complex.i);
 458       break;
 459
 460     case BT_LOGICAL:
 461       result->representation.length =
 462         gfc_interpret_logical (result->ts.kind, buffer, buffer_size,
 463                                &result->value.logical);
 464       break;
 465
 466     case BT_CHARACTER:
 467       result->representation.length =
 468         gfc_interpret_character (buffer, buffer_size, result);
 469       break;
 470
 471     case BT_DERIVED:
 472       result->representation.length =
 473         gfc_interpret_derived (buffer, buffer_size, result);
 474       break;
 475
 476     default:
 477       gfc_internal_error ("Invalid expression in gfc_target_interpret_expr.");
 478       break;
 479     }
 480
 481   if (result->ts.type == BT_CHARACTER)
 482     result->representation.string = result->value.character.string;
 483   else
 484     {
 485       result->representation.string =
 486         gfc_getmem (result->representation.length + 1);
 487       memcpy (result->representation.string, buffer,
 488               result->representation.length);
 489       result->representation.string[result->representation.length] = '\0';
 490     }
 491
 492   return result->representation.length;
 493 }