path: root/gcc/ada/exp_cg.adb

------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--                               E X P _ C G                                --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--          Copyright (C) 2010-2018, Free Software Foundation, Inc.         --
--                                                                          --
-- GNAT is free software;  you can  redistribute it  and/or modify it under --
-- terms of the  GNU General Public License as published  by the Free Soft- --
-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
-- for  more details.  You should have  received  a copy of the GNU General --
-- Public License  distributed with GNAT; see file COPYING3.  If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license.          --
--                                                                          --
-- GNAT was originally developed  by the GNAT team at  New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
--                                                                          --
------------------------------------------------------------------------------

with Atree;    use Atree;
with Einfo;    use Einfo;
with Elists;   use Elists;
with Exp_Dbug; use Exp_Dbug;
with Exp_Tss;  use Exp_Tss;
with Lib;      use Lib;
with Namet;    use Namet;
with Opt;      use Opt;
with Output;   use Output;
with Sem_Aux;  use Sem_Aux;
with Sem_Disp; use Sem_Disp;
with Sem_Type; use Sem_Type;
with Sem_Util; use Sem_Util;
with Sinfo;    use Sinfo;
with Sinput;   use Sinput;
with Snames;   use Snames;
with System;   use System;
with Table;
with Uintp;    use Uintp;

package body Exp_CG is

   --  We duplicate here some declarations from packages Interfaces.C and
   --  Interfaces.C_Streams because adding their dependence to the frontend
   --  causes bootstrapping problems with old versions of the compiler.

   subtype FILEs is System.Address;
   --  Corresponds to the C type FILE*

   subtype C_chars is System.Address;
   --  Pointer to null-terminated array of characters

   function fputs (Strng : C_chars; Stream : FILEs) return Integer;
   pragma Import (C, fputs, "fputs");

   --  Import the file stream associated with the "ci" output file. Done to
   --  generate the output in the file created and left opened by routine
   --  toplev.c before calling gnat1drv.

   Callgraph_Info_File : FILEs;
   pragma Import (C, Callgraph_Info_File);

   package Call_Graph_Nodes is new Table.Table (
      Table_Component_Type => Node_Id,
      Table_Index_Type     => Natural,
      Table_Low_Bound      => 1,
      Table_Initial        => 50,
      Table_Increment      => 100,
      Table_Name           => "Call_Graph_Nodes");
   --  This table records nodes associated with dispatching calls and tagged
   --  type declarations found in the main compilation unit. Used as an
   --  auxiliary storage because the call-graph output requires fully qualified
   --  names and they are not available until the backend is called.

   function Is_Predefined_Dispatching_Operation (E : Entity_Id) return Boolean;
   --  Determines if E is a predefined primitive operation.
   --  Note: This routine should replace the routine with the same name that is
   --  currently available in exp_disp because it extends its functionality to
   --  handle fully qualified names ???

   function Slot_Number (Prim : Entity_Id) return Uint;
   --  Returns the slot number associated with Prim. For predefined primitives
   --  the slot is returned as a negative number.

   procedure Write_Output (Str : String);
   --  Used to print a line in the output file (this is used as the
   --  argument for a call to Set_Special_Output in package Output).

   procedure Write_Call_Info (Call : Node_Id);
   --  Subsidiary of Generate_CG_Output that generates the output associated
   --  with a dispatching call.

   procedure Write_Type_Info (Typ : Entity_Id);
   --  Subsidiary of Generate_CG_Output that generates the output associated
   --  with a tagged type declaration.

   ------------------------
   -- Generate_CG_Output --
   ------------------------

   procedure Generate_CG_Output is
      N : Node_Id;

   begin
      --  No output if the "ci" output file has not been previously opened
      --  by toplev.c

      if Callgraph_Info_File = Null_Address then
         return;
      end if;

      --  Setup write routine, create the output file and generate the output

      Set_Special_Output (Write_Output'Access);

      for J in Call_Graph_Nodes.First .. Call_Graph_Nodes.Last loop
         N := Call_Graph_Nodes.Table (J);

         if Nkind (N) in N_Subprogram_Call then
            Write_Call_Info (N);

         else pragma Assert (Nkind (N) = N_Defining_Identifier);

            --  The type may be a private untagged type whose completion is
            --  tagged, in which case we must use the full tagged view.

            if not Is_Tagged_Type (N) and then Is_Private_Type (N) then
               N := Full_View (N);
            end if;

            pragma Assert (Is_Tagged_Type (N));

            Write_Type_Info (N);
         end if;
      end loop;

      Set_Special_Output (null);
   end Generate_CG_Output;

   ----------------
   -- Initialize --
   ----------------

   procedure Initialize is
   begin
      Call_Graph_Nodes.Init;
   end Initialize;

   -----------------------------------------
   -- Is_Predefined_Dispatching_Operation --
   -----------------------------------------

   function Is_Predefined_Dispatching_Operation
     (E : Entity_Id) return Boolean
   is
      function Homonym_Suffix_Length (E : Entity_Id) return Natural;
      --  Returns the length of the homonym suffix corresponding to E.
      --  Note: This routine relies on the functionality provided by routines
      --  of Exp_Dbug. Further work needed here to decide if it should be
      --  located in that package???

      ---------------------------
      -- Homonym_Suffix_Length --
      ---------------------------

      function Homonym_Suffix_Length (E : Entity_Id) return Natural is
         Prefix_Length : constant := 2;
         --  Length of prefix "__"

         H  : Entity_Id;
         Nr : Nat := 1;

      begin
         if not Has_Homonym (E) then
            return 0;

         else
            H := Homonym (E);
            while Present (H) loop
               if Scope (H) = Scope (E) then
                  Nr := Nr + 1;
               end if;

               H := Homonym (H);
            end loop;

            if Nr = 1 then
               return 0;

            --  Prefix "__" followed by number

            else
               declare
                  Result : Natural := Prefix_Length + 1;

               begin
                  while Nr >= 10 loop
                     Result := Result + 1;
                     Nr := Nr / 10;
                  end loop;

                  return Result;
               end;
            end if;
         end if;
      end Homonym_Suffix_Length;

      --  Local variables

      Full_Name     : constant String := Get_Name_String (Chars (E));
      Suffix_Length : Natural;
      TSS_Name      : TSS_Name_Type;

   --  Start of processing for Is_Predefined_Dispatching_Operation

   begin
      if not Is_Dispatching_Operation (E) then
         return False;
      end if;

      --  Search for and strip suffix for body-nested package entities

      Suffix_Length := Homonym_Suffix_Length (E);
      for J in reverse Full_Name'First + 2 .. Full_Name'Last loop
         if Full_Name (J) = 'X' then

            --  Include the "X", "Xb", "Xn", ... in the part of the
            --  suffix to be removed.

            Suffix_Length := Suffix_Length + Full_Name'Last - J + 1;
            exit;
         end if;

         exit when Full_Name (J) /= 'b' and then Full_Name (J) /= 'n';
      end loop;

      --  Most predefined primitives have internally generated names. Equality
      --  must be treated differently; the predefined operation is recognized
      --  as a homogeneous binary operator that returns Boolean.

      if Full_Name'Length > TSS_Name_Type'Length then
         TSS_Name :=
           TSS_Name_Type
             (Full_Name
               (Full_Name'Last - TSS_Name'Length - Suffix_Length + 1
                  .. Full_Name'Last - Suffix_Length));

         if        TSS_Name = TSS_Stream_Read
           or else TSS_Name = TSS_Stream_Write
           or else TSS_Name = TSS_Stream_Input
           or else TSS_Name = TSS_Stream_Output
           or else TSS_Name = TSS_Deep_Adjust
           or else TSS_Name = TSS_Deep_Finalize
         then
            return True;

         elsif not Has_Fully_Qualified_Name (E) then
            if Nam_In (Chars (E), Name_uSize, Name_uAlignment, Name_uAssign)
              or else
                (Chars (E) = Name_Op_Eq
                  and then Etype (First_Formal (E)) = Etype (Last_Formal (E)))
              or else Is_Predefined_Interface_Primitive (E)
            then
               return True;
            end if;

         --  Handle fully qualified names

         else
            declare
               type Names_Table is array (Positive range <>) of Name_Id;

               Predef_Names_95 : constant Names_Table :=
                                   (Name_uSize,
                                    Name_uAlignment,
                                    Name_Op_Eq,
                                    Name_uAssign);

               Predef_Names_05 : constant Names_Table :=
                                   (Name_uDisp_Asynchronous_Select,
                                    Name_uDisp_Conditional_Select,
                                    Name_uDisp_Get_Prim_Op_Kind,
                                    Name_uDisp_Get_Task_Id,
                                    Name_uDisp_Requeue,
                                    Name_uDisp_Timed_Select);

            begin
               for J in Predef_Names_95'Range loop
                  Get_Name_String (Predef_Names_95 (J));

                  --  The predefined primitive operations are identified by the
                  --  names "_size", "_alignment", etc. If we try a pattern
                  --  matching against this string, we can wrongly match other
                  --  primitive operations like "get_size". To avoid this, we
                  --  add the "__" scope separator, which can only prepend
                  --  predefined primitive operations because other primitive
                  --  operations can neither start with an underline nor
                  --  contain two consecutive underlines in its name.

                  if Full_Name'Last - Suffix_Length > Name_Len + 2
                    and then
                      Full_Name
                        (Full_Name'Last - Name_Len - 2 - Suffix_Length + 1
                           .. Full_Name'Last - Suffix_Length) =
                      "__" & Name_Buffer (1 .. Name_Len)
                  then
                     --  For the equality operator the type of the two operands
                     --  must also match.

                     return Predef_Names_95 (J) /= Name_Op_Eq
                       or else
                         Etype (First_Formal (E)) = Etype (Last_Formal (E));
                  end if;
               end loop;

               if Ada_Version >= Ada_2005 then
                  for J in Predef_Names_05'Range loop
                     Get_Name_String (Predef_Names_05 (J));

                     if Full_Name'Last - Suffix_Length > Name_Len + 2
                       and then
                         Full_Name
                           (Full_Name'Last - Name_Len - 2 - Suffix_Length + 1
                              .. Full_Name'Last - Suffix_Length) =
                         "__" & Name_Buffer (1 .. Name_Len)
                     then
                        return True;
                     end if;
                  end loop;
               end if;
            end;
         end if;
      end if;

      return False;
   end Is_Predefined_Dispatching_Operation;

   ----------------------
   -- Register_CG_Node --
   ----------------------

   procedure Register_CG_Node (N : Node_Id) is
   begin
      if Nkind (N) in N_Subprogram_Call then
         if Current_Scope = Main_Unit_Entity
           or else Entity_Is_In_Main_Unit (Current_Scope)
         then
            --  Register a copy of the dispatching call node. Needed since the
            --  node containing a dispatching call is rewritten by the
            --  expander.

            declare
               Copy : constant Node_Id := New_Copy (N);
               Par  : Node_Id;

            begin
               --  Determine the enclosing scope to use when generating the
               --  call graph. This must be done now to avoid problems with
               --  control structures that may be rewritten during expansion.

               Par := Parent (N);
               while Nkind (Par) /= N_Subprogram_Body
                 and then Nkind (Parent (Par)) /= N_Compilation_Unit
               loop
                  Par := Parent (Par);
                  pragma Assert (Present (Par));
               end loop;

               Set_Parent (Copy, Par);
               Call_Graph_Nodes.Append (Copy);
            end;
         end if;

      else pragma Assert (Nkind (N) = N_Defining_Identifier);
         if Entity_Is_In_Main_Unit (N) then
            Call_Graph_Nodes.Append (N);
         end if;
      end if;
   end Register_CG_Node;

   -----------------
   -- Slot_Number --
   -----------------

   function Slot_Number (Prim : Entity_Id) return Uint is
      E : constant Entity_Id := Ultimate_Alias (Prim);
   begin
      if Is_Predefined_Dispatching_Operation (E) then
         return -DT_Position (E);
      else
         return DT_Position (E);
      end if;
   end Slot_Number;

   ------------------
   -- Write_Output --
   ------------------

   procedure Write_Output (Str : String) is
      Nul   : constant Character := Character'First;
      Line  : String (Str'First .. Str'Last + 1);
      Errno : Integer;

   begin
      --  Add the null character to the string as required by fputs

      Line  := Str & Nul;
      Errno := fputs (Line'Address, Callgraph_Info_File);
      pragma Assert (Errno >= 0);
   end Write_Output;

   ---------------------
   -- Write_Call_Info --
   ---------------------

   procedure Write_Call_Info (Call : Node_Id) is
      Ctrl_Arg : constant Node_Id   := Controlling_Argument (Call);
      Ctrl_Typ : constant Entity_Id := Base_Type (Etype (Ctrl_Arg));
      Prim     : constant Entity_Id := Entity (Sinfo.Name (Call));
      P        : constant Node_Id   := Parent (Call);

   begin
      Write_Str ("edge: { sourcename: ");
      Write_Char ('"');

      --  The parent node is the construct that contains the call: subprogram
      --  body or library-level package. Display the qualified name of the
      --  entity of the construct. For a subprogram, it is the entity of the
      --  spec, which carries a homonym counter when it is overloaded.

      if Nkind (P) = N_Subprogram_Body
        and then not Acts_As_Spec (P)
      then
         Get_External_Name (Corresponding_Spec (P));

      else
         Get_External_Name (Defining_Entity (P));
      end if;

      Write_Str (Name_Buffer (1 .. Name_Len));

      if Nkind (P) = N_Package_Declaration then
         Write_Str ("___elabs");

      elsif Nkind (P) = N_Package_Body then
         Write_Str ("___elabb");
      end if;

      Write_Char ('"');
      Write_Eol;

      --  The targetname is a triple:
      --     N:  the index in a vtable used for dispatch
      --     V:  the type who's vtable is used
      --     S:  the static type of the expression

      Write_Str  ("  targetname: ");
      Write_Char ('"');

      pragma Assert (No (Interface_Alias (Prim)));

      --  The check on Is_Ancestor is done here to avoid problems with
      --  renamings of primitives. For example:

      --    type Root is tagged ...
      --    procedure Base   (Obj : Root);
      --    procedure Base2  (Obj : Root) renames Base;

      if Present (Alias (Prim))
        and then
          Is_Ancestor
            (Find_Dispatching_Type (Ultimate_Alias (Prim)),
             Root_Type (Ctrl_Typ),
             Use_Full_View => True)
      then
         --  This is a special case in which we generate in the ci file the
         --  slot number of the renaming primitive (i.e. Base2) but instead of
         --  generating the name of this renaming entity we reference directly
         --  the renamed entity (i.e. Base).

         Write_Int (UI_To_Int (Slot_Number (Prim)));
         Write_Char (':');
         Write_Name
           (Chars (Find_Dispatching_Type (Ultimate_Alias (Prim))));
      else
         Write_Int (UI_To_Int (Slot_Number (Prim)));
         Write_Char (':');
         Write_Name (Chars (Root_Type (Ctrl_Typ)));
      end if;

      Write_Char (',');
      Write_Name (Chars (Root_Type (Ctrl_Typ)));

      Write_Char ('"');
      Write_Eol;

      Write_Str  ("  label: ");
      Write_Char ('"');
      Write_Location (Sloc (Call));
      Write_Char ('"');
      Write_Eol;

      Write_Char ('}');
      Write_Eol;
   end Write_Call_Info;

   ---------------------
   -- Write_Type_Info --
   ---------------------

   procedure Write_Type_Info (Typ : Entity_Id) is
      Elmt : Elmt_Id;
      Prim : Node_Id;

      Parent_Typ       : Entity_Id;
      Separator_Needed : Boolean := False;

   begin
      --  Initialize Parent_Typ handling private types

      Parent_Typ := Etype (Typ);

      if Present (Full_View (Parent_Typ)) then
         Parent_Typ := Full_View (Parent_Typ);
      end if;

      Write_Str ("class {");
      Write_Eol;

      Write_Str ("  classname: ");
      Write_Char ('"');
      Write_Name (Chars (Typ));
      Write_Char ('"');
      Write_Eol;

      Write_Str  ("  label: ");
      Write_Char ('"');
      Write_Name (Chars (Typ));
      Write_Char ('\');
      Write_Location (Sloc (Typ));
      Write_Char ('"');
      Write_Eol;

      if Parent_Typ /= Typ then
         Write_Str  ("  parent: ");
         Write_Char ('"');
         Write_Name (Chars (Parent_Typ));

         --  Note: Einfo prefix not needed if this routine is moved to
         --  exp_disp???

         if Present (Einfo.Interfaces (Typ))
           and then not Is_Empty_Elmt_List (Einfo.Interfaces (Typ))
         then
            Elmt := First_Elmt (Einfo.Interfaces (Typ));
            while Present (Elmt) loop
               Write_Str  (", ");
               Write_Name (Chars (Node (Elmt)));
               Next_Elmt  (Elmt);
            end loop;
         end if;

         Write_Char ('"');
         Write_Eol;
      end if;

      Write_Str ("  virtuals: ");
      Write_Char ('"');

      Elmt := First_Elmt (Primitive_Operations (Typ));
      while Present (Elmt) loop
         Prim := Node (Elmt);

         --  Skip internal entities associated with overridden interface
         --  primitives, and also inherited primitives.

         if Present (Interface_Alias (Prim))
           or else
             (Present (Alias (Prim))
               and then Find_Dispatching_Type (Prim) /=
                        Find_Dispatching_Type (Alias (Prim)))
         then
            goto Continue;
         end if;

         --  Do not generate separator for output of first primitive

         if Separator_Needed then
            Write_Str ("\n");
            Write_Eol;
            Write_Str ("             ");
         else
            Separator_Needed := True;
         end if;

         Write_Int (UI_To_Int (Slot_Number (Prim)));
         Write_Char (':');

         --  Handle renamed primitives

         if Present (Alias (Prim)) then
            Write_Name (Chars (Ultimate_Alias (Prim)));
         else
            Write_Name (Chars (Prim));
         end if;

         --  Display overriding of parent primitives

         if Present (Overridden_Operation (Prim))
           and then
             Is_Ancestor
               (Find_Dispatching_Type (Overridden_Operation (Prim)), Typ,
                Use_Full_View => True)
         then
            Write_Char (',');
            Write_Int
              (UI_To_Int (Slot_Number (Overridden_Operation (Prim))));
            Write_Char (':');
            Write_Name
              (Chars (Find_Dispatching_Type (Overridden_Operation (Prim))));
         end if;

         --  Display overriding of interface primitives

         if Has_Interfaces (Typ) then
            declare
               Prim_Elmt : Elmt_Id;
               Prim_Op   : Node_Id;
               Int_Alias : Entity_Id;

            begin
               Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
               while Present (Prim_Elmt) loop
                  Prim_Op := Node (Prim_Elmt);
                  Int_Alias := Interface_Alias (Prim_Op);

                  if Present (Int_Alias)
                    and then
                      not Is_Ancestor (Find_Dispatching_Type (Int_Alias), Typ,
                                       Use_Full_View => True)
                    and then (Alias (Prim_Op)) = Prim
                  then
                     Write_Char (',');
                     Write_Int (UI_To_Int (Slot_Number (Int_Alias)));
                     Write_Char (':');
                     Write_Name (Chars (Find_Dispatching_Type (Int_Alias)));
                  end if;

                  Next_Elmt (Prim_Elmt);
               end loop;
            end;
         end if;

         <<Continue>>
         Next_Elmt (Elmt);
      end loop;

      Write_Char ('"');
      Write_Eol;

      Write_Char ('}');
      Write_Eol;
   end Write_Type_Info;

end Exp_CG;