/* 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 <canqun@nudt.edu.cn>
This file is part of GCC.
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.
#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"
-/* Holds a single variable in a equivalence set. */
+/* Holds a single variable in an equivalence set. */
typedef struct segment_info
{
gfc_symbol *sym;
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 *
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;
}
/* 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. */
/* 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;
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. */
common_sym->backend_decl = pushdecl_top_level (decl);
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;
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);
/* 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");
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;
}
}
- gcc_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))
- gcc_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);
/* 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;
}
}
}
}
-/* 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)
{
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;
+ }
}
}
}
}
-/* Given a seed symbol, create a new segment consisting of that symbol
- and all of the symbols equivalenced with that symbol. */
+/* 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;
+}
+
+
+/* Adjust segment offsets by the given amount. */
+
+static void
+apply_segment_offset (segment_info * s, HOST_WIDE_INT offset)
+{
+ for (; s; s = s->next)
+ s->offset += offset;
+}
+
+
+/* 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. */
+
+/* Translate a single common block. */
static void
-new_segment (gfc_common_head *common, gfc_symbol *sym)
+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);
+ }
- current_segment = get_segment_info (sym, current_offset);
+ /* Apply the offset to the new segments. */
+ apply_segment_offset (current_segment, offset);
+ current_offset += offset;
+ if (max_align < align)
+ max_align = align;
- /* The offset of the next common variable. */
- current_offset += current_segment->length;
+ /* Add the new segments to the common block. */
+ common_segment = add_segments (common_segment, current_segment);
+ }
- /* Add all object directly or indirectly equivalenced with this common
- variable. */
- add_equivalences ();
+ /* The offset of the next common variable. */
+ current_offset += s->length;
+ }
- 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);
+ 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);
+ }
- /* Add these to the common block. */
- current_common = add_segments (current_common, current_segment);
+ create_common (common, common_segment, saw_equiv);
}
{
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)
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);
}
OSDN Git Service
