?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
[Ada] Unnesting: take inlining (-gnatn) into account
[official-gcc.git] / gcc / ada / exp_unst.adb
blob7cc9a6a4231a7274e5d6c132e088c65fed925c99
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- E X P _ U N S T --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 2014-2019, 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 Debug; use Debug;
28 with Einfo; use Einfo;
29 with Elists; use Elists;
30 with Lib; use Lib;
31 with Namet; use Namet;
32 with Nlists; use Nlists;
33 with Nmake; use Nmake;
34 with Opt;
35 with Output; use Output;
36 with Rtsfind; use Rtsfind;
37 with Sem; use Sem;
38 with Sem_Aux; use Sem_Aux;
39 with Sem_Ch8; use Sem_Ch8;
40 with Sem_Mech; use Sem_Mech;
41 with Sem_Res; use Sem_Res;
42 with Sem_Util; use Sem_Util;
43 with Sinfo; use Sinfo;
44 with Sinput; use Sinput;
45 with Snames; use Snames;
46 with Stand; use Stand;
47 with Tbuild; use Tbuild;
48 with Uintp; use Uintp;
49
50 package body Exp_Unst is
51
52 -----------------------
53 -- Local Subprograms --
54 -----------------------
55
56 procedure Unnest_Subprogram
57 (Subp : Entity_Id; Subp_Body : Node_Id; For_Inline : Boolean := False);
58 -- Subp is a library-level subprogram which has nested subprograms, and
59 -- Subp_Body is the corresponding N_Subprogram_Body node. This procedure
60 -- declares the AREC types and objects, adds assignments to the AREC record
61 -- as required, defines the xxxPTR types for uplevel referenced objects,
62 -- adds the ARECP parameter to all nested subprograms which need it, and
63 -- modifies all uplevel references appropriately. If For_Inline is True,
64 -- we're unnesting this subprogram because it's on the list of inlined
65 -- subprograms and should unnest it despite it not being part of the main
66 -- unit.
67
68 -----------
69 -- Calls --
70 -----------
71
72 -- Table to record calls within the nest being analyzed. These are the
73 -- calls which may need to have an AREC actual added. This table is built
74 -- new for each subprogram nest and cleared at the end of processing each
75 -- subprogram nest.
76
77 type Call_Entry is record
78 N : Node_Id;
79 -- The actual call
80
81 Caller : Entity_Id;
82 -- Entity of the subprogram containing the call (can be at any level)
83
84 Callee : Entity_Id;
85 -- Entity of the subprogram called (always at level 2 or higher). Note
86 -- that in accordance with the basic rules of nesting, the level of To
87 -- is either less than or equal to the level of From, or one greater.
88 end record;
89
90 package Calls is new Table.Table (
91 Table_Component_Type => Call_Entry,
92 Table_Index_Type => Nat,
93 Table_Low_Bound => 1,
94 Table_Initial => 100,
95 Table_Increment => 200,
96 Table_Name => "Unnest_Calls");
97 -- Records each call within the outer subprogram and all nested subprograms
98 -- that are to other subprograms nested within the outer subprogram. These
99 -- are the calls that may need an additional parameter.
100
101 procedure Append_Unique_Call (Call : Call_Entry);
102 -- Append a call entry to the Calls table. A check is made to see if the
103 -- table already contains this entry and if so it has no effect.
104
105 ----------------------------------
106 -- Subprograms For Fat Pointers --
107 ----------------------------------
108
109 function Build_Access_Type_Decl
110 (E : Entity_Id;
111 Scop : Entity_Id) return Node_Id;
112 -- For an uplevel reference that involves an unconstrained array type,
113 -- build an access type declaration for the corresponding activation
114 -- record component. The relevant attributes of the access type are
115 -- set here to avoid a full analysis that would require a scope stack.
116
117 function Needs_Fat_Pointer (E : Entity_Id) return Boolean;
118 -- A formal parameter of an unconstrained array type that appears in an
119 -- uplevel reference requires the construction of an access type, to be
120 -- used in the corresponding component declaration.
121
122 -----------
123 -- Urefs --
124 -----------
125
126 -- Table to record explicit uplevel references to objects (variables,
127 -- constants, formal parameters). These are the references that will
128 -- need rewriting to use the activation table (AREC) pointers. Also
129 -- included are implicit and explicit uplevel references to types, but
130 -- these do not get rewritten by the front end. This table is built new
131 -- for each subprogram nest and cleared at the end of processing each
132 -- subprogram nest.
133
134 type Uref_Entry is record
135 Ref : Node_Id;
136 -- The reference itself. For objects this is always an entity reference
137 -- and the referenced entity will have its Is_Uplevel_Referenced_Entity
138 -- flag set and will appear in the Uplevel_Referenced_Entities list of
139 -- the subprogram declaring this entity.
140
141 Ent : Entity_Id;
142 -- The Entity_Id of the uplevel referenced object or type
143
144 Caller : Entity_Id;
145 -- The entity for the subprogram immediately containing this entity
146
147 Callee : Entity_Id;
148 -- The entity for the subprogram containing the referenced entity. Note
149 -- that the level of Callee must be less than the level of Caller, since
150 -- this is an uplevel reference.
151 end record;
152
153 package Urefs is new Table.Table (
154 Table_Component_Type => Uref_Entry,
155 Table_Index_Type => Nat,
156 Table_Low_Bound => 1,
157 Table_Initial => 100,
158 Table_Increment => 200,
159 Table_Name => "Unnest_Urefs");
160
161 ------------------------
162 -- Append_Unique_Call --
163 ------------------------
164
165 procedure Append_Unique_Call (Call : Call_Entry) is
166 begin
167 for J in Calls.First .. Calls.Last loop
168 if Calls.Table (J) = Call then
169 return;
170 end if;
171 end loop;
172
173 Calls.Append (Call);
174 end Append_Unique_Call;
175
176 -----------------------------
177 -- Build_Access_Type_Decl --
178 -----------------------------
179
180 function Build_Access_Type_Decl
181 (E : Entity_Id;
182 Scop : Entity_Id) return Node_Id
183 is
184 Loc : constant Source_Ptr := Sloc (E);
185 Typ : Entity_Id;
186
187 begin
188 Typ := Make_Temporary (Loc, 'S');
189 Set_Ekind (Typ, E_General_Access_Type);
190 Set_Etype (Typ, Typ);
191 Set_Scope (Typ, Scop);
192 Set_Directly_Designated_Type (Typ, Etype (E));
193
194 return
195 Make_Full_Type_Declaration (Loc,
196 Defining_Identifier => Typ,
197 Type_Definition =>
198 Make_Access_To_Object_Definition (Loc,
199 Subtype_Indication => New_Occurrence_Of (Etype (E), Loc)));
200 end Build_Access_Type_Decl;
201
202 ---------------
203 -- Get_Level --
204 ---------------
205
206 function Get_Level (Subp : Entity_Id; Sub : Entity_Id) return Nat is
207 Lev : Nat;
208 S : Entity_Id;
209
210 begin
211 Lev := 1;
212 S := Sub;
213 loop
214 if S = Subp then
215 return Lev;
216 else
217 Lev := Lev + 1;
218 S := Enclosing_Subprogram (S);
219 end if;
220 end loop;
221 end Get_Level;
222
223 --------------------------
224 -- In_Synchronized_Unit --
225 --------------------------
226
227 function In_Synchronized_Unit (Subp : Entity_Id) return Boolean is
228 S : Entity_Id := Scope (Subp);
229
230 begin
231 while Present (S) and then S /= Standard_Standard loop
232 if Is_Concurrent_Type (S) then
233 return True;
234
235 elsif Is_Private_Type (S)
236 and then Present (Full_View (S))
237 and then Is_Concurrent_Type (Full_View (S))
238 then
239 return True;
240 end if;
241
242 S := Scope (S);
243 end loop;
244
245 return False;
246 end In_Synchronized_Unit;
247
248 -----------------------
249 -- Needs_Fat_Pointer --
250 -----------------------
251
252 function Needs_Fat_Pointer (E : Entity_Id) return Boolean is
253 Typ : Entity_Id;
254 begin
255 if Is_Formal (E) then
256 Typ := Etype (E);
257 if Is_Private_Type (Typ) and then Present (Full_View (Typ)) then
258 Typ := Full_View (Typ);
259 end if;
260
261 return Is_Array_Type (Typ) and then not Is_Constrained (Typ);
262 else
263 return False;
264 end if;
265 end Needs_Fat_Pointer;
266
267 ----------------
268 -- Subp_Index --
269 ----------------
270
271 function Subp_Index (Sub : Entity_Id) return SI_Type is
272 E : Entity_Id := Sub;
273
274 begin
275 pragma Assert (Is_Subprogram (E));
276
277 if Subps_Index (E) = Uint_0 then
278 E := Ultimate_Alias (E);
279
280 -- The body of a protected operation has a different name and
281 -- has been scanned at this point, and thus has an entry in the
282 -- subprogram table.
283
284 if E = Sub and then Convention (E) = Convention_Protected then
285 E := Protected_Body_Subprogram (E);
286 end if;
287
288 if Ekind (E) = E_Function
289 and then Rewritten_For_C (E)
290 and then Present (Corresponding_Procedure (E))
291 then
292 E := Corresponding_Procedure (E);
293 end if;
294 end if;
295
296 pragma Assert (Subps_Index (E) /= Uint_0);
297 return SI_Type (UI_To_Int (Subps_Index (E)));
298 end Subp_Index;
299
300 -----------------------
301 -- Unnest_Subprogram --
302 -----------------------
303
304 procedure Unnest_Subprogram
305 (Subp : Entity_Id; Subp_Body : Node_Id; For_Inline : Boolean := False) is
306 function AREC_Name (J : Pos; S : String) return Name_Id;
307 -- Returns name for string ARECjS, where j is the decimal value of j
308
309 function Enclosing_Subp (Subp : SI_Type) return SI_Type;
310 -- Subp is the index of a subprogram which has a Lev greater than 1.
311 -- This function returns the index of the enclosing subprogram which
312 -- will have a Lev value one less than this.
313
314 function Img_Pos (N : Pos) return String;
315 -- Return image of N without leading blank
316
317 function Upref_Name
318 (Ent : Entity_Id;
319 Index : Pos;
320 Clist : List_Id) return Name_Id;
321 -- This function returns the name to be used in the activation record to
322 -- reference the variable uplevel. Clist is the list of components that
323 -- have been created in the activation record so far. Normally the name
324 -- is just a copy of the Chars field of the entity. The exception is
325 -- when the name has already been used, in which case we suffix the name
326 -- with the index value Index to avoid duplication. This happens with
327 -- declare blocks and generic parameters at least.
328
329 ---------------
330 -- AREC_Name --
331 ---------------
332
333 function AREC_Name (J : Pos; S : String) return Name_Id is
334 begin
335 return Name_Find ("AREC" & Img_Pos (J) & S);
336 end AREC_Name;
337
338 --------------------
339 -- Enclosing_Subp --
340 --------------------
341
342 function Enclosing_Subp (Subp : SI_Type) return SI_Type is
343 STJ : Subp_Entry renames Subps.Table (Subp);
344 Ret : constant SI_Type := Subp_Index (Enclosing_Subprogram (STJ.Ent));
345 begin
346 pragma Assert (STJ.Lev > 1);
347 pragma Assert (Subps.Table (Ret).Lev = STJ.Lev - 1);
348 return Ret;
349 end Enclosing_Subp;
350
351 -------------
352 -- Img_Pos --
353 -------------
354
355 function Img_Pos (N : Pos) return String is
356 Buf : String (1 .. 20);
357 Ptr : Natural;
358 NV : Nat;
359
360 begin
361 Ptr := Buf'Last;
362 NV := N;
363 while NV /= 0 loop
364 Buf (Ptr) := Character'Val (48 + NV mod 10);
365 Ptr := Ptr - 1;
366 NV := NV / 10;
367 end loop;
368
369 return Buf (Ptr + 1 .. Buf'Last);
370 end Img_Pos;
371
372 ----------------
373 -- Upref_Name --
374 ----------------
375
376 function Upref_Name
377 (Ent : Entity_Id;
378 Index : Pos;
379 Clist : List_Id) return Name_Id
380 is
381 C : Node_Id;
382 begin
383 C := First (Clist);
384 loop
385 if No (C) then
386 return Chars (Ent);
387
388 elsif Chars (Defining_Identifier (C)) = Chars (Ent) then
389 return
390 Name_Find (Get_Name_String (Chars (Ent)) & Img_Pos (Index));
391 else
392 Next (C);
393 end if;
394 end loop;
395 end Upref_Name;
396
397 -- Start of processing for Unnest_Subprogram
398
399 begin
400 -- Nothing to do inside a generic (all processing is for instance)
401
402 if Inside_A_Generic then
403 return;
404 end if;
405
406 -- If the main unit is a package body then we need to examine the spec
407 -- to determine whether the main unit is generic (the scope stack is not
408 -- present when this is called on the main unit).
409
410 if not For_Inline
411 and then Ekind (Cunit_Entity (Main_Unit)) = E_Package_Body
412 and then Is_Generic_Unit (Spec_Entity (Cunit_Entity (Main_Unit)))
413 then
414 return;
415
416 -- Only unnest when generating code for the main source unit or if we're
417 -- unnesting for inline.
418
419 elsif not For_Inline
420 and then not In_Extended_Main_Code_Unit (Subp_Body)
421 then
422 return;
423 end if;
424
425 -- This routine is called late, after the scope stack is gone. The
426 -- following creates a suitable dummy scope stack to be used for the
427 -- analyze/expand calls made from this routine.
428
429 Push_Scope (Subp);
430
431 -- First step, we must mark all nested subprograms that require a static
432 -- link (activation record) because either they contain explicit uplevel
433 -- references (as indicated by Is_Uplevel_Referenced_Entity being set at
434 -- this point), or they make calls to other subprograms in the same nest
435 -- that require a static link (in which case we set this flag).
436
437 -- This is a recursive definition, and to implement this, we have to
438 -- build a call graph for the set of nested subprograms, and then go
439 -- over this graph to implement recursively the invariant that if a
440 -- subprogram has a call to a subprogram requiring a static link, then
441 -- the calling subprogram requires a static link.
442
443 -- First populate the above tables
444
445 Subps_First := Subps.Last + 1;
446 Calls.Init;
447 Urefs.Init;
448
449 Build_Tables : declare
450 Current_Subprogram : Entity_Id := Empty;
451 -- When we scan a subprogram body, we set Current_Subprogram to the
452 -- corresponding entity. This gets recursively saved and restored.
453
454 function Visit_Node (N : Node_Id) return Traverse_Result;
455 -- Visit a single node in Subp
456
457 -----------
458 -- Visit --
459 -----------
460
461 procedure Visit is new Traverse_Proc (Visit_Node);
462 -- Used to traverse the body of Subp, populating the tables
463
464 ----------------
465 -- Visit_Node --
466 ----------------
467
468 function Visit_Node (N : Node_Id) return Traverse_Result is
469 Ent : Entity_Id;
470 Caller : Entity_Id;
471 Callee : Entity_Id;
472
473 procedure Check_Static_Type
474 (T : Entity_Id;
475 N : Node_Id;
476 DT : in out Boolean;
477 Check_Designated : Boolean := False);
478 -- Given a type T, checks if it is a static type defined as a type
479 -- with no dynamic bounds in sight. If so, the only action is to
480 -- set Is_Static_Type True for T. If T is not a static type, then
481 -- all types with dynamic bounds associated with T are detected,
482 -- and their bounds are marked as uplevel referenced if not at the
483 -- library level, and DT is set True. If N is specified, it's the
484 -- node that will need to be replaced. If not specified, it means
485 -- we can't do a replacement because the bound is implicit.
486
487 -- If Check_Designated is True and T or its full view is an access
488 -- type, check whether the designated type has dynamic bounds.
489
490 procedure Note_Uplevel_Ref
491 (E : Entity_Id;
492 N : Node_Id;
493 Caller : Entity_Id;
494 Callee : Entity_Id);
495 -- Called when we detect an explicit or implicit uplevel reference
496 -- from within Caller to entity E declared in Callee. E can be a
497 -- an object or a type.
498
499 procedure Register_Subprogram (E : Entity_Id; Bod : Node_Id);
500 -- Enter a subprogram whose body is visible or which is a
501 -- subprogram instance into the subprogram table.
502
503 -----------------------
504 -- Check_Static_Type --
505 -----------------------
506
507 procedure Check_Static_Type
508 (T : Entity_Id;
509 N : Node_Id;
510 DT : in out Boolean;
511 Check_Designated : Boolean := False)
512 is
513 procedure Note_Uplevel_Bound (N : Node_Id; Ref : Node_Id);
514 -- N is the bound of a dynamic type. This procedure notes that
515 -- this bound is uplevel referenced, it can handle references
516 -- to entities (typically _FIRST and _LAST entities), and also
517 -- attribute references of the form T'name (name is typically
518 -- FIRST or LAST) where T is the uplevel referenced bound.
519 -- Ref, if Present, is the location of the reference to
520 -- replace.
521
522 ------------------------
523 -- Note_Uplevel_Bound --
524 ------------------------
525
526 procedure Note_Uplevel_Bound (N : Node_Id; Ref : Node_Id) is
527 begin
528 -- Entity name case. Make sure that the entity is declared
529 -- in a subprogram. This may not be the case for for a type
530 -- in a loop appearing in a precondition.
531 -- Exclude explicitly discriminants (that can appear
532 -- in bounds of discriminated components).
533
534 if Is_Entity_Name (N) then
535 if Present (Entity (N))
536 and then not Is_Type (Entity (N))
537 and then Present (Enclosing_Subprogram (Entity (N)))
538 and then Ekind (Entity (N)) /= E_Discriminant
539 then
540 Note_Uplevel_Ref
541 (E => Entity (N),
542 N => Empty,
543 Caller => Current_Subprogram,
544 Callee => Enclosing_Subprogram (Entity (N)));
545 end if;
546
547 -- Attribute or indexed component case
548
549 elsif Nkind_In (N, N_Attribute_Reference,
550 N_Indexed_Component)
551 then
552 Note_Uplevel_Bound (Prefix (N), Ref);
553
554 -- The indices of the indexed components, or the
555 -- associated expressions of an attribute reference,
556 -- may also involve uplevel references.
557
558 declare
559 Expr : Node_Id;
560
561 begin
562 Expr := First (Expressions (N));
563 while Present (Expr) loop
564 Note_Uplevel_Bound (Expr, Ref);
565 Next (Expr);
566 end loop;
567 end;
568
569 -- The type of the prefix may be have an uplevel
570 -- reference if this needs bounds.
571
572 if Nkind (N) = N_Attribute_Reference then
573 declare
574 Attr : constant Attribute_Id :=
575 Get_Attribute_Id (Attribute_Name (N));
576 DT : Boolean := False;
577
578 begin
579 if (Attr = Attribute_First
580 or else Attr = Attribute_Last
581 or else Attr = Attribute_Length)
582 and then Is_Constrained (Etype (Prefix (N)))
583 then
584 Check_Static_Type
585 (Etype (Prefix (N)), Empty, DT);
586 end if;
587 end;
588 end if;
589
590 -- Binary operator cases. These can apply to arrays for
591 -- which we may need bounds.
592
593 elsif Nkind (N) in N_Binary_Op then
594 Note_Uplevel_Bound (Left_Opnd (N), Ref);
595 Note_Uplevel_Bound (Right_Opnd (N), Ref);
596
597 -- Unary operator case
598
599 elsif Nkind (N) in N_Unary_Op then
600 Note_Uplevel_Bound (Right_Opnd (N), Ref);
601
602 -- Explicit dereference and selected component case
603
604 elsif Nkind_In (N, N_Explicit_Dereference,
605 N_Selected_Component)
606 then
607 Note_Uplevel_Bound (Prefix (N), Ref);
608
609 -- Conditional expressions
610
611 elsif Nkind (N) = N_If_Expression then
612 declare
613 Expr : Node_Id;
614
615 begin
616 Expr := First (Expressions (N));
617 while Present (Expr) loop
618 Note_Uplevel_Bound (Expr, Ref);
619 Next (Expr);
620 end loop;
621 end;
622
623 elsif Nkind (N) = N_Case_Expression then
624 declare
625 Alternative : Node_Id;
626
627 begin
628 Note_Uplevel_Bound (Expression (N), Ref);
629
630 Alternative := First (Alternatives (N));
631 while Present (Alternative) loop
632 Note_Uplevel_Bound (Expression (Alternative), Ref);
633 end loop;
634 end;
635
636 -- Conversion case
637
638 elsif Nkind (N) = N_Type_Conversion then
639 Note_Uplevel_Bound (Expression (N), Ref);
640 end if;
641 end Note_Uplevel_Bound;
642
643 -- Start of processing for Check_Static_Type
644
645 begin
646 -- If already marked static, immediate return
647
648 if Is_Static_Type (T) and then not Check_Designated then
649 return;
650 end if;
651
652 -- If the type is at library level, always consider it static,
653 -- since such uplevel references are irrelevant.
654
655 if Is_Library_Level_Entity (T) then
656 Set_Is_Static_Type (T);
657 return;
658 end if;
659
660 -- Otherwise figure out what the story is with this type
661
662 -- For a scalar type, check bounds
663
664 if Is_Scalar_Type (T) then
665
666 -- If both bounds static, then this is a static type
667
668 declare
669 LB : constant Node_Id := Type_Low_Bound (T);
670 UB : constant Node_Id := Type_High_Bound (T);
671
672 begin
673 if not Is_Static_Expression (LB) then
674 Note_Uplevel_Bound (LB, N);
675 DT := True;
676 end if;
677
678 if not Is_Static_Expression (UB) then
679 Note_Uplevel_Bound (UB, N);
680 DT := True;
681 end if;
682 end;
683
684 -- For record type, check all components and discriminant
685 -- constraints if present.
686
687 elsif Is_Record_Type (T) then
688 declare
689 C : Entity_Id;
690 D : Elmt_Id;
691
692 begin
693 C := First_Component_Or_Discriminant (T);
694 while Present (C) loop
695 Check_Static_Type (Etype (C), N, DT);
696 Next_Component_Or_Discriminant (C);
697 end loop;
698
699 if Has_Discriminants (T)
700 and then Present (Discriminant_Constraint (T))
701 then
702 D := First_Elmt (Discriminant_Constraint (T));
703 while Present (D) loop
704 if not Is_Static_Expression (Node (D)) then
705 Note_Uplevel_Bound (Node (D), N);
706 DT := True;
707 end if;
708
709 Next_Elmt (D);
710 end loop;
711 end if;
712 end;
713
714 -- For array type, check index types and component type
715
716 elsif Is_Array_Type (T) then
717 declare
718 IX : Node_Id;
719 begin
720 Check_Static_Type (Component_Type (T), N, DT);
721
722 IX := First_Index (T);
723 while Present (IX) loop
724 Check_Static_Type (Etype (IX), N, DT);
725 Next_Index (IX);
726 end loop;
727 end;
728
729 -- For private type, examine whether full view is static
730
731 elsif Is_Incomplete_Or_Private_Type (T)
732 and then Present (Full_View (T))
733 then
734 Check_Static_Type (Full_View (T), N, DT, Check_Designated);
735
736 if Is_Static_Type (Full_View (T)) then
737 Set_Is_Static_Type (T);
738 end if;
739
740 -- For access types, check designated type when required
741
742 elsif Is_Access_Type (T) and then Check_Designated then
743 Check_Static_Type (Directly_Designated_Type (T), N, DT);
744
745 -- For now, ignore other types
746
747 else
748 return;
749 end if;
750
751 if not DT then
752 Set_Is_Static_Type (T);
753 end if;
754 end Check_Static_Type;
755
756 ----------------------
757 -- Note_Uplevel_Ref --
758 ----------------------
759
760 procedure Note_Uplevel_Ref
761 (E : Entity_Id;
762 N : Node_Id;
763 Caller : Entity_Id;
764 Callee : Entity_Id)
765 is
766 Full_E : Entity_Id := E;
767 begin
768 -- Nothing to do for static type
769
770 if Is_Static_Type (E) then
771 return;
772 end if;
773
774 -- Nothing to do if Caller and Callee are the same
775
776 if Caller = Callee then
777 return;
778
779 -- Callee may be a function that returns an array, and that has
780 -- been rewritten as a procedure. If caller is that procedure,
781 -- nothing to do either.
782
783 elsif Ekind (Callee) = E_Function
784 and then Rewritten_For_C (Callee)
785 and then Corresponding_Procedure (Callee) = Caller
786 then
787 return;
788
789 elsif Ekind_In (Callee, E_Entry, E_Entry_Family) then
790 return;
791 end if;
792
793 -- We have a new uplevel referenced entity
794
795 if Ekind (E) = E_Constant and then Present (Full_View (E)) then
796 Full_E := Full_View (E);
797 end if;
798
799 -- All we do at this stage is to add the uplevel reference to
800 -- the table. It's too early to do anything else, since this
801 -- uplevel reference may come from an unreachable subprogram
802 -- in which case the entry will be deleted.
803
804 Urefs.Append ((N, Full_E, Caller, Callee));
805 end Note_Uplevel_Ref;
806
807 -------------------------
808 -- Register_Subprogram --
809 -------------------------
810
811 procedure Register_Subprogram (E : Entity_Id; Bod : Node_Id) is
812 L : constant Nat := Get_Level (Subp, E);
813
814 begin
815 -- Subprograms declared in tasks and protected types cannot be
816 -- eliminated because calls to them may be in other units, so
817 -- they must be treated as reachable.
818
819 Subps.Append
820 ((Ent => E,
821 Bod => Bod,
822 Lev => L,
823 Reachable => In_Synchronized_Unit (E)
824 or else Address_Taken (E),
825 Uplevel_Ref => L,
826 Declares_AREC => False,
827 Uents => No_Elist,
828 Last => 0,
829 ARECnF => Empty,
830 ARECn => Empty,
831 ARECnT => Empty,
832 ARECnPT => Empty,
833 ARECnP => Empty,
834 ARECnU => Empty));
835
836 Set_Subps_Index (E, UI_From_Int (Subps.Last));
837
838 -- If we marked this reachable because it's in a synchronized
839 -- unit, we have to mark all enclosing subprograms as reachable
840 -- as well.
841
842 if In_Synchronized_Unit (E) then
843 declare
844 S : Entity_Id := E;
845
846 begin
847 for J in reverse 1 .. L - 1 loop
848 S := Enclosing_Subprogram (S);
849 Subps.Table (Subp_Index (S)).Reachable := True;
850 end loop;
851 end;
852 end if;
853 end Register_Subprogram;
854
855 -- Start of processing for Visit_Node
856
857 begin
858 case Nkind (N) is
859
860 -- Record a subprogram call
861
862 when N_Function_Call
863 | N_Procedure_Call_Statement
864 =>
865 -- We are only interested in direct calls, not indirect
866 -- calls (where Name (N) is an explicit dereference) at
867 -- least for now!
868
869 if Nkind (Name (N)) in N_Has_Entity then
870 Ent := Entity (Name (N));
871
872 -- We are only interested in calls to subprograms nested
873 -- within Subp. Calls to Subp itself or to subprograms
874 -- outside the nested structure do not affect us.
875
876 if Scope_Within (Ent, Subp)
877 and then Is_Subprogram (Ent)
878 and then not Is_Imported (Ent)
879 then
880 Append_Unique_Call ((N, Current_Subprogram, Ent));
881 end if;
882 end if;
883
884 -- For all calls where the formal is an unconstrained array
885 -- and the actual is constrained we need to check the bounds
886 -- for uplevel references.
887
888 declare
889 Actual : Entity_Id;
890 DT : Boolean := False;
891 Formal : Node_Id;
892 Subp : Entity_Id;
893
894 begin
895 if Nkind (Name (N)) = N_Explicit_Dereference then
896 Subp := Etype (Name (N));
897 else
898 Subp := Entity (Name (N));
899 end if;
900
901 Actual := First_Actual (N);
902 Formal := First_Formal_With_Extras (Subp);
903 while Present (Actual) loop
904 if Is_Array_Type (Etype (Formal))
905 and then not Is_Constrained (Etype (Formal))
906 and then Is_Constrained (Etype (Actual))
907 then
908 Check_Static_Type (Etype (Actual), Empty, DT);
909 end if;
910
911 Next_Actual (Actual);
912 Next_Formal_With_Extras (Formal);
913 end loop;
914 end;
915
916 -- An At_End_Proc in a statement sequence indicates that there
917 -- is a call from the enclosing construct or block to that
918 -- subprogram. As above, the called entity must be local and
919 -- not imported.
920
921 when N_Handled_Sequence_Of_Statements =>
922 if Present (At_End_Proc (N))
923 and then Scope_Within (Entity (At_End_Proc (N)), Subp)
924 and then not Is_Imported (Entity (At_End_Proc (N)))
925 then
926 Append_Unique_Call
927 ((N, Current_Subprogram, Entity (At_End_Proc (N))));
928 end if;
929
930 -- Similarly, the following constructs include a semantic
931 -- attribute Procedure_To_Call that must be handled like
932 -- other calls. Likewise for attribute Storage_Pool.
933
934 when N_Allocator
935 | N_Extended_Return_Statement
936 | N_Free_Statement
937 | N_Simple_Return_Statement
938 =>
939 declare
940 Pool : constant Entity_Id := Storage_Pool (N);
941 Proc : constant Entity_Id := Procedure_To_Call (N);
942
943 begin
944 if Present (Proc)
945 and then Scope_Within (Proc, Subp)
946 and then not Is_Imported (Proc)
947 then
948 Append_Unique_Call ((N, Current_Subprogram, Proc));
949 end if;
950
951 if Present (Pool)
952 and then not Is_Library_Level_Entity (Pool)
953 and then Scope_Within_Or_Same (Scope (Pool), Subp)
954 then
955 Caller := Current_Subprogram;
956 Callee := Enclosing_Subprogram (Pool);
957
958 if Callee /= Caller then
959 Note_Uplevel_Ref (Pool, Empty, Caller, Callee);
960 end if;
961 end if;
962 end;
963
964 -- For an allocator with a qualified expression, check type
965 -- of expression being qualified. The explicit type name is
966 -- handled as an entity reference.
967
968 if Nkind (N) = N_Allocator
969 and then Nkind (Expression (N)) = N_Qualified_Expression
970 then
971 declare
972 DT : Boolean := False;
973 begin
974 Check_Static_Type
975 (Etype (Expression (Expression (N))), Empty, DT);
976 end;
977
978 -- For a Return or Free (all other nodes we handle here),
979 -- we usually need the size of the object, so we need to be
980 -- sure that any nonstatic bounds of the expression's type
981 -- that are uplevel are handled.
982
983 elsif Nkind (N) /= N_Allocator
984 and then Present (Expression (N))
985 then
986 declare
987 DT : Boolean := False;
988 begin
989 Check_Static_Type
990 (Etype (Expression (N)),
991 Empty,
992 DT,
993 Check_Designated => Nkind (N) = N_Free_Statement);
994 end;
995 end if;
996
997 -- A 'Access reference is a (potential) call. So is 'Address,
998 -- in particular on imported subprograms. Other attributes
999 -- require special handling.
1000
1001 when N_Attribute_Reference =>
1002 declare
1003 Attr : constant Attribute_Id :=
1004 Get_Attribute_Id (Attribute_Name (N));
1005 begin
1006 case Attr is
1007 when Attribute_Access
1008 | Attribute_Unchecked_Access
1009 | Attribute_Unrestricted_Access
1010 | Attribute_Address
1011 =>
1012 if Nkind (Prefix (N)) in N_Has_Entity then
1013 Ent := Entity (Prefix (N));
1014
1015 -- We only need to examine calls to subprograms
1016 -- nested within current Subp.
1017
1018 if Scope_Within (Ent, Subp) then
1019 if Is_Imported (Ent) then
1020 null;
1021
1022 elsif Is_Subprogram (Ent) then
1023 Append_Unique_Call
1024 ((N, Current_Subprogram, Ent));
1025 end if;
1026 end if;
1027 end if;
1028
1029 -- References to bounds can be uplevel references if
1030 -- the type isn't static.
1031
1032 when Attribute_First
1033 | Attribute_Last
1034 | Attribute_Length
1035 =>
1036 -- Special-case attributes of objects whose bounds
1037 -- may be uplevel references. More complex prefixes
1038 -- handled during full traversal. Note that if the
1039 -- nominal subtype of the prefix is unconstrained,
1040 -- the bound must be obtained from the object, not
1041 -- from the (possibly) uplevel reference.
1042
1043 if Is_Constrained (Etype (Prefix (N))) then
1044 declare
1045 DT : Boolean := False;
1046 begin
1047 Check_Static_Type
1048 (Etype (Prefix (N)), Empty, DT);
1049 end;
1050
1051 return OK;
1052 end if;
1053
1054 when others =>
1055 null;
1056 end case;
1057 end;
1058
1059 -- Component associations in aggregates are either static or
1060 -- else the aggregate will be expanded into assignments, in
1061 -- which case the expression is analyzed later and provides
1062 -- no relevant code generation.
1063
1064 when N_Component_Association =>
1065 if No (Expression (N))
1066 or else No (Etype (Expression (N)))
1067 then
1068 return Skip;
1069 end if;
1070
1071 -- Generic associations are not analyzed: the actuals are
1072 -- transferred to renaming and subtype declarations that
1073 -- are the ones that must be examined.
1074
1075 when N_Generic_Association =>
1076 return Skip;
1077
1078 -- Indexed references can be uplevel if the type isn't static
1079 -- and if the lower bound (or an inner bound for a multi-
1080 -- dimensional array) is uplevel.
1081
1082 when N_Indexed_Component
1083 | N_Slice
1084 =>
1085 if Is_Constrained (Etype (Prefix (N))) then
1086 declare
1087 DT : Boolean := False;
1088 begin
1089 Check_Static_Type (Etype (Prefix (N)), Empty, DT);
1090 end;
1091 end if;
1092
1093 -- A selected component can have an implicit up-level
1094 -- reference due to the bounds of previous fields in the
1095 -- record. We simplify the processing here by examining
1096 -- all components of the record.
1097
1098 -- Selected components appear as unit names and end labels
1099 -- for child units. Prefixes of these nodes denote parent
1100 -- units and carry no type information so they are skipped.
1101
1102 when N_Selected_Component =>
1103 if Present (Etype (Prefix (N))) then
1104 declare
1105 DT : Boolean := False;
1106 begin
1107 Check_Static_Type (Etype (Prefix (N)), Empty, DT);
1108 end;
1109 end if;
1110
1111 -- For EQ/NE comparisons, we need the type of the operands
1112 -- in order to do the comparison, which means we need the
1113 -- bounds.
1114
1115 when N_Op_Eq
1116 | N_Op_Ne
1117 =>
1118 declare
1119 DT : Boolean := False;
1120 begin
1121 Check_Static_Type (Etype (Left_Opnd (N)), Empty, DT);
1122 Check_Static_Type (Etype (Right_Opnd (N)), Empty, DT);
1123 end;
1124
1125 -- Likewise we need the sizes to compute how much to move in
1126 -- an assignment.
1127
1128 when N_Assignment_Statement =>
1129 declare
1130 DT : Boolean := False;
1131 begin
1132 Check_Static_Type (Etype (Name (N)), Empty, DT);
1133 Check_Static_Type (Etype (Expression (N)), Empty, DT);
1134 end;
1135
1136 -- Record a subprogram. We record a subprogram body that acts
1137 -- as a spec. Otherwise we record a subprogram declaration,
1138 -- providing that it has a corresponding body we can get hold
1139 -- of. The case of no corresponding body being available is
1140 -- ignored for now.
1141
1142 when N_Subprogram_Body =>
1143 Ent := Unique_Defining_Entity (N);
1144
1145 -- Ignore generic subprogram
1146
1147 if Is_Generic_Subprogram (Ent) then
1148 return Skip;
1149 end if;
1150
1151 -- Make new entry in subprogram table if not already made
1152
1153 Register_Subprogram (Ent, N);
1154
1155 -- We make a recursive call to scan the subprogram body, so
1156 -- that we can save and restore Current_Subprogram.
1157
1158 declare
1159 Save_CS : constant Entity_Id := Current_Subprogram;
1160 Decl : Node_Id;
1161
1162 begin
1163 Current_Subprogram := Ent;
1164
1165 -- Scan declarations
1166
1167 Decl := First (Declarations (N));
1168 while Present (Decl) loop
1169 Visit (Decl);
1170 Next (Decl);
1171 end loop;
1172
1173 -- Scan statements
1174
1175 Visit (Handled_Statement_Sequence (N));
1176
1177 -- Restore current subprogram setting
1178
1179 Current_Subprogram := Save_CS;
1180 end;
1181
1182 -- Now at this level, return skipping the subprogram body
1183 -- descendants, since we already took care of them!
1184
1185 return Skip;
1186
1187 -- If we have a body stub, visit the associated subunit, which
1188 -- is a semantic descendant of the stub.
1189
1190 when N_Body_Stub =>
1191 Visit (Library_Unit (N));
1192
1193 -- A declaration of a wrapper package indicates a subprogram
1194 -- instance for which there is no explicit body. Enter the
1195 -- subprogram instance in the table.
1196
1197 when N_Package_Declaration =>
1198 if Is_Wrapper_Package (Defining_Entity (N)) then
1199 Register_Subprogram
1200 (Related_Instance (Defining_Entity (N)), Empty);
1201 end if;
1202
1203 -- Skip generic declarations
1204
1205 when N_Generic_Declaration =>
1206 return Skip;
1207
1208 -- Skip generic package body
1209
1210 when N_Package_Body =>
1211 if Present (Corresponding_Spec (N))
1212 and then Ekind (Corresponding_Spec (N)) = E_Generic_Package
1213 then
1214 return Skip;
1215 end if;
1216
1217 -- Pragmas and component declarations are ignored. Quantified
1218 -- expressions are expanded into explicit loops and the
1219 -- original epression must be ignored.
1220
1221 when N_Component_Declaration
1222 | N_Pragma
1223 | N_Quantified_Expression
1224 =>
1225 return Skip;
1226
1227 -- We want to skip the function spec for a generic function
1228 -- to avoid looking at any generic types that might be in
1229 -- its formals.
1230
1231 when N_Function_Specification =>
1232 if Is_Generic_Subprogram (Unique_Defining_Entity (N)) then
1233 return Skip;
1234 end if;
1235
1236 -- Otherwise record an uplevel reference in a local identifier
1237
1238 when others =>
1239 if Nkind (N) in N_Has_Entity
1240 and then Present (Entity (N))
1241 then
1242 Ent := Entity (N);
1243
1244 -- Only interested in entities declared within our nest
1245
1246 if not Is_Library_Level_Entity (Ent)
1247 and then Scope_Within_Or_Same (Scope (Ent), Subp)
1248
1249 -- Skip entities defined in inlined subprograms
1250
1251 and then
1252 Chars (Enclosing_Subprogram (Ent)) /= Name_uParent
1253
1254 -- Constants and variables are potentially uplevel
1255 -- references to global declarations.
1256
1257 and then
1258 (Ekind_In (Ent, E_Constant,
1259 E_Loop_Parameter,
1260 E_Variable)
1261
1262 -- Formals are interesting, but not if being used
1263 -- as mere names of parameters for name notation
1264 -- calls.
1265
1266 or else
1267 (Is_Formal (Ent)
1268 and then not
1269 (Nkind (Parent (N)) = N_Parameter_Association
1270 and then Selector_Name (Parent (N)) = N))
1271
1272 -- Types other than known Is_Static types are
1273 -- potentially interesting.
1274
1275 or else
1276 (Is_Type (Ent) and then not Is_Static_Type (Ent)))
1277 then
1278 -- Here we have a potentially interesting uplevel
1279 -- reference to examine.
1280
1281 if Is_Type (Ent) then
1282 declare
1283 DT : Boolean := False;
1284
1285 begin
1286 Check_Static_Type (Ent, N, DT);
1287 return OK;
1288 end;
1289 end if;
1290
1291 Caller := Current_Subprogram;
1292 Callee := Enclosing_Subprogram (Ent);
1293
1294 if Callee /= Caller
1295 and then (not Is_Static_Type (Ent)
1296 or else Needs_Fat_Pointer (Ent))
1297 then
1298 Note_Uplevel_Ref (Ent, N, Caller, Callee);
1299
1300 -- Check the type of a formal parameter of the current
1301 -- subprogram, whose formal type may be an uplevel
1302 -- reference.
1303
1304 elsif Is_Formal (Ent)
1305 and then Scope (Ent) = Current_Subprogram
1306 then
1307 declare
1308 DT : Boolean := False;
1309
1310 begin
1311 Check_Static_Type (Etype (Ent), Empty, DT);
1312 end;
1313 end if;
1314 end if;
1315 end if;
1316 end case;
1317
1318 -- Fall through to continue scanning children of this node
1319
1320 return OK;
1321 end Visit_Node;
1322
1323 -- Start of processing for Build_Tables
1324
1325 begin
1326 -- Traverse the body to get subprograms, calls and uplevel references
1327
1328 Visit (Subp_Body);
1329 end Build_Tables;
1330
1331 -- Now do the first transitive closure which determines which
1332 -- subprograms in the nest are actually reachable.
1333
1334 Reachable_Closure : declare
1335 Modified : Boolean;
1336
1337 begin
1338 Subps.Table (Subps_First).Reachable := True;
1339
1340 -- We use a simple minded algorithm as follows (obviously this can
1341 -- be done more efficiently, using one of the standard algorithms
1342 -- for efficient transitive closure computation, but this is simple
1343 -- and most likely fast enough that its speed does not matter).
1344
1345 -- Repeatedly scan the list of calls. Any time we find a call from
1346 -- A to B, where A is reachable, but B is not, then B is reachable,
1347 -- and note that we have made a change by setting Modified True. We
1348 -- repeat this until we make a pass with no modifications.
1349
1350 Outer : loop
1351 Modified := False;
1352 Inner : for J in Calls.First .. Calls.Last loop
1353 declare
1354 CTJ : Call_Entry renames Calls.Table (J);
1355
1356 SINF : constant SI_Type := Subp_Index (CTJ.Caller);
1357 SINT : constant SI_Type := Subp_Index (CTJ.Callee);
1358
1359 SUBF : Subp_Entry renames Subps.Table (SINF);
1360 SUBT : Subp_Entry renames Subps.Table (SINT);
1361
1362 begin
1363 if SUBF.Reachable and then not SUBT.Reachable then
1364 SUBT.Reachable := True;
1365 Modified := True;
1366 end if;
1367 end;
1368 end loop Inner;
1369
1370 exit Outer when not Modified;
1371 end loop Outer;
1372 end Reachable_Closure;
1373
1374 -- Remove calls from unreachable subprograms
1375
1376 declare
1377 New_Index : Nat;
1378
1379 begin
1380 New_Index := 0;
1381 for J in Calls.First .. Calls.Last loop
1382 declare
1383 CTJ : Call_Entry renames Calls.Table (J);
1384
1385 SINF : constant SI_Type := Subp_Index (CTJ.Caller);
1386 SINT : constant SI_Type := Subp_Index (CTJ.Callee);
1387
1388 SUBF : Subp_Entry renames Subps.Table (SINF);
1389 SUBT : Subp_Entry renames Subps.Table (SINT);
1390
1391 begin
1392 if SUBF.Reachable then
1393 pragma Assert (SUBT.Reachable);
1394 New_Index := New_Index + 1;
1395 Calls.Table (New_Index) := Calls.Table (J);
1396 end if;
1397 end;
1398 end loop;
1399
1400 Calls.Set_Last (New_Index);
1401 end;
1402
1403 -- Remove uplevel references from unreachable subprograms
1404
1405 declare
1406 New_Index : Nat;
1407
1408 begin
1409 New_Index := 0;
1410 for J in Urefs.First .. Urefs.Last loop
1411 declare
1412 URJ : Uref_Entry renames Urefs.Table (J);
1413
1414 SINF : constant SI_Type := Subp_Index (URJ.Caller);
1415 SINT : constant SI_Type := Subp_Index (URJ.Callee);
1416
1417 SUBF : Subp_Entry renames Subps.Table (SINF);
1418 SUBT : Subp_Entry renames Subps.Table (SINT);
1419
1420 S : Entity_Id;
1421
1422 begin
1423 -- Keep reachable reference
1424
1425 if SUBF.Reachable then
1426 New_Index := New_Index + 1;
1427 Urefs.Table (New_Index) := Urefs.Table (J);
1428
1429 -- And since we know we are keeping this one, this is a good
1430 -- place to fill in information for a good reference.
1431
1432 -- Mark all enclosing subprograms need to declare AREC
1433
1434 S := URJ.Caller;
1435 loop
1436 S := Enclosing_Subprogram (S);
1437
1438 -- If we are at the top level, as can happen with
1439 -- references to formals in aspects of nested subprogram
1440 -- declarations, there are no further subprograms to mark
1441 -- as requiring activation records.
1442
1443 exit when No (S);
1444
1445 declare
1446 SUBI : Subp_Entry renames Subps.Table (Subp_Index (S));
1447 begin
1448 SUBI.Declares_AREC := True;
1449
1450 -- If this entity was marked reachable because it is
1451 -- in a task or protected type, there may not appear
1452 -- to be any calls to it, which would normally adjust
1453 -- the levels of the parent subprograms. So we need to
1454 -- be sure that the uplevel reference of that entity
1455 -- takes into account possible calls.
1456
1457 if In_Synchronized_Unit (SUBF.Ent)
1458 and then SUBT.Lev < SUBI.Uplevel_Ref
1459 then
1460 SUBI.Uplevel_Ref := SUBT.Lev;
1461 end if;
1462 end;
1463
1464 exit when S = URJ.Callee;
1465 end loop;
1466
1467 -- Add to list of uplevel referenced entities for Callee.
1468 -- We do not add types to this list, only actual references
1469 -- to objects that will be referenced uplevel, and we use
1470 -- the flag Is_Uplevel_Referenced_Entity to avoid making
1471 -- duplicate entries in the list. Discriminants are also
1472 -- excluded, only the enclosing object can appear in the
1473 -- list.
1474
1475 if not Is_Uplevel_Referenced_Entity (URJ.Ent)
1476 and then Ekind (URJ.Ent) /= E_Discriminant
1477 then
1478 Set_Is_Uplevel_Referenced_Entity (URJ.Ent);
1479 Append_New_Elmt (URJ.Ent, SUBT.Uents);
1480 end if;
1481
1482 -- And set uplevel indication for caller
1483
1484 if SUBT.Lev < SUBF.Uplevel_Ref then
1485 SUBF.Uplevel_Ref := SUBT.Lev;
1486 end if;
1487 end if;
1488 end;
1489 end loop;
1490
1491 Urefs.Set_Last (New_Index);
1492 end;
1493
1494 -- Remove unreachable subprograms from Subps table. Note that we do
1495 -- this after eliminating entries from the other two tables, since
1496 -- those elimination steps depend on referencing the Subps table.
1497
1498 declare
1499 New_SI : SI_Type;
1500
1501 begin
1502 New_SI := Subps_First - 1;
1503 for J in Subps_First .. Subps.Last loop
1504 declare
1505 STJ : Subp_Entry renames Subps.Table (J);
1506 Spec : Node_Id;
1507 Decl : Node_Id;
1508
1509 begin
1510 -- Subprogram is reachable, copy and reset index
1511
1512 if STJ.Reachable then
1513 New_SI := New_SI + 1;
1514 Subps.Table (New_SI) := STJ;
1515 Set_Subps_Index (STJ.Ent, UI_From_Int (New_SI));
1516
1517 -- Subprogram is not reachable
1518
1519 else
1520 -- Clear index, since no longer active
1521
1522 Set_Subps_Index (Subps.Table (J).Ent, Uint_0);
1523
1524 -- Output debug information if -gnatd.3 set
1525
1526 if Debug_Flag_Dot_3 then
1527 Write_Str ("Eliminate ");
1528 Write_Name (Chars (Subps.Table (J).Ent));
1529 Write_Str (" at ");
1530 Write_Location (Sloc (Subps.Table (J).Ent));
1531 Write_Str (" (not referenced)");
1532 Write_Eol;
1533 end if;
1534
1535 -- Rewrite declaration, body, and corresponding freeze node
1536 -- to null statements.
1537
1538 -- A subprogram instantiation does not have an explicit
1539 -- body. If unused, we could remove the corresponding
1540 -- wrapper package and its body (TBD).
1541
1542 if Present (STJ.Bod) then
1543 Spec := Corresponding_Spec (STJ.Bod);
1544
1545 if Present (Spec) then
1546 Decl := Parent (Declaration_Node (Spec));
1547 Rewrite (Decl, Make_Null_Statement (Sloc (Decl)));
1548
1549 if Present (Freeze_Node (Spec)) then
1550 Rewrite (Freeze_Node (Spec),
1551 Make_Null_Statement (Sloc (Decl)));
1552 end if;
1553 end if;
1554
1555 Rewrite (STJ.Bod, Make_Null_Statement (Sloc (STJ.Bod)));
1556 end if;
1557 end if;
1558 end;
1559 end loop;
1560
1561 Subps.Set_Last (New_SI);
1562 end;
1563
1564 -- Now it is time for the second transitive closure, which follows calls
1565 -- and makes sure that A calls B, and B has uplevel references, then A
1566 -- is also marked as having uplevel references.
1567
1568 Closure_Uplevel : declare
1569 Modified : Boolean;
1570
1571 begin
1572 -- We use a simple minded algorithm as follows (obviously this can
1573 -- be done more efficiently, using one of the standard algorithms
1574 -- for efficient transitive closure computation, but this is simple
1575 -- and most likely fast enough that its speed does not matter).
1576
1577 -- Repeatedly scan the list of calls. Any time we find a call from
1578 -- A to B, where B has uplevel references, make sure that A is marked
1579 -- as having at least the same level of uplevel referencing.
1580
1581 Outer2 : loop
1582 Modified := False;
1583 Inner2 : for J in Calls.First .. Calls.Last loop
1584 declare
1585 CTJ : Call_Entry renames Calls.Table (J);
1586 SINF : constant SI_Type := Subp_Index (CTJ.Caller);
1587 SINT : constant SI_Type := Subp_Index (CTJ.Callee);
1588 SUBF : Subp_Entry renames Subps.Table (SINF);
1589 SUBT : Subp_Entry renames Subps.Table (SINT);
1590 begin
1591 if SUBT.Lev > SUBT.Uplevel_Ref
1592 and then SUBF.Uplevel_Ref > SUBT.Uplevel_Ref
1593 then
1594 SUBF.Uplevel_Ref := SUBT.Uplevel_Ref;
1595 Modified := True;
1596 end if;
1597 end;
1598 end loop Inner2;
1599
1600 exit Outer2 when not Modified;
1601 end loop Outer2;
1602 end Closure_Uplevel;
1603
1604 -- We have one more step before the tables are complete. An uplevel
1605 -- call from subprogram A to subprogram B where subprogram B has uplevel
1606 -- references is in effect an uplevel reference, and must arrange for
1607 -- the proper activation link to be passed.
1608
1609 for J in Calls.First .. Calls.Last loop
1610 declare
1611 CTJ : Call_Entry renames Calls.Table (J);
1612
1613 SINF : constant SI_Type := Subp_Index (CTJ.Caller);
1614 SINT : constant SI_Type := Subp_Index (CTJ.Callee);
1615
1616 SUBF : Subp_Entry renames Subps.Table (SINF);
1617 SUBT : Subp_Entry renames Subps.Table (SINT);
1618
1619 A : Entity_Id;
1620
1621 begin
1622 -- If callee has uplevel references
1623
1624 if SUBT.Uplevel_Ref < SUBT.Lev
1625
1626 -- And this is an uplevel call
1627
1628 and then SUBT.Lev < SUBF.Lev
1629 then
1630 -- We need to arrange for finding the uplink
1631
1632 A := CTJ.Caller;
1633 loop
1634 A := Enclosing_Subprogram (A);
1635 Subps.Table (Subp_Index (A)).Declares_AREC := True;
1636 exit when A = CTJ.Callee;
1637
1638 -- In any case exit when we get to the outer level. This
1639 -- happens in some odd cases with generics (in particular
1640 -- sem_ch3.adb does not compile without this kludge ???).
1641
1642 exit when A = Subp;
1643 end loop;
1644 end if;
1645 end;
1646 end loop;
1647
1648 -- The tables are now complete, so we can record the last index in the
1649 -- Subps table for later reference in Cprint.
1650
1651 Subps.Table (Subps_First).Last := Subps.Last;
1652
1653 -- Next step, create the entities for code we will insert. We do this
1654 -- at the start so that all the entities are defined, regardless of the
1655 -- order in which we do the code insertions.
1656
1657 Create_Entities : for J in Subps_First .. Subps.Last loop
1658 declare
1659 STJ : Subp_Entry renames Subps.Table (J);
1660 Loc : constant Source_Ptr := Sloc (STJ.Bod);
1661
1662 begin
1663 -- First we create the ARECnF entity for the additional formal for
1664 -- all subprograms which need an activation record passed.
1665
1666 if STJ.Uplevel_Ref < STJ.Lev then
1667 STJ.ARECnF :=
1668 Make_Defining_Identifier (Loc, Chars => AREC_Name (J, "F"));
1669 end if;
1670
1671 -- Define the AREC entities for the activation record if needed
1672
1673 if STJ.Declares_AREC then
1674 STJ.ARECn :=
1675 Make_Defining_Identifier (Loc, AREC_Name (J, ""));
1676 STJ.ARECnT :=
1677 Make_Defining_Identifier (Loc, AREC_Name (J, "T"));
1678 STJ.ARECnPT :=
1679 Make_Defining_Identifier (Loc, AREC_Name (J, "PT"));
1680 STJ.ARECnP :=
1681 Make_Defining_Identifier (Loc, AREC_Name (J, "P"));
1682
1683 -- Define uplink component entity if inner nesting case
1684
1685 if Present (STJ.ARECnF) then
1686 STJ.ARECnU :=
1687 Make_Defining_Identifier (Loc, AREC_Name (J, "U"));
1688 end if;
1689 end if;
1690 end;
1691 end loop Create_Entities;
1692
1693 -- Loop through subprograms
1694
1695 Subp_Loop : declare
1696 Addr : Entity_Id := Empty;
1697
1698 begin
1699 for J in Subps_First .. Subps.Last loop
1700 declare
1701 STJ : Subp_Entry renames Subps.Table (J);
1702
1703 begin
1704 -- First add the extra formal if needed. This applies to all
1705 -- nested subprograms that require an activation record to be
1706 -- passed, as indicated by ARECnF being defined.
1707
1708 if Present (STJ.ARECnF) then
1709
1710 -- Here we need the extra formal. We do the expansion and
1711 -- analysis of this manually, since it is fairly simple,
1712 -- and it is not obvious how we can get what we want if we
1713 -- try to use the normal Analyze circuit.
1714
1715 Add_Extra_Formal : declare
1716 Encl : constant SI_Type := Enclosing_Subp (J);
1717 STJE : Subp_Entry renames Subps.Table (Encl);
1718 -- Index and Subp_Entry for enclosing routine
1719
1720 Form : constant Entity_Id := STJ.ARECnF;
1721 -- The formal to be added. Note that n here is one less
1722 -- than the level of the subprogram itself (STJ.Ent).
1723
1724 procedure Add_Form_To_Spec (F : Entity_Id; S : Node_Id);
1725 -- S is an N_Function/Procedure_Specification node, and F
1726 -- is the new entity to add to this subprogramn spec as
1727 -- the last Extra_Formal.
1728
1729 ----------------------
1730 -- Add_Form_To_Spec --
1731 ----------------------
1732
1733 procedure Add_Form_To_Spec (F : Entity_Id; S : Node_Id) is
1734 Sub : constant Entity_Id := Defining_Entity (S);
1735 Ent : Entity_Id;
1736
1737 begin
1738 -- Case of at least one Extra_Formal is present, set
1739 -- ARECnF as the new last entry in the list.
1740
1741 if Present (Extra_Formals (Sub)) then
1742 Ent := Extra_Formals (Sub);
1743 while Present (Extra_Formal (Ent)) loop
1744 Ent := Extra_Formal (Ent);
1745 end loop;
1746
1747 Set_Extra_Formal (Ent, F);
1748
1749 -- No Extra formals present
1750
1751 else
1752 Set_Extra_Formals (Sub, F);
1753 Ent := Last_Formal (Sub);
1754
1755 if Present (Ent) then
1756 Set_Extra_Formal (Ent, F);
1757 end if;
1758 end if;
1759 end Add_Form_To_Spec;
1760
1761 -- Start of processing for Add_Extra_Formal
1762
1763 begin
1764 -- Decorate the new formal entity
1765
1766 Set_Scope (Form, STJ.Ent);
1767 Set_Ekind (Form, E_In_Parameter);
1768 Set_Etype (Form, STJE.ARECnPT);
1769 Set_Mechanism (Form, By_Copy);
1770 Set_Never_Set_In_Source (Form, True);
1771 Set_Analyzed (Form, True);
1772 Set_Comes_From_Source (Form, False);
1773 Set_Is_Activation_Record (Form, True);
1774
1775 -- Case of only body present
1776
1777 if Acts_As_Spec (STJ.Bod) then
1778 Add_Form_To_Spec (Form, Specification (STJ.Bod));
1779
1780 -- Case of separate spec
1781
1782 else
1783 Add_Form_To_Spec (Form, Parent (STJ.Ent));
1784 end if;
1785 end Add_Extra_Formal;
1786 end if;
1787
1788 -- Processing for subprograms that declare an activation record
1789
1790 if Present (STJ.ARECn) then
1791
1792 -- Local declarations for one such subprogram
1793
1794 declare
1795 Loc : constant Source_Ptr := Sloc (STJ.Bod);
1796
1797 Decls : constant List_Id := New_List;
1798 -- List of new declarations we create
1799
1800 Clist : List_Id;
1801 Comp : Entity_Id;
1802
1803 Decl_Assign : Node_Id;
1804 -- Assigment to set uplink, Empty if none
1805
1806 Decl_ARECnT : Node_Id;
1807 Decl_ARECnPT : Node_Id;
1808 Decl_ARECn : Node_Id;
1809 Decl_ARECnP : Node_Id;
1810 -- Declaration nodes for the AREC entities we build
1811
1812 begin
1813 -- Build list of component declarations for ARECnT and
1814 -- load System.Address.
1815
1816 Clist := Empty_List;
1817
1818 if No (Addr) then
1819 Addr := RTE (RE_Address);
1820 end if;
1821
1822 -- If we are in a subprogram that has a static link that
1823 -- is passed in (as indicated by ARECnF being defined),
1824 -- then include ARECnU : ARECmPT where ARECmPT comes from
1825 -- the level one higher than the current level, and the
1826 -- entity ARECnPT comes from the enclosing subprogram.
1827
1828 if Present (STJ.ARECnF) then
1829 declare
1830 STJE : Subp_Entry
1831 renames Subps.Table (Enclosing_Subp (J));
1832 begin
1833 Append_To (Clist,
1834 Make_Component_Declaration (Loc,
1835 Defining_Identifier => STJ.ARECnU,
1836 Component_Definition =>
1837 Make_Component_Definition (Loc,
1838 Subtype_Indication =>
1839 New_Occurrence_Of (STJE.ARECnPT, Loc))));
1840 end;
1841 end if;
1842
1843 -- Add components for uplevel referenced entities
1844
1845 if Present (STJ.Uents) then
1846 declare
1847 Elmt : Elmt_Id;
1848 Ptr_Decl : Node_Id;
1849 Uent : Entity_Id;
1850
1851 Indx : Nat;
1852 -- 1's origin of index in list of elements. This is
1853 -- used to uniquify names if needed in Upref_Name.
1854
1855 begin
1856 Elmt := First_Elmt (STJ.Uents);
1857 Indx := 0;
1858 while Present (Elmt) loop
1859 Uent := Node (Elmt);
1860 Indx := Indx + 1;
1861
1862 Comp :=
1863 Make_Defining_Identifier (Loc,
1864 Chars => Upref_Name (Uent, Indx, Clist));
1865
1866 Set_Activation_Record_Component
1867 (Uent, Comp);
1868
1869 if Needs_Fat_Pointer (Uent) then
1870
1871 -- Build corresponding access type
1872
1873 Ptr_Decl :=
1874 Build_Access_Type_Decl
1875 (Etype (Uent), STJ.Ent);
1876 Append_To (Decls, Ptr_Decl);
1877
1878 -- And use its type in the corresponding
1879 -- component.
1880
1881 Append_To (Clist,
1882 Make_Component_Declaration (Loc,
1883 Defining_Identifier => Comp,
1884 Component_Definition =>
1885 Make_Component_Definition (Loc,
1886 Subtype_Indication =>
1887 New_Occurrence_Of
1888 (Defining_Identifier (Ptr_Decl),
1889 Loc))));
1890 else
1891 Append_To (Clist,
1892 Make_Component_Declaration (Loc,
1893 Defining_Identifier => Comp,
1894 Component_Definition =>
1895 Make_Component_Definition (Loc,
1896 Subtype_Indication =>
1897 New_Occurrence_Of (Addr, Loc))));
1898 end if;
1899 Next_Elmt (Elmt);
1900 end loop;
1901 end;
1902 end if;
1903
1904 -- Now we can insert the AREC declarations into the body
1905 -- type ARECnT is record .. end record;
1906 -- pragma Suppress_Initialization (ARECnT);
1907
1908 -- Note that we need to set the Suppress_Initialization
1909 -- flag after Decl_ARECnT has been analyzed.
1910
1911 Decl_ARECnT :=
1912 Make_Full_Type_Declaration (Loc,
1913 Defining_Identifier => STJ.ARECnT,
1914 Type_Definition =>
1915 Make_Record_Definition (Loc,
1916 Component_List =>
1917 Make_Component_List (Loc,
1918 Component_Items => Clist)));
1919 Append_To (Decls, Decl_ARECnT);
1920
1921 -- type ARECnPT is access all ARECnT;
1922
1923 Decl_ARECnPT :=
1924 Make_Full_Type_Declaration (Loc,
1925 Defining_Identifier => STJ.ARECnPT,
1926 Type_Definition =>
1927 Make_Access_To_Object_Definition (Loc,
1928 All_Present => True,
1929 Subtype_Indication =>
1930 New_Occurrence_Of (STJ.ARECnT, Loc)));
1931 Append_To (Decls, Decl_ARECnPT);
1932
1933 -- ARECn : aliased ARECnT;
1934
1935 Decl_ARECn :=
1936 Make_Object_Declaration (Loc,
1937 Defining_Identifier => STJ.ARECn,
1938 Aliased_Present => True,
1939 Object_Definition =>
1940 New_Occurrence_Of (STJ.ARECnT, Loc));
1941 Append_To (Decls, Decl_ARECn);
1942
1943 -- ARECnP : constant ARECnPT := ARECn'Access;
1944
1945 Decl_ARECnP :=
1946 Make_Object_Declaration (Loc,
1947 Defining_Identifier => STJ.ARECnP,
1948 Constant_Present => True,
1949 Object_Definition =>
1950 New_Occurrence_Of (STJ.ARECnPT, Loc),
1951 Expression =>
1952 Make_Attribute_Reference (Loc,
1953 Prefix =>
1954 New_Occurrence_Of (STJ.ARECn, Loc),
1955 Attribute_Name => Name_Access));
1956 Append_To (Decls, Decl_ARECnP);
1957
1958 -- If we are in a subprogram that has a static link that
1959 -- is passed in (as indicated by ARECnF being defined),
1960 -- then generate ARECn.ARECmU := ARECmF where m is
1961 -- one less than the current level to set the uplink.
1962
1963 if Present (STJ.ARECnF) then
1964 Decl_Assign :=
1965 Make_Assignment_Statement (Loc,
1966 Name =>
1967 Make_Selected_Component (Loc,
1968 Prefix =>
1969 New_Occurrence_Of (STJ.ARECn, Loc),
1970 Selector_Name =>
1971 New_Occurrence_Of (STJ.ARECnU, Loc)),
1972 Expression =>
1973 New_Occurrence_Of (STJ.ARECnF, Loc));
1974 Append_To (Decls, Decl_Assign);
1975
1976 else
1977 Decl_Assign := Empty;
1978 end if;
1979
1980 if No (Declarations (STJ.Bod)) then
1981 Set_Declarations (STJ.Bod, Decls);
1982 else
1983 Prepend_List_To (Declarations (STJ.Bod), Decls);
1984 end if;
1985
1986 -- Analyze the newly inserted declarations. Note that we
1987 -- do not need to establish the whole scope stack, since
1988 -- we have already set all entity fields (so there will
1989 -- be no searching of upper scopes to resolve names). But
1990 -- we do set the scope of the current subprogram, so that
1991 -- newly created entities go in the right entity chain.
1992
1993 -- We analyze with all checks suppressed (since we do
1994 -- not expect any exceptions).
1995
1996 Push_Scope (STJ.Ent);
1997 Analyze (Decl_ARECnT, Suppress => All_Checks);
1998
1999 -- Note that we need to call Set_Suppress_Initialization
2000 -- after Decl_ARECnT has been analyzed, but before
2001 -- analyzing Decl_ARECnP so that the flag is properly
2002 -- taking into account.
2003
2004 Set_Suppress_Initialization (STJ.ARECnT);
2005
2006 Analyze (Decl_ARECnPT, Suppress => All_Checks);
2007 Analyze (Decl_ARECn, Suppress => All_Checks);
2008 Analyze (Decl_ARECnP, Suppress => All_Checks);
2009
2010 if Present (Decl_Assign) then
2011 Analyze (Decl_Assign, Suppress => All_Checks);
2012 end if;
2013
2014 Pop_Scope;
2015
2016 -- Next step, for each uplevel referenced entity, add
2017 -- assignment operations to set the component in the
2018 -- activation record.
2019
2020 if Present (STJ.Uents) then
2021 declare
2022 Elmt : Elmt_Id;
2023
2024 begin
2025 Elmt := First_Elmt (STJ.Uents);
2026 while Present (Elmt) loop
2027 declare
2028 Ent : constant Entity_Id := Node (Elmt);
2029 Loc : constant Source_Ptr := Sloc (Ent);
2030 Dec : constant Node_Id :=
2031 Declaration_Node (Ent);
2032
2033 Asn : Node_Id;
2034 Attr : Name_Id;
2035 Comp : Entity_Id;
2036 Ins : Node_Id;
2037 Rhs : Node_Id;
2038
2039 begin
2040 -- For parameters, we insert the assignment
2041 -- right after the declaration of ARECnP.
2042 -- For all other entities, we insert the
2043 -- assignment immediately after the
2044 -- declaration of the entity or after the
2045 -- freeze node if present.
2046
2047 -- Note: we don't need to mark the entity
2048 -- as being aliased, because the address
2049 -- attribute will mark it as Address_Taken,
2050 -- and that is good enough.
2051
2052 if Is_Formal (Ent) then
2053 Ins := Decl_ARECnP;
2054
2055 elsif Has_Delayed_Freeze (Ent) then
2056 Ins := Freeze_Node (Ent);
2057
2058 else
2059 Ins := Dec;
2060 end if;
2061
2062 -- Build and insert the assignment:
2063 -- ARECn.nam := nam'Address
2064 -- or else 'Access for unconstrained array
2065
2066 if Needs_Fat_Pointer (Ent) then
2067 Attr := Name_Access;
2068 else
2069 Attr := Name_Address;
2070 end if;
2071
2072 Rhs :=
2073 Make_Attribute_Reference (Loc,
2074 Prefix =>
2075 New_Occurrence_Of (Ent, Loc),
2076 Attribute_Name => Attr);
2077
2078 -- If the entity is an unconstrained formal
2079 -- we wrap the attribute reference in an
2080 -- unchecked conversion to the type of the
2081 -- activation record component, to prevent
2082 -- spurious subtype conformance errors within
2083 -- instances.
2084
2085 if Is_Formal (Ent)
2086 and then not Is_Constrained (Etype (Ent))
2087 then
2088 -- Find target component and its type
2089
2090 Comp := First_Component (STJ.ARECnT);
2091 while Chars (Comp) /= Chars (Ent) loop
2092 Comp := Next_Component (Comp);
2093 end loop;
2094
2095 Rhs :=
2096 Unchecked_Convert_To (Etype (Comp), Rhs);
2097 end if;
2098
2099 Asn :=
2100 Make_Assignment_Statement (Loc,
2101 Name =>
2102 Make_Selected_Component (Loc,
2103 Prefix =>
2104 New_Occurrence_Of (STJ.ARECn, Loc),
2105 Selector_Name =>
2106 New_Occurrence_Of
2107 (Activation_Record_Component
2108 (Ent),
2109 Loc)),
2110 Expression => Rhs);
2111
2112 -- If we have a loop parameter, we have
2113 -- to insert before the first statement
2114 -- of the loop. Ins points to the
2115 -- N_Loop_Parameter_Specification or to
2116 -- an N_Iterator_Specification.
2117
2118 if Nkind_In
2119 (Ins, N_Iterator_Specification,
2120 N_Loop_Parameter_Specification)
2121 then
2122 -- Quantified expression are rewritten as
2123 -- loops during expansion.
2124
2125 if Nkind (Parent (Ins)) =
2126 N_Quantified_Expression
2127 then
2128 null;
2129
2130 else
2131 Ins :=
2132 First
2133 (Statements
2134 (Parent (Parent (Ins))));
2135 Insert_Before (Ins, Asn);
2136 end if;
2137
2138 else
2139 Insert_After (Ins, Asn);
2140 end if;
2141
2142 -- Analyze the assignment statement. We do
2143 -- not need to establish the relevant scope
2144 -- stack entries here, because we have
2145 -- already set the correct entity references,
2146 -- so no name resolution is required, and no
2147 -- new entities are created, so we don't even
2148 -- need to set the current scope.
2149
2150 -- We analyze with all checks suppressed
2151 -- (since we do not expect any exceptions).
2152
2153 Analyze (Asn, Suppress => All_Checks);
2154 end;
2155
2156 Next_Elmt (Elmt);
2157 end loop;
2158 end;
2159 end if;
2160 end;
2161 end if;
2162 end;
2163 end loop;
2164 end Subp_Loop;
2165
2166 -- Next step, process uplevel references. This has to be done in a
2167 -- separate pass, after completing the processing in Sub_Loop because we
2168 -- need all the AREC declarations generated, inserted, and analyzed so
2169 -- that the uplevel references can be successfully analyzed.
2170
2171 Uplev_Refs : for J in Urefs.First .. Urefs.Last loop
2172 declare
2173 UPJ : Uref_Entry renames Urefs.Table (J);
2174
2175 begin
2176 -- Ignore type references, these are implicit references that do
2177 -- not need rewriting (e.g. the appearence in a conversion).
2178 -- Also ignore if no reference was specified or if the rewriting
2179 -- has already been done (this can happen if the N_Identifier
2180 -- occurs more than one time in the tree).
2181
2182 if No (UPJ.Ref)
2183 or else not Is_Entity_Name (UPJ.Ref)
2184 or else not Present (Entity (UPJ.Ref))
2185 then
2186 goto Continue;
2187 end if;
2188
2189 -- Rewrite one reference
2190
2191 Rewrite_One_Ref : declare
2192 Loc : constant Source_Ptr := Sloc (UPJ.Ref);
2193 -- Source location for the reference
2194
2195 Typ : constant Entity_Id := Etype (UPJ.Ent);
2196 -- The type of the referenced entity
2197
2198 Atyp : Entity_Id;
2199 -- The actual subtype of the reference
2200
2201 RS_Caller : constant SI_Type := Subp_Index (UPJ.Caller);
2202 -- Subp_Index for caller containing reference
2203
2204 STJR : Subp_Entry renames Subps.Table (RS_Caller);
2205 -- Subp_Entry for subprogram containing reference
2206
2207 RS_Callee : constant SI_Type := Subp_Index (UPJ.Callee);
2208 -- Subp_Index for subprogram containing referenced entity
2209
2210 STJE : Subp_Entry renames Subps.Table (RS_Callee);
2211 -- Subp_Entry for subprogram containing referenced entity
2212
2213 Pfx : Node_Id;
2214 Comp : Entity_Id;
2215 SI : SI_Type;
2216
2217 begin
2218 Atyp := Etype (UPJ.Ref);
2219
2220 if Ekind (Atyp) /= E_Record_Subtype then
2221 Atyp := Get_Actual_Subtype (UPJ.Ref);
2222 end if;
2223
2224 -- Ignore if no ARECnF entity for enclosing subprogram which
2225 -- probably happens as a result of not properly treating
2226 -- instance bodies. To be examined ???
2227
2228 -- If this test is omitted, then the compilation of freeze.adb
2229 -- and inline.adb fail in unnesting mode.
2230
2231 if No (STJR.ARECnF) then
2232 goto Continue;
2233 end if;
2234
2235 -- If this is a reference to a global constant, use its value
2236 -- rather than create a reference. It is more efficient and
2237 -- furthermore indispensable if the context requires a
2238 -- constant, such as a branch of a case statement.
2239
2240 if Ekind (UPJ.Ent) = E_Constant
2241 and then Is_True_Constant (UPJ.Ent)
2242 and then Present (Constant_Value (UPJ.Ent))
2243 and then Is_Static_Expression (Constant_Value (UPJ.Ent))
2244 then
2245 Rewrite (UPJ.Ref, New_Copy_Tree (Constant_Value (UPJ.Ent)));
2246 goto Continue;
2247 end if;
2248
2249 -- Push the current scope, so that the pointer type Tnn, and
2250 -- any subsidiary entities resulting from the analysis of the
2251 -- rewritten reference, go in the right entity chain.
2252
2253 Push_Scope (STJR.Ent);
2254
2255 -- Now we need to rewrite the reference. We have a reference
2256 -- from level STJR.Lev to level STJE.Lev. The general form of
2257 -- the rewritten reference for entity X is:
2258
2259 -- Typ'Deref (ARECaF.ARECbU.ARECcU.ARECdU....ARECmU.X)
2260
2261 -- where a,b,c,d .. m =
2262 -- STJR.Lev - 1, STJR.Lev - 2, .. STJE.Lev
2263
2264 pragma Assert (STJR.Lev > STJE.Lev);
2265
2266 -- Compute the prefix of X. Here are examples to make things
2267 -- clear (with parens to show groupings, the prefix is
2268 -- everything except the .X at the end).
2269
2270 -- level 2 to level 1
2271
2272 -- AREC1F.X
2273
2274 -- level 3 to level 1
2275
2276 -- (AREC2F.AREC1U).X
2277
2278 -- level 4 to level 1
2279
2280 -- ((AREC3F.AREC2U).AREC1U).X
2281
2282 -- level 6 to level 2
2283
2284 -- (((AREC5F.AREC4U).AREC3U).AREC2U).X
2285
2286 -- In the above, ARECnF and ARECnU are pointers, so there are
2287 -- explicit dereferences required for these occurrences.
2288
2289 Pfx :=
2290 Make_Explicit_Dereference (Loc,
2291 Prefix => New_Occurrence_Of (STJR.ARECnF, Loc));
2292 SI := RS_Caller;
2293 for L in STJE.Lev .. STJR.Lev - 2 loop
2294 SI := Enclosing_Subp (SI);
2295 Pfx :=
2296 Make_Explicit_Dereference (Loc,
2297 Prefix =>
2298 Make_Selected_Component (Loc,
2299 Prefix => Pfx,
2300 Selector_Name =>
2301 New_Occurrence_Of (Subps.Table (SI).ARECnU, Loc)));
2302 end loop;
2303
2304 -- Get activation record component (must exist)
2305
2306 Comp := Activation_Record_Component (UPJ.Ent);
2307 pragma Assert (Present (Comp));
2308
2309 -- Do the replacement. If the component type is an access type,
2310 -- this is an uplevel reference for an entity that requires a
2311 -- fat pointer, so dereference the component.
2312
2313 if Is_Access_Type (Etype (Comp)) then
2314 Rewrite (UPJ.Ref,
2315 Make_Explicit_Dereference (Loc,
2316 Prefix =>
2317 Make_Selected_Component (Loc,
2318 Prefix => Pfx,
2319 Selector_Name =>
2320 New_Occurrence_Of (Comp, Loc))));
2321
2322 else
2323 Rewrite (UPJ.Ref,
2324 Make_Attribute_Reference (Loc,
2325 Prefix => New_Occurrence_Of (Atyp, Loc),
2326 Attribute_Name => Name_Deref,
2327 Expressions => New_List (
2328 Make_Selected_Component (Loc,
2329 Prefix => Pfx,
2330 Selector_Name =>
2331 New_Occurrence_Of (Comp, Loc)))));
2332 end if;
2333
2334 -- Analyze and resolve the new expression. We do not need to
2335 -- establish the relevant scope stack entries here, because we
2336 -- have already set all the correct entity references, so no
2337 -- name resolution is needed. We have already set the current
2338 -- scope, so that any new entities created will be in the right
2339 -- scope.
2340
2341 -- We analyze with all checks suppressed (since we do not
2342 -- expect any exceptions)
2343
2344 Analyze_And_Resolve (UPJ.Ref, Typ, Suppress => All_Checks);
2345 Pop_Scope;
2346 end Rewrite_One_Ref;
2347 end;
2348
2349 <<Continue>>
2350 null;
2351 end loop Uplev_Refs;
2352
2353 -- Finally, loop through all calls adding extra actual for the
2354 -- activation record where it is required.
2355
2356 Adjust_Calls : for J in Calls.First .. Calls.Last loop
2357
2358 -- Process a single call, we are only interested in a call to a
2359 -- subprogram that actually needs a pointer to an activation record,
2360 -- as indicated by the ARECnF entity being set. This excludes the
2361 -- top level subprogram, and any subprogram not having uplevel refs.
2362
2363 Adjust_One_Call : declare
2364 CTJ : Call_Entry renames Calls.Table (J);
2365 STF : Subp_Entry renames Subps.Table (Subp_Index (CTJ.Caller));
2366 STT : Subp_Entry renames Subps.Table (Subp_Index (CTJ.Callee));
2367
2368 Loc : constant Source_Ptr := Sloc (CTJ.N);
2369
2370 Extra : Node_Id;
2371 ExtraP : Node_Id;
2372 SubX : SI_Type;
2373 Act : Node_Id;
2374
2375 begin
2376 if Present (STT.ARECnF)
2377 and then Nkind (CTJ.N) in N_Subprogram_Call
2378 then
2379 -- CTJ.N is a call to a subprogram which may require a pointer
2380 -- to an activation record. The subprogram containing the call
2381 -- is CTJ.From and the subprogram being called is CTJ.To, so we
2382 -- have a call from level STF.Lev to level STT.Lev.
2383
2384 -- There are three possibilities:
2385
2386 -- For a call to the same level, we just pass the activation
2387 -- record passed to the calling subprogram.
2388
2389 if STF.Lev = STT.Lev then
2390 Extra := New_Occurrence_Of (STF.ARECnF, Loc);
2391
2392 -- For a call that goes down a level, we pass a pointer to the
2393 -- activation record constructed within the caller (which may
2394 -- be the outer-level subprogram, but also may be a more deeply
2395 -- nested caller).
2396
2397 elsif STT.Lev = STF.Lev + 1 then
2398 Extra := New_Occurrence_Of (STF.ARECnP, Loc);
2399
2400 -- Otherwise we must have an upcall (STT.Lev < STF.LEV),
2401 -- since it is not possible to do a downcall of more than
2402 -- one level.
2403
2404 -- For a call from level STF.Lev to level STT.Lev, we
2405 -- have to find the activation record needed by the
2406 -- callee. This is as follows:
2407
2408 -- ARECaF.ARECbU.ARECcU....ARECmU
2409
2410 -- where a,b,c .. m =
2411 -- STF.Lev - 1, STF.Lev - 2, STF.Lev - 3 .. STT.Lev
2412
2413 else
2414 pragma Assert (STT.Lev < STF.Lev);
2415
2416 Extra := New_Occurrence_Of (STF.ARECnF, Loc);
2417 SubX := Subp_Index (CTJ.Caller);
2418 for K in reverse STT.Lev .. STF.Lev - 1 loop
2419 SubX := Enclosing_Subp (SubX);
2420 Extra :=
2421 Make_Selected_Component (Loc,
2422 Prefix => Extra,
2423 Selector_Name =>
2424 New_Occurrence_Of
2425 (Subps.Table (SubX).ARECnU, Loc));
2426 end loop;
2427 end if;
2428
2429 -- Extra is the additional parameter to be added. Build a
2430 -- parameter association that we can append to the actuals.
2431
2432 ExtraP :=
2433 Make_Parameter_Association (Loc,
2434 Selector_Name =>
2435 New_Occurrence_Of (STT.ARECnF, Loc),
2436 Explicit_Actual_Parameter => Extra);
2437
2438 if No (Parameter_Associations (CTJ.N)) then
2439 Set_Parameter_Associations (CTJ.N, Empty_List);
2440 end if;
2441
2442 Append (ExtraP, Parameter_Associations (CTJ.N));
2443
2444 -- We need to deal with the actual parameter chain as well. The
2445 -- newly added parameter is always the last actual.
2446
2447 Act := First_Named_Actual (CTJ.N);
2448
2449 if No (Act) then
2450 Set_First_Named_Actual (CTJ.N, Extra);
2451
2452 -- If call has been relocated (as with an expression in
2453 -- an aggregate), set First_Named pointer in original node
2454 -- as well, because that's the parent of the parameter list.
2455
2456 Set_First_Named_Actual
2457 (Parent (List_Containing (ExtraP)), Extra);
2458
2459 -- Here we must follow the chain and append the new entry
2460
2461 else
2462 loop
2463 declare
2464 PAN : Node_Id;
2465 NNA : Node_Id;
2466
2467 begin
2468 PAN := Parent (Act);
2469 pragma Assert (Nkind (PAN) = N_Parameter_Association);
2470 NNA := Next_Named_Actual (PAN);
2471
2472 if No (NNA) then
2473 Set_Next_Named_Actual (PAN, Extra);
2474 exit;
2475 end if;
2476
2477 Act := NNA;
2478 end;
2479 end loop;
2480 end if;
2481
2482 -- Analyze and resolve the new actual. We do not need to
2483 -- establish the relevant scope stack entries here, because
2484 -- we have already set all the correct entity references, so
2485 -- no name resolution is needed.
2486
2487 -- We analyze with all checks suppressed (since we do not
2488 -- expect any exceptions, and also we temporarily turn off
2489 -- Unested_Subprogram_Mode to avoid trying to mark uplevel
2490 -- references (not needed at this stage, and in fact causes
2491 -- a bit of recursive chaos).
2492
2493 Opt.Unnest_Subprogram_Mode := False;
2494 Analyze_And_Resolve
2495 (Extra, Etype (STT.ARECnF), Suppress => All_Checks);
2496 Opt.Unnest_Subprogram_Mode := True;
2497 end if;
2498 end Adjust_One_Call;
2499 end loop Adjust_Calls;
2500
2501 return;
2502 end Unnest_Subprogram;
2503
2504 ------------------------
2505 -- Unnest_Subprograms --
2506 ------------------------
2507
2508 procedure Unnest_Subprograms (N : Node_Id) is
2509 function Search_Subprograms (N : Node_Id) return Traverse_Result;
2510 -- Tree visitor that search for outer level procedures with nested
2511 -- subprograms and invokes Unnest_Subprogram()
2512
2513 ---------------
2514 -- Do_Search --
2515 ---------------
2516
2517 procedure Do_Search is new Traverse_Proc (Search_Subprograms);
2518 -- Subtree visitor instantiation
2519
2520 ------------------------
2521 -- Search_Subprograms --
2522 ------------------------
2523
2524 function Search_Subprograms (N : Node_Id) return Traverse_Result is
2525 begin
2526 if Nkind_In (N, N_Subprogram_Body, N_Subprogram_Body_Stub) then
2527 declare
2528 Spec_Id : constant Entity_Id := Unique_Defining_Entity (N);
2529
2530 begin
2531 -- We are only interested in subprograms (not generic
2532 -- subprograms), that have nested subprograms.
2533
2534 if Is_Subprogram (Spec_Id)
2535 and then Has_Nested_Subprogram (Spec_Id)
2536 and then Is_Library_Level_Entity (Spec_Id)
2537 then
2538 Unnest_Subprogram (Spec_Id, N);
2539 end if;
2540 end;
2541
2542 -- The proper body of a stub may contain nested subprograms, and
2543 -- therefore must be visited explicitly. Nested stubs are examined
2544 -- recursively in Visit_Node.
2545
2546 elsif Nkind (N) in N_Body_Stub then
2547 Do_Search (Library_Unit (N));
2548
2549 -- Skip generic packages
2550
2551 elsif Nkind (N) = N_Package_Body
2552 and then Ekind (Corresponding_Spec (N)) = E_Generic_Package
2553 then
2554 return Skip;
2555 end if;
2556
2557 return OK;
2558 end Search_Subprograms;
2559
2560 Subp : Entity_Id;
2561 Subp_Body : Node_Id;
2562
2563 -- Start of processing for Unnest_Subprograms
2564
2565 begin
2566 if not Opt.Unnest_Subprogram_Mode or not Opt.Expander_Active then
2567 return;
2568 end if;
2569
2570 -- A specification will contain bodies if it contains instantiations so
2571 -- examine package or subprogram declaration of the main unit, when it
2572 -- is present.
2573
2574 if Nkind (Unit (N)) = N_Package_Body
2575 or else (Nkind (Unit (N)) = N_Subprogram_Body
2576 and then not Acts_As_Spec (N))
2577 then
2578 Do_Search (Library_Unit (N));
2579 end if;
2580
2581 Do_Search (N);
2582
2583 -- Unnest any subprograms passed on the list of inlined subprograms
2584
2585 Subp := First_Inlined_Subprogram (N);
2586
2587 while Present (Subp) loop
2588 Subp_Body := Parent (Declaration_Node (Subp));
2589
2590 if Nkind (Subp_Body) = N_Subprogram_Declaration
2591 and then Present (Corresponding_Body (Subp_Body))
2592 then
2593 Subp_Body := Parent (Declaration_Node
2594 (Corresponding_Body (Subp_Body)));
2595 Unnest_Subprogram (Subp, Subp_Body, For_Inline => True);
2596 end if;
2597
2598 Next_Inlined_Subprogram (Subp);
2599 end loop;
2600 end Unnest_Subprograms;
2601
2602 end Exp_Unst;
Mirror of the offical gcc git repository hosted at gcc.gnu.org