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 rewriten by the expander.
360 Copy
: constant Node_Id
:= New_Copy
(N
);
364 -- Determine the enclosing scope to use when generating the
365 -- call graph. This must be done now to avoid problems with
366 -- control structures that may be rewritten during expansion.
369 while Nkind
(Par
) /= N_Subprogram_Body
370 and then Nkind
(Parent
(Par
)) /= N_Compilation_Unit
373 pragma Assert
(Present
(Par
));
376 Set_Parent
(Copy
, Par
);
377 Call_Graph_Nodes
.Append
(Copy
);
381 else pragma Assert
(Nkind
(N
) = N_Defining_Identifier
);
382 if Entity_Is_In_Main_Unit
(N
) then
383 Call_Graph_Nodes
.Append
(N
);
386 end Register_CG_Node
;
392 function Slot_Number
(Prim
: Entity_Id
) return Uint
is
393 E
: constant Entity_Id
:= Ultimate_Alias
(Prim
);
395 if Is_Predefined_Dispatching_Operation
(E
) then
396 return -DT_Position
(E
);
398 return DT_Position
(E
);
406 procedure Write_Output
(Str
: String) is
407 Nul
: constant Character := Character'First;
408 Line
: String (Str
'First .. Str
'Last + 1);
412 -- Add the null character to the string as required by fputs
415 Errno
:= fputs
(Line
'Address, Callgraph_Info_File
);
416 pragma Assert
(Errno
>= 0);
419 ---------------------
420 -- Write_Call_Info --
421 ---------------------
423 procedure Write_Call_Info
(Call
: Node_Id
) is
424 Ctrl_Arg
: constant Node_Id
:= Controlling_Argument
(Call
);
425 Ctrl_Typ
: constant Entity_Id
:= Base_Type
(Etype
(Ctrl_Arg
));
426 Prim
: constant Entity_Id
:= Entity
(Sinfo
.Name
(Call
));
427 P
: constant Node_Id
:= Parent
(Call
);
430 Write_Str
("edge: { sourcename: ");
433 -- The parent node is the construct that contains the call: subprogram
434 -- body or library-level package. Display the qualified name of the
435 -- entity of the construct. For a subprogram, it is the entity of the
436 -- spec, which carries a homonym counter when it is overloaded.
438 if Nkind
(P
) = N_Subprogram_Body
439 and then not Acts_As_Spec
(P
)
441 Get_External_Name
(Corresponding_Spec
(P
), Has_Suffix
=> False);
444 Get_External_Name
(Defining_Entity
(P
), Has_Suffix
=> False);
447 Write_Str
(Name_Buffer
(1 .. Name_Len
));
449 if Nkind
(P
) = N_Package_Declaration
then
450 Write_Str
("___elabs");
452 elsif Nkind
(P
) = N_Package_Body
then
453 Write_Str
("___elabb");
459 -- The targetname is a triple:
460 -- N: the index in a vtable used for dispatch
461 -- V: the type who's vtable is used
462 -- S: the static type of the expression
464 Write_Str
(" targetname: ");
467 pragma Assert
(No
(Interface_Alias
(Prim
)));
469 -- The check on Is_Ancestor is done here to avoid problems with
470 -- renamings of primitives. For example:
472 -- type Root is tagged ...
473 -- procedure Base (Obj : Root);
474 -- procedure Base2 (Obj : Root) renames Base;
476 if Present
(Alias
(Prim
))
479 (Find_Dispatching_Type
(Ultimate_Alias
(Prim
)),
480 Root_Type
(Ctrl_Typ
))
482 -- This is a special case in which we generate in the ci file the
483 -- slot number of the renaming primitive (i.e. Base2) but instead of
484 -- generating the name of this renaming entity we reference directly
485 -- the renamed entity (i.e. Base).
487 Write_Int
(UI_To_Int
(Slot_Number
(Prim
)));
490 (Chars
(Find_Dispatching_Type
(Ultimate_Alias
(Prim
))));
492 Write_Int
(UI_To_Int
(Slot_Number
(Prim
)));
494 Write_Name
(Chars
(Root_Type
(Ctrl_Typ
)));
498 Write_Name
(Chars
(Root_Type
(Ctrl_Typ
)));
503 Write_Str
(" label: ");
505 Write_Location
(Sloc
(Call
));
513 ---------------------
514 -- Write_Type_Info --
515 ---------------------
517 procedure Write_Type_Info
(Typ
: Entity_Id
) is
521 Parent_Typ
: Entity_Id
;
522 Separator_Needed
: Boolean := False;
525 -- Initialize Parent_Typ handling private types
527 Parent_Typ
:= Etype
(Typ
);
529 if Present
(Full_View
(Parent_Typ
)) then
530 Parent_Typ
:= Full_View
(Parent_Typ
);
533 Write_Str
("class {");
536 Write_Str
(" classname: ");
538 Write_Name
(Chars
(Typ
));
542 Write_Str
(" label: ");
544 Write_Name
(Chars
(Typ
));
546 Write_Location
(Sloc
(Typ
));
550 if Parent_Typ
/= Typ
then
551 Write_Str
(" parent: ");
553 Write_Name
(Chars
(Parent_Typ
));
555 -- Note: Einfo prefix not needed if this routine is moved to
558 if Present
(Einfo
.Interfaces
(Typ
))
559 and then not Is_Empty_Elmt_List
(Einfo
.Interfaces
(Typ
))
561 Elmt
:= First_Elmt
(Einfo
.Interfaces
(Typ
));
562 while Present
(Elmt
) loop
564 Write_Name
(Chars
(Node
(Elmt
)));
573 Write_Str
(" virtuals: ");
576 Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
577 while Present
(Elmt
) loop
580 -- Skip internal entities associated with overridden interface
581 -- primitives, and also inherited primitives.
583 if Present
(Interface_Alias
(Prim
))
585 (Present
(Alias
(Prim
))
586 and then Find_Dispatching_Type
(Prim
) /=
587 Find_Dispatching_Type
(Alias
(Prim
)))
592 -- Do not generate separator for output of first primitive
594 if Separator_Needed
then
599 Separator_Needed
:= True;
602 Write_Int
(UI_To_Int
(Slot_Number
(Prim
)));
605 -- Handle renamed primitives
607 if Present
(Alias
(Prim
)) then
608 Write_Name
(Chars
(Ultimate_Alias
(Prim
)));
610 Write_Name
(Chars
(Prim
));
613 -- Display overriding of parent primitives
615 if Present
(Overridden_Operation
(Prim
))
618 (Find_Dispatching_Type
(Overridden_Operation
(Prim
)), Typ
)
622 (UI_To_Int
(Slot_Number
(Overridden_Operation
(Prim
))));
625 (Chars
(Find_Dispatching_Type
(Overridden_Operation
(Prim
))));
628 -- Display overriding of interface primitives
630 if Has_Interfaces
(Typ
) then
634 Int_Alias
: Entity_Id
;
637 Prim_Elmt
:= First_Elmt
(Primitive_Operations
(Typ
));
638 while Present
(Prim_Elmt
) loop
639 Prim_Op
:= Node
(Prim_Elmt
);
640 Int_Alias
:= Interface_Alias
(Prim_Op
);
642 if Present
(Int_Alias
)
644 not Is_Ancestor
(Find_Dispatching_Type
(Int_Alias
), Typ
)
645 and then (Alias
(Prim_Op
)) = Prim
648 Write_Int
(UI_To_Int
(Slot_Number
(Int_Alias
)));
650 Write_Name
(Chars
(Find_Dispatching_Type
(Int_Alias
)));
653 Next_Elmt
(Prim_Elmt
);