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