1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 2010, Free Software Foundation, Inc. --
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. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Atree; use Atree;
27 with Einfo; use Einfo;
28 with Elists; use Elists;
29 with Exp_Disp; use Exp_Disp;
30 with Exp_Dbug; use Exp_Dbug;
31 with Exp_Tss; use Exp_Tss;
33 with Namet; use Namet;
35 with Output; use Output;
36 with Sem_Aux; use Sem_Aux;
37 with Sem_Disp; use Sem_Disp;
38 with Sem_Type; use Sem_Type;
39 with Sem_Util; use Sem_Util;
40 with Sinfo; use Sinfo;
41 with Sinput; use Sinput;
42 with Snames; use Snames;
43 with System; use System;
45 with Uintp; use Uintp;
47 package body Exp_CG is
49 -- We duplicate here some declarations from packages Interfaces.C and
50 -- Interfaces.C_Streams because adding their dependence to the frontend
51 -- causes bootstrapping problems with old versions of the compiler.
53 subtype FILEs is System.Address;
54 -- Corresponds to the C type FILE*
56 subtype C_chars is System.Address;
57 -- Pointer to null-terminated array of characters
59 function fputs (Strng : C_chars; Stream : FILEs) return Integer;
60 pragma Import (C, fputs, "fputs");
62 -- Import the file stream associated with the "ci" output file. Done to
63 -- generate the output in the file created and left opened by routine
64 -- toplev.c before calling gnat1drv.
66 Callgraph_Info_File : FILEs;
67 pragma Import (C, Callgraph_Info_File);
69 package Call_Graph_Nodes is new Table.Table (
70 Table_Component_Type => Node_Id,
71 Table_Index_Type => Natural,
74 Table_Increment => 100,
75 Table_Name => "Call_Graph_Nodes");
76 -- This table records nodes associated with dispatching calls and tagged
77 -- type declarations found in the main compilation unit. Used as an
78 -- auxiliary storage because the call-graph output requires fully qualified
79 -- names and they are not available until the backend is called.
81 function Is_Predefined_Dispatching_Operation (E : Entity_Id) return Boolean;
82 -- Determines if E is a predefined primitive operation.
83 -- Note: This routine should replace the routine with the same name that is
84 -- currently available in exp_disp because it extends its functionality to
85 -- handle fully qualified names ???
87 function Slot_Number (Prim : Entity_Id) return Uint;
88 -- Returns the slot number associated with Prim. For predefined primitives
89 -- the slot is returned as a negative number.
91 procedure Write_Output (Str : String);
92 -- Used to print a line in the output file (this is used as the
93 -- argument for a call to Set_Special_Output in package Output).
95 procedure Write_Call_Info (Call : Node_Id);
96 -- Subsidiary of Generate_CG_Output that generates the output associated
97 -- with a dispatching call.
99 procedure Write_Type_Info (Typ : Entity_Id);
100 -- Subsidiary of Generate_CG_Output that generates the output associated
101 -- with a tagged type declaration.
103 ------------------------
104 -- Generate_CG_Output --
105 ------------------------
107 procedure Generate_CG_Output is
111 -- No output if the "ci" output file has not been previously opened
114 if Callgraph_Info_File = Null_Address then
118 -- Setup write routine, create the output file and generate the output
120 Set_Special_Output (Write_Output'Access);
122 for J in Call_Graph_Nodes.First .. Call_Graph_Nodes.Last loop
123 N := Call_Graph_Nodes.Table (J);
125 if Nkind_In (N, N_Procedure_Call_Statement, N_Function_Call) then
128 else pragma Assert (Nkind (N) = N_Defining_Identifier);
130 -- The type may be a private untagged type whose completion is
131 -- tagged, in which case we must use the full tagged view.
133 if not Is_Tagged_Type (N) and then Is_Private_Type (N) then
137 pragma Assert (Is_Tagged_Type (N));
143 Set_Special_Output (null);
144 end Generate_CG_Output;
150 procedure Initialize is
152 Call_Graph_Nodes.Init;
155 -----------------------------------------
156 -- Is_Predefined_Dispatching_Operation --
157 -----------------------------------------
159 function Is_Predefined_Dispatching_Operation
160 (E : Entity_Id) return Boolean
162 function Homonym_Suffix_Length (E : Entity_Id) return Natural;
163 -- Returns the length of the homonym suffix corresponding to E.
164 -- Note: This routine relies on the functionality provided by routines
165 -- of Exp_Dbug. Further work needed here to decide if it should be
166 -- located in that package???
168 ---------------------------
169 -- Homonym_Suffix_Length --
170 ---------------------------
172 function Homonym_Suffix_Length (E : Entity_Id) return Natural is
173 Prefix_Length : constant := 2;
174 -- Length of prefix "__"
180 if not Has_Homonym (E) then
185 while Present (H) loop
186 if Scope (H) = Scope (E) then
196 -- Prefix "__" followed by number
200 Result : Natural := Prefix_Length + 1;
204 Result := Result + 1;
212 end Homonym_Suffix_Length;
216 Full_Name : constant String := Get_Name_String (Chars (E));
217 Suffix_Length : Natural;
218 TSS_Name : TSS_Name_Type;
220 -- Start of processing for Is_Predefined_Dispatching_Operation
223 if not Is_Dispatching_Operation (E) then
227 -- Search for and strip suffix for body-nested package entities
229 Suffix_Length := Homonym_Suffix_Length (E);
230 for J in reverse Full_Name'First + 2 .. Full_Name'Last loop
231 if Full_Name (J) = 'X' then
233 -- Include the "X", "Xb", "Xn", ... in the part of the
234 -- suffix to be removed.
236 Suffix_Length := Suffix_Length + Full_Name'Last - J + 1;
240 exit when Full_Name (J) /= 'b' and then Full_Name (J) /= 'n';
243 -- Most predefined primitives have internally generated names. Equality
244 -- must be treated differently; the predefined operation is recognized
245 -- as a homogeneous binary operator that returns Boolean.
247 if Full_Name'Length > TSS_Name_Type'Length then
251 (Full_Name'Last - TSS_Name'Length - Suffix_Length + 1
252 .. Full_Name'Last - Suffix_Length));
254 if TSS_Name = TSS_Stream_Read
255 or else TSS_Name = TSS_Stream_Write
256 or else TSS_Name = TSS_Stream_Input
257 or else TSS_Name = TSS_Stream_Output
258 or else TSS_Name = TSS_Deep_Adjust
259 or else TSS_Name = TSS_Deep_Finalize
263 elsif not Has_Fully_Qualified_Name (E) then
264 if Chars (E) = Name_uSize
265 or else Chars (E) = Name_uAlignment
267 (Chars (E) = Name_Op_Eq
268 and then Etype (First_Formal (E)) = Etype (Last_Formal (E)))
269 or else Chars (E) = Name_uAssign
270 or else Is_Predefined_Interface_Primitive (E)
275 -- Handle fully qualified names
279 type Names_Table is array (Positive range <>) of Name_Id;
281 Predef_Names_95 : constant Names_Table :=
287 Predef_Names_05 : constant Names_Table :=
288 (Name_uDisp_Asynchronous_Select,
289 Name_uDisp_Conditional_Select,
290 Name_uDisp_Get_Prim_Op_Kind,
291 Name_uDisp_Get_Task_Id,
293 Name_uDisp_Timed_Select);
296 for J in Predef_Names_95'Range loop
297 Get_Name_String (Predef_Names_95 (J));
299 -- The predefined primitive operations are identified by the
300 -- names "_size", "_alignment", etc. If we try a pattern
301 -- matching against this string, we can wrongly match other
302 -- primitive operations like "get_size". To avoid this, we
303 -- add the "__" scope separator, which can only prepend
304 -- predefined primitive operations because other primitive
305 -- operations can neither start with an underline nor
306 -- contain two consecutive underlines in its name.
308 if Full_Name'Last - Suffix_Length > Name_Len + 2
311 (Full_Name'Last - Name_Len - 2 - Suffix_Length + 1
312 .. Full_Name'Last - Suffix_Length) =
313 "__" & Name_Buffer (1 .. Name_Len)
315 -- For the equality operator the type of the two operands
318 return Predef_Names_95 (J) /= Name_Op_Eq
320 Etype (First_Formal (E)) = Etype (Last_Formal (E));
324 if Ada_Version >= Ada_2005 then
325 for J in Predef_Names_05'Range loop
326 Get_Name_String (Predef_Names_05 (J));
328 if Full_Name'Last - Suffix_Length > Name_Len + 2
331 (Full_Name'Last - Name_Len - 2 - Suffix_Length + 1
332 .. Full_Name'Last - Suffix_Length) =
333 "__" & Name_Buffer (1 .. Name_Len)
344 end Is_Predefined_Dispatching_Operation;
346 ----------------------
347 -- Register_CG_Node --
348 ----------------------
350 procedure Register_CG_Node (N : Node_Id) is
352 if Nkind_In (N, N_Procedure_Call_Statement, N_Function_Call) then
353 if Current_Scope = Main_Unit_Entity
354 or else Entity_Is_In_Main_Unit (Current_Scope)
356 -- Register a copy of the dispatching call node. Needed since the
357 -- node containing a dispatching call is rewritten by the
361 Copy : constant Node_Id := New_Copy (N);
365 -- Determine the enclosing scope to use when generating the
366 -- call graph. This must be done now to avoid problems with
367 -- control structures that may be rewritten during expansion.
370 while Nkind (Par) /= N_Subprogram_Body
371 and then Nkind (Parent (Par)) /= N_Compilation_Unit
374 pragma Assert (Present (Par));
377 Set_Parent (Copy, Par);
378 Call_Graph_Nodes.Append (Copy);
382 else pragma Assert (Nkind (N) = N_Defining_Identifier);
383 if Entity_Is_In_Main_Unit (N) then
384 Call_Graph_Nodes.Append (N);
387 end Register_CG_Node;
393 function Slot_Number (Prim : Entity_Id) return Uint is
394 E : constant Entity_Id := Ultimate_Alias (Prim);
396 if Is_Predefined_Dispatching_Operation (E) then
397 return -DT_Position (E);
399 return DT_Position (E);
407 procedure Write_Output (Str : String) is
408 Nul : constant Character := Character'First;
409 Line : String (Str'First .. Str'Last + 1);
413 -- Add the null character to the string as required by fputs
416 Errno := fputs (Line'Address, Callgraph_Info_File);
417 pragma Assert (Errno >= 0);
420 ---------------------
421 -- Write_Call_Info --
422 ---------------------
424 procedure Write_Call_Info (Call : Node_Id) is
425 Ctrl_Arg : constant Node_Id := Controlling_Argument (Call);
426 Ctrl_Typ : constant Entity_Id := Base_Type (Etype (Ctrl_Arg));
427 Prim : constant Entity_Id := Entity (Sinfo.Name (Call));
428 P : constant Node_Id := Parent (Call);
431 Write_Str ("edge: { sourcename: ");
434 -- The parent node is the construct that contains the call: subprogram
435 -- body or library-level package. Display the qualified name of the
436 -- entity of the construct. For a subprogram, it is the entity of the
437 -- spec, which carries a homonym counter when it is overloaded.
439 if Nkind (P) = N_Subprogram_Body
440 and then not Acts_As_Spec (P)
442 Get_External_Name (Corresponding_Spec (P), Has_Suffix => False);
445 Get_External_Name (Defining_Entity (P), Has_Suffix => False);
448 Write_Str (Name_Buffer (1 .. Name_Len));
450 if Nkind (P) = N_Package_Declaration then
451 Write_Str ("___elabs");
453 elsif Nkind (P) = N_Package_Body then
454 Write_Str ("___elabb");
460 -- The targetname is a triple:
461 -- N: the index in a vtable used for dispatch
462 -- V: the type who's vtable is used
463 -- S: the static type of the expression
465 Write_Str (" targetname: ");
468 pragma Assert (No (Interface_Alias (Prim)));
470 -- The check on Is_Ancestor is done here to avoid problems with
471 -- renamings of primitives. For example:
473 -- type Root is tagged ...
474 -- procedure Base (Obj : Root);
475 -- procedure Base2 (Obj : Root) renames Base;
477 if Present (Alias (Prim))
480 (Find_Dispatching_Type (Ultimate_Alias (Prim)),
481 Root_Type (Ctrl_Typ),
482 Use_Full_View => True)
484 -- This is a special case in which we generate in the ci file the
485 -- slot number of the renaming primitive (i.e. Base2) but instead of
486 -- generating the name of this renaming entity we reference directly
487 -- the renamed entity (i.e. Base).
489 Write_Int (UI_To_Int (Slot_Number (Prim)));
492 (Chars (Find_Dispatching_Type (Ultimate_Alias (Prim))));
494 Write_Int (UI_To_Int (Slot_Number (Prim)));
496 Write_Name (Chars (Root_Type (Ctrl_Typ)));
500 Write_Name (Chars (Root_Type (Ctrl_Typ)));
505 Write_Str (" label: ");
507 Write_Location (Sloc (Call));
515 ---------------------
516 -- Write_Type_Info --
517 ---------------------
519 procedure Write_Type_Info (Typ : Entity_Id) is
523 Parent_Typ : Entity_Id;
524 Separator_Needed : Boolean := False;
527 -- Initialize Parent_Typ handling private types
529 Parent_Typ := Etype (Typ);
531 if Present (Full_View (Parent_Typ)) then
532 Parent_Typ := Full_View (Parent_Typ);
535 Write_Str ("class {");
538 Write_Str (" classname: ");
540 Write_Name (Chars (Typ));
544 Write_Str (" label: ");
546 Write_Name (Chars (Typ));
548 Write_Location (Sloc (Typ));
552 if Parent_Typ /= Typ then
553 Write_Str (" parent: ");
555 Write_Name (Chars (Parent_Typ));
557 -- Note: Einfo prefix not needed if this routine is moved to
560 if Present (Einfo.Interfaces (Typ))
561 and then not Is_Empty_Elmt_List (Einfo.Interfaces (Typ))
563 Elmt := First_Elmt (Einfo.Interfaces (Typ));
564 while Present (Elmt) loop
566 Write_Name (Chars (Node (Elmt)));
575 Write_Str (" virtuals: ");
578 Elmt := First_Elmt (Primitive_Operations (Typ));
579 while Present (Elmt) loop
582 -- Skip internal entities associated with overridden interface
583 -- primitives, and also inherited primitives.
585 if Present (Interface_Alias (Prim))
587 (Present (Alias (Prim))
588 and then Find_Dispatching_Type (Prim) /=
589 Find_Dispatching_Type (Alias (Prim)))
594 -- Do not generate separator for output of first primitive
596 if Separator_Needed then
601 Separator_Needed := True;
604 Write_Int (UI_To_Int (Slot_Number (Prim)));
607 -- Handle renamed primitives
609 if Present (Alias (Prim)) then
610 Write_Name (Chars (Ultimate_Alias (Prim)));
612 Write_Name (Chars (Prim));
615 -- Display overriding of parent primitives
617 if Present (Overridden_Operation (Prim))
620 (Find_Dispatching_Type (Overridden_Operation (Prim)), Typ,
621 Use_Full_View => True)
625 (UI_To_Int (Slot_Number (Overridden_Operation (Prim))));
628 (Chars (Find_Dispatching_Type (Overridden_Operation (Prim))));
631 -- Display overriding of interface primitives
633 if Has_Interfaces (Typ) then
637 Int_Alias : Entity_Id;
640 Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
641 while Present (Prim_Elmt) loop
642 Prim_Op := Node (Prim_Elmt);
643 Int_Alias := Interface_Alias (Prim_Op);
645 if Present (Int_Alias)
647 not Is_Ancestor (Find_Dispatching_Type (Int_Alias), Typ,
648 Use_Full_View => True)
649 and then (Alias (Prim_Op)) = Prim
652 Write_Int (UI_To_Int (Slot_Number (Int_Alias)));
654 Write_Name (Chars (Find_Dispatching_Type (Int_Alias)));
657 Next_Elmt (Prim_Elmt);