1 /* Common block and equivalence list handling
2 Copyright (C) 2000-2003 Free Software Foundation, Inc.
3 Contributed by Canqun Yang <canqun@nudt.edu.cn>
5 This file is part of GNU G95.
7 G95 is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 2, or (at your option)
12 G95 is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 You should have received a copy of the GNU General Public License
18 along with G95; see the file COPYING. If not, write to
19 the Free Software Foundation, 59 Temple Place - Suite 330,
20 Boston, MA 02111-1307, USA. */
22 /* The core algorithm is based on Andy Vaught's g95 tree. Also the
23 way to build UNION_TYPE is borrowed from Richard Henderson.
25 Transform common blocks. An integral part of this is processing
26 equvalence variables. Equivalenced variables that are not in a
27 common block end up in a private block of their own.
29 Each common block or local equivalence list is declared as a union.
30 Variables within the block are represented as a field within the
31 block with the proper offset.
33 So if two variables are equivalenced, they just point to a common
36 Mathematically, laying out an equivalence block is equivalent to
37 solving a linear system of equations. The matrix is usually a
38 sparse matrix in which each row contains all zero elements except
39 for a +1 and a -1, a sort of a generalized Vandermonde matrix. The
40 matrix is usually block diagonal. The system can be
41 overdetermined, underdetermined or have a unique solution. If the
42 system is inconsistent, the program is not standard conforming.
43 The solution vector is integral, since all of the pivots are +1 or -1.
45 How we lay out an equivalence block is a little less complicated.
46 In an equivalence list with n elements, there are n-1 conditions to
47 be satisfied. The conditions partition the variables into what we
48 will call segments. If A and B are equivalenced then A and B are
49 in the same segment. If B and C are equivalenced as well, then A,
50 B and C are in a segment and so on. Each segment is a block of
51 memory that has one or more variables equivalenced in some way. A
52 common block is made up of a series of segments that are joined one
53 after the other. In the linear system, a segment is a block
56 To lay out a segment we first start with some variable and
57 determine its length. The first variable is assumed to start at
58 offset one and extends to however long it is. We then traverse the
59 list of equivalences to find an unused condition that involves at
60 least one of the variables currently in the segment.
62 Each equivalence condition amounts to the condition B+b=C+c where B
63 and C are the offsets of the B and C variables, and b and c are
64 constants which are nonzero for array elements, substrings or
65 structure components. So for
67 EQUIVALENCE(B(2), C(3))
69 B + 2*size of B's elements = C + 3*size of C's elements.
71 If B and C are known we check to see if the condition already
72 holds. If B is known we can solve for C. Since we know the length
73 of C, we can see if the minimum and maximum extents of the segment
74 are affected. Eventually, we make a full pass through the
75 equivalence list without finding any new conditions and the segment
78 At this point, the segment is added to the current common block.
79 Since we know the minimum extent of the segment, everything in the
80 segment is translated to its position in the common block. The
81 usual case here is that there are no equivalence statements and the
82 common block is series of segments with one variable each, which is
83 a diagonal matrix in the matrix formulation.
85 Once all common blocks have been created, the list of equivalences
86 is examined for still-unused equivalence conditions. We create a
87 block for each merged equivalence list. */
91 #include "coretypes.h"
97 #include "trans-types.h"
98 #include "trans-const.h"
101 typedef struct segment_info
107 struct segment_info *next;
110 static segment_info *current_segment, *current_common;
111 static int current_length, current_offset;
112 static gfc_namespace *gfc_common_ns = NULL;
114 #define get_segment_info() gfc_getmem (sizeof (segment_info))
116 #define BLANK_COMMON_NAME "__BLNK__"
119 /* Construct mangled common block name from symbol name. */
122 gfc_sym_mangled_common_id (gfc_symbol *sym)
125 char name[GFC_MAX_MANGLED_SYMBOL_LEN + 1];
127 if (strcmp (sym->name, BLANK_COMMON_NAME) == 0)
128 return get_identifier (sym->name);
129 if (gfc_option.flag_underscoring)
131 has_underscore = strchr (sym->name, '_') != 0;
132 if (gfc_option.flag_second_underscore && has_underscore)
133 snprintf (name, sizeof name, "%s__", sym->name);
135 snprintf (name, sizeof name, "%s_", sym->name);
136 return get_identifier (name);
139 return get_identifier (sym->name);
143 /* Build a filed declaration for a common variable or a local equivalence
147 build_field (segment_info *h, tree union_type, record_layout_info rli)
149 tree type = gfc_sym_type (h->sym);
150 tree name = get_identifier (h->sym->name);
151 tree field = build_decl (FIELD_DECL, name, type);
152 HOST_WIDE_INT offset = h->offset;
153 unsigned int desired_align, known_align;
155 known_align = (offset & -offset) * BITS_PER_UNIT;
156 if (known_align == 0 || known_align > BIGGEST_ALIGNMENT)
157 known_align = BIGGEST_ALIGNMENT;
159 desired_align = update_alignment_for_field (rli, field, known_align);
160 if (desired_align > known_align)
161 DECL_PACKED (field) = 1;
163 DECL_FIELD_CONTEXT (field) = union_type;
164 DECL_FIELD_OFFSET (field) = size_int (offset);
165 DECL_FIELD_BIT_OFFSET (field) = bitsize_zero_node;
166 SET_DECL_OFFSET_ALIGN (field, known_align);
168 rli->offset = size_binop (MAX_EXPR, rli->offset,
169 size_binop (PLUS_EXPR,
170 DECL_FIELD_OFFSET (field),
171 DECL_SIZE_UNIT (field)));
176 /* Get storage for local equivalence. */
179 build_equiv_decl (tree union_type, bool is_init)
182 decl = build_decl (VAR_DECL, NULL, union_type);
183 DECL_ARTIFICIAL (decl) = 1;
186 DECL_COMMON (decl) = 0;
188 DECL_COMMON (decl) = 1;
190 TREE_ADDRESSABLE (decl) = 1;
191 TREE_USED (decl) = 1;
192 gfc_add_decl_to_function (decl);
198 /* Get storage for common block. */
201 build_common_decl (gfc_symbol *sym, tree union_type, bool is_init)
203 gfc_symbol *common_sym;
206 /* Create a namespace to store symbols for common blocks. */
207 if (gfc_common_ns == NULL)
208 gfc_common_ns = gfc_get_namespace (NULL);
210 gfc_get_symbol (sym->name, gfc_common_ns, &common_sym);
211 decl = common_sym->backend_decl;
213 /* Update the size of this common block as needed. */
214 if (decl != NULL_TREE)
216 tree size = build_int_2 (current_length, 0);
217 if (tree_int_cst_lt (DECL_SIZE_UNIT (decl), size))
219 /* Named common blocks of the same name shall be of the same size
220 in all scoping units of a program in which they appear, but
221 blank common blocks may be of different sizes. */
222 if (strcmp (sym->name, BLANK_COMMON_NAME))
223 gfc_warning ("named COMMON block '%s' at %L shall be of the "
224 "same size", sym->name, &sym->declared_at);
225 DECL_SIZE_UNIT (decl) = size;
229 /* If this common block has been declared in a previous program unit,
230 and either it is already initialized or there is no new initialization
231 for it, just return. */
232 if ((decl != NULL_TREE) && (!is_init || DECL_INITIAL (decl)))
235 /* If there is no backend_decl for the common block, build it. */
236 if (decl == NULL_TREE)
238 decl = build_decl (VAR_DECL, get_identifier (sym->name), union_type);
239 SET_DECL_ASSEMBLER_NAME (decl, gfc_sym_mangled_common_id (sym));
240 TREE_PUBLIC (decl) = 1;
241 TREE_STATIC (decl) = 1;
242 DECL_ALIGN (decl) = BIGGEST_ALIGNMENT;
243 DECL_USER_ALIGN (decl) = 0;
246 /* Has no initial values. */
249 DECL_INITIAL (decl) = NULL_TREE;
250 DECL_COMMON (decl) = 1;
251 DECL_DEFER_OUTPUT (decl) = 1;
253 /* Place the back end declaration for this common block in
254 GLOBAL_BINDING_LEVEL. */
255 common_sym->backend_decl = pushdecl_top_level (decl);
259 DECL_INITIAL (decl) = error_mark_node;
260 DECL_COMMON (decl) = 0;
261 DECL_DEFER_OUTPUT (decl) = 0;
262 common_sym->backend_decl = decl;
268 /* Declare memory for the common block or local equivalence, and create
269 backend declarations for all of the elements. */
272 create_common (gfc_symbol *sym)
274 segment_info *h, *next_s;
277 record_layout_info rli;
279 bool is_init = false;
281 /* Declare the variables inside the common block. */
282 union_type = make_node (UNION_TYPE);
283 rli = start_record_layout (union_type);
284 field_link = &TYPE_FIELDS (union_type);
286 for (h = current_common; h; h = next_s)
289 field = build_field (h, union_type, rli);
291 /* Link the field into the type. */
293 field_link = &TREE_CHAIN (field);
295 /* Has initial value. */
301 finish_record_layout (rli, true);
304 gfc_todo_error ("initial values for COMMON or EQUIVALENCE");
307 decl = build_common_decl (sym, union_type, is_init);
309 decl = build_equiv_decl (union_type, is_init);
311 /* Build component reference for each variable. */
312 for (h = current_common; h; h = next_s)
314 h->sym->backend_decl = build (COMPONENT_REF, TREE_TYPE (h->field),
323 /* Given a symbol, find it in the current segment list. Returns NULL if
326 static segment_info *
327 find_segment_info (gfc_symbol *symbol)
331 for (n = current_segment; n; n = n->next)
332 if (n->sym == symbol) return n;
338 /* Given a variable symbol, calculate the total length in bytes of the
342 calculate_length (gfc_symbol *symbol)
347 if (symbol->ts.type == BT_CHARACTER)
348 gfc_conv_const_charlen (symbol->ts.cl);
349 element_size = int_size_in_bytes (gfc_typenode_for_spec (&symbol->ts));
350 if (symbol->as == NULL)
353 /* Calculate the number of elements in the array */
354 if (spec_size (symbol->as, &elements) == FAILURE)
355 gfc_internal_error ("calculate_length(): Unable to determine array size");
356 j = mpz_get_ui (elements);
357 mpz_clear (elements);
359 return j*element_size;;
363 /* Given an expression node, make sure it is a constant integer and return
367 get_mpz (gfc_expr *g)
369 if (g->expr_type != EXPR_CONSTANT)
370 gfc_internal_error ("get_mpz(): Not an integer constant");
372 return &g->value.integer;
376 /* Given an array specification and an array reference, figure out the
377 array element number (zero based). Bounds and elements are guaranteed
378 to be constants. If something goes wrong we generate an error and
382 element_number (gfc_array_ref *ar)
384 mpz_t multiplier, offset, extent, l;
390 mpz_init_set_ui (multiplier, 1);
391 mpz_init_set_ui (offset, 0);
395 for (b = 0; b < rank; b++)
397 if (ar->dimen_type[b] != DIMEN_ELEMENT)
398 gfc_internal_error ("element_number(): Bad dimension type");
400 mpz_sub (l, *get_mpz (ar->start[b]), *get_mpz (as->lower[b]));
402 mpz_mul (l, l, multiplier);
403 mpz_add (offset, offset, l);
405 mpz_sub (extent, *get_mpz (as->upper[b]), *get_mpz (as->lower[b]));
406 mpz_add_ui (extent, extent, 1);
408 if (mpz_sgn (extent) < 0)
409 mpz_set_ui (extent, 0);
411 mpz_mul (multiplier, multiplier, extent);
414 b = mpz_get_ui (offset);
416 mpz_clear (multiplier);
425 /* Given a single element of an equivalence list, figure out the offset
426 from the base symbol. For simple variables or full arrays, this is
427 simply zero. For an array element we have to calculate the array
428 element number and multiply by the element size. For a substring we
429 have to calculate the further reference. */
432 calculate_offset (gfc_expr *s)
434 int a, element_size, offset;
435 gfc_typespec *element_type;
439 element_type = &s->symtree->n.sym->ts;
441 for (reference = s->ref; reference; reference = reference->next)
442 switch (reference->type)
445 switch (reference->u.ar.type)
451 a = element_number (&reference->u.ar);
452 if (element_type->type == BT_CHARACTER)
453 gfc_conv_const_charlen (element_type->cl);
455 int_size_in_bytes (gfc_typenode_for_spec (element_type));
456 offset += a * element_size;
460 gfc_error ("bad array reference at %L", &s->where);
464 if (reference->u.ss.start != NULL)
465 offset += mpz_get_ui (*get_mpz (reference->u.ss.start)) - 1;
468 gfc_error ("illegal reference type at %L as EQUIVALENCE object",
475 /* Add a new segment_info structure to the current eq1 is already in the
476 list at s1, eq2 is not. */
479 new_condition (segment_info *v, gfc_equiv *eq1, gfc_equiv *eq2)
481 int offset1, offset2;
484 offset1 = calculate_offset (eq1->expr);
485 offset2 = calculate_offset (eq2->expr);
487 a = get_segment_info ();
489 a->sym = eq2->expr->symtree->n.sym;
490 a->offset = v->offset + offset1 - offset2;
491 a->length = calculate_length (eq2->expr->symtree->n.sym);
493 a->next = current_segment;
498 /* Given two equivalence structures that are both already in the list, make
499 sure that this new condition is not violated, generating an error if it
503 confirm_condition (segment_info *k, gfc_equiv *eq1, segment_info *e,
506 int offset1, offset2;
508 offset1 = calculate_offset (eq1->expr);
509 offset2 = calculate_offset (eq2->expr);
511 if (k->offset + offset1 != e->offset + offset2)
512 gfc_error ("inconsistent equivalence rules involving '%s' at %L and "
513 "'%s' at %L", k->sym->name, &k->sym->declared_at,
514 e->sym->name, &e->sym->declared_at);
518 /* At this point we have a new equivalence condition to process. If both
519 variables are already present, then we are confirming that the condition
520 holds. Otherwise we are adding a new variable to the segment list. */
523 add_condition (gfc_equiv *eq1, gfc_equiv *eq2)
527 eq1->expr->symtree->n.sym->mark = 1;
528 eq2->expr->symtree->n.sym->mark = 1;
532 n = find_segment_info (eq1->expr->symtree->n.sym);
533 t = find_segment_info (eq2->expr->symtree->n.sym);
535 if (n == NULL && t == NULL)
537 if (n != NULL && t == NULL)
538 new_condition (n, eq1, eq2);
539 if (n == NULL && t != NULL)
540 new_condition (t, eq2, eq1);
541 if (n != NULL && t != NULL)
542 confirm_condition (n, eq1, t, eq2);
546 /* Given a symbol, search through the equivalence lists for an unused
547 condition that involves the symbol. If a rule is found, we return
548 nonzero, the rule is marked as used and the eq1 and eq2 pointers point
552 find_equivalence (gfc_symbol *sym, gfc_equiv **eq1, gfc_equiv **eq2)
556 for (c = sym->ns->equiv; c; c = c->next)
557 for (l = c->eq; l; l = l->eq)
559 if (l->used) continue;
561 if (c->expr->symtree->n.sym == sym || l->expr->symtree->n.sym == sym)
572 /* Function for adding symbols to current segment. Returns zero if the
573 segment was modified. Equivalence rules are considered to be between
574 the first expression in the list and each of the other expressions in
575 the list. Symbols are scanned multiple times because a symbol can be
576 equivalenced more than once. */
579 add_equivalences (void)
581 int segment_modified;
582 gfc_equiv *eq1, *eq2;
585 segment_modified = 0;
587 for (f = current_segment; f; f = f->next)
588 if (find_equivalence (f->sym, &eq1, &eq2)) break;
592 add_condition (eq1, eq2);
593 segment_modified = 1;
596 return segment_modified;
600 /* Given a seed symbol, create a new segment consisting of that symbol
601 and all of the symbols equivalenced with that symbol. */
604 new_segment (gfc_symbol *common_sym, gfc_symbol *sym)
609 current_segment = get_segment_info ();
610 current_segment->sym = sym;
611 current_segment->offset = current_offset;
612 length = calculate_length (sym);
613 current_segment->length = length;
617 /* Add all object directly or indirectly equivalenced with this common
619 while (add_equivalences ());
621 /* Calculate the storage size to hold the common block. */
622 for (v = current_segment; v; v = v->next)
625 gfc_error ("the equivalence set for '%s' cause an invalid extension "
626 "to COMMON '%s' at %L",
627 sym->name, common_sym->name, &common_sym->declared_at);
628 if (current_length < (v->offset + v->length))
629 current_length = v->offset + v->length;
632 /* The offset of the next common variable. */
633 current_offset += length;
635 /* Append the current segment to the current common. */
637 while (v->next != NULL)
640 v->next = current_common;
641 current_common = current_segment;
642 current_segment = NULL;
646 /* Create a new block for each merged equivalence list. */
649 finish_equivalences (gfc_namespace *ns)
656 for (z = ns->equiv; z; z = z->next)
657 for (y= z->eq; y; y = y->eq)
659 if (y->used) continue;
660 sym = z->expr->symtree->n.sym;
662 current_segment = get_segment_info ();
663 current_segment->sym = sym;
664 current_segment->offset = 0;
665 current_segment->length = calculate_length (sym);
668 /* All object directly or indrectly equivalenced with this symbol. */
669 while (add_equivalences ());
671 /* Calculate the minimal offset. */
673 for (v = current_segment; v; v = v->next)
674 min_offset = (min_offset >= v->offset) ? v->offset : min_offset;
676 /* Adjust the offset of each equivalence object, and calculate the
677 maximal storage size to hold them. */
678 for (v = current_segment; v; v = v->next)
680 v->offset -= min_offset;
681 if (current_length < (v->offset + v->length))
682 current_length = v->offset + v->length;
685 current_common = current_segment;
686 create_common (NULL);
692 /* Translate a single common block. */
695 translate_common (gfc_symbol *common_sym, gfc_symbol *var_list)
699 current_common = NULL;
703 /* Mark bits indicate which symbols have already been placed in a
705 for (sym = var_list; sym; sym = sym->common_next)
710 for (sym = var_list; sym; sym = sym->common_next)
711 if (!sym->mark) break;
713 /* All symbols have been placed in a common. */
714 if (sym == NULL) break;
715 new_segment (common_sym, sym);
718 create_common (common_sym);
722 /* Work function for translating a named common block. */
725 named_common (gfc_symbol *s)
728 translate_common (s, s->common_head);
732 /* Translate the common blocks in a namespace. Unlike other variables,
733 these have to be created before code, because the backend_decl depends
734 on the rest of the common block. */
737 gfc_trans_common (gfc_namespace *ns)
741 /* Translate the blank common block. */
742 if (ns->blank_common != NULL)
744 gfc_get_symbol (BLANK_COMMON_NAME, ns, &sym);
745 translate_common (sym, ns->blank_common);
748 /* Translate all named common blocks. */
749 gfc_traverse_ns (ns, named_common);
751 /* Commit the newly created symbols for common blocks. */
752 gfc_commit_symbols ();
754 /* Translate local equivalence. */
755 finish_equivalences (ns);