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