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             pragma Assert (Is_Tagged_Type (N));
 133
 134             Write_Type_Info (N);
 135          end if;
 136       end loop;
 137
 138       Set_Special_Output (null);
 139    end Generate_CG_Output;
 140
 141    ----------------
 142    -- Initialize --
 143    ----------------
 144
 145    procedure Initialize is
 146    begin
 147       Call_Graph_Nodes.Init;
 148    end Initialize;
 149
 150    -----------------------------------------
 151    -- Is_Predefined_Dispatching_Operation --
 152    -----------------------------------------
 153
 154    function Is_Predefined_Dispatching_Operation
 155      (E : Entity_Id) return Boolean
 156    is
 157       function Homonym_Suffix_Length (E : Entity_Id) return Natural;
 158       --  Returns the length of the homonym suffix corresponding to E.
 159       --  Note: This routine relies on the functionality provided by routines
 160       --  of Exp_Dbug. Further work needed here to decide if it should be
 161       --  located in that package???
 162
 163       ---------------------------
 164       -- Homonym_Suffix_Length --
 165       ---------------------------
 166
 167       function Homonym_Suffix_Length (E : Entity_Id) return Natural is
 168          Prefix_Length : constant := 2; --  Length of prefix "__"
 169
 170          H  : Entity_Id;
 171          Nr : Nat := 1;
 172
 173       begin
 174          if not Has_Homonym (E) then
 175             return 0;
 176
 177          else
 178             H := Homonym (E);
 179             while Present (H) loop
 180                if Scope (H) = Scope (E) then
 181                   Nr := Nr + 1;
 182                end if;
 183
 184                H := Homonym (H);
 185             end loop;
 186
 187             if Nr = 1 then
 188                return 0;
 189
 190             --  Prefix "__" followed by number
 191
 192             else
 193                declare
 194                   Result : Natural := Prefix_Length + 1;
 195                begin
 196                   while Nr > 10 loop
 197                      Result := Result + 1;
 198                      Nr := Nr / 10;
 199                   end loop;
 200                   return Result;
 201                end;
 202             end if;
 203          end if;
 204       end Homonym_Suffix_Length;
 205
 206       --  Local variables
 207
 208       Full_Name : constant String := Get_Name_String (Chars (E));
 209       TSS_Name  : TSS_Name_Type;
 210
 211    --  Start of processing for Is_Predefined_Dispatching_Operation
 212
 213    begin
 214       if not Is_Dispatching_Operation (E) then
 215          return False;
 216       end if;
 217
 218       --  Most predefined primitives have internally generated names. Equality
 219       --  must be treated differently; the predefined operation is recognized
 220       --  as a homogeneous binary operator that returns Boolean.
 221
 222       if Full_Name'Length > TSS_Name_Type'Length then
 223          TSS_Name :=
 224            TSS_Name_Type (Full_Name (Full_Name'Last - TSS_Name'Length + 1
 225                            .. Full_Name'Last));
 226
 227          if        TSS_Name = TSS_Stream_Read
 228            or else TSS_Name = TSS_Stream_Write
 229            or else TSS_Name = TSS_Stream_Input
 230            or else TSS_Name = TSS_Stream_Output
 231            or else TSS_Name = TSS_Deep_Adjust
 232            or else TSS_Name = TSS_Deep_Finalize
 233          then
 234             return True;
 235
 236          elsif not Has_Fully_Qualified_Name (E) then
 237             if        Chars (E) = Name_uSize
 238               or else Chars (E) = Name_uAlignment
 239               or else
 240                 (Chars (E) = Name_Op_Eq
 241                    and then Etype (First_Formal (E)) = Etype (Last_Formal (E)))
 242               or else Chars (E) = Name_uAssign
 243               or else Is_Predefined_Interface_Primitive (E)
 244             then
 245                return True;
 246             end if;
 247
 248          --  Handle fully qualified names
 249
 250          else
 251             declare
 252                type Names_Table is array (Positive range <>) of Name_Id;
 253
 254                Predef_Names_95 : constant Names_Table :=
 255                                    (Name_uSize,
 256                                     Name_uAlignment,
 257                                     Name_Op_Eq,
 258                                     Name_uAssign);
 259
 260                Predef_Names_05 : constant Names_Table :=
 261                                    (Name_uDisp_Asynchronous_Select,
 262                                     Name_uDisp_Conditional_Select,
 263                                     Name_uDisp_Get_Prim_Op_Kind,
 264                                     Name_uDisp_Get_Task_Id,
 265                                     Name_uDisp_Requeue,
 266                                     Name_uDisp_Timed_Select);
 267
 268                Suffix_Length : constant Natural := Homonym_Suffix_Length (E);
 269
 270             begin
 271                for J in Predef_Names_95'Range loop
 272                   Get_Name_String (Predef_Names_95 (J));
 273
 274                   if Full_Name'Last - Suffix_Length > Name_Len
 275                     and then
 276                       Full_Name
 277                         (Full_Name'Last - Name_Len - Suffix_Length + 1
 278                            .. Full_Name'Last - Suffix_Length) =
 279                                                   Name_Buffer (1 .. Name_Len)
 280                   then
 281                      --  For the equality operator the type of the two operands
 282                      --  must also match.
 283
 284                      return Predef_Names_95 (J) /= Name_Op_Eq
 285                        or else
 286                          Etype (First_Formal (E)) = Etype (Last_Formal (E));
 287                   end if;
 288                end loop;
 289
 290                if Ada_Version >= Ada_05 then
 291                   for J in Predef_Names_05'Range loop
 292                      Get_Name_String (Predef_Names_05 (J));
 293
 294                      if Full_Name'Last - Suffix_Length > Name_Len
 295                        and then
 296                          Full_Name
 297                            (Full_Name'Last - Name_Len - Suffix_Length + 1
 298                               .. Full_Name'Last - Suffix_Length) =
 299                                                  Name_Buffer (1 .. Name_Len)
 300                      then
 301                         return True;
 302                      end if;
 303                   end loop;
 304                end if;
 305             end;
 306          end if;
 307       end if;
 308
 309       return False;
 310    end Is_Predefined_Dispatching_Operation;
 311
 312    ----------------------
 313    -- Register_CG_Node --
 314    ----------------------
 315
 316    procedure Register_CG_Node (N : Node_Id) is
 317    begin
 318       if Nkind_In (N, N_Procedure_Call_Statement, N_Function_Call) then
 319          if Current_Scope = Main_Unit_Entity
 320            or else Entity_Is_In_Main_Unit (Current_Scope)
 321          then
 322             --  Register a copy of the dispatching call node. Needed since the
 323             --  node containing a dispatching call is rewriten by the expander.
 324
 325             declare
 326                Copy : constant Node_Id := New_Copy (N);
 327
 328             begin
 329                --  Copy the link to the parent to allow climbing up the tree
 330                --  when the call-graph information is generated
 331
 332                Set_Parent (Copy, Parent (N));
 333                Call_Graph_Nodes.Append (Copy);
 334             end;
 335          end if;
 336
 337       else pragma Assert (Nkind (N) = N_Defining_Identifier);
 338          if Entity_Is_In_Main_Unit (N) then
 339             Call_Graph_Nodes.Append (N);
 340          end if;
 341       end if;
 342    end Register_CG_Node;
 343
 344    -----------------
 345    -- Slot_Number --
 346    -----------------
 347
 348    function Slot_Number (Prim : Entity_Id) return Uint is
 349    begin
 350       if Is_Predefined_Dispatching_Operation (Prim) then
 351          return -DT_Position (Prim);
 352       else
 353          return DT_Position (Prim);
 354       end if;
 355    end Slot_Number;
 356
 357    ------------------
 358    -- Write_Output --
 359    ------------------
 360
 361    procedure Write_Output (Str : String) is
 362       Nul   : constant Character := Character'First;
 363       Line  : String (Str'First .. Str'Last + 1);
 364       Errno : Integer;
 365    begin
 366       --  Add the null character to the string as required by fputs
 367
 368       Line  := Str & Nul;
 369       Errno := fputs (Line'Address, Callgraph_Info_File);
 370       pragma Assert (Errno >= 0);
 371    end Write_Output;
 372
 373    ---------------------
 374    -- Write_Call_Info --
 375    ---------------------
 376
 377    procedure Write_Call_Info (Call : Node_Id) is
 378       Ctrl_Arg : constant Node_Id   := Controlling_Argument (Call);
 379       Ctrl_Typ : constant Entity_Id := Base_Type (Etype (Ctrl_Arg));
 380       Prim     : constant Entity_Id := Entity (Sinfo.Name (Call));
 381       P        : Node_Id;
 382
 383    begin
 384       --  Locate the enclosing context: a subprogram (if available) or the
 385       --  enclosing library-level package
 386
 387       P := Parent (Call);
 388       while Nkind (P) /= N_Subprogram_Body
 389         and then Nkind (Parent (P)) /= N_Compilation_Unit
 390       loop
 391          P := Parent (P);
 392          pragma Assert (Present (P));
 393       end loop;
 394
 395       Write_Str ("edge: { sourcename: ");
 396       Write_Char ('"');
 397       Get_External_Name (Defining_Entity (P), Has_Suffix => False);
 398       Write_Str (Name_Buffer (1 .. Name_Len));
 399
 400       if Nkind (P) = N_Package_Declaration then
 401          Write_Str ("___elabs");
 402
 403       elsif Nkind (P) = N_Package_Body then
 404          Write_Str ("___elabb");
 405       end if;
 406
 407       Write_Char ('"');
 408       Write_Eol;
 409
 410       --  The targetname is a triple:
 411       --     N:  the index in a vtable used for dispatch
 412       --     V:  the type who's vtable is used
 413       --     S:  the static type of the expression
 414
 415       Write_Str  ("  targetname: ");
 416       Write_Char ('"');
 417
 418       pragma Assert (No (Interface_Alias (Prim)));
 419
 420       --  The check on Is_Ancestor is done here to avoid problems with
 421       --  renamings of primitives. For example:
 422
 423       --    type Root is tagged ...
 424       --    procedure Base   (Obj : Root);
 425       --    procedure Base2  (Obj : Root) renames Base;
 426
 427       if Present (Alias (Prim))
 428         and then
 429           Is_Ancestor
 430             (Find_Dispatching_Type (Ultimate_Alias (Prim)),
 431              Root_Type (Ctrl_Typ))
 432       then
 433          Write_Int (UI_To_Int (Slot_Number (Ultimate_Alias (Prim))));
 434          Write_Char (':');
 435          Write_Name
 436            (Chars (Find_Dispatching_Type (Ultimate_Alias (Prim))));
 437       else
 438          Write_Int (UI_To_Int (Slot_Number (Prim)));
 439          Write_Char (':');
 440          Write_Name (Chars (Root_Type (Ctrl_Typ)));
 441       end if;
 442
 443       Write_Char (',');
 444       Write_Name (Chars (Root_Type (Ctrl_Typ)));
 445
 446       Write_Char ('"');
 447       Write_Eol;
 448
 449       Write_Str  ("  label: ");
 450       Write_Char ('"');
 451       Write_Location (Sloc (Call));
 452       Write_Char ('"');
 453       Write_Eol;
 454
 455       Write_Char ('}');
 456       Write_Eol;
 457    end Write_Call_Info;
 458
 459    ---------------------
 460    -- Write_Type_Info --
 461    ---------------------
 462
 463    procedure Write_Type_Info (Typ : Entity_Id) is
 464       Elmt : Elmt_Id;
 465       Prim : Node_Id;
 466
 467       Parent_Typ       : Entity_Id;
 468       Separator_Needed : Boolean := False;
 469
 470    begin
 471       --  Initialize Parent_Typ handling private types
 472
 473       Parent_Typ := Etype (Typ);
 474
 475       if Present (Full_View (Parent_Typ)) then
 476          Parent_Typ := Full_View (Parent_Typ);
 477       end if;
 478
 479       Write_Str ("class {");
 480       Write_Eol;
 481
 482       Write_Str ("  classname: ");
 483       Write_Char ('"');
 484       Write_Name (Chars (Typ));
 485       Write_Char ('"');
 486       Write_Eol;
 487
 488       Write_Str  ("  label: ");
 489       Write_Char ('"');
 490       Write_Name (Chars (Typ));
 491       Write_Char ('\');
 492       Write_Location (Sloc (Typ));
 493       Write_Char ('"');
 494       Write_Eol;
 495
 496       if Parent_Typ /= Typ then
 497          Write_Str  ("  parent: ");
 498          Write_Char ('"');
 499          Write_Name (Chars (Parent_Typ));
 500
 501          --  Note: Einfo prefix not needed if this routine is moved to
 502          --  exp_disp???
 503
 504          if Present (Einfo.Interfaces (Typ))
 505            and then not Is_Empty_Elmt_List (Einfo.Interfaces (Typ))
 506          then
 507             Elmt := First_Elmt (Einfo.Interfaces (Typ));
 508             while Present (Elmt) loop
 509                Write_Str  (", ");
 510                Write_Name (Chars (Node (Elmt)));
 511                Next_Elmt  (Elmt);
 512             end loop;
 513          end if;
 514
 515          Write_Char ('"');
 516          Write_Eol;
 517       end if;
 518
 519       Write_Str ("  virtuals: ");
 520       Write_Char ('"');
 521
 522       Elmt := First_Elmt (Primitive_Operations (Typ));
 523       while Present (Elmt) loop
 524          Prim := Node (Elmt);
 525
 526          --  Display only primitives overriden or defined
 527
 528          if Present (Alias (Prim)) then
 529             goto Continue;
 530          end if;
 531
 532          --  Do not generate separator for output of first primitive
 533
 534          if Separator_Needed then
 535             Write_Str ("\n");
 536             Write_Eol;
 537             Write_Str ("             ");
 538          else
 539             Separator_Needed := True;
 540          end if;
 541
 542          Write_Int (UI_To_Int (Slot_Number (Prim)));
 543          Write_Char (':');
 544          Write_Name (Chars (Prim));
 545
 546          --  Display overriding of parent primitives
 547
 548          if Present (Overridden_Operation (Prim))
 549            and then
 550              Is_Ancestor
 551                (Find_Dispatching_Type (Overridden_Operation (Prim)), Typ)
 552          then
 553             Write_Char (',');
 554             Write_Int
 555               (UI_To_Int (Slot_Number (Overridden_Operation (Prim))));
 556             Write_Char (':');
 557             Write_Name
 558               (Chars (Find_Dispatching_Type (Overridden_Operation (Prim))));
 559          end if;
 560
 561          --  Display overriding of interface primitives
 562
 563          if Has_Interfaces (Typ) then
 564             declare
 565                Prim_Elmt : Elmt_Id;
 566                Prim_Op   : Node_Id;
 567                Int_Alias : Entity_Id;
 568
 569             begin
 570                Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
 571                while Present (Prim_Elmt) loop
 572                   Prim_Op := Node (Prim_Elmt);
 573                   Int_Alias := Interface_Alias (Prim_Op);
 574
 575                   if Present (Int_Alias)
 576                     and then not Is_Ancestor
 577                                    (Find_Dispatching_Type (Int_Alias), Typ)
 578                     and then (Alias (Prim_Op)) = Prim
 579                   then
 580                      Write_Char (',');
 581                      Write_Int (UI_To_Int (Slot_Number (Int_Alias)));
 582                      Write_Char (':');
 583                      Write_Name (Chars (Find_Dispatching_Type (Int_Alias)));
 584                   end if;
 585
 586                   Next_Elmt (Prim_Elmt);
 587                end loop;
 588             end;
 589          end if;
 590
 591          <<Continue>>
 592          Next_Elmt (Elmt);
 593       end loop;
 594
 595       Write_Char ('"');
 596       Write_Eol;
 597
 598       Write_Char ('}');
 599       Write_Eol;
 600    end Write_Type_Info;
 601
 602 end Exp_CG;