diff options
author | upstream source tree <ports@midipix.org> | 2015-03-15 20:14:05 -0400 |
---|---|---|
committer | upstream source tree <ports@midipix.org> | 2015-03-15 20:14:05 -0400 |
commit | 554fd8c5195424bdbcabf5de30fdc183aba391bd (patch) | |
tree | 976dc5ab7fddf506dadce60ae936f43f58787092 /gcc/fortran/target-memory.c | |
download | cbb-gcc-4.6.4-15d2061ac0796199866debe9ac87130894b0cdd3.tar.bz2 cbb-gcc-4.6.4-15d2061ac0796199866debe9ac87130894b0cdd3.tar.xz |
obtained gcc-4.6.4.tar.bz2 from upstream website;upstream
verified gcc-4.6.4.tar.bz2.sig;
imported gcc-4.6.4 source tree from verified upstream tarball.
downloading a git-generated archive based on the 'upstream' tag
should provide you with a source tree that is binary identical
to the one extracted from the above tarball.
if you have obtained the source via the command 'git clone',
however, do note that line-endings of files in your working
directory might differ from line-endings of the respective
files in the upstream repository.
Diffstat (limited to 'gcc/fortran/target-memory.c')
-rw-r--r-- | gcc/fortran/target-memory.c | 752 |
1 files changed, 752 insertions, 0 deletions
diff --git a/gcc/fortran/target-memory.c b/gcc/fortran/target-memory.c new file mode 100644 index 000000000..0a09f5a5e --- /dev/null +++ b/gcc/fortran/target-memory.c @@ -0,0 +1,752 @@ +/* Simulate storage of variables into target memory. + Copyright (C) 2007, 2008, 2009, 2010 + Free Software Foundation, Inc. + Contributed by Paul Thomas and Brooks Moses + +This file is part of GCC. + +GCC is free software; you can redistribute it and/or modify it under +the terms of the GNU General Public License as published by the Free +Software Foundation; either version 3, or (at your option) any later +version. + +GCC is distributed in the hope that it will be useful, but WITHOUT ANY +WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with GCC; see the file COPYING3. If not see +<http://www.gnu.org/licenses/>. */ + +#include "config.h" +#include "system.h" +#include "flags.h" +#include "machmode.h" +#include "tree.h" +#include "gfortran.h" +#include "arith.h" +#include "constructor.h" +#include "trans.h" +#include "trans-const.h" +#include "trans-types.h" +#include "target-memory.h" + +/* --------------------------------------------------------------- */ +/* Calculate the size of an expression. */ + +static size_t +size_array (gfc_expr *e) +{ + mpz_t array_size; + gfc_constructor *c = gfc_constructor_first (e->value.constructor); + size_t elt_size = gfc_target_expr_size (c->expr); + + gfc_array_size (e, &array_size); + return (size_t)mpz_get_ui (array_size) * elt_size; +} + +static size_t +size_integer (int kind) +{ + return GET_MODE_SIZE (TYPE_MODE (gfc_get_int_type (kind)));; +} + + +static size_t +size_float (int kind) +{ + return GET_MODE_SIZE (TYPE_MODE (gfc_get_real_type (kind)));; +} + + +static size_t +size_complex (int kind) +{ + return 2 * size_float (kind); +} + + +static size_t +size_logical (int kind) +{ + return GET_MODE_SIZE (TYPE_MODE (gfc_get_logical_type (kind)));; +} + + +static size_t +size_character (int length, int kind) +{ + int i = gfc_validate_kind (BT_CHARACTER, kind, false); + return length * gfc_character_kinds[i].bit_size / 8; +} + + +size_t +gfc_target_expr_size (gfc_expr *e) +{ + tree type; + + gcc_assert (e != NULL); + + if (e->expr_type == EXPR_ARRAY) + return size_array (e); + + switch (e->ts.type) + { + case BT_INTEGER: + return size_integer (e->ts.kind); + case BT_REAL: + return size_float (e->ts.kind); + case BT_COMPLEX: + return size_complex (e->ts.kind); + case BT_LOGICAL: + return size_logical (e->ts.kind); + case BT_CHARACTER: + if (e->expr_type == EXPR_SUBSTRING && e->ref) + { + int start, end; + + gfc_extract_int (e->ref->u.ss.start, &start); + gfc_extract_int (e->ref->u.ss.end, &end); + return size_character (MAX(end - start + 1, 0), e->ts.kind); + } + else + return size_character (e->value.character.length, e->ts.kind); + case BT_HOLLERITH: + return e->representation.length; + case BT_DERIVED: + type = gfc_typenode_for_spec (&e->ts); + return int_size_in_bytes (type); + default: + gfc_internal_error ("Invalid expression in gfc_target_expr_size."); + return 0; + } +} + + +/* The encode_* functions export a value into a buffer, and + return the number of bytes of the buffer that have been + used. */ + +static int +encode_array (gfc_expr *expr, unsigned char *buffer, size_t buffer_size) +{ + mpz_t array_size; + int i; + int ptr = 0; + + gfc_constructor_base ctor = expr->value.constructor; + + gfc_array_size (expr, &array_size); + for (i = 0; i < (int)mpz_get_ui (array_size); i++) + { + ptr += gfc_target_encode_expr (gfc_constructor_lookup_expr (ctor, i), + &buffer[ptr], buffer_size - ptr); + } + + mpz_clear (array_size); + return ptr; +} + + +static int +encode_integer (int kind, mpz_t integer, unsigned char *buffer, + size_t buffer_size) +{ + return native_encode_expr (gfc_conv_mpz_to_tree (integer, kind), + buffer, buffer_size); +} + + +static int +encode_float (int kind, mpfr_t real, unsigned char *buffer, size_t buffer_size) +{ + return native_encode_expr (gfc_conv_mpfr_to_tree (real, kind, 0), buffer, + buffer_size); +} + + +static int +encode_complex (int kind, mpc_t cmplx, + unsigned char *buffer, size_t buffer_size) +{ + int size; + size = encode_float (kind, mpc_realref (cmplx), &buffer[0], buffer_size); + size += encode_float (kind, mpc_imagref (cmplx), + &buffer[size], buffer_size - size); + return size; +} + + +static int +encode_logical (int kind, int logical, unsigned char *buffer, size_t buffer_size) +{ + return native_encode_expr (build_int_cst (gfc_get_logical_type (kind), + logical), + buffer, buffer_size); +} + + +int +gfc_encode_character (int kind, int length, const gfc_char_t *string, + unsigned char *buffer, size_t buffer_size) +{ + size_t elsize = size_character (1, kind); + tree type = gfc_get_char_type (kind); + int i; + + gcc_assert (buffer_size >= size_character (length, kind)); + + for (i = 0; i < length; i++) + native_encode_expr (build_int_cst (type, string[i]), &buffer[i*elsize], + elsize); + + return length; +} + + +static int +encode_derived (gfc_expr *source, unsigned char *buffer, size_t buffer_size) +{ + gfc_constructor *c; + gfc_component *cmp; + int ptr; + tree type; + + type = gfc_typenode_for_spec (&source->ts); + + for (c = gfc_constructor_first (source->value.constructor), + cmp = source->ts.u.derived->components; + c; + c = gfc_constructor_next (c), cmp = cmp->next) + { + gcc_assert (cmp); + if (!c->expr) + continue; + ptr = TREE_INT_CST_LOW(DECL_FIELD_OFFSET(cmp->backend_decl)) + + TREE_INT_CST_LOW(DECL_FIELD_BIT_OFFSET(cmp->backend_decl))/8; + + if (c->expr->expr_type == EXPR_NULL) + memset (&buffer[ptr], 0, + int_size_in_bytes (TREE_TYPE (cmp->backend_decl))); + else + gfc_target_encode_expr (c->expr, &buffer[ptr], + buffer_size - ptr); + } + + return int_size_in_bytes (type); +} + + +/* Write a constant expression in binary form to a buffer. */ +int +gfc_target_encode_expr (gfc_expr *source, unsigned char *buffer, + size_t buffer_size) +{ + if (source == NULL) + return 0; + + if (source->expr_type == EXPR_ARRAY) + return encode_array (source, buffer, buffer_size); + + gcc_assert (source->expr_type == EXPR_CONSTANT + || source->expr_type == EXPR_STRUCTURE + || source->expr_type == EXPR_SUBSTRING); + + /* If we already have a target-memory representation, we use that rather + than recreating one. */ + if (source->representation.string) + { + memcpy (buffer, source->representation.string, + source->representation.length); + return source->representation.length; + } + + switch (source->ts.type) + { + case BT_INTEGER: + return encode_integer (source->ts.kind, source->value.integer, buffer, + buffer_size); + case BT_REAL: + return encode_float (source->ts.kind, source->value.real, buffer, + buffer_size); + case BT_COMPLEX: + return encode_complex (source->ts.kind, source->value.complex, + buffer, buffer_size); + case BT_LOGICAL: + return encode_logical (source->ts.kind, source->value.logical, buffer, + buffer_size); + case BT_CHARACTER: + if (source->expr_type == EXPR_CONSTANT || source->ref == NULL) + return gfc_encode_character (source->ts.kind, + source->value.character.length, + source->value.character.string, + buffer, buffer_size); + else + { + int start, end; + + gcc_assert (source->expr_type == EXPR_SUBSTRING); + gfc_extract_int (source->ref->u.ss.start, &start); + gfc_extract_int (source->ref->u.ss.end, &end); + return gfc_encode_character (source->ts.kind, MAX(end - start + 1, 0), + &source->value.character.string[start-1], + buffer, buffer_size); + } + + case BT_DERIVED: + return encode_derived (source, buffer, buffer_size); + default: + gfc_internal_error ("Invalid expression in gfc_target_encode_expr."); + return 0; + } +} + + +static int +interpret_array (unsigned char *buffer, size_t buffer_size, gfc_expr *result) +{ + gfc_constructor_base base = NULL; + int array_size = 1; + int i; + int ptr = 0; + + /* Calculate array size from its shape and rank. */ + gcc_assert (result->rank > 0 && result->shape); + + for (i = 0; i < result->rank; i++) + array_size *= (int)mpz_get_ui (result->shape[i]); + + /* Iterate over array elements, producing constructors. */ + for (i = 0; i < array_size; i++) + { + gfc_expr *e = gfc_get_constant_expr (result->ts.type, result->ts.kind, + &result->where); + e->ts = result->ts; + + if (e->ts.type == BT_CHARACTER) + e->value.character.length = result->value.character.length; + + gfc_constructor_append_expr (&base, e, &result->where); + + ptr += gfc_target_interpret_expr (&buffer[ptr], buffer_size - ptr, e); + } + + result->value.constructor = base; + return ptr; +} + + +int +gfc_interpret_integer (int kind, unsigned char *buffer, size_t buffer_size, + mpz_t integer) +{ + mpz_init (integer); + gfc_conv_tree_to_mpz (integer, + native_interpret_expr (gfc_get_int_type (kind), + buffer, buffer_size)); + return size_integer (kind); +} + + +int +gfc_interpret_float (int kind, unsigned char *buffer, size_t buffer_size, + mpfr_t real) +{ + gfc_set_model_kind (kind); + mpfr_init (real); + gfc_conv_tree_to_mpfr (real, + native_interpret_expr (gfc_get_real_type (kind), + buffer, buffer_size)); + + return size_float (kind); +} + + +int +gfc_interpret_complex (int kind, unsigned char *buffer, size_t buffer_size, + mpc_t complex) +{ + int size; + size = gfc_interpret_float (kind, &buffer[0], buffer_size, + mpc_realref (complex)); + size += gfc_interpret_float (kind, &buffer[size], buffer_size - size, + mpc_imagref (complex)); + return size; +} + + +int +gfc_interpret_logical (int kind, unsigned char *buffer, size_t buffer_size, + int *logical) +{ + tree t = native_interpret_expr (gfc_get_logical_type (kind), buffer, + buffer_size); + *logical = double_int_zero_p (tree_to_double_int (t)) + ? 0 : 1; + return size_logical (kind); +} + + +int +gfc_interpret_character (unsigned char *buffer, size_t buffer_size, + gfc_expr *result) +{ + int i; + + if (result->ts.u.cl && result->ts.u.cl->length) + result->value.character.length = + (int) mpz_get_ui (result->ts.u.cl->length->value.integer); + + gcc_assert (buffer_size >= size_character (result->value.character.length, + result->ts.kind)); + result->value.character.string = + gfc_get_wide_string (result->value.character.length + 1); + + if (result->ts.kind == gfc_default_character_kind) + for (i = 0; i < result->value.character.length; i++) + result->value.character.string[i] = (gfc_char_t) buffer[i]; + else + { + mpz_t integer; + unsigned bytes = size_character (1, result->ts.kind); + mpz_init (integer); + gcc_assert (bytes <= sizeof (unsigned long)); + + for (i = 0; i < result->value.character.length; i++) + { + gfc_conv_tree_to_mpz (integer, + native_interpret_expr (gfc_get_char_type (result->ts.kind), + &buffer[bytes*i], buffer_size-bytes*i)); + result->value.character.string[i] + = (gfc_char_t) mpz_get_ui (integer); + } + + mpz_clear (integer); + } + + result->value.character.string[result->value.character.length] = '\0'; + + return result->value.character.length; +} + + +int +gfc_interpret_derived (unsigned char *buffer, size_t buffer_size, gfc_expr *result) +{ + gfc_component *cmp; + int ptr; + tree type; + + /* The attributes of the derived type need to be bolted to the floor. */ + result->expr_type = EXPR_STRUCTURE; + + cmp = result->ts.u.derived->components; + + if (result->ts.u.derived->from_intmod == INTMOD_ISO_C_BINDING + && (result->ts.u.derived->intmod_sym_id == ISOCBINDING_PTR + || result->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR)) + { + gfc_constructor *c; + gfc_expr *e; + /* Needed as gfc_typenode_for_spec as gfc_typenode_for_spec + sets this to BT_INTEGER. */ + result->ts.type = BT_DERIVED; + e = gfc_get_constant_expr (cmp->ts.type, cmp->ts.kind, &result->where); + c = gfc_constructor_append_expr (&result->value.constructor, e, NULL); + c->n.component = cmp; + gfc_target_interpret_expr (buffer, buffer_size, e); + e->ts.is_iso_c = 1; + return int_size_in_bytes (ptr_type_node); + } + + type = gfc_typenode_for_spec (&result->ts); + + /* Run through the derived type components. */ + for (;cmp; cmp = cmp->next) + { + gfc_constructor *c; + gfc_expr *e = gfc_get_constant_expr (cmp->ts.type, cmp->ts.kind, + &result->where); + e->ts = cmp->ts; + + /* Copy shape, if needed. */ + if (cmp->as && cmp->as->rank) + { + int n; + + e->expr_type = EXPR_ARRAY; + e->rank = cmp->as->rank; + + e->shape = gfc_get_shape (e->rank); + for (n = 0; n < e->rank; n++) + { + mpz_init_set_ui (e->shape[n], 1); + mpz_add (e->shape[n], e->shape[n], + cmp->as->upper[n]->value.integer); + mpz_sub (e->shape[n], e->shape[n], + cmp->as->lower[n]->value.integer); + } + } + + c = gfc_constructor_append_expr (&result->value.constructor, e, NULL); + + /* The constructor points to the component. */ + c->n.component = cmp; + + /* Calculate the offset, which consists of the the FIELD_OFFSET in + bytes, which appears in multiples of DECL_OFFSET_ALIGN-bit-sized, + and additional bits of FIELD_BIT_OFFSET. The code assumes that all + sizes of the components are multiples of BITS_PER_UNIT, + i.e. there are, e.g., no bit fields. */ + + gcc_assert (cmp->backend_decl); + ptr = TREE_INT_CST_LOW (DECL_FIELD_BIT_OFFSET (cmp->backend_decl)); + gcc_assert (ptr % 8 == 0); + ptr = ptr/8 + TREE_INT_CST_LOW (DECL_FIELD_OFFSET (cmp->backend_decl)); + + gfc_target_interpret_expr (&buffer[ptr], buffer_size - ptr, e); + } + + return int_size_in_bytes (type); +} + + +/* Read a binary buffer to a constant expression. */ +int +gfc_target_interpret_expr (unsigned char *buffer, size_t buffer_size, + gfc_expr *result) +{ + if (result->expr_type == EXPR_ARRAY) + return interpret_array (buffer, buffer_size, result); + + switch (result->ts.type) + { + case BT_INTEGER: + result->representation.length = + gfc_interpret_integer (result->ts.kind, buffer, buffer_size, + result->value.integer); + break; + + case BT_REAL: + result->representation.length = + gfc_interpret_float (result->ts.kind, buffer, buffer_size, + result->value.real); + break; + + case BT_COMPLEX: + result->representation.length = + gfc_interpret_complex (result->ts.kind, buffer, buffer_size, + result->value.complex); + break; + + case BT_LOGICAL: + result->representation.length = + gfc_interpret_logical (result->ts.kind, buffer, buffer_size, + &result->value.logical); + break; + + case BT_CHARACTER: + result->representation.length = + gfc_interpret_character (buffer, buffer_size, result); + break; + + case BT_DERIVED: + result->representation.length = + gfc_interpret_derived (buffer, buffer_size, result); + break; + + default: + gfc_internal_error ("Invalid expression in gfc_target_interpret_expr."); + break; + } + + if (result->ts.type == BT_CHARACTER) + result->representation.string + = gfc_widechar_to_char (result->value.character.string, + result->value.character.length); + else + { + result->representation.string = + (char *) gfc_getmem (result->representation.length + 1); + memcpy (result->representation.string, buffer, + result->representation.length); + result->representation.string[result->representation.length] = '\0'; + } + + return result->representation.length; +} + + +/* --------------------------------------------------------------- */ +/* Two functions used by trans-common.c to write overlapping + equivalence initializers to a buffer. This is added to the union + and the original initializers freed. */ + + +/* Writes the values of a constant expression to a char buffer. If another + unequal initializer has already been written to the buffer, this is an + error. */ + +static size_t +expr_to_char (gfc_expr *e, unsigned char *data, unsigned char *chk, size_t len) +{ + int i; + int ptr; + gfc_constructor *c; + gfc_component *cmp; + unsigned char *buffer; + + if (e == NULL) + return 0; + + /* Take a derived type, one component at a time, using the offsets from the backend + declaration. */ + if (e->ts.type == BT_DERIVED) + { + for (c = gfc_constructor_first (e->value.constructor), + cmp = e->ts.u.derived->components; + c; c = gfc_constructor_next (c), cmp = cmp->next) + { + gcc_assert (cmp && cmp->backend_decl); + if (!c->expr) + continue; + ptr = TREE_INT_CST_LOW(DECL_FIELD_OFFSET(cmp->backend_decl)) + + TREE_INT_CST_LOW(DECL_FIELD_BIT_OFFSET(cmp->backend_decl))/8; + expr_to_char (c->expr, &data[ptr], &chk[ptr], len); + } + return len; + } + + /* Otherwise, use the target-memory machinery to write a bitwise image, appropriate + to the target, in a buffer and check off the initialized part of the buffer. */ + len = gfc_target_expr_size (e); + buffer = (unsigned char*)alloca (len); + len = gfc_target_encode_expr (e, buffer, len); + + for (i = 0; i < (int)len; i++) + { + if (chk[i] && (buffer[i] != data[i])) + { + gfc_error ("Overlapping unequal initializers in EQUIVALENCE " + "at %L", &e->where); + return 0; + } + chk[i] = 0xFF; + } + + memcpy (data, buffer, len); + return len; +} + + +/* Writes the values from the equivalence initializers to a char* array + that will be written to the constructor to make the initializer for + the union declaration. */ + +size_t +gfc_merge_initializers (gfc_typespec ts, gfc_expr *e, unsigned char *data, + unsigned char *chk, size_t length) +{ + size_t len = 0; + gfc_constructor * c; + + switch (e->expr_type) + { + case EXPR_CONSTANT: + case EXPR_STRUCTURE: + len = expr_to_char (e, &data[0], &chk[0], length); + + break; + + case EXPR_ARRAY: + for (c = gfc_constructor_first (e->value.constructor); + c; c = gfc_constructor_next (c)) + { + size_t elt_size = gfc_target_expr_size (c->expr); + + if (c->offset) + len = elt_size * (size_t)mpz_get_si (c->offset); + + len = len + gfc_merge_initializers (ts, c->expr, &data[len], + &chk[len], length - len); + } + break; + + default: + return 0; + } + + return len; +} + + +/* Transfer the bitpattern of a (integer) BOZ to real or complex variables. + When successful, no BOZ or nothing to do, true is returned. */ + +bool +gfc_convert_boz (gfc_expr *expr, gfc_typespec *ts) +{ + size_t buffer_size, boz_bit_size, ts_bit_size; + int index; + unsigned char *buffer; + + if (!expr->is_boz) + return true; + + gcc_assert (expr->expr_type == EXPR_CONSTANT + && expr->ts.type == BT_INTEGER); + + /* Don't convert BOZ to logical, character, derived etc. */ + if (ts->type == BT_REAL) + { + buffer_size = size_float (ts->kind); + ts_bit_size = buffer_size * 8; + } + else if (ts->type == BT_COMPLEX) + { + buffer_size = size_complex (ts->kind); + ts_bit_size = buffer_size * 8 / 2; + } + else + return true; + + /* Convert BOZ to the smallest possible integer kind. */ + boz_bit_size = mpz_sizeinbase (expr->value.integer, 2); + + if (boz_bit_size > ts_bit_size) + { + gfc_error_now ("BOZ constant at %L is too large (%ld vs %ld bits)", + &expr->where, (long) boz_bit_size, (long) ts_bit_size); + return false; + } + + for (index = 0; gfc_integer_kinds[index].kind != 0; ++index) + if ((unsigned) gfc_integer_kinds[index].bit_size >= ts_bit_size) + break; + + expr->ts.kind = gfc_integer_kinds[index].kind; + buffer_size = MAX (buffer_size, size_integer (expr->ts.kind)); + + buffer = (unsigned char*)alloca (buffer_size); + encode_integer (expr->ts.kind, expr->value.integer, buffer, buffer_size); + mpz_clear (expr->value.integer); + + if (ts->type == BT_REAL) + { + mpfr_init (expr->value.real); + gfc_interpret_float (ts->kind, buffer, buffer_size, expr->value.real); + } + else + { + mpc_init2 (expr->value.complex, mpfr_get_default_prec()); + gfc_interpret_complex (ts->kind, buffer, buffer_size, + expr->value.complex); + } + expr->is_boz = 0; + expr->ts.type = ts->type; + expr->ts.kind = ts->kind; + + return true; +} |