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