1 /* Common block and equivalence list handling
2 Copyright (C) 2000, 2003, 2004 Free Software Foundation, Inc.
3 Contributed by Canqun Yang <canqun@nudt.edu.cn>
5 This file is part of GCC.
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 2, or (at your option) any later
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
17 You should have received a copy of the GNU General Public License
18 along with GCC; see the file COPYING. If not, write to the Free
19 Software Foundation, 59 Temple Place - Suite 330, Boston, MA
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 Each segment is described by a chain of segment_info structures. Each
86 segment_info structure describes the extents of a single varible within
87 the segment. This list is maintained in the order the elements are
88 positioned withing the segment. If two elements have the same starting
89 offset the smaller will come first. If they also have the same size their
90 ordering is undefined.
92 Once all common blocks have been created, the list of equivalences
93 is examined for still-unused equivalence conditions. We create a
94 block for each merged equivalence list. */
98 #include "coretypes.h"
102 #include "gfortran.h"
104 #include "trans-types.h"
105 #include "trans-const.h"
109 /* Holds a single variable in a equivalence set. */
110 typedef struct segment_info
113 HOST_WIDE_INT offset
;
114 HOST_WIDE_INT length
;
115 /* This will contain the field type until the field is created. */
117 struct segment_info
*next
;
120 static segment_info
*current_segment
, *current_common
;
121 static HOST_WIDE_INT current_offset
;
122 static gfc_namespace
*gfc_common_ns
= NULL
;
124 #define BLANK_COMMON_NAME "__BLNK__"
126 /* Make a segment_info based on a symbol. */
128 static segment_info
*
129 get_segment_info (gfc_symbol
* sym
, HOST_WIDE_INT offset
)
133 /* Make sure we've got the character length. */
134 if (sym
->ts
.type
== BT_CHARACTER
)
135 gfc_conv_const_charlen (sym
->ts
.cl
);
137 /* Create the segment_info and fill it in. */
138 s
= (segment_info
*) gfc_getmem (sizeof (segment_info
));
140 /* We will use this type when building the segment aggreagate type. */
141 s
->field
= gfc_sym_type (sym
);
142 s
->length
= int_size_in_bytes (s
->field
);
148 /* Add combine segment V and segment LIST. */
150 static segment_info
*
151 add_segments (segment_info
*list
, segment_info
*v
)
162 /* Find the location of the new element. */
165 if (v
->offset
< s
->offset
)
167 if (v
->offset
== s
->offset
168 && v
->length
<= s
->length
)
175 /* Insert the new element in between p and s. */
190 /* Construct mangled common block name from symbol name. */
193 gfc_sym_mangled_common_id (const char *name
)
196 char mangled_name
[GFC_MAX_MANGLED_SYMBOL_LEN
+ 1];
198 if (strcmp (name
, BLANK_COMMON_NAME
) == 0)
199 return get_identifier (name
);
201 if (gfc_option
.flag_underscoring
)
203 has_underscore
= strchr (name
, '_') != 0;
204 if (gfc_option
.flag_second_underscore
&& has_underscore
)
205 snprintf (mangled_name
, sizeof mangled_name
, "%s__", name
);
207 snprintf (mangled_name
, sizeof mangled_name
, "%s_", name
);
209 return get_identifier (mangled_name
);
212 return get_identifier (name
);
216 /* Build a field declaration for a common variable or a local equivalence
220 build_field (segment_info
*h
, tree union_type
, record_layout_info rli
)
224 HOST_WIDE_INT offset
= h
->offset
;
225 unsigned HOST_WIDE_INT desired_align
, known_align
;
227 name
= get_identifier (h
->sym
->name
);
228 field
= build_decl (FIELD_DECL
, name
, h
->field
);
229 known_align
= (offset
& -offset
) * BITS_PER_UNIT
;
230 if (known_align
== 0 || known_align
> BIGGEST_ALIGNMENT
)
231 known_align
= BIGGEST_ALIGNMENT
;
233 desired_align
= update_alignment_for_field (rli
, field
, known_align
);
234 if (desired_align
> known_align
)
235 DECL_PACKED (field
) = 1;
237 DECL_FIELD_CONTEXT (field
) = union_type
;
238 DECL_FIELD_OFFSET (field
) = size_int (offset
);
239 DECL_FIELD_BIT_OFFSET (field
) = bitsize_zero_node
;
240 SET_DECL_OFFSET_ALIGN (field
, known_align
);
242 rli
->offset
= size_binop (MAX_EXPR
, rli
->offset
,
243 size_binop (PLUS_EXPR
,
244 DECL_FIELD_OFFSET (field
),
245 DECL_SIZE_UNIT (field
)));
250 /* Get storage for local equivalence. */
253 build_equiv_decl (tree union_type
, bool is_init
)
259 decl
= gfc_create_var (union_type
, "equiv");
260 TREE_STATIC (decl
) = 1;
264 decl
= build_decl (VAR_DECL
, NULL
, union_type
);
265 DECL_ARTIFICIAL (decl
) = 1;
267 DECL_COMMON (decl
) = 1;
269 TREE_ADDRESSABLE (decl
) = 1;
270 TREE_USED (decl
) = 1;
271 gfc_add_decl_to_function (decl
);
277 /* Get storage for common block. */
280 build_common_decl (gfc_common_head
*com
, tree union_type
, bool is_init
)
282 gfc_symbol
*common_sym
;
285 /* Create a namespace to store symbols for common blocks. */
286 if (gfc_common_ns
== NULL
)
287 gfc_common_ns
= gfc_get_namespace (NULL
);
289 gfc_get_symbol (com
->name
, gfc_common_ns
, &common_sym
);
290 decl
= common_sym
->backend_decl
;
292 /* Update the size of this common block as needed. */
293 if (decl
!= NULL_TREE
)
295 tree size
= TYPE_SIZE_UNIT (union_type
);
296 if (tree_int_cst_lt (DECL_SIZE_UNIT (decl
), size
))
298 /* Named common blocks of the same name shall be of the same size
299 in all scoping units of a program in which they appear, but
300 blank common blocks may be of different sizes. */
301 if (strcmp (com
->name
, BLANK_COMMON_NAME
))
302 gfc_warning ("Named COMMON block '%s' at %L shall be of the "
303 "same size", com
->name
, &com
->where
);
304 DECL_SIZE_UNIT (decl
) = size
;
308 /* If this common block has been declared in a previous program unit,
309 and either it is already initialized or there is no new initialization
310 for it, just return. */
311 if ((decl
!= NULL_TREE
) && (!is_init
|| DECL_INITIAL (decl
)))
314 /* If there is no backend_decl for the common block, build it. */
315 if (decl
== NULL_TREE
)
317 decl
= build_decl (VAR_DECL
, get_identifier (com
->name
), union_type
);
318 SET_DECL_ASSEMBLER_NAME (decl
, gfc_sym_mangled_common_id (com
->name
));
319 TREE_PUBLIC (decl
) = 1;
320 TREE_STATIC (decl
) = 1;
321 DECL_ALIGN (decl
) = BIGGEST_ALIGNMENT
;
322 DECL_USER_ALIGN (decl
) = 0;
324 /* Place the back end declaration for this common block in
325 GLOBAL_BINDING_LEVEL. */
326 common_sym
->backend_decl
= pushdecl_top_level (decl
);
329 /* Has no initial values. */
332 DECL_INITIAL (decl
) = NULL_TREE
;
333 DECL_COMMON (decl
) = 1;
334 DECL_DEFER_OUTPUT (decl
) = 1;
338 DECL_INITIAL (decl
) = error_mark_node
;
339 DECL_COMMON (decl
) = 0;
340 DECL_DEFER_OUTPUT (decl
) = 0;
346 /* Declare memory for the common block or local equivalence, and create
347 backend declarations for all of the elements. */
350 create_common (gfc_common_head
*com
)
352 segment_info
*s
, *next_s
;
355 record_layout_info rli
;
357 bool is_init
= false;
359 /* Declare the variables inside the common block. */
360 union_type
= make_node (UNION_TYPE
);
361 rli
= start_record_layout (union_type
);
362 field_link
= &TYPE_FIELDS (union_type
);
364 for (s
= current_common
; s
; s
= s
->next
)
366 build_field (s
, union_type
, rli
);
368 /* Link the field into the type. */
369 *field_link
= s
->field
;
370 field_link
= &TREE_CHAIN (s
->field
);
372 /* Has initial value. */
376 finish_record_layout (rli
, true);
379 decl
= build_common_decl (com
, union_type
, is_init
);
381 decl
= build_equiv_decl (union_type
, is_init
);
385 tree list
, ctor
, tmp
;
386 HOST_WIDE_INT offset
= 0;
389 for (s
= current_common
; s
; s
= s
->next
)
393 if (s
->offset
< offset
)
395 /* We have overlapping initializers. It could either be
396 partially initilalized arrays (legal), or the user
397 specified multiple initial values (illegal).
398 We don't implement this yet, so bail out. */
399 gfc_todo_error ("Initialization of overlapping variables");
401 /* Add the initializer for this field. */
402 tmp
= gfc_conv_initializer (s
->sym
->value
, &s
->sym
->ts
,
403 TREE_TYPE (s
->field
), s
->sym
->attr
.dimension
,
404 s
->sym
->attr
.pointer
|| s
->sym
->attr
.allocatable
);
405 list
= tree_cons (s
->field
, tmp
, list
);
406 offset
= s
->offset
+ s
->length
;
410 ctor
= build1 (CONSTRUCTOR
, union_type
, nreverse(list
));
411 TREE_CONSTANT (ctor
) = 1;
412 TREE_INVARIANT (ctor
) = 1;
413 TREE_STATIC (ctor
) = 1;
414 DECL_INITIAL (decl
) = ctor
;
416 #ifdef ENABLE_CHECKING
417 for (tmp
= CONSTRUCTOR_ELTS (ctor
); tmp
; tmp
= TREE_CHAIN (tmp
))
418 assert (TREE_CODE (TREE_PURPOSE (tmp
)) == FIELD_DECL
);
422 /* Build component reference for each variable. */
423 for (s
= current_common
; s
; s
= next_s
)
425 s
->sym
->backend_decl
= build (COMPONENT_REF
, TREE_TYPE (s
->field
),
426 decl
, s
->field
, NULL_TREE
);
434 /* Given a symbol, find it in the current segment list. Returns NULL if
437 static segment_info
*
438 find_segment_info (gfc_symbol
*symbol
)
442 for (n
= current_segment
; n
; n
= n
->next
)
444 if (n
->sym
== symbol
)
452 /* Given an expression node, make sure it is a constant integer and return
456 get_mpz (gfc_expr
*e
)
459 if (e
->expr_type
!= EXPR_CONSTANT
)
460 gfc_internal_error ("get_mpz(): Not an integer constant");
462 return &e
->value
.integer
;
466 /* Given an array specification and an array reference, figure out the
467 array element number (zero based). Bounds and elements are guaranteed
468 to be constants. If something goes wrong we generate an error and
472 element_number (gfc_array_ref
*ar
)
474 mpz_t multiplier
, offset
, extent
, n
;
476 HOST_WIDE_INT i
, rank
;
480 mpz_init_set_ui (multiplier
, 1);
481 mpz_init_set_ui (offset
, 0);
485 for (i
= 0; i
< rank
; i
++)
487 if (ar
->dimen_type
[i
] != DIMEN_ELEMENT
)
488 gfc_internal_error ("element_number(): Bad dimension type");
490 mpz_sub (n
, *get_mpz (ar
->start
[i
]), *get_mpz (as
->lower
[i
]));
492 mpz_mul (n
, n
, multiplier
);
493 mpz_add (offset
, offset
, n
);
495 mpz_sub (extent
, *get_mpz (as
->upper
[i
]), *get_mpz (as
->lower
[i
]));
496 mpz_add_ui (extent
, extent
, 1);
498 if (mpz_sgn (extent
) < 0)
499 mpz_set_ui (extent
, 0);
501 mpz_mul (multiplier
, multiplier
, extent
);
504 i
= mpz_get_ui (offset
);
506 mpz_clear (multiplier
);
515 /* Given a single element of an equivalence list, figure out the offset
516 from the base symbol. For simple variables or full arrays, this is
517 simply zero. For an array element we have to calculate the array
518 element number and multiply by the element size. For a substring we
519 have to calculate the further reference. */
522 calculate_offset (gfc_expr
*e
)
524 HOST_WIDE_INT n
, element_size
, offset
;
525 gfc_typespec
*element_type
;
529 element_type
= &e
->symtree
->n
.sym
->ts
;
531 for (reference
= e
->ref
; reference
; reference
= reference
->next
)
532 switch (reference
->type
)
535 switch (reference
->u
.ar
.type
)
541 n
= element_number (&reference
->u
.ar
);
542 if (element_type
->type
== BT_CHARACTER
)
543 gfc_conv_const_charlen (element_type
->cl
);
545 int_size_in_bytes (gfc_typenode_for_spec (element_type
));
546 offset
+= n
* element_size
;
550 gfc_error ("Bad array reference at %L", &e
->where
);
554 if (reference
->u
.ss
.start
!= NULL
)
555 offset
+= mpz_get_ui (*get_mpz (reference
->u
.ss
.start
)) - 1;
558 gfc_error ("Illegal reference type at %L as EQUIVALENCE object",
565 /* Add a new segment_info structure to the current segment. eq1 is already
566 in the list, eq2 is not. */
569 new_condition (segment_info
*v
, gfc_equiv
*eq1
, gfc_equiv
*eq2
)
571 HOST_WIDE_INT offset1
, offset2
;
574 offset1
= calculate_offset (eq1
->expr
);
575 offset2
= calculate_offset (eq2
->expr
);
577 a
= get_segment_info (eq2
->expr
->symtree
->n
.sym
,
578 v
->offset
+ offset1
- offset2
);
580 current_segment
= add_segments (current_segment
, a
);
584 /* Given two equivalence structures that are both already in the list, make
585 sure that this new condition is not violated, generating an error if it
589 confirm_condition (segment_info
*s1
, gfc_equiv
*eq1
, segment_info
*s2
,
592 HOST_WIDE_INT offset1
, offset2
;
594 offset1
= calculate_offset (eq1
->expr
);
595 offset2
= calculate_offset (eq2
->expr
);
597 if (s1
->offset
+ offset1
!= s2
->offset
+ offset2
)
598 gfc_error ("Inconsistent equivalence rules involving '%s' at %L and "
599 "'%s' at %L", s1
->sym
->name
, &s1
->sym
->declared_at
,
600 s2
->sym
->name
, &s2
->sym
->declared_at
);
604 /* Process a new equivalence condition. eq1 is know to be in segment f.
605 If eq2 is also present then confirm that the condition holds.
606 Otherwise add a new variable to the segment list. */
609 add_condition (segment_info
*f
, gfc_equiv
*eq1
, gfc_equiv
*eq2
)
613 n
= find_segment_info (eq2
->expr
->symtree
->n
.sym
);
616 new_condition (f
, eq1
, eq2
);
618 confirm_condition (f
, eq1
, n
, eq2
);
622 /* Given a segment element, search through the equivalence lists for unused
623 conditions that involve the symbol. Add these rules to the segment. Only
624 checks for rules involving the first symbol in the equivalence set. */
627 find_equivalence (segment_info
*n
)
629 gfc_equiv
*e1
, *e2
, *eq
, *other
;
633 for (e1
= n
->sym
->ns
->equiv
; e1
; e1
= e1
->next
)
636 for (e2
= e1
->eq
; e2
; e2
= e2
->eq
)
641 if (e1
->expr
->symtree
->n
.sym
== n
->sym
)
646 else if (e2
->expr
->symtree
->n
.sym
== n
->sym
)
656 add_condition (n
, eq
, other
);
659 /* If this symbol is the first in the chain we may find other
660 matches. Otherwise we can skip to the next equivalence. */
670 /* Add all symbols equivalenced within a segment. We need to scan the
671 segment list multiple times to include indirect equivalences. */
674 add_equivalences (void)
683 for (f
= current_segment
; f
; f
= f
->next
)
685 if (!f
->sym
->equiv_built
)
687 f
->sym
->equiv_built
= 1;
688 more
= find_equivalence (f
);
695 /* Given a seed symbol, create a new segment consisting of that symbol
696 and all of the symbols equivalenced with that symbol. */
699 new_segment (gfc_common_head
*common
, gfc_symbol
*sym
)
702 current_segment
= get_segment_info (sym
, current_offset
);
704 /* The offset of the next common variable. */
705 current_offset
+= current_segment
->length
;
707 /* Add all object directly or indirectly equivalenced with this common
711 if (current_segment
->offset
< 0)
712 gfc_error ("The equivalence set for '%s' cause an invalid "
713 "extension to COMMON '%s' at %L", sym
->name
,
714 common
->name
, &common
->where
);
716 /* Add these to the common block. */
717 current_common
= add_segments (current_common
, current_segment
);
721 /* Create a new block for each merged equivalence list. */
724 finish_equivalences (gfc_namespace
*ns
)
729 HOST_WIDE_INT min_offset
;
731 for (z
= ns
->equiv
; z
; z
= z
->next
)
732 for (y
= z
->eq
; y
; y
= y
->eq
)
736 sym
= z
->expr
->symtree
->n
.sym
;
737 current_segment
= get_segment_info (sym
, 0);
739 /* All objects directly or indrectly equivalenced with this symbol. */
742 /* Calculate the minimal offset. */
743 min_offset
= current_segment
->offset
;
745 /* Adjust the offset of each equivalence object. */
746 for (v
= current_segment
; v
; v
= v
->next
)
747 v
->offset
-= min_offset
;
749 current_common
= current_segment
;
750 create_common (NULL
);
756 /* Translate a single common block. */
759 translate_common (gfc_common_head
*common
, gfc_symbol
*var_list
)
763 current_common
= NULL
;
766 /* Add symbols to the segment. */
767 for (sym
= var_list
; sym
; sym
= sym
->common_next
)
769 if (! sym
->equiv_built
)
770 new_segment (common
, sym
);
773 create_common (common
);
777 /* Work function for translating a named common block. */
780 named_common (gfc_symtree
*st
)
783 translate_common (st
->n
.common
, st
->n
.common
->head
);
787 /* Translate the common blocks in a namespace. Unlike other variables,
788 these have to be created before code, because the backend_decl depends
789 on the rest of the common block. */
792 gfc_trans_common (gfc_namespace
*ns
)
796 /* Translate the blank common block. */
797 if (ns
->blank_common
.head
!= NULL
)
799 c
= gfc_get_common_head ();
800 strcpy (c
->name
, BLANK_COMMON_NAME
);
801 translate_common (c
, ns
->blank_common
.head
);
804 /* Translate all named common blocks. */
805 gfc_traverse_symtree (ns
->common_root
, named_common
);
807 /* Commit the newly created symbols for common blocks. */
808 gfc_commit_symbols ();
810 /* Translate local equivalence. */
811 finish_equivalences (ns
);