------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- E X P _ C G -- -- -- -- B o d y -- -- -- -- Copyright (C) 2010-2014, 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_Disp; use Exp_Disp; 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; <> Next_Elmt (Elmt); end loop; Write_Char ('"'); Write_Eol; Write_Char ('}'); Write_Eol; end Write_Type_Info; end Exp_CG;