1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- E X P _ C G -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 2010-2021, Free Software Foundation, Inc. -- 10-- -- 11-- GNAT is free software; you can redistribute it and/or modify it under -- 12-- terms of the GNU General Public License as published by the Free Soft- -- 13-- ware Foundation; either version 3, or (at your option) any later ver- -- 14-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 15-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 16-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- 17-- for more details. You should have received a copy of the GNU General -- 18-- Public License distributed with GNAT; see file COPYING3. If not, go to -- 19-- http://www.gnu.org/licenses for a complete copy of the license. -- 20-- -- 21-- GNAT was originally developed by the GNAT team at New York University. -- 22-- Extensive contributions were provided by Ada Core Technologies Inc. -- 23-- -- 24------------------------------------------------------------------------------ 25 26with Atree; use Atree; 27with Einfo; use Einfo; 28with Einfo.Entities; use Einfo.Entities; 29with Einfo.Utils; use Einfo.Utils; 30with Elists; use Elists; 31with Exp_Dbug; use Exp_Dbug; 32with Exp_Tss; use Exp_Tss; 33with Lib; use Lib; 34with Namet; use Namet; 35with Opt; use Opt; 36with Output; use Output; 37with Sem_Aux; use Sem_Aux; 38with Sem_Disp; use Sem_Disp; 39with Sem_Type; use Sem_Type; 40with Sem_Util; use Sem_Util; 41with Sinfo; use Sinfo; 42with Sinfo.Nodes; use Sinfo.Nodes; 43with Sinfo.Utils; use Sinfo.Utils; 44with Sinput; use Sinput; 45with Snames; use Snames; 46with System; use System; 47with Table; 48with Uintp; use Uintp; 49 50package body Exp_CG is 51 52 -- We duplicate here some declarations from packages Interfaces.C and 53 -- Interfaces.C_Streams because adding their dependence to the frontend 54 -- causes bootstrapping problems with old versions of the compiler. 55 56 subtype FILEs is System.Address; 57 -- Corresponds to the C type FILE* 58 59 subtype C_chars is System.Address; 60 -- Pointer to null-terminated array of characters 61 62 function fputs (Strng : C_chars; Stream : FILEs) return Integer; 63 pragma Import (C, fputs, "fputs"); 64 65 -- Import the file stream associated with the "ci" output file. Done to 66 -- generate the output in the file created and left opened by routine 67 -- toplev.c before calling gnat1drv. 68 69 Callgraph_Info_File : FILEs; 70 pragma Import (C, Callgraph_Info_File); 71 72 package Call_Graph_Nodes is new Table.Table ( 73 Table_Component_Type => Node_Id, 74 Table_Index_Type => Natural, 75 Table_Low_Bound => 1, 76 Table_Initial => 50, 77 Table_Increment => 100, 78 Table_Name => "Call_Graph_Nodes"); 79 -- This table records nodes associated with dispatching calls and tagged 80 -- type declarations found in the main compilation unit. Used as an 81 -- auxiliary storage because the call-graph output requires fully qualified 82 -- names and they are not available until the backend is called. 83 84 function Is_Predefined_Dispatching_Operation (E : Entity_Id) return Boolean; 85 -- Determines if E is a predefined primitive operation. 86 -- Note: This routine should replace the routine with the same name that is 87 -- currently available in exp_disp because it extends its functionality to 88 -- handle fully qualified names. It's actually in Sem_Util. ??? 89 90 function Slot_Number (Prim : Entity_Id) return Uint; 91 -- Returns the slot number associated with Prim. For predefined primitives 92 -- the slot is returned as a negative number. 93 94 procedure Write_Output (Str : String); 95 -- Used to print a line in the output file (this is used as the 96 -- argument for a call to Set_Special_Output in package Output). 97 98 procedure Write_Call_Info (Call : Node_Id); 99 -- Subsidiary of Generate_CG_Output that generates the output associated 100 -- with a dispatching call. 101 102 procedure Write_Type_Info (Typ : Entity_Id); 103 -- Subsidiary of Generate_CG_Output that generates the output associated 104 -- with a tagged type declaration. 105 106 ------------------------ 107 -- Generate_CG_Output -- 108 ------------------------ 109 110 procedure Generate_CG_Output is 111 N : Node_Id; 112 113 begin 114 -- No output if the "ci" output file has not been previously opened 115 -- by toplev.c 116 117 if Callgraph_Info_File = Null_Address then 118 return; 119 end if; 120 121 -- Setup write routine, create the output file and generate the output 122 123 Set_Special_Output (Write_Output'Access); 124 125 for J in Call_Graph_Nodes.First .. Call_Graph_Nodes.Last loop 126 N := Call_Graph_Nodes.Table (J); 127 128 -- No action needed for subprogram calls removed by the expander 129 -- (for example, calls to ignored ghost entities). 130 131 if Nkind (N) = N_Null_Statement then 132 pragma Assert (Nkind (Original_Node (N)) in N_Subprogram_Call); 133 null; 134 135 elsif Nkind (N) in N_Subprogram_Call then 136 Write_Call_Info (N); 137 138 else pragma Assert (Nkind (N) = N_Defining_Identifier); 139 140 -- The type may be a private untagged type whose completion is 141 -- tagged, in which case we must use the full tagged view. 142 143 if not Is_Tagged_Type (N) and then Is_Private_Type (N) then 144 N := Full_View (N); 145 end if; 146 147 pragma Assert (Is_Tagged_Type (N)); 148 149 Write_Type_Info (N); 150 end if; 151 end loop; 152 153 Cancel_Special_Output; 154 end Generate_CG_Output; 155 156 ---------------- 157 -- Initialize -- 158 ---------------- 159 160 procedure Initialize is 161 begin 162 Call_Graph_Nodes.Init; 163 end Initialize; 164 165 ----------------------------------------- 166 -- Is_Predefined_Dispatching_Operation -- 167 ----------------------------------------- 168 169 function Is_Predefined_Dispatching_Operation 170 (E : Entity_Id) return Boolean 171 is 172 function Homonym_Suffix_Length (E : Entity_Id) return Natural; 173 -- Returns the length of the homonym suffix corresponding to E. 174 -- Note: This routine relies on the functionality provided by routines 175 -- of Exp_Dbug. Further work needed here to decide if it should be 176 -- located in that package??? 177 178 --------------------------- 179 -- Homonym_Suffix_Length -- 180 --------------------------- 181 182 function Homonym_Suffix_Length (E : Entity_Id) return Natural is 183 Prefix_Length : constant := 2; 184 -- Length of prefix "__" 185 186 H : Entity_Id; 187 Nr : Nat := 1; 188 189 begin 190 if not Has_Homonym (E) then 191 return 0; 192 193 else 194 H := Homonym (E); 195 while Present (H) loop 196 if Scope (H) = Scope (E) then 197 Nr := Nr + 1; 198 end if; 199 200 H := Homonym (H); 201 end loop; 202 203 if Nr = 1 then 204 return 0; 205 206 -- Prefix "__" followed by number 207 208 else 209 declare 210 Result : Natural := Prefix_Length + 1; 211 212 begin 213 while Nr >= 10 loop 214 Result := Result + 1; 215 Nr := Nr / 10; 216 end loop; 217 218 return Result; 219 end; 220 end if; 221 end if; 222 end Homonym_Suffix_Length; 223 224 -- Local variables 225 226 Full_Name : constant String := Get_Name_String (Chars (E)); 227 Suffix_Length : Natural; 228 TSS_Name : TSS_Name_Type; 229 230 -- Start of processing for Is_Predefined_Dispatching_Operation 231 232 begin 233 if not Is_Dispatching_Operation (E) then 234 return False; 235 end if; 236 237 -- Search for and strip suffix for body-nested package entities 238 239 Suffix_Length := Homonym_Suffix_Length (E); 240 for J in reverse Full_Name'First + 2 .. Full_Name'Last loop 241 if Full_Name (J) = 'X' then 242 243 -- Include the "X", "Xb", "Xn", ... in the part of the 244 -- suffix to be removed. 245 246 Suffix_Length := Suffix_Length + Full_Name'Last - J + 1; 247 exit; 248 end if; 249 250 exit when Full_Name (J) /= 'b' and then Full_Name (J) /= 'n'; 251 end loop; 252 253 -- Most predefined primitives have internally generated names. Equality 254 -- must be treated differently; the predefined operation is recognized 255 -- as a homogeneous binary operator that returns Boolean. 256 257 if Full_Name'Length > TSS_Name_Type'Length then 258 TSS_Name := 259 TSS_Name_Type 260 (Full_Name 261 (Full_Name'Last - TSS_Name'Length - Suffix_Length + 1 262 .. Full_Name'Last - Suffix_Length)); 263 264 if TSS_Name = TSS_Stream_Read 265 or else TSS_Name = TSS_Stream_Write 266 or else TSS_Name = TSS_Stream_Input 267 or else TSS_Name = TSS_Stream_Output 268 or else TSS_Name = TSS_Put_Image 269 or else TSS_Name = TSS_Deep_Adjust 270 or else TSS_Name = TSS_Deep_Finalize 271 then 272 return True; 273 274 elsif not Has_Fully_Qualified_Name (E) then 275 if Chars (E) in Name_uSize | Name_uAlignment | Name_uAssign 276 or else 277 (Chars (E) = Name_Op_Eq 278 and then Etype (First_Formal (E)) = Etype (Last_Formal (E))) 279 or else Is_Predefined_Interface_Primitive (E) 280 then 281 return True; 282 end if; 283 284 -- Handle fully qualified names 285 286 else 287 declare 288 type Names_Table is array (Positive range <>) of Name_Id; 289 290 Predef_Names_95 : constant Names_Table := 291 (Name_uSize, 292 Name_uAlignment, 293 Name_Op_Eq, 294 Name_uAssign); 295 296 Predef_Names_05 : constant Names_Table := 297 (Name_uDisp_Asynchronous_Select, 298 Name_uDisp_Conditional_Select, 299 Name_uDisp_Get_Prim_Op_Kind, 300 Name_uDisp_Get_Task_Id, 301 Name_uDisp_Requeue, 302 Name_uDisp_Timed_Select); 303 304 begin 305 for J in Predef_Names_95'Range loop 306 Get_Name_String (Predef_Names_95 (J)); 307 308 -- The predefined primitive operations are identified by the 309 -- names "_size", "_alignment", etc. If we try a pattern 310 -- matching against this string, we can wrongly match other 311 -- primitive operations like "get_size". To avoid this, we 312 -- add the "__" scope separator, which can only prepend 313 -- predefined primitive operations because other primitive 314 -- operations can neither start with an underline nor 315 -- contain two consecutive underlines in its name. 316 317 if Full_Name'Last - Suffix_Length > Name_Len + 2 318 and then 319 Full_Name 320 (Full_Name'Last - Name_Len - 2 - Suffix_Length + 1 321 .. Full_Name'Last - Suffix_Length) = 322 "__" & Name_Buffer (1 .. Name_Len) 323 then 324 -- For the equality operator the type of the two operands 325 -- must also match. 326 327 return Predef_Names_95 (J) /= Name_Op_Eq 328 or else 329 Etype (First_Formal (E)) = Etype (Last_Formal (E)); 330 end if; 331 end loop; 332 333 if Ada_Version >= Ada_2005 then 334 for J in Predef_Names_05'Range loop 335 Get_Name_String (Predef_Names_05 (J)); 336 337 if Full_Name'Last - Suffix_Length > Name_Len + 2 338 and then 339 Full_Name 340 (Full_Name'Last - Name_Len - 2 - Suffix_Length + 1 341 .. Full_Name'Last - Suffix_Length) = 342 "__" & Name_Buffer (1 .. Name_Len) 343 then 344 return True; 345 end if; 346 end loop; 347 end if; 348 end; 349 end if; 350 end if; 351 352 return False; 353 end Is_Predefined_Dispatching_Operation; 354 355 ---------------------- 356 -- Register_CG_Node -- 357 ---------------------- 358 359 procedure Register_CG_Node (N : Node_Id) is 360 begin 361 if Nkind (N) in N_Subprogram_Call then 362 if Current_Scope = Main_Unit_Entity 363 or else Entity_Is_In_Main_Unit (Current_Scope) 364 then 365 -- Register a copy of the dispatching call node. Needed since the 366 -- node containing a dispatching call is rewritten by the 367 -- expander. 368 369 declare 370 Copy : constant Node_Id := New_Copy (N); 371 Par : Node_Id; 372 373 begin 374 -- Determine the enclosing scope to use when generating the 375 -- call graph. This must be done now to avoid problems with 376 -- control structures that may be rewritten during expansion. 377 378 Par := Parent (N); 379 while Nkind (Par) /= N_Subprogram_Body 380 and then Nkind (Parent (Par)) /= N_Compilation_Unit 381 loop 382 Par := Parent (Par); 383 384 -- Par can legitimately be empty inside a class-wide 385 -- precondition; the "real" call will be found inside the 386 -- generated pragma. 387 388 if No (Par) then 389 return; 390 end if; 391 end loop; 392 393 Set_Parent (Copy, Par); 394 Call_Graph_Nodes.Append (Copy); 395 end; 396 end if; 397 398 else pragma Assert (Nkind (N) = N_Defining_Identifier); 399 if Entity_Is_In_Main_Unit (N) then 400 Call_Graph_Nodes.Append (N); 401 end if; 402 end if; 403 end Register_CG_Node; 404 405 ----------------- 406 -- Slot_Number -- 407 ----------------- 408 409 function Slot_Number (Prim : Entity_Id) return Uint is 410 E : constant Entity_Id := Ultimate_Alias (Prim); 411 begin 412 if Is_Predefined_Dispatching_Operation (E) then 413 return -DT_Position (E); 414 else 415 return DT_Position (E); 416 end if; 417 end Slot_Number; 418 419 ------------------ 420 -- Write_Output -- 421 ------------------ 422 423 procedure Write_Output (Str : String) is 424 Nul : constant Character := Character'First; 425 Line : String (Str'First .. Str'Last + 1); 426 Errno : Integer; 427 428 begin 429 -- Add the null character to the string as required by fputs 430 431 Line := Str & Nul; 432 Errno := fputs (Line'Address, Callgraph_Info_File); 433 pragma Assert (Errno >= 0); 434 end Write_Output; 435 436 --------------------- 437 -- Write_Call_Info -- 438 --------------------- 439 440 procedure Write_Call_Info (Call : Node_Id) is 441 Ctrl_Arg : constant Node_Id := Controlling_Argument (Call); 442 Ctrl_Typ : constant Entity_Id := Base_Type (Etype (Ctrl_Arg)); 443 Prim : constant Entity_Id := Entity (Sinfo.Nodes.Name (Call)); 444 P : constant Node_Id := Parent (Call); 445 446 begin 447 Write_Str ("edge: { sourcename: "); 448 Write_Char ('"'); 449 450 -- The parent node is the construct that contains the call: subprogram 451 -- body or library-level package. Display the qualified name of the 452 -- entity of the construct. For a subprogram, it is the entity of the 453 -- spec, which carries a homonym counter when it is overloaded. 454 455 if Nkind (P) = N_Subprogram_Body 456 and then not Acts_As_Spec (P) 457 then 458 Get_External_Name (Corresponding_Spec (P)); 459 460 else 461 Get_External_Name (Defining_Entity (P)); 462 end if; 463 464 Write_Str (Name_Buffer (1 .. Name_Len)); 465 466 if Nkind (P) = N_Package_Declaration then 467 Write_Str ("___elabs"); 468 469 elsif Nkind (P) = N_Package_Body then 470 Write_Str ("___elabb"); 471 end if; 472 473 Write_Char ('"'); 474 Write_Eol; 475 476 -- The targetname is a triple: 477 -- N: the index in a vtable used for dispatch 478 -- V: the type who's vtable is used 479 -- S: the static type of the expression 480 481 Write_Str (" targetname: "); 482 Write_Char ('"'); 483 484 pragma Assert (No (Interface_Alias (Prim))); 485 486 -- The check on Is_Ancestor is done here to avoid problems with 487 -- renamings of primitives. For example: 488 489 -- type Root is tagged ... 490 -- procedure Base (Obj : Root); 491 -- procedure Base2 (Obj : Root) renames Base; 492 493 if Present (Alias (Prim)) 494 and then 495 Is_Ancestor 496 (Find_Dispatching_Type (Ultimate_Alias (Prim)), 497 Root_Type (Ctrl_Typ), 498 Use_Full_View => True) 499 then 500 -- This is a special case in which we generate in the ci file the 501 -- slot number of the renaming primitive (i.e. Base2) but instead of 502 -- generating the name of this renaming entity we reference directly 503 -- the renamed entity (i.e. Base). 504 505 Write_Int (UI_To_Int (Slot_Number (Prim))); 506 Write_Char (':'); 507 Write_Name 508 (Chars (Find_Dispatching_Type (Ultimate_Alias (Prim)))); 509 else 510 Write_Int (UI_To_Int (Slot_Number (Prim))); 511 Write_Char (':'); 512 Write_Name (Chars (Root_Type (Ctrl_Typ))); 513 end if; 514 515 Write_Char (','); 516 Write_Name (Chars (Root_Type (Ctrl_Typ))); 517 518 Write_Char ('"'); 519 Write_Eol; 520 521 Write_Str (" label: "); 522 Write_Char ('"'); 523 Write_Location (Sloc (Call)); 524 Write_Char ('"'); 525 Write_Eol; 526 527 Write_Char ('}'); 528 Write_Eol; 529 end Write_Call_Info; 530 531 --------------------- 532 -- Write_Type_Info -- 533 --------------------- 534 535 procedure Write_Type_Info (Typ : Entity_Id) is 536 Elmt : Elmt_Id; 537 Prim : Node_Id; 538 539 Parent_Typ : Entity_Id; 540 Separator_Needed : Boolean := False; 541 542 begin 543 -- Initialize Parent_Typ handling private types 544 545 Parent_Typ := Etype (Typ); 546 547 if Present (Full_View (Parent_Typ)) then 548 Parent_Typ := Full_View (Parent_Typ); 549 end if; 550 551 Write_Str ("class {"); 552 Write_Eol; 553 554 Write_Str (" classname: "); 555 Write_Char ('"'); 556 Write_Name (Chars (Typ)); 557 Write_Char ('"'); 558 Write_Eol; 559 560 Write_Str (" label: "); 561 Write_Char ('"'); 562 Write_Name (Chars (Typ)); 563 Write_Char ('\'); 564 Write_Location (Sloc (Typ)); 565 Write_Char ('"'); 566 Write_Eol; 567 568 if Parent_Typ /= Typ then 569 Write_Str (" parent: "); 570 Write_Char ('"'); 571 Write_Name (Chars (Parent_Typ)); 572 573 -- Note: Einfo.Entities prefix not needed if this routine is moved to 574 -- exp_disp??? 575 576 if Present (Einfo.Entities.Interfaces (Typ)) 577 and then not Is_Empty_Elmt_List (Einfo.Entities.Interfaces (Typ)) 578 then 579 Elmt := First_Elmt (Einfo.Entities.Interfaces (Typ)); 580 while Present (Elmt) loop 581 Write_Str (", "); 582 Write_Name (Chars (Node (Elmt))); 583 Next_Elmt (Elmt); 584 end loop; 585 end if; 586 587 Write_Char ('"'); 588 Write_Eol; 589 end if; 590 591 Write_Str (" virtuals: "); 592 Write_Char ('"'); 593 594 Elmt := First_Elmt (Primitive_Operations (Typ)); 595 while Present (Elmt) loop 596 Prim := Node (Elmt); 597 598 -- Skip internal entities associated with overridden interface 599 -- primitives, and also inherited primitives. 600 601 if Present (Interface_Alias (Prim)) 602 or else 603 (Present (Alias (Prim)) 604 and then Find_Dispatching_Type (Prim) /= 605 Find_Dispatching_Type (Alias (Prim))) 606 then 607 goto Continue; 608 end if; 609 610 -- Do not generate separator for output of first primitive 611 612 if Separator_Needed then 613 Write_Str ("\n"); 614 Write_Eol; 615 Write_Str (" "); 616 else 617 Separator_Needed := True; 618 end if; 619 620 Write_Int (UI_To_Int (Slot_Number (Prim))); 621 Write_Char (':'); 622 623 -- Handle renamed primitives 624 625 if Present (Alias (Prim)) then 626 Write_Name (Chars (Ultimate_Alias (Prim))); 627 else 628 Write_Name (Chars (Prim)); 629 end if; 630 631 -- Display overriding of parent primitives 632 633 if Present (Overridden_Operation (Prim)) 634 and then 635 Is_Ancestor 636 (Find_Dispatching_Type (Overridden_Operation (Prim)), Typ, 637 Use_Full_View => True) 638 then 639 Write_Char (','); 640 Write_Int 641 (UI_To_Int (Slot_Number (Overridden_Operation (Prim)))); 642 Write_Char (':'); 643 Write_Name 644 (Chars (Find_Dispatching_Type (Overridden_Operation (Prim)))); 645 end if; 646 647 -- Display overriding of interface primitives 648 649 if Has_Interfaces (Typ) then 650 declare 651 Prim_Elmt : Elmt_Id; 652 Prim_Op : Node_Id; 653 Int_Alias : Entity_Id; 654 655 begin 656 Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); 657 while Present (Prim_Elmt) loop 658 Prim_Op := Node (Prim_Elmt); 659 Int_Alias := Interface_Alias (Prim_Op); 660 661 if Present (Int_Alias) 662 and then 663 not Is_Ancestor (Find_Dispatching_Type (Int_Alias), Typ, 664 Use_Full_View => True) 665 and then (Alias (Prim_Op)) = Prim 666 then 667 Write_Char (','); 668 Write_Int (UI_To_Int (Slot_Number (Int_Alias))); 669 Write_Char (':'); 670 Write_Name (Chars (Find_Dispatching_Type (Int_Alias))); 671 end if; 672 673 Next_Elmt (Prim_Elmt); 674 end loop; 675 end; 676 end if; 677 678 <<Continue>> 679 Next_Elmt (Elmt); 680 end loop; 681 682 Write_Char ('"'); 683 Write_Eol; 684 685 Write_Char ('}'); 686 Write_Eol; 687 end Write_Type_Info; 688 689end Exp_CG; 690