Branch data Line data Source code
1 : : /* Common block and equivalence list handling
2 : : Copyright (C) 2000-2025 Free Software Foundation, Inc.
3 : : Contributed by Canqun Yang <canqun@nudt.edu.cn>
4 : :
5 : : This file is part of GCC.
6 : :
7 : : GCC is free software; you can redistribute it and/or modify it under
8 : : the terms of the GNU General Public License as published by the Free
9 : : Software Foundation; either version 3, or (at your option) any later
10 : : version.
11 : :
12 : : GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 : : WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 : : FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
15 : : for more details.
16 : :
17 : : You should have received a copy of the GNU General Public License
18 : : along with GCC; see the file COPYING3. If not see
19 : : <http://www.gnu.org/licenses/>. */
20 : :
21 : : /* The core algorithm is based on Andy Vaught's g95 tree. Also the
22 : : way to build UNION_TYPE is borrowed from Richard Henderson.
23 : :
24 : : Transform common blocks. An integral part of this is processing
25 : : equivalence variables. Equivalenced variables that are not in a
26 : : common block end up in a private block of their own.
27 : :
28 : : Each common block or local equivalence list is declared as a union.
29 : : Variables within the block are represented as a field within the
30 : : block with the proper offset.
31 : :
32 : : So if two variables are equivalenced, they just point to a common
33 : : area in memory.
34 : :
35 : : Mathematically, laying out an equivalence block is equivalent to
36 : : solving a linear system of equations. The matrix is usually a
37 : : sparse matrix in which each row contains all zero elements except
38 : : for a +1 and a -1, a sort of a generalized Vandermonde matrix. The
39 : : matrix is usually block diagonal. The system can be
40 : : overdetermined, underdetermined or have a unique solution. If the
41 : : system is inconsistent, the program is not standard conforming.
42 : : The solution vector is integral, since all of the pivots are +1 or -1.
43 : :
44 : : How we lay out an equivalence block is a little less complicated.
45 : : In an equivalence list with n elements, there are n-1 conditions to
46 : : be satisfied. The conditions partition the variables into what we
47 : : will call segments. If A and B are equivalenced then A and B are
48 : : in the same segment. If B and C are equivalenced as well, then A,
49 : : B and C are in a segment and so on. Each segment is a block of
50 : : memory that has one or more variables equivalenced in some way. A
51 : : common block is made up of a series of segments that are joined one
52 : : after the other. In the linear system, a segment is a block
53 : : diagonal.
54 : :
55 : : To lay out a segment we first start with some variable and
56 : : determine its length. The first variable is assumed to start at
57 : : offset one and extends to however long it is. We then traverse the
58 : : list of equivalences to find an unused condition that involves at
59 : : least one of the variables currently in the segment.
60 : :
61 : : Each equivalence condition amounts to the condition B+b=C+c where B
62 : : and C are the offsets of the B and C variables, and b and c are
63 : : constants which are nonzero for array elements, substrings or
64 : : structure components. So for
65 : :
66 : : EQUIVALENCE(B(2), C(3))
67 : : we have
68 : : B + 2*size of B's elements = C + 3*size of C's elements.
69 : :
70 : : If B and C are known we check to see if the condition already
71 : : holds. If B is known we can solve for C. Since we know the length
72 : : of C, we can see if the minimum and maximum extents of the segment
73 : : are affected. Eventually, we make a full pass through the
74 : : equivalence list without finding any new conditions and the segment
75 : : is fully specified.
76 : :
77 : : At this point, the segment is added to the current common block.
78 : : Since we know the minimum extent of the segment, everything in the
79 : : segment is translated to its position in the common block. The
80 : : usual case here is that there are no equivalence statements and the
81 : : common block is series of segments with one variable each, which is
82 : : a diagonal matrix in the matrix formulation.
83 : :
84 : : Each segment is described by a chain of segment_info structures. Each
85 : : segment_info structure describes the extents of a single variable within
86 : : the segment. This list is maintained in the order the elements are
87 : : positioned within the segment. If two elements have the same starting
88 : : offset the smaller will come first. If they also have the same size their
89 : : ordering is undefined.
90 : :
91 : : Once all common blocks have been created, the list of equivalences
92 : : is examined for still-unused equivalence conditions. We create a
93 : : block for each merged equivalence list. */
94 : :
95 : : #include "config.h"
96 : : #define INCLUDE_MAP
97 : : #include "system.h"
98 : : #include "coretypes.h"
99 : : #include "tm.h"
100 : : #include "tree.h"
101 : : #include "cgraph.h"
102 : : #include "context.h"
103 : : #include "omp-offload.h"
104 : : #include "gfortran.h"
105 : : #include "trans.h"
106 : : #include "stringpool.h"
107 : : #include "fold-const.h"
108 : : #include "stor-layout.h"
109 : : #include "varasm.h"
110 : : #include "trans-types.h"
111 : : #include "trans-const.h"
112 : : #include "target-memory.h"
113 : :
114 : :
115 : : /* Holds a single variable in an equivalence set. */
116 : : typedef struct segment_info
117 : : {
118 : : gfc_symbol *sym;
119 : : HOST_WIDE_INT offset;
120 : : HOST_WIDE_INT length;
121 : : /* This will contain the field type until the field is created. */
122 : : tree field;
123 : : struct segment_info *next;
124 : : } segment_info;
125 : :
126 : : static segment_info * current_segment;
127 : :
128 : : /* Store decl of all common blocks in this translation unit; the first
129 : : tree is the identifier. */
130 : : static std::map<tree, tree> gfc_map_of_all_commons;
131 : :
132 : :
133 : : /* Make a segment_info based on a symbol. */
134 : :
135 : : static segment_info *
136 : 8107 : get_segment_info (gfc_symbol * sym, HOST_WIDE_INT offset)
137 : : {
138 : 8107 : segment_info *s;
139 : :
140 : : /* Make sure we've got the character length. */
141 : 8107 : if (sym->ts.type == BT_CHARACTER)
142 : 641 : gfc_conv_const_charlen (sym->ts.u.cl);
143 : :
144 : : /* Create the segment_info and fill it in. */
145 : 8107 : s = XCNEW (segment_info);
146 : 8107 : s->sym = sym;
147 : : /* We will use this type when building the segment aggregate type. */
148 : 8107 : s->field = gfc_sym_type (sym);
149 : 8107 : s->length = int_size_in_bytes (s->field);
150 : 8107 : s->offset = offset;
151 : :
152 : 8107 : return s;
153 : : }
154 : :
155 : :
156 : : /* Add a copy of a segment list to the namespace. This is specifically for
157 : : equivalence segments, so that dependency checking can be done on
158 : : equivalence group members. */
159 : :
160 : : static void
161 : 6546 : copy_equiv_list_to_ns (segment_info *c)
162 : : {
163 : 6546 : segment_info *f;
164 : 6546 : gfc_equiv_info *s;
165 : 6546 : gfc_equiv_list *l;
166 : :
167 : 6546 : l = XCNEW (gfc_equiv_list);
168 : :
169 : 6546 : l->next = c->sym->ns->equiv_lists;
170 : 6546 : c->sym->ns->equiv_lists = l;
171 : :
172 : 14653 : for (f = c; f; f = f->next)
173 : : {
174 : 8107 : s = XCNEW (gfc_equiv_info);
175 : 8107 : s->next = l->equiv;
176 : 8107 : l->equiv = s;
177 : 8107 : s->sym = f->sym;
178 : 8107 : s->offset = f->offset;
179 : 8107 : s->length = f->length;
180 : : }
181 : 6546 : }
182 : :
183 : :
184 : : /* Add combine segment V and segment LIST. */
185 : :
186 : : static segment_info *
187 : 7314 : add_segments (segment_info *list, segment_info *v)
188 : : {
189 : 7314 : segment_info *s;
190 : 7314 : segment_info *p;
191 : 7314 : segment_info *next;
192 : :
193 : 7314 : p = NULL;
194 : 7314 : s = list;
195 : :
196 : 14975 : while (v)
197 : : {
198 : : /* Find the location of the new element. */
199 : 42128 : while (s)
200 : : {
201 : 35575 : if (v->offset < s->offset)
202 : : break;
203 : 35153 : if (v->offset == s->offset
204 : 732 : && v->length <= s->length)
205 : : break;
206 : :
207 : 34467 : p = s;
208 : 34467 : s = s->next;
209 : : }
210 : :
211 : : /* Insert the new element in between p and s. */
212 : 7661 : next = v->next;
213 : 7661 : v->next = s;
214 : 7661 : if (p == NULL)
215 : : list = v;
216 : : else
217 : 4770 : p->next = v;
218 : :
219 : : p = v;
220 : : v = next;
221 : : }
222 : :
223 : 7314 : return list;
224 : : }
225 : :
226 : :
227 : : /* Construct mangled common block name from symbol name. */
228 : :
229 : : /* We need the bind(c) flag to tell us how/if we should mangle the symbol
230 : : name. There are few calls to this function, so few places that this
231 : : would need to be added. At the moment, there is only one call, in
232 : : build_common_decl(). We can't attempt to look up the common block
233 : : because we may be building it for the first time and therefore, it won't
234 : : be in the common_root. We also need the binding label, if it's bind(c).
235 : : Therefore, send in the pointer to the common block, so whatever info we
236 : : have so far can be used. All of the necessary info should be available
237 : : in the gfc_common_head by now, so it should be accurate to test the
238 : : isBindC flag and use the binding label given if it is bind(c).
239 : :
240 : : We may NOT know yet if it's bind(c) or not, but we can try at least.
241 : : Will have to figure out what to do later if it's labeled bind(c)
242 : : after this is called. */
243 : :
244 : : static tree
245 : 2053 : gfc_sym_mangled_common_id (gfc_common_head *com)
246 : : {
247 : 2053 : int has_underscore;
248 : : /* Provide sufficient space to hold "symbol.symbol.eq.1234567890__". */
249 : 2053 : char mangled_name[2*GFC_MAX_MANGLED_SYMBOL_LEN + 1 + 16 + 1];
250 : 2053 : char name[sizeof (mangled_name) - 2];
251 : :
252 : : /* Get the name out of the common block pointer. */
253 : 2053 : size_t len = strlen (com->name);
254 : 2053 : gcc_assert (len < sizeof (name));
255 : 2053 : strcpy (name, com->name);
256 : :
257 : : /* If we're suppose to do a bind(c). */
258 : 2053 : if (com->is_bind_c == 1 && com->binding_label)
259 : 69 : return get_identifier (com->binding_label);
260 : :
261 : 1984 : if (strcmp (name, BLANK_COMMON_NAME) == 0)
262 : 192 : return get_identifier (name);
263 : :
264 : 1792 : if (flag_underscoring)
265 : : {
266 : 1792 : has_underscore = strchr (name, '_') != 0;
267 : 1792 : if (flag_second_underscore && has_underscore)
268 : 4 : snprintf (mangled_name, sizeof mangled_name, "%s__", name);
269 : : else
270 : 1788 : snprintf (mangled_name, sizeof mangled_name, "%s_", name);
271 : :
272 : 1792 : return get_identifier (mangled_name);
273 : : }
274 : : else
275 : 0 : return get_identifier (name);
276 : : }
277 : :
278 : :
279 : : /* Build a field declaration for a common variable or a local equivalence
280 : : object. */
281 : :
282 : : static void
283 : 8107 : build_field (segment_info *h, tree union_type, record_layout_info rli)
284 : : {
285 : 8107 : tree field;
286 : 8107 : tree name;
287 : 8107 : HOST_WIDE_INT offset = h->offset;
288 : 8107 : unsigned HOST_WIDE_INT desired_align, known_align;
289 : :
290 : 8107 : name = get_identifier (h->sym->name);
291 : 8107 : field = build_decl (gfc_get_location (&h->sym->declared_at),
292 : : FIELD_DECL, name, h->field);
293 : 8107 : known_align = (offset & -offset) * BITS_PER_UNIT;
294 : 12879 : if (known_align == 0 || known_align > BIGGEST_ALIGNMENT)
295 : 4892 : known_align = BIGGEST_ALIGNMENT;
296 : :
297 : 8107 : desired_align = update_alignment_for_field (rli, field, known_align);
298 : 8107 : if (desired_align > known_align)
299 : 7 : DECL_PACKED (field) = 1;
300 : :
301 : 8107 : DECL_FIELD_CONTEXT (field) = union_type;
302 : 8107 : DECL_FIELD_OFFSET (field) = size_int (offset);
303 : 8107 : DECL_FIELD_BIT_OFFSET (field) = bitsize_zero_node;
304 : 8107 : SET_DECL_OFFSET_ALIGN (field, known_align);
305 : :
306 : 8107 : rli->offset = size_binop (MAX_EXPR, rli->offset,
307 : : size_binop (PLUS_EXPR,
308 : : DECL_FIELD_OFFSET (field),
309 : : DECL_SIZE_UNIT (field)));
310 : : /* If this field is assigned to a label, we create another two variables.
311 : : One will hold the address of target label or format label. The other will
312 : : hold the length of format label string. */
313 : 8107 : if (h->sym->attr.assign)
314 : : {
315 : 14 : tree len;
316 : 14 : tree addr;
317 : :
318 : 14 : gfc_allocate_lang_decl (field);
319 : 14 : GFC_DECL_ASSIGN (field) = 1;
320 : 14 : len = gfc_create_var_np (gfc_charlen_type_node,h->sym->name);
321 : 14 : addr = gfc_create_var_np (pvoid_type_node, h->sym->name);
322 : 14 : TREE_STATIC (len) = 1;
323 : 14 : TREE_STATIC (addr) = 1;
324 : 14 : DECL_INITIAL (len) = build_int_cst (gfc_charlen_type_node, -2);
325 : 14 : gfc_set_decl_location (len, &h->sym->declared_at);
326 : 14 : gfc_set_decl_location (addr, &h->sym->declared_at);
327 : 14 : GFC_DECL_STRING_LEN (field) = pushdecl_top_level (len);
328 : 14 : GFC_DECL_ASSIGN_ADDR (field) = pushdecl_top_level (addr);
329 : : }
330 : :
331 : : /* If this field is volatile, mark it. */
332 : 8107 : if (h->sym->attr.volatile_)
333 : : {
334 : 3 : tree new_type;
335 : 3 : TREE_THIS_VOLATILE (field) = 1;
336 : 3 : TREE_SIDE_EFFECTS (field) = 1;
337 : 3 : new_type = build_qualified_type (TREE_TYPE (field), TYPE_QUAL_VOLATILE);
338 : 3 : TREE_TYPE (field) = new_type;
339 : : }
340 : :
341 : 8107 : h->field = field;
342 : 8107 : }
343 : :
344 : : #if !defined (NO_DOT_IN_LABEL)
345 : : #define GFC_EQUIV_FMT "equiv.%d"
346 : : #elif !defined (NO_DOLLAR_IN_LABEL)
347 : : #define GFC_EQUIV_FMT "_Equiv$%d"
348 : : #else
349 : : #define GFC_EQUIV_FMT "_Equiv_%d"
350 : : #endif
351 : :
352 : : /* Get storage for local equivalence. */
353 : :
354 : : static tree
355 : 688 : build_equiv_decl (tree union_type, bool is_init, bool is_saved, bool is_auto)
356 : : {
357 : 688 : tree decl;
358 : 688 : char name[18];
359 : 688 : static int serial = 0;
360 : :
361 : 688 : if (is_init)
362 : : {
363 : 141 : decl = gfc_create_var (union_type, "equiv");
364 : 141 : TREE_STATIC (decl) = 1;
365 : 141 : GFC_DECL_COMMON_OR_EQUIV (decl) = 1;
366 : 141 : return decl;
367 : : }
368 : :
369 : 547 : snprintf (name, sizeof (name), GFC_EQUIV_FMT, serial++);
370 : 547 : decl = build_decl (input_location,
371 : : VAR_DECL, get_identifier (name), union_type);
372 : 547 : DECL_ARTIFICIAL (decl) = 1;
373 : 547 : DECL_IGNORED_P (decl) = 1;
374 : :
375 : 547 : if (!is_auto && (!gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl))
376 : 526 : || is_saved))
377 : 27 : TREE_STATIC (decl) = 1;
378 : :
379 : 547 : TREE_ADDRESSABLE (decl) = 1;
380 : 547 : TREE_USED (decl) = 1;
381 : 547 : GFC_DECL_COMMON_OR_EQUIV (decl) = 1;
382 : :
383 : : /* The source location has been lost, and doesn't really matter.
384 : : We need to set it to something though. */
385 : 547 : DECL_SOURCE_LOCATION (decl) = input_location;
386 : :
387 : 547 : gfc_add_decl_to_function (decl);
388 : :
389 : 547 : return decl;
390 : : }
391 : :
392 : :
393 : : /* Get storage for common block. */
394 : :
395 : : static tree
396 : 2053 : build_common_decl (gfc_common_head *com, tree union_type, bool is_init)
397 : : {
398 : 2053 : tree decl, identifier;
399 : :
400 : 2053 : identifier = gfc_sym_mangled_common_id (com);
401 : 2053 : decl = gfc_map_of_all_commons.count(identifier)
402 : 969 : ? gfc_map_of_all_commons[identifier] : NULL_TREE;
403 : :
404 : : /* Update the size of this common block as needed. */
405 : 2053 : if (decl != NULL_TREE)
406 : : {
407 : 969 : tree size = TYPE_SIZE_UNIT (union_type);
408 : :
409 : : /* Named common blocks of the same name shall be of the same size
410 : : in all scoping units of a program in which they appear, but
411 : : blank common blocks may be of different sizes. */
412 : 969 : if (!tree_int_cst_equal (DECL_SIZE_UNIT (decl), size)
413 : 969 : && strcmp (com->name, BLANK_COMMON_NAME))
414 : 45 : gfc_warning (0, "Named COMMON block %qs at %L shall be of the "
415 : : "same size as elsewhere (%wu vs %wu bytes)", com->name,
416 : : &com->where,
417 : 15 : TREE_INT_CST_LOW (size),
418 : 15 : TREE_INT_CST_LOW (DECL_SIZE_UNIT (decl)));
419 : :
420 : 969 : if (tree_int_cst_lt (DECL_SIZE_UNIT (decl), size))
421 : : {
422 : 11 : DECL_SIZE (decl) = TYPE_SIZE (union_type);
423 : 11 : DECL_SIZE_UNIT (decl) = size;
424 : 11 : SET_DECL_MODE (decl, TYPE_MODE (union_type));
425 : 11 : TREE_TYPE (decl) = union_type;
426 : 11 : layout_decl (decl, 0);
427 : : }
428 : : }
429 : :
430 : : /* If this common block has been declared in a previous program unit,
431 : : and either it is already initialized or there is no new initialization
432 : : for it, just return. */
433 : 969 : if ((decl != NULL_TREE) && (!is_init || DECL_INITIAL (decl)))
434 : : return decl;
435 : :
436 : : /* If there is no backend_decl for the common block, build it. */
437 : 1102 : if (decl == NULL_TREE)
438 : : {
439 : 1084 : tree omp_clauses = NULL_TREE;
440 : :
441 : 1084 : if (com->is_bind_c == 1 && com->binding_label)
442 : 51 : decl = build_decl (input_location, VAR_DECL, identifier, union_type);
443 : : else
444 : : {
445 : 1033 : decl = build_decl (input_location, VAR_DECL, get_identifier (com->name),
446 : : union_type);
447 : 1033 : gfc_set_decl_assembler_name (decl, identifier);
448 : : }
449 : :
450 : 1084 : TREE_PUBLIC (decl) = 1;
451 : 1084 : TREE_STATIC (decl) = 1;
452 : 1084 : DECL_IGNORED_P (decl) = 1;
453 : 1084 : if (!com->is_bind_c)
454 : 2037 : SET_DECL_ALIGN (decl, BIGGEST_ALIGNMENT);
455 : : else
456 : : {
457 : : /* Do not set the alignment for bind(c) common blocks to
458 : : BIGGEST_ALIGNMENT because that won't match what C does. Also,
459 : : for common blocks with one element, the alignment must be
460 : : that of the field within the common block in order to match
461 : : what C will do. */
462 : 59 : tree field = NULL_TREE;
463 : 59 : field = TYPE_FIELDS (TREE_TYPE (decl));
464 : 59 : if (DECL_CHAIN (field) == NULL_TREE)
465 : 23 : SET_DECL_ALIGN (decl, TYPE_ALIGN (TREE_TYPE (field)));
466 : : }
467 : 1084 : DECL_USER_ALIGN (decl) = 0;
468 : 1084 : GFC_DECL_COMMON_OR_EQUIV (decl) = 1;
469 : :
470 : 1084 : gfc_set_decl_location (decl, &com->where);
471 : :
472 : 1084 : if (com->threadprivate)
473 : 42 : set_decl_tls_model (decl, decl_default_tls_model (decl));
474 : :
475 : 1084 : if (com->omp_device_type != OMP_DEVICE_TYPE_UNSET)
476 : : {
477 : 6 : tree c = build_omp_clause (UNKNOWN_LOCATION, OMP_CLAUSE_DEVICE_TYPE);
478 : 6 : switch (com->omp_device_type)
479 : : {
480 : 2 : case OMP_DEVICE_TYPE_HOST:
481 : 2 : OMP_CLAUSE_DEVICE_TYPE_KIND (c) = OMP_CLAUSE_DEVICE_TYPE_HOST;
482 : 2 : break;
483 : 2 : case OMP_DEVICE_TYPE_NOHOST:
484 : 2 : OMP_CLAUSE_DEVICE_TYPE_KIND (c) = OMP_CLAUSE_DEVICE_TYPE_NOHOST;
485 : 2 : break;
486 : 2 : case OMP_DEVICE_TYPE_ANY:
487 : 2 : OMP_CLAUSE_DEVICE_TYPE_KIND (c) = OMP_CLAUSE_DEVICE_TYPE_ANY;
488 : 2 : break;
489 : 0 : default:
490 : 0 : gcc_unreachable ();
491 : : }
492 : : omp_clauses = c;
493 : : }
494 : 1084 : if (com->omp_declare_target_link)
495 : 4 : DECL_ATTRIBUTES (decl)
496 : 8 : = tree_cons (get_identifier ("omp declare target link"),
497 : 4 : omp_clauses, DECL_ATTRIBUTES (decl));
498 : 1080 : else if (com->omp_declare_target)
499 : 5 : DECL_ATTRIBUTES (decl)
500 : 10 : = tree_cons (get_identifier ("omp declare target"),
501 : 5 : omp_clauses, DECL_ATTRIBUTES (decl));
502 : :
503 : 1084 : if (com->omp_declare_target_link || com->omp_declare_target)
504 : : {
505 : : /* Add to offload_vars; get_create does so for omp_declare_target,
506 : : omp_declare_target_link requires manual work. */
507 : 9 : gcc_assert (symtab_node::get (decl) == 0);
508 : 9 : symtab_node *node = symtab_node::get_create (decl);
509 : 9 : if (node != NULL && com->omp_declare_target_link)
510 : : {
511 : 4 : node->offloadable = 1;
512 : 4 : if (ENABLE_OFFLOADING)
513 : : {
514 : : g->have_offload = true;
515 : : if (is_a <varpool_node *> (node))
516 : : vec_safe_push (offload_vars, decl);
517 : : }
518 : : }
519 : : }
520 : :
521 : : /* Place the back end declaration for this common block in
522 : : GLOBAL_BINDING_LEVEL. */
523 : 1084 : gfc_map_of_all_commons[identifier] = pushdecl_top_level (decl);
524 : : }
525 : :
526 : : /* Has no initial values. */
527 : 1102 : if (!is_init)
528 : : {
529 : 1000 : DECL_INITIAL (decl) = NULL_TREE;
530 : 1000 : DECL_COMMON (decl) = 1;
531 : 1000 : DECL_DEFER_OUTPUT (decl) = 1;
532 : : }
533 : : else
534 : : {
535 : 102 : DECL_INITIAL (decl) = error_mark_node;
536 : 102 : DECL_COMMON (decl) = 0;
537 : 102 : DECL_DEFER_OUTPUT (decl) = 0;
538 : : }
539 : : return decl;
540 : : }
541 : :
542 : :
543 : : /* Return a field that is the size of the union, if an equivalence has
544 : : overlapping initializers. Merge the initializers into a single
545 : : initializer for this new field, then free the old ones. */
546 : :
547 : : static tree
548 : 941 : get_init_field (segment_info *head, tree union_type, tree *field_init,
549 : : record_layout_info rli)
550 : : {
551 : 941 : segment_info *s;
552 : 941 : HOST_WIDE_INT length = 0;
553 : 941 : HOST_WIDE_INT offset = 0;
554 : 941 : unsigned HOST_WIDE_INT known_align, desired_align;
555 : 941 : bool overlap = false;
556 : 941 : tree tmp, field;
557 : 941 : tree init;
558 : 941 : unsigned char *data, *chk;
559 : 941 : vec<constructor_elt, va_gc> *v = NULL;
560 : :
561 : 941 : tree type = unsigned_char_type_node;
562 : 941 : int i;
563 : :
564 : : /* Obtain the size of the union and check if there are any overlapping
565 : : initializers. */
566 : 4070 : for (s = head; s; s = s->next)
567 : : {
568 : 3129 : HOST_WIDE_INT slen = s->offset + s->length;
569 : 3129 : if (s->sym->value)
570 : : {
571 : 229 : if (s->offset < offset)
572 : 50 : overlap = true;
573 : : offset = slen;
574 : : }
575 : 3129 : length = length < slen ? slen : length;
576 : : }
577 : :
578 : 941 : if (!overlap)
579 : : return NULL_TREE;
580 : :
581 : : /* Now absorb all the initializer data into a single vector,
582 : : whilst checking for overlapping, unequal values. */
583 : 46 : data = XCNEWVEC (unsigned char, (size_t)length);
584 : 46 : chk = XCNEWVEC (unsigned char, (size_t)length);
585 : :
586 : : /* TODO - change this when default initialization is implemented. */
587 : 46 : memset (data, '\0', (size_t)length);
588 : 46 : memset (chk, '\0', (size_t)length);
589 : 156 : for (s = head; s; s = s->next)
590 : 110 : if (s->sym->value)
591 : : {
592 : 96 : locus *loc = NULL;
593 : 96 : if (s->sym->ns->equiv && s->sym->ns->equiv->eq)
594 : 96 : loc = &s->sym->ns->equiv->eq->expr->where;
595 : 96 : gfc_merge_initializers (s->sym->ts, s->sym->value, loc,
596 : : &data[s->offset],
597 : 96 : &chk[s->offset],
598 : 96 : (size_t)s->length);
599 : : }
600 : :
601 : 1142 : for (i = 0; i < length; i++)
602 : 1096 : CONSTRUCTOR_APPEND_ELT (v, NULL, build_int_cst (type, data[i]));
603 : :
604 : 46 : free (data);
605 : 46 : free (chk);
606 : :
607 : : /* Build a char[length] array to hold the initializers. Much of what
608 : : follows is borrowed from build_field, above. */
609 : :
610 : 46 : tmp = build_int_cst (gfc_array_index_type, length - 1);
611 : 46 : tmp = build_range_type (gfc_array_index_type,
612 : : gfc_index_zero_node, tmp);
613 : 46 : tmp = build_array_type (type, tmp);
614 : 46 : field = build_decl (input_location, FIELD_DECL, NULL_TREE, tmp);
615 : :
616 : 46 : known_align = BIGGEST_ALIGNMENT;
617 : :
618 : 46 : desired_align = update_alignment_for_field (rli, field, known_align);
619 : 46 : if (desired_align > known_align)
620 : 0 : DECL_PACKED (field) = 1;
621 : :
622 : 46 : DECL_FIELD_CONTEXT (field) = union_type;
623 : 46 : DECL_FIELD_OFFSET (field) = size_int (0);
624 : 46 : DECL_FIELD_BIT_OFFSET (field) = bitsize_zero_node;
625 : 46 : SET_DECL_OFFSET_ALIGN (field, known_align);
626 : :
627 : 46 : rli->offset = size_binop (MAX_EXPR, rli->offset,
628 : : size_binop (PLUS_EXPR,
629 : : DECL_FIELD_OFFSET (field),
630 : : DECL_SIZE_UNIT (field)));
631 : :
632 : 46 : init = build_constructor (TREE_TYPE (field), v);
633 : 46 : TREE_CONSTANT (init) = 1;
634 : :
635 : 46 : *field_init = init;
636 : :
637 : 156 : for (s = head; s; s = s->next)
638 : : {
639 : 110 : if (s->sym->value == NULL)
640 : 14 : continue;
641 : :
642 : 96 : gfc_free_expr (s->sym->value);
643 : 96 : s->sym->value = NULL;
644 : : }
645 : :
646 : : return field;
647 : : }
648 : :
649 : :
650 : : /* Declare memory for the common block or local equivalence, and create
651 : : backend declarations for all of the elements. */
652 : :
653 : : static void
654 : 2741 : create_common (gfc_common_head *com, segment_info *head, bool saw_equiv)
655 : : {
656 : 2741 : segment_info *s, *next_s;
657 : 2741 : tree union_type;
658 : 2741 : tree *field_link;
659 : 2741 : tree field;
660 : 2741 : tree field_init = NULL_TREE;
661 : 2741 : record_layout_info rli;
662 : 2741 : tree decl;
663 : 2741 : bool is_init = false;
664 : 2741 : bool is_saved = false;
665 : 2741 : bool is_auto = false;
666 : :
667 : : /* Declare the variables inside the common block.
668 : : If the current common block contains any equivalence object, then
669 : : make a UNION_TYPE node, otherwise RECORD_TYPE. This will let the
670 : : alias analyzer work well when there is no address overlapping for
671 : : common variables in the current common block. */
672 : 2741 : if (saw_equiv)
673 : 941 : union_type = make_node (UNION_TYPE);
674 : : else
675 : 1800 : union_type = make_node (RECORD_TYPE);
676 : :
677 : 2741 : rli = start_record_layout (union_type);
678 : 2741 : field_link = &TYPE_FIELDS (union_type);
679 : :
680 : : /* Check for overlapping initializers and replace them with a single,
681 : : artificial field that contains all the data. */
682 : 2741 : if (saw_equiv)
683 : 941 : field = get_init_field (head, union_type, &field_init, rli);
684 : : else
685 : : field = NULL_TREE;
686 : :
687 : 941 : if (field != NULL_TREE)
688 : : {
689 : 46 : is_init = true;
690 : 46 : *field_link = field;
691 : 46 : field_link = &DECL_CHAIN (field);
692 : : }
693 : :
694 : 10848 : for (s = head; s; s = s->next)
695 : : {
696 : 8107 : build_field (s, union_type, rli);
697 : :
698 : : /* Link the field into the type. */
699 : 8107 : *field_link = s->field;
700 : 8107 : field_link = &DECL_CHAIN (s->field);
701 : :
702 : : /* Has initial value. */
703 : 8107 : if (s->sym->value)
704 : 254 : is_init = true;
705 : :
706 : : /* Has SAVE attribute. */
707 : 8107 : if (s->sym->attr.save)
708 : 575 : is_saved = true;
709 : :
710 : : /* Has AUTOMATIC attribute. */
711 : 8107 : if (s->sym->attr.automatic)
712 : 14 : is_auto = true;
713 : : }
714 : :
715 : 2741 : finish_record_layout (rli, true);
716 : :
717 : 2741 : if (com)
718 : 2053 : decl = build_common_decl (com, union_type, is_init);
719 : : else
720 : 688 : decl = build_equiv_decl (union_type, is_init, is_saved, is_auto);
721 : :
722 : 2741 : if (is_init)
723 : : {
724 : 243 : tree ctor, tmp;
725 : 243 : vec<constructor_elt, va_gc> *v = NULL;
726 : :
727 : 243 : if (field != NULL_TREE && field_init != NULL_TREE)
728 : 46 : CONSTRUCTOR_APPEND_ELT (v, field, field_init);
729 : : else
730 : 605 : for (s = head; s; s = s->next)
731 : : {
732 : 408 : if (s->sym->value)
733 : : {
734 : : /* Add the initializer for this field. */
735 : 254 : tmp = gfc_conv_initializer (s->sym->value, &s->sym->ts,
736 : 254 : TREE_TYPE (s->field),
737 : : s->sym->attr.dimension,
738 : : s->sym->attr.pointer
739 : 254 : || s->sym->attr.allocatable, false);
740 : :
741 : 254 : CONSTRUCTOR_APPEND_ELT (v, s->field, tmp);
742 : : }
743 : : }
744 : :
745 : 243 : gcc_assert (!v->is_empty ());
746 : 243 : ctor = build_constructor (union_type, v);
747 : 243 : TREE_CONSTANT (ctor) = 1;
748 : 243 : TREE_STATIC (ctor) = 1;
749 : 243 : DECL_INITIAL (decl) = ctor;
750 : :
751 : 243 : if (flag_checking)
752 : : {
753 : : tree field, value;
754 : : unsigned HOST_WIDE_INT idx;
755 : 543 : FOR_EACH_CONSTRUCTOR_ELT (CONSTRUCTOR_ELTS (ctor), idx, field, value)
756 : 300 : gcc_assert (TREE_CODE (field) == FIELD_DECL);
757 : : }
758 : : }
759 : :
760 : : /* Build component reference for each variable. */
761 : 10848 : for (s = head; s; s = next_s)
762 : : {
763 : 8107 : tree var_decl;
764 : :
765 : 8107 : var_decl = build_decl (gfc_get_location (&s->sym->declared_at),
766 : 8107 : VAR_DECL, DECL_NAME (s->field),
767 : 8107 : TREE_TYPE (s->field));
768 : 8107 : TREE_STATIC (var_decl) = TREE_STATIC (decl);
769 : : /* Mark the variable as used in order to avoid warnings about
770 : : unused variables. */
771 : 8107 : TREE_USED (var_decl) = 1;
772 : 8107 : if (s->sym->attr.use_assoc)
773 : 436 : DECL_IGNORED_P (var_decl) = 1;
774 : 8107 : if (s->sym->attr.target)
775 : 66 : TREE_ADDRESSABLE (var_decl) = 1;
776 : : /* Fake variables are not visible from other translation units. */
777 : 8107 : TREE_PUBLIC (var_decl) = 0;
778 : 8107 : gfc_finish_decl_attrs (var_decl, &s->sym->attr);
779 : :
780 : : /* To preserve identifier names in COMMON, chain to procedure
781 : : scope unless at top level in a module definition. */
782 : 8107 : if (com
783 : 6347 : && s->sym->ns->proc_name
784 : 6276 : && s->sym->ns->proc_name->attr.flavor == FL_MODULE)
785 : 484 : var_decl = pushdecl_top_level (var_decl);
786 : : else
787 : 7623 : gfc_add_decl_to_function (var_decl);
788 : :
789 : 8107 : tree comp = build3_loc (input_location, COMPONENT_REF,
790 : 8107 : TREE_TYPE (s->field), decl, s->field, NULL_TREE);
791 : 8107 : if (TREE_THIS_VOLATILE (s->field))
792 : 3 : TREE_THIS_VOLATILE (comp) = 1;
793 : 8107 : SET_DECL_VALUE_EXPR (var_decl, comp);
794 : 8107 : DECL_HAS_VALUE_EXPR_P (var_decl) = 1;
795 : 8107 : GFC_DECL_COMMON_OR_EQUIV (var_decl) = 1;
796 : :
797 : 8107 : if (s->sym->attr.assign)
798 : : {
799 : 14 : gfc_allocate_lang_decl (var_decl);
800 : 14 : GFC_DECL_ASSIGN (var_decl) = 1;
801 : 14 : GFC_DECL_STRING_LEN (var_decl) = GFC_DECL_STRING_LEN (s->field);
802 : 14 : GFC_DECL_ASSIGN_ADDR (var_decl) = GFC_DECL_ASSIGN_ADDR (s->field);
803 : : }
804 : :
805 : 8107 : s->sym->backend_decl = var_decl;
806 : :
807 : 8107 : next_s = s->next;
808 : 8107 : free (s);
809 : : }
810 : 2741 : }
811 : :
812 : :
813 : : /* Given a symbol, find it in the current segment list. Returns NULL if
814 : : not found. */
815 : :
816 : : static segment_info *
817 : 7323 : find_segment_info (gfc_symbol *symbol)
818 : : {
819 : 7323 : segment_info *n;
820 : :
821 : 43377 : for (n = current_segment; n; n = n->next)
822 : : {
823 : 36063 : if (n->sym == symbol)
824 : : return n;
825 : : }
826 : :
827 : : return NULL;
828 : : }
829 : :
830 : :
831 : : /* Given an expression node, make sure it is a constant integer and return
832 : : the mpz_t value. */
833 : :
834 : : static mpz_t *
835 : 6084 : get_mpz (gfc_expr *e)
836 : : {
837 : :
838 : 0 : if (e->expr_type != EXPR_CONSTANT)
839 : 0 : gfc_internal_error ("get_mpz(): Not an integer constant");
840 : :
841 : 6084 : return &e->value.integer;
842 : : }
843 : :
844 : :
845 : : /* Given an array specification and an array reference, figure out the
846 : : array element number (zero based). Bounds and elements are guaranteed
847 : : to be constants. If something goes wrong we generate an error and
848 : : return zero. */
849 : :
850 : : static HOST_WIDE_INT
851 : 1427 : element_number (gfc_array_ref *ar)
852 : : {
853 : 1427 : mpz_t multiplier, offset, extent, n;
854 : 1427 : gfc_array_spec *as;
855 : 1427 : HOST_WIDE_INT i, rank;
856 : :
857 : 1427 : as = ar->as;
858 : 1427 : rank = as->rank;
859 : 1427 : mpz_init_set_ui (multiplier, 1);
860 : 1427 : mpz_init_set_ui (offset, 0);
861 : 1427 : mpz_init (extent);
862 : 1427 : mpz_init (n);
863 : :
864 : 4291 : for (i = 0; i < rank; i++)
865 : : {
866 : 1437 : if (ar->dimen_type[i] != DIMEN_ELEMENT)
867 : 0 : gfc_internal_error ("element_number(): Bad dimension type");
868 : :
869 : 1437 : if (as && as->lower[i])
870 : 1436 : mpz_sub (n, *get_mpz (ar->start[i]), *get_mpz (as->lower[i]));
871 : : else
872 : 1 : mpz_sub_ui (n, *get_mpz (ar->start[i]), 1);
873 : :
874 : 1437 : mpz_mul (n, n, multiplier);
875 : 1437 : mpz_add (offset, offset, n);
876 : :
877 : 1437 : if (as && as->upper[i] && as->lower[i])
878 : : {
879 : 1436 : mpz_sub (extent, *get_mpz (as->upper[i]), *get_mpz (as->lower[i]));
880 : 1436 : mpz_add_ui (extent, extent, 1);
881 : : }
882 : : else
883 : 1 : mpz_set_ui (extent, 0);
884 : :
885 : 1437 : if (mpz_sgn (extent) < 0)
886 : 0 : mpz_set_ui (extent, 0);
887 : :
888 : 1437 : mpz_mul (multiplier, multiplier, extent);
889 : : }
890 : :
891 : 1427 : i = mpz_get_ui (offset);
892 : :
893 : 1427 : mpz_clear (multiplier);
894 : 1427 : mpz_clear (offset);
895 : 1427 : mpz_clear (extent);
896 : 1427 : mpz_clear (n);
897 : :
898 : 1427 : return i;
899 : : }
900 : :
901 : :
902 : : /* Given a single element of an equivalence list, figure out the offset
903 : : from the base symbol. For simple variables or full arrays, this is
904 : : simply zero. For an array element we have to calculate the array
905 : : element number and multiply by the element size. For a substring we
906 : : have to calculate the further reference. */
907 : :
908 : : static HOST_WIDE_INT
909 : 3126 : calculate_offset (gfc_expr *e)
910 : : {
911 : 3126 : HOST_WIDE_INT n, element_size, offset;
912 : 3126 : gfc_typespec *element_type;
913 : 3126 : gfc_ref *reference;
914 : :
915 : 3126 : offset = 0;
916 : 3126 : element_type = &e->symtree->n.sym->ts;
917 : :
918 : 5320 : for (reference = e->ref; reference; reference = reference->next)
919 : 2194 : switch (reference->type)
920 : : {
921 : 1855 : case REF_ARRAY:
922 : 1855 : switch (reference->u.ar.type)
923 : : {
924 : : case AR_FULL:
925 : : break;
926 : :
927 : 1427 : case AR_ELEMENT:
928 : 1427 : n = element_number (&reference->u.ar);
929 : 1427 : if (element_type->type == BT_CHARACTER)
930 : 221 : gfc_conv_const_charlen (element_type->u.cl);
931 : 1427 : element_size =
932 : 1427 : int_size_in_bytes (gfc_typenode_for_spec (element_type));
933 : 1427 : offset += n * element_size;
934 : 1427 : break;
935 : :
936 : 0 : default:
937 : 0 : gfc_error ("Bad array reference at %L", &e->where);
938 : : }
939 : : break;
940 : 339 : case REF_SUBSTRING:
941 : 339 : if (reference->u.ss.start != NULL)
942 : 339 : offset += mpz_get_ui (*get_mpz (reference->u.ss.start)) - 1;
943 : : break;
944 : 0 : default:
945 : 0 : gfc_error ("Illegal reference type at %L as EQUIVALENCE object",
946 : : &e->where);
947 : : }
948 : 3126 : return offset;
949 : : }
950 : :
951 : :
952 : : /* Add a new segment_info structure to the current segment. eq1 is already
953 : : in the list, eq2 is not. */
954 : :
955 : : static void
956 : 1561 : new_condition (segment_info *v, gfc_equiv *eq1, gfc_equiv *eq2)
957 : : {
958 : 1561 : HOST_WIDE_INT offset1, offset2;
959 : 1561 : segment_info *a;
960 : :
961 : 1561 : offset1 = calculate_offset (eq1->expr);
962 : 1561 : offset2 = calculate_offset (eq2->expr);
963 : :
964 : 3122 : a = get_segment_info (eq2->expr->symtree->n.sym,
965 : 1561 : v->offset + offset1 - offset2);
966 : :
967 : 1561 : current_segment = add_segments (current_segment, a);
968 : 1561 : }
969 : :
970 : :
971 : : /* Given two equivalence structures that are both already in the list, make
972 : : sure that this new condition is not violated, generating an error if it
973 : : is. */
974 : :
975 : : static void
976 : 2 : confirm_condition (segment_info *s1, gfc_equiv *eq1, segment_info *s2,
977 : : gfc_equiv *eq2)
978 : : {
979 : 2 : HOST_WIDE_INT offset1, offset2;
980 : :
981 : 2 : offset1 = calculate_offset (eq1->expr);
982 : 2 : offset2 = calculate_offset (eq2->expr);
983 : :
984 : 2 : if (s1->offset + offset1 != s2->offset + offset2)
985 : 2 : gfc_error ("Inconsistent equivalence rules involving %qs at %L and "
986 : 2 : "%qs at %L", s1->sym->name, &s1->sym->declared_at,
987 : 2 : s2->sym->name, &s2->sym->declared_at);
988 : 2 : }
989 : :
990 : :
991 : : /* Process a new equivalence condition. eq1 is know to be in segment f.
992 : : If eq2 is also present then confirm that the condition holds.
993 : : Otherwise add a new variable to the segment list. */
994 : :
995 : : static void
996 : 1563 : add_condition (segment_info *f, gfc_equiv *eq1, gfc_equiv *eq2)
997 : : {
998 : 1563 : segment_info *n;
999 : :
1000 : 1563 : n = find_segment_info (eq2->expr->symtree->n.sym);
1001 : :
1002 : 1563 : if (n == NULL)
1003 : 1561 : new_condition (f, eq1, eq2);
1004 : : else
1005 : 2 : confirm_condition (f, eq1, n, eq2);
1006 : 1563 : }
1007 : :
1008 : : static void
1009 : 44745 : accumulate_equivalence_attributes (symbol_attribute *dummy_symbol, gfc_equiv *e)
1010 : : {
1011 : 44745 : symbol_attribute attr = e->expr->symtree->n.sym->attr;
1012 : :
1013 : 44745 : dummy_symbol->dummy |= attr.dummy;
1014 : 44745 : dummy_symbol->pointer |= attr.pointer;
1015 : 44745 : dummy_symbol->target |= attr.target;
1016 : 44745 : dummy_symbol->external |= attr.external;
1017 : 44745 : dummy_symbol->intrinsic |= attr.intrinsic;
1018 : 44745 : dummy_symbol->allocatable |= attr.allocatable;
1019 : 44745 : dummy_symbol->elemental |= attr.elemental;
1020 : 44745 : dummy_symbol->recursive |= attr.recursive;
1021 : 44745 : dummy_symbol->in_common |= attr.in_common;
1022 : 44745 : dummy_symbol->result |= attr.result;
1023 : 44745 : dummy_symbol->in_namelist |= attr.in_namelist;
1024 : 44745 : dummy_symbol->optional |= attr.optional;
1025 : 44745 : dummy_symbol->entry |= attr.entry;
1026 : 44745 : dummy_symbol->function |= attr.function;
1027 : 44745 : dummy_symbol->subroutine |= attr.subroutine;
1028 : 44745 : dummy_symbol->dimension |= attr.dimension;
1029 : 44745 : dummy_symbol->in_equivalence |= attr.in_equivalence;
1030 : 44745 : dummy_symbol->use_assoc |= attr.use_assoc;
1031 : 44745 : dummy_symbol->cray_pointer |= attr.cray_pointer;
1032 : 44745 : dummy_symbol->cray_pointee |= attr.cray_pointee;
1033 : 44745 : dummy_symbol->data |= attr.data;
1034 : 44745 : dummy_symbol->value |= attr.value;
1035 : 44745 : dummy_symbol->volatile_ |= attr.volatile_;
1036 : 44745 : dummy_symbol->is_protected |= attr.is_protected;
1037 : 44745 : dummy_symbol->is_bind_c |= attr.is_bind_c;
1038 : 44745 : dummy_symbol->procedure |= attr.procedure;
1039 : 44745 : dummy_symbol->proc_pointer |= attr.proc_pointer;
1040 : 44745 : dummy_symbol->abstract |= attr.abstract;
1041 : 44745 : dummy_symbol->asynchronous |= attr.asynchronous;
1042 : 44745 : dummy_symbol->codimension |= attr.codimension;
1043 : 44745 : dummy_symbol->contiguous |= attr.contiguous;
1044 : 44745 : dummy_symbol->generic |= attr.generic;
1045 : 44745 : dummy_symbol->automatic |= attr.automatic;
1046 : 44745 : dummy_symbol->threadprivate |= attr.threadprivate;
1047 : 44745 : dummy_symbol->omp_declare_target |= attr.omp_declare_target;
1048 : 44745 : dummy_symbol->omp_declare_target_link |= attr.omp_declare_target_link;
1049 : 44745 : dummy_symbol->oacc_declare_copyin |= attr.oacc_declare_copyin;
1050 : 44745 : dummy_symbol->oacc_declare_create |= attr.oacc_declare_create;
1051 : 44745 : dummy_symbol->oacc_declare_deviceptr |= attr.oacc_declare_deviceptr;
1052 : 44745 : dummy_symbol->oacc_declare_device_resident
1053 : 44745 : |= attr.oacc_declare_device_resident;
1054 : :
1055 : : /* Not strictly correct, but probably close enough. */
1056 : 44745 : if (attr.save > dummy_symbol->save)
1057 : 691 : dummy_symbol->save = attr.save;
1058 : 44745 : if (attr.access > dummy_symbol->access)
1059 : 4 : dummy_symbol->access = attr.access;
1060 : 44745 : }
1061 : :
1062 : : /* Given a segment element, search through the equivalence lists for unused
1063 : : conditions that involve the symbol. Add these rules to the segment. */
1064 : :
1065 : : static bool
1066 : 8095 : find_equivalence (segment_info *n)
1067 : : {
1068 : 8095 : gfc_equiv *e1, *e2, *eq;
1069 : 8095 : bool found;
1070 : :
1071 : 8095 : found = false;
1072 : :
1073 : 31002 : for (e1 = n->sym->ns->equiv; e1; e1 = e1->next)
1074 : : {
1075 : 22907 : eq = NULL;
1076 : :
1077 : : /* Search the equivalence list, including the root (first) element
1078 : : for the symbol that owns the segment. */
1079 : 22907 : symbol_attribute dummy_symbol;
1080 : 22907 : memset (&dummy_symbol, 0, sizeof (dummy_symbol));
1081 : 66136 : for (e2 = e1; e2; e2 = e2->eq)
1082 : : {
1083 : 44745 : accumulate_equivalence_attributes (&dummy_symbol, e2);
1084 : 44745 : if (!e2->used && e2->expr->symtree->n.sym == n->sym)
1085 : : {
1086 : : eq = e2;
1087 : : break;
1088 : : }
1089 : : }
1090 : :
1091 : 22907 : gfc_check_conflict (&dummy_symbol, e1->expr->symtree->name, &e1->expr->where);
1092 : :
1093 : : /* Go to the next root element. */
1094 : 22907 : if (eq == NULL)
1095 : 21391 : continue;
1096 : :
1097 : 1516 : eq->used = 1;
1098 : :
1099 : : /* Now traverse the equivalence list matching the offsets. */
1100 : 4595 : for (e2 = e1; e2; e2 = e2->eq)
1101 : : {
1102 : 3079 : if (!e2->used && e2 != eq)
1103 : : {
1104 : 1563 : add_condition (n, eq, e2);
1105 : 1563 : e2->used = 1;
1106 : 1563 : found = true;
1107 : : }
1108 : : }
1109 : : }
1110 : 8095 : return found;
1111 : : }
1112 : :
1113 : :
1114 : : /* Add all symbols equivalenced within a segment. We need to scan the
1115 : : segment list multiple times to include indirect equivalences. Since
1116 : : a new segment_info can inserted at the beginning of the segment list,
1117 : : depending on its offset, we have to force a final pass through the
1118 : : loop by demanding that completion sees a pass with no matches; i.e.,
1119 : : all symbols with equiv_built set and no new equivalences found. */
1120 : :
1121 : : static void
1122 : 6546 : add_equivalences (bool *saw_equiv)
1123 : : {
1124 : 6546 : segment_info *f;
1125 : 6546 : bool more = true;
1126 : :
1127 : 14248 : while (more)
1128 : : {
1129 : 7702 : more = false;
1130 : 17683 : for (f = current_segment; f; f = f->next)
1131 : : {
1132 : 9981 : if (!f->sym->equiv_built)
1133 : : {
1134 : 8095 : f->sym->equiv_built = 1;
1135 : 8095 : bool seen_one = find_equivalence (f);
1136 : 8095 : if (seen_one)
1137 : : {
1138 : 1163 : *saw_equiv = true;
1139 : 1163 : more = true;
1140 : : }
1141 : : }
1142 : : }
1143 : : }
1144 : :
1145 : : /* Add a copy of this segment list to the namespace. */
1146 : 6546 : copy_equiv_list_to_ns (current_segment);
1147 : 6546 : }
1148 : :
1149 : :
1150 : : /* Returns the offset necessary to properly align the current equivalence.
1151 : : Sets *palign to the required alignment. */
1152 : :
1153 : : static HOST_WIDE_INT
1154 : 6528 : align_segment (unsigned HOST_WIDE_INT *palign)
1155 : : {
1156 : 6528 : segment_info *s;
1157 : 6528 : unsigned HOST_WIDE_INT offset;
1158 : 6528 : unsigned HOST_WIDE_INT max_align;
1159 : 6528 : unsigned HOST_WIDE_INT this_align;
1160 : 6528 : unsigned HOST_WIDE_INT this_offset;
1161 : :
1162 : 6528 : max_align = 1;
1163 : 6528 : offset = 0;
1164 : 14617 : for (s = current_segment; s; s = s->next)
1165 : : {
1166 : 8089 : this_align = TYPE_ALIGN_UNIT (s->field);
1167 : 8089 : if (s->offset & (this_align - 1))
1168 : : {
1169 : : /* Field is misaligned. */
1170 : 128 : this_offset = this_align - ((s->offset + offset) & (this_align - 1));
1171 : 128 : if (this_offset & (max_align - 1))
1172 : : {
1173 : : /* Aligning this field would misalign a previous field. */
1174 : 0 : gfc_error ("The equivalence set for variable %qs "
1175 : : "declared at %L violates alignment requirements",
1176 : 0 : s->sym->name, &s->sym->declared_at);
1177 : : }
1178 : 128 : offset += this_offset;
1179 : : }
1180 : 8089 : max_align = this_align;
1181 : : }
1182 : 6528 : if (palign)
1183 : 6528 : *palign = max_align;
1184 : 6528 : return offset;
1185 : : }
1186 : :
1187 : :
1188 : : /* Adjust segment offsets by the given amount. */
1189 : :
1190 : : static void
1191 : 6546 : apply_segment_offset (segment_info *s, HOST_WIDE_INT offset)
1192 : : {
1193 : 14653 : for (; s; s = s->next)
1194 : 8107 : s->offset += offset;
1195 : 0 : }
1196 : :
1197 : :
1198 : : /* Lay out a symbol in a common block. If the symbol has already been seen
1199 : : then check the location is consistent. Otherwise create segments
1200 : : for that symbol and all the symbols equivalenced with it. */
1201 : :
1202 : : /* Translate a single common block. */
1203 : :
1204 : : static void
1205 : 1949 : translate_common (gfc_common_head *common, gfc_symbol *var_list)
1206 : : {
1207 : 1949 : gfc_symbol *sym;
1208 : 1949 : segment_info *s;
1209 : 1949 : segment_info *common_segment;
1210 : 1949 : HOST_WIDE_INT offset;
1211 : 1949 : HOST_WIDE_INT current_offset;
1212 : 1949 : unsigned HOST_WIDE_INT align;
1213 : 1949 : bool saw_equiv;
1214 : :
1215 : 1949 : common_segment = NULL;
1216 : 1949 : offset = 0;
1217 : 1949 : current_offset = 0;
1218 : 1949 : align = 1;
1219 : 1949 : saw_equiv = false;
1220 : :
1221 : 1949 : if (var_list && var_list->attr.omp_allocate)
1222 : 6 : gfc_error ("Sorry, !$OMP allocate for COMMON block variable %qs at %L "
1223 : 6 : "not supported", common->name, &common->where);
1224 : :
1225 : : /* Add symbols to the segment. */
1226 : 7709 : for (sym = var_list; sym; sym = sym->common_next)
1227 : : {
1228 : 5760 : current_segment = common_segment;
1229 : 5760 : s = find_segment_info (sym);
1230 : :
1231 : : /* Symbol has already been added via an equivalence. Multiple
1232 : : use associations of the same common block result in equiv_built
1233 : : being set but no information about the symbol in the segment. */
1234 : 5760 : if (s && sym->equiv_built)
1235 : : {
1236 : : /* Ensure the current location is properly aligned. */
1237 : 7 : align = TYPE_ALIGN_UNIT (s->field);
1238 : 7 : current_offset = (current_offset + align - 1) &~ (align - 1);
1239 : :
1240 : : /* Verify that it ended up where we expect it. */
1241 : 7 : if (s->offset != current_offset)
1242 : : {
1243 : 1 : gfc_error ("Equivalence for %qs does not match ordering of "
1244 : : "COMMON %qs at %L", sym->name,
1245 : 1 : common->name, &common->where);
1246 : : }
1247 : : }
1248 : : else
1249 : : {
1250 : : /* A symbol we haven't seen before. */
1251 : 5753 : s = current_segment = get_segment_info (sym, current_offset);
1252 : :
1253 : : /* Add all objects directly or indirectly equivalenced with this
1254 : : symbol. */
1255 : 5753 : add_equivalences (&saw_equiv);
1256 : :
1257 : 5753 : if (current_segment->offset < 0)
1258 : 0 : gfc_error ("The equivalence set for %qs cause an invalid "
1259 : : "extension to COMMON %qs at %L", sym->name,
1260 : 0 : common->name, &common->where);
1261 : :
1262 : 5753 : if (flag_align_commons)
1263 : 5735 : offset = align_segment (&align);
1264 : :
1265 : 5753 : if (offset)
1266 : : {
1267 : : /* The required offset conflicts with previous alignment
1268 : : requirements. Insert padding immediately before this
1269 : : segment. */
1270 : 37 : if (warn_align_commons)
1271 : : {
1272 : 35 : if (strcmp (common->name, BLANK_COMMON_NAME))
1273 : 23 : gfc_warning (OPT_Walign_commons,
1274 : : "Padding of %d bytes required before %qs in "
1275 : : "COMMON %qs at %L; reorder elements or use "
1276 : : "%<-fno-align-commons%>", (int)offset,
1277 : 23 : s->sym->name, common->name, &common->where);
1278 : : else
1279 : 12 : gfc_warning (OPT_Walign_commons,
1280 : : "Padding of %d bytes required before %qs in "
1281 : : "COMMON at %L; reorder elements or use "
1282 : : "%<-fno-align-commons%>", (int)offset,
1283 : 12 : s->sym->name, &common->where);
1284 : : }
1285 : : }
1286 : :
1287 : : /* Apply the offset to the new segments. */
1288 : 5753 : apply_segment_offset (current_segment, offset);
1289 : 5753 : current_offset += offset;
1290 : :
1291 : : /* Add the new segments to the common block. */
1292 : 5753 : common_segment = add_segments (common_segment, current_segment);
1293 : : }
1294 : :
1295 : : /* The offset of the next common variable. */
1296 : 5760 : current_offset += s->length;
1297 : : }
1298 : :
1299 : 1949 : if (common_segment == NULL)
1300 : : {
1301 : 1 : gfc_error ("COMMON %qs at %L does not exist",
1302 : 1 : common->name, &common->where);
1303 : 1 : return;
1304 : : }
1305 : :
1306 : 1948 : if (common_segment->offset != 0 && warn_align_commons)
1307 : : {
1308 : 0 : if (strcmp (common->name, BLANK_COMMON_NAME))
1309 : 0 : gfc_warning (OPT_Walign_commons,
1310 : : "COMMON %qs at %L requires %d bytes of padding; "
1311 : : "reorder elements or use %<-fno-align-commons%>",
1312 : : common->name, &common->where, (int)common_segment->offset);
1313 : : else
1314 : 0 : gfc_warning (OPT_Walign_commons,
1315 : : "COMMON at %L requires %d bytes of padding; "
1316 : : "reorder elements or use %<-fno-align-commons%>",
1317 : : &common->where, (int)common_segment->offset);
1318 : : }
1319 : :
1320 : 1948 : create_common (common, common_segment, saw_equiv);
1321 : : }
1322 : :
1323 : :
1324 : : /* Create a new block for each merged equivalence list. */
1325 : :
1326 : : static void
1327 : 89284 : finish_equivalences (gfc_namespace *ns)
1328 : : {
1329 : 89284 : gfc_equiv *z, *y;
1330 : 89284 : gfc_symbol *sym;
1331 : 89284 : gfc_common_head * c;
1332 : 89284 : HOST_WIDE_INT offset;
1333 : 89284 : unsigned HOST_WIDE_INT align;
1334 : 89284 : bool dummy;
1335 : :
1336 : 90800 : for (z = ns->equiv; z; z = z->next)
1337 : 2269 : for (y = z->eq; y; y = y->eq)
1338 : : {
1339 : 1546 : if (y->used)
1340 : 753 : continue;
1341 : 793 : sym = z->expr->symtree->n.sym;
1342 : 793 : current_segment = get_segment_info (sym, 0);
1343 : :
1344 : : /* All objects directly or indirectly equivalenced with this
1345 : : symbol. */
1346 : 793 : add_equivalences (&dummy);
1347 : :
1348 : : /* Align the block. */
1349 : 793 : offset = align_segment (&align);
1350 : :
1351 : : /* Ensure all offsets are positive. */
1352 : 793 : offset -= current_segment->offset & ~(align - 1);
1353 : :
1354 : 793 : apply_segment_offset (current_segment, offset);
1355 : :
1356 : : /* Create the decl. If this is a module equivalence, it has a
1357 : : unique name, pointed to by z->module. This is written to a
1358 : : gfc_common_header to push create_common into using
1359 : : build_common_decl, so that the equivalence appears as an
1360 : : external symbol. Otherwise, a local declaration is built using
1361 : : build_equiv_decl. */
1362 : 793 : if (z->module)
1363 : : {
1364 : 105 : c = gfc_get_common_head ();
1365 : : /* We've lost the real location, so use the location of the
1366 : : enclosing procedure. If we're in a BLOCK DATA block, then
1367 : : use the location in the sym_root. */
1368 : 105 : if (ns->proc_name)
1369 : 104 : c->where = ns->proc_name->declared_at;
1370 : 1 : else if (ns->is_block_data)
1371 : 1 : c->where = ns->sym_root->n.sym->declared_at;
1372 : :
1373 : 105 : size_t len = strlen (z->module);
1374 : 105 : gcc_assert (len < sizeof (c->name));
1375 : 105 : memcpy (c->name, z->module, len);
1376 : 105 : c->name[len] = '\0';
1377 : : }
1378 : : else
1379 : : c = NULL;
1380 : :
1381 : 793 : create_common (c, current_segment, true);
1382 : 793 : break;
1383 : : }
1384 : 89284 : }
1385 : :
1386 : :
1387 : : /* Work function for translating a named common block. */
1388 : :
1389 : : static void
1390 : 1763 : named_common (gfc_symtree *st)
1391 : : {
1392 : 1763 : translate_common (st->n.common, st->n.common->head);
1393 : 1763 : }
1394 : :
1395 : :
1396 : : /* Translate the common blocks in a namespace. Unlike other variables,
1397 : : these have to be created before code, because the backend_decl depends
1398 : : on the rest of the common block. */
1399 : :
1400 : : void
1401 : 89284 : gfc_trans_common (gfc_namespace *ns)
1402 : : {
1403 : 89284 : gfc_common_head *c;
1404 : :
1405 : : /* Translate the blank common block. */
1406 : 89284 : if (ns->blank_common.head != NULL)
1407 : : {
1408 : 186 : c = gfc_get_common_head ();
1409 : 186 : c->where = ns->blank_common.head->common_head->where;
1410 : 186 : strcpy (c->name, BLANK_COMMON_NAME);
1411 : 186 : translate_common (c, ns->blank_common.head);
1412 : : }
1413 : :
1414 : : /* Translate all named common blocks. */
1415 : 89284 : gfc_traverse_symtree (ns->common_root, named_common);
1416 : :
1417 : : /* Translate local equivalence. */
1418 : 89284 : finish_equivalences (ns);
1419 : :
1420 : : /* Commit the newly created symbols for common blocks and module
1421 : : equivalences. */
1422 : 89284 : gfc_commit_symbols ();
1423 : 89284 : }
|
