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_DERIVED:
 106       type = gfc_typenode_for_spec (&e->ts);
 107       return int_size_in_bytes (type);
 108     default:
 109       gfc_internal_error ("Invalid expression in gfc_target_expr_size.");
 110       return 0;
 111     }
 112 }
 113
 114
 115 /* The encode_* functions export a value into a buffer, and
 116    return the number of bytes of the buffer that have been
 117    used.  */
 118
 119 static int
 120 encode_array (gfc_expr *expr, unsigned char *buffer, size_t buffer_size)
 121 {
 122   mpz_t array_size;
 123   int i;
 124   int ptr = 0;
 125
 126   gfc_array_size (expr, &array_size);
 127   for (i = 0; i < (int)mpz_get_ui (array_size); i++)
 128     {
 129       ptr += gfc_target_encode_expr (gfc_get_array_element (expr, i),
 130                                      &buffer[ptr], buffer_size - ptr);
 131     }
 132
 133   mpz_clear (array_size);
 134   return ptr;
 135 }
 136
 137
 138 static int
 139 encode_integer (int kind, mpz_t integer, unsigned char *buffer,
 140                 size_t buffer_size)
 141 {
 142   return native_encode_expr (gfc_conv_mpz_to_tree (integer, kind),
 143                              buffer, buffer_size);
 144 }
 145
 146
 147 static int
 148 encode_float (int kind, mpfr_t real, unsigned char *buffer, size_t buffer_size)
 149 {
 150   return native_encode_expr (gfc_conv_mpfr_to_tree (real, kind), buffer,
 151                              buffer_size);
 152 }
 153
 154
 155 static int
 156 encode_complex (int kind, mpfr_t real, mpfr_t imaginary, unsigned char *buffer,
 157                 size_t buffer_size)
 158 {
 159   int size;
 160   size = encode_float (kind, real, &buffer[0], buffer_size);
 161   size += encode_float (kind, imaginary, &buffer[size], buffer_size - size);
 162   return size;
 163 }
 164
 165
 166 static int
 167 encode_logical (int kind, int logical, unsigned char *buffer, size_t buffer_size)
 168 {
 169   return native_encode_expr (build_int_cst (gfc_get_logical_type (kind),
 170                                             logical),
 171                              buffer, buffer_size);
 172 }
 173
 174
 175 static int
 176 encode_character (int length, char *string, unsigned char *buffer,
 177                   size_t buffer_size)
 178 {
 179   gcc_assert (buffer_size >= size_character (length));
 180   memcpy (buffer, string, length);
 181   return length;
 182 }
 183
 184
 185 static int
 186 encode_derived (gfc_expr *source, unsigned char *buffer, size_t buffer_size)
 187 {
 188   gfc_constructor *ctr;
 189   gfc_component *cmp;
 190   int ptr;
 191   tree type;
 192
 193   type = gfc_typenode_for_spec (&source->ts);
 194
 195   ctr = source->value.constructor;
 196   cmp = source->ts.derived->components;
 197   for (;ctr; ctr = ctr->next, cmp = cmp->next)
 198     {
 199       gcc_assert (ctr->expr && cmp);
 200       ptr = TREE_INT_CST_LOW (DECL_FIELD_OFFSET (cmp->backend_decl));
 201       gfc_target_encode_expr (ctr->expr, &buffer[ptr],
 202                               buffer_size - ptr);
 203     }
 204
 205   return int_size_in_bytes (type);
 206 }
 207
 208
 209 /* Write a constant expression in binary form to a buffer.  */
 210 int
 211 gfc_target_encode_expr (gfc_expr *source, unsigned char *buffer,
 212                         size_t buffer_size)
 213 {
 214   if (source == NULL)
 215     return 0;
 216
 217   if (source->expr_type == EXPR_ARRAY)
 218     return encode_array (source, buffer, buffer_size);
 219
 220   gcc_assert (source->expr_type == EXPR_CONSTANT
 221               || source->expr_type == EXPR_STRUCTURE);
 222
 223   switch (source->ts.type)
 224     {
 225     case BT_INTEGER:
 226       return encode_integer (source->ts.kind, source->value.integer, buffer,
 227                              buffer_size);
 228     case BT_REAL:
 229       return encode_float (source->ts.kind, source->value.real, buffer,
 230                            buffer_size);
 231     case BT_COMPLEX:
 232       return encode_complex (source->ts.kind, source->value.complex.r,
 233                              source->value.complex.i, buffer, buffer_size);
 234     case BT_LOGICAL:
 235       return encode_logical (source->ts.kind, source->value.logical, buffer,
 236                              buffer_size);
 237     case BT_CHARACTER:
 238       return encode_character (source->value.character.length,
 239                                source->value.character.string, buffer,
 240                                buffer_size);
 241     case BT_DERIVED:
 242       return encode_derived (source, buffer, buffer_size);
 243     default:
 244       gfc_internal_error ("Invalid expression in gfc_target_encode_expr.");
 245       return 0;
 246     }
 247 }
 248
 249
 250 static int
 251 interpret_array (unsigned char *buffer, size_t buffer_size, gfc_expr *result)
 252 {
 253   int array_size = 1;
 254   int i;
 255   int ptr = 0;
 256   gfc_constructor *head = NULL, *tail = NULL;
 257
 258   /* Calculate array size from its shape and rank.  */
 259   gcc_assert (result->rank > 0 && result->shape);
 260
 261   for (i = 0; i < result->rank; i++)
 262     array_size *= (int)mpz_get_ui (result->shape[i]);
 263
 264   /* Iterate over array elements, producing constructors.  */
 265   for (i = 0; i < array_size; i++)
 266     {
 267       if (head == NULL)
 268         head = tail = gfc_get_constructor ();
 269       else
 270         {
 271           tail->next = gfc_get_constructor ();
 272           tail = tail->next;
 273         }
 274
 275       tail->where = result->where;
 276       tail->expr = gfc_constant_result (result->ts.type,
 277                                           result->ts.kind, &result->where);
 278       tail->expr->ts = result->ts;
 279
 280       if (tail->expr->ts.type == BT_CHARACTER)
 281         tail->expr->value.character.length = result->value.character.length;
 282
 283       ptr += gfc_target_interpret_expr (&buffer[ptr], buffer_size - ptr,
 284                                         tail->expr);
 285     }
 286   result->value.constructor = head;
 287
 288   return ptr;
 289 }
 290
 291
 292 static int
 293 interpret_integer (int kind, unsigned char *buffer, size_t buffer_size,
 294                    mpz_t integer)
 295 {
 296   mpz_init (integer);
 297   gfc_conv_tree_to_mpz (integer,
 298                         native_interpret_expr (gfc_get_int_type (kind),
 299                                                buffer, buffer_size));
 300   return size_integer (kind);
 301 }
 302
 303
 304 static int
 305 interpret_float (int kind, unsigned char *buffer, size_t buffer_size,
 306                  mpfr_t real)
 307 {
 308   mpfr_init (real);
 309   gfc_conv_tree_to_mpfr (real,
 310                          native_interpret_expr (gfc_get_real_type (kind),
 311                                                 buffer, buffer_size));
 312
 313   return size_float (kind);
 314 }
 315
 316
 317 static int
 318 interpret_complex (int kind, unsigned char *buffer, size_t buffer_size,
 319                    mpfr_t real, mpfr_t imaginary)
 320 {
 321   int size;
 322   size = interpret_float (kind, &buffer[0], buffer_size, real);
 323   size += interpret_float (kind, &buffer[size], buffer_size - size, imaginary);
 324   return size;
 325 }
 326
 327
 328 static int
 329 interpret_logical (int kind, unsigned char *buffer, size_t buffer_size,
 330                    int *logical)
 331 {
 332   tree t = native_interpret_expr (gfc_get_logical_type (kind), buffer,
 333                                   buffer_size);
 334   *logical = double_int_zero_p (tree_to_double_int (t))
 335              ? 0 : 1;
 336   return size_logical (kind);
 337 }
 338
 339
 340 static int
 341 interpret_character (unsigned char *buffer, size_t buffer_size, gfc_expr *result)
 342 {
 343   if (result->ts.cl && result->ts.cl->length)
 344     result->value.character.length =
 345       (int)mpz_get_ui (result->ts.cl->length->value.integer);
 346
 347   gcc_assert (buffer_size >= size_character (result->value.character.length));
 348   result->value.character.string =
 349     gfc_getmem (result->value.character.length + 1);
 350   memcpy (result->value.character.string, buffer,
 351           result->value.character.length);
 352   result->value.character.string [result->value.character.length] = '\0';
 353
 354   return result->value.character.length;
 355 }
 356
 357
 358 static int
 359 interpret_derived (unsigned char *buffer, size_t buffer_size, gfc_expr *result)
 360 {
 361   gfc_component *cmp;
 362   gfc_constructor *head = NULL, *tail = NULL;
 363   int ptr;
 364   tree type;
 365
 366   /* The attributes of the derived type need to be bolted to the floor.  */
 367   result->expr_type = EXPR_STRUCTURE;
 368
 369   type = gfc_typenode_for_spec (&result->ts);
 370   cmp = result->ts.derived->components;
 371
 372   /* Run through the derived type components.  */
 373   for (;cmp; cmp = cmp->next)
 374     {
 375       if (head == NULL)
 376         head = tail = gfc_get_constructor ();
 377       else
 378         {
 379           tail->next = gfc_get_constructor ();
 380           tail = tail->next;
 381         }
 382
 383       /* The constructor points to the component.  */
 384       tail->n.component = cmp;
 385
 386       tail->expr = gfc_constant_result (cmp->ts.type, cmp->ts.kind,
 387                                         &result->where);
 388       tail->expr->ts = cmp->ts;
 389
 390       /* Copy shape, if needed.  */
 391       if (cmp->as && cmp->as->rank)
 392         {
 393           int n;
 394
 395           tail->expr->expr_type = EXPR_ARRAY;
 396           tail->expr->rank = cmp->as->rank;
 397
 398           tail->expr->shape = gfc_get_shape (tail->expr->rank);
 399           for (n = 0; n < tail->expr->rank; n++)
 400              {
 401                mpz_init_set_ui (tail->expr->shape[n], 1);
 402                mpz_add (tail->expr->shape[n], tail->expr->shape[n],
 403                         cmp->as->upper[n]->value.integer);
 404                mpz_sub (tail->expr->shape[n], tail->expr->shape[n],
 405                         cmp->as->lower[n]->value.integer);
 406              }
 407         }
 408
 409       ptr = TREE_INT_CST_LOW (DECL_FIELD_OFFSET (cmp->backend_decl));
 410       gfc_target_interpret_expr (&buffer[ptr], buffer_size - ptr,
 411                                  tail->expr);
 412
 413       result->value.constructor = head;
 414     }
 415
 416   return int_size_in_bytes (type);
 417 }
 418
 419
 420 /* Read a binary buffer to a constant expression.  */
 421 int
 422 gfc_target_interpret_expr (unsigned char *buffer, size_t buffer_size,
 423                            gfc_expr *result)
 424 {
 425   if (result->expr_type == EXPR_ARRAY)
 426     return interpret_array (buffer, buffer_size, result);
 427
 428   switch (result->ts.type)
 429     {
 430     case BT_INTEGER:
 431       return interpret_integer (result->ts.kind, buffer, buffer_size,
 432                                 result->value.integer);
 433     case BT_REAL:
 434       return interpret_float (result->ts.kind, buffer, buffer_size,
 435                               result->value.real);
 436     case BT_COMPLEX:
 437       return interpret_complex (result->ts.kind, buffer, buffer_size,
 438                                 result->value.complex.r,
 439                                 result->value.complex.i);
 440     case BT_LOGICAL:
 441       return interpret_logical (result->ts.kind, buffer, buffer_size,
 442                                 &result->value.logical);
 443     case BT_CHARACTER:
 444       return interpret_character (buffer, buffer_size, result);
 445     case BT_DERIVED:
 446       return interpret_derived (buffer, buffer_size, result);
 447     default:
 448       gfc_internal_error ("Invalid expression in gfc_target_interpret_expr.");
 449     }
 450   return 0;
 451 }