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