| ------------------------------------------------------------------------------ |
| -- -- |
| -- 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; |
| |
| <<Continue>> |
| Next_Elmt (Elmt); |
| end loop; |
| |
| Write_Char ('"'); |
| Write_Eol; |
| |
| Write_Char ('}'); |
| Write_Eol; |
| end Write_Type_Info; |
| |
| end Exp_CG; |
