1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- I N L I N E -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-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 Alloc; 27with Aspects; use Aspects; 28with Atree; use Atree; 29with Debug; use Debug; 30with Einfo; use Einfo; 31with Elists; use Elists; 32with Errout; use Errout; 33with Expander; use Expander; 34with Exp_Ch6; use Exp_Ch6; 35with Exp_Ch7; use Exp_Ch7; 36with Exp_Tss; use Exp_Tss; 37with Exp_Util; use Exp_Util; 38with Fname; use Fname; 39with Fname.UF; use Fname.UF; 40with Lib; use Lib; 41with Namet; use Namet; 42with Nmake; use Nmake; 43with Nlists; use Nlists; 44with Output; use Output; 45with Sem_Aux; use Sem_Aux; 46with Sem_Ch8; use Sem_Ch8; 47with Sem_Ch10; use Sem_Ch10; 48with Sem_Ch12; use Sem_Ch12; 49with Sem_Prag; use Sem_Prag; 50with Sem_Util; use Sem_Util; 51with Sinfo; use Sinfo; 52with Sinput; use Sinput; 53with Snames; use Snames; 54with Stand; use Stand; 55with Table; 56with Tbuild; use Tbuild; 57with Uintp; use Uintp; 58with Uname; use Uname; 59 60with GNAT.HTable; 61 62package body Inline is 63 64 Check_Inlining_Restrictions : constant Boolean := True; 65 -- In the following cases the frontend rejects inlining because they 66 -- are not handled well by the backend. This variable facilitates 67 -- disabling these restrictions to evaluate future versions of the 68 -- GCC backend in which some of the restrictions may be supported. 69 -- 70 -- - subprograms that have: 71 -- - nested subprograms 72 -- - instantiations 73 -- - package declarations 74 -- - task or protected object declarations 75 -- - some of the following statements: 76 -- - abort 77 -- - asynchronous-select 78 -- - conditional-entry-call 79 -- - delay-relative 80 -- - delay-until 81 -- - selective-accept 82 -- - timed-entry-call 83 84 Inlined_Calls : Elist_Id; 85 -- List of frontend inlined calls 86 87 Backend_Calls : Elist_Id; 88 -- List of inline calls passed to the backend 89 90 Backend_Instances : Elist_Id; 91 -- List of instances inlined for the backend 92 93 Backend_Inlined_Subps : Elist_Id; 94 -- List of subprograms inlined by the backend 95 96 Backend_Not_Inlined_Subps : Elist_Id; 97 -- List of subprograms that cannot be inlined by the backend 98 99 ----------------------------- 100 -- Pending_Instantiations -- 101 ----------------------------- 102 103 -- We make entries in this table for the pending instantiations of generic 104 -- bodies that are created during semantic analysis. After the analysis is 105 -- complete, calling Instantiate_Bodies performs the actual instantiations. 106 107 package Pending_Instantiations is new Table.Table ( 108 Table_Component_Type => Pending_Body_Info, 109 Table_Index_Type => Int, 110 Table_Low_Bound => 0, 111 Table_Initial => Alloc.Pending_Instantiations_Initial, 112 Table_Increment => Alloc.Pending_Instantiations_Increment, 113 Table_Name => "Pending_Instantiations"); 114 115 ------------------------------------- 116 -- Called_Pending_Instantiations -- 117 ------------------------------------- 118 119 -- With back-end inlining, the pending instantiations that are not in the 120 -- main unit or subunit are performed only after a call to the subprogram 121 -- instance, or to a subprogram within the package instance, is inlined. 122 -- Since such a call can be within a subsequent pending instantiation, 123 -- we make entries in this table that stores the index of these "called" 124 -- pending instantiations and perform them when the table is populated. 125 126 package Called_Pending_Instantiations is new Table.Table ( 127 Table_Component_Type => Int, 128 Table_Index_Type => Int, 129 Table_Low_Bound => 0, 130 Table_Initial => Alloc.Pending_Instantiations_Initial, 131 Table_Increment => Alloc.Pending_Instantiations_Increment, 132 Table_Name => "Called_Pending_Instantiations"); 133 134 --------------------------------- 135 -- To_Pending_Instantiations -- 136 --------------------------------- 137 138 -- With back-end inlining, we also need to have a map from the pending 139 -- instantiations to their index in the Pending_Instantiations table. 140 141 Node_Table_Size : constant := 257; 142 -- Number of headers in hash table 143 144 subtype Node_Header_Num is Integer range 0 .. Node_Table_Size - 1; 145 -- Range of headers in hash table 146 147 function Node_Hash (Id : Node_Id) return Node_Header_Num; 148 -- Simple hash function for Node_Ids 149 150 package To_Pending_Instantiations is new GNAT.Htable.Simple_HTable 151 (Header_Num => Node_Header_Num, 152 Element => Int, 153 No_Element => -1, 154 Key => Node_Id, 155 Hash => Node_Hash, 156 Equal => "="); 157 158 ----------------- 159 -- Node_Hash -- 160 ----------------- 161 162 function Node_Hash (Id : Node_Id) return Node_Header_Num is 163 begin 164 return Node_Header_Num (Id mod Node_Table_Size); 165 end Node_Hash; 166 167 -------------------- 168 -- Inlined Bodies -- 169 -------------------- 170 171 -- Inlined functions are actually placed in line by the backend if the 172 -- corresponding bodies are available (i.e. compiled). Whenever we find 173 -- a call to an inlined subprogram, we add the name of the enclosing 174 -- compilation unit to a worklist. After all compilation, and after 175 -- expansion of generic bodies, we traverse the list of pending bodies 176 -- and compile them as well. 177 178 package Inlined_Bodies is new Table.Table ( 179 Table_Component_Type => Entity_Id, 180 Table_Index_Type => Int, 181 Table_Low_Bound => 0, 182 Table_Initial => Alloc.Inlined_Bodies_Initial, 183 Table_Increment => Alloc.Inlined_Bodies_Increment, 184 Table_Name => "Inlined_Bodies"); 185 186 ----------------------- 187 -- Inline Processing -- 188 ----------------------- 189 190 -- For each call to an inlined subprogram, we make entries in a table 191 -- that stores caller and callee, and indicates the call direction from 192 -- one to the other. We also record the compilation unit that contains 193 -- the callee. After analyzing the bodies of all such compilation units, 194 -- we compute the transitive closure of inlined subprograms called from 195 -- the main compilation unit and make it available to the code generator 196 -- in no particular order, thus allowing cycles in the call graph. 197 198 Last_Inlined : Entity_Id := Empty; 199 200 -- For each entry in the table we keep a list of successors in topological 201 -- order, i.e. callers of the current subprogram. 202 203 type Subp_Index is new Nat; 204 No_Subp : constant Subp_Index := 0; 205 206 -- The subprogram entities are hashed into the Inlined table 207 208 Num_Hash_Headers : constant := 512; 209 210 Hash_Headers : array (Subp_Index range 0 .. Num_Hash_Headers - 1) 211 of Subp_Index; 212 213 type Succ_Index is new Nat; 214 No_Succ : constant Succ_Index := 0; 215 216 type Succ_Info is record 217 Subp : Subp_Index; 218 Next : Succ_Index; 219 end record; 220 221 -- The following table stores list elements for the successor lists. These 222 -- lists cannot be chained directly through entries in the Inlined table, 223 -- because a given subprogram can appear in several such lists. 224 225 package Successors is new Table.Table ( 226 Table_Component_Type => Succ_Info, 227 Table_Index_Type => Succ_Index, 228 Table_Low_Bound => 1, 229 Table_Initial => Alloc.Successors_Initial, 230 Table_Increment => Alloc.Successors_Increment, 231 Table_Name => "Successors"); 232 233 type Subp_Info is record 234 Name : Entity_Id := Empty; 235 Next : Subp_Index := No_Subp; 236 First_Succ : Succ_Index := No_Succ; 237 Main_Call : Boolean := False; 238 Processed : Boolean := False; 239 end record; 240 241 package Inlined is new Table.Table ( 242 Table_Component_Type => Subp_Info, 243 Table_Index_Type => Subp_Index, 244 Table_Low_Bound => 1, 245 Table_Initial => Alloc.Inlined_Initial, 246 Table_Increment => Alloc.Inlined_Increment, 247 Table_Name => "Inlined"); 248 249 ----------------------- 250 -- Local Subprograms -- 251 ----------------------- 252 253 procedure Add_Call (Called : Entity_Id; Caller : Entity_Id := Empty); 254 -- Make two entries in Inlined table, for an inlined subprogram being 255 -- called, and for the inlined subprogram that contains the call. If 256 -- the call is in the main compilation unit, Caller is Empty. 257 258 procedure Add_Inlined_Instance (E : Entity_Id); 259 -- Add instance E to the list of inlined instances for the unit 260 261 procedure Add_Inlined_Subprogram (E : Entity_Id); 262 -- Add subprogram E to the list of inlined subprograms for the unit 263 264 function Add_Subp (E : Entity_Id) return Subp_Index; 265 -- Make entry in Inlined table for subprogram E, or return table index 266 -- that already holds E. 267 268 function Get_Code_Unit_Entity (E : Entity_Id) return Entity_Id; 269 pragma Inline (Get_Code_Unit_Entity); 270 -- Return the entity node for the unit containing E. Always return the spec 271 -- for a package. 272 273 function Has_Initialized_Type (E : Entity_Id) return Boolean; 274 -- If a candidate for inlining contains type declarations for types with 275 -- nontrivial initialization procedures, they are not worth inlining. 276 277 function Has_Single_Return (N : Node_Id) return Boolean; 278 -- In general we cannot inline functions that return unconstrained type. 279 -- However, we can handle such functions if all return statements return 280 -- a local variable that is the first declaration in the body of the 281 -- function. In that case the call can be replaced by that local 282 -- variable as is done for other inlined calls. 283 284 function In_Main_Unit_Or_Subunit (E : Entity_Id) return Boolean; 285 -- Return True if E is in the main unit or its spec or in a subunit 286 287 function Is_Nested (E : Entity_Id) return Boolean; 288 -- If the function is nested inside some other function, it will always 289 -- be compiled if that function is, so don't add it to the inline list. 290 -- We cannot compile a nested function outside the scope of the containing 291 -- function anyway. This is also the case if the function is defined in a 292 -- task body or within an entry (for example, an initialization procedure). 293 294 procedure Remove_Aspects_And_Pragmas (Body_Decl : Node_Id); 295 -- Remove all aspects and/or pragmas that have no meaning in inlined body 296 -- Body_Decl. The analysis of these items is performed on the non-inlined 297 -- body. The items currently removed are: 298 -- Contract_Cases 299 -- Global 300 -- Depends 301 -- Postcondition 302 -- Precondition 303 -- Refined_Global 304 -- Refined_Depends 305 -- Refined_Post 306 -- Test_Case 307 -- Unmodified 308 -- Unreferenced 309 310 ------------------------------ 311 -- Deferred Cleanup Actions -- 312 ------------------------------ 313 314 -- The cleanup actions for scopes that contain instantiations is delayed 315 -- until after expansion of those instantiations, because they may contain 316 -- finalizable objects or tasks that affect the cleanup code. A scope 317 -- that contains instantiations only needs to be finalized once, even 318 -- if it contains more than one instance. We keep a list of scopes 319 -- that must still be finalized, and call cleanup_actions after all 320 -- the instantiations have been completed. 321 322 To_Clean : Elist_Id; 323 324 procedure Add_Scope_To_Clean (Inst : Entity_Id); 325 -- Build set of scopes on which cleanup actions must be performed 326 327 procedure Cleanup_Scopes; 328 -- Complete cleanup actions on scopes that need it 329 330 -------------- 331 -- Add_Call -- 332 -------------- 333 334 procedure Add_Call (Called : Entity_Id; Caller : Entity_Id := Empty) is 335 P1 : constant Subp_Index := Add_Subp (Called); 336 P2 : Subp_Index; 337 J : Succ_Index; 338 339 begin 340 if Present (Caller) then 341 P2 := Add_Subp (Caller); 342 343 -- Add P1 to the list of successors of P2, if not already there. 344 -- Note that P2 may contain more than one call to P1, and only 345 -- one needs to be recorded. 346 347 J := Inlined.Table (P2).First_Succ; 348 while J /= No_Succ loop 349 if Successors.Table (J).Subp = P1 then 350 return; 351 end if; 352 353 J := Successors.Table (J).Next; 354 end loop; 355 356 -- On exit, make a successor entry for P1 357 358 Successors.Increment_Last; 359 Successors.Table (Successors.Last).Subp := P1; 360 Successors.Table (Successors.Last).Next := 361 Inlined.Table (P2).First_Succ; 362 Inlined.Table (P2).First_Succ := Successors.Last; 363 else 364 Inlined.Table (P1).Main_Call := True; 365 end if; 366 end Add_Call; 367 368 ---------------------- 369 -- Add_Inlined_Body -- 370 ---------------------- 371 372 procedure Add_Inlined_Body (E : Entity_Id; N : Node_Id) is 373 374 type Inline_Level_Type is (Dont_Inline, Inline_Call, Inline_Package); 375 -- Level of inlining for the call: Dont_Inline means no inlining, 376 -- Inline_Call means that only the call is considered for inlining, 377 -- Inline_Package means that the call is considered for inlining and 378 -- its package compiled and scanned for more inlining opportunities. 379 380 function Is_Non_Loading_Expression_Function 381 (Id : Entity_Id) return Boolean; 382 -- Determine whether arbitrary entity Id denotes a subprogram which is 383 -- either 384 -- 385 -- * An expression function 386 -- 387 -- * A function completed by an expression function where both the 388 -- spec and body are in the same context. 389 390 function Must_Inline return Inline_Level_Type; 391 -- Inlining is only done if the call statement N is in the main unit, 392 -- or within the body of another inlined subprogram. 393 394 ---------------------------------------- 395 -- Is_Non_Loading_Expression_Function -- 396 ---------------------------------------- 397 398 function Is_Non_Loading_Expression_Function 399 (Id : Entity_Id) return Boolean 400 is 401 Body_Decl : Node_Id; 402 Body_Id : Entity_Id; 403 Spec_Decl : Node_Id; 404 405 begin 406 -- A stand-alone expression function is transformed into a spec-body 407 -- pair in-place. Since both the spec and body are in the same list, 408 -- the inlining of such an expression function does not need to load 409 -- anything extra. 410 411 if Is_Expression_Function (Id) then 412 return True; 413 414 -- A function may be completed by an expression function 415 416 elsif Ekind (Id) = E_Function then 417 Spec_Decl := Unit_Declaration_Node (Id); 418 419 if Nkind (Spec_Decl) = N_Subprogram_Declaration then 420 Body_Id := Corresponding_Body (Spec_Decl); 421 422 if Present (Body_Id) then 423 Body_Decl := Unit_Declaration_Node (Body_Id); 424 425 -- The inlining of a completing expression function does 426 -- not need to load anything extra when both the spec and 427 -- body are in the same context. 428 429 return 430 Was_Expression_Function (Body_Decl) 431 and then Parent (Spec_Decl) = Parent (Body_Decl); 432 end if; 433 end if; 434 end if; 435 436 return False; 437 end Is_Non_Loading_Expression_Function; 438 439 ----------------- 440 -- Must_Inline -- 441 ----------------- 442 443 function Must_Inline return Inline_Level_Type is 444 Scop : Entity_Id; 445 Comp : Node_Id; 446 447 begin 448 -- Check if call is in main unit 449 450 Scop := Current_Scope; 451 452 -- Do not try to inline if scope is standard. This could happen, for 453 -- example, for a call to Add_Global_Declaration, and it causes 454 -- trouble to try to inline at this level. 455 456 if Scop = Standard_Standard then 457 return Dont_Inline; 458 end if; 459 460 -- Otherwise lookup scope stack to outer scope 461 462 while Scope (Scop) /= Standard_Standard 463 and then not Is_Child_Unit (Scop) 464 loop 465 Scop := Scope (Scop); 466 end loop; 467 468 Comp := Parent (Scop); 469 while Nkind (Comp) /= N_Compilation_Unit loop 470 Comp := Parent (Comp); 471 end loop; 472 473 -- If the call is in the main unit, inline the call and compile the 474 -- package of the subprogram to find more calls to be inlined. 475 476 if Comp = Cunit (Main_Unit) 477 or else Comp = Library_Unit (Cunit (Main_Unit)) 478 then 479 Add_Call (E); 480 return Inline_Package; 481 end if; 482 483 -- The call is not in the main unit. See if it is in some subprogram 484 -- that can be inlined outside its unit. If so, inline the call and, 485 -- if the inlining level is set to 1, stop there; otherwise also 486 -- compile the package as above. 487 488 Scop := Current_Scope; 489 while Scope (Scop) /= Standard_Standard 490 and then not Is_Child_Unit (Scop) 491 loop 492 if Is_Overloadable (Scop) 493 and then Is_Inlined (Scop) 494 and then not Is_Nested (Scop) 495 then 496 Add_Call (E, Scop); 497 498 if Inline_Level = 1 then 499 return Inline_Call; 500 else 501 return Inline_Package; 502 end if; 503 end if; 504 505 Scop := Scope (Scop); 506 end loop; 507 508 return Dont_Inline; 509 end Must_Inline; 510 511 Inst : Entity_Id; 512 Inst_Decl : Node_Id; 513 Level : Inline_Level_Type; 514 515 -- Start of processing for Add_Inlined_Body 516 517 begin 518 Append_New_Elmt (N, To => Backend_Calls); 519 520 -- Skip subprograms that cannot or need not be inlined outside their 521 -- unit or parent subprogram. 522 523 if Is_Abstract_Subprogram (E) 524 or else Convention (E) = Convention_Protected 525 or else In_Main_Unit_Or_Subunit (E) 526 or else Is_Nested (E) 527 then 528 return; 529 end if; 530 531 -- Find out whether the call must be inlined. Unless the result is 532 -- Dont_Inline, Must_Inline also creates an edge for the call in the 533 -- callgraph; however, it will not be activated until after Is_Called 534 -- is set on the subprogram. 535 536 Level := Must_Inline; 537 538 if Level = Dont_Inline then 539 return; 540 end if; 541 542 -- If a previous call to the subprogram has been inlined, nothing to do 543 544 if Is_Called (E) then 545 return; 546 end if; 547 548 -- If the subprogram is an instance, then inline the instance 549 550 if Is_Generic_Instance (E) then 551 Add_Inlined_Instance (E); 552 end if; 553 554 -- Mark the subprogram as called 555 556 Set_Is_Called (E); 557 558 -- If the call was generated by the compiler and is to a subprogram in 559 -- a run-time unit, we need to suppress debugging information for it, 560 -- so that the code that is eventually inlined will not affect the 561 -- debugging of the program. We do not do it if the call comes from 562 -- source because, even if the call is inlined, the user may expect it 563 -- to be present in the debugging information. 564 565 if not Comes_From_Source (N) 566 and then In_Extended_Main_Source_Unit (N) 567 and then Is_Predefined_Unit (Get_Source_Unit (E)) 568 then 569 Set_Needs_Debug_Info (E, False); 570 end if; 571 572 -- If the subprogram is an expression function, or is completed by one 573 -- where both the spec and body are in the same context, then there is 574 -- no need to load any package body since the body of the function is 575 -- in the spec. 576 577 if Is_Non_Loading_Expression_Function (E) then 578 return; 579 end if; 580 581 -- Find unit containing E, and add to list of inlined bodies if needed. 582 -- Library-level functions must be handled specially, because there is 583 -- no enclosing package to retrieve. In this case, it is the body of 584 -- the function that will have to be loaded. 585 586 declare 587 Pack : constant Entity_Id := Get_Code_Unit_Entity (E); 588 589 begin 590 if Pack = E then 591 Inlined_Bodies.Increment_Last; 592 Inlined_Bodies.Table (Inlined_Bodies.Last) := E; 593 594 else 595 pragma Assert (Ekind (Pack) = E_Package); 596 597 -- If the subprogram is within an instance, inline the instance 598 599 if Comes_From_Source (E) then 600 Inst := Scope (E); 601 602 while Present (Inst) and then Inst /= Standard_Standard loop 603 exit when Is_Generic_Instance (Inst); 604 Inst := Scope (Inst); 605 end loop; 606 607 if Present (Inst) 608 and then Is_Generic_Instance (Inst) 609 and then not Is_Called (Inst) 610 then 611 Inst_Decl := Unit_Declaration_Node (Inst); 612 613 -- Do not inline the instance if the body already exists, 614 -- or the instance node is simply missing. 615 616 if Present (Corresponding_Body (Inst_Decl)) 617 or else (Nkind (Parent (Inst_Decl)) /= N_Compilation_Unit 618 and then No (Next (Inst_Decl))) 619 then 620 Set_Is_Called (Inst); 621 else 622 Add_Inlined_Instance (Inst); 623 end if; 624 end if; 625 end if; 626 627 -- If the unit containing E is an instance, nothing more to do 628 629 if Is_Generic_Instance (Pack) then 630 null; 631 632 -- Do not inline the package if the subprogram is an init proc 633 -- or other internally generated subprogram, because in that 634 -- case the subprogram body appears in the same unit that 635 -- declares the type, and that body is visible to the back end. 636 -- Do not inline it either if it is in the main unit. 637 -- Extend the -gnatn2 processing to -gnatn1 for Inline_Always 638 -- calls if the back end takes care of inlining the call. 639 -- Note that Level is in Inline_Call | Inline_Package here. 640 641 elsif ((Level = Inline_Call 642 and then Has_Pragma_Inline_Always (E) 643 and then Back_End_Inlining) 644 or else Level = Inline_Package) 645 and then not Is_Inlined (Pack) 646 and then not Is_Internal (E) 647 and then not In_Main_Unit_Or_Subunit (Pack) 648 then 649 Set_Is_Inlined (Pack); 650 Inlined_Bodies.Increment_Last; 651 Inlined_Bodies.Table (Inlined_Bodies.Last) := Pack; 652 end if; 653 end if; 654 655 -- Ensure that Analyze_Inlined_Bodies will be invoked after 656 -- completing the analysis of the current unit. 657 658 Inline_Processing_Required := True; 659 end; 660 end Add_Inlined_Body; 661 662 -------------------------- 663 -- Add_Inlined_Instance -- 664 -------------------------- 665 666 procedure Add_Inlined_Instance (E : Entity_Id) is 667 Decl_Node : constant Node_Id := Unit_Declaration_Node (E); 668 Index : Int; 669 670 begin 671 -- This machinery is only used with back-end inlining 672 673 if not Back_End_Inlining then 674 return; 675 end if; 676 677 -- Register the instance in the list 678 679 Append_New_Elmt (Decl_Node, To => Backend_Instances); 680 681 -- Retrieve the index of its corresponding pending instantiation 682 -- and mark this corresponding pending instantiation as needed. 683 684 Index := To_Pending_Instantiations.Get (Decl_Node); 685 if Index >= 0 then 686 Called_Pending_Instantiations.Append (Index); 687 else 688 pragma Assert (False); 689 null; 690 end if; 691 692 Set_Is_Called (E); 693 end Add_Inlined_Instance; 694 695 ---------------------------- 696 -- Add_Inlined_Subprogram -- 697 ---------------------------- 698 699 procedure Add_Inlined_Subprogram (E : Entity_Id) is 700 Decl : constant Node_Id := Parent (Declaration_Node (E)); 701 Pack : constant Entity_Id := Get_Code_Unit_Entity (E); 702 703 procedure Register_Backend_Inlined_Subprogram (Subp : Entity_Id); 704 -- Append Subp to the list of subprograms inlined by the backend 705 706 procedure Register_Backend_Not_Inlined_Subprogram (Subp : Entity_Id); 707 -- Append Subp to the list of subprograms that cannot be inlined by 708 -- the backend. 709 710 ----------------------------------------- 711 -- Register_Backend_Inlined_Subprogram -- 712 ----------------------------------------- 713 714 procedure Register_Backend_Inlined_Subprogram (Subp : Entity_Id) is 715 begin 716 Append_New_Elmt (Subp, To => Backend_Inlined_Subps); 717 end Register_Backend_Inlined_Subprogram; 718 719 --------------------------------------------- 720 -- Register_Backend_Not_Inlined_Subprogram -- 721 --------------------------------------------- 722 723 procedure Register_Backend_Not_Inlined_Subprogram (Subp : Entity_Id) is 724 begin 725 Append_New_Elmt (Subp, To => Backend_Not_Inlined_Subps); 726 end Register_Backend_Not_Inlined_Subprogram; 727 728 -- Start of processing for Add_Inlined_Subprogram 729 730 begin 731 -- We can inline the subprogram if its unit is known to be inlined or is 732 -- an instance whose body will be analyzed anyway or the subprogram was 733 -- generated as a body by the compiler (for example an initialization 734 -- procedure) or its declaration was provided along with the body (for 735 -- example an expression function) and it does not declare types with 736 -- nontrivial initialization procedures. 737 738 if (Is_Inlined (Pack) 739 or else Is_Generic_Instance (Pack) 740 or else Nkind (Decl) = N_Subprogram_Body 741 or else Present (Corresponding_Body (Decl))) 742 and then not Has_Initialized_Type (E) 743 then 744 Register_Backend_Inlined_Subprogram (E); 745 746 if No (Last_Inlined) then 747 Set_First_Inlined_Subprogram (Cunit (Main_Unit), E); 748 else 749 Set_Next_Inlined_Subprogram (Last_Inlined, E); 750 end if; 751 752 Last_Inlined := E; 753 754 else 755 Register_Backend_Not_Inlined_Subprogram (E); 756 end if; 757 end Add_Inlined_Subprogram; 758 759 -------------------------------- 760 -- Add_Pending_Instantiation -- 761 -------------------------------- 762 763 procedure Add_Pending_Instantiation (Inst : Node_Id; Act_Decl : Node_Id) is 764 Act_Decl_Id : Entity_Id; 765 Index : Int; 766 767 begin 768 -- Here is a defense against a ludicrous number of instantiations 769 -- caused by a circular set of instantiation attempts. 770 771 if Pending_Instantiations.Last + 1 >= Maximum_Instantiations then 772 Error_Msg_Uint_1 := UI_From_Int (Maximum_Instantiations); 773 Error_Msg_N ("too many instantiations, exceeds max of^", Inst); 774 Error_Msg_N ("\limit can be changed using -gnateinn switch", Inst); 775 raise Unrecoverable_Error; 776 end if; 777 778 -- Capture the body of the generic instantiation along with its context 779 -- for later processing by Instantiate_Bodies. 780 781 Pending_Instantiations.Append 782 ((Act_Decl => Act_Decl, 783 Config_Switches => Save_Config_Switches, 784 Current_Sem_Unit => Current_Sem_Unit, 785 Expander_Status => Expander_Active, 786 Inst_Node => Inst, 787 Local_Suppress_Stack_Top => Local_Suppress_Stack_Top, 788 Scope_Suppress => Scope_Suppress, 789 Warnings => Save_Warnings)); 790 791 -- With back-end inlining, also associate the index to the instantiation 792 793 if Back_End_Inlining then 794 Act_Decl_Id := Defining_Entity (Act_Decl); 795 Index := Pending_Instantiations.Last; 796 797 To_Pending_Instantiations.Set (Act_Decl, Index); 798 799 -- If an instantiation is in the main unit or subunit, or is a nested 800 -- subprogram, then its body is needed as per the analysis done in 801 -- Analyze_Package_Instantiation & Analyze_Subprogram_Instantiation. 802 803 if In_Main_Unit_Or_Subunit (Act_Decl_Id) 804 or else (Is_Subprogram (Act_Decl_Id) 805 and then Is_Nested (Act_Decl_Id)) 806 then 807 Called_Pending_Instantiations.Append (Index); 808 809 Set_Is_Called (Act_Decl_Id); 810 end if; 811 end if; 812 end Add_Pending_Instantiation; 813 814 ------------------------ 815 -- Add_Scope_To_Clean -- 816 ------------------------ 817 818 procedure Add_Scope_To_Clean (Inst : Entity_Id) is 819 Scop : constant Entity_Id := Enclosing_Dynamic_Scope (Inst); 820 Elmt : Elmt_Id; 821 822 begin 823 -- If the instance appears in a library-level package declaration, 824 -- all finalization is global, and nothing needs doing here. 825 826 if Scop = Standard_Standard then 827 return; 828 end if; 829 830 -- If the instance is within a generic unit, no finalization code 831 -- can be generated. Note that at this point all bodies have been 832 -- analyzed, and the scope stack itself is not present, and the flag 833 -- Inside_A_Generic is not set. 834 835 declare 836 S : Entity_Id; 837 838 begin 839 S := Scope (Inst); 840 while Present (S) and then S /= Standard_Standard loop 841 if Is_Generic_Unit (S) then 842 return; 843 end if; 844 845 S := Scope (S); 846 end loop; 847 end; 848 849 Elmt := First_Elmt (To_Clean); 850 while Present (Elmt) loop 851 if Node (Elmt) = Scop then 852 return; 853 end if; 854 855 Elmt := Next_Elmt (Elmt); 856 end loop; 857 858 Append_Elmt (Scop, To_Clean); 859 end Add_Scope_To_Clean; 860 861 -------------- 862 -- Add_Subp -- 863 -------------- 864 865 function Add_Subp (E : Entity_Id) return Subp_Index is 866 Index : Subp_Index := Subp_Index (E) mod Num_Hash_Headers; 867 J : Subp_Index; 868 869 procedure New_Entry; 870 -- Initialize entry in Inlined table 871 872 procedure New_Entry is 873 begin 874 Inlined.Increment_Last; 875 Inlined.Table (Inlined.Last).Name := E; 876 Inlined.Table (Inlined.Last).Next := No_Subp; 877 Inlined.Table (Inlined.Last).First_Succ := No_Succ; 878 Inlined.Table (Inlined.Last).Main_Call := False; 879 Inlined.Table (Inlined.Last).Processed := False; 880 end New_Entry; 881 882 -- Start of processing for Add_Subp 883 884 begin 885 if Hash_Headers (Index) = No_Subp then 886 New_Entry; 887 Hash_Headers (Index) := Inlined.Last; 888 return Inlined.Last; 889 890 else 891 J := Hash_Headers (Index); 892 while J /= No_Subp loop 893 if Inlined.Table (J).Name = E then 894 return J; 895 else 896 Index := J; 897 J := Inlined.Table (J).Next; 898 end if; 899 end loop; 900 901 -- On exit, subprogram was not found. Enter in table. Index is 902 -- the current last entry on the hash chain. 903 904 New_Entry; 905 Inlined.Table (Index).Next := Inlined.Last; 906 return Inlined.Last; 907 end if; 908 end Add_Subp; 909 910 ---------------------------- 911 -- Analyze_Inlined_Bodies -- 912 ---------------------------- 913 914 procedure Analyze_Inlined_Bodies is 915 Comp_Unit : Node_Id; 916 J : Int; 917 Pack : Entity_Id; 918 Subp : Subp_Index; 919 S : Succ_Index; 920 921 type Pending_Index is new Nat; 922 923 package Pending_Inlined is new Table.Table ( 924 Table_Component_Type => Subp_Index, 925 Table_Index_Type => Pending_Index, 926 Table_Low_Bound => 1, 927 Table_Initial => Alloc.Inlined_Initial, 928 Table_Increment => Alloc.Inlined_Increment, 929 Table_Name => "Pending_Inlined"); 930 -- The workpile used to compute the transitive closure 931 932 -- Start of processing for Analyze_Inlined_Bodies 933 934 begin 935 if Serious_Errors_Detected = 0 then 936 Push_Scope (Standard_Standard); 937 938 J := 0; 939 while J <= Inlined_Bodies.Last 940 and then Serious_Errors_Detected = 0 941 loop 942 Pack := Inlined_Bodies.Table (J); 943 while Present (Pack) 944 and then Scope (Pack) /= Standard_Standard 945 and then not Is_Child_Unit (Pack) 946 loop 947 Pack := Scope (Pack); 948 end loop; 949 950 Comp_Unit := Parent (Pack); 951 while Present (Comp_Unit) 952 and then Nkind (Comp_Unit) /= N_Compilation_Unit 953 loop 954 Comp_Unit := Parent (Comp_Unit); 955 end loop; 956 957 -- Load the body if it exists and contains inlineable entities, 958 -- unless it is the main unit, or is an instance whose body has 959 -- already been analyzed. 960 961 if Present (Comp_Unit) 962 and then Comp_Unit /= Cunit (Main_Unit) 963 and then Body_Required (Comp_Unit) 964 and then 965 (Nkind (Unit (Comp_Unit)) /= N_Package_Declaration 966 or else 967 (No (Corresponding_Body (Unit (Comp_Unit))) 968 and then Body_Needed_For_Inlining 969 (Defining_Entity (Unit (Comp_Unit))))) 970 then 971 declare 972 Bname : constant Unit_Name_Type := 973 Get_Body_Name (Get_Unit_Name (Unit (Comp_Unit))); 974 975 OK : Boolean; 976 977 begin 978 if not Is_Loaded (Bname) then 979 Style_Check := False; 980 Load_Needed_Body (Comp_Unit, OK); 981 982 if not OK then 983 984 -- Warn that a body was not available for inlining 985 -- by the back-end. 986 987 Error_Msg_Unit_1 := Bname; 988 Error_Msg_N 989 ("one or more inlined subprograms accessed in $!??", 990 Comp_Unit); 991 Error_Msg_File_1 := 992 Get_File_Name (Bname, Subunit => False); 993 Error_Msg_N ("\but file{ was not found!??", Comp_Unit); 994 end if; 995 end if; 996 end; 997 end if; 998 999 J := J + 1; 1000 1001 if J > Inlined_Bodies.Last then 1002 1003 -- The analysis of required bodies may have produced additional 1004 -- generic instantiations. To obtain further inlining, we need 1005 -- to perform another round of generic body instantiations. 1006 1007 Instantiate_Bodies; 1008 1009 -- Symmetrically, the instantiation of required generic bodies 1010 -- may have caused additional bodies to be inlined. To obtain 1011 -- further inlining, we keep looping over the inlined bodies. 1012 end if; 1013 end loop; 1014 1015 -- The list of inlined subprograms is an overestimate, because it 1016 -- includes inlined functions called from functions that are compiled 1017 -- as part of an inlined package, but are not themselves called. An 1018 -- accurate computation of just those subprograms that are needed 1019 -- requires that we perform a transitive closure over the call graph, 1020 -- starting from calls in the main compilation unit. 1021 1022 for Index in Inlined.First .. Inlined.Last loop 1023 if not Is_Called (Inlined.Table (Index).Name) then 1024 1025 -- This means that Add_Inlined_Body added the subprogram to the 1026 -- table but wasn't able to handle its code unit. Do nothing. 1027 1028 Inlined.Table (Index).Processed := True; 1029 1030 elsif Inlined.Table (Index).Main_Call then 1031 Pending_Inlined.Increment_Last; 1032 Pending_Inlined.Table (Pending_Inlined.Last) := Index; 1033 Inlined.Table (Index).Processed := True; 1034 1035 else 1036 Set_Is_Called (Inlined.Table (Index).Name, False); 1037 end if; 1038 end loop; 1039 1040 -- Iterate over the workpile until it is emptied, propagating the 1041 -- Is_Called flag to the successors of the processed subprogram. 1042 1043 while Pending_Inlined.Last >= Pending_Inlined.First loop 1044 Subp := Pending_Inlined.Table (Pending_Inlined.Last); 1045 Pending_Inlined.Decrement_Last; 1046 1047 S := Inlined.Table (Subp).First_Succ; 1048 1049 while S /= No_Succ loop 1050 Subp := Successors.Table (S).Subp; 1051 1052 if not Inlined.Table (Subp).Processed then 1053 Set_Is_Called (Inlined.Table (Subp).Name); 1054 Pending_Inlined.Increment_Last; 1055 Pending_Inlined.Table (Pending_Inlined.Last) := Subp; 1056 Inlined.Table (Subp).Processed := True; 1057 end if; 1058 1059 S := Successors.Table (S).Next; 1060 end loop; 1061 end loop; 1062 1063 -- Finally add the called subprograms to the list of inlined 1064 -- subprograms for the unit. 1065 1066 for Index in Inlined.First .. Inlined.Last loop 1067 if Is_Called (Inlined.Table (Index).Name) then 1068 Add_Inlined_Subprogram (Inlined.Table (Index).Name); 1069 end if; 1070 end loop; 1071 1072 Pop_Scope; 1073 end if; 1074 end Analyze_Inlined_Bodies; 1075 1076 -------------------------- 1077 -- Build_Body_To_Inline -- 1078 -------------------------- 1079 1080 procedure Build_Body_To_Inline (N : Node_Id; Spec_Id : Entity_Id) is 1081 Decl : constant Node_Id := Unit_Declaration_Node (Spec_Id); 1082 Analysis_Status : constant Boolean := Full_Analysis; 1083 Original_Body : Node_Id; 1084 Body_To_Analyze : Node_Id; 1085 Max_Size : constant := 10; 1086 1087 function Has_Extended_Return return Boolean; 1088 -- This function returns True if the subprogram has an extended return 1089 -- statement. 1090 1091 function Has_Pending_Instantiation return Boolean; 1092 -- If some enclosing body contains instantiations that appear before 1093 -- the corresponding generic body, the enclosing body has a freeze node 1094 -- so that it can be elaborated after the generic itself. This might 1095 -- conflict with subsequent inlinings, so that it is unsafe to try to 1096 -- inline in such a case. 1097 1098 function Has_Single_Return_In_GNATprove_Mode return Boolean; 1099 -- This function is called only in GNATprove mode, and it returns 1100 -- True if the subprogram has no return statement or a single return 1101 -- statement as last statement. It returns False for subprogram with 1102 -- a single return as last statement inside one or more blocks, as 1103 -- inlining would generate gotos in that case as well (although the 1104 -- goto is useless in that case). 1105 1106 function Uses_Secondary_Stack (Bod : Node_Id) return Boolean; 1107 -- If the body of the subprogram includes a call that returns an 1108 -- unconstrained type, the secondary stack is involved, and it is 1109 -- not worth inlining. 1110 1111 ------------------------- 1112 -- Has_Extended_Return -- 1113 ------------------------- 1114 1115 function Has_Extended_Return return Boolean is 1116 Body_To_Inline : constant Node_Id := N; 1117 1118 function Check_Return (N : Node_Id) return Traverse_Result; 1119 -- Returns OK on node N if this is not an extended return statement 1120 1121 ------------------ 1122 -- Check_Return -- 1123 ------------------ 1124 1125 function Check_Return (N : Node_Id) return Traverse_Result is 1126 begin 1127 case Nkind (N) is 1128 when N_Extended_Return_Statement => 1129 return Abandon; 1130 1131 -- Skip locally declared subprogram bodies inside the body to 1132 -- inline, as the return statements inside those do not count. 1133 1134 when N_Subprogram_Body => 1135 if N = Body_To_Inline then 1136 return OK; 1137 else 1138 return Skip; 1139 end if; 1140 1141 when others => 1142 return OK; 1143 end case; 1144 end Check_Return; 1145 1146 function Check_All_Returns is new Traverse_Func (Check_Return); 1147 1148 -- Start of processing for Has_Extended_Return 1149 1150 begin 1151 return Check_All_Returns (N) /= OK; 1152 end Has_Extended_Return; 1153 1154 ------------------------------- 1155 -- Has_Pending_Instantiation -- 1156 ------------------------------- 1157 1158 function Has_Pending_Instantiation return Boolean is 1159 S : Entity_Id; 1160 1161 begin 1162 S := Current_Scope; 1163 while Present (S) loop 1164 if Is_Compilation_Unit (S) 1165 or else Is_Child_Unit (S) 1166 then 1167 return False; 1168 1169 elsif Ekind (S) = E_Package 1170 and then Has_Forward_Instantiation (S) 1171 then 1172 return True; 1173 end if; 1174 1175 S := Scope (S); 1176 end loop; 1177 1178 return False; 1179 end Has_Pending_Instantiation; 1180 1181 ----------------------------------------- 1182 -- Has_Single_Return_In_GNATprove_Mode -- 1183 ----------------------------------------- 1184 1185 function Has_Single_Return_In_GNATprove_Mode return Boolean is 1186 Body_To_Inline : constant Node_Id := N; 1187 Last_Statement : Node_Id := Empty; 1188 1189 function Check_Return (N : Node_Id) return Traverse_Result; 1190 -- Returns OK on node N if this is not a return statement different 1191 -- from the last statement in the subprogram. 1192 1193 ------------------ 1194 -- Check_Return -- 1195 ------------------ 1196 1197 function Check_Return (N : Node_Id) return Traverse_Result is 1198 begin 1199 case Nkind (N) is 1200 when N_Extended_Return_Statement 1201 | N_Simple_Return_Statement 1202 => 1203 if N = Last_Statement then 1204 return OK; 1205 else 1206 return Abandon; 1207 end if; 1208 1209 -- Skip locally declared subprogram bodies inside the body to 1210 -- inline, as the return statements inside those do not count. 1211 1212 when N_Subprogram_Body => 1213 if N = Body_To_Inline then 1214 return OK; 1215 else 1216 return Skip; 1217 end if; 1218 1219 when others => 1220 return OK; 1221 end case; 1222 end Check_Return; 1223 1224 function Check_All_Returns is new Traverse_Func (Check_Return); 1225 1226 -- Start of processing for Has_Single_Return_In_GNATprove_Mode 1227 1228 begin 1229 -- Retrieve the last statement 1230 1231 Last_Statement := Last (Statements (Handled_Statement_Sequence (N))); 1232 1233 -- Check that the last statement is the only possible return 1234 -- statement in the subprogram. 1235 1236 return Check_All_Returns (N) = OK; 1237 end Has_Single_Return_In_GNATprove_Mode; 1238 1239 -------------------------- 1240 -- Uses_Secondary_Stack -- 1241 -------------------------- 1242 1243 function Uses_Secondary_Stack (Bod : Node_Id) return Boolean is 1244 function Check_Call (N : Node_Id) return Traverse_Result; 1245 -- Look for function calls that return an unconstrained type 1246 1247 ---------------- 1248 -- Check_Call -- 1249 ---------------- 1250 1251 function Check_Call (N : Node_Id) return Traverse_Result is 1252 begin 1253 if Nkind (N) = N_Function_Call 1254 and then Is_Entity_Name (Name (N)) 1255 and then Is_Composite_Type (Etype (Entity (Name (N)))) 1256 and then not Is_Constrained (Etype (Entity (Name (N)))) 1257 then 1258 Cannot_Inline 1259 ("cannot inline & (call returns unconstrained type)?", 1260 N, Spec_Id); 1261 return Abandon; 1262 else 1263 return OK; 1264 end if; 1265 end Check_Call; 1266 1267 function Check_Calls is new Traverse_Func (Check_Call); 1268 1269 begin 1270 return Check_Calls (Bod) = Abandon; 1271 end Uses_Secondary_Stack; 1272 1273 -- Start of processing for Build_Body_To_Inline 1274 1275 begin 1276 -- Return immediately if done already 1277 1278 if Nkind (Decl) = N_Subprogram_Declaration 1279 and then Present (Body_To_Inline (Decl)) 1280 then 1281 return; 1282 1283 -- Subprograms that have return statements in the middle of the body are 1284 -- inlined with gotos. GNATprove does not currently support gotos, so 1285 -- we prevent such inlining. 1286 1287 elsif GNATprove_Mode 1288 and then not Has_Single_Return_In_GNATprove_Mode 1289 then 1290 Cannot_Inline ("cannot inline & (multiple returns)?", N, Spec_Id); 1291 return; 1292 1293 -- Functions that return controlled types cannot currently be inlined 1294 -- because they require secondary stack handling; controlled actions 1295 -- may also interfere in complex ways with inlining. 1296 1297 elsif Ekind (Spec_Id) = E_Function 1298 and then Needs_Finalization (Etype (Spec_Id)) 1299 then 1300 Cannot_Inline 1301 ("cannot inline & (controlled return type)?", N, Spec_Id); 1302 return; 1303 end if; 1304 1305 if Present (Declarations (N)) 1306 and then Has_Excluded_Declaration (Spec_Id, Declarations (N)) 1307 then 1308 return; 1309 end if; 1310 1311 if Present (Handled_Statement_Sequence (N)) then 1312 if Present (Exception_Handlers (Handled_Statement_Sequence (N))) then 1313 Cannot_Inline 1314 ("cannot inline& (exception handler)?", 1315 First (Exception_Handlers (Handled_Statement_Sequence (N))), 1316 Spec_Id); 1317 return; 1318 1319 elsif Has_Excluded_Statement 1320 (Spec_Id, Statements (Handled_Statement_Sequence (N))) 1321 then 1322 return; 1323 end if; 1324 end if; 1325 1326 -- We do not inline a subprogram that is too large, unless it is marked 1327 -- Inline_Always or we are in GNATprove mode. This pragma does not 1328 -- suppress the other checks on inlining (forbidden declarations, 1329 -- handlers, etc). 1330 1331 if not (Has_Pragma_Inline_Always (Spec_Id) or else GNATprove_Mode) 1332 and then List_Length 1333 (Statements (Handled_Statement_Sequence (N))) > Max_Size 1334 then 1335 Cannot_Inline ("cannot inline& (body too large)?", N, Spec_Id); 1336 return; 1337 end if; 1338 1339 if Has_Pending_Instantiation then 1340 Cannot_Inline 1341 ("cannot inline& (forward instance within enclosing body)?", 1342 N, Spec_Id); 1343 return; 1344 end if; 1345 1346 -- Within an instance, the body to inline must be treated as a nested 1347 -- generic, so that the proper global references are preserved. 1348 1349 -- Note that we do not do this at the library level, because it is not 1350 -- needed, and furthermore this causes trouble if front-end inlining 1351 -- is activated (-gnatN). 1352 1353 if In_Instance and then Scope (Current_Scope) /= Standard_Standard then 1354 Save_Env (Scope (Current_Scope), Scope (Current_Scope)); 1355 Original_Body := Copy_Generic_Node (N, Empty, Instantiating => True); 1356 else 1357 Original_Body := Copy_Separate_Tree (N); 1358 end if; 1359 1360 -- We need to capture references to the formals in order to substitute 1361 -- the actuals at the point of inlining, i.e. instantiation. To treat 1362 -- the formals as globals to the body to inline, we nest it within a 1363 -- dummy parameterless subprogram, declared within the real one. To 1364 -- avoid generating an internal name (which is never public, and which 1365 -- affects serial numbers of other generated names), we use an internal 1366 -- symbol that cannot conflict with user declarations. 1367 1368 Set_Parameter_Specifications (Specification (Original_Body), No_List); 1369 Set_Defining_Unit_Name 1370 (Specification (Original_Body), 1371 Make_Defining_Identifier (Sloc (N), Name_uParent)); 1372 Set_Corresponding_Spec (Original_Body, Empty); 1373 1374 -- Remove all aspects/pragmas that have no meaning in an inlined body 1375 1376 Remove_Aspects_And_Pragmas (Original_Body); 1377 1378 Body_To_Analyze := 1379 Copy_Generic_Node (Original_Body, Empty, Instantiating => False); 1380 1381 -- Set return type of function, which is also global and does not need 1382 -- to be resolved. 1383 1384 if Ekind (Spec_Id) = E_Function then 1385 Set_Result_Definition 1386 (Specification (Body_To_Analyze), 1387 New_Occurrence_Of (Etype (Spec_Id), Sloc (N))); 1388 end if; 1389 1390 if No (Declarations (N)) then 1391 Set_Declarations (N, New_List (Body_To_Analyze)); 1392 else 1393 Append (Body_To_Analyze, Declarations (N)); 1394 end if; 1395 1396 -- The body to inline is preanalyzed. In GNATprove mode we must disable 1397 -- full analysis as well so that light expansion does not take place 1398 -- either, and name resolution is unaffected. 1399 1400 Expander_Mode_Save_And_Set (False); 1401 Full_Analysis := False; 1402 1403 Analyze (Body_To_Analyze); 1404 Push_Scope (Defining_Entity (Body_To_Analyze)); 1405 Save_Global_References (Original_Body); 1406 End_Scope; 1407 Remove (Body_To_Analyze); 1408 1409 Expander_Mode_Restore; 1410 Full_Analysis := Analysis_Status; 1411 1412 -- Restore environment if previously saved 1413 1414 if In_Instance and then Scope (Current_Scope) /= Standard_Standard then 1415 Restore_Env; 1416 end if; 1417 1418 -- Functions that return unconstrained composite types require 1419 -- secondary stack handling, and cannot currently be inlined, unless 1420 -- all return statements return a local variable that is the first 1421 -- local declaration in the body. We had to delay this check until 1422 -- the body of the function is analyzed since Has_Single_Return() 1423 -- requires a minimum decoration. 1424 1425 if Ekind (Spec_Id) = E_Function 1426 and then not Is_Scalar_Type (Etype (Spec_Id)) 1427 and then not Is_Access_Type (Etype (Spec_Id)) 1428 and then not Is_Constrained (Etype (Spec_Id)) 1429 then 1430 if not Has_Single_Return (Body_To_Analyze) 1431 1432 -- Skip inlining if the function returns an unconstrained type 1433 -- using an extended return statement, since this part of the 1434 -- new inlining model is not yet supported by the current 1435 -- implementation. ??? 1436 1437 or else (Returns_Unconstrained_Type (Spec_Id) 1438 and then Has_Extended_Return) 1439 then 1440 Cannot_Inline 1441 ("cannot inline & (unconstrained return type)?", N, Spec_Id); 1442 return; 1443 end if; 1444 1445 -- If secondary stack is used, there is no point in inlining. We have 1446 -- already issued the warning in this case, so nothing to do. 1447 1448 elsif Uses_Secondary_Stack (Body_To_Analyze) then 1449 return; 1450 end if; 1451 1452 Set_Body_To_Inline (Decl, Original_Body); 1453 Set_Ekind (Defining_Entity (Original_Body), Ekind (Spec_Id)); 1454 Set_Is_Inlined (Spec_Id); 1455 end Build_Body_To_Inline; 1456 1457 ------------------------------------------- 1458 -- Call_Can_Be_Inlined_In_GNATprove_Mode -- 1459 ------------------------------------------- 1460 1461 function Call_Can_Be_Inlined_In_GNATprove_Mode 1462 (N : Node_Id; 1463 Subp : Entity_Id) return Boolean 1464 is 1465 F : Entity_Id; 1466 A : Node_Id; 1467 1468 begin 1469 F := First_Formal (Subp); 1470 A := First_Actual (N); 1471 while Present (F) loop 1472 if Ekind (F) /= E_Out_Parameter 1473 and then not Same_Type (Etype (F), Etype (A)) 1474 and then 1475 (Is_By_Reference_Type (Etype (A)) 1476 or else Is_Limited_Type (Etype (A))) 1477 then 1478 return False; 1479 end if; 1480 1481 Next_Formal (F); 1482 Next_Actual (A); 1483 end loop; 1484 1485 return True; 1486 end Call_Can_Be_Inlined_In_GNATprove_Mode; 1487 1488 -------------------------------------- 1489 -- Can_Be_Inlined_In_GNATprove_Mode -- 1490 -------------------------------------- 1491 1492 function Can_Be_Inlined_In_GNATprove_Mode 1493 (Spec_Id : Entity_Id; 1494 Body_Id : Entity_Id) return Boolean 1495 is 1496 function Has_Formal_Or_Result_Of_Deep_Type 1497 (Id : Entity_Id) return Boolean; 1498 -- Returns true if the subprogram has at least one formal parameter or 1499 -- a return type of a deep type: either an access type or a composite 1500 -- type containing an access type. 1501 1502 function Has_Formal_With_Discriminant_Dependent_Fields 1503 (Id : Entity_Id) return Boolean; 1504 -- Returns true if the subprogram has at least one formal parameter of 1505 -- an unconstrained record type with per-object constraints on component 1506 -- types. 1507 1508 function Has_Some_Contract (Id : Entity_Id) return Boolean; 1509 -- Return True if subprogram Id has any contract. The presence of 1510 -- Extensions_Visible or Volatile_Function is also considered as a 1511 -- contract here. 1512 1513 function Is_Unit_Subprogram (Id : Entity_Id) return Boolean; 1514 -- Return True if subprogram Id defines a compilation unit 1515 -- Shouldn't this be in Sem_Aux??? 1516 1517 function In_Package_Spec (Id : Entity_Id) return Boolean; 1518 -- Return True if subprogram Id is defined in the package specification, 1519 -- either its visible or private part. 1520 1521 function Maybe_Traversal_Function (Id : Entity_Id) return Boolean; 1522 -- Return True if subprogram Id could be a traversal function, as 1523 -- defined in SPARK RM 3.10. This is only a safe approximation, as the 1524 -- knowledge of the SPARK boundary is needed to determine exactly 1525 -- traversal functions. 1526 1527 --------------------------------------- 1528 -- Has_Formal_Or_Result_Of_Deep_Type -- 1529 --------------------------------------- 1530 1531 function Has_Formal_Or_Result_Of_Deep_Type 1532 (Id : Entity_Id) return Boolean 1533 is 1534 function Is_Deep (Typ : Entity_Id) return Boolean; 1535 -- Return True if Typ is deep: either an access type or a composite 1536 -- type containing an access type. 1537 1538 ------------- 1539 -- Is_Deep -- 1540 ------------- 1541 1542 function Is_Deep (Typ : Entity_Id) return Boolean is 1543 begin 1544 case Type_Kind'(Ekind (Typ)) is 1545 when Access_Kind => 1546 return True; 1547 1548 when E_Array_Type 1549 | E_Array_Subtype 1550 => 1551 return Is_Deep (Component_Type (Typ)); 1552 1553 when Record_Kind => 1554 declare 1555 Comp : Entity_Id := First_Component_Or_Discriminant (Typ); 1556 begin 1557 while Present (Comp) loop 1558 if Is_Deep (Etype (Comp)) then 1559 return True; 1560 end if; 1561 Next_Component_Or_Discriminant (Comp); 1562 end loop; 1563 end; 1564 return False; 1565 1566 when Scalar_Kind 1567 | E_String_Literal_Subtype 1568 | Concurrent_Kind 1569 | Incomplete_Kind 1570 | E_Exception_Type 1571 | E_Subprogram_Type 1572 => 1573 return False; 1574 1575 when E_Private_Type 1576 | E_Private_Subtype 1577 | E_Limited_Private_Type 1578 | E_Limited_Private_Subtype 1579 => 1580 -- Conservatively consider that the type might be deep if 1581 -- its completion has not been seen yet. 1582 1583 if No (Underlying_Type (Typ)) then 1584 return True; 1585 1586 -- Do not peek under a private type if its completion has 1587 -- SPARK_Mode Off. In such a case, a deep type is considered 1588 -- by GNATprove to be not deep. 1589 1590 elsif Present (Full_View (Typ)) 1591 and then Present (SPARK_Pragma (Full_View (Typ))) 1592 and then Get_SPARK_Mode_From_Annotation 1593 (SPARK_Pragma (Full_View (Typ))) = Off 1594 then 1595 return False; 1596 1597 -- Otherwise peek under the private type. 1598 1599 else 1600 return Is_Deep (Underlying_Type (Typ)); 1601 end if; 1602 end case; 1603 end Is_Deep; 1604 1605 -- Local variables 1606 1607 Subp_Id : constant Entity_Id := Ultimate_Alias (Id); 1608 Formal : Entity_Id; 1609 Formal_Typ : Entity_Id; 1610 1611 -- Start of processing for Has_Formal_Or_Result_Of_Deep_Type 1612 1613 begin 1614 -- Inspect all parameters of the subprogram looking for a formal 1615 -- of a deep type. 1616 1617 Formal := First_Formal (Subp_Id); 1618 while Present (Formal) loop 1619 Formal_Typ := Etype (Formal); 1620 1621 if Is_Deep (Formal_Typ) then 1622 return True; 1623 end if; 1624 1625 Next_Formal (Formal); 1626 end loop; 1627 1628 -- Check whether this is a function whose return type is deep 1629 1630 if Ekind (Subp_Id) = E_Function 1631 and then Is_Deep (Etype (Subp_Id)) 1632 then 1633 return True; 1634 end if; 1635 1636 return False; 1637 end Has_Formal_Or_Result_Of_Deep_Type; 1638 1639 --------------------------------------------------- 1640 -- Has_Formal_With_Discriminant_Dependent_Fields -- 1641 --------------------------------------------------- 1642 1643 function Has_Formal_With_Discriminant_Dependent_Fields 1644 (Id : Entity_Id) return Boolean 1645 is 1646 function Has_Discriminant_Dependent_Component 1647 (Typ : Entity_Id) return Boolean; 1648 -- Determine whether unconstrained record type Typ has at least one 1649 -- component that depends on a discriminant. 1650 1651 ------------------------------------------ 1652 -- Has_Discriminant_Dependent_Component -- 1653 ------------------------------------------ 1654 1655 function Has_Discriminant_Dependent_Component 1656 (Typ : Entity_Id) return Boolean 1657 is 1658 Comp : Entity_Id; 1659 1660 begin 1661 -- Inspect all components of the record type looking for one that 1662 -- depends on a discriminant. 1663 1664 Comp := First_Component (Typ); 1665 while Present (Comp) loop 1666 if Has_Discriminant_Dependent_Constraint (Comp) then 1667 return True; 1668 end if; 1669 1670 Next_Component (Comp); 1671 end loop; 1672 1673 return False; 1674 end Has_Discriminant_Dependent_Component; 1675 1676 -- Local variables 1677 1678 Subp_Id : constant Entity_Id := Ultimate_Alias (Id); 1679 Formal : Entity_Id; 1680 Formal_Typ : Entity_Id; 1681 1682 -- Start of processing for 1683 -- Has_Formal_With_Discriminant_Dependent_Fields 1684 1685 begin 1686 -- Inspect all parameters of the subprogram looking for a formal 1687 -- of an unconstrained record type with at least one discriminant 1688 -- dependent component. 1689 1690 Formal := First_Formal (Subp_Id); 1691 while Present (Formal) loop 1692 Formal_Typ := Etype (Formal); 1693 1694 if Is_Record_Type (Formal_Typ) 1695 and then not Is_Constrained (Formal_Typ) 1696 and then Has_Discriminant_Dependent_Component (Formal_Typ) 1697 then 1698 return True; 1699 end if; 1700 1701 Next_Formal (Formal); 1702 end loop; 1703 1704 return False; 1705 end Has_Formal_With_Discriminant_Dependent_Fields; 1706 1707 ----------------------- 1708 -- Has_Some_Contract -- 1709 ----------------------- 1710 1711 function Has_Some_Contract (Id : Entity_Id) return Boolean is 1712 Items : Node_Id; 1713 1714 begin 1715 -- A call to an expression function may precede the actual body which 1716 -- is inserted at the end of the enclosing declarations. Ensure that 1717 -- the related entity is decorated before inspecting the contract. 1718 1719 if Is_Subprogram_Or_Generic_Subprogram (Id) then 1720 Items := Contract (Id); 1721 1722 -- Note that Classifications is not Empty when Extensions_Visible 1723 -- or Volatile_Function is present, which causes such subprograms 1724 -- to be considered to have a contract here. This is fine as we 1725 -- want to avoid inlining these too. 1726 1727 return Present (Items) 1728 and then (Present (Pre_Post_Conditions (Items)) or else 1729 Present (Contract_Test_Cases (Items)) or else 1730 Present (Classifications (Items))); 1731 end if; 1732 1733 return False; 1734 end Has_Some_Contract; 1735 1736 --------------------- 1737 -- In_Package_Spec -- 1738 --------------------- 1739 1740 function In_Package_Spec (Id : Entity_Id) return Boolean is 1741 P : constant Node_Id := Parent (Subprogram_Spec (Id)); 1742 -- Parent of the subprogram's declaration 1743 1744 begin 1745 return Nkind (Enclosing_Declaration (P)) = N_Package_Declaration; 1746 end In_Package_Spec; 1747 1748 ------------------------ 1749 -- Is_Unit_Subprogram -- 1750 ------------------------ 1751 1752 function Is_Unit_Subprogram (Id : Entity_Id) return Boolean is 1753 Decl : Node_Id := Parent (Parent (Id)); 1754 begin 1755 if Nkind (Parent (Id)) = N_Defining_Program_Unit_Name then 1756 Decl := Parent (Decl); 1757 end if; 1758 1759 return Nkind (Parent (Decl)) = N_Compilation_Unit; 1760 end Is_Unit_Subprogram; 1761 1762 ------------------------------ 1763 -- Maybe_Traversal_Function -- 1764 ------------------------------ 1765 1766 function Maybe_Traversal_Function (Id : Entity_Id) return Boolean is 1767 begin 1768 return Ekind (Id) = E_Function 1769 1770 -- Only traversal functions return an anonymous access-to-object 1771 -- type in SPARK. 1772 1773 and then Is_Anonymous_Access_Type (Etype (Id)); 1774 end Maybe_Traversal_Function; 1775 1776 -- Local declarations 1777 1778 Id : Entity_Id; 1779 -- Procedure or function entity for the subprogram 1780 1781 -- Start of processing for Can_Be_Inlined_In_GNATprove_Mode 1782 1783 begin 1784 pragma Assert (Present (Spec_Id) or else Present (Body_Id)); 1785 1786 if Present (Spec_Id) then 1787 Id := Spec_Id; 1788 else 1789 Id := Body_Id; 1790 end if; 1791 1792 -- Only local subprograms without contracts are inlined in GNATprove 1793 -- mode, as these are the subprograms which a user is not interested in 1794 -- analyzing in isolation, but rather in the context of their call. This 1795 -- is a convenient convention, that could be changed for an explicit 1796 -- pragma/aspect one day. 1797 1798 -- In a number of special cases, inlining is not desirable or not 1799 -- possible, see below. 1800 1801 -- Do not inline unit-level subprograms 1802 1803 if Is_Unit_Subprogram (Id) then 1804 return False; 1805 1806 -- Do not inline subprograms declared in package specs, because they are 1807 -- not local, i.e. can be called either from anywhere (if declared in 1808 -- visible part) or from the child units (if declared in private part). 1809 1810 elsif In_Package_Spec (Id) then 1811 return False; 1812 1813 -- Do not inline subprograms declared in other units. This is important 1814 -- in particular for subprograms defined in the private part of a 1815 -- package spec, when analyzing one of its child packages, as otherwise 1816 -- we issue spurious messages about the impossibility to inline such 1817 -- calls. 1818 1819 elsif not In_Extended_Main_Code_Unit (Id) then 1820 return False; 1821 1822 -- Do not inline dispatching operations, as only their static calls 1823 -- can be analyzed in context, and not their dispatching calls. 1824 1825 elsif Is_Dispatching_Operation (Id) then 1826 return False; 1827 1828 -- Do not inline subprograms marked No_Return, possibly used for 1829 -- signaling errors, which GNATprove handles specially. 1830 1831 elsif No_Return (Id) then 1832 return False; 1833 1834 -- Do not inline subprograms that have a contract on the spec or the 1835 -- body. Use the contract(s) instead in GNATprove. This also prevents 1836 -- inlining of subprograms with Extensions_Visible or Volatile_Function. 1837 1838 elsif (Present (Spec_Id) and then Has_Some_Contract (Spec_Id)) 1839 or else 1840 (Present (Body_Id) and then Has_Some_Contract (Body_Id)) 1841 then 1842 return False; 1843 1844 -- Do not inline expression functions, which are directly inlined at the 1845 -- prover level. 1846 1847 elsif (Present (Spec_Id) and then Is_Expression_Function (Spec_Id)) 1848 or else 1849 (Present (Body_Id) and then Is_Expression_Function (Body_Id)) 1850 then 1851 return False; 1852 1853 -- Do not inline generic subprogram instances. The visibility rules of 1854 -- generic instances plays badly with inlining. 1855 1856 elsif Is_Generic_Instance (Spec_Id) then 1857 return False; 1858 1859 -- Only inline subprograms whose spec is marked SPARK_Mode On. For 1860 -- the subprogram body, a similar check is performed after the body 1861 -- is analyzed, as this is where a pragma SPARK_Mode might be inserted. 1862 1863 elsif Present (Spec_Id) 1864 and then 1865 (No (SPARK_Pragma (Spec_Id)) 1866 or else 1867 Get_SPARK_Mode_From_Annotation (SPARK_Pragma (Spec_Id)) /= On) 1868 then 1869 return False; 1870 1871 -- Subprograms in generic instances are currently not inlined, to avoid 1872 -- problems with inlining of standard library subprograms. 1873 1874 elsif Instantiation_Location (Sloc (Id)) /= No_Location then 1875 return False; 1876 1877 -- Do not inline subprograms and entries defined inside protected types, 1878 -- which typically are not helper subprograms, which also avoids getting 1879 -- spurious messages on calls that cannot be inlined. 1880 1881 elsif Within_Protected_Type (Id) then 1882 return False; 1883 1884 -- Do not inline predicate functions (treated specially by GNATprove) 1885 1886 elsif Is_Predicate_Function (Id) then 1887 return False; 1888 1889 -- Do not inline subprograms with a parameter of an unconstrained 1890 -- record type if it has discrimiant dependent fields. Indeed, with 1891 -- such parameters, the frontend cannot always ensure type compliance 1892 -- in record component accesses (in particular with records containing 1893 -- packed arrays). 1894 1895 elsif Has_Formal_With_Discriminant_Dependent_Fields (Id) then 1896 return False; 1897 1898 -- Do not inline subprograms with a formal parameter or return type of 1899 -- a deep type, as in that case inlining might generate code that 1900 -- violates borrow-checking rules of SPARK 3.10 even if the original 1901 -- code did not. 1902 1903 elsif Has_Formal_Or_Result_Of_Deep_Type (Id) then 1904 return False; 1905 1906 -- Do not inline subprograms which may be traversal functions. Such 1907 -- inlining introduces temporary variables of named access type for 1908 -- which assignments are move instead of borrow/observe, possibly 1909 -- leading to spurious errors when checking SPARK rules related to 1910 -- pointer usage. 1911 1912 elsif Maybe_Traversal_Function (Id) then 1913 return False; 1914 1915 -- Otherwise, this is a subprogram declared inside the private part of a 1916 -- package, or inside a package body, or locally in a subprogram, and it 1917 -- does not have any contract. Inline it. 1918 1919 else 1920 return True; 1921 end if; 1922 end Can_Be_Inlined_In_GNATprove_Mode; 1923 1924 ------------------- 1925 -- Cannot_Inline -- 1926 ------------------- 1927 1928 procedure Cannot_Inline 1929 (Msg : String; 1930 N : Node_Id; 1931 Subp : Entity_Id; 1932 Is_Serious : Boolean := False) 1933 is 1934 begin 1935 -- In GNATprove mode, inlining is the technical means by which the 1936 -- higher-level goal of contextual analysis is reached, so issue 1937 -- messages about failure to apply contextual analysis to a 1938 -- subprogram, rather than failure to inline it. 1939 1940 if GNATprove_Mode 1941 and then Msg (Msg'First .. Msg'First + 12) = "cannot inline" 1942 then 1943 declare 1944 Len1 : constant Positive := 1945 String (String'("cannot inline"))'Length; 1946 Len2 : constant Positive := 1947 String (String'("info: no contextual analysis of"))'Length; 1948 1949 New_Msg : String (1 .. Msg'Length + Len2 - Len1); 1950 1951 begin 1952 New_Msg (1 .. Len2) := "info: no contextual analysis of"; 1953 New_Msg (Len2 + 1 .. Msg'Length + Len2 - Len1) := 1954 Msg (Msg'First + Len1 .. Msg'Last); 1955 Cannot_Inline (New_Msg, N, Subp, Is_Serious); 1956 return; 1957 end; 1958 end if; 1959 1960 pragma Assert (Msg (Msg'Last) = '?'); 1961 1962 -- Legacy front-end inlining model 1963 1964 if not Back_End_Inlining then 1965 1966 -- Do not emit warning if this is a predefined unit which is not 1967 -- the main unit. With validity checks enabled, some predefined 1968 -- subprograms may contain nested subprograms and become ineligible 1969 -- for inlining. 1970 1971 if Is_Predefined_Unit (Get_Source_Unit (Subp)) 1972 and then not In_Extended_Main_Source_Unit (Subp) 1973 then 1974 null; 1975 1976 -- In GNATprove mode, issue a warning when -gnatd_f is set, and 1977 -- indicate that the subprogram is not always inlined by setting 1978 -- flag Is_Inlined_Always to False. 1979 1980 elsif GNATprove_Mode then 1981 Set_Is_Inlined_Always (Subp, False); 1982 1983 if Debug_Flag_Underscore_F then 1984 Error_Msg_NE (Msg, N, Subp); 1985 end if; 1986 1987 elsif Has_Pragma_Inline_Always (Subp) then 1988 1989 -- Remove last character (question mark) to make this into an 1990 -- error, because the Inline_Always pragma cannot be obeyed. 1991 1992 Error_Msg_NE (Msg (Msg'First .. Msg'Last - 1), N, Subp); 1993 1994 elsif Ineffective_Inline_Warnings then 1995 Error_Msg_NE (Msg & "p?", N, Subp); 1996 end if; 1997 1998 -- New semantics relying on back-end inlining 1999 2000 elsif Is_Serious then 2001 2002 -- Remove last character (question mark) to make this into an error. 2003 2004 Error_Msg_NE (Msg (Msg'First .. Msg'Last - 1), N, Subp); 2005 2006 -- In GNATprove mode, issue a warning when -gnatd_f is set, and 2007 -- indicate that the subprogram is not always inlined by setting 2008 -- flag Is_Inlined_Always to False. 2009 2010 elsif GNATprove_Mode then 2011 Set_Is_Inlined_Always (Subp, False); 2012 2013 if Debug_Flag_Underscore_F then 2014 Error_Msg_NE (Msg, N, Subp); 2015 end if; 2016 2017 else 2018 2019 -- Do not emit warning if this is a predefined unit which is not 2020 -- the main unit. This behavior is currently provided for backward 2021 -- compatibility but it will be removed when we enforce the 2022 -- strictness of the new rules. 2023 2024 if Is_Predefined_Unit (Get_Source_Unit (Subp)) 2025 and then not In_Extended_Main_Source_Unit (Subp) 2026 then 2027 null; 2028 2029 elsif Has_Pragma_Inline_Always (Subp) then 2030 2031 -- Emit a warning if this is a call to a runtime subprogram 2032 -- which is located inside a generic. Previously this call 2033 -- was silently skipped. 2034 2035 if Is_Generic_Instance (Subp) then 2036 declare 2037 Gen_P : constant Entity_Id := Generic_Parent (Parent (Subp)); 2038 begin 2039 if Is_Predefined_Unit (Get_Source_Unit (Gen_P)) then 2040 Set_Is_Inlined (Subp, False); 2041 Error_Msg_NE (Msg & "p?", N, Subp); 2042 return; 2043 end if; 2044 end; 2045 end if; 2046 2047 -- Remove last character (question mark) to make this into an 2048 -- error, because the Inline_Always pragma cannot be obeyed. 2049 2050 Error_Msg_NE (Msg (Msg'First .. Msg'Last - 1), N, Subp); 2051 2052 else 2053 Set_Is_Inlined (Subp, False); 2054 2055 if Ineffective_Inline_Warnings then 2056 Error_Msg_NE (Msg & "p?", N, Subp); 2057 end if; 2058 end if; 2059 end if; 2060 end Cannot_Inline; 2061 2062 -------------------------------------------- 2063 -- Check_And_Split_Unconstrained_Function -- 2064 -------------------------------------------- 2065 2066 procedure Check_And_Split_Unconstrained_Function 2067 (N : Node_Id; 2068 Spec_Id : Entity_Id; 2069 Body_Id : Entity_Id) 2070 is 2071 procedure Build_Body_To_Inline (N : Node_Id; Spec_Id : Entity_Id); 2072 -- Use generic machinery to build an unexpanded body for the subprogram. 2073 -- This body is subsequently used for inline expansions at call sites. 2074 2075 procedure Build_Return_Object_Formal 2076 (Loc : Source_Ptr; 2077 Obj_Decl : Node_Id; 2078 Formals : List_Id); 2079 -- Create a formal parameter for return object declaration Obj_Decl of 2080 -- an extended return statement and add it to list Formals. 2081 2082 function Can_Split_Unconstrained_Function (N : Node_Id) return Boolean; 2083 -- Return true if we generate code for the function body N, the function 2084 -- body N has no local declarations and its unique statement is a single 2085 -- extended return statement with a handled statements sequence. 2086 2087 procedure Copy_Formals 2088 (Loc : Source_Ptr; 2089 Subp_Id : Entity_Id; 2090 Formals : List_Id); 2091 -- Create new formal parameters from the formal parameters of subprogram 2092 -- Subp_Id and add them to list Formals. 2093 2094 function Copy_Return_Object (Obj_Decl : Node_Id) return Node_Id; 2095 -- Create a copy of return object declaration Obj_Decl of an extended 2096 -- return statement. 2097 2098 procedure Split_Unconstrained_Function 2099 (N : Node_Id; 2100 Spec_Id : Entity_Id); 2101 -- N is an inlined function body that returns an unconstrained type and 2102 -- has a single extended return statement. Split N in two subprograms: 2103 -- a procedure P' and a function F'. The formals of P' duplicate the 2104 -- formals of N plus an extra formal which is used to return a value; 2105 -- its body is composed by the declarations and list of statements 2106 -- of the extended return statement of N. 2107 2108 -------------------------- 2109 -- Build_Body_To_Inline -- 2110 -------------------------- 2111 2112 procedure Build_Body_To_Inline (N : Node_Id; Spec_Id : Entity_Id) is 2113 procedure Generate_Subprogram_Body 2114 (N : Node_Id; 2115 Body_To_Inline : out Node_Id); 2116 -- Generate a parameterless duplicate of subprogram body N. Note that 2117 -- occurrences of pragmas referencing the formals are removed since 2118 -- they have no meaning when the body is inlined and the formals are 2119 -- rewritten (the analysis of the non-inlined body will handle these 2120 -- pragmas). A new internal name is associated with Body_To_Inline. 2121 2122 ------------------------------ 2123 -- Generate_Subprogram_Body -- 2124 ------------------------------ 2125 2126 procedure Generate_Subprogram_Body 2127 (N : Node_Id; 2128 Body_To_Inline : out Node_Id) 2129 is 2130 begin 2131 -- Within an instance, the body to inline must be treated as a 2132 -- nested generic so that proper global references are preserved. 2133 2134 -- Note that we do not do this at the library level, because it 2135 -- is not needed, and furthermore this causes trouble if front 2136 -- end inlining is activated (-gnatN). 2137 2138 if In_Instance 2139 and then Scope (Current_Scope) /= Standard_Standard 2140 then 2141 Body_To_Inline := 2142 Copy_Generic_Node (N, Empty, Instantiating => True); 2143 else 2144 -- ??? Shouldn't this use New_Copy_Tree? What about global 2145 -- references captured in the body to inline? 2146 2147 Body_To_Inline := Copy_Separate_Tree (N); 2148 end if; 2149 2150 -- Remove aspects/pragmas that have no meaning in an inlined body 2151 2152 Remove_Aspects_And_Pragmas (Body_To_Inline); 2153 2154 -- We need to capture references to the formals in order 2155 -- to substitute the actuals at the point of inlining, i.e. 2156 -- instantiation. To treat the formals as globals to the body to 2157 -- inline, we nest it within a dummy parameterless subprogram, 2158 -- declared within the real one. 2159 2160 Set_Parameter_Specifications 2161 (Specification (Body_To_Inline), No_List); 2162 2163 -- A new internal name is associated with Body_To_Inline to avoid 2164 -- conflicts when the non-inlined body N is analyzed. 2165 2166 Set_Defining_Unit_Name (Specification (Body_To_Inline), 2167 Make_Defining_Identifier (Sloc (N), New_Internal_Name ('P'))); 2168 Set_Corresponding_Spec (Body_To_Inline, Empty); 2169 end Generate_Subprogram_Body; 2170 2171 -- Local variables 2172 2173 Decl : constant Node_Id := Unit_Declaration_Node (Spec_Id); 2174 Original_Body : Node_Id; 2175 Body_To_Analyze : Node_Id; 2176 2177 -- Start of processing for Build_Body_To_Inline 2178 2179 begin 2180 pragma Assert (Current_Scope = Spec_Id); 2181 2182 -- Within an instance, the body to inline must be treated as a nested 2183 -- generic, so that the proper global references are preserved. We 2184 -- do not do this at the library level, because it is not needed, and 2185 -- furthermore this causes trouble if front-end inlining is activated 2186 -- (-gnatN). 2187 2188 if In_Instance 2189 and then Scope (Current_Scope) /= Standard_Standard 2190 then 2191 Save_Env (Scope (Current_Scope), Scope (Current_Scope)); 2192 end if; 2193 2194 -- Capture references to formals in order to substitute the actuals 2195 -- at the point of inlining or instantiation. To treat the formals 2196 -- as globals to the body to inline, nest the body within a dummy 2197 -- parameterless subprogram, declared within the real one. 2198 2199 Generate_Subprogram_Body (N, Original_Body); 2200 Body_To_Analyze := 2201 Copy_Generic_Node (Original_Body, Empty, Instantiating => False); 2202 2203 -- Set return type of function, which is also global and does not 2204 -- need to be resolved. 2205 2206 if Ekind (Spec_Id) = E_Function then 2207 Set_Result_Definition (Specification (Body_To_Analyze), 2208 New_Occurrence_Of (Etype (Spec_Id), Sloc (N))); 2209 end if; 2210 2211 if No (Declarations (N)) then 2212 Set_Declarations (N, New_List (Body_To_Analyze)); 2213 else 2214 Append_To (Declarations (N), Body_To_Analyze); 2215 end if; 2216 2217 Preanalyze (Body_To_Analyze); 2218 2219 Push_Scope (Defining_Entity (Body_To_Analyze)); 2220 Save_Global_References (Original_Body); 2221 End_Scope; 2222 Remove (Body_To_Analyze); 2223 2224 -- Restore environment if previously saved 2225 2226 if In_Instance 2227 and then Scope (Current_Scope) /= Standard_Standard 2228 then 2229 Restore_Env; 2230 end if; 2231 2232 pragma Assert (No (Body_To_Inline (Decl))); 2233 Set_Body_To_Inline (Decl, Original_Body); 2234 Set_Ekind (Defining_Entity (Original_Body), Ekind (Spec_Id)); 2235 end Build_Body_To_Inline; 2236 2237 -------------------------------- 2238 -- Build_Return_Object_Formal -- 2239 -------------------------------- 2240 2241 procedure Build_Return_Object_Formal 2242 (Loc : Source_Ptr; 2243 Obj_Decl : Node_Id; 2244 Formals : List_Id) 2245 is 2246 Obj_Def : constant Node_Id := Object_Definition (Obj_Decl); 2247 Obj_Id : constant Entity_Id := Defining_Entity (Obj_Decl); 2248 Typ_Def : Node_Id; 2249 2250 begin 2251 -- Build the type definition of the formal parameter. The use of 2252 -- New_Copy_Tree ensures that global references preserved in the 2253 -- case of generics. 2254 2255 if Is_Entity_Name (Obj_Def) then 2256 Typ_Def := New_Copy_Tree (Obj_Def); 2257 else 2258 Typ_Def := New_Copy_Tree (Subtype_Mark (Obj_Def)); 2259 end if; 2260 2261 -- Generate: 2262 -- 2263 -- Obj_Id : [out] Typ_Def 2264 2265 -- Mode OUT should not be used when the return object is declared as 2266 -- a constant. Check the definition of the object declaration because 2267 -- the object has not been analyzed yet. 2268 2269 Append_To (Formals, 2270 Make_Parameter_Specification (Loc, 2271 Defining_Identifier => 2272 Make_Defining_Identifier (Loc, Chars (Obj_Id)), 2273 In_Present => False, 2274 Out_Present => not Constant_Present (Obj_Decl), 2275 Null_Exclusion_Present => False, 2276 Parameter_Type => Typ_Def)); 2277 end Build_Return_Object_Formal; 2278 2279 -------------------------------------- 2280 -- Can_Split_Unconstrained_Function -- 2281 -------------------------------------- 2282 2283 function Can_Split_Unconstrained_Function (N : Node_Id) return Boolean is 2284 Stmt : constant Node_Id := 2285 First (Statements (Handled_Statement_Sequence (N))); 2286 Decl : Node_Id; 2287 2288 begin 2289 -- No user defined declarations allowed in the function except inside 2290 -- the unique return statement; implicit labels are the only allowed 2291 -- declarations. 2292 2293 Decl := First (Declarations (N)); 2294 while Present (Decl) loop 2295 if Nkind (Decl) /= N_Implicit_Label_Declaration then 2296 return False; 2297 end if; 2298 2299 Next (Decl); 2300 end loop; 2301 2302 -- We only split the inlined function when we are generating the code 2303 -- of its body; otherwise we leave duplicated split subprograms in 2304 -- the tree which (if referenced) generate wrong references at link 2305 -- time. 2306 2307 return In_Extended_Main_Code_Unit (N) 2308 and then Present (Stmt) 2309 and then Nkind (Stmt) = N_Extended_Return_Statement 2310 and then No (Next (Stmt)) 2311 and then Present (Handled_Statement_Sequence (Stmt)); 2312 end Can_Split_Unconstrained_Function; 2313 2314 ------------------ 2315 -- Copy_Formals -- 2316 ------------------ 2317 2318 procedure Copy_Formals 2319 (Loc : Source_Ptr; 2320 Subp_Id : Entity_Id; 2321 Formals : List_Id) 2322 is 2323 Formal : Entity_Id; 2324 Spec : Node_Id; 2325 2326 begin 2327 Formal := First_Formal (Subp_Id); 2328 while Present (Formal) loop 2329 Spec := Parent (Formal); 2330 2331 -- Create an exact copy of the formal parameter. The use of 2332 -- New_Copy_Tree ensures that global references are preserved 2333 -- in case of generics. 2334 2335 Append_To (Formals, 2336 Make_Parameter_Specification (Loc, 2337 Defining_Identifier => 2338 Make_Defining_Identifier (Sloc (Formal), Chars (Formal)), 2339 In_Present => In_Present (Spec), 2340 Out_Present => Out_Present (Spec), 2341 Null_Exclusion_Present => Null_Exclusion_Present (Spec), 2342 Parameter_Type => 2343 New_Copy_Tree (Parameter_Type (Spec)), 2344 Expression => New_Copy_Tree (Expression (Spec)))); 2345 2346 Next_Formal (Formal); 2347 end loop; 2348 end Copy_Formals; 2349 2350 ------------------------ 2351 -- Copy_Return_Object -- 2352 ------------------------ 2353 2354 function Copy_Return_Object (Obj_Decl : Node_Id) return Node_Id is 2355 Obj_Id : constant Entity_Id := Defining_Entity (Obj_Decl); 2356 2357 begin 2358 -- The use of New_Copy_Tree ensures that global references are 2359 -- preserved in case of generics. 2360 2361 return 2362 Make_Object_Declaration (Sloc (Obj_Decl), 2363 Defining_Identifier => 2364 Make_Defining_Identifier (Sloc (Obj_Id), Chars (Obj_Id)), 2365 Aliased_Present => Aliased_Present (Obj_Decl), 2366 Constant_Present => Constant_Present (Obj_Decl), 2367 Null_Exclusion_Present => Null_Exclusion_Present (Obj_Decl), 2368 Object_Definition => 2369 New_Copy_Tree (Object_Definition (Obj_Decl)), 2370 Expression => New_Copy_Tree (Expression (Obj_Decl))); 2371 end Copy_Return_Object; 2372 2373 ---------------------------------- 2374 -- Split_Unconstrained_Function -- 2375 ---------------------------------- 2376 2377 procedure Split_Unconstrained_Function 2378 (N : Node_Id; 2379 Spec_Id : Entity_Id) 2380 is 2381 Loc : constant Source_Ptr := Sloc (N); 2382 Ret_Stmt : constant Node_Id := 2383 First (Statements (Handled_Statement_Sequence (N))); 2384 Ret_Obj : constant Node_Id := 2385 First (Return_Object_Declarations (Ret_Stmt)); 2386 2387 procedure Build_Procedure 2388 (Proc_Id : out Entity_Id; 2389 Decl_List : out List_Id); 2390 -- Build a procedure containing the statements found in the extended 2391 -- return statement of the unconstrained function body N. 2392 2393 --------------------- 2394 -- Build_Procedure -- 2395 --------------------- 2396 2397 procedure Build_Procedure 2398 (Proc_Id : out Entity_Id; 2399 Decl_List : out List_Id) 2400 is 2401 Formals : constant List_Id := New_List; 2402 Subp_Name : constant Name_Id := New_Internal_Name ('F'); 2403 2404 Body_Decls : List_Id := No_List; 2405 Decl : Node_Id; 2406 Proc_Body : Node_Id; 2407 Proc_Spec : Node_Id; 2408 2409 begin 2410 -- Create formal parameters for the return object and all formals 2411 -- of the unconstrained function in order to pass their values to 2412 -- the procedure. 2413 2414 Build_Return_Object_Formal 2415 (Loc => Loc, 2416 Obj_Decl => Ret_Obj, 2417 Formals => Formals); 2418 2419 Copy_Formals 2420 (Loc => Loc, 2421 Subp_Id => Spec_Id, 2422 Formals => Formals); 2423 2424 Proc_Id := Make_Defining_Identifier (Loc, Chars => Subp_Name); 2425 2426 Proc_Spec := 2427 Make_Procedure_Specification (Loc, 2428 Defining_Unit_Name => Proc_Id, 2429 Parameter_Specifications => Formals); 2430 2431 Decl_List := New_List; 2432 2433 Append_To (Decl_List, 2434 Make_Subprogram_Declaration (Loc, Proc_Spec)); 2435 2436 -- Can_Convert_Unconstrained_Function checked that the function 2437 -- has no local declarations except implicit label declarations. 2438 -- Copy these declarations to the built procedure. 2439 2440 if Present (Declarations (N)) then 2441 Body_Decls := New_List; 2442 2443 Decl := First (Declarations (N)); 2444 while Present (Decl) loop 2445 pragma Assert (Nkind (Decl) = N_Implicit_Label_Declaration); 2446 2447 Append_To (Body_Decls, 2448 Make_Implicit_Label_Declaration (Loc, 2449 Make_Defining_Identifier (Loc, 2450 Chars => Chars (Defining_Identifier (Decl))), 2451 Label_Construct => Empty)); 2452 2453 Next (Decl); 2454 end loop; 2455 end if; 2456 2457 pragma Assert (Present (Handled_Statement_Sequence (Ret_Stmt))); 2458 2459 Proc_Body := 2460 Make_Subprogram_Body (Loc, 2461 Specification => Copy_Subprogram_Spec (Proc_Spec), 2462 Declarations => Body_Decls, 2463 Handled_Statement_Sequence => 2464 New_Copy_Tree (Handled_Statement_Sequence (Ret_Stmt))); 2465 2466 Set_Defining_Unit_Name (Specification (Proc_Body), 2467 Make_Defining_Identifier (Loc, Subp_Name)); 2468 2469 Append_To (Decl_List, Proc_Body); 2470 end Build_Procedure; 2471 2472 -- Local variables 2473 2474 New_Obj : constant Node_Id := Copy_Return_Object (Ret_Obj); 2475 Blk_Stmt : Node_Id; 2476 Proc_Call : Node_Id; 2477 Proc_Id : Entity_Id; 2478 2479 -- Start of processing for Split_Unconstrained_Function 2480 2481 begin 2482 -- Build the associated procedure, analyze it and insert it before 2483 -- the function body N. 2484 2485 declare 2486 Scope : constant Entity_Id := Current_Scope; 2487 Decl_List : List_Id; 2488 begin 2489 Pop_Scope; 2490 Build_Procedure (Proc_Id, Decl_List); 2491 Insert_Actions (N, Decl_List); 2492 Set_Is_Inlined (Proc_Id); 2493 Push_Scope (Scope); 2494 end; 2495 2496 -- Build the call to the generated procedure 2497 2498 declare 2499 Actual_List : constant List_Id := New_List; 2500 Formal : Entity_Id; 2501 2502 begin 2503 Append_To (Actual_List, 2504 New_Occurrence_Of (Defining_Identifier (New_Obj), Loc)); 2505 2506 Formal := First_Formal (Spec_Id); 2507 while Present (Formal) loop 2508 Append_To (Actual_List, New_Occurrence_Of (Formal, Loc)); 2509 2510 -- Avoid spurious warning on unreferenced formals 2511 2512 Set_Referenced (Formal); 2513 Next_Formal (Formal); 2514 end loop; 2515 2516 Proc_Call := 2517 Make_Procedure_Call_Statement (Loc, 2518 Name => New_Occurrence_Of (Proc_Id, Loc), 2519 Parameter_Associations => Actual_List); 2520 end; 2521 2522 -- Generate: 2523 2524 -- declare 2525 -- New_Obj : ... 2526 -- begin 2527 -- Proc (New_Obj, ...); 2528 -- return New_Obj; 2529 -- end; 2530 2531 Blk_Stmt := 2532 Make_Block_Statement (Loc, 2533 Declarations => New_List (New_Obj), 2534 Handled_Statement_Sequence => 2535 Make_Handled_Sequence_Of_Statements (Loc, 2536 Statements => New_List ( 2537 2538 Proc_Call, 2539 2540 Make_Simple_Return_Statement (Loc, 2541 Expression => 2542 New_Occurrence_Of 2543 (Defining_Identifier (New_Obj), Loc))))); 2544 2545 Rewrite (Ret_Stmt, Blk_Stmt); 2546 end Split_Unconstrained_Function; 2547 2548 -- Local variables 2549 2550 Decl : constant Node_Id := Unit_Declaration_Node (Spec_Id); 2551 2552 -- Start of processing for Check_And_Split_Unconstrained_Function 2553 2554 begin 2555 pragma Assert (Back_End_Inlining 2556 and then Ekind (Spec_Id) = E_Function 2557 and then Returns_Unconstrained_Type (Spec_Id) 2558 and then Comes_From_Source (Body_Id) 2559 and then (Has_Pragma_Inline_Always (Spec_Id) 2560 or else Optimization_Level > 0)); 2561 2562 -- This routine must not be used in GNATprove mode since GNATprove 2563 -- relies on frontend inlining 2564 2565 pragma Assert (not GNATprove_Mode); 2566 2567 -- No need to split the function if we cannot generate the code 2568 2569 if Serious_Errors_Detected /= 0 then 2570 return; 2571 end if; 2572 2573 -- No action needed in stubs since the attribute Body_To_Inline 2574 -- is not available 2575 2576 if Nkind (Decl) = N_Subprogram_Body_Stub then 2577 return; 2578 2579 -- Cannot build the body to inline if the attribute is already set. 2580 -- This attribute may have been set if this is a subprogram renaming 2581 -- declarations (see Freeze.Build_Renamed_Body). 2582 2583 elsif Present (Body_To_Inline (Decl)) then 2584 return; 2585 2586 -- Do not generate a body to inline for protected functions, because the 2587 -- transformation generates a call to a protected procedure, causing 2588 -- spurious errors. We don't inline protected operations anyway, so 2589 -- this is no loss. We might as well ignore intrinsics and foreign 2590 -- conventions as well -- just allow Ada conventions. 2591 2592 elsif not (Convention (Spec_Id) = Convention_Ada 2593 or else Convention (Spec_Id) = Convention_Ada_Pass_By_Copy 2594 or else Convention (Spec_Id) = Convention_Ada_Pass_By_Reference) 2595 then 2596 return; 2597 2598 -- Check excluded declarations 2599 2600 elsif Present (Declarations (N)) 2601 and then Has_Excluded_Declaration (Spec_Id, Declarations (N)) 2602 then 2603 return; 2604 2605 -- Check excluded statements. There is no need to protect us against 2606 -- exception handlers since they are supported by the GCC backend. 2607 2608 elsif Present (Handled_Statement_Sequence (N)) 2609 and then Has_Excluded_Statement 2610 (Spec_Id, Statements (Handled_Statement_Sequence (N))) 2611 then 2612 return; 2613 end if; 2614 2615 -- Build the body to inline only if really needed 2616 2617 if Can_Split_Unconstrained_Function (N) then 2618 Split_Unconstrained_Function (N, Spec_Id); 2619 Build_Body_To_Inline (N, Spec_Id); 2620 Set_Is_Inlined (Spec_Id); 2621 end if; 2622 end Check_And_Split_Unconstrained_Function; 2623 2624 ------------------------------------- 2625 -- Check_Package_Body_For_Inlining -- 2626 ------------------------------------- 2627 2628 procedure Check_Package_Body_For_Inlining (N : Node_Id; P : Entity_Id) is 2629 Bname : Unit_Name_Type; 2630 E : Entity_Id; 2631 OK : Boolean; 2632 2633 begin 2634 -- Legacy implementation (relying on frontend inlining) 2635 2636 if not Back_End_Inlining 2637 and then Is_Compilation_Unit (P) 2638 and then not Is_Generic_Instance (P) 2639 then 2640 Bname := Get_Body_Name (Get_Unit_Name (Unit (N))); 2641 2642 E := First_Entity (P); 2643 while Present (E) loop 2644 if Has_Pragma_Inline_Always (E) 2645 or else (Has_Pragma_Inline (E) and Front_End_Inlining) 2646 then 2647 if not Is_Loaded (Bname) then 2648 Load_Needed_Body (N, OK); 2649 2650 if OK then 2651 2652 -- Check we are not trying to inline a parent whose body 2653 -- depends on a child, when we are compiling the body of 2654 -- the child. Otherwise we have a potential elaboration 2655 -- circularity with inlined subprograms and with 2656 -- Taft-Amendment types. 2657 2658 declare 2659 Comp : Node_Id; -- Body just compiled 2660 Child_Spec : Entity_Id; -- Spec of main unit 2661 Ent : Entity_Id; -- For iteration 2662 With_Clause : Node_Id; -- Context of body. 2663 2664 begin 2665 if Nkind (Unit (Cunit (Main_Unit))) = N_Package_Body 2666 and then Present (Body_Entity (P)) 2667 then 2668 Child_Spec := 2669 Defining_Entity 2670 ((Unit (Library_Unit (Cunit (Main_Unit))))); 2671 2672 Comp := 2673 Parent (Unit_Declaration_Node (Body_Entity (P))); 2674 2675 -- Check whether the context of the body just 2676 -- compiled includes a child of itself, and that 2677 -- child is the spec of the main compilation. 2678 2679 With_Clause := First (Context_Items (Comp)); 2680 while Present (With_Clause) loop 2681 if Nkind (With_Clause) = N_With_Clause 2682 and then 2683 Scope (Entity (Name (With_Clause))) = P 2684 and then 2685 Entity (Name (With_Clause)) = Child_Spec 2686 then 2687 Error_Msg_Node_2 := Child_Spec; 2688 Error_Msg_NE 2689 ("body of & depends on child unit&??", 2690 With_Clause, P); 2691 Error_Msg_N 2692 ("\subprograms in body cannot be inlined??", 2693 With_Clause); 2694 2695 -- Disable further inlining from this unit, 2696 -- and keep Taft-amendment types incomplete. 2697 2698 Ent := First_Entity (P); 2699 while Present (Ent) loop 2700 if Is_Type (Ent) 2701 and then Has_Completion_In_Body (Ent) 2702 then 2703 Set_Full_View (Ent, Empty); 2704 2705 elsif Is_Subprogram (Ent) then 2706 Set_Is_Inlined (Ent, False); 2707 end if; 2708 2709 Next_Entity (Ent); 2710 end loop; 2711 2712 return; 2713 end if; 2714 2715 Next (With_Clause); 2716 end loop; 2717 end if; 2718 end; 2719 2720 elsif Ineffective_Inline_Warnings then 2721 Error_Msg_Unit_1 := Bname; 2722 Error_Msg_N 2723 ("unable to inline subprograms defined in $??", P); 2724 Error_Msg_N ("\body not found??", P); 2725 return; 2726 end if; 2727 end if; 2728 2729 return; 2730 end if; 2731 2732 Next_Entity (E); 2733 end loop; 2734 end if; 2735 end Check_Package_Body_For_Inlining; 2736 2737 -------------------- 2738 -- Cleanup_Scopes -- 2739 -------------------- 2740 2741 procedure Cleanup_Scopes is 2742 Elmt : Elmt_Id; 2743 Decl : Node_Id; 2744 Scop : Entity_Id; 2745 2746 begin 2747 Elmt := First_Elmt (To_Clean); 2748 while Present (Elmt) loop 2749 Scop := Node (Elmt); 2750 2751 if Ekind (Scop) = E_Entry then 2752 Scop := Protected_Body_Subprogram (Scop); 2753 2754 elsif Is_Subprogram (Scop) 2755 and then Is_Protected_Type (Scope (Scop)) 2756 and then Present (Protected_Body_Subprogram (Scop)) 2757 then 2758 -- If a protected operation contains an instance, its cleanup 2759 -- operations have been delayed, and the subprogram has been 2760 -- rewritten in the expansion of the enclosing protected body. It 2761 -- is the corresponding subprogram that may require the cleanup 2762 -- operations, so propagate the information that triggers cleanup 2763 -- activity. 2764 2765 Set_Uses_Sec_Stack 2766 (Protected_Body_Subprogram (Scop), 2767 Uses_Sec_Stack (Scop)); 2768 2769 Scop := Protected_Body_Subprogram (Scop); 2770 end if; 2771 2772 if Ekind (Scop) = E_Block then 2773 Decl := Parent (Block_Node (Scop)); 2774 2775 else 2776 Decl := Unit_Declaration_Node (Scop); 2777 2778 if Nkind_In (Decl, N_Subprogram_Declaration, 2779 N_Task_Type_Declaration, 2780 N_Subprogram_Body_Stub) 2781 then 2782 Decl := Unit_Declaration_Node (Corresponding_Body (Decl)); 2783 end if; 2784 end if; 2785 2786 Push_Scope (Scop); 2787 Expand_Cleanup_Actions (Decl); 2788 End_Scope; 2789 2790 Elmt := Next_Elmt (Elmt); 2791 end loop; 2792 end Cleanup_Scopes; 2793 2794 ------------------------- 2795 -- Expand_Inlined_Call -- 2796 ------------------------- 2797 2798 procedure Expand_Inlined_Call 2799 (N : Node_Id; 2800 Subp : Entity_Id; 2801 Orig_Subp : Entity_Id) 2802 is 2803 Decls : constant List_Id := New_List; 2804 Is_Predef : constant Boolean := 2805 Is_Predefined_Unit (Get_Source_Unit (Subp)); 2806 Loc : constant Source_Ptr := Sloc (N); 2807 Orig_Bod : constant Node_Id := 2808 Body_To_Inline (Unit_Declaration_Node (Subp)); 2809 2810 Uses_Back_End : constant Boolean := 2811 Back_End_Inlining and then Optimization_Level > 0; 2812 -- The back-end expansion is used if the target supports back-end 2813 -- inlining and some level of optimixation is required; otherwise 2814 -- the inlining takes place fully as a tree expansion. 2815 2816 Blk : Node_Id; 2817 Decl : Node_Id; 2818 Exit_Lab : Entity_Id := Empty; 2819 F : Entity_Id; 2820 A : Node_Id; 2821 Lab_Decl : Node_Id := Empty; 2822 Lab_Id : Node_Id; 2823 New_A : Node_Id; 2824 Num_Ret : Nat := 0; 2825 Ret_Type : Entity_Id; 2826 Temp : Entity_Id; 2827 Temp_Typ : Entity_Id; 2828 2829 Is_Unc : Boolean; 2830 Is_Unc_Decl : Boolean; 2831 -- If the type returned by the function is unconstrained and the call 2832 -- can be inlined, special processing is required. 2833 2834 Return_Object : Entity_Id := Empty; 2835 -- Entity in declaration in an extended_return_statement 2836 2837 Targ : Node_Id := Empty; 2838 -- The target of the call. If context is an assignment statement then 2839 -- this is the left-hand side of the assignment, else it is a temporary 2840 -- to which the return value is assigned prior to rewriting the call. 2841 2842 Targ1 : Node_Id := Empty; 2843 -- A separate target used when the return type is unconstrained 2844 2845 procedure Declare_Postconditions_Result; 2846 -- When generating C code, declare _Result, which may be used in the 2847 -- inlined _Postconditions procedure to verify the return value. 2848 2849 procedure Make_Exit_Label; 2850 -- Build declaration for exit label to be used in Return statements, 2851 -- sets Exit_Lab (the label node) and Lab_Decl (corresponding implicit 2852 -- declaration). Does nothing if Exit_Lab already set. 2853 2854 procedure Make_Loop_Labels_Unique (HSS : Node_Id); 2855 -- When compiling for CCG and performing front-end inlining, replace 2856 -- loop names and references to them so that they do not conflict with 2857 -- homographs in the current subprogram. 2858 2859 function Process_Formals (N : Node_Id) return Traverse_Result; 2860 -- Replace occurrence of a formal with the corresponding actual, or the 2861 -- thunk generated for it. Replace a return statement with an assignment 2862 -- to the target of the call, with appropriate conversions if needed. 2863 2864 function Process_Formals_In_Aspects (N : Node_Id) return Traverse_Result; 2865 -- Because aspects are linked indirectly to the rest of the tree, 2866 -- replacement of formals appearing in aspect specifications must 2867 -- be performed in a separate pass, using an instantiation of the 2868 -- previous subprogram over aspect specifications reachable from N. 2869 2870 function Process_Sloc (Nod : Node_Id) return Traverse_Result; 2871 -- If the call being expanded is that of an internal subprogram, set the 2872 -- sloc of the generated block to that of the call itself, so that the 2873 -- expansion is skipped by the "next" command in gdb. Same processing 2874 -- for a subprogram in a predefined file, e.g. Ada.Tags. If 2875 -- Debug_Generated_Code is true, suppress this change to simplify our 2876 -- own development. Same in GNATprove mode, to ensure that warnings and 2877 -- diagnostics point to the proper location. 2878 2879 procedure Reset_Dispatching_Calls (N : Node_Id); 2880 -- In subtree N search for occurrences of dispatching calls that use the 2881 -- Ada 2005 Object.Operation notation and the object is a formal of the 2882 -- inlined subprogram. Reset the entity associated with Operation in all 2883 -- the found occurrences. 2884 2885 procedure Rewrite_Function_Call (N : Node_Id; Blk : Node_Id); 2886 -- If the function body is a single expression, replace call with 2887 -- expression, else insert block appropriately. 2888 2889 procedure Rewrite_Procedure_Call (N : Node_Id; Blk : Node_Id); 2890 -- If procedure body has no local variables, inline body without 2891 -- creating block, otherwise rewrite call with block. 2892 2893 function Formal_Is_Used_Once (Formal : Entity_Id) return Boolean; 2894 -- Determine whether a formal parameter is used only once in Orig_Bod 2895 2896 ----------------------------------- 2897 -- Declare_Postconditions_Result -- 2898 ----------------------------------- 2899 2900 procedure Declare_Postconditions_Result is 2901 Enclosing_Subp : constant Entity_Id := Scope (Subp); 2902 2903 begin 2904 pragma Assert 2905 (Modify_Tree_For_C 2906 and then Is_Subprogram (Enclosing_Subp) 2907 and then Present (Postconditions_Proc (Enclosing_Subp))); 2908 2909 if Ekind (Enclosing_Subp) = E_Function then 2910 if Nkind (First (Parameter_Associations (N))) in 2911 N_Numeric_Or_String_Literal 2912 then 2913 Append_To (Declarations (Blk), 2914 Make_Object_Declaration (Loc, 2915 Defining_Identifier => 2916 Make_Defining_Identifier (Loc, Name_uResult), 2917 Constant_Present => True, 2918 Object_Definition => 2919 New_Occurrence_Of (Etype (Enclosing_Subp), Loc), 2920 Expression => 2921 New_Copy_Tree (First (Parameter_Associations (N))))); 2922 else 2923 Append_To (Declarations (Blk), 2924 Make_Object_Renaming_Declaration (Loc, 2925 Defining_Identifier => 2926 Make_Defining_Identifier (Loc, Name_uResult), 2927 Subtype_Mark => 2928 New_Occurrence_Of (Etype (Enclosing_Subp), Loc), 2929 Name => 2930 New_Copy_Tree (First (Parameter_Associations (N))))); 2931 end if; 2932 end if; 2933 end Declare_Postconditions_Result; 2934 2935 --------------------- 2936 -- Make_Exit_Label -- 2937 --------------------- 2938 2939 procedure Make_Exit_Label is 2940 Lab_Ent : Entity_Id; 2941 begin 2942 if No (Exit_Lab) then 2943 Lab_Ent := Make_Temporary (Loc, 'L'); 2944 Lab_Id := New_Occurrence_Of (Lab_Ent, Loc); 2945 Exit_Lab := Make_Label (Loc, Lab_Id); 2946 Lab_Decl := 2947 Make_Implicit_Label_Declaration (Loc, 2948 Defining_Identifier => Lab_Ent, 2949 Label_Construct => Exit_Lab); 2950 end if; 2951 end Make_Exit_Label; 2952 2953 ----------------------------- 2954 -- Make_Loop_Labels_Unique -- 2955 ----------------------------- 2956 2957 procedure Make_Loop_Labels_Unique (HSS : Node_Id) is 2958 function Process_Loop (N : Node_Id) return Traverse_Result; 2959 2960 ------------------ 2961 -- Process_Loop -- 2962 ------------------ 2963 2964 function Process_Loop (N : Node_Id) return Traverse_Result is 2965 Id : Entity_Id; 2966 2967 begin 2968 if Nkind (N) = N_Loop_Statement 2969 and then Present (Identifier (N)) 2970 then 2971 -- Create new external name for loop and update the 2972 -- corresponding entity. 2973 2974 Id := Entity (Identifier (N)); 2975 Set_Chars (Id, New_External_Name (Chars (Id), 'L', -1)); 2976 Set_Chars (Identifier (N), Chars (Id)); 2977 2978 elsif Nkind (N) = N_Exit_Statement 2979 and then Present (Name (N)) 2980 then 2981 -- The exit statement must name an enclosing loop, whose name 2982 -- has already been updated. 2983 2984 Set_Chars (Name (N), Chars (Entity (Name (N)))); 2985 end if; 2986 2987 return OK; 2988 end Process_Loop; 2989 2990 procedure Update_Loop_Names is new Traverse_Proc (Process_Loop); 2991 2992 -- Local variables 2993 2994 Stmt : Node_Id; 2995 2996 -- Start of processing for Make_Loop_Labels_Unique 2997 2998 begin 2999 if Modify_Tree_For_C then 3000 Stmt := First (Statements (HSS)); 3001 while Present (Stmt) loop 3002 Update_Loop_Names (Stmt); 3003 Next (Stmt); 3004 end loop; 3005 end if; 3006 end Make_Loop_Labels_Unique; 3007 3008 --------------------- 3009 -- Process_Formals -- 3010 --------------------- 3011 3012 function Process_Formals (N : Node_Id) return Traverse_Result is 3013 A : Entity_Id; 3014 E : Entity_Id; 3015 Ret : Node_Id; 3016 3017 begin 3018 if Is_Entity_Name (N) and then Present (Entity (N)) then 3019 E := Entity (N); 3020 3021 if Is_Formal (E) and then Scope (E) = Subp then 3022 A := Renamed_Object (E); 3023 3024 -- Rewrite the occurrence of the formal into an occurrence of 3025 -- the actual. Also establish visibility on the proper view of 3026 -- the actual's subtype for the body's context (if the actual's 3027 -- subtype is private at the call point but its full view is 3028 -- visible to the body, then the inlined tree here must be 3029 -- analyzed with the full view). 3030 3031 if Is_Entity_Name (A) then 3032 Rewrite (N, New_Occurrence_Of (Entity (A), Sloc (N))); 3033 Check_Private_View (N); 3034 3035 elsif Nkind (A) = N_Defining_Identifier then 3036 Rewrite (N, New_Occurrence_Of (A, Sloc (N))); 3037 Check_Private_View (N); 3038 3039 -- Numeric literal 3040 3041 else 3042 Rewrite (N, New_Copy (A)); 3043 end if; 3044 end if; 3045 3046 return Skip; 3047 3048 elsif Is_Entity_Name (N) 3049 and then Present (Return_Object) 3050 and then Chars (N) = Chars (Return_Object) 3051 then 3052 -- Occurrence within an extended return statement. The return 3053 -- object is local to the body been inlined, and thus the generic 3054 -- copy is not analyzed yet, so we match by name, and replace it 3055 -- with target of call. 3056 3057 if Nkind (Targ) = N_Defining_Identifier then 3058 Rewrite (N, New_Occurrence_Of (Targ, Loc)); 3059 else 3060 Rewrite (N, New_Copy_Tree (Targ)); 3061 end if; 3062 3063 return Skip; 3064 3065 elsif Nkind (N) = N_Simple_Return_Statement then 3066 if No (Expression (N)) then 3067 Num_Ret := Num_Ret + 1; 3068 Make_Exit_Label; 3069 Rewrite (N, 3070 Make_Goto_Statement (Loc, Name => New_Copy (Lab_Id))); 3071 3072 else 3073 if Nkind (Parent (N)) = N_Handled_Sequence_Of_Statements 3074 and then Nkind (Parent (Parent (N))) = N_Subprogram_Body 3075 then 3076 -- Function body is a single expression. No need for 3077 -- exit label. 3078 3079 null; 3080 3081 else 3082 Num_Ret := Num_Ret + 1; 3083 Make_Exit_Label; 3084 end if; 3085 3086 -- Because of the presence of private types, the views of the 3087 -- expression and the context may be different, so place 3088 -- a type conversion to the context type to avoid spurious 3089 -- errors, e.g. when the expression is a numeric literal and 3090 -- the context is private. If the expression is an aggregate, 3091 -- use a qualified expression, because an aggregate is not a 3092 -- legal argument of a conversion. Ditto for numeric, character 3093 -- and string literals, and attributes that yield a universal 3094 -- type, because those must be resolved to a specific type. 3095 3096 if Nkind_In (Expression (N), N_Aggregate, 3097 N_Character_Literal, 3098 N_Null, 3099 N_String_Literal) 3100 or else Yields_Universal_Type (Expression (N)) 3101 then 3102 Ret := 3103 Make_Qualified_Expression (Sloc (N), 3104 Subtype_Mark => New_Occurrence_Of (Ret_Type, Sloc (N)), 3105 Expression => Relocate_Node (Expression (N))); 3106 3107 -- Use an unchecked type conversion between access types, for 3108 -- which a type conversion would not always be valid, as no 3109 -- check may result from the conversion. 3110 3111 elsif Is_Access_Type (Ret_Type) then 3112 Ret := 3113 Unchecked_Convert_To 3114 (Ret_Type, Relocate_Node (Expression (N))); 3115 3116 -- Otherwise use a type conversion, which may trigger a check 3117 3118 else 3119 Ret := 3120 Make_Type_Conversion (Sloc (N), 3121 Subtype_Mark => New_Occurrence_Of (Ret_Type, Sloc (N)), 3122 Expression => Relocate_Node (Expression (N))); 3123 end if; 3124 3125 if Nkind (Targ) = N_Defining_Identifier then 3126 Rewrite (N, 3127 Make_Assignment_Statement (Loc, 3128 Name => New_Occurrence_Of (Targ, Loc), 3129 Expression => Ret)); 3130 else 3131 Rewrite (N, 3132 Make_Assignment_Statement (Loc, 3133 Name => New_Copy (Targ), 3134 Expression => Ret)); 3135 end if; 3136 3137 Set_Assignment_OK (Name (N)); 3138 3139 if Present (Exit_Lab) then 3140 Insert_After (N, 3141 Make_Goto_Statement (Loc, Name => New_Copy (Lab_Id))); 3142 end if; 3143 end if; 3144 3145 return OK; 3146 3147 -- An extended return becomes a block whose first statement is the 3148 -- assignment of the initial expression of the return object to the 3149 -- target of the call itself. 3150 3151 elsif Nkind (N) = N_Extended_Return_Statement then 3152 declare 3153 Return_Decl : constant Entity_Id := 3154 First (Return_Object_Declarations (N)); 3155 Assign : Node_Id; 3156 3157 begin 3158 Return_Object := Defining_Identifier (Return_Decl); 3159 3160 if Present (Expression (Return_Decl)) then 3161 if Nkind (Targ) = N_Defining_Identifier then 3162 Assign := 3163 Make_Assignment_Statement (Loc, 3164 Name => New_Occurrence_Of (Targ, Loc), 3165 Expression => Expression (Return_Decl)); 3166 else 3167 Assign := 3168 Make_Assignment_Statement (Loc, 3169 Name => New_Copy (Targ), 3170 Expression => Expression (Return_Decl)); 3171 end if; 3172 3173 Set_Assignment_OK (Name (Assign)); 3174 3175 if No (Handled_Statement_Sequence (N)) then 3176 Set_Handled_Statement_Sequence (N, 3177 Make_Handled_Sequence_Of_Statements (Loc, 3178 Statements => New_List)); 3179 end if; 3180 3181 Prepend (Assign, 3182 Statements (Handled_Statement_Sequence (N))); 3183 end if; 3184 3185 Rewrite (N, 3186 Make_Block_Statement (Loc, 3187 Handled_Statement_Sequence => 3188 Handled_Statement_Sequence (N))); 3189 3190 return OK; 3191 end; 3192 3193 -- Remove pragma Unreferenced since it may refer to formals that 3194 -- are not visible in the inlined body, and in any case we will 3195 -- not be posting warnings on the inlined body so it is unneeded. 3196 3197 elsif Nkind (N) = N_Pragma 3198 and then Pragma_Name (N) = Name_Unreferenced 3199 then 3200 Rewrite (N, Make_Null_Statement (Sloc (N))); 3201 return OK; 3202 3203 else 3204 return OK; 3205 end if; 3206 end Process_Formals; 3207 3208 procedure Replace_Formals is new Traverse_Proc (Process_Formals); 3209 3210 -------------------------------- 3211 -- Process_Formals_In_Aspects -- 3212 -------------------------------- 3213 3214 function Process_Formals_In_Aspects 3215 (N : Node_Id) return Traverse_Result 3216 is 3217 A : Node_Id; 3218 3219 begin 3220 if Has_Aspects (N) then 3221 A := First (Aspect_Specifications (N)); 3222 while Present (A) loop 3223 Replace_Formals (Expression (A)); 3224 3225 Next (A); 3226 end loop; 3227 end if; 3228 return OK; 3229 end Process_Formals_In_Aspects; 3230 3231 procedure Replace_Formals_In_Aspects is 3232 new Traverse_Proc (Process_Formals_In_Aspects); 3233 3234 ------------------ 3235 -- Process_Sloc -- 3236 ------------------ 3237 3238 function Process_Sloc (Nod : Node_Id) return Traverse_Result is 3239 begin 3240 if not Debug_Generated_Code then 3241 Set_Sloc (Nod, Sloc (N)); 3242 Set_Comes_From_Source (Nod, False); 3243 end if; 3244 3245 return OK; 3246 end Process_Sloc; 3247 3248 procedure Reset_Slocs is new Traverse_Proc (Process_Sloc); 3249 3250 ------------------------------ 3251 -- Reset_Dispatching_Calls -- 3252 ------------------------------ 3253 3254 procedure Reset_Dispatching_Calls (N : Node_Id) is 3255 3256 function Do_Reset (N : Node_Id) return Traverse_Result; 3257 -- Comment required ??? 3258 3259 -------------- 3260 -- Do_Reset -- 3261 -------------- 3262 3263 function Do_Reset (N : Node_Id) return Traverse_Result is 3264 begin 3265 if Nkind (N) = N_Procedure_Call_Statement 3266 and then Nkind (Name (N)) = N_Selected_Component 3267 and then Nkind (Prefix (Name (N))) = N_Identifier 3268 and then Is_Formal (Entity (Prefix (Name (N)))) 3269 and then Is_Dispatching_Operation 3270 (Entity (Selector_Name (Name (N)))) 3271 then 3272 Set_Entity (Selector_Name (Name (N)), Empty); 3273 end if; 3274 3275 return OK; 3276 end Do_Reset; 3277 3278 function Do_Reset_Calls is new Traverse_Func (Do_Reset); 3279 3280 -- Local variables 3281 3282 Dummy : constant Traverse_Result := Do_Reset_Calls (N); 3283 pragma Unreferenced (Dummy); 3284 3285 -- Start of processing for Reset_Dispatching_Calls 3286 3287 begin 3288 null; 3289 end Reset_Dispatching_Calls; 3290 3291 --------------------------- 3292 -- Rewrite_Function_Call -- 3293 --------------------------- 3294 3295 procedure Rewrite_Function_Call (N : Node_Id; Blk : Node_Id) is 3296 HSS : constant Node_Id := Handled_Statement_Sequence (Blk); 3297 Fst : constant Node_Id := First (Statements (HSS)); 3298 3299 begin 3300 Make_Loop_Labels_Unique (HSS); 3301 3302 -- Optimize simple case: function body is a single return statement, 3303 -- which has been expanded into an assignment. 3304 3305 if Is_Empty_List (Declarations (Blk)) 3306 and then Nkind (Fst) = N_Assignment_Statement 3307 and then No (Next (Fst)) 3308 then 3309 -- The function call may have been rewritten as the temporary 3310 -- that holds the result of the call, in which case remove the 3311 -- now useless declaration. 3312 3313 if Nkind (N) = N_Identifier 3314 and then Nkind (Parent (Entity (N))) = N_Object_Declaration 3315 then 3316 Rewrite (Parent (Entity (N)), Make_Null_Statement (Loc)); 3317 end if; 3318 3319 Rewrite (N, Expression (Fst)); 3320 3321 elsif Nkind (N) = N_Identifier 3322 and then Nkind (Parent (Entity (N))) = N_Object_Declaration 3323 then 3324 -- The block assigns the result of the call to the temporary 3325 3326 Insert_After (Parent (Entity (N)), Blk); 3327 3328 -- If the context is an assignment, and the left-hand side is free of 3329 -- side-effects, the replacement is also safe. 3330 -- Can this be generalized further??? 3331 3332 elsif Nkind (Parent (N)) = N_Assignment_Statement 3333 and then 3334 (Is_Entity_Name (Name (Parent (N))) 3335 or else 3336 (Nkind (Name (Parent (N))) = N_Explicit_Dereference 3337 and then Is_Entity_Name (Prefix (Name (Parent (N))))) 3338 3339 or else 3340 (Nkind (Name (Parent (N))) = N_Selected_Component 3341 and then Is_Entity_Name (Prefix (Name (Parent (N)))))) 3342 then 3343 -- Replace assignment with the block 3344 3345 declare 3346 Original_Assignment : constant Node_Id := Parent (N); 3347 3348 begin 3349 -- Preserve the original assignment node to keep the complete 3350 -- assignment subtree consistent enough for Analyze_Assignment 3351 -- to proceed (specifically, the original Lhs node must still 3352 -- have an assignment statement as its parent). 3353 3354 -- We cannot rely on Original_Node to go back from the block 3355 -- node to the assignment node, because the assignment might 3356 -- already be a rewrite substitution. 3357 3358 Discard_Node (Relocate_Node (Original_Assignment)); 3359 Rewrite (Original_Assignment, Blk); 3360 end; 3361 3362 elsif Nkind (Parent (N)) = N_Object_Declaration then 3363 3364 -- A call to a function which returns an unconstrained type 3365 -- found in the expression initializing an object-declaration is 3366 -- expanded into a procedure call which must be added after the 3367 -- object declaration. 3368 3369 if Is_Unc_Decl and Back_End_Inlining then 3370 Insert_Action_After (Parent (N), Blk); 3371 else 3372 Set_Expression (Parent (N), Empty); 3373 Insert_After (Parent (N), Blk); 3374 end if; 3375 3376 elsif Is_Unc and then not Back_End_Inlining then 3377 Insert_Before (Parent (N), Blk); 3378 end if; 3379 end Rewrite_Function_Call; 3380 3381 ---------------------------- 3382 -- Rewrite_Procedure_Call -- 3383 ---------------------------- 3384 3385 procedure Rewrite_Procedure_Call (N : Node_Id; Blk : Node_Id) is 3386 HSS : constant Node_Id := Handled_Statement_Sequence (Blk); 3387 3388 begin 3389 Make_Loop_Labels_Unique (HSS); 3390 3391 -- If there is a transient scope for N, this will be the scope of the 3392 -- actions for N, and the statements in Blk need to be within this 3393 -- scope. For example, they need to have visibility on the constant 3394 -- declarations created for the formals. 3395 3396 -- If N needs no transient scope, and if there are no declarations in 3397 -- the inlined body, we can do a little optimization and insert the 3398 -- statements for the body directly after N, and rewrite N to a 3399 -- null statement, instead of rewriting N into a full-blown block 3400 -- statement. 3401 3402 if not Scope_Is_Transient 3403 and then Is_Empty_List (Declarations (Blk)) 3404 then 3405 Insert_List_After (N, Statements (HSS)); 3406 Rewrite (N, Make_Null_Statement (Loc)); 3407 else 3408 Rewrite (N, Blk); 3409 end if; 3410 end Rewrite_Procedure_Call; 3411 3412 ------------------------- 3413 -- Formal_Is_Used_Once -- 3414 ------------------------- 3415 3416 function Formal_Is_Used_Once (Formal : Entity_Id) return Boolean is 3417 Use_Counter : Int := 0; 3418 3419 function Count_Uses (N : Node_Id) return Traverse_Result; 3420 -- Traverse the tree and count the uses of the formal parameter. 3421 -- In this case, for optimization purposes, we do not need to 3422 -- continue the traversal once more than one use is encountered. 3423 3424 ---------------- 3425 -- Count_Uses -- 3426 ---------------- 3427 3428 function Count_Uses (N : Node_Id) return Traverse_Result is 3429 begin 3430 -- The original node is an identifier 3431 3432 if Nkind (N) = N_Identifier 3433 and then Present (Entity (N)) 3434 3435 -- Original node's entity points to the one in the copied body 3436 3437 and then Nkind (Entity (N)) = N_Identifier 3438 and then Present (Entity (Entity (N))) 3439 3440 -- The entity of the copied node is the formal parameter 3441 3442 and then Entity (Entity (N)) = Formal 3443 then 3444 Use_Counter := Use_Counter + 1; 3445 3446 if Use_Counter > 1 then 3447 3448 -- Denote more than one use and abandon the traversal 3449 3450 Use_Counter := 2; 3451 return Abandon; 3452 3453 end if; 3454 end if; 3455 3456 return OK; 3457 end Count_Uses; 3458 3459 procedure Count_Formal_Uses is new Traverse_Proc (Count_Uses); 3460 3461 -- Start of processing for Formal_Is_Used_Once 3462 3463 begin 3464 Count_Formal_Uses (Orig_Bod); 3465 return Use_Counter = 1; 3466 end Formal_Is_Used_Once; 3467 3468 -- Start of processing for Expand_Inlined_Call 3469 3470 begin 3471 -- Initializations for old/new semantics 3472 3473 if not Uses_Back_End then 3474 Is_Unc := Is_Array_Type (Etype (Subp)) 3475 and then not Is_Constrained (Etype (Subp)); 3476 Is_Unc_Decl := False; 3477 else 3478 Is_Unc := Returns_Unconstrained_Type (Subp) 3479 and then Optimization_Level > 0; 3480 Is_Unc_Decl := Nkind (Parent (N)) = N_Object_Declaration 3481 and then Is_Unc; 3482 end if; 3483 3484 -- Check for an illegal attempt to inline a recursive procedure. If the 3485 -- subprogram has parameters this is detected when trying to supply a 3486 -- binding for parameters that already have one. For parameterless 3487 -- subprograms this must be done explicitly. 3488 3489 if In_Open_Scopes (Subp) then 3490 Cannot_Inline 3491 ("cannot inline call to recursive subprogram?", N, Subp); 3492 Set_Is_Inlined (Subp, False); 3493 return; 3494 3495 -- Skip inlining if this is not a true inlining since the attribute 3496 -- Body_To_Inline is also set for renamings (see sinfo.ads). For a 3497 -- true inlining, Orig_Bod has code rather than being an entity. 3498 3499 elsif Nkind (Orig_Bod) in N_Entity then 3500 return; 3501 end if; 3502 3503 if Nkind (Orig_Bod) = N_Defining_Identifier 3504 or else Nkind (Orig_Bod) = N_Defining_Operator_Symbol 3505 then 3506 -- Subprogram is renaming_as_body. Calls occurring after the renaming 3507 -- can be replaced with calls to the renamed entity directly, because 3508 -- the subprograms are subtype conformant. If the renamed subprogram 3509 -- is an inherited operation, we must redo the expansion because 3510 -- implicit conversions may be needed. Similarly, if the renamed 3511 -- entity is inlined, expand the call for further optimizations. 3512 3513 Set_Name (N, New_Occurrence_Of (Orig_Bod, Loc)); 3514 3515 if Present (Alias (Orig_Bod)) or else Is_Inlined (Orig_Bod) then 3516 Expand_Call (N); 3517 end if; 3518 3519 return; 3520 end if; 3521 3522 -- Register the call in the list of inlined calls 3523 3524 Append_New_Elmt (N, To => Inlined_Calls); 3525 3526 -- Use generic machinery to copy body of inlined subprogram, as if it 3527 -- were an instantiation, resetting source locations appropriately, so 3528 -- that nested inlined calls appear in the main unit. 3529 3530 Save_Env (Subp, Empty); 3531 Set_Copied_Sloc_For_Inlined_Body (N, Defining_Entity (Orig_Bod)); 3532 3533 -- Old semantics 3534 3535 if not Uses_Back_End then 3536 declare 3537 Bod : Node_Id; 3538 3539 begin 3540 Bod := Copy_Generic_Node (Orig_Bod, Empty, Instantiating => True); 3541 Blk := 3542 Make_Block_Statement (Loc, 3543 Declarations => Declarations (Bod), 3544 Handled_Statement_Sequence => 3545 Handled_Statement_Sequence (Bod)); 3546 3547 if No (Declarations (Bod)) then 3548 Set_Declarations (Blk, New_List); 3549 end if; 3550 3551 -- When generating C code, declare _Result, which may be used to 3552 -- verify the return value. 3553 3554 if Modify_Tree_For_C 3555 and then Nkind (N) = N_Procedure_Call_Statement 3556 and then Chars (Name (N)) = Name_uPostconditions 3557 then 3558 Declare_Postconditions_Result; 3559 end if; 3560 3561 -- For the unconstrained case, capture the name of the local 3562 -- variable that holds the result. This must be the first 3563 -- declaration in the block, because its bounds cannot depend 3564 -- on local variables. Otherwise there is no way to declare the 3565 -- result outside of the block. Needless to say, in general the 3566 -- bounds will depend on the actuals in the call. 3567 3568 -- If the context is an assignment statement, as is the case 3569 -- for the expansion of an extended return, the left-hand side 3570 -- provides bounds even if the return type is unconstrained. 3571 3572 if Is_Unc then 3573 declare 3574 First_Decl : Node_Id; 3575 3576 begin 3577 First_Decl := First (Declarations (Blk)); 3578 3579 -- If the body is a single extended return statement,the 3580 -- resulting block is a nested block. 3581 3582 if No (First_Decl) then 3583 First_Decl := 3584 First (Statements (Handled_Statement_Sequence (Blk))); 3585 3586 if Nkind (First_Decl) = N_Block_Statement then 3587 First_Decl := First (Declarations (First_Decl)); 3588 end if; 3589 end if; 3590 3591 -- No front-end inlining possible 3592 3593 if Nkind (First_Decl) /= N_Object_Declaration then 3594 return; 3595 end if; 3596 3597 if Nkind (Parent (N)) /= N_Assignment_Statement then 3598 Targ1 := Defining_Identifier (First_Decl); 3599 else 3600 Targ1 := Name (Parent (N)); 3601 end if; 3602 end; 3603 end if; 3604 end; 3605 3606 -- New semantics 3607 3608 else 3609 declare 3610 Bod : Node_Id; 3611 3612 begin 3613 -- General case 3614 3615 if not Is_Unc then 3616 Bod := 3617 Copy_Generic_Node (Orig_Bod, Empty, Instantiating => True); 3618 Blk := 3619 Make_Block_Statement (Loc, 3620 Declarations => Declarations (Bod), 3621 Handled_Statement_Sequence => 3622 Handled_Statement_Sequence (Bod)); 3623 3624 -- Inline a call to a function that returns an unconstrained type. 3625 -- The semantic analyzer checked that frontend-inlined functions 3626 -- returning unconstrained types have no declarations and have 3627 -- a single extended return statement. As part of its processing 3628 -- the function was split into two subprograms: a procedure P' and 3629 -- a function F' that has a block with a call to procedure P' (see 3630 -- Split_Unconstrained_Function). 3631 3632 else 3633 pragma Assert 3634 (Nkind 3635 (First 3636 (Statements (Handled_Statement_Sequence (Orig_Bod)))) = 3637 N_Block_Statement); 3638 3639 declare 3640 Blk_Stmt : constant Node_Id := 3641 First (Statements (Handled_Statement_Sequence (Orig_Bod))); 3642 First_Stmt : constant Node_Id := 3643 First (Statements (Handled_Statement_Sequence (Blk_Stmt))); 3644 Second_Stmt : constant Node_Id := Next (First_Stmt); 3645 3646 begin 3647 pragma Assert 3648 (Nkind (First_Stmt) = N_Procedure_Call_Statement 3649 and then Nkind (Second_Stmt) = N_Simple_Return_Statement 3650 and then No (Next (Second_Stmt))); 3651 3652 Bod := 3653 Copy_Generic_Node 3654 (First 3655 (Statements (Handled_Statement_Sequence (Orig_Bod))), 3656 Empty, Instantiating => True); 3657 Blk := Bod; 3658 3659 -- Capture the name of the local variable that holds the 3660 -- result. This must be the first declaration in the block, 3661 -- because its bounds cannot depend on local variables. 3662 -- Otherwise there is no way to declare the result outside 3663 -- of the block. Needless to say, in general the bounds will 3664 -- depend on the actuals in the call. 3665 3666 if Nkind (Parent (N)) /= N_Assignment_Statement then 3667 Targ1 := Defining_Identifier (First (Declarations (Blk))); 3668 3669 -- If the context is an assignment statement, as is the case 3670 -- for the expansion of an extended return, the left-hand 3671 -- side provides bounds even if the return type is 3672 -- unconstrained. 3673 3674 else 3675 Targ1 := Name (Parent (N)); 3676 end if; 3677 end; 3678 end if; 3679 3680 if No (Declarations (Bod)) then 3681 Set_Declarations (Blk, New_List); 3682 end if; 3683 end; 3684 end if; 3685 3686 -- If this is a derived function, establish the proper return type 3687 3688 if Present (Orig_Subp) and then Orig_Subp /= Subp then 3689 Ret_Type := Etype (Orig_Subp); 3690 else 3691 Ret_Type := Etype (Subp); 3692 end if; 3693 3694 -- Create temporaries for the actuals that are expressions, or that are 3695 -- scalars and require copying to preserve semantics. 3696 3697 F := First_Formal (Subp); 3698 A := First_Actual (N); 3699 while Present (F) loop 3700 if Present (Renamed_Object (F)) then 3701 3702 -- If expander is active, it is an error to try to inline a 3703 -- recursive program. In GNATprove mode, just indicate that the 3704 -- inlining will not happen, and mark the subprogram as not always 3705 -- inlined. 3706 3707 if GNATprove_Mode then 3708 Cannot_Inline 3709 ("cannot inline call to recursive subprogram?", N, Subp); 3710 Set_Is_Inlined_Always (Subp, False); 3711 else 3712 Error_Msg_N 3713 ("cannot inline call to recursive subprogram", N); 3714 end if; 3715 3716 return; 3717 end if; 3718 3719 -- Reset Last_Assignment for any parameters of mode out or in out, to 3720 -- prevent spurious warnings about overwriting for assignments to the 3721 -- formal in the inlined code. 3722 3723 if Is_Entity_Name (A) and then Ekind (F) /= E_In_Parameter then 3724 Set_Last_Assignment (Entity (A), Empty); 3725 end if; 3726 3727 -- If the argument may be a controlling argument in a call within 3728 -- the inlined body, we must preserve its classwide nature to insure 3729 -- that dynamic dispatching take place subsequently. If the formal 3730 -- has a constraint it must be preserved to retain the semantics of 3731 -- the body. 3732 3733 if Is_Class_Wide_Type (Etype (F)) 3734 or else (Is_Access_Type (Etype (F)) 3735 and then Is_Class_Wide_Type (Designated_Type (Etype (F)))) 3736 then 3737 Temp_Typ := Etype (F); 3738 3739 elsif Base_Type (Etype (F)) = Base_Type (Etype (A)) 3740 and then Etype (F) /= Base_Type (Etype (F)) 3741 and then Is_Constrained (Etype (F)) 3742 then 3743 Temp_Typ := Etype (F); 3744 3745 else 3746 Temp_Typ := Etype (A); 3747 end if; 3748 3749 -- If the actual is a simple name or a literal, no need to 3750 -- create a temporary, object can be used directly. 3751 3752 -- If the actual is a literal and the formal has its address taken, 3753 -- we cannot pass the literal itself as an argument, so its value 3754 -- must be captured in a temporary. Skip this optimization in 3755 -- GNATprove mode, to make sure any check on a type conversion 3756 -- will be issued. 3757 3758 if (Is_Entity_Name (A) 3759 and then 3760 (not Is_Scalar_Type (Etype (A)) 3761 or else Ekind (Entity (A)) = E_Enumeration_Literal) 3762 and then not GNATprove_Mode) 3763 3764 -- When the actual is an identifier and the corresponding formal is 3765 -- used only once in the original body, the formal can be substituted 3766 -- directly with the actual parameter. Skip this optimization in 3767 -- GNATprove mode, to make sure any check on a type conversion 3768 -- will be issued. 3769 3770 or else 3771 (Nkind (A) = N_Identifier 3772 and then Formal_Is_Used_Once (F) 3773 and then not GNATprove_Mode) 3774 3775 or else 3776 (Nkind_In (A, N_Real_Literal, 3777 N_Integer_Literal, 3778 N_Character_Literal) 3779 and then not Address_Taken (F)) 3780 then 3781 if Etype (F) /= Etype (A) then 3782 Set_Renamed_Object 3783 (F, Unchecked_Convert_To (Etype (F), Relocate_Node (A))); 3784 else 3785 Set_Renamed_Object (F, A); 3786 end if; 3787 3788 else 3789 Temp := Make_Temporary (Loc, 'C'); 3790 3791 -- If the actual for an in/in-out parameter is a view conversion, 3792 -- make it into an unchecked conversion, given that an untagged 3793 -- type conversion is not a proper object for a renaming. 3794 3795 -- In-out conversions that involve real conversions have already 3796 -- been transformed in Expand_Actuals. 3797 3798 if Nkind (A) = N_Type_Conversion 3799 and then Ekind (F) /= E_In_Parameter 3800 then 3801 New_A := 3802 Make_Unchecked_Type_Conversion (Loc, 3803 Subtype_Mark => New_Occurrence_Of (Etype (F), Loc), 3804 Expression => Relocate_Node (Expression (A))); 3805 3806 -- In GNATprove mode, keep the most precise type of the actual for 3807 -- the temporary variable, when the formal type is unconstrained. 3808 -- Otherwise, the AST may contain unexpected assignment statements 3809 -- to a temporary variable of unconstrained type renaming a local 3810 -- variable of constrained type, which is not expected by 3811 -- GNATprove. 3812 3813 elsif Etype (F) /= Etype (A) 3814 and then (not GNATprove_Mode or else Is_Constrained (Etype (F))) 3815 then 3816 New_A := Unchecked_Convert_To (Etype (F), Relocate_Node (A)); 3817 Temp_Typ := Etype (F); 3818 3819 else 3820 New_A := Relocate_Node (A); 3821 end if; 3822 3823 Set_Sloc (New_A, Sloc (N)); 3824 3825 -- If the actual has a by-reference type, it cannot be copied, 3826 -- so its value is captured in a renaming declaration. Otherwise 3827 -- declare a local constant initialized with the actual. 3828 3829 -- We also use a renaming declaration for expressions of an array 3830 -- type that is not bit-packed, both for efficiency reasons and to 3831 -- respect the semantics of the call: in most cases the original 3832 -- call will pass the parameter by reference, and thus the inlined 3833 -- code will have the same semantics. 3834 3835 -- Finally, we need a renaming declaration in the case of limited 3836 -- types for which initialization cannot be by copy either. 3837 3838 if Ekind (F) = E_In_Parameter 3839 and then not Is_By_Reference_Type (Etype (A)) 3840 and then not Is_Limited_Type (Etype (A)) 3841 and then 3842 (not Is_Array_Type (Etype (A)) 3843 or else not Is_Object_Reference (A) 3844 or else Is_Bit_Packed_Array (Etype (A))) 3845 then 3846 Decl := 3847 Make_Object_Declaration (Loc, 3848 Defining_Identifier => Temp, 3849 Constant_Present => True, 3850 Object_Definition => New_Occurrence_Of (Temp_Typ, Loc), 3851 Expression => New_A); 3852 3853 else 3854 -- In GNATprove mode, make an explicit copy of input 3855 -- parameters when formal and actual types differ, to make 3856 -- sure any check on the type conversion will be issued. 3857 -- The legality of the copy is ensured by calling first 3858 -- Call_Can_Be_Inlined_In_GNATprove_Mode. 3859 3860 if GNATprove_Mode 3861 and then Ekind (F) /= E_Out_Parameter 3862 and then not Same_Type (Etype (F), Etype (A)) 3863 then 3864 pragma Assert (not Is_By_Reference_Type (Etype (A))); 3865 pragma Assert (not Is_Limited_Type (Etype (A))); 3866 3867 Append_To (Decls, 3868 Make_Object_Declaration (Loc, 3869 Defining_Identifier => Make_Temporary (Loc, 'C'), 3870 Constant_Present => True, 3871 Object_Definition => New_Occurrence_Of (Temp_Typ, Loc), 3872 Expression => New_Copy_Tree (New_A))); 3873 end if; 3874 3875 Decl := 3876 Make_Object_Renaming_Declaration (Loc, 3877 Defining_Identifier => Temp, 3878 Subtype_Mark => New_Occurrence_Of (Temp_Typ, Loc), 3879 Name => New_A); 3880 end if; 3881 3882 Append (Decl, Decls); 3883 Set_Renamed_Object (F, Temp); 3884 end if; 3885 3886 Next_Formal (F); 3887 Next_Actual (A); 3888 end loop; 3889 3890 -- Establish target of function call. If context is not assignment or 3891 -- declaration, create a temporary as a target. The declaration for the 3892 -- temporary may be subsequently optimized away if the body is a single 3893 -- expression, or if the left-hand side of the assignment is simple 3894 -- enough, i.e. an entity or an explicit dereference of one. 3895 3896 if Ekind (Subp) = E_Function then 3897 if Nkind (Parent (N)) = N_Assignment_Statement 3898 and then Is_Entity_Name (Name (Parent (N))) 3899 then 3900 Targ := Name (Parent (N)); 3901 3902 elsif Nkind (Parent (N)) = N_Assignment_Statement 3903 and then Nkind (Name (Parent (N))) = N_Explicit_Dereference 3904 and then Is_Entity_Name (Prefix (Name (Parent (N)))) 3905 then 3906 Targ := Name (Parent (N)); 3907 3908 elsif Nkind (Parent (N)) = N_Assignment_Statement 3909 and then Nkind (Name (Parent (N))) = N_Selected_Component 3910 and then Is_Entity_Name (Prefix (Name (Parent (N)))) 3911 then 3912 Targ := New_Copy_Tree (Name (Parent (N))); 3913 3914 elsif Nkind (Parent (N)) = N_Object_Declaration 3915 and then Is_Limited_Type (Etype (Subp)) 3916 then 3917 Targ := Defining_Identifier (Parent (N)); 3918 3919 -- New semantics: In an object declaration avoid an extra copy 3920 -- of the result of a call to an inlined function that returns 3921 -- an unconstrained type 3922 3923 elsif Uses_Back_End 3924 and then Nkind (Parent (N)) = N_Object_Declaration 3925 and then Is_Unc 3926 then 3927 Targ := Defining_Identifier (Parent (N)); 3928 3929 else 3930 -- Replace call with temporary and create its declaration 3931 3932 Temp := Make_Temporary (Loc, 'C'); 3933 Set_Is_Internal (Temp); 3934 3935 -- For the unconstrained case, the generated temporary has the 3936 -- same constrained declaration as the result variable. It may 3937 -- eventually be possible to remove that temporary and use the 3938 -- result variable directly. 3939 3940 if Is_Unc and then Nkind (Parent (N)) /= N_Assignment_Statement 3941 then 3942 Decl := 3943 Make_Object_Declaration (Loc, 3944 Defining_Identifier => Temp, 3945 Object_Definition => 3946 New_Copy_Tree (Object_Definition (Parent (Targ1)))); 3947 3948 Replace_Formals (Decl); 3949 3950 else 3951 Decl := 3952 Make_Object_Declaration (Loc, 3953 Defining_Identifier => Temp, 3954 Object_Definition => New_Occurrence_Of (Ret_Type, Loc)); 3955 3956 Set_Etype (Temp, Ret_Type); 3957 end if; 3958 3959 Set_No_Initialization (Decl); 3960 Append (Decl, Decls); 3961 Rewrite (N, New_Occurrence_Of (Temp, Loc)); 3962 Targ := Temp; 3963 end if; 3964 end if; 3965 3966 Insert_Actions (N, Decls); 3967 3968 if Is_Unc_Decl then 3969 3970 -- Special management for inlining a call to a function that returns 3971 -- an unconstrained type and initializes an object declaration: we 3972 -- avoid generating undesired extra calls and goto statements. 3973 3974 -- Given: 3975 -- function Func (...) return String is 3976 -- begin 3977 -- declare 3978 -- Result : String (1 .. 4); 3979 -- begin 3980 -- Proc (Result, ...); 3981 -- return Result; 3982 -- end; 3983 -- end Func; 3984 3985 -- Result : String := Func (...); 3986 3987 -- Replace this object declaration by: 3988 3989 -- Result : String (1 .. 4); 3990 -- Proc (Result, ...); 3991 3992 Remove_Homonym (Targ); 3993 3994 Decl := 3995 Make_Object_Declaration 3996 (Loc, 3997 Defining_Identifier => Targ, 3998 Object_Definition => 3999 New_Copy_Tree (Object_Definition (Parent (Targ1)))); 4000 Replace_Formals (Decl); 4001 Rewrite (Parent (N), Decl); 4002 Analyze (Parent (N)); 4003 4004 -- Avoid spurious warnings since we know that this declaration is 4005 -- referenced by the procedure call. 4006 4007 Set_Never_Set_In_Source (Targ, False); 4008 4009 -- Remove the local declaration of the extended return stmt from the 4010 -- inlined code 4011 4012 Remove (Parent (Targ1)); 4013 4014 -- Update the reference to the result (since we have rewriten the 4015 -- object declaration) 4016 4017 declare 4018 Blk_Call_Stmt : Node_Id; 4019 4020 begin 4021 -- Capture the call to the procedure 4022 4023 Blk_Call_Stmt := 4024 First (Statements (Handled_Statement_Sequence (Blk))); 4025 pragma Assert 4026 (Nkind (Blk_Call_Stmt) = N_Procedure_Call_Statement); 4027 4028 Remove (First (Parameter_Associations (Blk_Call_Stmt))); 4029 Prepend_To (Parameter_Associations (Blk_Call_Stmt), 4030 New_Occurrence_Of (Targ, Loc)); 4031 end; 4032 4033 -- Remove the return statement 4034 4035 pragma Assert 4036 (Nkind (Last (Statements (Handled_Statement_Sequence (Blk)))) = 4037 N_Simple_Return_Statement); 4038 4039 Remove (Last (Statements (Handled_Statement_Sequence (Blk)))); 4040 end if; 4041 4042 -- Traverse the tree and replace formals with actuals or their thunks. 4043 -- Attach block to tree before analysis and rewriting. 4044 4045 Replace_Formals (Blk); 4046 Replace_Formals_In_Aspects (Blk); 4047 Set_Parent (Blk, N); 4048 4049 if GNATprove_Mode then 4050 null; 4051 4052 elsif not Comes_From_Source (Subp) or else Is_Predef then 4053 Reset_Slocs (Blk); 4054 end if; 4055 4056 if Is_Unc_Decl then 4057 4058 -- No action needed since return statement has been already removed 4059 4060 null; 4061 4062 elsif Present (Exit_Lab) then 4063 4064 -- If there's a single return statement at the end of the subprogram, 4065 -- the corresponding goto statement and the corresponding label are 4066 -- useless. 4067 4068 if Num_Ret = 1 4069 and then 4070 Nkind (Last (Statements (Handled_Statement_Sequence (Blk)))) = 4071 N_Goto_Statement 4072 then 4073 Remove (Last (Statements (Handled_Statement_Sequence (Blk)))); 4074 else 4075 Append (Lab_Decl, (Declarations (Blk))); 4076 Append (Exit_Lab, Statements (Handled_Statement_Sequence (Blk))); 4077 end if; 4078 end if; 4079 4080 -- Analyze Blk with In_Inlined_Body set, to avoid spurious errors 4081 -- on conflicting private views that Gigi would ignore. If this is a 4082 -- predefined unit, analyze with checks off, as is done in the non- 4083 -- inlined run-time units. 4084 4085 declare 4086 I_Flag : constant Boolean := In_Inlined_Body; 4087 4088 begin 4089 In_Inlined_Body := True; 4090 4091 if Is_Predef then 4092 declare 4093 Style : constant Boolean := Style_Check; 4094 4095 begin 4096 Style_Check := False; 4097 4098 -- Search for dispatching calls that use the Object.Operation 4099 -- notation using an Object that is a parameter of the inlined 4100 -- function. We reset the decoration of Operation to force 4101 -- the reanalysis of the inlined dispatching call because 4102 -- the actual object has been inlined. 4103 4104 Reset_Dispatching_Calls (Blk); 4105 4106 Analyze (Blk, Suppress => All_Checks); 4107 Style_Check := Style; 4108 end; 4109 4110 else 4111 Analyze (Blk); 4112 end if; 4113 4114 In_Inlined_Body := I_Flag; 4115 end; 4116 4117 if Ekind (Subp) = E_Procedure then 4118 Rewrite_Procedure_Call (N, Blk); 4119 4120 else 4121 Rewrite_Function_Call (N, Blk); 4122 4123 if Is_Unc_Decl then 4124 null; 4125 4126 -- For the unconstrained case, the replacement of the call has been 4127 -- made prior to the complete analysis of the generated declarations. 4128 -- Propagate the proper type now. 4129 4130 elsif Is_Unc then 4131 if Nkind (N) = N_Identifier then 4132 Set_Etype (N, Etype (Entity (N))); 4133 else 4134 Set_Etype (N, Etype (Targ1)); 4135 end if; 4136 end if; 4137 end if; 4138 4139 Restore_Env; 4140 4141 -- Cleanup mapping between formals and actuals for other expansions 4142 4143 F := First_Formal (Subp); 4144 while Present (F) loop 4145 Set_Renamed_Object (F, Empty); 4146 Next_Formal (F); 4147 end loop; 4148 end Expand_Inlined_Call; 4149 4150 -------------------------- 4151 -- Get_Code_Unit_Entity -- 4152 -------------------------- 4153 4154 function Get_Code_Unit_Entity (E : Entity_Id) return Entity_Id is 4155 Unit : Entity_Id := Cunit_Entity (Get_Code_Unit (E)); 4156 4157 begin 4158 if Ekind (Unit) = E_Package_Body then 4159 Unit := Spec_Entity (Unit); 4160 end if; 4161 4162 return Unit; 4163 end Get_Code_Unit_Entity; 4164 4165 ------------------------------ 4166 -- Has_Excluded_Declaration -- 4167 ------------------------------ 4168 4169 function Has_Excluded_Declaration 4170 (Subp : Entity_Id; 4171 Decls : List_Id) return Boolean 4172 is 4173 D : Node_Id; 4174 4175 function Is_Unchecked_Conversion (D : Node_Id) return Boolean; 4176 -- Nested subprograms make a given body ineligible for inlining, but 4177 -- we make an exception for instantiations of unchecked conversion. 4178 -- The body has not been analyzed yet, so check the name, and verify 4179 -- that the visible entity with that name is the predefined unit. 4180 4181 ----------------------------- 4182 -- Is_Unchecked_Conversion -- 4183 ----------------------------- 4184 4185 function Is_Unchecked_Conversion (D : Node_Id) return Boolean is 4186 Id : constant Node_Id := Name (D); 4187 Conv : Entity_Id; 4188 4189 begin 4190 if Nkind (Id) = N_Identifier 4191 and then Chars (Id) = Name_Unchecked_Conversion 4192 then 4193 Conv := Current_Entity (Id); 4194 4195 elsif Nkind_In (Id, N_Selected_Component, N_Expanded_Name) 4196 and then Chars (Selector_Name (Id)) = Name_Unchecked_Conversion 4197 then 4198 Conv := Current_Entity (Selector_Name (Id)); 4199 else 4200 return False; 4201 end if; 4202 4203 return Present (Conv) 4204 and then Is_Predefined_Unit (Get_Source_Unit (Conv)) 4205 and then Is_Intrinsic_Subprogram (Conv); 4206 end Is_Unchecked_Conversion; 4207 4208 -- Start of processing for Has_Excluded_Declaration 4209 4210 begin 4211 -- No action needed if the check is not needed 4212 4213 if not Check_Inlining_Restrictions then 4214 return False; 4215 end if; 4216 4217 D := First (Decls); 4218 while Present (D) loop 4219 4220 -- First declarations universally excluded 4221 4222 if Nkind (D) = N_Package_Declaration then 4223 Cannot_Inline 4224 ("cannot inline & (nested package declaration)?", D, Subp); 4225 return True; 4226 4227 elsif Nkind (D) = N_Package_Instantiation then 4228 Cannot_Inline 4229 ("cannot inline & (nested package instantiation)?", D, Subp); 4230 return True; 4231 end if; 4232 4233 -- Then declarations excluded only for front-end inlining 4234 4235 if Back_End_Inlining then 4236 null; 4237 4238 elsif Nkind (D) = N_Task_Type_Declaration 4239 or else Nkind (D) = N_Single_Task_Declaration 4240 then 4241 Cannot_Inline 4242 ("cannot inline & (nested task type declaration)?", D, Subp); 4243 return True; 4244 4245 elsif Nkind (D) = N_Protected_Type_Declaration 4246 or else Nkind (D) = N_Single_Protected_Declaration 4247 then 4248 Cannot_Inline 4249 ("cannot inline & (nested protected type declaration)?", 4250 D, Subp); 4251 return True; 4252 4253 elsif Nkind (D) = N_Subprogram_Body then 4254 Cannot_Inline 4255 ("cannot inline & (nested subprogram)?", D, Subp); 4256 return True; 4257 4258 elsif Nkind (D) = N_Function_Instantiation 4259 and then not Is_Unchecked_Conversion (D) 4260 then 4261 Cannot_Inline 4262 ("cannot inline & (nested function instantiation)?", D, Subp); 4263 return True; 4264 4265 elsif Nkind (D) = N_Procedure_Instantiation then 4266 Cannot_Inline 4267 ("cannot inline & (nested procedure instantiation)?", D, Subp); 4268 return True; 4269 4270 -- Subtype declarations with predicates will generate predicate 4271 -- functions, i.e. nested subprogram bodies, so inlining is not 4272 -- possible. 4273 4274 elsif Nkind (D) = N_Subtype_Declaration 4275 and then Present (Aspect_Specifications (D)) 4276 then 4277 declare 4278 A : Node_Id; 4279 A_Id : Aspect_Id; 4280 4281 begin 4282 A := First (Aspect_Specifications (D)); 4283 while Present (A) loop 4284 A_Id := Get_Aspect_Id (Chars (Identifier (A))); 4285 4286 if A_Id = Aspect_Predicate 4287 or else A_Id = Aspect_Static_Predicate 4288 or else A_Id = Aspect_Dynamic_Predicate 4289 then 4290 Cannot_Inline 4291 ("cannot inline & (subtype declaration with " 4292 & "predicate)?", D, Subp); 4293 return True; 4294 end if; 4295 4296 Next (A); 4297 end loop; 4298 end; 4299 end if; 4300 4301 Next (D); 4302 end loop; 4303 4304 return False; 4305 end Has_Excluded_Declaration; 4306 4307 ---------------------------- 4308 -- Has_Excluded_Statement -- 4309 ---------------------------- 4310 4311 function Has_Excluded_Statement 4312 (Subp : Entity_Id; 4313 Stats : List_Id) return Boolean 4314 is 4315 S : Node_Id; 4316 E : Node_Id; 4317 4318 begin 4319 -- No action needed if the check is not needed 4320 4321 if not Check_Inlining_Restrictions then 4322 return False; 4323 end if; 4324 4325 S := First (Stats); 4326 while Present (S) loop 4327 if Nkind_In (S, N_Abort_Statement, 4328 N_Asynchronous_Select, 4329 N_Conditional_Entry_Call, 4330 N_Delay_Relative_Statement, 4331 N_Delay_Until_Statement, 4332 N_Selective_Accept, 4333 N_Timed_Entry_Call) 4334 then 4335 Cannot_Inline 4336 ("cannot inline & (non-allowed statement)?", S, Subp); 4337 return True; 4338 4339 elsif Nkind (S) = N_Block_Statement then 4340 if Present (Declarations (S)) 4341 and then Has_Excluded_Declaration (Subp, Declarations (S)) 4342 then 4343 return True; 4344 4345 elsif Present (Handled_Statement_Sequence (S)) then 4346 if not Back_End_Inlining 4347 and then 4348 Present 4349 (Exception_Handlers (Handled_Statement_Sequence (S))) 4350 then 4351 Cannot_Inline 4352 ("cannot inline& (exception handler)?", 4353 First (Exception_Handlers 4354 (Handled_Statement_Sequence (S))), 4355 Subp); 4356 return True; 4357 4358 elsif Has_Excluded_Statement 4359 (Subp, Statements (Handled_Statement_Sequence (S))) 4360 then 4361 return True; 4362 end if; 4363 end if; 4364 4365 elsif Nkind (S) = N_Case_Statement then 4366 E := First (Alternatives (S)); 4367 while Present (E) loop 4368 if Has_Excluded_Statement (Subp, Statements (E)) then 4369 return True; 4370 end if; 4371 4372 Next (E); 4373 end loop; 4374 4375 elsif Nkind (S) = N_If_Statement then 4376 if Has_Excluded_Statement (Subp, Then_Statements (S)) then 4377 return True; 4378 end if; 4379 4380 if Present (Elsif_Parts (S)) then 4381 E := First (Elsif_Parts (S)); 4382 while Present (E) loop 4383 if Has_Excluded_Statement (Subp, Then_Statements (E)) then 4384 return True; 4385 end if; 4386 4387 Next (E); 4388 end loop; 4389 end if; 4390 4391 if Present (Else_Statements (S)) 4392 and then Has_Excluded_Statement (Subp, Else_Statements (S)) 4393 then 4394 return True; 4395 end if; 4396 4397 elsif Nkind (S) = N_Loop_Statement 4398 and then Has_Excluded_Statement (Subp, Statements (S)) 4399 then 4400 return True; 4401 4402 elsif Nkind (S) = N_Extended_Return_Statement then 4403 if Present (Handled_Statement_Sequence (S)) 4404 and then 4405 Has_Excluded_Statement 4406 (Subp, Statements (Handled_Statement_Sequence (S))) 4407 then 4408 return True; 4409 4410 elsif not Back_End_Inlining 4411 and then Present (Handled_Statement_Sequence (S)) 4412 and then 4413 Present (Exception_Handlers 4414 (Handled_Statement_Sequence (S))) 4415 then 4416 Cannot_Inline 4417 ("cannot inline& (exception handler)?", 4418 First (Exception_Handlers (Handled_Statement_Sequence (S))), 4419 Subp); 4420 return True; 4421 end if; 4422 end if; 4423 4424 Next (S); 4425 end loop; 4426 4427 return False; 4428 end Has_Excluded_Statement; 4429 4430 -------------------------- 4431 -- Has_Initialized_Type -- 4432 -------------------------- 4433 4434 function Has_Initialized_Type (E : Entity_Id) return Boolean is 4435 E_Body : constant Node_Id := Subprogram_Body (E); 4436 Decl : Node_Id; 4437 4438 begin 4439 if No (E_Body) then -- imported subprogram 4440 return False; 4441 4442 else 4443 Decl := First (Declarations (E_Body)); 4444 while Present (Decl) loop 4445 if Nkind (Decl) = N_Full_Type_Declaration 4446 and then Present (Init_Proc (Defining_Identifier (Decl))) 4447 then 4448 return True; 4449 end if; 4450 4451 Next (Decl); 4452 end loop; 4453 end if; 4454 4455 return False; 4456 end Has_Initialized_Type; 4457 4458 ----------------------- 4459 -- Has_Single_Return -- 4460 ----------------------- 4461 4462 function Has_Single_Return (N : Node_Id) return Boolean is 4463 Return_Statement : Node_Id := Empty; 4464 4465 function Check_Return (N : Node_Id) return Traverse_Result; 4466 4467 ------------------ 4468 -- Check_Return -- 4469 ------------------ 4470 4471 function Check_Return (N : Node_Id) return Traverse_Result is 4472 begin 4473 if Nkind (N) = N_Simple_Return_Statement then 4474 if Present (Expression (N)) 4475 and then Is_Entity_Name (Expression (N)) 4476 then 4477 pragma Assert (Present (Entity (Expression (N)))); 4478 4479 if No (Return_Statement) then 4480 Return_Statement := N; 4481 return OK; 4482 4483 else 4484 pragma Assert 4485 (Present (Entity (Expression (Return_Statement)))); 4486 4487 if Entity (Expression (N)) = 4488 Entity (Expression (Return_Statement)) 4489 then 4490 return OK; 4491 else 4492 return Abandon; 4493 end if; 4494 end if; 4495 4496 -- A return statement within an extended return is a noop after 4497 -- inlining. 4498 4499 elsif No (Expression (N)) 4500 and then Nkind (Parent (Parent (N))) = 4501 N_Extended_Return_Statement 4502 then 4503 return OK; 4504 4505 else 4506 -- Expression has wrong form 4507 4508 return Abandon; 4509 end if; 4510 4511 -- We can only inline a build-in-place function if it has a single 4512 -- extended return. 4513 4514 elsif Nkind (N) = N_Extended_Return_Statement then 4515 if No (Return_Statement) then 4516 Return_Statement := N; 4517 return OK; 4518 4519 else 4520 return Abandon; 4521 end if; 4522 4523 else 4524 return OK; 4525 end if; 4526 end Check_Return; 4527 4528 function Check_All_Returns is new Traverse_Func (Check_Return); 4529 4530 -- Start of processing for Has_Single_Return 4531 4532 begin 4533 if Check_All_Returns (N) /= OK then 4534 return False; 4535 4536 elsif Nkind (Return_Statement) = N_Extended_Return_Statement then 4537 return True; 4538 4539 else 4540 return 4541 Present (Declarations (N)) 4542 and then Present (First (Declarations (N))) 4543 and then Entity (Expression (Return_Statement)) = 4544 Defining_Identifier (First (Declarations (N))); 4545 end if; 4546 end Has_Single_Return; 4547 4548 ----------------------------- 4549 -- In_Main_Unit_Or_Subunit -- 4550 ----------------------------- 4551 4552 function In_Main_Unit_Or_Subunit (E : Entity_Id) return Boolean is 4553 Comp : Node_Id := Cunit (Get_Code_Unit (E)); 4554 4555 begin 4556 -- Check whether the subprogram or package to inline is within the main 4557 -- unit or its spec or within a subunit. In either case there are no 4558 -- additional bodies to process. If the subprogram appears in a parent 4559 -- of the current unit, the check on whether inlining is possible is 4560 -- done in Analyze_Inlined_Bodies. 4561 4562 while Nkind (Unit (Comp)) = N_Subunit loop 4563 Comp := Library_Unit (Comp); 4564 end loop; 4565 4566 return Comp = Cunit (Main_Unit) 4567 or else Comp = Library_Unit (Cunit (Main_Unit)); 4568 end In_Main_Unit_Or_Subunit; 4569 4570 ---------------- 4571 -- Initialize -- 4572 ---------------- 4573 4574 procedure Initialize is 4575 begin 4576 Pending_Instantiations.Init; 4577 Called_Pending_Instantiations.Init; 4578 Inlined_Bodies.Init; 4579 Successors.Init; 4580 Inlined.Init; 4581 4582 for J in Hash_Headers'Range loop 4583 Hash_Headers (J) := No_Subp; 4584 end loop; 4585 4586 Inlined_Calls := No_Elist; 4587 Backend_Calls := No_Elist; 4588 Backend_Instances := No_Elist; 4589 Backend_Inlined_Subps := No_Elist; 4590 Backend_Not_Inlined_Subps := No_Elist; 4591 end Initialize; 4592 4593 ------------------------ 4594 -- Instantiate_Bodies -- 4595 ------------------------ 4596 4597 -- Generic bodies contain all the non-local references, so an 4598 -- instantiation does not need any more context than Standard 4599 -- itself, even if the instantiation appears in an inner scope. 4600 -- Generic associations have verified that the contract model is 4601 -- satisfied, so that any error that may occur in the analysis of 4602 -- the body is an internal error. 4603 4604 procedure Instantiate_Bodies is 4605 4606 procedure Instantiate_Body (Info : Pending_Body_Info); 4607 -- Instantiate a pending body 4608 4609 ------------------------ 4610 -- Instantiate_Body -- 4611 ------------------------ 4612 4613 procedure Instantiate_Body (Info : Pending_Body_Info) is 4614 begin 4615 -- If the instantiation node is absent, it has been removed as part 4616 -- of unreachable code. 4617 4618 if No (Info.Inst_Node) then 4619 null; 4620 4621 -- If the instantiation node is a package body, this means that the 4622 -- instance is a compilation unit and the instantiation has already 4623 -- been performed by Build_Instance_Compilation_Unit_Nodes. 4624 4625 elsif Nkind (Info.Inst_Node) = N_Package_Body then 4626 null; 4627 4628 elsif Nkind (Info.Act_Decl) = N_Package_Declaration then 4629 Instantiate_Package_Body (Info); 4630 Add_Scope_To_Clean (Defining_Entity (Info.Act_Decl)); 4631 4632 else 4633 Instantiate_Subprogram_Body (Info); 4634 end if; 4635 end Instantiate_Body; 4636 4637 J, K : Nat; 4638 Info : Pending_Body_Info; 4639 4640 -- Start of processing for Instantiate_Bodies 4641 4642 begin 4643 if Serious_Errors_Detected = 0 then 4644 Expander_Active := (Operating_Mode = Opt.Generate_Code); 4645 Push_Scope (Standard_Standard); 4646 To_Clean := New_Elmt_List; 4647 4648 if Is_Generic_Unit (Cunit_Entity (Main_Unit)) then 4649 Start_Generic; 4650 end if; 4651 4652 -- A body instantiation may generate additional instantiations, so 4653 -- the following loop must scan to the end of a possibly expanding 4654 -- set (that's why we cannot simply use a FOR loop here). We must 4655 -- also capture the element lest the set be entirely reallocated. 4656 4657 J := 0; 4658 if Back_End_Inlining then 4659 while J <= Called_Pending_Instantiations.Last 4660 and then Serious_Errors_Detected = 0 4661 loop 4662 K := Called_Pending_Instantiations.Table (J); 4663 Info := Pending_Instantiations.Table (K); 4664 Instantiate_Body (Info); 4665 4666 J := J + 1; 4667 end loop; 4668 4669 else 4670 while J <= Pending_Instantiations.Last 4671 and then Serious_Errors_Detected = 0 4672 loop 4673 Info := Pending_Instantiations.Table (J); 4674 Instantiate_Body (Info); 4675 4676 J := J + 1; 4677 end loop; 4678 end if; 4679 4680 -- Reset the table of instantiations. Additional instantiations 4681 -- may be added through inlining, when additional bodies are 4682 -- analyzed. 4683 4684 if Back_End_Inlining then 4685 Called_Pending_Instantiations.Init; 4686 else 4687 Pending_Instantiations.Init; 4688 end if; 4689 4690 -- We can now complete the cleanup actions of scopes that contain 4691 -- pending instantiations (skipped for generic units, since we 4692 -- never need any cleanups in generic units). 4693 4694 if Expander_Active 4695 and then not Is_Generic_Unit (Main_Unit_Entity) 4696 then 4697 Cleanup_Scopes; 4698 elsif Is_Generic_Unit (Cunit_Entity (Main_Unit)) then 4699 End_Generic; 4700 end if; 4701 4702 Pop_Scope; 4703 end if; 4704 end Instantiate_Bodies; 4705 4706 --------------- 4707 -- Is_Nested -- 4708 --------------- 4709 4710 function Is_Nested (E : Entity_Id) return Boolean is 4711 Scop : Entity_Id; 4712 4713 begin 4714 Scop := Scope (E); 4715 while Scop /= Standard_Standard loop 4716 if Is_Subprogram (Scop) then 4717 return True; 4718 4719 elsif Ekind (Scop) = E_Task_Type 4720 or else Ekind (Scop) = E_Entry 4721 or else Ekind (Scop) = E_Entry_Family 4722 then 4723 return True; 4724 end if; 4725 4726 Scop := Scope (Scop); 4727 end loop; 4728 4729 return False; 4730 end Is_Nested; 4731 4732 ------------------------ 4733 -- List_Inlining_Info -- 4734 ------------------------ 4735 4736 procedure List_Inlining_Info is 4737 Elmt : Elmt_Id; 4738 Nod : Node_Id; 4739 Count : Nat; 4740 4741 begin 4742 if not Debug_Flag_Dot_J then 4743 return; 4744 end if; 4745 4746 -- Generate listing of calls inlined by the frontend 4747 4748 if Present (Inlined_Calls) then 4749 Count := 0; 4750 Elmt := First_Elmt (Inlined_Calls); 4751 while Present (Elmt) loop 4752 Nod := Node (Elmt); 4753 4754 if not In_Internal_Unit (Nod) then 4755 Count := Count + 1; 4756 4757 if Count = 1 then 4758 Write_Str ("List of calls inlined by the frontend"); 4759 Write_Eol; 4760 end if; 4761 4762 Write_Str (" "); 4763 Write_Int (Count); 4764 Write_Str (":"); 4765 Write_Location (Sloc (Nod)); 4766 Write_Str (":"); 4767 Output.Write_Eol; 4768 end if; 4769 4770 Next_Elmt (Elmt); 4771 end loop; 4772 end if; 4773 4774 -- Generate listing of calls passed to the backend 4775 4776 if Present (Backend_Calls) then 4777 Count := 0; 4778 4779 Elmt := First_Elmt (Backend_Calls); 4780 while Present (Elmt) loop 4781 Nod := Node (Elmt); 4782 4783 if not In_Internal_Unit (Nod) then 4784 Count := Count + 1; 4785 4786 if Count = 1 then 4787 Write_Str ("List of inlined calls passed to the backend"); 4788 Write_Eol; 4789 end if; 4790 4791 Write_Str (" "); 4792 Write_Int (Count); 4793 Write_Str (":"); 4794 Write_Location (Sloc (Nod)); 4795 Output.Write_Eol; 4796 end if; 4797 4798 Next_Elmt (Elmt); 4799 end loop; 4800 end if; 4801 4802 -- Generate listing of instances inlined for the backend 4803 4804 if Present (Backend_Instances) then 4805 Count := 0; 4806 4807 Elmt := First_Elmt (Backend_Instances); 4808 while Present (Elmt) loop 4809 Nod := Node (Elmt); 4810 4811 if not In_Internal_Unit (Nod) then 4812 Count := Count + 1; 4813 4814 if Count = 1 then 4815 Write_Str ("List of instances inlined for the backend"); 4816 Write_Eol; 4817 end if; 4818 4819 Write_Str (" "); 4820 Write_Int (Count); 4821 Write_Str (":"); 4822 Write_Location (Sloc (Nod)); 4823 Output.Write_Eol; 4824 end if; 4825 4826 Next_Elmt (Elmt); 4827 end loop; 4828 end if; 4829 4830 -- Generate listing of subprograms passed to the backend 4831 4832 if Present (Backend_Inlined_Subps) and then Back_End_Inlining then 4833 Count := 0; 4834 4835 Elmt := First_Elmt (Backend_Inlined_Subps); 4836 while Present (Elmt) loop 4837 Nod := Node (Elmt); 4838 4839 if not In_Internal_Unit (Nod) then 4840 Count := Count + 1; 4841 4842 if Count = 1 then 4843 Write_Str 4844 ("List of inlined subprograms passed to the backend"); 4845 Write_Eol; 4846 end if; 4847 4848 Write_Str (" "); 4849 Write_Int (Count); 4850 Write_Str (":"); 4851 Write_Name (Chars (Nod)); 4852 Write_Str (" ("); 4853 Write_Location (Sloc (Nod)); 4854 Write_Str (")"); 4855 Output.Write_Eol; 4856 end if; 4857 4858 Next_Elmt (Elmt); 4859 end loop; 4860 end if; 4861 4862 -- Generate listing of subprograms that cannot be inlined by the backend 4863 4864 if Present (Backend_Not_Inlined_Subps) and then Back_End_Inlining then 4865 Count := 0; 4866 4867 Elmt := First_Elmt (Backend_Not_Inlined_Subps); 4868 while Present (Elmt) loop 4869 Nod := Node (Elmt); 4870 4871 if not In_Internal_Unit (Nod) then 4872 Count := Count + 1; 4873 4874 if Count = 1 then 4875 Write_Str 4876 ("List of subprograms that cannot be inlined by backend"); 4877 Write_Eol; 4878 end if; 4879 4880 Write_Str (" "); 4881 Write_Int (Count); 4882 Write_Str (":"); 4883 Write_Name (Chars (Nod)); 4884 Write_Str (" ("); 4885 Write_Location (Sloc (Nod)); 4886 Write_Str (")"); 4887 Output.Write_Eol; 4888 end if; 4889 4890 Next_Elmt (Elmt); 4891 end loop; 4892 end if; 4893 end List_Inlining_Info; 4894 4895 ---------- 4896 -- Lock -- 4897 ---------- 4898 4899 procedure Lock is 4900 begin 4901 Pending_Instantiations.Release; 4902 Pending_Instantiations.Locked := True; 4903 Called_Pending_Instantiations.Release; 4904 Called_Pending_Instantiations.Locked := True; 4905 Inlined_Bodies.Release; 4906 Inlined_Bodies.Locked := True; 4907 Successors.Release; 4908 Successors.Locked := True; 4909 Inlined.Release; 4910 Inlined.Locked := True; 4911 end Lock; 4912 4913 -------------------------------- 4914 -- Remove_Aspects_And_Pragmas -- 4915 -------------------------------- 4916 4917 procedure Remove_Aspects_And_Pragmas (Body_Decl : Node_Id) is 4918 procedure Remove_Items (List : List_Id); 4919 -- Remove all useless aspects/pragmas from a particular list 4920 4921 ------------------ 4922 -- Remove_Items -- 4923 ------------------ 4924 4925 procedure Remove_Items (List : List_Id) is 4926 Item : Node_Id; 4927 Item_Id : Node_Id; 4928 Next_Item : Node_Id; 4929 4930 begin 4931 -- Traverse the list looking for an aspect specification or a pragma 4932 4933 Item := First (List); 4934 while Present (Item) loop 4935 Next_Item := Next (Item); 4936 4937 if Nkind (Item) = N_Aspect_Specification then 4938 Item_Id := Identifier (Item); 4939 elsif Nkind (Item) = N_Pragma then 4940 Item_Id := Pragma_Identifier (Item); 4941 else 4942 Item_Id := Empty; 4943 end if; 4944 4945 if Present (Item_Id) 4946 and then Nam_In (Chars (Item_Id), Name_Contract_Cases, 4947 Name_Global, 4948 Name_Depends, 4949 Name_Postcondition, 4950 Name_Precondition, 4951 Name_Refined_Global, 4952 Name_Refined_Depends, 4953 Name_Refined_Post, 4954 Name_Test_Case, 4955 Name_Unmodified, 4956 Name_Unreferenced, 4957 Name_Unused) 4958 then 4959 Remove (Item); 4960 end if; 4961 4962 Item := Next_Item; 4963 end loop; 4964 end Remove_Items; 4965 4966 -- Start of processing for Remove_Aspects_And_Pragmas 4967 4968 begin 4969 Remove_Items (Aspect_Specifications (Body_Decl)); 4970 Remove_Items (Declarations (Body_Decl)); 4971 4972 -- Pragmas Unmodified, Unreferenced, and Unused may additionally appear 4973 -- in the body of the subprogram. 4974 4975 Remove_Items (Statements (Handled_Statement_Sequence (Body_Decl))); 4976 end Remove_Aspects_And_Pragmas; 4977 4978 -------------------------- 4979 -- Remove_Dead_Instance -- 4980 -------------------------- 4981 4982 procedure Remove_Dead_Instance (N : Node_Id) is 4983 J : Int; 4984 4985 begin 4986 J := 0; 4987 while J <= Pending_Instantiations.Last loop 4988 if Pending_Instantiations.Table (J).Inst_Node = N then 4989 Pending_Instantiations.Table (J).Inst_Node := Empty; 4990 return; 4991 end if; 4992 4993 J := J + 1; 4994 end loop; 4995 end Remove_Dead_Instance; 4996 4997end Inline; 4998