File : exp_cg.adb
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- E X P _ C G --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 2010-2014, Free Software Foundation, Inc. --
10 -- --
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. --
20 -- --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
23 -- --
24 ------------------------------------------------------------------------------
25
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;
32 with Lib; use Lib;
33 with Namet; use Namet;
34 with Opt; use Opt;
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;
44 with Table;
45 with Uintp; use Uintp;
46
47 package body Exp_CG is
48
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.
52
53 subtype FILEs is System.Address;
54 -- Corresponds to the C type FILE*
55
56 subtype C_chars is System.Address;
57 -- Pointer to null-terminated array of characters
58
59 function fputs (Strng : C_chars; Stream : FILEs) return Integer;
60 pragma Import (C, fputs, "fputs");
61
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.
65
66 Callgraph_Info_File : FILEs;
67 pragma Import (C, Callgraph_Info_File);
68
69 package Call_Graph_Nodes is new Table.Table (
70 Table_Component_Type => Node_Id,
71 Table_Index_Type => Natural,
72 Table_Low_Bound => 1,
73 Table_Initial => 50,
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.
80
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 ???
86
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.
90
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).
94
95 procedure Write_Call_Info (Call : Node_Id);
96 -- Subsidiary of Generate_CG_Output that generates the output associated
97 -- with a dispatching call.
98
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.
102
103 ------------------------
104 -- Generate_CG_Output --
105 ------------------------
106
107 procedure Generate_CG_Output is
108 N : Node_Id;
109
110 begin
111 -- No output if the "ci" output file has not been previously opened
112 -- by toplev.c
113
114 if Callgraph_Info_File = Null_Address then
115 return;
116 end if;
117
118 -- Setup write routine, create the output file and generate the output
119
120 Set_Special_Output (Write_Output'Access);
121
122 for J in Call_Graph_Nodes.First .. Call_Graph_Nodes.Last loop
123 N := Call_Graph_Nodes.Table (J);
124
125 if Nkind (N) in N_Subprogram_Call then
126 Write_Call_Info (N);
127
128 else pragma Assert (Nkind (N) = N_Defining_Identifier);
129
130 -- The type may be a private untagged type whose completion is
131 -- tagged, in which case we must use the full tagged view.
132
133 if not Is_Tagged_Type (N) and then Is_Private_Type (N) then
134 N := Full_View (N);
135 end if;
136
137 pragma Assert (Is_Tagged_Type (N));
138
139 Write_Type_Info (N);
140 end if;
141 end loop;
142
143 Set_Special_Output (null);
144 end Generate_CG_Output;
145
146 ----------------
147 -- Initialize --
148 ----------------
149
150 procedure Initialize is
151 begin
152 Call_Graph_Nodes.Init;
153 end Initialize;
154
155 -----------------------------------------
156 -- Is_Predefined_Dispatching_Operation --
157 -----------------------------------------
158
159 function Is_Predefined_Dispatching_Operation
160 (E : Entity_Id) return Boolean
161 is
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???
167
168 ---------------------------
169 -- Homonym_Suffix_Length --
170 ---------------------------
171
172 function Homonym_Suffix_Length (E : Entity_Id) return Natural is
173 Prefix_Length : constant := 2;
174 -- Length of prefix "__"
175
176 H : Entity_Id;
177 Nr : Nat := 1;
178
179 begin
180 if not Has_Homonym (E) then
181 return 0;
182
183 else
184 H := Homonym (E);
185 while Present (H) loop
186 if Scope (H) = Scope (E) then
187 Nr := Nr + 1;
188 end if;
189
190 H := Homonym (H);
191 end loop;
192
193 if Nr = 1 then
194 return 0;
195
196 -- Prefix "__" followed by number
197
198 else
199 declare
200 Result : Natural := Prefix_Length + 1;
201
202 begin
203 while Nr >= 10 loop
204 Result := Result + 1;
205 Nr := Nr / 10;
206 end loop;
207
208 return Result;
209 end;
210 end if;
211 end if;
212 end Homonym_Suffix_Length;
213
214 -- Local variables
215
216 Full_Name : constant String := Get_Name_String (Chars (E));
217 Suffix_Length : Natural;
218 TSS_Name : TSS_Name_Type;
219
220 -- Start of processing for Is_Predefined_Dispatching_Operation
221
222 begin
223 if not Is_Dispatching_Operation (E) then
224 return False;
225 end if;
226
227 -- Search for and strip suffix for body-nested package entities
228
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
232
233 -- Include the "X", "Xb", "Xn", ... in the part of the
234 -- suffix to be removed.
235
236 Suffix_Length := Suffix_Length + Full_Name'Last - J + 1;
237 exit;
238 end if;
239
240 exit when Full_Name (J) /= 'b' and then Full_Name (J) /= 'n';
241 end loop;
242
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.
246
247 if Full_Name'Length > TSS_Name_Type'Length then
248 TSS_Name :=
249 TSS_Name_Type
250 (Full_Name
251 (Full_Name'Last - TSS_Name'Length - Suffix_Length + 1
252 .. Full_Name'Last - Suffix_Length));
253
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
260 then
261 return True;
262
263 elsif not Has_Fully_Qualified_Name (E) then
264 if Nam_In (Chars (E), Name_uSize, Name_uAlignment, Name_uAssign)
265 or else
266 (Chars (E) = Name_Op_Eq
267 and then Etype (First_Formal (E)) = Etype (Last_Formal (E)))
268 or else Is_Predefined_Interface_Primitive (E)
269 then
270 return True;
271 end if;
272
273 -- Handle fully qualified names
274
275 else
276 declare
277 type Names_Table is array (Positive range <>) of Name_Id;
278
279 Predef_Names_95 : constant Names_Table :=
280 (Name_uSize,
281 Name_uAlignment,
282 Name_Op_Eq,
283 Name_uAssign);
284
285 Predef_Names_05 : constant Names_Table :=
286 (Name_uDisp_Asynchronous_Select,
287 Name_uDisp_Conditional_Select,
288 Name_uDisp_Get_Prim_Op_Kind,
289 Name_uDisp_Get_Task_Id,
290 Name_uDisp_Requeue,
291 Name_uDisp_Timed_Select);
292
293 begin
294 for J in Predef_Names_95'Range loop
295 Get_Name_String (Predef_Names_95 (J));
296
297 -- The predefined primitive operations are identified by the
298 -- names "_size", "_alignment", etc. If we try a pattern
299 -- matching against this string, we can wrongly match other
300 -- primitive operations like "get_size". To avoid this, we
301 -- add the "__" scope separator, which can only prepend
302 -- predefined primitive operations because other primitive
303 -- operations can neither start with an underline nor
304 -- contain two consecutive underlines in its name.
305
306 if Full_Name'Last - Suffix_Length > Name_Len + 2
307 and then
308 Full_Name
309 (Full_Name'Last - Name_Len - 2 - Suffix_Length + 1
310 .. Full_Name'Last - Suffix_Length) =
311 "__" & Name_Buffer (1 .. Name_Len)
312 then
313 -- For the equality operator the type of the two operands
314 -- must also match.
315
316 return Predef_Names_95 (J) /= Name_Op_Eq
317 or else
318 Etype (First_Formal (E)) = Etype (Last_Formal (E));
319 end if;
320 end loop;
321
322 if Ada_Version >= Ada_2005 then
323 for J in Predef_Names_05'Range loop
324 Get_Name_String (Predef_Names_05 (J));
325
326 if Full_Name'Last - Suffix_Length > Name_Len + 2
327 and then
328 Full_Name
329 (Full_Name'Last - Name_Len - 2 - Suffix_Length + 1
330 .. Full_Name'Last - Suffix_Length) =
331 "__" & Name_Buffer (1 .. Name_Len)
332 then
333 return True;
334 end if;
335 end loop;
336 end if;
337 end;
338 end if;
339 end if;
340
341 return False;
342 end Is_Predefined_Dispatching_Operation;
343
344 ----------------------
345 -- Register_CG_Node --
346 ----------------------
347
348 procedure Register_CG_Node (N : Node_Id) is
349 begin
350 if Nkind (N) in N_Subprogram_Call then
351 if Current_Scope = Main_Unit_Entity
352 or else Entity_Is_In_Main_Unit (Current_Scope)
353 then
354 -- Register a copy of the dispatching call node. Needed since the
355 -- node containing a dispatching call is rewritten by the
356 -- expander.
357
358 declare
359 Copy : constant Node_Id := New_Copy (N);
360 Par : Node_Id;
361
362 begin
363 -- Determine the enclosing scope to use when generating the
364 -- call graph. This must be done now to avoid problems with
365 -- control structures that may be rewritten during expansion.
366
367 Par := Parent (N);
368 while Nkind (Par) /= N_Subprogram_Body
369 and then Nkind (Parent (Par)) /= N_Compilation_Unit
370 loop
371 Par := Parent (Par);
372 pragma Assert (Present (Par));
373 end loop;
374
375 Set_Parent (Copy, Par);
376 Call_Graph_Nodes.Append (Copy);
377 end;
378 end if;
379
380 else pragma Assert (Nkind (N) = N_Defining_Identifier);
381 if Entity_Is_In_Main_Unit (N) then
382 Call_Graph_Nodes.Append (N);
383 end if;
384 end if;
385 end Register_CG_Node;
386
387 -----------------
388 -- Slot_Number --
389 -----------------
390
391 function Slot_Number (Prim : Entity_Id) return Uint is
392 E : constant Entity_Id := Ultimate_Alias (Prim);
393 begin
394 if Is_Predefined_Dispatching_Operation (E) then
395 return -DT_Position (E);
396 else
397 return DT_Position (E);
398 end if;
399 end Slot_Number;
400
401 ------------------
402 -- Write_Output --
403 ------------------
404
405 procedure Write_Output (Str : String) is
406 Nul : constant Character := Character'First;
407 Line : String (Str'First .. Str'Last + 1);
408 Errno : Integer;
409
410 begin
411 -- Add the null character to the string as required by fputs
412
413 Line := Str & Nul;
414 Errno := fputs (Line'Address, Callgraph_Info_File);
415 pragma Assert (Errno >= 0);
416 end Write_Output;
417
418 ---------------------
419 -- Write_Call_Info --
420 ---------------------
421
422 procedure Write_Call_Info (Call : Node_Id) is
423 Ctrl_Arg : constant Node_Id := Controlling_Argument (Call);
424 Ctrl_Typ : constant Entity_Id := Base_Type (Etype (Ctrl_Arg));
425 Prim : constant Entity_Id := Entity (Sinfo.Name (Call));
426 P : constant Node_Id := Parent (Call);
427
428 begin
429 Write_Str ("edge: { sourcename: ");
430 Write_Char ('"');
431
432 -- The parent node is the construct that contains the call: subprogram
433 -- body or library-level package. Display the qualified name of the
434 -- entity of the construct. For a subprogram, it is the entity of the
435 -- spec, which carries a homonym counter when it is overloaded.
436
437 if Nkind (P) = N_Subprogram_Body
438 and then not Acts_As_Spec (P)
439 then
440 Get_External_Name (Corresponding_Spec (P));
441
442 else
443 Get_External_Name (Defining_Entity (P));
444 end if;
445
446 Write_Str (Name_Buffer (1 .. Name_Len));
447
448 if Nkind (P) = N_Package_Declaration then
449 Write_Str ("___elabs");
450
451 elsif Nkind (P) = N_Package_Body then
452 Write_Str ("___elabb");
453 end if;
454
455 Write_Char ('"');
456 Write_Eol;
457
458 -- The targetname is a triple:
459 -- N: the index in a vtable used for dispatch
460 -- V: the type who's vtable is used
461 -- S: the static type of the expression
462
463 Write_Str (" targetname: ");
464 Write_Char ('"');
465
466 pragma Assert (No (Interface_Alias (Prim)));
467
468 -- The check on Is_Ancestor is done here to avoid problems with
469 -- renamings of primitives. For example:
470
471 -- type Root is tagged ...
472 -- procedure Base (Obj : Root);
473 -- procedure Base2 (Obj : Root) renames Base;
474
475 if Present (Alias (Prim))
476 and then
477 Is_Ancestor
478 (Find_Dispatching_Type (Ultimate_Alias (Prim)),
479 Root_Type (Ctrl_Typ),
480 Use_Full_View => True)
481 then
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).
486
487 Write_Int (UI_To_Int (Slot_Number (Prim)));
488 Write_Char (':');
489 Write_Name
490 (Chars (Find_Dispatching_Type (Ultimate_Alias (Prim))));
491 else
492 Write_Int (UI_To_Int (Slot_Number (Prim)));
493 Write_Char (':');
494 Write_Name (Chars (Root_Type (Ctrl_Typ)));
495 end if;
496
497 Write_Char (',');
498 Write_Name (Chars (Root_Type (Ctrl_Typ)));
499
500 Write_Char ('"');
501 Write_Eol;
502
503 Write_Str (" label: ");
504 Write_Char ('"');
505 Write_Location (Sloc (Call));
506 Write_Char ('"');
507 Write_Eol;
508
509 Write_Char ('}');
510 Write_Eol;
511 end Write_Call_Info;
512
513 ---------------------
514 -- Write_Type_Info --
515 ---------------------
516
517 procedure Write_Type_Info (Typ : Entity_Id) is
518 Elmt : Elmt_Id;
519 Prim : Node_Id;
520
521 Parent_Typ : Entity_Id;
522 Separator_Needed : Boolean := False;
523
524 begin
525 -- Initialize Parent_Typ handling private types
526
527 Parent_Typ := Etype (Typ);
528
529 if Present (Full_View (Parent_Typ)) then
530 Parent_Typ := Full_View (Parent_Typ);
531 end if;
532
533 Write_Str ("class {");
534 Write_Eol;
535
536 Write_Str (" classname: ");
537 Write_Char ('"');
538 Write_Name (Chars (Typ));
539 Write_Char ('"');
540 Write_Eol;
541
542 Write_Str (" label: ");
543 Write_Char ('"');
544 Write_Name (Chars (Typ));
545 Write_Char ('\');
546 Write_Location (Sloc (Typ));
547 Write_Char ('"');
548 Write_Eol;
549
550 if Parent_Typ /= Typ then
551 Write_Str (" parent: ");
552 Write_Char ('"');
553 Write_Name (Chars (Parent_Typ));
554
555 -- Note: Einfo prefix not needed if this routine is moved to
556 -- exp_disp???
557
558 if Present (Einfo.Interfaces (Typ))
559 and then not Is_Empty_Elmt_List (Einfo.Interfaces (Typ))
560 then
561 Elmt := First_Elmt (Einfo.Interfaces (Typ));
562 while Present (Elmt) loop
563 Write_Str (", ");
564 Write_Name (Chars (Node (Elmt)));
565 Next_Elmt (Elmt);
566 end loop;
567 end if;
568
569 Write_Char ('"');
570 Write_Eol;
571 end if;
572
573 Write_Str (" virtuals: ");
574 Write_Char ('"');
575
576 Elmt := First_Elmt (Primitive_Operations (Typ));
577 while Present (Elmt) loop
578 Prim := Node (Elmt);
579
580 -- Skip internal entities associated with overridden interface
581 -- primitives, and also inherited primitives.
582
583 if Present (Interface_Alias (Prim))
584 or else
585 (Present (Alias (Prim))
586 and then Find_Dispatching_Type (Prim) /=
587 Find_Dispatching_Type (Alias (Prim)))
588 then
589 goto Continue;
590 end if;
591
592 -- Do not generate separator for output of first primitive
593
594 if Separator_Needed then
595 Write_Str ("\n");
596 Write_Eol;
597 Write_Str (" ");
598 else
599 Separator_Needed := True;
600 end if;
601
602 Write_Int (UI_To_Int (Slot_Number (Prim)));
603 Write_Char (':');
604
605 -- Handle renamed primitives
606
607 if Present (Alias (Prim)) then
608 Write_Name (Chars (Ultimate_Alias (Prim)));
609 else
610 Write_Name (Chars (Prim));
611 end if;
612
613 -- Display overriding of parent primitives
614
615 if Present (Overridden_Operation (Prim))
616 and then
617 Is_Ancestor
618 (Find_Dispatching_Type (Overridden_Operation (Prim)), Typ,
619 Use_Full_View => True)
620 then
621 Write_Char (',');
622 Write_Int
623 (UI_To_Int (Slot_Number (Overridden_Operation (Prim))));
624 Write_Char (':');
625 Write_Name
626 (Chars (Find_Dispatching_Type (Overridden_Operation (Prim))));
627 end if;
628
629 -- Display overriding of interface primitives
630
631 if Has_Interfaces (Typ) then
632 declare
633 Prim_Elmt : Elmt_Id;
634 Prim_Op : Node_Id;
635 Int_Alias : Entity_Id;
636
637 begin
638 Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
639 while Present (Prim_Elmt) loop
640 Prim_Op := Node (Prim_Elmt);
641 Int_Alias := Interface_Alias (Prim_Op);
642
643 if Present (Int_Alias)
644 and then
645 not Is_Ancestor (Find_Dispatching_Type (Int_Alias), Typ,
646 Use_Full_View => True)
647 and then (Alias (Prim_Op)) = Prim
648 then
649 Write_Char (',');
650 Write_Int (UI_To_Int (Slot_Number (Int_Alias)));
651 Write_Char (':');
652 Write_Name (Chars (Find_Dispatching_Type (Int_Alias)));
653 end if;
654
655 Next_Elmt (Prim_Elmt);
656 end loop;
657 end;
658 end if;
659
660 <<Continue>>
661 Next_Elmt (Elmt);
662 end loop;
663
664 Write_Char ('"');
665 Write_Eol;
666
667 Write_Char ('}');
668 Write_Eol;
669 end Write_Type_Info;
670
671 end Exp_CG;