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