gcc/ada/exp_cg.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                               E X P _ C G                                --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 2010-2018, 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
  26 with Atree;    use Atree;
  27 with Einfo;    use Einfo;
  28 with Elists;   use Elists;
  29 with Exp_Dbug; use Exp_Dbug;
  30 with Exp_Tss;  use Exp_Tss;
  31 with Lib;      use Lib;
  32 with Namet;    use Namet;
  33 with Opt;      use Opt;
  34 with Output;   use Output;
  35 with Sem_Aux;  use Sem_Aux;
  36 with Sem_Disp; use Sem_Disp;
  37 with Sem_Type; use Sem_Type;
  38 with Sem_Util; use Sem_Util;
  39 with Sinfo;    use Sinfo;
  40 with Sinput;   use Sinput;
  41 with Snames;   use Snames;
  42 with System;   use System;
  43 with Table;
  44 with Uintp;    use Uintp;
  45
  46 package 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
 677 end Exp_CG;