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 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
;
34 with Namet
; use Namet
;
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
;
46 with Uintp
; use Uintp
;
48 package body Exp_CG
is
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.
54 subtype FILEs
is System
.Address
;
55 -- Corresponds to the C type FILE*
57 subtype C_chars
is System
.Address
;
58 -- Pointer to null-terminated array of characters
60 function fputs
(Strng
: C_chars
; Stream
: FILEs
) return Integer;
61 pragma Import
(C
, fputs
, "fputs");
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.
67 Callgraph_Info_File
: FILEs
;
68 pragma Import
(C
, Callgraph_Info_File
);
70 package Call_Graph_Nodes
is new Table
.Table
(
71 Table_Component_Type
=> Node_Id
,
72 Table_Index_Type
=> Natural,
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.
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 ???
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.
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).
96 procedure Write_Call_Info
(Call
: Node_Id
);
97 -- Subsidiary of Generate_CG_Output that generates the output associated
98 -- with a dispatching call.
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.
104 ------------------------
105 -- Generate_CG_Output --
106 ------------------------
108 procedure Generate_CG_Output
is
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
115 if Callgraph_Info_File
= Null_Address
116 or else not Debug_Flag_Dot_ZZ
121 -- Setup write routine, create the output file and generate the output
123 Set_Special_Output
(Write_Output
'Access);
125 for J
in Call_Graph_Nodes
.First
.. Call_Graph_Nodes
.Last
loop
126 N
:= Call_Graph_Nodes
.Table
(J
);
128 if Nkind_In
(N
, N_Procedure_Call_Statement
, N_Function_Call
) then
131 else pragma Assert
(Nkind
(N
) = N_Defining_Identifier
);
132 pragma Assert
(Is_Tagged_Type
(N
));
138 Set_Special_Output
(null);
139 end Generate_CG_Output
;
145 procedure Initialize
is
147 Call_Graph_Nodes
.Init
;
150 -----------------------------------------
151 -- Is_Predefined_Dispatching_Operation --
152 -----------------------------------------
154 function Is_Predefined_Dispatching_Operation
155 (E
: Entity_Id
) return Boolean
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???
163 ---------------------------
164 -- Homonym_Suffix_Length --
165 ---------------------------
167 function Homonym_Suffix_Length
(E
: Entity_Id
) return Natural is
168 Prefix_Length
: constant := 2; -- Length of prefix "__"
174 if not Has_Homonym
(E
) then
179 while Present
(H
) loop
180 if Scope
(H
) = Scope
(E
) then
190 -- Prefix "__" followed by number
194 Result
: Natural := Prefix_Length
+ 1;
197 Result
:= Result
+ 1;
204 end Homonym_Suffix_Length
;
208 Full_Name
: constant String := Get_Name_String
(Chars
(E
));
209 TSS_Name
: TSS_Name_Type
;
211 -- Start of processing for Is_Predefined_Dispatching_Operation
214 if not Is_Dispatching_Operation
(E
) then
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.
222 if Full_Name
'Length > TSS_Name_Type
'Length then
224 TSS_Name_Type
(Full_Name
(Full_Name
'Last - TSS_Name
'Length + 1
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
236 elsif not Has_Fully_Qualified_Name
(E
) then
237 if Chars
(E
) = Name_uSize
238 or else Chars
(E
) = Name_uAlignment
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
)
248 -- Handle fully qualified names
252 type Names_Table
is array (Positive range <>) of Name_Id
;
254 Predef_Names_95
: constant Names_Table
:=
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
,
266 Name_uDisp_Timed_Select
);
268 Suffix_Length
: constant Natural := Homonym_Suffix_Length
(E
);
271 for J
in Predef_Names_95
'Range loop
272 Get_Name_String
(Predef_Names_95
(J
));
274 if Full_Name
'Last - Suffix_Length
> Name_Len
277 (Full_Name
'Last - Name_Len
- Suffix_Length
+ 1
278 .. Full_Name
'Last - Suffix_Length
) =
279 Name_Buffer
(1 .. Name_Len
)
281 -- For the equality operator the type of the two operands
284 return Predef_Names_95
(J
) /= Name_Op_Eq
286 Etype
(First_Formal
(E
)) = Etype
(Last_Formal
(E
));
290 if Ada_Version
>= Ada_05
then
291 for J
in Predef_Names_05
'Range loop
292 Get_Name_String
(Predef_Names_05
(J
));
294 if Full_Name
'Last - Suffix_Length
> Name_Len
297 (Full_Name
'Last - Name_Len
- Suffix_Length
+ 1
298 .. Full_Name
'Last - Suffix_Length
) =
299 Name_Buffer
(1 .. Name_Len
)
310 end Is_Predefined_Dispatching_Operation
;
312 ----------------------
313 -- Register_CG_Node --
314 ----------------------
316 procedure Register_CG_Node
(N
: Node_Id
) is
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
)
322 -- Register a copy of the dispatching call node. Needed since the
323 -- node containing a dispatching call is rewriten by the expander.
326 Copy
: constant Node_Id
:= New_Copy
(N
);
329 -- Copy the link to the parent to allow climbing up the tree
330 -- when the call-graph information is generated
332 Set_Parent
(Copy
, Parent
(N
));
333 Call_Graph_Nodes
.Append
(Copy
);
337 else pragma Assert
(Nkind
(N
) = N_Defining_Identifier
);
338 if Entity_Is_In_Main_Unit
(N
) then
339 Call_Graph_Nodes
.Append
(N
);
342 end Register_CG_Node
;
348 function Slot_Number
(Prim
: Entity_Id
) return Uint
is
350 if Is_Predefined_Dispatching_Operation
(Prim
) then
351 return -DT_Position
(Prim
);
353 return DT_Position
(Prim
);
361 procedure Write_Output
(Str
: String) is
362 Nul
: constant Character := Character'First;
363 Line
: String (Str
'First .. Str
'Last + 1);
366 -- Add the null character to the string as required by fputs
369 Errno
:= fputs
(Line
'Address, Callgraph_Info_File
);
370 pragma Assert
(Errno
>= 0);
373 ---------------------
374 -- Write_Call_Info --
375 ---------------------
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
));
384 -- Locate the enclosing context: a subprogram (if available) or the
385 -- enclosing library-level package
388 while Nkind
(P
) /= N_Subprogram_Body
389 and then Nkind
(Parent
(P
)) /= N_Compilation_Unit
392 pragma Assert
(Present
(P
));
395 Write_Str
("edge: { sourcename: ");
397 Get_External_Name
(Defining_Entity
(P
), Has_Suffix
=> False);
398 Write_Str
(Name_Buffer
(1 .. Name_Len
));
400 if Nkind
(P
) = N_Package_Declaration
then
401 Write_Str
("___elabs");
403 elsif Nkind
(P
) = N_Package_Body
then
404 Write_Str
("___elabb");
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
415 Write_Str
(" targetname: ");
418 pragma Assert
(No
(Interface_Alias
(Prim
)));
420 -- The check on Is_Ancestor is done here to avoid problems with
421 -- renamings of primitives. For example:
423 -- type Root is tagged ...
424 -- procedure Base (Obj : Root);
425 -- procedure Base2 (Obj : Root) renames Base;
427 if Present
(Alias
(Prim
))
430 (Find_Dispatching_Type
(Ultimate_Alias
(Prim
)),
431 Root_Type
(Ctrl_Typ
))
433 Write_Int
(UI_To_Int
(Slot_Number
(Ultimate_Alias
(Prim
))));
436 (Chars
(Find_Dispatching_Type
(Ultimate_Alias
(Prim
))));
438 Write_Int
(UI_To_Int
(Slot_Number
(Prim
)));
440 Write_Name
(Chars
(Root_Type
(Ctrl_Typ
)));
444 Write_Name
(Chars
(Root_Type
(Ctrl_Typ
)));
449 Write_Str
(" label: ");
451 Write_Location
(Sloc
(Call
));
459 ---------------------
460 -- Write_Type_Info --
461 ---------------------
463 procedure Write_Type_Info
(Typ
: Entity_Id
) is
467 Parent_Typ
: Entity_Id
;
468 Separator_Needed
: Boolean := False;
471 -- Initialize Parent_Typ handling private types
473 Parent_Typ
:= Etype
(Typ
);
475 if Present
(Full_View
(Parent_Typ
)) then
476 Parent_Typ
:= Full_View
(Parent_Typ
);
479 Write_Str
("class {");
482 Write_Str
(" classname: ");
484 Write_Name
(Chars
(Typ
));
488 Write_Str
(" label: ");
490 Write_Name
(Chars
(Typ
));
492 Write_Location
(Sloc
(Typ
));
496 if Parent_Typ
/= Typ
then
497 Write_Str
(" parent: ");
499 Write_Name
(Chars
(Parent_Typ
));
501 -- Note: Einfo prefix not needed if this routine is moved to
504 if Present
(Einfo
.Interfaces
(Typ
))
505 and then not Is_Empty_Elmt_List
(Einfo
.Interfaces
(Typ
))
507 Elmt
:= First_Elmt
(Einfo
.Interfaces
(Typ
));
508 while Present
(Elmt
) loop
510 Write_Name
(Chars
(Node
(Elmt
)));
519 Write_Str
(" virtuals: ");
522 Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
523 while Present
(Elmt
) loop
526 -- Display only primitives overriden or defined
528 if Present
(Alias
(Prim
)) then
532 -- Do not generate separator for output of first primitive
534 if Separator_Needed
then
539 Separator_Needed
:= True;
542 Write_Int
(UI_To_Int
(Slot_Number
(Prim
)));
544 Write_Name
(Chars
(Prim
));
546 -- Display overriding of parent primitives
548 if Present
(Overridden_Operation
(Prim
))
551 (Find_Dispatching_Type
(Overridden_Operation
(Prim
)), Typ
)
555 (UI_To_Int
(Slot_Number
(Overridden_Operation
(Prim
))));
558 (Chars
(Find_Dispatching_Type
(Overridden_Operation
(Prim
))));
561 -- Display overriding of interface primitives
563 if Has_Interfaces
(Typ
) then
567 Int_Alias
: Entity_Id
;
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
);
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
581 Write_Int
(UI_To_Int
(Slot_Number
(Int_Alias
)));
583 Write_Name
(Chars
(Find_Dispatching_Type
(Int_Alias
)));
586 Next_Elmt
(Prim_Elmt
);