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