1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- E X P _ C G -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 2010-2019, Free Software Foundation, Inc. -- 10-- -- 11-- GNAT is free software; you can redistribute it and/or modify it under -- 12-- terms of the GNU General Public License as published by the Free Soft- -- 13-- ware Foundation; either version 3, or (at your option) any later ver- -- 14-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 15-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 16-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- 17-- for more details. You should have received a copy of the GNU General -- 18-- Public License distributed with GNAT; see file COPYING3. If not, go to -- 19-- http://www.gnu.org/licenses for a complete copy of the license. -- 20-- -- 21-- GNAT was originally developed by the GNAT team at New York University. -- 22-- Extensive contributions were provided by Ada Core Technologies Inc. -- 23-- -- 24------------------------------------------------------------------------------ 25 26with Atree; use Atree; 27with 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 ??? 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_Deep_Adjust 265 or else TSS_Name = TSS_Deep_Finalize 266 then 267 return True; 268 269 elsif not Has_Fully_Qualified_Name (E) then 270 if Nam_In (Chars (E), Name_uSize, Name_uAlignment, Name_uAssign) 271 or else 272 (Chars (E) = Name_Op_Eq 273 and then Etype (First_Formal (E)) = Etype (Last_Formal (E))) 274 or else Is_Predefined_Interface_Primitive (E) 275 then 276 return True; 277 end if; 278 279 -- Handle fully qualified names 280 281 else 282 declare 283 type Names_Table is array (Positive range <>) of Name_Id; 284 285 Predef_Names_95 : constant Names_Table := 286 (Name_uSize, 287 Name_uAlignment, 288 Name_Op_Eq, 289 Name_uAssign); 290 291 Predef_Names_05 : constant Names_Table := 292 (Name_uDisp_Asynchronous_Select, 293 Name_uDisp_Conditional_Select, 294 Name_uDisp_Get_Prim_Op_Kind, 295 Name_uDisp_Get_Task_Id, 296 Name_uDisp_Requeue, 297 Name_uDisp_Timed_Select); 298 299 begin 300 for J in Predef_Names_95'Range loop 301 Get_Name_String (Predef_Names_95 (J)); 302 303 -- The predefined primitive operations are identified by the 304 -- names "_size", "_alignment", etc. If we try a pattern 305 -- matching against this string, we can wrongly match other 306 -- primitive operations like "get_size". To avoid this, we 307 -- add the "__" scope separator, which can only prepend 308 -- predefined primitive operations because other primitive 309 -- operations can neither start with an underline nor 310 -- contain two consecutive underlines in its name. 311 312 if Full_Name'Last - Suffix_Length > Name_Len + 2 313 and then 314 Full_Name 315 (Full_Name'Last - Name_Len - 2 - Suffix_Length + 1 316 .. Full_Name'Last - Suffix_Length) = 317 "__" & Name_Buffer (1 .. Name_Len) 318 then 319 -- For the equality operator the type of the two operands 320 -- must also match. 321 322 return Predef_Names_95 (J) /= Name_Op_Eq 323 or else 324 Etype (First_Formal (E)) = Etype (Last_Formal (E)); 325 end if; 326 end loop; 327 328 if Ada_Version >= Ada_2005 then 329 for J in Predef_Names_05'Range loop 330 Get_Name_String (Predef_Names_05 (J)); 331 332 if Full_Name'Last - Suffix_Length > Name_Len + 2 333 and then 334 Full_Name 335 (Full_Name'Last - Name_Len - 2 - Suffix_Length + 1 336 .. Full_Name'Last - Suffix_Length) = 337 "__" & Name_Buffer (1 .. Name_Len) 338 then 339 return True; 340 end if; 341 end loop; 342 end if; 343 end; 344 end if; 345 end if; 346 347 return False; 348 end Is_Predefined_Dispatching_Operation; 349 350 ---------------------- 351 -- Register_CG_Node -- 352 ---------------------- 353 354 procedure Register_CG_Node (N : Node_Id) is 355 begin 356 if Nkind (N) in N_Subprogram_Call then 357 if Current_Scope = Main_Unit_Entity 358 or else Entity_Is_In_Main_Unit (Current_Scope) 359 then 360 -- Register a copy of the dispatching call node. Needed since the 361 -- node containing a dispatching call is rewritten by the 362 -- expander. 363 364 declare 365 Copy : constant Node_Id := New_Copy (N); 366 Par : Node_Id; 367 368 begin 369 -- Determine the enclosing scope to use when generating the 370 -- call graph. This must be done now to avoid problems with 371 -- control structures that may be rewritten during expansion. 372 373 Par := Parent (N); 374 while Nkind (Par) /= N_Subprogram_Body 375 and then Nkind (Parent (Par)) /= N_Compilation_Unit 376 loop 377 Par := Parent (Par); 378 pragma Assert (Present (Par)); 379 end loop; 380 381 Set_Parent (Copy, Par); 382 Call_Graph_Nodes.Append (Copy); 383 end; 384 end if; 385 386 else pragma Assert (Nkind (N) = N_Defining_Identifier); 387 if Entity_Is_In_Main_Unit (N) then 388 Call_Graph_Nodes.Append (N); 389 end if; 390 end if; 391 end Register_CG_Node; 392 393 ----------------- 394 -- Slot_Number -- 395 ----------------- 396 397 function Slot_Number (Prim : Entity_Id) return Uint is 398 E : constant Entity_Id := Ultimate_Alias (Prim); 399 begin 400 if Is_Predefined_Dispatching_Operation (E) then 401 return -DT_Position (E); 402 else 403 return DT_Position (E); 404 end if; 405 end Slot_Number; 406 407 ------------------ 408 -- Write_Output -- 409 ------------------ 410 411 procedure Write_Output (Str : String) is 412 Nul : constant Character := Character'First; 413 Line : String (Str'First .. Str'Last + 1); 414 Errno : Integer; 415 416 begin 417 -- Add the null character to the string as required by fputs 418 419 Line := Str & Nul; 420 Errno := fputs (Line'Address, Callgraph_Info_File); 421 pragma Assert (Errno >= 0); 422 end Write_Output; 423 424 --------------------- 425 -- Write_Call_Info -- 426 --------------------- 427 428 procedure Write_Call_Info (Call : Node_Id) is 429 Ctrl_Arg : constant Node_Id := Controlling_Argument (Call); 430 Ctrl_Typ : constant Entity_Id := Base_Type (Etype (Ctrl_Arg)); 431 Prim : constant Entity_Id := Entity (Sinfo.Name (Call)); 432 P : constant Node_Id := Parent (Call); 433 434 begin 435 Write_Str ("edge: { sourcename: "); 436 Write_Char ('"'); 437 438 -- The parent node is the construct that contains the call: subprogram 439 -- body or library-level package. Display the qualified name of the 440 -- entity of the construct. For a subprogram, it is the entity of the 441 -- spec, which carries a homonym counter when it is overloaded. 442 443 if Nkind (P) = N_Subprogram_Body 444 and then not Acts_As_Spec (P) 445 then 446 Get_External_Name (Corresponding_Spec (P)); 447 448 else 449 Get_External_Name (Defining_Entity (P)); 450 end if; 451 452 Write_Str (Name_Buffer (1 .. Name_Len)); 453 454 if Nkind (P) = N_Package_Declaration then 455 Write_Str ("___elabs"); 456 457 elsif Nkind (P) = N_Package_Body then 458 Write_Str ("___elabb"); 459 end if; 460 461 Write_Char ('"'); 462 Write_Eol; 463 464 -- The targetname is a triple: 465 -- N: the index in a vtable used for dispatch 466 -- V: the type who's vtable is used 467 -- S: the static type of the expression 468 469 Write_Str (" targetname: "); 470 Write_Char ('"'); 471 472 pragma Assert (No (Interface_Alias (Prim))); 473 474 -- The check on Is_Ancestor is done here to avoid problems with 475 -- renamings of primitives. For example: 476 477 -- type Root is tagged ... 478 -- procedure Base (Obj : Root); 479 -- procedure Base2 (Obj : Root) renames Base; 480 481 if Present (Alias (Prim)) 482 and then 483 Is_Ancestor 484 (Find_Dispatching_Type (Ultimate_Alias (Prim)), 485 Root_Type (Ctrl_Typ), 486 Use_Full_View => True) 487 then 488 -- This is a special case in which we generate in the ci file the 489 -- slot number of the renaming primitive (i.e. Base2) but instead of 490 -- generating the name of this renaming entity we reference directly 491 -- the renamed entity (i.e. Base). 492 493 Write_Int (UI_To_Int (Slot_Number (Prim))); 494 Write_Char (':'); 495 Write_Name 496 (Chars (Find_Dispatching_Type (Ultimate_Alias (Prim)))); 497 else 498 Write_Int (UI_To_Int (Slot_Number (Prim))); 499 Write_Char (':'); 500 Write_Name (Chars (Root_Type (Ctrl_Typ))); 501 end if; 502 503 Write_Char (','); 504 Write_Name (Chars (Root_Type (Ctrl_Typ))); 505 506 Write_Char ('"'); 507 Write_Eol; 508 509 Write_Str (" label: "); 510 Write_Char ('"'); 511 Write_Location (Sloc (Call)); 512 Write_Char ('"'); 513 Write_Eol; 514 515 Write_Char ('}'); 516 Write_Eol; 517 end Write_Call_Info; 518 519 --------------------- 520 -- Write_Type_Info -- 521 --------------------- 522 523 procedure Write_Type_Info (Typ : Entity_Id) is 524 Elmt : Elmt_Id; 525 Prim : Node_Id; 526 527 Parent_Typ : Entity_Id; 528 Separator_Needed : Boolean := False; 529 530 begin 531 -- Initialize Parent_Typ handling private types 532 533 Parent_Typ := Etype (Typ); 534 535 if Present (Full_View (Parent_Typ)) then 536 Parent_Typ := Full_View (Parent_Typ); 537 end if; 538 539 Write_Str ("class {"); 540 Write_Eol; 541 542 Write_Str (" classname: "); 543 Write_Char ('"'); 544 Write_Name (Chars (Typ)); 545 Write_Char ('"'); 546 Write_Eol; 547 548 Write_Str (" label: "); 549 Write_Char ('"'); 550 Write_Name (Chars (Typ)); 551 Write_Char ('\'); 552 Write_Location (Sloc (Typ)); 553 Write_Char ('"'); 554 Write_Eol; 555 556 if Parent_Typ /= Typ then 557 Write_Str (" parent: "); 558 Write_Char ('"'); 559 Write_Name (Chars (Parent_Typ)); 560 561 -- Note: Einfo prefix not needed if this routine is moved to 562 -- exp_disp??? 563 564 if Present (Einfo.Interfaces (Typ)) 565 and then not Is_Empty_Elmt_List (Einfo.Interfaces (Typ)) 566 then 567 Elmt := First_Elmt (Einfo.Interfaces (Typ)); 568 while Present (Elmt) loop 569 Write_Str (", "); 570 Write_Name (Chars (Node (Elmt))); 571 Next_Elmt (Elmt); 572 end loop; 573 end if; 574 575 Write_Char ('"'); 576 Write_Eol; 577 end if; 578 579 Write_Str (" virtuals: "); 580 Write_Char ('"'); 581 582 Elmt := First_Elmt (Primitive_Operations (Typ)); 583 while Present (Elmt) loop 584 Prim := Node (Elmt); 585 586 -- Skip internal entities associated with overridden interface 587 -- primitives, and also inherited primitives. 588 589 if Present (Interface_Alias (Prim)) 590 or else 591 (Present (Alias (Prim)) 592 and then Find_Dispatching_Type (Prim) /= 593 Find_Dispatching_Type (Alias (Prim))) 594 then 595 goto Continue; 596 end if; 597 598 -- Do not generate separator for output of first primitive 599 600 if Separator_Needed then 601 Write_Str ("\n"); 602 Write_Eol; 603 Write_Str (" "); 604 else 605 Separator_Needed := True; 606 end if; 607 608 Write_Int (UI_To_Int (Slot_Number (Prim))); 609 Write_Char (':'); 610 611 -- Handle renamed primitives 612 613 if Present (Alias (Prim)) then 614 Write_Name (Chars (Ultimate_Alias (Prim))); 615 else 616 Write_Name (Chars (Prim)); 617 end if; 618 619 -- Display overriding of parent primitives 620 621 if Present (Overridden_Operation (Prim)) 622 and then 623 Is_Ancestor 624 (Find_Dispatching_Type (Overridden_Operation (Prim)), Typ, 625 Use_Full_View => True) 626 then 627 Write_Char (','); 628 Write_Int 629 (UI_To_Int (Slot_Number (Overridden_Operation (Prim)))); 630 Write_Char (':'); 631 Write_Name 632 (Chars (Find_Dispatching_Type (Overridden_Operation (Prim)))); 633 end if; 634 635 -- Display overriding of interface primitives 636 637 if Has_Interfaces (Typ) then 638 declare 639 Prim_Elmt : Elmt_Id; 640 Prim_Op : Node_Id; 641 Int_Alias : Entity_Id; 642 643 begin 644 Prim_Elmt := First_Elmt (Primitive_Operations (Typ)); 645 while Present (Prim_Elmt) loop 646 Prim_Op := Node (Prim_Elmt); 647 Int_Alias := Interface_Alias (Prim_Op); 648 649 if Present (Int_Alias) 650 and then 651 not Is_Ancestor (Find_Dispatching_Type (Int_Alias), Typ, 652 Use_Full_View => True) 653 and then (Alias (Prim_Op)) = Prim 654 then 655 Write_Char (','); 656 Write_Int (UI_To_Int (Slot_Number (Int_Alias))); 657 Write_Char (':'); 658 Write_Name (Chars (Find_Dispatching_Type (Int_Alias))); 659 end if; 660 661 Next_Elmt (Prim_Elmt); 662 end loop; 663 end; 664 end if; 665 666 <<Continue>> 667 Next_Elmt (Elmt); 668 end loop; 669 670 Write_Char ('"'); 671 Write_Eol; 672 673 Write_Char ('}'); 674 Write_Eol; 675 end Write_Type_Info; 676 677end Exp_CG; 678