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