X-Git-Url: http://git.sourceforge.jp/view?a=blobdiff_plain;f=gcc%2Ffortran%2Ftrans-common.c;h=5d72a5086bca633e756d6ff9950b2f4766b59669;hb=477c2f8751efea5fa8a283d3a0faec5115175282;hp=69cb1a3a20b04793beda7796f5240c1a444c51d7;hpb=ed52ef8b296ce70cca9044e0292e5ece9ea0ac7b;p=pf3gnuchains%2Fgcc-fork.git diff --git a/gcc/fortran/trans-common.c b/gcc/fortran/trans-common.c index 69cb1a3a20b..5d72a5086bc 100644 --- a/gcc/fortran/trans-common.c +++ b/gcc/fortran/trans-common.c @@ -1,5 +1,6 @@ /* Common block and equivalence list handling - Copyright (C) 2000, 2003, 2004 Free Software Foundation, Inc. + Copyright (C) 2000, 2003, 2004, 2005, 2006 + Free Software Foundation, Inc. Contributed by Canqun Yang This file is part of GCC. @@ -16,14 +17,14 @@ for more details. You should have received a copy of the GNU General Public License along with GCC; see the file COPYING. If not, write to the Free -Software Foundation, 59 Temple Place - Suite 330, Boston, MA -02111-1307, USA. */ +Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA +02110-1301, USA. */ /* The core algorithm is based on Andy Vaught's g95 tree. Also the way to build UNION_TYPE is borrowed from Richard Henderson. Transform common blocks. An integral part of this is processing - equvalence variables. Equivalenced variables that are not in a + equivalence variables. Equivalenced variables that are not in a common block end up in a private block of their own. Each common block or local equivalence list is declared as a union. @@ -96,17 +97,18 @@ Software Foundation, 59 Temple Place - Suite 330, Boston, MA #include "config.h" #include "system.h" #include "coretypes.h" +#include "target.h" #include "tree.h" #include "toplev.h" #include "tm.h" +#include "rtl.h" #include "gfortran.h" #include "trans.h" #include "trans-types.h" #include "trans-const.h" -#include -/* Holds a single variable in a equivalence set. */ +/* Holds a single variable in an equivalence set. */ typedef struct segment_info { gfc_symbol *sym; @@ -117,12 +119,9 @@ typedef struct segment_info struct segment_info *next; } segment_info; -static segment_info *current_segment, *current_common; -static HOST_WIDE_INT current_offset; +static segment_info * current_segment; static gfc_namespace *gfc_common_ns = NULL; -#define BLANK_COMMON_NAME "__BLNK__" - /* Make a segment_info based on a symbol. */ static segment_info * @@ -137,7 +136,7 @@ get_segment_info (gfc_symbol * sym, HOST_WIDE_INT offset) /* Create the segment_info and fill it in. */ s = (segment_info *) gfc_getmem (sizeof (segment_info)); s->sym = sym; - /* We will use this type when building the segment aggreagate type. */ + /* We will use this type when building the segment aggregate type. */ s->field = gfc_sym_type (sym); s->length = int_size_in_bytes (s->field); s->offset = offset; @@ -226,6 +225,7 @@ build_field (segment_info *h, tree union_type, record_layout_info rli) name = get_identifier (h->sym->name); field = build_decl (FIELD_DECL, name, h->field); + gfc_set_decl_location (field, &h->sym->declared_at); known_align = (offset & -offset) * BITS_PER_UNIT; if (known_align == 0 || known_align > BIGGEST_ALIGNMENT) known_align = BIGGEST_ALIGNMENT; @@ -243,6 +243,27 @@ build_field (segment_info *h, tree union_type, record_layout_info rli) size_binop (PLUS_EXPR, DECL_FIELD_OFFSET (field), DECL_SIZE_UNIT (field))); + /* If this field is assigned to a label, we create another two variables. + One will hold the address of target label or format label. The other will + hold the length of format label string. */ + if (h->sym->attr.assign) + { + tree len; + tree addr; + + gfc_allocate_lang_decl (field); + GFC_DECL_ASSIGN (field) = 1; + len = gfc_create_var_np (gfc_charlen_type_node,h->sym->name); + addr = gfc_create_var_np (pvoid_type_node, h->sym->name); + TREE_STATIC (len) = 1; + TREE_STATIC (addr) = 1; + DECL_INITIAL (len) = build_int_cst (NULL_TREE, -2); + gfc_set_decl_location (len, &h->sym->declared_at); + gfc_set_decl_location (addr, &h->sym->declared_at); + GFC_DECL_STRING_LEN (field) = pushdecl_top_level (len); + GFC_DECL_ASSIGN_ADDR (field) = pushdecl_top_level (addr); + } + h->field = field; } @@ -250,24 +271,37 @@ build_field (segment_info *h, tree union_type, record_layout_info rli) /* Get storage for local equivalence. */ static tree -build_equiv_decl (tree union_type, bool is_init) +build_equiv_decl (tree union_type, bool is_init, bool is_saved) { tree decl; + char name[15]; + static int serial = 0; if (is_init) { decl = gfc_create_var (union_type, "equiv"); TREE_STATIC (decl) = 1; + GFC_DECL_COMMON_OR_EQUIV (decl) = 1; return decl; } - decl = build_decl (VAR_DECL, NULL, union_type); + snprintf (name, sizeof (name), "equiv.%d", serial++); + decl = build_decl (VAR_DECL, get_identifier (name), union_type); DECL_ARTIFICIAL (decl) = 1; + DECL_IGNORED_P (decl) = 1; - DECL_COMMON (decl) = 1; + if (!gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl)) + || is_saved) + TREE_STATIC (decl) = 1; TREE_ADDRESSABLE (decl) = 1; TREE_USED (decl) = 1; + GFC_DECL_COMMON_OR_EQUIV (decl) = 1; + + /* The source location has been lost, and doesn't really matter. + We need to set it to something though. */ + gfc_set_decl_location (decl, &gfc_current_locus); + gfc_add_decl_to_function (decl); return decl; @@ -284,7 +318,7 @@ build_common_decl (gfc_common_head *com, tree union_type, bool is_init) /* Create a namespace to store symbols for common blocks. */ if (gfc_common_ns == NULL) - gfc_common_ns = gfc_get_namespace (NULL); + gfc_common_ns = gfc_get_namespace (NULL, 0); gfc_get_symbol (com->name, gfc_common_ns, &common_sym); decl = common_sym->backend_decl; @@ -320,6 +354,12 @@ build_common_decl (gfc_common_head *com, tree union_type, bool is_init) TREE_STATIC (decl) = 1; DECL_ALIGN (decl) = BIGGEST_ALIGNMENT; DECL_USER_ALIGN (decl) = 0; + GFC_DECL_COMMON_OR_EQUIV (decl) = 1; + + gfc_set_decl_location (decl, &com->where); + + if (com->threadprivate && targetm.have_tls) + DECL_TLS_MODEL (decl) = decl_default_tls_model (decl); /* Place the back end declaration for this common block in GLOBAL_BINDING_LEVEL. */ @@ -347,7 +387,7 @@ build_common_decl (gfc_common_head *com, tree union_type, bool is_init) backend declarations for all of the elements. */ static void -create_common (gfc_common_head *com) +create_common (gfc_common_head *com, segment_info * head, bool saw_equiv) { segment_info *s, *next_s; tree union_type; @@ -355,13 +395,22 @@ create_common (gfc_common_head *com) record_layout_info rli; tree decl; bool is_init = false; + bool is_saved = false; + + /* Declare the variables inside the common block. + If the current common block contains any equivalence object, then + make a UNION_TYPE node, otherwise RECORD_TYPE. This will let the + alias analyzer work well when there is no address overlapping for + common variables in the current common block. */ + if (saw_equiv) + union_type = make_node (UNION_TYPE); + else + union_type = make_node (RECORD_TYPE); - /* Declare the variables inside the common block. */ - union_type = make_node (UNION_TYPE); rli = start_record_layout (union_type); field_link = &TYPE_FIELDS (union_type); - for (s = current_common; s; s = s->next) + for (s = head; s; s = s->next) { build_field (s, union_type, rli); @@ -372,28 +421,32 @@ create_common (gfc_common_head *com) /* Has initial value. */ if (s->sym->value) is_init = true; + + /* Has SAVE attribute. */ + if (s->sym->attr.save) + is_saved = true; } finish_record_layout (rli, true); if (com) decl = build_common_decl (com, union_type, is_init); else - decl = build_equiv_decl (union_type, is_init); + decl = build_equiv_decl (union_type, is_init, is_saved); if (is_init) { - tree list, ctor, tmp; + tree ctor, tmp; HOST_WIDE_INT offset = 0; + VEC(constructor_elt,gc) *v = NULL; - list = NULL_TREE; - for (s = current_common; s; s = s->next) + for (s = head; s; s = s->next) { if (s->sym->value) { if (s->offset < offset) { /* We have overlapping initializers. It could either be - partially initilalized arrays (legal), or the user + partially initialized arrays (legal), or the user specified multiple initial values (illegal). We don't implement this yet, so bail out. */ gfc_todo_error ("Initialization of overlapping variables"); @@ -402,28 +455,64 @@ create_common (gfc_common_head *com) tmp = gfc_conv_initializer (s->sym->value, &s->sym->ts, TREE_TYPE (s->field), s->sym->attr.dimension, s->sym->attr.pointer || s->sym->attr.allocatable); - list = tree_cons (s->field, tmp, list); + + CONSTRUCTOR_APPEND_ELT (v, s->field, tmp); offset = s->offset + s->length; } } - assert (list); - ctor = build1 (CONSTRUCTOR, union_type, nreverse(list)); + gcc_assert (!VEC_empty (constructor_elt, v)); + ctor = build_constructor (union_type, v); TREE_CONSTANT (ctor) = 1; TREE_INVARIANT (ctor) = 1; TREE_STATIC (ctor) = 1; DECL_INITIAL (decl) = ctor; #ifdef ENABLE_CHECKING - for (tmp = CONSTRUCTOR_ELTS (ctor); tmp; tmp = TREE_CHAIN (tmp)) - assert (TREE_CODE (TREE_PURPOSE (tmp)) == FIELD_DECL); + { + tree field, value; + unsigned HOST_WIDE_INT idx; + FOR_EACH_CONSTRUCTOR_ELT (CONSTRUCTOR_ELTS (ctor), idx, field, value) + gcc_assert (TREE_CODE (field) == FIELD_DECL); + } #endif } /* Build component reference for each variable. */ - for (s = current_common; s; s = next_s) + for (s = head; s; s = next_s) { - s->sym->backend_decl = build3 (COMPONENT_REF, TREE_TYPE (s->field), - decl, s->field, NULL_TREE); + tree var_decl; + + var_decl = build_decl (VAR_DECL, DECL_NAME (s->field), + TREE_TYPE (s->field)); + gfc_set_decl_location (var_decl, &s->sym->declared_at); + TREE_PUBLIC (var_decl) = TREE_PUBLIC (decl); + TREE_STATIC (var_decl) = TREE_STATIC (decl); + TREE_USED (var_decl) = TREE_USED (decl); + if (s->sym->attr.target) + TREE_ADDRESSABLE (var_decl) = 1; + /* This is a fake variable just for debugging purposes. */ + TREE_ASM_WRITTEN (var_decl) = 1; + + if (com) + var_decl = pushdecl_top_level (var_decl); + else + gfc_add_decl_to_function (var_decl); + + SET_DECL_VALUE_EXPR (var_decl, + build3 (COMPONENT_REF, TREE_TYPE (s->field), + decl, s->field, NULL_TREE)); + DECL_HAS_VALUE_EXPR_P (var_decl) = 1; + GFC_DECL_COMMON_OR_EQUIV (var_decl) = 1; + + if (s->sym->attr.assign) + { + gfc_allocate_lang_decl (var_decl); + GFC_DECL_ASSIGN (var_decl) = 1; + GFC_DECL_STRING_LEN (var_decl) = GFC_DECL_STRING_LEN (s->field); + GFC_DECL_ASSIGN_ADDR (var_decl) = GFC_DECL_ASSIGN_ADDR (s->field); + } + + s->sym->backend_decl = var_decl; next_s = s->next; gfc_free (s); @@ -620,46 +709,45 @@ add_condition (segment_info *f, gfc_equiv *eq1, gfc_equiv *eq2) /* Given a segment element, search through the equivalence lists for unused - conditions that involve the symbol. Add these rules to the segment. Only - checks for rules involving the first symbol in the equivalence set. */ - + conditions that involve the symbol. Add these rules to the segment. */ + static bool find_equivalence (segment_info *n) { - gfc_equiv *e1, *e2, *eq, *other; + gfc_equiv *e1, *e2, *eq; bool found; - + found = FALSE; + for (e1 = n->sym->ns->equiv; e1; e1 = e1->next) { - other = NULL; - for (e2 = e1->eq; e2; e2 = e2->eq) - { - if (e2->used) - continue; + eq = NULL; - if (e1->expr->symtree->n.sym == n->sym) - { - eq = e1; - other = e2; - } - else if (e2->expr->symtree->n.sym == n->sym) + /* Search the equivalence list, including the root (first) element + for the symbol that owns the segment. */ + for (e2 = e1; e2; e2 = e2->eq) + { + if (!e2->used && e2->expr->symtree->n.sym == n->sym) { eq = e2; - other = e1; + break; } - else - eq = NULL; - - if (eq) + } + + /* Go to the next root element. */ + if (eq == NULL) + continue; + + eq->used = 1; + + /* Now traverse the equivalence list matching the offsets. */ + for (e2 = e1; e2; e2 = e2->eq) + { + if (!e2->used && e2 != eq) { - add_condition (n, eq, other); - eq->used = 1; + add_condition (n, eq, e2); + e2->used = 1; found = TRUE; - /* If this symbol is the first in the chain we may find other - matches. Otherwise we can skip to the next equivalence. */ - if (eq == e2) - break; } } } @@ -667,15 +755,20 @@ find_equivalence (segment_info *n) } -/* Add all symbols equivalenced within a segment. We need to scan the - segment list multiple times to include indirect equivalences. */ + /* Add all symbols equivalenced within a segment. We need to scan the + segment list multiple times to include indirect equivalences. Since + a new segment_info can inserted at the beginning of the segment list, + depending on its offset, we have to force a final pass through the + loop by demanding that completion sees a pass with no matches; ie. + all symbols with equiv_built set and no new equivalences found. */ static void -add_equivalences (void) +add_equivalences (bool *saw_equiv) { segment_info *f; - bool more; + bool seen_one, more; + seen_one = false; more = TRUE; while (more) { @@ -685,36 +778,164 @@ add_equivalences (void) if (!f->sym->equiv_built) { f->sym->equiv_built = 1; - more = find_equivalence (f); + seen_one = find_equivalence (f); + if (seen_one) + { + *saw_equiv = true; + more = true; + } + } + } + } +} + + +/* Returns the offset necessary to properly align the current equivalence. + Sets *palign to the required alignment. */ + +static HOST_WIDE_INT +align_segment (unsigned HOST_WIDE_INT * palign) +{ + segment_info *s; + unsigned HOST_WIDE_INT offset; + unsigned HOST_WIDE_INT max_align; + unsigned HOST_WIDE_INT this_align; + unsigned HOST_WIDE_INT this_offset; + + max_align = 1; + offset = 0; + for (s = current_segment; s; s = s->next) + { + this_align = TYPE_ALIGN_UNIT (s->field); + if (s->offset & (this_align - 1)) + { + /* Field is misaligned. */ + this_offset = this_align - ((s->offset + offset) & (this_align - 1)); + if (this_offset & (max_align - 1)) + { + /* Aligning this field would misalign a previous field. */ + gfc_error ("The equivalence set for variable '%s' " + "declared at %L violates alignment requirents", + s->sym->name, &s->sym->declared_at); } + offset += this_offset; } + max_align = this_align; } + if (palign) + *palign = max_align; + return offset; } -/* Given a seed symbol, create a new segment consisting of that symbol - and all of the symbols equivalenced with that symbol. */ +/* Adjust segment offsets by the given amount. */ static void -new_segment (gfc_common_head *common, gfc_symbol *sym) +apply_segment_offset (segment_info * s, HOST_WIDE_INT offset) { + for (; s; s = s->next) + s->offset += offset; +} - current_segment = get_segment_info (sym, current_offset); - /* The offset of the next common variable. */ - current_offset += current_segment->length; +/* Lay out a symbol in a common block. If the symbol has already been seen + then check the location is consistent. Otherwise create segments + for that symbol and all the symbols equivalenced with it. */ - /* Add all object directly or indirectly equivalenced with this common - variable. */ - add_equivalences (); +/* Translate a single common block. */ - if (current_segment->offset < 0) - gfc_error ("The equivalence set for '%s' cause an invalid " - "extension to COMMON '%s' at %L", sym->name, - common->name, &common->where); +static void +translate_common (gfc_common_head *common, gfc_symbol *var_list) +{ + gfc_symbol *sym; + segment_info *s; + segment_info *common_segment; + HOST_WIDE_INT offset; + HOST_WIDE_INT current_offset; + unsigned HOST_WIDE_INT align; + unsigned HOST_WIDE_INT max_align; + bool saw_equiv; + + common_segment = NULL; + current_offset = 0; + max_align = 1; + saw_equiv = false; + + /* Add symbols to the segment. */ + for (sym = var_list; sym; sym = sym->common_next) + { + current_segment = common_segment; + s = find_segment_info (sym); + + /* Symbol has already been added via an equivalence. Multiple + use associations of the same common block result in equiv_built + being set but no information about the symbol in the segment. */ + if (s && sym->equiv_built) + { + /* Ensure the current location is properly aligned. */ + align = TYPE_ALIGN_UNIT (s->field); + current_offset = (current_offset + align - 1) &~ (align - 1); + + /* Verify that it ended up where we expect it. */ + if (s->offset != current_offset) + { + gfc_error ("Equivalence for '%s' does not match ordering of " + "COMMON '%s' at %L", sym->name, + common->name, &common->where); + } + } + else + { + /* A symbol we haven't seen before. */ + s = current_segment = get_segment_info (sym, current_offset); + + /* Add all objects directly or indirectly equivalenced with this + symbol. */ + add_equivalences (&saw_equiv); + + if (current_segment->offset < 0) + gfc_error ("The equivalence set for '%s' cause an invalid " + "extension to COMMON '%s' at %L", sym->name, + common->name, &common->where); + + offset = align_segment (&align); + + if (offset & (max_align - 1)) + { + /* The required offset conflicts with previous alignment + requirements. Insert padding immediately before this + segment. */ + gfc_warning ("Padding of %d bytes required before '%s' in " + "COMMON '%s' at %L", (int)offset, s->sym->name, + common->name, &common->where); + } + else + { + /* Offset the whole common block. */ + apply_segment_offset (common_segment, offset); + } + + /* Apply the offset to the new segments. */ + apply_segment_offset (current_segment, offset); + current_offset += offset; + if (max_align < align) + max_align = align; + + /* Add the new segments to the common block. */ + common_segment = add_segments (common_segment, current_segment); + } - /* Add these to the common block. */ - current_common = add_segments (current_common, current_segment); + /* The offset of the next common variable. */ + current_offset += s->length; + } + + if (common_segment->offset != 0) + { + gfc_warning ("COMMON '%s' at %L requires %d bytes of padding at start", + common->name, &common->where, (int)common_segment->offset); + } + + create_common (common, common_segment, saw_equiv); } @@ -725,8 +946,10 @@ finish_equivalences (gfc_namespace *ns) { gfc_equiv *z, *y; gfc_symbol *sym; - segment_info *v; - HOST_WIDE_INT min_offset; + gfc_common_head * c; + HOST_WIDE_INT offset; + unsigned HOST_WIDE_INT align; + bool dummy; for (z = ns->equiv; z; z = z->next) for (y = z->eq; y; y = y->eq) @@ -736,50 +959,44 @@ finish_equivalences (gfc_namespace *ns) sym = z->expr->symtree->n.sym; current_segment = get_segment_info (sym, 0); - /* All objects directly or indrectly equivalenced with this symbol. */ - add_equivalences (); - - /* Calculate the minimal offset. */ - min_offset = current_segment->offset; - - /* Adjust the offset of each equivalence object. */ - for (v = current_segment; v; v = v->next) - v->offset -= min_offset; - - current_common = current_segment; - create_common (NULL); + /* All objects directly or indirectly equivalenced with this symbol. */ + add_equivalences (&dummy); + + /* Align the block. */ + offset = align_segment (&align); + + /* Ensure all offsets are positive. */ + offset -= current_segment->offset & ~(align - 1); + + apply_segment_offset (current_segment, offset); + + /* Create the decl. If this is a module equivalence, it has a unique + name, pointed to by z->module. This is written to a gfc_common_header + to push create_common into using build_common_decl, so that the + equivalence appears as an external symbol. Otherwise, a local + declaration is built using build_equiv_decl.*/ + if (z->module) + { + c = gfc_get_common_head (); + /* We've lost the real location, so use the location of the + enclosing procedure. */ + c->where = ns->proc_name->declared_at; + strcpy (c->name, z->module); + } + else + c = NULL; + + create_common (c, current_segment, true); break; } } -/* Translate a single common block. */ - -static void -translate_common (gfc_common_head *common, gfc_symbol *var_list) -{ - gfc_symbol *sym; - - current_common = NULL; - current_offset = 0; - - /* Add symbols to the segment. */ - for (sym = var_list; sym; sym = sym->common_next) - { - if (! sym->equiv_built) - new_segment (common, sym); - } - - create_common (common); -} - - /* Work function for translating a named common block. */ static void named_common (gfc_symtree *st) { - translate_common (st->n.common, st->n.common->head); } @@ -797,6 +1014,9 @@ gfc_trans_common (gfc_namespace *ns) if (ns->blank_common.head != NULL) { c = gfc_get_common_head (); + /* We've lost the real location, so use the location of the + enclosing procedure. */ + c->where = ns->proc_name->declared_at; strcpy (c->name, BLANK_COMMON_NAME); translate_common (c, ns->blank_common.head); }