1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- E X P _ U N S T -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 2014-2019, Free Software Foundation, Inc. -- 10-- -- 11-- GNAT is free software; you can redistribute it and/or modify it under -- 12-- terms of the GNU General Public License as published by the Free Soft- -- 13-- ware Foundation; either version 3, or (at your option) any later ver- -- 14-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 15-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 16-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- 17-- for more details. You should have received a copy of the GNU General -- 18-- Public License distributed with GNAT; see file COPYING3. If not, go to -- 19-- http://www.gnu.org/licenses for a complete copy of the license. -- 20-- -- 21-- GNAT was originally developed by the GNAT team at New York University. -- 22-- Extensive contributions were provided by Ada Core Technologies Inc. -- 23-- -- 24------------------------------------------------------------------------------ 25 26with Atree; use Atree; 27with Debug; use Debug; 28with Einfo; use Einfo; 29with Elists; use Elists; 30with Exp_Util; use Exp_Util; 31with Lib; use Lib; 32with Namet; use Namet; 33with Nlists; use Nlists; 34with Nmake; use Nmake; 35with Opt; 36with Output; use Output; 37with Rtsfind; use Rtsfind; 38with Sem; use Sem; 39with Sem_Aux; use Sem_Aux; 40with Sem_Ch8; use Sem_Ch8; 41with Sem_Mech; use Sem_Mech; 42with Sem_Res; use Sem_Res; 43with Sem_Util; use Sem_Util; 44with Sinfo; use Sinfo; 45with Sinput; use Sinput; 46with Snames; use Snames; 47with Stand; use Stand; 48with Tbuild; use Tbuild; 49with Uintp; use Uintp; 50 51package body Exp_Unst is 52 53 ----------------------- 54 -- Local Subprograms -- 55 ----------------------- 56 57 procedure Unnest_Subprogram 58 (Subp : Entity_Id; Subp_Body : Node_Id; For_Inline : Boolean := False); 59 -- Subp is a library-level subprogram which has nested subprograms, and 60 -- Subp_Body is the corresponding N_Subprogram_Body node. This procedure 61 -- declares the AREC types and objects, adds assignments to the AREC record 62 -- as required, defines the xxxPTR types for uplevel referenced objects, 63 -- adds the ARECP parameter to all nested subprograms which need it, and 64 -- modifies all uplevel references appropriately. If For_Inline is True, 65 -- we're unnesting this subprogram because it's on the list of inlined 66 -- subprograms and should unnest it despite it not being part of the main 67 -- unit. 68 69 ----------- 70 -- Calls -- 71 ----------- 72 73 -- Table to record calls within the nest being analyzed. These are the 74 -- calls which may need to have an AREC actual added. This table is built 75 -- new for each subprogram nest and cleared at the end of processing each 76 -- subprogram nest. 77 78 type Call_Entry is record 79 N : Node_Id; 80 -- The actual call 81 82 Caller : Entity_Id; 83 -- Entity of the subprogram containing the call (can be at any level) 84 85 Callee : Entity_Id; 86 -- Entity of the subprogram called (always at level 2 or higher). Note 87 -- that in accordance with the basic rules of nesting, the level of To 88 -- is either less than or equal to the level of From, or one greater. 89 end record; 90 91 package Calls is new Table.Table ( 92 Table_Component_Type => Call_Entry, 93 Table_Index_Type => Nat, 94 Table_Low_Bound => 1, 95 Table_Initial => 100, 96 Table_Increment => 200, 97 Table_Name => "Unnest_Calls"); 98 -- Records each call within the outer subprogram and all nested subprograms 99 -- that are to other subprograms nested within the outer subprogram. These 100 -- are the calls that may need an additional parameter. 101 102 procedure Append_Unique_Call (Call : Call_Entry); 103 -- Append a call entry to the Calls table. A check is made to see if the 104 -- table already contains this entry and if so it has no effect. 105 106 ---------------------------------- 107 -- Subprograms For Fat Pointers -- 108 ---------------------------------- 109 110 function Build_Access_Type_Decl 111 (E : Entity_Id; 112 Scop : Entity_Id) return Node_Id; 113 -- For an uplevel reference that involves an unconstrained array type, 114 -- build an access type declaration for the corresponding activation 115 -- record component. The relevant attributes of the access type are 116 -- set here to avoid a full analysis that would require a scope stack. 117 118 function Needs_Fat_Pointer (E : Entity_Id) return Boolean; 119 -- A formal parameter of an unconstrained array type that appears in an 120 -- uplevel reference requires the construction of an access type, to be 121 -- used in the corresponding component declaration. 122 123 ----------- 124 -- Urefs -- 125 ----------- 126 127 -- Table to record explicit uplevel references to objects (variables, 128 -- constants, formal parameters). These are the references that will 129 -- need rewriting to use the activation table (AREC) pointers. Also 130 -- included are implicit and explicit uplevel references to types, but 131 -- these do not get rewritten by the front end. This table is built new 132 -- for each subprogram nest and cleared at the end of processing each 133 -- subprogram nest. 134 135 type Uref_Entry is record 136 Ref : Node_Id; 137 -- The reference itself. For objects this is always an entity reference 138 -- and the referenced entity will have its Is_Uplevel_Referenced_Entity 139 -- flag set and will appear in the Uplevel_Referenced_Entities list of 140 -- the subprogram declaring this entity. 141 142 Ent : Entity_Id; 143 -- The Entity_Id of the uplevel referenced object or type 144 145 Caller : Entity_Id; 146 -- The entity for the subprogram immediately containing this entity 147 148 Callee : Entity_Id; 149 -- The entity for the subprogram containing the referenced entity. Note 150 -- that the level of Callee must be less than the level of Caller, since 151 -- this is an uplevel reference. 152 end record; 153 154 package Urefs is new Table.Table ( 155 Table_Component_Type => Uref_Entry, 156 Table_Index_Type => Nat, 157 Table_Low_Bound => 1, 158 Table_Initial => 100, 159 Table_Increment => 200, 160 Table_Name => "Unnest_Urefs"); 161 162 ------------------------ 163 -- Append_Unique_Call -- 164 ------------------------ 165 166 procedure Append_Unique_Call (Call : Call_Entry) is 167 begin 168 for J in Calls.First .. Calls.Last loop 169 if Calls.Table (J) = Call then 170 return; 171 end if; 172 end loop; 173 174 Calls.Append (Call); 175 end Append_Unique_Call; 176 177 ----------------------------- 178 -- Build_Access_Type_Decl -- 179 ----------------------------- 180 181 function Build_Access_Type_Decl 182 (E : Entity_Id; 183 Scop : Entity_Id) return Node_Id 184 is 185 Loc : constant Source_Ptr := Sloc (E); 186 Typ : Entity_Id; 187 188 begin 189 Typ := Make_Temporary (Loc, 'S'); 190 Set_Ekind (Typ, E_General_Access_Type); 191 Set_Etype (Typ, Typ); 192 Set_Scope (Typ, Scop); 193 Set_Directly_Designated_Type (Typ, Etype (E)); 194 195 return 196 Make_Full_Type_Declaration (Loc, 197 Defining_Identifier => Typ, 198 Type_Definition => 199 Make_Access_To_Object_Definition (Loc, 200 Subtype_Indication => New_Occurrence_Of (Etype (E), Loc))); 201 end Build_Access_Type_Decl; 202 203 --------------- 204 -- Get_Level -- 205 --------------- 206 207 function Get_Level (Subp : Entity_Id; Sub : Entity_Id) return Nat is 208 Lev : Nat; 209 S : Entity_Id; 210 211 begin 212 Lev := 1; 213 S := Sub; 214 loop 215 if S = Subp then 216 return Lev; 217 else 218 Lev := Lev + 1; 219 S := Enclosing_Subprogram (S); 220 end if; 221 end loop; 222 end Get_Level; 223 224 -------------------------- 225 -- In_Synchronized_Unit -- 226 -------------------------- 227 228 function In_Synchronized_Unit (Subp : Entity_Id) return Boolean is 229 S : Entity_Id := Scope (Subp); 230 231 begin 232 while Present (S) and then S /= Standard_Standard loop 233 if Is_Concurrent_Type (S) then 234 return True; 235 236 elsif Is_Private_Type (S) 237 and then Present (Full_View (S)) 238 and then Is_Concurrent_Type (Full_View (S)) 239 then 240 return True; 241 end if; 242 243 S := Scope (S); 244 end loop; 245 246 return False; 247 end In_Synchronized_Unit; 248 249 ----------------------- 250 -- Needs_Fat_Pointer -- 251 ----------------------- 252 253 function Needs_Fat_Pointer (E : Entity_Id) return Boolean is 254 Typ : Entity_Id; 255 begin 256 if Is_Formal (E) then 257 Typ := Etype (E); 258 if Is_Private_Type (Typ) and then Present (Full_View (Typ)) then 259 Typ := Full_View (Typ); 260 end if; 261 262 return Is_Array_Type (Typ) and then not Is_Constrained (Typ); 263 else 264 return False; 265 end if; 266 end Needs_Fat_Pointer; 267 268 ---------------- 269 -- Subp_Index -- 270 ---------------- 271 272 function Subp_Index (Sub : Entity_Id) return SI_Type is 273 E : Entity_Id := Sub; 274 275 begin 276 pragma Assert (Is_Subprogram (E)); 277 278 if Subps_Index (E) = Uint_0 then 279 E := Ultimate_Alias (E); 280 281 -- The body of a protected operation has a different name and 282 -- has been scanned at this point, and thus has an entry in the 283 -- subprogram table. 284 285 if E = Sub and then Convention (E) = Convention_Protected then 286 E := Protected_Body_Subprogram (E); 287 end if; 288 289 if Ekind (E) = E_Function 290 and then Rewritten_For_C (E) 291 and then Present (Corresponding_Procedure (E)) 292 then 293 E := Corresponding_Procedure (E); 294 end if; 295 end if; 296 297 pragma Assert (Subps_Index (E) /= Uint_0); 298 return SI_Type (UI_To_Int (Subps_Index (E))); 299 end Subp_Index; 300 301 ----------------------- 302 -- Unnest_Subprogram -- 303 ----------------------- 304 305 procedure Unnest_Subprogram 306 (Subp : Entity_Id; Subp_Body : Node_Id; For_Inline : Boolean := False) is 307 function AREC_Name (J : Pos; S : String) return Name_Id; 308 -- Returns name for string ARECjS, where j is the decimal value of j 309 310 function Enclosing_Subp (Subp : SI_Type) return SI_Type; 311 -- Subp is the index of a subprogram which has a Lev greater than 1. 312 -- This function returns the index of the enclosing subprogram which 313 -- will have a Lev value one less than this. 314 315 function Img_Pos (N : Pos) return String; 316 -- Return image of N without leading blank 317 318 function Upref_Name 319 (Ent : Entity_Id; 320 Index : Pos; 321 Clist : List_Id) return Name_Id; 322 -- This function returns the name to be used in the activation record to 323 -- reference the variable uplevel. Clist is the list of components that 324 -- have been created in the activation record so far. Normally the name 325 -- is just a copy of the Chars field of the entity. The exception is 326 -- when the name has already been used, in which case we suffix the name 327 -- with the index value Index to avoid duplication. This happens with 328 -- declare blocks and generic parameters at least. 329 330 --------------- 331 -- AREC_Name -- 332 --------------- 333 334 function AREC_Name (J : Pos; S : String) return Name_Id is 335 begin 336 return Name_Find ("AREC" & Img_Pos (J) & S); 337 end AREC_Name; 338 339 -------------------- 340 -- Enclosing_Subp -- 341 -------------------- 342 343 function Enclosing_Subp (Subp : SI_Type) return SI_Type is 344 STJ : Subp_Entry renames Subps.Table (Subp); 345 Ret : constant SI_Type := Subp_Index (Enclosing_Subprogram (STJ.Ent)); 346 begin 347 pragma Assert (STJ.Lev > 1); 348 pragma Assert (Subps.Table (Ret).Lev = STJ.Lev - 1); 349 return Ret; 350 end Enclosing_Subp; 351 352 ------------- 353 -- Img_Pos -- 354 ------------- 355 356 function Img_Pos (N : Pos) return String is 357 Buf : String (1 .. 20); 358 Ptr : Natural; 359 NV : Nat; 360 361 begin 362 Ptr := Buf'Last; 363 NV := N; 364 while NV /= 0 loop 365 Buf (Ptr) := Character'Val (48 + NV mod 10); 366 Ptr := Ptr - 1; 367 NV := NV / 10; 368 end loop; 369 370 return Buf (Ptr + 1 .. Buf'Last); 371 end Img_Pos; 372 373 ---------------- 374 -- Upref_Name -- 375 ---------------- 376 377 function Upref_Name 378 (Ent : Entity_Id; 379 Index : Pos; 380 Clist : List_Id) return Name_Id 381 is 382 C : Node_Id; 383 begin 384 C := First (Clist); 385 loop 386 if No (C) then 387 return Chars (Ent); 388 389 elsif Chars (Defining_Identifier (C)) = Chars (Ent) then 390 return 391 Name_Find (Get_Name_String (Chars (Ent)) & Img_Pos (Index)); 392 else 393 Next (C); 394 end if; 395 end loop; 396 end Upref_Name; 397 398 -- Start of processing for Unnest_Subprogram 399 400 begin 401 -- Nothing to do inside a generic (all processing is for instance) 402 403 if Inside_A_Generic then 404 return; 405 end if; 406 407 -- If the main unit is a package body then we need to examine the spec 408 -- to determine whether the main unit is generic (the scope stack is not 409 -- present when this is called on the main unit). 410 411 if not For_Inline 412 and then Ekind (Cunit_Entity (Main_Unit)) = E_Package_Body 413 and then Is_Generic_Unit (Spec_Entity (Cunit_Entity (Main_Unit))) 414 then 415 return; 416 417 -- Only unnest when generating code for the main source unit or if 418 -- we're unnesting for inline. But in some Annex E cases the Sloc 419 -- points to a different unit, so also make sure that the Parent 420 -- isn't in something that we know we're generating code for. 421 422 elsif not For_Inline 423 and then not In_Extended_Main_Code_Unit (Subp_Body) 424 and then not In_Extended_Main_Code_Unit (Parent (Subp_Body)) 425 then 426 return; 427 end if; 428 429 -- This routine is called late, after the scope stack is gone. The 430 -- following creates a suitable dummy scope stack to be used for the 431 -- analyze/expand calls made from this routine. 432 433 Push_Scope (Subp); 434 435 -- First step, we must mark all nested subprograms that require a static 436 -- link (activation record) because either they contain explicit uplevel 437 -- references (as indicated by Is_Uplevel_Referenced_Entity being set at 438 -- this point), or they make calls to other subprograms in the same nest 439 -- that require a static link (in which case we set this flag). 440 441 -- This is a recursive definition, and to implement this, we have to 442 -- build a call graph for the set of nested subprograms, and then go 443 -- over this graph to implement recursively the invariant that if a 444 -- subprogram has a call to a subprogram requiring a static link, then 445 -- the calling subprogram requires a static link. 446 447 -- First populate the above tables 448 449 Subps_First := Subps.Last + 1; 450 Calls.Init; 451 Urefs.Init; 452 453 Build_Tables : declare 454 Current_Subprogram : Entity_Id := Empty; 455 -- When we scan a subprogram body, we set Current_Subprogram to the 456 -- corresponding entity. This gets recursively saved and restored. 457 458 function Visit_Node (N : Node_Id) return Traverse_Result; 459 -- Visit a single node in Subp 460 461 ----------- 462 -- Visit -- 463 ----------- 464 465 procedure Visit is new Traverse_Proc (Visit_Node); 466 -- Used to traverse the body of Subp, populating the tables 467 468 ---------------- 469 -- Visit_Node -- 470 ---------------- 471 472 function Visit_Node (N : Node_Id) return Traverse_Result is 473 Ent : Entity_Id; 474 Caller : Entity_Id; 475 Callee : Entity_Id; 476 477 procedure Check_Static_Type 478 (T : Entity_Id; 479 N : Node_Id; 480 DT : in out Boolean; 481 Check_Designated : Boolean := False); 482 -- Given a type T, checks if it is a static type defined as a type 483 -- with no dynamic bounds in sight. If so, the only action is to 484 -- set Is_Static_Type True for T. If T is not a static type, then 485 -- all types with dynamic bounds associated with T are detected, 486 -- and their bounds are marked as uplevel referenced if not at the 487 -- library level, and DT is set True. If N is specified, it's the 488 -- node that will need to be replaced. If not specified, it means 489 -- we can't do a replacement because the bound is implicit. 490 491 -- If Check_Designated is True and T or its full view is an access 492 -- type, check whether the designated type has dynamic bounds. 493 494 procedure Note_Uplevel_Ref 495 (E : Entity_Id; 496 N : Node_Id; 497 Caller : Entity_Id; 498 Callee : Entity_Id); 499 -- Called when we detect an explicit or implicit uplevel reference 500 -- from within Caller to entity E declared in Callee. E can be a 501 -- an object or a type. 502 503 procedure Register_Subprogram (E : Entity_Id; Bod : Node_Id); 504 -- Enter a subprogram whose body is visible or which is a 505 -- subprogram instance into the subprogram table. 506 507 ----------------------- 508 -- Check_Static_Type -- 509 ----------------------- 510 511 procedure Check_Static_Type 512 (T : Entity_Id; 513 N : Node_Id; 514 DT : in out Boolean; 515 Check_Designated : Boolean := False) 516 is 517 procedure Note_Uplevel_Bound (N : Node_Id; Ref : Node_Id); 518 -- N is the bound of a dynamic type. This procedure notes that 519 -- this bound is uplevel referenced, it can handle references 520 -- to entities (typically _FIRST and _LAST entities), and also 521 -- attribute references of the form T'name (name is typically 522 -- FIRST or LAST) where T is the uplevel referenced bound. 523 -- Ref, if Present, is the location of the reference to 524 -- replace. 525 526 ------------------------ 527 -- Note_Uplevel_Bound -- 528 ------------------------ 529 530 procedure Note_Uplevel_Bound (N : Node_Id; Ref : Node_Id) is 531 begin 532 -- Entity name case. Make sure that the entity is declared 533 -- in a subprogram. This may not be the case for a type in a 534 -- loop appearing in a precondition. 535 -- Exclude explicitly discriminants (that can appear 536 -- in bounds of discriminated components). 537 538 if Is_Entity_Name (N) then 539 if Present (Entity (N)) 540 and then not Is_Type (Entity (N)) 541 and then Present (Enclosing_Subprogram (Entity (N))) 542 and then Ekind (Entity (N)) /= E_Discriminant 543 then 544 Note_Uplevel_Ref 545 (E => Entity (N), 546 N => Empty, 547 Caller => Current_Subprogram, 548 Callee => Enclosing_Subprogram (Entity (N))); 549 end if; 550 551 -- Attribute or indexed component case 552 553 elsif Nkind_In (N, N_Attribute_Reference, 554 N_Indexed_Component) 555 then 556 Note_Uplevel_Bound (Prefix (N), Ref); 557 558 -- The indices of the indexed components, or the 559 -- associated expressions of an attribute reference, 560 -- may also involve uplevel references. 561 562 declare 563 Expr : Node_Id; 564 565 begin 566 Expr := First (Expressions (N)); 567 while Present (Expr) loop 568 Note_Uplevel_Bound (Expr, Ref); 569 Next (Expr); 570 end loop; 571 end; 572 573 -- The type of the prefix may be have an uplevel 574 -- reference if this needs bounds. 575 576 if Nkind (N) = N_Attribute_Reference then 577 declare 578 Attr : constant Attribute_Id := 579 Get_Attribute_Id (Attribute_Name (N)); 580 DT : Boolean := False; 581 582 begin 583 if (Attr = Attribute_First 584 or else Attr = Attribute_Last 585 or else Attr = Attribute_Length) 586 and then Is_Constrained (Etype (Prefix (N))) 587 then 588 Check_Static_Type 589 (Etype (Prefix (N)), Empty, DT); 590 end if; 591 end; 592 end if; 593 594 -- Binary operator cases. These can apply to arrays for 595 -- which we may need bounds. 596 597 elsif Nkind (N) in N_Binary_Op then 598 Note_Uplevel_Bound (Left_Opnd (N), Ref); 599 Note_Uplevel_Bound (Right_Opnd (N), Ref); 600 601 -- Unary operator case 602 603 elsif Nkind (N) in N_Unary_Op then 604 Note_Uplevel_Bound (Right_Opnd (N), Ref); 605 606 -- Explicit dereference and selected component case 607 608 elsif Nkind_In (N, N_Explicit_Dereference, 609 N_Selected_Component) 610 then 611 Note_Uplevel_Bound (Prefix (N), Ref); 612 613 -- Conditional expressions 614 615 elsif Nkind (N) = N_If_Expression then 616 declare 617 Expr : Node_Id; 618 619 begin 620 Expr := First (Expressions (N)); 621 while Present (Expr) loop 622 Note_Uplevel_Bound (Expr, Ref); 623 Next (Expr); 624 end loop; 625 end; 626 627 elsif Nkind (N) = N_Case_Expression then 628 declare 629 Alternative : Node_Id; 630 631 begin 632 Note_Uplevel_Bound (Expression (N), Ref); 633 634 Alternative := First (Alternatives (N)); 635 while Present (Alternative) loop 636 Note_Uplevel_Bound (Expression (Alternative), Ref); 637 end loop; 638 end; 639 640 -- Conversion case 641 642 elsif Nkind (N) = N_Type_Conversion then 643 Note_Uplevel_Bound (Expression (N), Ref); 644 end if; 645 end Note_Uplevel_Bound; 646 647 -- Start of processing for Check_Static_Type 648 649 begin 650 -- If already marked static, immediate return 651 652 if Is_Static_Type (T) and then not Check_Designated then 653 return; 654 end if; 655 656 -- If the type is at library level, always consider it static, 657 -- since such uplevel references are irrelevant. 658 659 if Is_Library_Level_Entity (T) then 660 Set_Is_Static_Type (T); 661 return; 662 end if; 663 664 -- Otherwise figure out what the story is with this type 665 666 -- For a scalar type, check bounds 667 668 if Is_Scalar_Type (T) then 669 670 -- If both bounds static, then this is a static type 671 672 declare 673 LB : constant Node_Id := Type_Low_Bound (T); 674 UB : constant Node_Id := Type_High_Bound (T); 675 676 begin 677 if not Is_Static_Expression (LB) then 678 Note_Uplevel_Bound (LB, N); 679 DT := True; 680 end if; 681 682 if not Is_Static_Expression (UB) then 683 Note_Uplevel_Bound (UB, N); 684 DT := True; 685 end if; 686 end; 687 688 -- For record type, check all components and discriminant 689 -- constraints if present. 690 691 elsif Is_Record_Type (T) then 692 declare 693 C : Entity_Id; 694 D : Elmt_Id; 695 696 begin 697 C := First_Component_Or_Discriminant (T); 698 while Present (C) loop 699 Check_Static_Type (Etype (C), N, DT); 700 Next_Component_Or_Discriminant (C); 701 end loop; 702 703 if Has_Discriminants (T) 704 and then Present (Discriminant_Constraint (T)) 705 then 706 D := First_Elmt (Discriminant_Constraint (T)); 707 while Present (D) loop 708 if not Is_Static_Expression (Node (D)) then 709 Note_Uplevel_Bound (Node (D), N); 710 DT := True; 711 end if; 712 713 Next_Elmt (D); 714 end loop; 715 end if; 716 end; 717 718 -- For array type, check index types and component type 719 720 elsif Is_Array_Type (T) then 721 declare 722 IX : Node_Id; 723 begin 724 Check_Static_Type (Component_Type (T), N, DT); 725 726 IX := First_Index (T); 727 while Present (IX) loop 728 Check_Static_Type (Etype (IX), N, DT); 729 Next_Index (IX); 730 end loop; 731 end; 732 733 -- For private type, examine whether full view is static 734 735 elsif Is_Incomplete_Or_Private_Type (T) 736 and then Present (Full_View (T)) 737 then 738 Check_Static_Type (Full_View (T), N, DT, Check_Designated); 739 740 if Is_Static_Type (Full_View (T)) then 741 Set_Is_Static_Type (T); 742 end if; 743 744 -- For access types, check designated type when required 745 746 elsif Is_Access_Type (T) and then Check_Designated then 747 Check_Static_Type (Directly_Designated_Type (T), N, DT); 748 749 -- For now, ignore other types 750 751 else 752 return; 753 end if; 754 755 if not DT then 756 Set_Is_Static_Type (T); 757 end if; 758 end Check_Static_Type; 759 760 ---------------------- 761 -- Note_Uplevel_Ref -- 762 ---------------------- 763 764 procedure Note_Uplevel_Ref 765 (E : Entity_Id; 766 N : Node_Id; 767 Caller : Entity_Id; 768 Callee : Entity_Id) 769 is 770 Full_E : Entity_Id := E; 771 begin 772 -- Nothing to do for static type 773 774 if Is_Static_Type (E) then 775 return; 776 end if; 777 778 -- Nothing to do if Caller and Callee are the same 779 780 if Caller = Callee then 781 return; 782 783 -- Callee may be a function that returns an array, and that has 784 -- been rewritten as a procedure. If caller is that procedure, 785 -- nothing to do either. 786 787 elsif Ekind (Callee) = E_Function 788 and then Rewritten_For_C (Callee) 789 and then Corresponding_Procedure (Callee) = Caller 790 then 791 return; 792 793 elsif Ekind_In (Callee, E_Entry, E_Entry_Family) then 794 return; 795 end if; 796 797 -- We have a new uplevel referenced entity 798 799 if Ekind (E) = E_Constant and then Present (Full_View (E)) then 800 Full_E := Full_View (E); 801 end if; 802 803 -- All we do at this stage is to add the uplevel reference to 804 -- the table. It's too early to do anything else, since this 805 -- uplevel reference may come from an unreachable subprogram 806 -- in which case the entry will be deleted. 807 808 Urefs.Append ((N, Full_E, Caller, Callee)); 809 end Note_Uplevel_Ref; 810 811 ------------------------- 812 -- Register_Subprogram -- 813 ------------------------- 814 815 procedure Register_Subprogram (E : Entity_Id; Bod : Node_Id) is 816 L : constant Nat := Get_Level (Subp, E); 817 818 begin 819 -- Subprograms declared in tasks and protected types cannot be 820 -- eliminated because calls to them may be in other units, so 821 -- they must be treated as reachable. 822 823 Subps.Append 824 ((Ent => E, 825 Bod => Bod, 826 Lev => L, 827 Reachable => In_Synchronized_Unit (E) 828 or else Address_Taken (E), 829 Uplevel_Ref => L, 830 Declares_AREC => False, 831 Uents => No_Elist, 832 Last => 0, 833 ARECnF => Empty, 834 ARECn => Empty, 835 ARECnT => Empty, 836 ARECnPT => Empty, 837 ARECnP => Empty, 838 ARECnU => Empty)); 839 840 Set_Subps_Index (E, UI_From_Int (Subps.Last)); 841 842 -- If we marked this reachable because it's in a synchronized 843 -- unit, we have to mark all enclosing subprograms as reachable 844 -- as well. 845 846 if In_Synchronized_Unit (E) then 847 declare 848 S : Entity_Id := E; 849 850 begin 851 for J in reverse 1 .. L - 1 loop 852 S := Enclosing_Subprogram (S); 853 Subps.Table (Subp_Index (S)).Reachable := True; 854 end loop; 855 end; 856 end if; 857 end Register_Subprogram; 858 859 -- Start of processing for Visit_Node 860 861 begin 862 case Nkind (N) is 863 864 -- Record a subprogram call 865 866 when N_Function_Call 867 | N_Procedure_Call_Statement 868 => 869 -- We are only interested in direct calls, not indirect 870 -- calls (where Name (N) is an explicit dereference) at 871 -- least for now! 872 873 if Nkind (Name (N)) in N_Has_Entity then 874 Ent := Entity (Name (N)); 875 876 -- We are only interested in calls to subprograms nested 877 -- within Subp. Calls to Subp itself or to subprograms 878 -- outside the nested structure do not affect us. 879 880 if Scope_Within (Ent, Subp) 881 and then Is_Subprogram (Ent) 882 and then not Is_Imported (Ent) 883 then 884 Append_Unique_Call ((N, Current_Subprogram, Ent)); 885 end if; 886 end if; 887 888 -- For all calls where the formal is an unconstrained array 889 -- and the actual is constrained we need to check the bounds 890 -- for uplevel references. 891 892 declare 893 Actual : Entity_Id; 894 DT : Boolean := False; 895 Formal : Node_Id; 896 Subp : Entity_Id; 897 898 begin 899 if Nkind (Name (N)) = N_Explicit_Dereference then 900 Subp := Etype (Name (N)); 901 else 902 Subp := Entity (Name (N)); 903 end if; 904 905 Actual := First_Actual (N); 906 Formal := First_Formal_With_Extras (Subp); 907 while Present (Actual) loop 908 if Is_Array_Type (Etype (Formal)) 909 and then not Is_Constrained (Etype (Formal)) 910 and then Is_Constrained (Etype (Actual)) 911 then 912 Check_Static_Type (Etype (Actual), Empty, DT); 913 end if; 914 915 Next_Actual (Actual); 916 Next_Formal_With_Extras (Formal); 917 end loop; 918 end; 919 920 -- An At_End_Proc in a statement sequence indicates that there 921 -- is a call from the enclosing construct or block to that 922 -- subprogram. As above, the called entity must be local and 923 -- not imported. 924 925 when N_Handled_Sequence_Of_Statements => 926 if Present (At_End_Proc (N)) 927 and then Scope_Within (Entity (At_End_Proc (N)), Subp) 928 and then not Is_Imported (Entity (At_End_Proc (N))) 929 then 930 Append_Unique_Call 931 ((N, Current_Subprogram, Entity (At_End_Proc (N)))); 932 end if; 933 934 -- Similarly, the following constructs include a semantic 935 -- attribute Procedure_To_Call that must be handled like 936 -- other calls. Likewise for attribute Storage_Pool. 937 938 when N_Allocator 939 | N_Extended_Return_Statement 940 | N_Free_Statement 941 | N_Simple_Return_Statement 942 => 943 declare 944 Pool : constant Entity_Id := Storage_Pool (N); 945 Proc : constant Entity_Id := Procedure_To_Call (N); 946 947 begin 948 if Present (Proc) 949 and then Scope_Within (Proc, Subp) 950 and then not Is_Imported (Proc) 951 then 952 Append_Unique_Call ((N, Current_Subprogram, Proc)); 953 end if; 954 955 if Present (Pool) 956 and then not Is_Library_Level_Entity (Pool) 957 and then Scope_Within_Or_Same (Scope (Pool), Subp) 958 then 959 Caller := Current_Subprogram; 960 Callee := Enclosing_Subprogram (Pool); 961 962 if Callee /= Caller then 963 Note_Uplevel_Ref (Pool, Empty, Caller, Callee); 964 end if; 965 end if; 966 end; 967 968 -- For an allocator with a qualified expression, check type 969 -- of expression being qualified. The explicit type name is 970 -- handled as an entity reference. 971 972 if Nkind (N) = N_Allocator 973 and then Nkind (Expression (N)) = N_Qualified_Expression 974 then 975 declare 976 DT : Boolean := False; 977 begin 978 Check_Static_Type 979 (Etype (Expression (Expression (N))), Empty, DT); 980 end; 981 982 -- For a Return or Free (all other nodes we handle here), 983 -- we usually need the size of the object, so we need to be 984 -- sure that any nonstatic bounds of the expression's type 985 -- that are uplevel are handled. 986 987 elsif Nkind (N) /= N_Allocator 988 and then Present (Expression (N)) 989 then 990 declare 991 DT : Boolean := False; 992 begin 993 Check_Static_Type 994 (Etype (Expression (N)), 995 Empty, 996 DT, 997 Check_Designated => Nkind (N) = N_Free_Statement); 998 end; 999 end if; 1000 1001 -- A 'Access reference is a (potential) call. So is 'Address, 1002 -- in particular on imported subprograms. Other attributes 1003 -- require special handling. 1004 1005 when N_Attribute_Reference => 1006 declare 1007 Attr : constant Attribute_Id := 1008 Get_Attribute_Id (Attribute_Name (N)); 1009 begin 1010 case Attr is 1011 when Attribute_Access 1012 | Attribute_Unchecked_Access 1013 | Attribute_Unrestricted_Access 1014 | Attribute_Address 1015 => 1016 if Nkind (Prefix (N)) in N_Has_Entity then 1017 Ent := Entity (Prefix (N)); 1018 1019 -- We only need to examine calls to subprograms 1020 -- nested within current Subp. 1021 1022 if Scope_Within (Ent, Subp) then 1023 if Is_Imported (Ent) then 1024 null; 1025 1026 elsif Is_Subprogram (Ent) then 1027 Append_Unique_Call 1028 ((N, Current_Subprogram, Ent)); 1029 end if; 1030 end if; 1031 end if; 1032 1033 -- References to bounds can be uplevel references if 1034 -- the type isn't static. 1035 1036 when Attribute_First 1037 | Attribute_Last 1038 | Attribute_Length 1039 => 1040 -- Special-case attributes of objects whose bounds 1041 -- may be uplevel references. More complex prefixes 1042 -- handled during full traversal. Note that if the 1043 -- nominal subtype of the prefix is unconstrained, 1044 -- the bound must be obtained from the object, not 1045 -- from the (possibly) uplevel reference. 1046 1047 if Is_Constrained (Etype (Prefix (N))) then 1048 declare 1049 DT : Boolean := False; 1050 begin 1051 Check_Static_Type 1052 (Etype (Prefix (N)), Empty, DT); 1053 end; 1054 1055 return OK; 1056 end if; 1057 1058 when others => 1059 null; 1060 end case; 1061 end; 1062 1063 -- Component associations in aggregates are either static or 1064 -- else the aggregate will be expanded into assignments, in 1065 -- which case the expression is analyzed later and provides 1066 -- no relevant code generation. 1067 1068 when N_Component_Association => 1069 if No (Expression (N)) 1070 or else No (Etype (Expression (N))) 1071 then 1072 return Skip; 1073 end if; 1074 1075 -- Generic associations are not analyzed: the actuals are 1076 -- transferred to renaming and subtype declarations that 1077 -- are the ones that must be examined. 1078 1079 when N_Generic_Association => 1080 return Skip; 1081 1082 -- Indexed references can be uplevel if the type isn't static 1083 -- and if the lower bound (or an inner bound for a multi- 1084 -- dimensional array) is uplevel. 1085 1086 when N_Indexed_Component 1087 | N_Slice 1088 => 1089 if Is_Constrained (Etype (Prefix (N))) then 1090 declare 1091 DT : Boolean := False; 1092 begin 1093 Check_Static_Type (Etype (Prefix (N)), Empty, DT); 1094 end; 1095 end if; 1096 1097 -- A selected component can have an implicit up-level 1098 -- reference due to the bounds of previous fields in the 1099 -- record. We simplify the processing here by examining 1100 -- all components of the record. 1101 1102 -- Selected components appear as unit names and end labels 1103 -- for child units. Prefixes of these nodes denote parent 1104 -- units and carry no type information so they are skipped. 1105 1106 when N_Selected_Component => 1107 if Present (Etype (Prefix (N))) then 1108 declare 1109 DT : Boolean := False; 1110 begin 1111 Check_Static_Type (Etype (Prefix (N)), Empty, DT); 1112 end; 1113 end if; 1114 1115 -- For EQ/NE comparisons, we need the type of the operands 1116 -- in order to do the comparison, which means we need the 1117 -- bounds. 1118 1119 when N_Op_Eq 1120 | N_Op_Ne 1121 => 1122 declare 1123 DT : Boolean := False; 1124 begin 1125 Check_Static_Type (Etype (Left_Opnd (N)), Empty, DT); 1126 Check_Static_Type (Etype (Right_Opnd (N)), Empty, DT); 1127 end; 1128 1129 -- Likewise we need the sizes to compute how much to move in 1130 -- an assignment. 1131 1132 when N_Assignment_Statement => 1133 declare 1134 DT : Boolean := False; 1135 begin 1136 Check_Static_Type (Etype (Name (N)), Empty, DT); 1137 Check_Static_Type (Etype (Expression (N)), Empty, DT); 1138 end; 1139 1140 -- Record a subprogram. We record a subprogram body that acts 1141 -- as a spec. Otherwise we record a subprogram declaration, 1142 -- providing that it has a corresponding body we can get hold 1143 -- of. The case of no corresponding body being available is 1144 -- ignored for now. 1145 1146 when N_Subprogram_Body => 1147 Ent := Unique_Defining_Entity (N); 1148 1149 -- Ignore generic subprogram 1150 1151 if Is_Generic_Subprogram (Ent) then 1152 return Skip; 1153 end if; 1154 1155 -- Make new entry in subprogram table if not already made 1156 1157 Register_Subprogram (Ent, N); 1158 1159 -- We make a recursive call to scan the subprogram body, so 1160 -- that we can save and restore Current_Subprogram. 1161 1162 declare 1163 Save_CS : constant Entity_Id := Current_Subprogram; 1164 Decl : Node_Id; 1165 1166 begin 1167 Current_Subprogram := Ent; 1168 1169 -- Scan declarations 1170 1171 Decl := First (Declarations (N)); 1172 while Present (Decl) loop 1173 Visit (Decl); 1174 Next (Decl); 1175 end loop; 1176 1177 -- Scan statements 1178 1179 Visit (Handled_Statement_Sequence (N)); 1180 1181 -- Restore current subprogram setting 1182 1183 Current_Subprogram := Save_CS; 1184 end; 1185 1186 -- Now at this level, return skipping the subprogram body 1187 -- descendants, since we already took care of them! 1188 1189 return Skip; 1190 1191 -- If we have a body stub, visit the associated subunit, which 1192 -- is a semantic descendant of the stub. 1193 1194 when N_Body_Stub => 1195 Visit (Library_Unit (N)); 1196 1197 -- A declaration of a wrapper package indicates a subprogram 1198 -- instance for which there is no explicit body. Enter the 1199 -- subprogram instance in the table. 1200 1201 when N_Package_Declaration => 1202 if Is_Wrapper_Package (Defining_Entity (N)) then 1203 Register_Subprogram 1204 (Related_Instance (Defining_Entity (N)), Empty); 1205 end if; 1206 1207 -- Skip generic declarations 1208 1209 when N_Generic_Declaration => 1210 return Skip; 1211 1212 -- Skip generic package body 1213 1214 when N_Package_Body => 1215 if Present (Corresponding_Spec (N)) 1216 and then Ekind (Corresponding_Spec (N)) = E_Generic_Package 1217 then 1218 return Skip; 1219 end if; 1220 1221 -- Pragmas and component declarations are ignored. Quantified 1222 -- expressions are expanded into explicit loops and the 1223 -- original epression must be ignored. 1224 1225 when N_Component_Declaration 1226 | N_Pragma 1227 | N_Quantified_Expression 1228 => 1229 return Skip; 1230 1231 -- We want to skip the function spec for a generic function 1232 -- to avoid looking at any generic types that might be in 1233 -- its formals. 1234 1235 when N_Function_Specification => 1236 if Is_Generic_Subprogram (Unique_Defining_Entity (N)) then 1237 return Skip; 1238 end if; 1239 1240 -- Otherwise record an uplevel reference in a local identifier 1241 1242 when others => 1243 if Nkind (N) in N_Has_Entity 1244 and then Present (Entity (N)) 1245 then 1246 Ent := Entity (N); 1247 1248 -- Only interested in entities declared within our nest 1249 1250 if not Is_Library_Level_Entity (Ent) 1251 and then Scope_Within_Or_Same (Scope (Ent), Subp) 1252 1253 -- Skip entities defined in inlined subprograms 1254 1255 and then 1256 Chars (Enclosing_Subprogram (Ent)) /= Name_uParent 1257 1258 -- Constants and variables are potentially uplevel 1259 -- references to global declarations. 1260 1261 and then 1262 (Ekind_In (Ent, E_Constant, 1263 E_Loop_Parameter, 1264 E_Variable) 1265 1266 -- Formals are interesting, but not if being used 1267 -- as mere names of parameters for name notation 1268 -- calls. 1269 1270 or else 1271 (Is_Formal (Ent) 1272 and then not 1273 (Nkind (Parent (N)) = N_Parameter_Association 1274 and then Selector_Name (Parent (N)) = N)) 1275 1276 -- Types other than known Is_Static types are 1277 -- potentially interesting. 1278 1279 or else 1280 (Is_Type (Ent) and then not Is_Static_Type (Ent))) 1281 then 1282 -- Here we have a potentially interesting uplevel 1283 -- reference to examine. 1284 1285 if Is_Type (Ent) then 1286 declare 1287 DT : Boolean := False; 1288 1289 begin 1290 Check_Static_Type (Ent, N, DT); 1291 return OK; 1292 end; 1293 end if; 1294 1295 Caller := Current_Subprogram; 1296 Callee := Enclosing_Subprogram (Ent); 1297 1298 if Callee /= Caller 1299 and then (not Is_Static_Type (Ent) 1300 or else Needs_Fat_Pointer (Ent)) 1301 then 1302 Note_Uplevel_Ref (Ent, N, Caller, Callee); 1303 1304 -- Check the type of a formal parameter of the current 1305 -- subprogram, whose formal type may be an uplevel 1306 -- reference. 1307 1308 elsif Is_Formal (Ent) 1309 and then Scope (Ent) = Current_Subprogram 1310 then 1311 declare 1312 DT : Boolean := False; 1313 1314 begin 1315 Check_Static_Type (Etype (Ent), Empty, DT); 1316 end; 1317 end if; 1318 end if; 1319 end if; 1320 end case; 1321 1322 -- Fall through to continue scanning children of this node 1323 1324 return OK; 1325 end Visit_Node; 1326 1327 -- Start of processing for Build_Tables 1328 1329 begin 1330 -- Traverse the body to get subprograms, calls and uplevel references 1331 1332 Visit (Subp_Body); 1333 end Build_Tables; 1334 1335 -- Now do the first transitive closure which determines which 1336 -- subprograms in the nest are actually reachable. 1337 1338 Reachable_Closure : declare 1339 Modified : Boolean; 1340 1341 begin 1342 Subps.Table (Subps_First).Reachable := True; 1343 1344 -- We use a simple minded algorithm as follows (obviously this can 1345 -- be done more efficiently, using one of the standard algorithms 1346 -- for efficient transitive closure computation, but this is simple 1347 -- and most likely fast enough that its speed does not matter). 1348 1349 -- Repeatedly scan the list of calls. Any time we find a call from 1350 -- A to B, where A is reachable, but B is not, then B is reachable, 1351 -- and note that we have made a change by setting Modified True. We 1352 -- repeat this until we make a pass with no modifications. 1353 1354 Outer : loop 1355 Modified := False; 1356 Inner : for J in Calls.First .. Calls.Last loop 1357 declare 1358 CTJ : Call_Entry renames Calls.Table (J); 1359 1360 SINF : constant SI_Type := Subp_Index (CTJ.Caller); 1361 SINT : constant SI_Type := Subp_Index (CTJ.Callee); 1362 1363 SUBF : Subp_Entry renames Subps.Table (SINF); 1364 SUBT : Subp_Entry renames Subps.Table (SINT); 1365 1366 begin 1367 if SUBF.Reachable and then not SUBT.Reachable then 1368 SUBT.Reachable := True; 1369 Modified := True; 1370 end if; 1371 end; 1372 end loop Inner; 1373 1374 exit Outer when not Modified; 1375 end loop Outer; 1376 end Reachable_Closure; 1377 1378 -- Remove calls from unreachable subprograms 1379 1380 declare 1381 New_Index : Nat; 1382 1383 begin 1384 New_Index := 0; 1385 for J in Calls.First .. Calls.Last loop 1386 declare 1387 CTJ : Call_Entry renames Calls.Table (J); 1388 1389 SINF : constant SI_Type := Subp_Index (CTJ.Caller); 1390 SINT : constant SI_Type := Subp_Index (CTJ.Callee); 1391 1392 SUBF : Subp_Entry renames Subps.Table (SINF); 1393 SUBT : Subp_Entry renames Subps.Table (SINT); 1394 1395 begin 1396 if SUBF.Reachable then 1397 pragma Assert (SUBT.Reachable); 1398 New_Index := New_Index + 1; 1399 Calls.Table (New_Index) := Calls.Table (J); 1400 end if; 1401 end; 1402 end loop; 1403 1404 Calls.Set_Last (New_Index); 1405 end; 1406 1407 -- Remove uplevel references from unreachable subprograms 1408 1409 declare 1410 New_Index : Nat; 1411 1412 begin 1413 New_Index := 0; 1414 for J in Urefs.First .. Urefs.Last loop 1415 declare 1416 URJ : Uref_Entry renames Urefs.Table (J); 1417 1418 SINF : constant SI_Type := Subp_Index (URJ.Caller); 1419 SINT : constant SI_Type := Subp_Index (URJ.Callee); 1420 1421 SUBF : Subp_Entry renames Subps.Table (SINF); 1422 SUBT : Subp_Entry renames Subps.Table (SINT); 1423 1424 S : Entity_Id; 1425 1426 begin 1427 -- Keep reachable reference 1428 1429 if SUBF.Reachable then 1430 New_Index := New_Index + 1; 1431 Urefs.Table (New_Index) := Urefs.Table (J); 1432 1433 -- And since we know we are keeping this one, this is a good 1434 -- place to fill in information for a good reference. 1435 1436 -- Mark all enclosing subprograms need to declare AREC 1437 1438 S := URJ.Caller; 1439 loop 1440 S := Enclosing_Subprogram (S); 1441 1442 -- If we are at the top level, as can happen with 1443 -- references to formals in aspects of nested subprogram 1444 -- declarations, there are no further subprograms to mark 1445 -- as requiring activation records. 1446 1447 exit when No (S); 1448 1449 declare 1450 SUBI : Subp_Entry renames Subps.Table (Subp_Index (S)); 1451 begin 1452 SUBI.Declares_AREC := True; 1453 1454 -- If this entity was marked reachable because it is 1455 -- in a task or protected type, there may not appear 1456 -- to be any calls to it, which would normally adjust 1457 -- the levels of the parent subprograms. So we need to 1458 -- be sure that the uplevel reference of that entity 1459 -- takes into account possible calls. 1460 1461 if In_Synchronized_Unit (SUBF.Ent) 1462 and then SUBT.Lev < SUBI.Uplevel_Ref 1463 then 1464 SUBI.Uplevel_Ref := SUBT.Lev; 1465 end if; 1466 end; 1467 1468 exit when S = URJ.Callee; 1469 end loop; 1470 1471 -- Add to list of uplevel referenced entities for Callee. 1472 -- We do not add types to this list, only actual references 1473 -- to objects that will be referenced uplevel, and we use 1474 -- the flag Is_Uplevel_Referenced_Entity to avoid making 1475 -- duplicate entries in the list. Discriminants are also 1476 -- excluded, only the enclosing object can appear in the 1477 -- list. 1478 1479 if not Is_Uplevel_Referenced_Entity (URJ.Ent) 1480 and then Ekind (URJ.Ent) /= E_Discriminant 1481 then 1482 Set_Is_Uplevel_Referenced_Entity (URJ.Ent); 1483 Append_New_Elmt (URJ.Ent, SUBT.Uents); 1484 end if; 1485 1486 -- And set uplevel indication for caller 1487 1488 if SUBT.Lev < SUBF.Uplevel_Ref then 1489 SUBF.Uplevel_Ref := SUBT.Lev; 1490 end if; 1491 end if; 1492 end; 1493 end loop; 1494 1495 Urefs.Set_Last (New_Index); 1496 end; 1497 1498 -- Remove unreachable subprograms from Subps table. Note that we do 1499 -- this after eliminating entries from the other two tables, since 1500 -- those elimination steps depend on referencing the Subps table. 1501 1502 declare 1503 New_SI : SI_Type; 1504 1505 begin 1506 New_SI := Subps_First - 1; 1507 for J in Subps_First .. Subps.Last loop 1508 declare 1509 STJ : Subp_Entry renames Subps.Table (J); 1510 Spec : Node_Id; 1511 Decl : Node_Id; 1512 1513 begin 1514 -- Subprogram is reachable, copy and reset index 1515 1516 if STJ.Reachable then 1517 New_SI := New_SI + 1; 1518 Subps.Table (New_SI) := STJ; 1519 Set_Subps_Index (STJ.Ent, UI_From_Int (New_SI)); 1520 1521 -- Subprogram is not reachable 1522 1523 else 1524 -- Clear index, since no longer active 1525 1526 Set_Subps_Index (Subps.Table (J).Ent, Uint_0); 1527 1528 -- Output debug information if -gnatd.3 set 1529 1530 if Debug_Flag_Dot_3 then 1531 Write_Str ("Eliminate "); 1532 Write_Name (Chars (Subps.Table (J).Ent)); 1533 Write_Str (" at "); 1534 Write_Location (Sloc (Subps.Table (J).Ent)); 1535 Write_Str (" (not referenced)"); 1536 Write_Eol; 1537 end if; 1538 1539 -- Rewrite declaration, body, and corresponding freeze node 1540 -- to null statements. 1541 1542 -- A subprogram instantiation does not have an explicit 1543 -- body. If unused, we could remove the corresponding 1544 -- wrapper package and its body (TBD). 1545 1546 if Present (STJ.Bod) then 1547 Spec := Corresponding_Spec (STJ.Bod); 1548 1549 if Present (Spec) then 1550 Decl := Parent (Declaration_Node (Spec)); 1551 Rewrite (Decl, Make_Null_Statement (Sloc (Decl))); 1552 1553 if Present (Freeze_Node (Spec)) then 1554 Rewrite (Freeze_Node (Spec), 1555 Make_Null_Statement (Sloc (Decl))); 1556 end if; 1557 end if; 1558 1559 Rewrite (STJ.Bod, Make_Null_Statement (Sloc (STJ.Bod))); 1560 end if; 1561 end if; 1562 end; 1563 end loop; 1564 1565 Subps.Set_Last (New_SI); 1566 end; 1567 1568 -- Now it is time for the second transitive closure, which follows calls 1569 -- and makes sure that A calls B, and B has uplevel references, then A 1570 -- is also marked as having uplevel references. 1571 1572 Closure_Uplevel : declare 1573 Modified : Boolean; 1574 1575 begin 1576 -- We use a simple minded algorithm as follows (obviously this can 1577 -- be done more efficiently, using one of the standard algorithms 1578 -- for efficient transitive closure computation, but this is simple 1579 -- and most likely fast enough that its speed does not matter). 1580 1581 -- Repeatedly scan the list of calls. Any time we find a call from 1582 -- A to B, where B has uplevel references, make sure that A is marked 1583 -- as having at least the same level of uplevel referencing. 1584 1585 Outer2 : loop 1586 Modified := False; 1587 Inner2 : for J in Calls.First .. Calls.Last loop 1588 declare 1589 CTJ : Call_Entry renames Calls.Table (J); 1590 SINF : constant SI_Type := Subp_Index (CTJ.Caller); 1591 SINT : constant SI_Type := Subp_Index (CTJ.Callee); 1592 SUBF : Subp_Entry renames Subps.Table (SINF); 1593 SUBT : Subp_Entry renames Subps.Table (SINT); 1594 begin 1595 if SUBT.Lev > SUBT.Uplevel_Ref 1596 and then SUBF.Uplevel_Ref > SUBT.Uplevel_Ref 1597 then 1598 SUBF.Uplevel_Ref := SUBT.Uplevel_Ref; 1599 Modified := True; 1600 end if; 1601 end; 1602 end loop Inner2; 1603 1604 exit Outer2 when not Modified; 1605 end loop Outer2; 1606 end Closure_Uplevel; 1607 1608 -- We have one more step before the tables are complete. An uplevel 1609 -- call from subprogram A to subprogram B where subprogram B has uplevel 1610 -- references is in effect an uplevel reference, and must arrange for 1611 -- the proper activation link to be passed. 1612 1613 for J in Calls.First .. Calls.Last loop 1614 declare 1615 CTJ : Call_Entry renames Calls.Table (J); 1616 1617 SINF : constant SI_Type := Subp_Index (CTJ.Caller); 1618 SINT : constant SI_Type := Subp_Index (CTJ.Callee); 1619 1620 SUBF : Subp_Entry renames Subps.Table (SINF); 1621 SUBT : Subp_Entry renames Subps.Table (SINT); 1622 1623 A : Entity_Id; 1624 1625 begin 1626 -- If callee has uplevel references 1627 1628 if SUBT.Uplevel_Ref < SUBT.Lev 1629 1630 -- And this is an uplevel call 1631 1632 and then SUBT.Lev < SUBF.Lev 1633 then 1634 -- We need to arrange for finding the uplink 1635 1636 A := CTJ.Caller; 1637 loop 1638 A := Enclosing_Subprogram (A); 1639 Subps.Table (Subp_Index (A)).Declares_AREC := True; 1640 exit when A = CTJ.Callee; 1641 1642 -- In any case exit when we get to the outer level. This 1643 -- happens in some odd cases with generics (in particular 1644 -- sem_ch3.adb does not compile without this kludge ???). 1645 1646 exit when A = Subp; 1647 end loop; 1648 end if; 1649 end; 1650 end loop; 1651 1652 -- The tables are now complete, so we can record the last index in the 1653 -- Subps table for later reference in Cprint. 1654 1655 Subps.Table (Subps_First).Last := Subps.Last; 1656 1657 -- Next step, create the entities for code we will insert. We do this 1658 -- at the start so that all the entities are defined, regardless of the 1659 -- order in which we do the code insertions. 1660 1661 Create_Entities : for J in Subps_First .. Subps.Last loop 1662 declare 1663 STJ : Subp_Entry renames Subps.Table (J); 1664 Loc : constant Source_Ptr := Sloc (STJ.Bod); 1665 1666 begin 1667 -- First we create the ARECnF entity for the additional formal for 1668 -- all subprograms which need an activation record passed. 1669 1670 if STJ.Uplevel_Ref < STJ.Lev then 1671 STJ.ARECnF := 1672 Make_Defining_Identifier (Loc, Chars => AREC_Name (J, "F")); 1673 end if; 1674 1675 -- Define the AREC entities for the activation record if needed 1676 1677 if STJ.Declares_AREC then 1678 STJ.ARECn := 1679 Make_Defining_Identifier (Loc, AREC_Name (J, "")); 1680 STJ.ARECnT := 1681 Make_Defining_Identifier (Loc, AREC_Name (J, "T")); 1682 STJ.ARECnPT := 1683 Make_Defining_Identifier (Loc, AREC_Name (J, "PT")); 1684 STJ.ARECnP := 1685 Make_Defining_Identifier (Loc, AREC_Name (J, "P")); 1686 1687 -- Define uplink component entity if inner nesting case 1688 1689 if Present (STJ.ARECnF) then 1690 STJ.ARECnU := 1691 Make_Defining_Identifier (Loc, AREC_Name (J, "U")); 1692 end if; 1693 end if; 1694 end; 1695 end loop Create_Entities; 1696 1697 -- Loop through subprograms 1698 1699 Subp_Loop : declare 1700 Addr : Entity_Id := Empty; 1701 1702 begin 1703 for J in Subps_First .. Subps.Last loop 1704 declare 1705 STJ : Subp_Entry renames Subps.Table (J); 1706 1707 begin 1708 -- First add the extra formal if needed. This applies to all 1709 -- nested subprograms that require an activation record to be 1710 -- passed, as indicated by ARECnF being defined. 1711 1712 if Present (STJ.ARECnF) then 1713 1714 -- Here we need the extra formal. We do the expansion and 1715 -- analysis of this manually, since it is fairly simple, 1716 -- and it is not obvious how we can get what we want if we 1717 -- try to use the normal Analyze circuit. 1718 1719 Add_Extra_Formal : declare 1720 Encl : constant SI_Type := Enclosing_Subp (J); 1721 STJE : Subp_Entry renames Subps.Table (Encl); 1722 -- Index and Subp_Entry for enclosing routine 1723 1724 Form : constant Entity_Id := STJ.ARECnF; 1725 -- The formal to be added. Note that n here is one less 1726 -- than the level of the subprogram itself (STJ.Ent). 1727 1728 procedure Add_Form_To_Spec (F : Entity_Id; S : Node_Id); 1729 -- S is an N_Function/Procedure_Specification node, and F 1730 -- is the new entity to add to this subprogramn spec as 1731 -- the last Extra_Formal. 1732 1733 ---------------------- 1734 -- Add_Form_To_Spec -- 1735 ---------------------- 1736 1737 procedure Add_Form_To_Spec (F : Entity_Id; S : Node_Id) is 1738 Sub : constant Entity_Id := Defining_Entity (S); 1739 Ent : Entity_Id; 1740 1741 begin 1742 -- Case of at least one Extra_Formal is present, set 1743 -- ARECnF as the new last entry in the list. 1744 1745 if Present (Extra_Formals (Sub)) then 1746 Ent := Extra_Formals (Sub); 1747 while Present (Extra_Formal (Ent)) loop 1748 Ent := Extra_Formal (Ent); 1749 end loop; 1750 1751 Set_Extra_Formal (Ent, F); 1752 1753 -- No Extra formals present 1754 1755 else 1756 Set_Extra_Formals (Sub, F); 1757 Ent := Last_Formal (Sub); 1758 1759 if Present (Ent) then 1760 Set_Extra_Formal (Ent, F); 1761 end if; 1762 end if; 1763 end Add_Form_To_Spec; 1764 1765 -- Start of processing for Add_Extra_Formal 1766 1767 begin 1768 -- Decorate the new formal entity 1769 1770 Set_Scope (Form, STJ.Ent); 1771 Set_Ekind (Form, E_In_Parameter); 1772 Set_Etype (Form, STJE.ARECnPT); 1773 Set_Mechanism (Form, By_Copy); 1774 Set_Never_Set_In_Source (Form, True); 1775 Set_Analyzed (Form, True); 1776 Set_Comes_From_Source (Form, False); 1777 Set_Is_Activation_Record (Form, True); 1778 1779 -- Case of only body present 1780 1781 if Acts_As_Spec (STJ.Bod) then 1782 Add_Form_To_Spec (Form, Specification (STJ.Bod)); 1783 1784 -- Case of separate spec 1785 1786 else 1787 Add_Form_To_Spec (Form, Parent (STJ.Ent)); 1788 end if; 1789 end Add_Extra_Formal; 1790 end if; 1791 1792 -- Processing for subprograms that declare an activation record 1793 1794 if Present (STJ.ARECn) then 1795 1796 -- Local declarations for one such subprogram 1797 1798 declare 1799 Loc : constant Source_Ptr := Sloc (STJ.Bod); 1800 1801 Decls : constant List_Id := New_List; 1802 -- List of new declarations we create 1803 1804 Clist : List_Id; 1805 Comp : Entity_Id; 1806 1807 Decl_Assign : Node_Id; 1808 -- Assignment to set uplink, Empty if none 1809 1810 Decl_ARECnT : Node_Id; 1811 Decl_ARECnPT : Node_Id; 1812 Decl_ARECn : Node_Id; 1813 Decl_ARECnP : Node_Id; 1814 -- Declaration nodes for the AREC entities we build 1815 1816 begin 1817 -- Build list of component declarations for ARECnT and 1818 -- load System.Address. 1819 1820 Clist := Empty_List; 1821 1822 if No (Addr) then 1823 Addr := RTE (RE_Address); 1824 end if; 1825 1826 -- If we are in a subprogram that has a static link that 1827 -- is passed in (as indicated by ARECnF being defined), 1828 -- then include ARECnU : ARECmPT where ARECmPT comes from 1829 -- the level one higher than the current level, and the 1830 -- entity ARECnPT comes from the enclosing subprogram. 1831 1832 if Present (STJ.ARECnF) then 1833 declare 1834 STJE : Subp_Entry 1835 renames Subps.Table (Enclosing_Subp (J)); 1836 begin 1837 Append_To (Clist, 1838 Make_Component_Declaration (Loc, 1839 Defining_Identifier => STJ.ARECnU, 1840 Component_Definition => 1841 Make_Component_Definition (Loc, 1842 Subtype_Indication => 1843 New_Occurrence_Of (STJE.ARECnPT, Loc)))); 1844 end; 1845 end if; 1846 1847 -- Add components for uplevel referenced entities 1848 1849 if Present (STJ.Uents) then 1850 declare 1851 Elmt : Elmt_Id; 1852 Ptr_Decl : Node_Id; 1853 Uent : Entity_Id; 1854 1855 Indx : Nat; 1856 -- 1's origin of index in list of elements. This is 1857 -- used to uniquify names if needed in Upref_Name. 1858 1859 begin 1860 Elmt := First_Elmt (STJ.Uents); 1861 Indx := 0; 1862 while Present (Elmt) loop 1863 Uent := Node (Elmt); 1864 Indx := Indx + 1; 1865 1866 Comp := 1867 Make_Defining_Identifier (Loc, 1868 Chars => Upref_Name (Uent, Indx, Clist)); 1869 1870 Set_Activation_Record_Component 1871 (Uent, Comp); 1872 1873 if Needs_Fat_Pointer (Uent) then 1874 1875 -- Build corresponding access type 1876 1877 Ptr_Decl := 1878 Build_Access_Type_Decl 1879 (Etype (Uent), STJ.Ent); 1880 Append_To (Decls, Ptr_Decl); 1881 1882 -- And use its type in the corresponding 1883 -- component. 1884 1885 Append_To (Clist, 1886 Make_Component_Declaration (Loc, 1887 Defining_Identifier => Comp, 1888 Component_Definition => 1889 Make_Component_Definition (Loc, 1890 Subtype_Indication => 1891 New_Occurrence_Of 1892 (Defining_Identifier (Ptr_Decl), 1893 Loc)))); 1894 else 1895 Append_To (Clist, 1896 Make_Component_Declaration (Loc, 1897 Defining_Identifier => Comp, 1898 Component_Definition => 1899 Make_Component_Definition (Loc, 1900 Subtype_Indication => 1901 New_Occurrence_Of (Addr, Loc)))); 1902 end if; 1903 Next_Elmt (Elmt); 1904 end loop; 1905 end; 1906 end if; 1907 1908 -- Now we can insert the AREC declarations into the body 1909 -- type ARECnT is record .. end record; 1910 -- pragma Suppress_Initialization (ARECnT); 1911 1912 -- Note that we need to set the Suppress_Initialization 1913 -- flag after Decl_ARECnT has been analyzed. 1914 1915 Decl_ARECnT := 1916 Make_Full_Type_Declaration (Loc, 1917 Defining_Identifier => STJ.ARECnT, 1918 Type_Definition => 1919 Make_Record_Definition (Loc, 1920 Component_List => 1921 Make_Component_List (Loc, 1922 Component_Items => Clist))); 1923 Append_To (Decls, Decl_ARECnT); 1924 1925 -- type ARECnPT is access all ARECnT; 1926 1927 Decl_ARECnPT := 1928 Make_Full_Type_Declaration (Loc, 1929 Defining_Identifier => STJ.ARECnPT, 1930 Type_Definition => 1931 Make_Access_To_Object_Definition (Loc, 1932 All_Present => True, 1933 Subtype_Indication => 1934 New_Occurrence_Of (STJ.ARECnT, Loc))); 1935 Append_To (Decls, Decl_ARECnPT); 1936 1937 -- ARECn : aliased ARECnT; 1938 1939 Decl_ARECn := 1940 Make_Object_Declaration (Loc, 1941 Defining_Identifier => STJ.ARECn, 1942 Aliased_Present => True, 1943 Object_Definition => 1944 New_Occurrence_Of (STJ.ARECnT, Loc)); 1945 Append_To (Decls, Decl_ARECn); 1946 1947 -- ARECnP : constant ARECnPT := ARECn'Access; 1948 1949 Decl_ARECnP := 1950 Make_Object_Declaration (Loc, 1951 Defining_Identifier => STJ.ARECnP, 1952 Constant_Present => True, 1953 Object_Definition => 1954 New_Occurrence_Of (STJ.ARECnPT, Loc), 1955 Expression => 1956 Make_Attribute_Reference (Loc, 1957 Prefix => 1958 New_Occurrence_Of (STJ.ARECn, Loc), 1959 Attribute_Name => Name_Access)); 1960 Append_To (Decls, Decl_ARECnP); 1961 1962 -- If we are in a subprogram that has a static link that 1963 -- is passed in (as indicated by ARECnF being defined), 1964 -- then generate ARECn.ARECmU := ARECmF where m is 1965 -- one less than the current level to set the uplink. 1966 1967 if Present (STJ.ARECnF) then 1968 Decl_Assign := 1969 Make_Assignment_Statement (Loc, 1970 Name => 1971 Make_Selected_Component (Loc, 1972 Prefix => 1973 New_Occurrence_Of (STJ.ARECn, Loc), 1974 Selector_Name => 1975 New_Occurrence_Of (STJ.ARECnU, Loc)), 1976 Expression => 1977 New_Occurrence_Of (STJ.ARECnF, Loc)); 1978 Append_To (Decls, Decl_Assign); 1979 1980 else 1981 Decl_Assign := Empty; 1982 end if; 1983 1984 if No (Declarations (STJ.Bod)) then 1985 Set_Declarations (STJ.Bod, Decls); 1986 else 1987 Prepend_List_To (Declarations (STJ.Bod), Decls); 1988 end if; 1989 1990 -- Analyze the newly inserted declarations. Note that we 1991 -- do not need to establish the whole scope stack, since 1992 -- we have already set all entity fields (so there will 1993 -- be no searching of upper scopes to resolve names). But 1994 -- we do set the scope of the current subprogram, so that 1995 -- newly created entities go in the right entity chain. 1996 1997 -- We analyze with all checks suppressed (since we do 1998 -- not expect any exceptions). 1999 2000 Push_Scope (STJ.Ent); 2001 Analyze (Decl_ARECnT, Suppress => All_Checks); 2002 2003 -- Note that we need to call Set_Suppress_Initialization 2004 -- after Decl_ARECnT has been analyzed, but before 2005 -- analyzing Decl_ARECnP so that the flag is properly 2006 -- taking into account. 2007 2008 Set_Suppress_Initialization (STJ.ARECnT); 2009 2010 Analyze (Decl_ARECnPT, Suppress => All_Checks); 2011 Analyze (Decl_ARECn, Suppress => All_Checks); 2012 Analyze (Decl_ARECnP, Suppress => All_Checks); 2013 2014 if Present (Decl_Assign) then 2015 Analyze (Decl_Assign, Suppress => All_Checks); 2016 end if; 2017 2018 Pop_Scope; 2019 2020 -- Next step, for each uplevel referenced entity, add 2021 -- assignment operations to set the component in the 2022 -- activation record. 2023 2024 if Present (STJ.Uents) then 2025 declare 2026 Elmt : Elmt_Id; 2027 2028 begin 2029 Elmt := First_Elmt (STJ.Uents); 2030 while Present (Elmt) loop 2031 declare 2032 Ent : constant Entity_Id := Node (Elmt); 2033 Loc : constant Source_Ptr := Sloc (Ent); 2034 Dec : constant Node_Id := 2035 Declaration_Node (Ent); 2036 2037 Asn : Node_Id; 2038 Attr : Name_Id; 2039 Comp : Entity_Id; 2040 Ins : Node_Id; 2041 Rhs : Node_Id; 2042 2043 begin 2044 -- For parameters, we insert the assignment 2045 -- right after the declaration of ARECnP. 2046 -- For all other entities, we insert the 2047 -- assignment immediately after the 2048 -- declaration of the entity or after the 2049 -- freeze node if present. 2050 2051 -- Note: we don't need to mark the entity 2052 -- as being aliased, because the address 2053 -- attribute will mark it as Address_Taken, 2054 -- and that is good enough. 2055 2056 if Is_Formal (Ent) then 2057 Ins := Decl_ARECnP; 2058 2059 elsif Has_Delayed_Freeze (Ent) then 2060 Ins := Freeze_Node (Ent); 2061 2062 else 2063 Ins := Dec; 2064 end if; 2065 2066 -- Build and insert the assignment: 2067 -- ARECn.nam := nam'Address 2068 -- or else 'Access for unconstrained array 2069 2070 if Needs_Fat_Pointer (Ent) then 2071 Attr := Name_Access; 2072 else 2073 Attr := Name_Address; 2074 end if; 2075 2076 Rhs := 2077 Make_Attribute_Reference (Loc, 2078 Prefix => 2079 New_Occurrence_Of (Ent, Loc), 2080 Attribute_Name => Attr); 2081 2082 -- If the entity is an unconstrained formal 2083 -- we wrap the attribute reference in an 2084 -- unchecked conversion to the type of the 2085 -- activation record component, to prevent 2086 -- spurious subtype conformance errors within 2087 -- instances. 2088 2089 if Is_Formal (Ent) 2090 and then not Is_Constrained (Etype (Ent)) 2091 then 2092 -- Find target component and its type 2093 2094 Comp := First_Component (STJ.ARECnT); 2095 while Chars (Comp) /= Chars (Ent) loop 2096 Comp := Next_Component (Comp); 2097 end loop; 2098 2099 Rhs := 2100 Unchecked_Convert_To (Etype (Comp), Rhs); 2101 end if; 2102 2103 Asn := 2104 Make_Assignment_Statement (Loc, 2105 Name => 2106 Make_Selected_Component (Loc, 2107 Prefix => 2108 New_Occurrence_Of (STJ.ARECn, Loc), 2109 Selector_Name => 2110 New_Occurrence_Of 2111 (Activation_Record_Component 2112 (Ent), 2113 Loc)), 2114 Expression => Rhs); 2115 2116 -- If we have a loop parameter, we have 2117 -- to insert before the first statement 2118 -- of the loop. Ins points to the 2119 -- N_Loop_Parameter_Specification or to 2120 -- an N_Iterator_Specification. 2121 2122 if Nkind_In 2123 (Ins, N_Iterator_Specification, 2124 N_Loop_Parameter_Specification) 2125 then 2126 -- Quantified expression are rewritten as 2127 -- loops during expansion. 2128 2129 if Nkind (Parent (Ins)) = 2130 N_Quantified_Expression 2131 then 2132 null; 2133 2134 else 2135 Ins := 2136 First 2137 (Statements 2138 (Parent (Parent (Ins)))); 2139 Insert_Before (Ins, Asn); 2140 end if; 2141 2142 else 2143 Insert_After (Ins, Asn); 2144 end if; 2145 2146 -- Analyze the assignment statement. We do 2147 -- not need to establish the relevant scope 2148 -- stack entries here, because we have 2149 -- already set the correct entity references, 2150 -- so no name resolution is required, and no 2151 -- new entities are created, so we don't even 2152 -- need to set the current scope. 2153 2154 -- We analyze with all checks suppressed 2155 -- (since we do not expect any exceptions). 2156 2157 Analyze (Asn, Suppress => All_Checks); 2158 end; 2159 2160 Next_Elmt (Elmt); 2161 end loop; 2162 end; 2163 end if; 2164 end; 2165 end if; 2166 end; 2167 end loop; 2168 end Subp_Loop; 2169 2170 -- Next step, process uplevel references. This has to be done in a 2171 -- separate pass, after completing the processing in Sub_Loop because we 2172 -- need all the AREC declarations generated, inserted, and analyzed so 2173 -- that the uplevel references can be successfully analyzed. 2174 2175 Uplev_Refs : for J in Urefs.First .. Urefs.Last loop 2176 declare 2177 UPJ : Uref_Entry renames Urefs.Table (J); 2178 2179 begin 2180 -- Ignore type references, these are implicit references that do 2181 -- not need rewriting (e.g. the appearence in a conversion). 2182 -- Also ignore if no reference was specified or if the rewriting 2183 -- has already been done (this can happen if the N_Identifier 2184 -- occurs more than one time in the tree). Also ignore references 2185 -- when not generating C code (in particular for the case of LLVM, 2186 -- since GNAT-LLVM will handle the processing for up-level refs). 2187 2188 if No (UPJ.Ref) 2189 or else not Is_Entity_Name (UPJ.Ref) 2190 or else not Present (Entity (UPJ.Ref)) 2191 or else not Opt.Generate_C_Code 2192 then 2193 goto Continue; 2194 end if; 2195 2196 -- Rewrite one reference 2197 2198 Rewrite_One_Ref : declare 2199 Loc : constant Source_Ptr := Sloc (UPJ.Ref); 2200 -- Source location for the reference 2201 2202 Typ : constant Entity_Id := Etype (UPJ.Ent); 2203 -- The type of the referenced entity 2204 2205 Atyp : Entity_Id; 2206 -- The actual subtype of the reference 2207 2208 RS_Caller : constant SI_Type := Subp_Index (UPJ.Caller); 2209 -- Subp_Index for caller containing reference 2210 2211 STJR : Subp_Entry renames Subps.Table (RS_Caller); 2212 -- Subp_Entry for subprogram containing reference 2213 2214 RS_Callee : constant SI_Type := Subp_Index (UPJ.Callee); 2215 -- Subp_Index for subprogram containing referenced entity 2216 2217 STJE : Subp_Entry renames Subps.Table (RS_Callee); 2218 -- Subp_Entry for subprogram containing referenced entity 2219 2220 Pfx : Node_Id; 2221 Comp : Entity_Id; 2222 SI : SI_Type; 2223 2224 begin 2225 Atyp := Etype (UPJ.Ref); 2226 2227 if Ekind (Atyp) /= E_Record_Subtype then 2228 Atyp := Get_Actual_Subtype (UPJ.Ref); 2229 end if; 2230 2231 -- Ignore if no ARECnF entity for enclosing subprogram which 2232 -- probably happens as a result of not properly treating 2233 -- instance bodies. To be examined ??? 2234 2235 -- If this test is omitted, then the compilation of freeze.adb 2236 -- and inline.adb fail in unnesting mode. 2237 2238 if No (STJR.ARECnF) then 2239 goto Continue; 2240 end if; 2241 2242 -- If this is a reference to a global constant, use its value 2243 -- rather than create a reference. It is more efficient and 2244 -- furthermore indispensable if the context requires a 2245 -- constant, such as a branch of a case statement. 2246 2247 if Ekind (UPJ.Ent) = E_Constant 2248 and then Is_True_Constant (UPJ.Ent) 2249 and then Present (Constant_Value (UPJ.Ent)) 2250 and then Is_Static_Expression (Constant_Value (UPJ.Ent)) 2251 then 2252 Rewrite (UPJ.Ref, New_Copy_Tree (Constant_Value (UPJ.Ent))); 2253 goto Continue; 2254 end if; 2255 2256 -- Push the current scope, so that the pointer type Tnn, and 2257 -- any subsidiary entities resulting from the analysis of the 2258 -- rewritten reference, go in the right entity chain. 2259 2260 Push_Scope (STJR.Ent); 2261 2262 -- Now we need to rewrite the reference. We have a reference 2263 -- from level STJR.Lev to level STJE.Lev. The general form of 2264 -- the rewritten reference for entity X is: 2265 2266 -- Typ'Deref (ARECaF.ARECbU.ARECcU.ARECdU....ARECmU.X) 2267 2268 -- where a,b,c,d .. m = 2269 -- STJR.Lev - 1, STJR.Lev - 2, .. STJE.Lev 2270 2271 pragma Assert (STJR.Lev > STJE.Lev); 2272 2273 -- Compute the prefix of X. Here are examples to make things 2274 -- clear (with parens to show groupings, the prefix is 2275 -- everything except the .X at the end). 2276 2277 -- level 2 to level 1 2278 2279 -- AREC1F.X 2280 2281 -- level 3 to level 1 2282 2283 -- (AREC2F.AREC1U).X 2284 2285 -- level 4 to level 1 2286 2287 -- ((AREC3F.AREC2U).AREC1U).X 2288 2289 -- level 6 to level 2 2290 2291 -- (((AREC5F.AREC4U).AREC3U).AREC2U).X 2292 2293 -- In the above, ARECnF and ARECnU are pointers, so there are 2294 -- explicit dereferences required for these occurrences. 2295 2296 Pfx := 2297 Make_Explicit_Dereference (Loc, 2298 Prefix => New_Occurrence_Of (STJR.ARECnF, Loc)); 2299 SI := RS_Caller; 2300 for L in STJE.Lev .. STJR.Lev - 2 loop 2301 SI := Enclosing_Subp (SI); 2302 Pfx := 2303 Make_Explicit_Dereference (Loc, 2304 Prefix => 2305 Make_Selected_Component (Loc, 2306 Prefix => Pfx, 2307 Selector_Name => 2308 New_Occurrence_Of (Subps.Table (SI).ARECnU, Loc))); 2309 end loop; 2310 2311 -- Get activation record component (must exist) 2312 2313 Comp := Activation_Record_Component (UPJ.Ent); 2314 pragma Assert (Present (Comp)); 2315 2316 -- Do the replacement. If the component type is an access type, 2317 -- this is an uplevel reference for an entity that requires a 2318 -- fat pointer, so dereference the component. 2319 2320 if Is_Access_Type (Etype (Comp)) then 2321 Rewrite (UPJ.Ref, 2322 Make_Explicit_Dereference (Loc, 2323 Prefix => 2324 Make_Selected_Component (Loc, 2325 Prefix => Pfx, 2326 Selector_Name => 2327 New_Occurrence_Of (Comp, Loc)))); 2328 2329 else 2330 Rewrite (UPJ.Ref, 2331 Make_Attribute_Reference (Loc, 2332 Prefix => New_Occurrence_Of (Atyp, Loc), 2333 Attribute_Name => Name_Deref, 2334 Expressions => New_List ( 2335 Make_Selected_Component (Loc, 2336 Prefix => Pfx, 2337 Selector_Name => 2338 New_Occurrence_Of (Comp, Loc))))); 2339 end if; 2340 2341 -- Analyze and resolve the new expression. We do not need to 2342 -- establish the relevant scope stack entries here, because we 2343 -- have already set all the correct entity references, so no 2344 -- name resolution is needed. We have already set the current 2345 -- scope, so that any new entities created will be in the right 2346 -- scope. 2347 2348 -- We analyze with all checks suppressed (since we do not 2349 -- expect any exceptions) 2350 2351 Analyze_And_Resolve (UPJ.Ref, Typ, Suppress => All_Checks); 2352 2353 -- Generate an extra temporary to facilitate the C backend 2354 -- processing this dereference 2355 2356 if Opt.Modify_Tree_For_C 2357 and then Nkind_In (Parent (UPJ.Ref), 2358 N_Type_Conversion, 2359 N_Unchecked_Type_Conversion) 2360 then 2361 Force_Evaluation (UPJ.Ref, Mode => Strict); 2362 end if; 2363 2364 Pop_Scope; 2365 end Rewrite_One_Ref; 2366 end; 2367 2368 <<Continue>> 2369 null; 2370 end loop Uplev_Refs; 2371 2372 -- Finally, loop through all calls adding extra actual for the 2373 -- activation record where it is required. 2374 2375 Adjust_Calls : for J in Calls.First .. Calls.Last loop 2376 2377 -- Process a single call, we are only interested in a call to a 2378 -- subprogram that actually needs a pointer to an activation record, 2379 -- as indicated by the ARECnF entity being set. This excludes the 2380 -- top level subprogram, and any subprogram not having uplevel refs. 2381 2382 Adjust_One_Call : declare 2383 CTJ : Call_Entry renames Calls.Table (J); 2384 STF : Subp_Entry renames Subps.Table (Subp_Index (CTJ.Caller)); 2385 STT : Subp_Entry renames Subps.Table (Subp_Index (CTJ.Callee)); 2386 2387 Loc : constant Source_Ptr := Sloc (CTJ.N); 2388 2389 Extra : Node_Id; 2390 ExtraP : Node_Id; 2391 SubX : SI_Type; 2392 Act : Node_Id; 2393 2394 begin 2395 if Present (STT.ARECnF) 2396 and then Nkind (CTJ.N) in N_Subprogram_Call 2397 then 2398 -- CTJ.N is a call to a subprogram which may require a pointer 2399 -- to an activation record. The subprogram containing the call 2400 -- is CTJ.From and the subprogram being called is CTJ.To, so we 2401 -- have a call from level STF.Lev to level STT.Lev. 2402 2403 -- There are three possibilities: 2404 2405 -- For a call to the same level, we just pass the activation 2406 -- record passed to the calling subprogram. 2407 2408 if STF.Lev = STT.Lev then 2409 Extra := New_Occurrence_Of (STF.ARECnF, Loc); 2410 2411 -- For a call that goes down a level, we pass a pointer to the 2412 -- activation record constructed within the caller (which may 2413 -- be the outer-level subprogram, but also may be a more deeply 2414 -- nested caller). 2415 2416 elsif STT.Lev = STF.Lev + 1 then 2417 Extra := New_Occurrence_Of (STF.ARECnP, Loc); 2418 2419 -- Otherwise we must have an upcall (STT.Lev < STF.LEV), 2420 -- since it is not possible to do a downcall of more than 2421 -- one level. 2422 2423 -- For a call from level STF.Lev to level STT.Lev, we 2424 -- have to find the activation record needed by the 2425 -- callee. This is as follows: 2426 2427 -- ARECaF.ARECbU.ARECcU....ARECmU 2428 2429 -- where a,b,c .. m = 2430 -- STF.Lev - 1, STF.Lev - 2, STF.Lev - 3 .. STT.Lev 2431 2432 else 2433 pragma Assert (STT.Lev < STF.Lev); 2434 2435 Extra := New_Occurrence_Of (STF.ARECnF, Loc); 2436 SubX := Subp_Index (CTJ.Caller); 2437 for K in reverse STT.Lev .. STF.Lev - 1 loop 2438 SubX := Enclosing_Subp (SubX); 2439 Extra := 2440 Make_Selected_Component (Loc, 2441 Prefix => Extra, 2442 Selector_Name => 2443 New_Occurrence_Of 2444 (Subps.Table (SubX).ARECnU, Loc)); 2445 end loop; 2446 end if; 2447 2448 -- Extra is the additional parameter to be added. Build a 2449 -- parameter association that we can append to the actuals. 2450 2451 ExtraP := 2452 Make_Parameter_Association (Loc, 2453 Selector_Name => 2454 New_Occurrence_Of (STT.ARECnF, Loc), 2455 Explicit_Actual_Parameter => Extra); 2456 2457 if No (Parameter_Associations (CTJ.N)) then 2458 Set_Parameter_Associations (CTJ.N, Empty_List); 2459 end if; 2460 2461 Append (ExtraP, Parameter_Associations (CTJ.N)); 2462 2463 -- We need to deal with the actual parameter chain as well. The 2464 -- newly added parameter is always the last actual. 2465 2466 Act := First_Named_Actual (CTJ.N); 2467 2468 if No (Act) then 2469 Set_First_Named_Actual (CTJ.N, Extra); 2470 2471 -- If call has been relocated (as with an expression in 2472 -- an aggregate), set First_Named pointer in original node 2473 -- as well, because that's the parent of the parameter list. 2474 2475 Set_First_Named_Actual 2476 (Parent (List_Containing (ExtraP)), Extra); 2477 2478 -- Here we must follow the chain and append the new entry 2479 2480 else 2481 loop 2482 declare 2483 PAN : Node_Id; 2484 NNA : Node_Id; 2485 2486 begin 2487 PAN := Parent (Act); 2488 pragma Assert (Nkind (PAN) = N_Parameter_Association); 2489 NNA := Next_Named_Actual (PAN); 2490 2491 if No (NNA) then 2492 Set_Next_Named_Actual (PAN, Extra); 2493 exit; 2494 end if; 2495 2496 Act := NNA; 2497 end; 2498 end loop; 2499 end if; 2500 2501 -- Analyze and resolve the new actual. We do not need to 2502 -- establish the relevant scope stack entries here, because 2503 -- we have already set all the correct entity references, so 2504 -- no name resolution is needed. 2505 2506 -- We analyze with all checks suppressed (since we do not 2507 -- expect any exceptions, and also we temporarily turn off 2508 -- Unested_Subprogram_Mode to avoid trying to mark uplevel 2509 -- references (not needed at this stage, and in fact causes 2510 -- a bit of recursive chaos). 2511 2512 Opt.Unnest_Subprogram_Mode := False; 2513 Analyze_And_Resolve 2514 (Extra, Etype (STT.ARECnF), Suppress => All_Checks); 2515 Opt.Unnest_Subprogram_Mode := True; 2516 end if; 2517 end Adjust_One_Call; 2518 end loop Adjust_Calls; 2519 2520 return; 2521 end Unnest_Subprogram; 2522 2523 ------------------------ 2524 -- Unnest_Subprograms -- 2525 ------------------------ 2526 2527 procedure Unnest_Subprograms (N : Node_Id) is 2528 function Search_Subprograms (N : Node_Id) return Traverse_Result; 2529 -- Tree visitor that search for outer level procedures with nested 2530 -- subprograms and invokes Unnest_Subprogram() 2531 2532 --------------- 2533 -- Do_Search -- 2534 --------------- 2535 2536 procedure Do_Search is new Traverse_Proc (Search_Subprograms); 2537 -- Subtree visitor instantiation 2538 2539 ------------------------ 2540 -- Search_Subprograms -- 2541 ------------------------ 2542 2543 function Search_Subprograms (N : Node_Id) return Traverse_Result is 2544 begin 2545 if Nkind_In (N, N_Subprogram_Body, N_Subprogram_Body_Stub) then 2546 declare 2547 Spec_Id : constant Entity_Id := Unique_Defining_Entity (N); 2548 2549 begin 2550 -- We are only interested in subprograms (not generic 2551 -- subprograms), that have nested subprograms. 2552 2553 if Is_Subprogram (Spec_Id) 2554 and then Has_Nested_Subprogram (Spec_Id) 2555 and then Is_Library_Level_Entity (Spec_Id) 2556 then 2557 Unnest_Subprogram (Spec_Id, N); 2558 end if; 2559 end; 2560 2561 -- The proper body of a stub may contain nested subprograms, and 2562 -- therefore must be visited explicitly. Nested stubs are examined 2563 -- recursively in Visit_Node. 2564 2565 elsif Nkind (N) in N_Body_Stub then 2566 Do_Search (Library_Unit (N)); 2567 2568 -- Skip generic packages 2569 2570 elsif Nkind (N) = N_Package_Body 2571 and then Ekind (Corresponding_Spec (N)) = E_Generic_Package 2572 then 2573 return Skip; 2574 end if; 2575 2576 return OK; 2577 end Search_Subprograms; 2578 2579 Subp : Entity_Id; 2580 Subp_Body : Node_Id; 2581 2582 -- Start of processing for Unnest_Subprograms 2583 2584 begin 2585 if not Opt.Unnest_Subprogram_Mode or not Opt.Expander_Active then 2586 return; 2587 end if; 2588 2589 -- A specification will contain bodies if it contains instantiations so 2590 -- examine package or subprogram declaration of the main unit, when it 2591 -- is present. 2592 2593 if Nkind (Unit (N)) = N_Package_Body 2594 or else (Nkind (Unit (N)) = N_Subprogram_Body 2595 and then not Acts_As_Spec (N)) 2596 then 2597 Do_Search (Library_Unit (N)); 2598 end if; 2599 2600 Do_Search (N); 2601 2602 -- Unnest any subprograms passed on the list of inlined subprograms 2603 2604 Subp := First_Inlined_Subprogram (N); 2605 2606 while Present (Subp) loop 2607 Subp_Body := Parent (Declaration_Node (Subp)); 2608 2609 if Nkind (Subp_Body) = N_Subprogram_Declaration 2610 and then Present (Corresponding_Body (Subp_Body)) 2611 then 2612 Subp_Body := Parent (Declaration_Node 2613 (Corresponding_Body (Subp_Body))); 2614 end if; 2615 2616 Unnest_Subprogram (Subp, Subp_Body, For_Inline => True); 2617 Next_Inlined_Subprogram (Subp); 2618 end loop; 2619 end Unnest_Subprograms; 2620 2621end Exp_Unst; 2622