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, 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_Disp; use Exp_Disp;
  30 with Exp_Dbug; use Exp_Dbug;
  31 with Exp_Tss;  use Exp_Tss;
  32 with Lib;      use Lib;
  33 with Namet;    use Namet;
  34 with Opt;      use Opt;
  35 with Output;   use Output;
  36 with Sem_Aux;  use Sem_Aux;
  37 with Sem_Disp; use Sem_Disp;
  38 with Sem_Type; use Sem_Type;
  39 with Sem_Util; use Sem_Util;
  40 with Sinfo;    use Sinfo;
  41 with Sinput;   use Sinput;
  42 with Snames;   use Snames;
  43 with System;   use System;
  44 with Table;
  45 with Uintp;    use Uintp;
  46
  47 package 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_In (N, N_Procedure_Call_Statement, N_Function_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_In (N, N_Procedure_Call_Statement, N_Function_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
 673 end Exp_CG;