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