1 /****************************************************************************
2 * *
3 * GNAT COMPILER COMPONENTS *
4 * *
5 * T R A N S *
6 * *
7 * C Implementation File *
8 * *
9 * Copyright (C) 1992-2021, 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 see *
19 * <http://www.gnu.org/licenses/>. *
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 #include "config.h"
27 #include "system.h"
28 #include "coretypes.h"
29 #include "target.h"
30 #include "function.h"
31 #include "bitmap.h"
32 #include "tree.h"
33 #include "gimple-expr.h"
34 #include "stringpool.h"
35 #include "cgraph.h"
36 #include "predict.h"
37 #include "diagnostic.h"
38 #include "alias.h"
39 #include "fold-const.h"
40 #include "stor-layout.h"
41 #include "stmt.h"
42 #include "varasm.h"
43 #include "output.h"
44 #include "debug.h"
45 #include "libfuncs.h" /* For set_stack_check_libfunc. */
46 #include "tree-iterator.h"
47 #include "gimplify.h"
48 #include "opts.h"
49 #include "common/common-target.h"
50 #include "gomp-constants.h"
51 #include "stringpool.h"
52 #include "attribs.h"
53 #include "tree-nested.h"
54
55 #include "ada.h"
56 #include "adadecode.h"
57 #include "types.h"
58 #include "atree.h"
59 #include "namet.h"
60 #include "nlists.h"
61 #include "snames.h"
62 #include "stringt.h"
63 #include "uintp.h"
64 #include "urealp.h"
65 #include "fe.h"
66 #include "sinfo.h"
67 #include "einfo.h"
68 #include "gadaint.h"
69 #include "ada-tree.h"
70 #include "gigi.h"
71
72 /* We should avoid allocating more than ALLOCA_THRESHOLD bytes via alloca,
73 for fear of running out of stack space. If we need more, we use xmalloc
74 instead. */
75 #define ALLOCA_THRESHOLD 1000
76
77 /* Pointers to front-end tables accessed through macros. */
78 Node_Header *Node_Offsets_Ptr;
79 any_slot *Slots_Ptr;
80 Node_Id *Next_Node_Ptr;
81 Node_Id *Prev_Node_Ptr;
82 struct Elist_Header *Elists_Ptr;
83 struct Elmt_Item *Elmts_Ptr;
84 struct String_Entry *Strings_Ptr;
85 Char_Code *String_Chars_Ptr;
86 struct List_Header *List_Headers_Ptr;
87
88 /* Highest number in the front-end node table. */
89 int max_gnat_nodes;
90
91 /* True when gigi is being called on an analyzed but unexpanded
92 tree, and the only purpose of the call is to properly annotate
93 types with representation information. */
94 bool type_annotate_only;
95
96 /* List of N_Validate_Unchecked_Conversion nodes in the unit. */
97 static vec<Node_Id> gnat_validate_uc_list;
98
99 /* List of expressions of pragma Compile_Time_{Error|Warning} in the unit. */
100 static vec<Node_Id> gnat_compile_time_expr_list;
101
102 /* When not optimizing, we cache the 'First, 'Last and 'Length attributes
103 of unconstrained array IN parameters to avoid emitting a great deal of
104 redundant instructions to recompute them each time. */
105 struct GTY (()) parm_attr_d {
106 int id; /* GTY doesn't like Entity_Id. */
107 int dim;
108 tree first;
109 tree last;
110 tree length;
111 };
112
113 typedef struct parm_attr_d *parm_attr;
114
115 /* Structure used to record information for a function. */
116 struct GTY(()) language_function {
117 vec<parm_attr, va_gc> *parm_attr_cache;
118 bitmap named_ret_val;
119 vec<tree, va_gc> *other_ret_val;
120 int gnat_ret;
121 };
122
123 #define f_parm_attr_cache \
124 DECL_STRUCT_FUNCTION (current_function_decl)->language->parm_attr_cache
125
126 #define f_named_ret_val \
127 DECL_STRUCT_FUNCTION (current_function_decl)->language->named_ret_val
128
129 #define f_other_ret_val \
130 DECL_STRUCT_FUNCTION (current_function_decl)->language->other_ret_val
131
132 #define f_gnat_ret \
133 DECL_STRUCT_FUNCTION (current_function_decl)->language->gnat_ret
134
135 /* A structure used to gather together information about a statement group.
136 We use this to gather related statements, for example the "then" part
137 of a IF. In the case where it represents a lexical scope, we may also
138 have a BLOCK node corresponding to it and/or cleanups. */
139
140 struct GTY((chain_next ("%h.previous"))) stmt_group {
141 struct stmt_group *previous; /* Previous code group. */
142 tree stmt_list; /* List of statements for this code group. */
143 tree block; /* BLOCK for this code group, if any. */
144 tree cleanups; /* Cleanups for this code group, if any. */
145 };
146
147 static GTY(()) struct stmt_group *current_stmt_group;
148
149 /* List of unused struct stmt_group nodes. */
150 static GTY((deletable)) struct stmt_group *stmt_group_free_list;
151
152 /* A structure used to record information on elaboration procedures
153 we've made and need to process.
154
155 ??? gnat_node should be Node_Id, but gengtype gets confused. */
156
157 struct GTY((chain_next ("%h.next"))) elab_info {
158 struct elab_info *next; /* Pointer to next in chain. */
159 tree elab_proc; /* Elaboration procedure. */
160 int gnat_node; /* The N_Compilation_Unit. */
161 };
162
163 static GTY(()) struct elab_info *elab_info_list;
164
165 /* Stack of exception pointer variables. Each entry is the VAR_DECL
166 that stores the address of the raised exception. Nonzero means we
167 are in an exception handler. Not used in the zero-cost case. */
168 static GTY(()) vec<tree, va_gc> *gnu_except_ptr_stack;
169
170 /* In ZCX case, current exception pointer. Used to re-raise it. */
171 static GTY(()) tree gnu_incoming_exc_ptr;
172
173 /* Stack for storing the current elaboration procedure decl. */
174 static GTY(()) vec<tree, va_gc> *gnu_elab_proc_stack;
175
176 /* Stack of labels to be used as a goto target instead of a return in
177 some functions. See processing for N_Subprogram_Body. */
178 static GTY(()) vec<tree, va_gc> *gnu_return_label_stack;
179
180 /* Stack of variable for the return value of a function with copy-in/copy-out
181 parameters. See processing for N_Subprogram_Body. */
182 static GTY(()) vec<tree, va_gc> *gnu_return_var_stack;
183
184 /* Structure used to record information for a range check. */
185 struct GTY(()) range_check_info_d {
186 tree low_bound;
187 tree high_bound;
188 tree disp;
189 bool neg_p;
190 tree type;
191 tree invariant_cond;
192 tree inserted_cond;
193 };
194
195 typedef struct range_check_info_d *range_check_info;
196
197 /* Structure used to record information for a loop. */
198 struct GTY(()) loop_info_d {
199 tree fndecl;
200 tree stmt;
201 tree loop_var;
202 tree low_bound;
203 tree high_bound;
204 tree omp_loop_clauses;
205 tree omp_construct_clauses;
206 enum tree_code omp_code;
207 vec<range_check_info, va_gc> *checks;
208 vec<tree, va_gc> *invariants;
209 };
210
211 typedef struct loop_info_d *loop_info;
212
213 /* Stack of loop_info structures associated with LOOP_STMT nodes. */
214 static GTY(()) vec<loop_info, va_gc> *gnu_loop_stack;
215
216 /* The stacks for N_{Push,Pop}_*_Label. */
217 static vec<Entity_Id> gnu_constraint_error_label_stack;
218 static vec<Entity_Id> gnu_storage_error_label_stack;
219 static vec<Entity_Id> gnu_program_error_label_stack;
220
221 /* Map GNAT tree codes to GCC tree codes for simple expressions. */
222 static enum tree_code gnu_codes[Number_Node_Kinds];
223
224 static void init_code_table (void);
225 static tree get_elaboration_procedure (void);
226 static void Compilation_Unit_to_gnu (Node_Id);
227 static bool empty_stmt_list_p (tree);
228 static void record_code_position (Node_Id);
229 static void insert_code_for (Node_Id);
230 static void add_cleanup (tree, Node_Id);
231 static void add_stmt_list (List_Id);
232 static tree build_stmt_group (List_Id, bool);
233 static inline bool stmt_group_may_fallthru (void);
234 static enum gimplify_status gnat_gimplify_stmt (tree *);
235 static void elaborate_all_entities (Node_Id);
236 static void process_freeze_entity (Node_Id);
237 static void process_decls (List_Id, List_Id, Node_Id, bool, bool);
238 static tree emit_check (tree, tree, int, Node_Id);
239 static tree build_unary_op_trapv (enum tree_code, tree, tree, Node_Id);
240 static tree build_binary_op_trapv (enum tree_code, tree, tree, tree, Node_Id);
241 static tree convert_with_check (Entity_Id, tree, bool, bool, Node_Id);
242 static bool addressable_p (tree, tree);
243 static tree assoc_to_constructor (Entity_Id, Node_Id, tree);
244 static tree pos_to_constructor (Node_Id, tree);
245 static void validate_unchecked_conversion (Node_Id);
246 static void set_expr_location_from_node (tree, Node_Id, bool = false);
247 static void set_gnu_expr_location_from_node (tree, Node_Id);
248 static bool set_end_locus_from_node (tree, Node_Id);
249 static int lvalue_required_p (Node_Id, tree, bool, bool);
250 static tree build_raise_check (int, enum exception_info_kind);
251 static tree create_init_temporary (const char *, tree, tree *, Node_Id);
252 static bool maybe_make_gnu_thunk (Entity_Id gnat_thunk, tree gnu_thunk);
253
254 /* This makes gigi's file_info_ptr visible in this translation unit,
255 so that Sloc_to_locus can look it up when deciding whether to map
256 decls to instances. */
257
258 static struct File_Info_Type *file_map;
259
260 /* Return the string of the identifier allocated for the file name Id. */
261
262 static const char*
File_Name_to_gnu(Name_Id Id)263 File_Name_to_gnu (Name_Id Id)
264 {
265 /* __gnat_to_canonical_file_spec translates file names from pragmas
266 Source_Reference that contain host style syntax not understood by GDB. */
267 const char *name = __gnat_to_canonical_file_spec (Get_Name_String (Id));
268
269 /* Use the identifier table to make a permanent copy of the file name as
270 the name table gets reallocated after Gigi returns but before all the
271 debugging information is output. */
272 return IDENTIFIER_POINTER (get_identifier (name));
273 }
274
275 /* This is the main program of the back-end. It sets up all the table
276 structures and then generates code. */
277
278 void
gigi(Node_Id gnat_root,int max_gnat_node,int number_name ATTRIBUTE_UNUSED,Node_Header * node_offsets_ptr,any_slot * slots_ptr,Node_Id * next_node_ptr,Node_Id * prev_node_ptr,struct Elist_Header * elists_ptr,struct Elmt_Item * elmts_ptr,struct String_Entry * strings_ptr,Char_Code * string_chars_ptr,struct List_Header * list_headers_ptr,Nat number_file,struct File_Info_Type * file_info_ptr,Entity_Id standard_boolean,Entity_Id standard_integer,Entity_Id standard_character,Entity_Id standard_long_long_float,Entity_Id standard_exception_type,Int gigi_operating_mode)279 gigi (Node_Id gnat_root,
280 int max_gnat_node,
281 int number_name ATTRIBUTE_UNUSED,
282 Node_Header *node_offsets_ptr,
283 any_slot *slots_ptr,
284 Node_Id *next_node_ptr,
285 Node_Id *prev_node_ptr,
286 struct Elist_Header *elists_ptr,
287 struct Elmt_Item *elmts_ptr,
288 struct String_Entry *strings_ptr,
289 Char_Code *string_chars_ptr,
290 struct List_Header *list_headers_ptr,
291 Nat number_file,
292 struct File_Info_Type *file_info_ptr,
293 Entity_Id standard_boolean,
294 Entity_Id standard_integer,
295 Entity_Id standard_character,
296 Entity_Id standard_long_long_float,
297 Entity_Id standard_exception_type,
298 Int gigi_operating_mode)
299 {
300 Node_Id gnat_iter;
301 Entity_Id gnat_literal;
302 tree t, ftype, int64_type;
303 struct elab_info *info;
304 int i;
305
306 max_gnat_nodes = max_gnat_node;
307
308 Node_Offsets_Ptr = node_offsets_ptr;
309 Slots_Ptr = slots_ptr;
310 Next_Node_Ptr = next_node_ptr;
311 Prev_Node_Ptr = prev_node_ptr;
312 Elists_Ptr = elists_ptr;
313 Elmts_Ptr = elmts_ptr;
314 Strings_Ptr = strings_ptr;
315 String_Chars_Ptr = string_chars_ptr;
316 List_Headers_Ptr = list_headers_ptr;
317
318 type_annotate_only = (gigi_operating_mode == 1);
319
320 if (Generate_SCO_Instance_Table != 0)
321 {
322 file_map = file_info_ptr;
323 maybe_create_decl_to_instance_map (number_file);
324 }
325
326 for (i = 0; i < number_file; i++)
327 {
328 /* We rely on the order isomorphism between files and line maps. */
329 if ((int) LINEMAPS_ORDINARY_USED (line_table) != i)
330 {
331 gcc_assert (i > 0);
332 error ("%s contains too many lines",
333 File_Name_to_gnu (file_info_ptr[i - 1].File_Name));
334 }
335
336 /* We create the line map for a source file at once, with a fixed number
337 of columns chosen to avoid jumping over the next power of 2. */
338 linemap_add (line_table, LC_ENTER, 0,
339 File_Name_to_gnu (file_info_ptr[i].File_Name), 1);
340 linemap_line_start (line_table, file_info_ptr[i].Num_Source_Lines, 252);
341 linemap_position_for_column (line_table, 252 - 1);
342 linemap_add (line_table, LC_LEAVE, 0, NULL, 0);
343 }
344
345 gcc_assert (Nkind (gnat_root) == N_Compilation_Unit);
346
347 /* Declare the name of the compilation unit as the first global
348 name in order to make the middle-end fully deterministic. */
349 t = create_concat_name (Defining_Entity (Unit (gnat_root)), NULL);
350 first_global_object_name = ggc_strdup (IDENTIFIER_POINTER (t));
351
352 /* Initialize ourselves. */
353 init_code_table ();
354 init_gnat_decl ();
355 init_gnat_utils ();
356
357 /* If we are just annotating types, give VOID_TYPE zero sizes to avoid
358 errors. */
359 if (type_annotate_only)
360 {
361 TYPE_SIZE (void_type_node) = bitsize_zero_node;
362 TYPE_SIZE_UNIT (void_type_node) = size_zero_node;
363 }
364
365 /* Enable GNAT stack checking method if needed */
366 if (!Stack_Check_Probes_On_Target)
367 set_stack_check_libfunc ("_gnat_stack_check");
368
369 /* Retrieve alignment settings. */
370 double_float_alignment = get_target_double_float_alignment ();
371 double_scalar_alignment = get_target_double_scalar_alignment ();
372
373 /* Record the builtin types. Define `integer' and `character' first so that
374 dbx will output them first. */
375 record_builtin_type ("integer", integer_type_node, false);
376 record_builtin_type ("character", char_type_node, false);
377 record_builtin_type ("boolean", boolean_type_node, false);
378 record_builtin_type ("void", void_type_node, false);
379
380 /* Save the type we made for integer as the type for Standard.Integer. */
381 save_gnu_tree (Base_Type (standard_integer),
382 TYPE_NAME (integer_type_node),
383 false);
384
385 /* Likewise for character as the type for Standard.Character. */
386 finish_character_type (char_type_node);
387 save_gnu_tree (Base_Type (standard_character),
388 TYPE_NAME (char_type_node),
389 false);
390
391 /* Likewise for boolean as the type for Standard.Boolean. */
392 save_gnu_tree (Base_Type (standard_boolean),
393 TYPE_NAME (boolean_type_node),
394 false);
395 gnat_literal = First_Literal (Base_Type (standard_boolean));
396 t = UI_To_gnu (Enumeration_Rep (gnat_literal), boolean_type_node);
397 gcc_assert (t == boolean_false_node);
398 t = create_var_decl (get_entity_name (gnat_literal), NULL_TREE,
399 boolean_type_node, t, true, false, false, false, false,
400 true, false, NULL, gnat_literal);
401 save_gnu_tree (gnat_literal, t, false);
402 gnat_literal = Next_Literal (gnat_literal);
403 t = UI_To_gnu (Enumeration_Rep (gnat_literal), boolean_type_node);
404 gcc_assert (t == boolean_true_node);
405 t = create_var_decl (get_entity_name (gnat_literal), NULL_TREE,
406 boolean_type_node, t, true, false, false, false, false,
407 true, false, NULL, gnat_literal);
408 save_gnu_tree (gnat_literal, t, false);
409
410 /* Declare the building blocks of function nodes. */
411 void_list_node = build_tree_list (NULL_TREE, void_type_node);
412 void_ftype = build_function_type_list (void_type_node, NULL_TREE);
413 ptr_void_ftype = build_pointer_type (void_ftype);
414
415 /* Now declare run-time functions. */
416 malloc_decl
417 = create_subprog_decl (get_identifier ("__gnat_malloc"), NULL_TREE,
418 build_function_type_list (ptr_type_node, sizetype,
419 NULL_TREE),
420 NULL_TREE, is_default, true, true, true, false,
421 false, NULL, Empty);
422 DECL_IS_MALLOC (malloc_decl) = 1;
423
424 free_decl
425 = create_subprog_decl (get_identifier ("__gnat_free"), NULL_TREE,
426 build_function_type_list (void_type_node,
427 ptr_type_node, NULL_TREE),
428 NULL_TREE, is_default, true, true, true, false,
429 false, NULL, Empty);
430
431 realloc_decl
432 = create_subprog_decl (get_identifier ("__gnat_realloc"), NULL_TREE,
433 build_function_type_list (ptr_type_node,
434 ptr_type_node, sizetype,
435 NULL_TREE),
436 NULL_TREE, is_default, true, true, true, false,
437 false, NULL, Empty);
438
439 /* This is used for 64-bit multiplication with overflow checking. */
440 int64_type = gnat_type_for_size (64, 0);
441 mulv64_decl
442 = create_subprog_decl (get_identifier ("__gnat_mulv64"), NULL_TREE,
443 build_function_type_list (int64_type, int64_type,
444 int64_type, NULL_TREE),
445 NULL_TREE, is_default, true, true, true, false,
446 false, NULL, Empty);
447
448 if (Enable_128bit_Types)
449 {
450 tree int128_type = gnat_type_for_size (128, 0);
451 mulv128_decl
452 = create_subprog_decl (get_identifier ("__gnat_mulv128"), NULL_TREE,
453 build_function_type_list (int128_type,
454 int128_type,
455 int128_type,
456 NULL_TREE),
457 NULL_TREE, is_default, true, true, true, false,
458 false, NULL, Empty);
459 }
460
461 /* Name of the _Parent field in tagged record types. */
462 parent_name_id = get_identifier (Get_Name_String (Name_uParent));
463
464 /* Name of the Not_Handled_By_Others field in exception record types. */
465 not_handled_by_others_name_id = get_identifier ("not_handled_by_others");
466
467 /* Make the types and functions used for exception processing. */
468 except_type_node = gnat_to_gnu_type (Base_Type (standard_exception_type));
469
470 for (t = TYPE_FIELDS (except_type_node); t; t = DECL_CHAIN (t))
471 if (DECL_NAME (t) == not_handled_by_others_name_id)
472 {
473 not_handled_by_others_decl = t;
474 break;
475 }
476 gcc_assert (DECL_P (not_handled_by_others_decl));
477
478 jmpbuf_type
479 = build_array_type (gnat_type_for_mode (Pmode, 0),
480 build_index_type (size_int (5)));
481 record_builtin_type ("JMPBUF_T", jmpbuf_type, true);
482 jmpbuf_ptr_type = build_pointer_type (jmpbuf_type);
483
484 /* Functions to get and set the jumpbuf pointer for the current thread. */
485 get_jmpbuf_decl
486 = create_subprog_decl
487 (get_identifier ("system__soft_links__get_jmpbuf_address_soft"),
488 NULL_TREE, build_function_type_list (jmpbuf_ptr_type, NULL_TREE),
489 NULL_TREE, is_default, true, true, true, false, false, NULL, Empty);
490
491 set_jmpbuf_decl
492 = create_subprog_decl
493 (get_identifier ("system__soft_links__set_jmpbuf_address_soft"),
494 NULL_TREE, build_function_type_list (void_type_node, jmpbuf_ptr_type,
495 NULL_TREE),
496 NULL_TREE, is_default, true, true, true, false, false, NULL, Empty);
497
498 get_excptr_decl
499 = create_subprog_decl
500 (get_identifier ("system__soft_links__get_gnat_exception"), NULL_TREE,
501 build_function_type_list (build_pointer_type (except_type_node),
502 NULL_TREE),
503 NULL_TREE, is_default, true, true, true, false, false, NULL, Empty);
504
505 /* setjmp returns an integer and has one operand, which is a pointer to
506 a jmpbuf. */
507 setjmp_decl
508 = create_subprog_decl
509 (get_identifier ("__builtin_setjmp"), NULL_TREE,
510 build_function_type_list (integer_type_node, jmpbuf_ptr_type,
511 NULL_TREE),
512 NULL_TREE, is_default, true, true, true, false, false, NULL, Empty);
513 set_decl_built_in_function (setjmp_decl, BUILT_IN_NORMAL, BUILT_IN_SETJMP);
514
515 /* update_setjmp_buf updates a setjmp buffer from the current stack pointer
516 address. */
517 update_setjmp_buf_decl
518 = create_subprog_decl
519 (get_identifier ("__builtin_update_setjmp_buf"), NULL_TREE,
520 build_function_type_list (void_type_node, jmpbuf_ptr_type, NULL_TREE),
521 NULL_TREE, is_default, true, true, true, false, false, NULL, Empty);
522 set_decl_built_in_function (update_setjmp_buf_decl, BUILT_IN_NORMAL,
523 BUILT_IN_UPDATE_SETJMP_BUF);
524
525 /* Indicate that it never returns. */
526 ftype = build_function_type_list (void_type_node,
527 build_pointer_type (except_type_node),
528 NULL_TREE);
529 ftype = build_qualified_type (ftype, TYPE_QUAL_VOLATILE);
530 raise_nodefer_decl
531 = create_subprog_decl
532 (get_identifier ("__gnat_raise_nodefer_with_msg"), NULL_TREE, ftype,
533 NULL_TREE, is_default, true, true, true, false, false, NULL, Empty);
534
535 set_exception_parameter_decl
536 = create_subprog_decl
537 (get_identifier ("__gnat_set_exception_parameter"), NULL_TREE,
538 build_function_type_list (void_type_node, ptr_type_node, ptr_type_node,
539 NULL_TREE),
540 NULL_TREE, is_default, true, true, true, false, false, NULL, Empty);
541
542 /* Hooks to call when entering/leaving an exception handler. */
543 ftype = build_function_type_list (ptr_type_node,
544 ptr_type_node, NULL_TREE);
545 begin_handler_decl
546 = create_subprog_decl (get_identifier ("__gnat_begin_handler_v1"),
547 NULL_TREE, ftype, NULL_TREE,
548 is_default, true, true, true, false, false, NULL,
549 Empty);
550 /* __gnat_begin_handler_v1 is not a dummy procedure, but we arrange
551 for it not to throw. */
552 TREE_NOTHROW (begin_handler_decl) = 1;
553
554 ftype = build_function_type_list (ptr_type_node,
555 ptr_type_node, ptr_type_node,
556 ptr_type_node, NULL_TREE);
557 end_handler_decl
558 = create_subprog_decl (get_identifier ("__gnat_end_handler_v1"), NULL_TREE,
559 ftype, NULL_TREE,
560 is_default, true, true, true, false, false, NULL,
561 Empty);
562
563 ftype = build_function_type_list (void_type_node, ptr_type_node, NULL_TREE);
564 unhandled_except_decl
565 = create_subprog_decl (get_identifier ("__gnat_unhandled_except_handler"),
566 NULL_TREE, ftype, NULL_TREE,
567 is_default, true, true, true, false, false, NULL,
568 Empty);
569
570 /* Indicate that it never returns. */
571 ftype = build_qualified_type (ftype, TYPE_QUAL_VOLATILE);
572 reraise_zcx_decl
573 = create_subprog_decl (get_identifier ("__gnat_reraise_zcx"), NULL_TREE,
574 ftype, NULL_TREE,
575 is_default, true, true, true, false, false, NULL,
576 Empty);
577
578 /* Dummy objects to materialize "others" and "all others" in the exception
579 tables. These are exported by a-exexpr-gcc.adb, so see this unit for
580 the types to use. */
581 others_decl
582 = create_var_decl (get_identifier ("OTHERS"),
583 get_identifier ("__gnat_others_value"),
584 char_type_node, NULL_TREE,
585 true, false, true, false, false, true, false,
586 NULL, Empty);
587
588 all_others_decl
589 = create_var_decl (get_identifier ("ALL_OTHERS"),
590 get_identifier ("__gnat_all_others_value"),
591 char_type_node, NULL_TREE,
592 true, false, true, false, false, true, false,
593 NULL, Empty);
594
595 unhandled_others_decl
596 = create_var_decl (get_identifier ("UNHANDLED_OTHERS"),
597 get_identifier ("__gnat_unhandled_others_value"),
598 char_type_node, NULL_TREE,
599 true, false, true, false, false, true, false,
600 NULL, Empty);
601
602 /* If in no exception handlers mode, all raise statements are redirected to
603 __gnat_last_chance_handler. No need to redefine raise_nodefer_decl since
604 this procedure will never be called in this mode. */
605 if (No_Exception_Handlers_Set ())
606 {
607 /* Indicate that it never returns. */
608 ftype = build_function_type_list (void_type_node,
609 build_pointer_type (char_type_node),
610 integer_type_node, NULL_TREE);
611 ftype = build_qualified_type (ftype, TYPE_QUAL_VOLATILE);
612 tree decl
613 = create_subprog_decl
614 (get_identifier ("__gnat_last_chance_handler"), NULL_TREE, ftype,
615 NULL_TREE, is_default, true, true, true, false, false, NULL,
616 Empty);
617 for (i = 0; i < (int) ARRAY_SIZE (gnat_raise_decls); i++)
618 gnat_raise_decls[i] = decl;
619 }
620 else
621 {
622 /* Otherwise, make one decl for each exception reason. */
623 for (i = 0; i < (int) ARRAY_SIZE (gnat_raise_decls); i++)
624 gnat_raise_decls[i] = build_raise_check (i, exception_simple);
625 for (i = 0; i < (int) ARRAY_SIZE (gnat_raise_decls_ext); i++)
626 gnat_raise_decls_ext[i]
627 = build_raise_check (i,
628 i == CE_Index_Check_Failed
629 || i == CE_Range_Check_Failed
630 || i == CE_Invalid_Data
631 ? exception_range : exception_column);
632 }
633
634 /* Build the special descriptor type and its null node if needed. */
635 if (TARGET_VTABLE_USES_DESCRIPTORS)
636 {
637 tree null_node = fold_convert (ptr_void_ftype, null_pointer_node);
638 tree field_list = NULL_TREE;
639 int j;
640 vec<constructor_elt, va_gc> *null_vec = NULL;
641 constructor_elt *elt;
642
643 fdesc_type_node = make_node (RECORD_TYPE);
644 vec_safe_grow (null_vec, TARGET_VTABLE_USES_DESCRIPTORS, true);
645 elt = (null_vec->address () + TARGET_VTABLE_USES_DESCRIPTORS - 1);
646
647 for (j = 0; j < TARGET_VTABLE_USES_DESCRIPTORS; j++)
648 {
649 tree field
650 = create_field_decl (NULL_TREE, ptr_void_ftype, fdesc_type_node,
651 NULL_TREE, NULL_TREE, 0, 1);
652 DECL_CHAIN (field) = field_list;
653 field_list = field;
654 elt->index = field;
655 elt->value = null_node;
656 elt--;
657 }
658
659 finish_record_type (fdesc_type_node, nreverse (field_list), 0, false);
660 record_builtin_type ("descriptor", fdesc_type_node, true);
661 null_fdesc_node = gnat_build_constructor (fdesc_type_node, null_vec);
662 }
663
664 longest_float_type_node
665 = get_unpadded_type (Base_Type (standard_long_long_float));
666
667 main_identifier_node = get_identifier ("main");
668
669 /* If we are using the GCC exception mechanism, let GCC know. */
670 if (Back_End_Exceptions ())
671 gnat_init_gcc_eh ();
672
673 /* Initialize the GCC support for FP operations. */
674 gnat_init_gcc_fp ();
675
676 /* Install the builtins we might need, either internally or as user-available
677 facilities for Intrinsic imports. Note that this must be done after the
678 GCC exception mechanism is initialized. */
679 gnat_install_builtins ();
680
681 vec_safe_push (gnu_except_ptr_stack, NULL_TREE);
682
683 gnu_constraint_error_label_stack.safe_push (Empty);
684 gnu_storage_error_label_stack.safe_push (Empty);
685 gnu_program_error_label_stack.safe_push (Empty);
686
687 /* Process any Pragma Ident for the main unit. */
688 if (Present (Ident_String (Main_Unit)))
689 targetm.asm_out.output_ident
690 (TREE_STRING_POINTER (gnat_to_gnu (Ident_String (Main_Unit))));
691
692 /* Force -fno-strict-aliasing if the configuration pragma was seen. */
693 if (No_Strict_Aliasing_CP)
694 flag_strict_aliasing = 0;
695
696 /* Save the current optimization options again after the above possible
697 global_options changes. */
698 optimization_default_node
699 = build_optimization_node (&global_options, &global_options_set);
700 optimization_current_node = optimization_default_node;
701
702 /* Now translate the compilation unit proper. */
703 Compilation_Unit_to_gnu (gnat_root);
704
705 /* Then process the N_Validate_Unchecked_Conversion nodes. We do this at
706 the very end to avoid having to second-guess the front-end when we run
707 into dummy nodes during the regular processing. */
708 for (i = 0; gnat_validate_uc_list.iterate (i, &gnat_iter); i++)
709 validate_unchecked_conversion (gnat_iter);
710 gnat_validate_uc_list.release ();
711
712 /* Finally see if we have any elaboration procedures to deal with. */
713 for (info = elab_info_list; info; info = info->next)
714 {
715 tree gnu_body = DECL_SAVED_TREE (info->elab_proc);
716
717 /* We should have a BIND_EXPR but it may not have any statements in it.
718 If it doesn't have any, we have nothing to do except for setting the
719 flag on the GNAT node. Otherwise, process the function as others. */
720 tree gnu_stmts = gnu_body;
721 if (TREE_CODE (gnu_stmts) == BIND_EXPR)
722 gnu_stmts = BIND_EXPR_BODY (gnu_stmts);
723 if (!gnu_stmts || empty_stmt_list_p (gnu_stmts))
724 Set_Has_No_Elaboration_Code (info->gnat_node, 1);
725 else
726 {
727 begin_subprog_body (info->elab_proc);
728 end_subprog_body (gnu_body);
729 rest_of_subprog_body_compilation (info->elab_proc);
730 }
731 }
732
733 /* Destroy ourselves. */
734 file_map = NULL;
735 destroy_gnat_decl ();
736 destroy_gnat_utils ();
737
738 /* We cannot track the location of errors past this point. */
739 Current_Error_Node = Empty;
740 }
741
742 /* Return a subprogram decl corresponding to __gnat_rcheck_xx for the given
743 CHECK if KIND is EXCEPTION_SIMPLE, or else to __gnat_rcheck_xx_ext. */
744
745 static tree
build_raise_check(int check,enum exception_info_kind kind)746 build_raise_check (int check, enum exception_info_kind kind)
747 {
748 tree result, ftype;
749 const char pfx[] = "__gnat_rcheck_";
750
751 strcpy (Name_Buffer, pfx);
752 Name_Len = sizeof (pfx) - 1;
753 Get_RT_Exception_Name ((enum RT_Exception_Code) check);
754
755 if (kind == exception_simple)
756 {
757 Name_Buffer[Name_Len] = 0;
758 ftype
759 = build_function_type_list (void_type_node,
760 build_pointer_type (char_type_node),
761 integer_type_node, NULL_TREE);
762 }
763 else
764 {
765 tree t = (kind == exception_column ? NULL_TREE : integer_type_node);
766
767 strcpy (Name_Buffer + Name_Len, "_ext");
768 Name_Buffer[Name_Len + 4] = 0;
769 ftype
770 = build_function_type_list (void_type_node,
771 build_pointer_type (char_type_node),
772 integer_type_node, integer_type_node,
773 t, t, NULL_TREE);
774 }
775
776 /* Indicate that it never returns. */
777 ftype = build_qualified_type (ftype, TYPE_QUAL_VOLATILE);
778 result
779 = create_subprog_decl (get_identifier (Name_Buffer), NULL_TREE, ftype,
780 NULL_TREE, is_default, true, true, true, false,
781 false, NULL, Empty);
782
783 return result;
784 }
785
786 /* Return a positive value if an lvalue is required for GNAT_NODE, which is
787 an N_Attribute_Reference. */
788
789 static int
lvalue_required_for_attribute_p(Node_Id gnat_node)790 lvalue_required_for_attribute_p (Node_Id gnat_node)
791 {
792 switch (Get_Attribute_Id (Attribute_Name (gnat_node)))
793 {
794 case Attr_Pred:
795 case Attr_Succ:
796 case Attr_First:
797 case Attr_Last:
798 case Attr_Range_Length:
799 case Attr_Length:
800 case Attr_Object_Size:
801 case Attr_Size:
802 case Attr_Value_Size:
803 case Attr_Component_Size:
804 case Attr_Descriptor_Size:
805 case Attr_Max_Size_In_Storage_Elements:
806 case Attr_Min:
807 case Attr_Max:
808 case Attr_Null_Parameter:
809 case Attr_Passed_By_Reference:
810 case Attr_Mechanism_Code:
811 case Attr_Machine:
812 case Attr_Model:
813 return 0;
814
815 case Attr_Address:
816 case Attr_Access:
817 case Attr_Unchecked_Access:
818 case Attr_Unrestricted_Access:
819 case Attr_Code_Address:
820 case Attr_Pool_Address:
821 case Attr_Alignment:
822 case Attr_Bit_Position:
823 case Attr_Position:
824 case Attr_First_Bit:
825 case Attr_Last_Bit:
826 case Attr_Bit:
827 case Attr_Asm_Input:
828 case Attr_Asm_Output:
829 default:
830 return 1;
831 }
832 }
833
834 /* Return a positive value if an lvalue is required for GNAT_NODE. GNU_TYPE
835 is the type that will be used for GNAT_NODE in the translated GNU tree.
836 CONSTANT indicates whether the underlying object represented by GNAT_NODE
837 is constant in the Ada sense. If it is, ADDRESS_OF_CONSTANT indicates
838 whether its value is the address of another constant. If it isn't, then
839 ADDRESS_OF_CONSTANT is ignored.
840
841 The function climbs up the GNAT tree starting from the node and returns 1
842 upon encountering a node that effectively requires an lvalue downstream.
843 It returns int instead of bool to facilitate usage in non-purely binary
844 logic contexts. */
845
846 static int
lvalue_required_p(Node_Id gnat_node,tree gnu_type,bool constant,bool address_of_constant)847 lvalue_required_p (Node_Id gnat_node, tree gnu_type, bool constant,
848 bool address_of_constant)
849 {
850 Node_Id gnat_parent = Parent (gnat_node), gnat_temp;
851
852 switch (Nkind (gnat_parent))
853 {
854 case N_Reference:
855 return 1;
856
857 case N_Attribute_Reference:
858 return lvalue_required_for_attribute_p (gnat_parent);
859
860 case N_Parameter_Association:
861 case N_Function_Call:
862 case N_Procedure_Call_Statement:
863 /* If the parameter is by reference, an lvalue is required. */
864 return (!constant
865 || must_pass_by_ref (gnu_type)
866 || default_pass_by_ref (gnu_type));
867
868 case N_Indexed_Component:
869 /* Only the array expression can require an lvalue. */
870 if (Prefix (gnat_parent) != gnat_node)
871 return 0;
872
873 /* ??? Consider that referencing an indexed component with a variable
874 index forces the whole aggregate to memory. Note that testing only
875 for literals is conservative, any static expression in the RM sense
876 could probably be accepted with some additional work. */
877 for (gnat_temp = First (Expressions (gnat_parent));
878 Present (gnat_temp);
879 gnat_temp = Next (gnat_temp))
880 if (Nkind (gnat_temp) != N_Character_Literal
881 && Nkind (gnat_temp) != N_Integer_Literal
882 && !(Is_Entity_Name (gnat_temp)
883 && Ekind (Entity (gnat_temp)) == E_Enumeration_Literal))
884 return 1;
885
886 /* ... fall through ... */
887
888 case N_Selected_Component:
889 case N_Slice:
890 /* Only the prefix expression can require an lvalue. */
891 if (Prefix (gnat_parent) != gnat_node)
892 return 0;
893
894 return lvalue_required_p (gnat_parent,
895 get_unpadded_type (Etype (gnat_parent)),
896 constant, address_of_constant);
897
898 case N_Object_Renaming_Declaration:
899 /* We need to preserve addresses through a renaming. */
900 return 1;
901
902 case N_Object_Declaration:
903 /* We cannot use a constructor if this is an atomic object because
904 the actual assignment might end up being done component-wise. */
905 return (!constant
906 ||(Is_Composite_Type (Underlying_Type (Etype (gnat_node)))
907 && Is_Full_Access (Defining_Entity (gnat_parent)))
908 /* We don't use a constructor if this is a class-wide object
909 because the effective type of the object is the equivalent
910 type of the class-wide subtype and it smashes most of the
911 data into an array of bytes to which we cannot convert. */
912 || Ekind ((Etype (Defining_Entity (gnat_parent))))
913 == E_Class_Wide_Subtype);
914
915 case N_Assignment_Statement:
916 /* We cannot use a constructor if the LHS is an atomic object because
917 the actual assignment might end up being done component-wise. */
918 return (!constant
919 || Name (gnat_parent) == gnat_node
920 || (Is_Composite_Type (Underlying_Type (Etype (gnat_node)))
921 && Is_Entity_Name (Name (gnat_parent))
922 && Is_Full_Access (Entity (Name (gnat_parent)))));
923
924 case N_Unchecked_Type_Conversion:
925 if (!constant)
926 return 1;
927
928 /* ... fall through ... */
929
930 case N_Type_Conversion:
931 case N_Qualified_Expression:
932 /* We must look through all conversions because we may need to bypass
933 an intermediate conversion that is meant to be purely formal. */
934 return lvalue_required_p (gnat_parent,
935 get_unpadded_type (Etype (gnat_parent)),
936 constant, address_of_constant);
937
938 case N_Explicit_Dereference:
939 /* We look through dereferences for address of constant because we need
940 to handle the special cases listed above. */
941 if (constant && address_of_constant)
942 return lvalue_required_p (gnat_parent,
943 get_unpadded_type (Etype (gnat_parent)),
944 true, false);
945
946 /* ... fall through ... */
947
948 default:
949 return 0;
950 }
951
952 gcc_unreachable ();
953 }
954
955 /* Return true if an lvalue should be used for GNAT_NODE. GNU_TYPE is the type
956 that will be used for GNAT_NODE in the translated GNU tree and is assumed to
957 be an aggregate type.
958
959 The function climbs up the GNAT tree starting from the node and returns true
960 upon encountering a node that makes it doable to decide. lvalue_required_p
961 should have been previously invoked on the arguments and returned false. */
962
963 static bool
lvalue_for_aggregate_p(Node_Id gnat_node,tree gnu_type)964 lvalue_for_aggregate_p (Node_Id gnat_node, tree gnu_type)
965 {
966 Node_Id gnat_parent = Parent (gnat_node);
967
968 switch (Nkind (gnat_parent))
969 {
970 case N_Parameter_Association:
971 case N_Function_Call:
972 case N_Procedure_Call_Statement:
973 /* Even if the parameter is by copy, prefer an lvalue. */
974 return true;
975
976 case N_Simple_Return_Statement:
977 /* Likewise for a return value. */
978 return true;
979
980 case N_Indexed_Component:
981 case N_Selected_Component:
982 /* If an elementary component is used, take it from the constant. */
983 if (!Is_Composite_Type (Underlying_Type (Etype (gnat_parent))))
984 return false;
985
986 /* ... fall through ... */
987
988 case N_Slice:
989 return lvalue_for_aggregate_p (gnat_parent,
990 get_unpadded_type (Etype (gnat_parent)));
991
992 case N_Object_Declaration:
993 /* For an aggregate object declaration, return false consistently. */
994 return false;
995
996 case N_Assignment_Statement:
997 /* For an aggregate assignment, decide based on the size. */
998 {
999 const HOST_WIDE_INT size = int_size_in_bytes (gnu_type);
1000 return size < 0 || size >= param_large_stack_frame / 4;
1001 }
1002
1003 case N_Unchecked_Type_Conversion:
1004 case N_Type_Conversion:
1005 case N_Qualified_Expression:
1006 return lvalue_for_aggregate_p (gnat_parent,
1007 get_unpadded_type (Etype (gnat_parent)));
1008
1009 case N_Allocator:
1010 /* We should only reach here through the N_Qualified_Expression case.
1011 Force an lvalue for aggregate types since a block-copy to the newly
1012 allocated area of memory is made. */
1013 return true;
1014
1015 default:
1016 return false;
1017 }
1018
1019 gcc_unreachable ();
1020 }
1021
1022
1023 /* Return true if T is a constant DECL node that can be safely replaced
1024 by its initializer. */
1025
1026 static bool
constant_decl_with_initializer_p(tree t)1027 constant_decl_with_initializer_p (tree t)
1028 {
1029 if (!TREE_CONSTANT (t) || !DECL_P (t) || !DECL_INITIAL (t))
1030 return false;
1031
1032 /* Return false for aggregate types that contain a placeholder since
1033 their initializers cannot be manipulated easily. */
1034 if (AGGREGATE_TYPE_P (TREE_TYPE (t))
1035 && !TYPE_IS_FAT_POINTER_P (TREE_TYPE (t))
1036 && type_contains_placeholder_p (TREE_TYPE (t)))
1037 return false;
1038
1039 return true;
1040 }
1041
1042 /* Return an expression equivalent to EXP but where constant DECL nodes
1043 have been replaced by their initializer. */
1044
1045 static tree
fold_constant_decl_in_expr(tree exp)1046 fold_constant_decl_in_expr (tree exp)
1047 {
1048 enum tree_code code = TREE_CODE (exp);
1049 tree op0;
1050
1051 switch (code)
1052 {
1053 case CONST_DECL:
1054 case VAR_DECL:
1055 if (!constant_decl_with_initializer_p (exp))
1056 return exp;
1057
1058 return DECL_INITIAL (exp);
1059
1060 case COMPONENT_REF:
1061 op0 = fold_constant_decl_in_expr (TREE_OPERAND (exp, 0));
1062 if (op0 == TREE_OPERAND (exp, 0))
1063 return exp;
1064
1065 return fold_build3 (COMPONENT_REF, TREE_TYPE (exp), op0,
1066 TREE_OPERAND (exp, 1), NULL_TREE);
1067
1068 case BIT_FIELD_REF:
1069 op0 = fold_constant_decl_in_expr (TREE_OPERAND (exp, 0));
1070 if (op0 == TREE_OPERAND (exp, 0))
1071 return exp;
1072
1073 return fold_build3 (BIT_FIELD_REF, TREE_TYPE (exp), op0,
1074 TREE_OPERAND (exp, 1), TREE_OPERAND (exp, 2));
1075
1076 case ARRAY_REF:
1077 case ARRAY_RANGE_REF:
1078 /* If the index is not itself constant, then nothing can be folded. */
1079 if (!TREE_CONSTANT (TREE_OPERAND (exp, 1)))
1080 return exp;
1081 op0 = fold_constant_decl_in_expr (TREE_OPERAND (exp, 0));
1082 if (op0 == TREE_OPERAND (exp, 0))
1083 return exp;
1084
1085 return fold (build4 (code, TREE_TYPE (exp), op0, TREE_OPERAND (exp, 1),
1086 TREE_OPERAND (exp, 2), NULL_TREE));
1087
1088 case REALPART_EXPR:
1089 case IMAGPART_EXPR:
1090 case VIEW_CONVERT_EXPR:
1091 op0 = fold_constant_decl_in_expr (TREE_OPERAND (exp, 0));
1092 if (op0 == TREE_OPERAND (exp, 0))
1093 return exp;
1094
1095 return fold_build1 (code, TREE_TYPE (exp), op0);
1096
1097 default:
1098 return exp;
1099 }
1100
1101 gcc_unreachable ();
1102 }
1103
1104 /* Return true if TYPE and DEF_TYPE are compatible GNAT types for Gigi. */
1105
1106 static bool
Gigi_Types_Compatible(Entity_Id type,Entity_Id def_type)1107 Gigi_Types_Compatible (Entity_Id type, Entity_Id def_type)
1108 {
1109 /* The trivial case. */
1110 if (type == def_type)
1111 return true;
1112
1113 /* A class-wide type is equivalent to a subtype of itself. */
1114 if (Is_Class_Wide_Type (type))
1115 return true;
1116
1117 /* A packed array type is compatible with its implementation type. */
1118 if (Is_Packed (def_type) && type == Packed_Array_Impl_Type (def_type))
1119 return true;
1120
1121 /* If both types are Itypes, one may be a copy of the other. */
1122 if (Is_Itype (def_type) && Is_Itype (type))
1123 return true;
1124
1125 /* If the type is incomplete and comes from a limited context, then also
1126 consider its non-limited view. */
1127 if (Is_Incomplete_Type (def_type)
1128 && From_Limited_With (def_type)
1129 && Present (Non_Limited_View (def_type)))
1130 return Gigi_Types_Compatible (type, Non_Limited_View (def_type));
1131
1132 /* If the type is incomplete/private, then also consider its full view. */
1133 if (Is_Incomplete_Or_Private_Type (def_type)
1134 && Present (Full_View (def_type)))
1135 return Gigi_Types_Compatible (type, Full_View (def_type));
1136
1137 return false;
1138 }
1139
1140 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Identifier,
1141 to a GCC tree, which is returned. GNU_RESULT_TYPE_P is a pointer
1142 to where we should place the result type. */
1143
1144 static tree
Identifier_to_gnu(Node_Id gnat_node,tree * gnu_result_type_p)1145 Identifier_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p)
1146 {
1147 /* The entity of GNAT_NODE and its type. */
1148 Node_Id gnat_entity = (Nkind (gnat_node) == N_Defining_Identifier
1149 || Nkind (gnat_node) == N_Defining_Operator_Symbol)
1150 ? gnat_node : Entity (gnat_node);
1151 Node_Id gnat_entity_type = Etype (gnat_entity);
1152 /* If GNAT_NODE is a constant, whether we should use the initialization
1153 value instead of the constant entity, typically for scalars with an
1154 address clause when the parent doesn't require an lvalue. */
1155 bool use_constant_initializer = false;
1156 /* Whether we should require an lvalue for GNAT_NODE. Needed in
1157 specific circumstances only, so evaluated lazily. < 0 means
1158 unknown, > 0 means known true, 0 means known false. */
1159 int require_lvalue = -1;
1160 Node_Id gnat_result_type;
1161 tree gnu_result, gnu_result_type;
1162
1163 /* If the Etype of this node is not the same as that of the Entity, then
1164 something went wrong, probably in generic instantiation. However, this
1165 does not apply to types. Since we sometime have strange Ekind's, just
1166 do this test for objects, except for discriminants because their type
1167 may have been changed to a subtype by Exp_Ch3.Adjust_Discriminants. */
1168 gcc_assert (!Is_Object (gnat_entity)
1169 || Ekind (gnat_entity) == E_Discriminant
1170 || Etype (gnat_node) == gnat_entity_type
1171 || Gigi_Types_Compatible (Etype (gnat_node), gnat_entity_type));
1172
1173 /* If this is a reference to a deferred constant whose partial view is an
1174 unconstrained private type, the proper type is on the full view of the
1175 constant, not on the full view of the type, which may be unconstrained.
1176
1177 This may be a reference to a type, for example in the prefix of the
1178 attribute Position, generated for dispatching code (see Make_DT in
1179 exp_disp,adb). In that case we need the type itself, not is parent,
1180 in particular if it is a derived type */
1181 if (Ekind (gnat_entity) == E_Constant
1182 && Is_Private_Type (gnat_entity_type)
1183 && (Has_Unknown_Discriminants (gnat_entity_type)
1184 || (Present (Full_View (gnat_entity_type))
1185 && Has_Discriminants (Full_View (gnat_entity_type))))
1186 && Present (Full_View (gnat_entity)))
1187 {
1188 gnat_entity = Full_View (gnat_entity);
1189 gnat_result_type = Etype (gnat_entity);
1190 }
1191 else
1192 {
1193 /* We use the Actual_Subtype only if it has already been elaborated,
1194 as we may be invoked precisely during its elaboration, otherwise
1195 the Etype. Avoid using it for packed arrays to simplify things,
1196 except in a return statement because we need the actual size and
1197 the front-end does not make it explicit in this case. */
1198 if ((Ekind (gnat_entity) == E_Constant
1199 || Ekind (gnat_entity) == E_Variable
1200 || Is_Formal (gnat_entity))
1201 && !(Is_Array_Type (Etype (gnat_entity))
1202 && Present (Packed_Array_Impl_Type (Etype (gnat_entity)))
1203 && Nkind (Parent (gnat_node)) != N_Simple_Return_Statement)
1204 && Present (Actual_Subtype (gnat_entity))
1205 && present_gnu_tree (Actual_Subtype (gnat_entity)))
1206 gnat_result_type = Actual_Subtype (gnat_entity);
1207 else
1208 gnat_result_type = Etype (gnat_node);
1209 }
1210
1211 /* Expand the type of this identifier first, in case it is an enumeral
1212 literal, which only get made when the type is expanded. There is no
1213 order-of-elaboration issue here. */
1214 gnu_result_type = get_unpadded_type (gnat_result_type);
1215
1216 /* If this is a non-imported elementary constant with an address clause,
1217 retrieve the value instead of a pointer to be dereferenced unless
1218 an lvalue is required. This is generally more efficient and actually
1219 required if this is a static expression because it might be used
1220 in a context where a dereference is inappropriate, such as a case
1221 statement alternative or a record discriminant. There is no possible
1222 volatile-ness short-circuit here since Volatile constants must be
1223 imported per C.6. */
1224 if (Ekind (gnat_entity) == E_Constant
1225 && Is_Elementary_Type (gnat_result_type)
1226 && !Is_Imported (gnat_entity)
1227 && Present (Address_Clause (gnat_entity)))
1228 {
1229 require_lvalue
1230 = lvalue_required_p (gnat_node, gnu_result_type, true, false);
1231 use_constant_initializer = !require_lvalue;
1232 }
1233
1234 if (use_constant_initializer)
1235 {
1236 /* If this is a deferred constant, the initializer is attached to
1237 the full view. */
1238 if (Present (Full_View (gnat_entity)))
1239 gnat_entity = Full_View (gnat_entity);
1240
1241 gnu_result = gnat_to_gnu (Expression (Declaration_Node (gnat_entity)));
1242 }
1243 else
1244 gnu_result = gnat_to_gnu_entity (gnat_entity, NULL_TREE, false);
1245
1246 /* Some objects (such as parameters passed by reference, globals of
1247 variable size, and renamed objects) actually represent the address
1248 of the object. In that case, we must do the dereference. Likewise,
1249 deal with parameters to foreign convention subprograms. */
1250 if (DECL_P (gnu_result)
1251 && (DECL_BY_REF_P (gnu_result)
1252 || (TREE_CODE (gnu_result) == PARM_DECL
1253 && DECL_BY_COMPONENT_PTR_P (gnu_result))))
1254 {
1255 const bool read_only = DECL_POINTS_TO_READONLY_P (gnu_result);
1256
1257 /* If it's a PARM_DECL to foreign convention subprogram, convert it. */
1258 if (TREE_CODE (gnu_result) == PARM_DECL
1259 && DECL_BY_COMPONENT_PTR_P (gnu_result))
1260 gnu_result
1261 = convert (build_pointer_type (gnu_result_type), gnu_result);
1262
1263 /* If it's a CONST_DECL, return the underlying constant like below. */
1264 else if (TREE_CODE (gnu_result) == CONST_DECL
1265 && !(DECL_CONST_ADDRESS_P (gnu_result)
1266 && lvalue_required_p (gnat_node, gnu_result_type, true,
1267 true)))
1268 gnu_result = DECL_INITIAL (gnu_result);
1269
1270 /* Do the final dereference. */
1271 gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_result);
1272
1273 if ((TREE_CODE (gnu_result) == INDIRECT_REF
1274 || TREE_CODE (gnu_result) == UNCONSTRAINED_ARRAY_REF)
1275 && No (Address_Clause (gnat_entity)))
1276 TREE_THIS_NOTRAP (gnu_result) = 1;
1277
1278 if (read_only)
1279 TREE_READONLY (gnu_result) = 1;
1280 }
1281
1282 /* If we have a constant declaration and its initializer, try to return the
1283 latter to avoid the need to call fold in lots of places and the need for
1284 elaboration code if this identifier is used as an initializer itself. */
1285 if (constant_decl_with_initializer_p (gnu_result))
1286 {
1287 bool constant_only = (TREE_CODE (gnu_result) == CONST_DECL
1288 && !DECL_CONST_CORRESPONDING_VAR (gnu_result));
1289 bool address_of_constant = (TREE_CODE (gnu_result) == CONST_DECL
1290 && DECL_CONST_ADDRESS_P (gnu_result));
1291
1292 /* If there is a (corresponding) variable or this is the address of a
1293 constant, we only want to return the initializer if an lvalue isn't
1294 required. Evaluate this now if we have not already done so. */
1295 if ((!constant_only || address_of_constant) && require_lvalue < 0)
1296 require_lvalue
1297 = lvalue_required_p (gnat_node, gnu_result_type, true,
1298 address_of_constant)
1299 || (AGGREGATE_TYPE_P (gnu_result_type)
1300 && lvalue_for_aggregate_p (gnat_node, gnu_result_type));
1301
1302 /* Finally retrieve the initializer if this is deemed valid. */
1303 if ((constant_only && !address_of_constant) || !require_lvalue)
1304 gnu_result = DECL_INITIAL (gnu_result);
1305 }
1306
1307 /* But for a constant renaming we couldn't do that incrementally for its
1308 definition because of the need to return an lvalue so, if the present
1309 context doesn't itself require an lvalue, we try again here. */
1310 else if (Ekind (gnat_entity) == E_Constant
1311 && Is_Elementary_Type (gnat_result_type)
1312 && Present (Renamed_Object (gnat_entity)))
1313 {
1314 if (require_lvalue < 0)
1315 require_lvalue
1316 = lvalue_required_p (gnat_node, gnu_result_type, true, false);
1317 if (!require_lvalue)
1318 gnu_result = fold_constant_decl_in_expr (gnu_result);
1319 }
1320
1321 /* The GNAT tree has the type of a function set to its result type, so we
1322 adjust here. Also use the type of the result if the Etype is a subtype
1323 that is nominally unconstrained. Likewise if this is a deferred constant
1324 of a discriminated type whose full view can be elaborated statically, to
1325 avoid problematic conversions to the nominal subtype. But remove any
1326 padding from the resulting type. */
1327 if (FUNC_OR_METHOD_TYPE_P (TREE_TYPE (gnu_result))
1328 || Is_Constr_Subt_For_UN_Aliased (gnat_result_type)
1329 || (Ekind (gnat_entity) == E_Constant
1330 && Present (Full_View (gnat_entity))
1331 && Has_Discriminants (gnat_result_type)
1332 && TREE_CODE (gnu_result) == CONSTRUCTOR))
1333 {
1334 gnu_result_type = TREE_TYPE (gnu_result);
1335 if (TYPE_IS_PADDING_P (gnu_result_type))
1336 gnu_result_type = TREE_TYPE (TYPE_FIELDS (gnu_result_type));
1337 }
1338
1339 *gnu_result_type_p = gnu_result_type;
1340
1341 return gnu_result;
1342 }
1343
1344 /* Subroutine of gnat_to_gnu to process gnat_node, an N_Pragma. Return
1345 any statements we generate. */
1346
1347 static tree
Pragma_to_gnu(Node_Id gnat_node)1348 Pragma_to_gnu (Node_Id gnat_node)
1349 {
1350 tree gnu_result = alloc_stmt_list ();
1351 Node_Id gnat_temp;
1352
1353 /* Check for (and ignore) unrecognized pragmas. */
1354 if (!Is_Pragma_Name (Chars (Pragma_Identifier (gnat_node))))
1355 return gnu_result;
1356
1357 const unsigned char id
1358 = Get_Pragma_Id (Chars (Pragma_Identifier (gnat_node)));
1359
1360 /* Save the expression of pragma Compile_Time_{Error|Warning} for later. */
1361 if (id == Pragma_Compile_Time_Error || id == Pragma_Compile_Time_Warning)
1362 {
1363 gnat_temp = First (Pragma_Argument_Associations (gnat_node));
1364 gnat_compile_time_expr_list.safe_push (Expression (gnat_temp));
1365 return gnu_result;
1366 }
1367
1368 /* Stop there if we are just annotating types. */
1369 if (type_annotate_only)
1370 return gnu_result;
1371
1372 switch (id)
1373 {
1374 case Pragma_Inspection_Point:
1375 /* Do nothing at top level: all such variables are already viewable. */
1376 if (global_bindings_p ())
1377 break;
1378
1379 for (gnat_temp = First (Pragma_Argument_Associations (gnat_node));
1380 Present (gnat_temp);
1381 gnat_temp = Next (gnat_temp))
1382 {
1383 Node_Id gnat_expr = Expression (gnat_temp);
1384 tree gnu_expr = gnat_to_gnu (gnat_expr);
1385 tree asm_constraint = NULL_TREE;
1386 #ifdef ASM_COMMENT_START
1387 char *comment;
1388 #endif
1389 gnu_expr = maybe_unconstrained_array (gnu_expr);
1390 gnat_mark_addressable (gnu_expr);
1391
1392 #ifdef ASM_COMMENT_START
1393 comment = concat (ASM_COMMENT_START,
1394 " inspection point: ",
1395 Get_Name_String (Chars (gnat_expr)),
1396 " is at %0",
1397 NULL);
1398 asm_constraint = build_string (strlen (comment), comment);
1399 free (comment);
1400 #endif
1401 gnu_expr = build5 (ASM_EXPR, void_type_node,
1402 asm_constraint,
1403 NULL_TREE,
1404 tree_cons
1405 (build_tree_list (NULL_TREE,
1406 build_string (1, "m")),
1407 gnu_expr, NULL_TREE),
1408 NULL_TREE, NULL_TREE);
1409 ASM_VOLATILE_P (gnu_expr) = 1;
1410 set_expr_location_from_node (gnu_expr, gnat_node);
1411 append_to_statement_list (gnu_expr, &gnu_result);
1412 }
1413 break;
1414
1415 case Pragma_Loop_Optimize:
1416 for (gnat_temp = First (Pragma_Argument_Associations (gnat_node));
1417 Present (gnat_temp);
1418 gnat_temp = Next (gnat_temp))
1419 {
1420 tree gnu_loop_stmt = gnu_loop_stack->last ()->stmt;
1421
1422 switch (Chars (Expression (gnat_temp)))
1423 {
1424 case Name_Ivdep:
1425 LOOP_STMT_IVDEP (gnu_loop_stmt) = 1;
1426 break;
1427
1428 case Name_No_Unroll:
1429 LOOP_STMT_NO_UNROLL (gnu_loop_stmt) = 1;
1430 break;
1431
1432 case Name_Unroll:
1433 LOOP_STMT_UNROLL (gnu_loop_stmt) = 1;
1434 break;
1435
1436 case Name_No_Vector:
1437 LOOP_STMT_NO_VECTOR (gnu_loop_stmt) = 1;
1438 break;
1439
1440 case Name_Vector:
1441 LOOP_STMT_VECTOR (gnu_loop_stmt) = 1;
1442 break;
1443
1444 default:
1445 gcc_unreachable ();
1446 }
1447 }
1448 break;
1449
1450 case Pragma_Optimize:
1451 switch (Chars (Expression
1452 (First (Pragma_Argument_Associations (gnat_node)))))
1453 {
1454 case Name_Off:
1455 if (optimize)
1456 post_error ("must specify -O0??", gnat_node);
1457 break;
1458
1459 case Name_Space:
1460 if (!optimize_size)
1461 post_error ("must specify -Os??", gnat_node);
1462 break;
1463
1464 case Name_Time:
1465 if (!optimize)
1466 post_error ("insufficient -O value??", gnat_node);
1467 break;
1468
1469 default:
1470 gcc_unreachable ();
1471 }
1472 break;
1473
1474 case Pragma_Reviewable:
1475 if (write_symbols == NO_DEBUG)
1476 post_error ("must specify -g??", gnat_node);
1477 break;
1478
1479 case Pragma_Warning_As_Error:
1480 case Pragma_Warnings:
1481 {
1482 Node_Id gnat_expr;
1483 /* Preserve the location of the pragma. */
1484 const location_t location = input_location;
1485 struct cl_option_handlers handlers;
1486 unsigned int option_index;
1487 diagnostic_t kind;
1488 bool imply;
1489
1490 gnat_temp = First (Pragma_Argument_Associations (gnat_node));
1491
1492 /* This is the String form: pragma Warning{s|_As_Error}(String). */
1493 if (Nkind (Expression (gnat_temp)) == N_String_Literal)
1494 {
1495 switch (id)
1496 {
1497 case Pragma_Warning_As_Error:
1498 kind = DK_ERROR;
1499 imply = false;
1500 break;
1501
1502 case Pragma_Warnings:
1503 kind = DK_WARNING;
1504 imply = true;
1505 break;
1506
1507 default:
1508 gcc_unreachable ();
1509 }
1510
1511 gnat_expr = Expression (gnat_temp);
1512 }
1513
1514 /* This is the On/Off form: pragma Warnings (On | Off [,String]). */
1515 else if (Nkind (Expression (gnat_temp)) == N_Identifier)
1516 {
1517 switch (Chars (Expression (gnat_temp)))
1518 {
1519 case Name_Off:
1520 kind = DK_IGNORED;
1521 break;
1522
1523 case Name_On:
1524 kind = DK_WARNING;
1525 break;
1526
1527 default:
1528 gcc_unreachable ();
1529 }
1530
1531 /* Deal with optional pattern (but ignore Reason => "..."). */
1532 if (Present (Next (gnat_temp))
1533 && Chars (Next (gnat_temp)) != Name_Reason)
1534 {
1535 /* pragma Warnings (On | Off, Name) is handled differently. */
1536 if (Nkind (Expression (Next (gnat_temp))) != N_String_Literal)
1537 break;
1538
1539 gnat_expr = Expression (Next (gnat_temp));
1540 }
1541 else
1542 {
1543 gnat_expr = Empty;
1544
1545 /* For pragma Warnings (Off), we save the current state... */
1546 if (kind == DK_IGNORED)
1547 diagnostic_push_diagnostics (global_dc, location);
1548
1549 /* ...so that, for pragma Warnings (On), we do not enable all
1550 the warnings but just restore the previous state. */
1551 else
1552 {
1553 diagnostic_pop_diagnostics (global_dc, location);
1554 break;
1555 }
1556 }
1557
1558 imply = false;
1559 }
1560
1561 else
1562 gcc_unreachable ();
1563
1564 /* This is the same implementation as in the C family of compilers. */
1565 const unsigned int lang_mask = CL_Ada | CL_COMMON;
1566 const char *arg = NULL;
1567 if (Present (gnat_expr))
1568 {
1569 tree gnu_expr = gnat_to_gnu (gnat_expr);
1570 const char *option_string = TREE_STRING_POINTER (gnu_expr);
1571 const int len = TREE_STRING_LENGTH (gnu_expr);
1572 if (len < 3 || option_string[0] != '-' || option_string[1] != 'W')
1573 break;
1574 option_index = find_opt (option_string + 1, lang_mask);
1575 if (option_index == OPT_SPECIAL_unknown)
1576 {
1577 post_error ("unknown -W switch??", gnat_node);
1578 break;
1579 }
1580 else if (!(cl_options[option_index].flags & CL_WARNING))
1581 {
1582 post_error ("-W switch does not control warning??", gnat_node);
1583 break;
1584 }
1585 else if (!(cl_options[option_index].flags & lang_mask))
1586 {
1587 post_error ("-W switch not valid for Ada??", gnat_node);
1588 break;
1589 }
1590 if (cl_options[option_index].flags & CL_JOINED)
1591 arg = option_string + 1 + cl_options[option_index].opt_len;
1592 }
1593 else
1594 option_index = 0;
1595
1596 set_default_handlers (&handlers, NULL);
1597 control_warning_option (option_index, (int) kind, arg, imply, location,
1598 lang_mask, &handlers, &global_options,
1599 &global_options_set, global_dc);
1600 }
1601 break;
1602
1603 default:
1604 break;
1605 }
1606
1607 return gnu_result;
1608 }
1609
1610 /* Check the inline status of nested function FNDECL wrt its parent function.
1611
1612 If a non-inline nested function is referenced from an inline external
1613 function, we cannot honor both requests at the same time without cloning
1614 the nested function in the current unit since it is private to its unit.
1615 We could inline it as well but it's probably better to err on the side
1616 of too little inlining.
1617
1618 This must be done only on nested functions present in the source code
1619 and not on nested functions generated by the compiler, e.g. finalizers,
1620 because they may be not marked inline and we don't want them to block
1621 the inlining of the parent function. */
1622
1623 static void
check_inlining_for_nested_subprog(tree fndecl)1624 check_inlining_for_nested_subprog (tree fndecl)
1625 {
1626 if (DECL_IGNORED_P (current_function_decl) || DECL_IGNORED_P (fndecl))
1627 return;
1628
1629 if (DECL_DECLARED_INLINE_P (fndecl))
1630 return;
1631
1632 tree parent_decl = decl_function_context (fndecl);
1633 if (DECL_EXTERNAL (parent_decl) && DECL_DECLARED_INLINE_P (parent_decl))
1634 {
1635 const location_t loc1 = DECL_SOURCE_LOCATION (fndecl);
1636 const location_t loc2 = DECL_SOURCE_LOCATION (parent_decl);
1637
1638 if (lookup_attribute ("always_inline", DECL_ATTRIBUTES (parent_decl)))
1639 {
1640 error_at (loc1, "subprogram %q+F not marked %<Inline_Always%>",
1641 fndecl);
1642 error_at (loc2, "parent subprogram cannot be inlined");
1643 }
1644 else
1645 {
1646 warning_at (loc1, OPT_Winline, "subprogram %q+F not marked %<Inline%>",
1647 fndecl);
1648 warning_at (loc2, OPT_Winline, "parent subprogram cannot be inlined");
1649 }
1650
1651 DECL_DECLARED_INLINE_P (parent_decl) = 0;
1652 DECL_UNINLINABLE (parent_decl) = 1;
1653 }
1654 }
1655
1656 /* Return an expression for the length of TYPE, an integral type, computed in
1657 RESULT_TYPE, another integral type.
1658
1659 We used to compute the length as MAX (hb - lb + 1, 0) which could overflow
1660 when lb == TYPE'First. We now compute it as (hb >= lb) ? hb - lb + 1 : 0
1661 which would only overflow in much rarer cases, for extremely large arrays
1662 we expect never to encounter in practice. Besides, the former computation
1663 required the use of potentially constraining signed arithmetics while the
1664 latter does not. Note that the comparison must be done in the original
1665 base index type in order to avoid any overflow during the conversion. */
1666
1667 static tree
get_type_length(tree type,tree result_type)1668 get_type_length (tree type, tree result_type)
1669 {
1670 tree comp_type = get_base_type (result_type);
1671 tree base_type = maybe_character_type (get_base_type (type));
1672 tree lb = convert (base_type, TYPE_MIN_VALUE (type));
1673 tree hb = convert (base_type, TYPE_MAX_VALUE (type));
1674 tree length
1675 = build_binary_op (PLUS_EXPR, comp_type,
1676 build_binary_op (MINUS_EXPR, comp_type,
1677 convert (comp_type, hb),
1678 convert (comp_type, lb)),
1679 build_int_cst (comp_type, 1));
1680 length
1681 = build_cond_expr (result_type,
1682 build_binary_op (GE_EXPR, boolean_type_node, hb, lb),
1683 convert (result_type, length),
1684 build_int_cst (result_type, 0));
1685 return length;
1686 }
1687
1688 /* Subroutine of gnat_to_gnu to translate GNAT_NODE, an N_Attribute node,
1689 to a GCC tree, which is returned. GNU_RESULT_TYPE_P is a pointer to
1690 where we should place the result type. ATTRIBUTE is the attribute ID. */
1691
1692 static tree
Attribute_to_gnu(Node_Id gnat_node,tree * gnu_result_type_p,int attribute)1693 Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute)
1694 {
1695 const Node_Id gnat_prefix = Prefix (gnat_node);
1696 tree gnu_prefix = gnat_to_gnu (gnat_prefix);
1697 tree gnu_type = TREE_TYPE (gnu_prefix);
1698 tree gnu_expr, gnu_result_type, gnu_result = error_mark_node;
1699 bool prefix_unused = false;
1700
1701 /* If the input is a NULL_EXPR, make a new one. */
1702 if (TREE_CODE (gnu_prefix) == NULL_EXPR)
1703 {
1704 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1705 *gnu_result_type_p = gnu_result_type;
1706 return build1 (NULL_EXPR, gnu_result_type, TREE_OPERAND (gnu_prefix, 0));
1707 }
1708
1709 switch (attribute)
1710 {
1711 case Attr_Pred:
1712 case Attr_Succ:
1713 /* These just add or subtract the constant 1 since representation
1714 clauses for enumeration types are handled in the front-end. */
1715 gnu_expr = gnat_to_gnu (First (Expressions (gnat_node)));
1716 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1717 gnu_type = maybe_character_type (gnu_result_type);
1718 if (TREE_TYPE (gnu_expr) != gnu_type)
1719 gnu_expr = convert (gnu_type, gnu_expr);
1720 gnu_result
1721 = build_binary_op (attribute == Attr_Pred ? MINUS_EXPR : PLUS_EXPR,
1722 gnu_type, gnu_expr, build_int_cst (gnu_type, 1));
1723 break;
1724
1725 case Attr_Address:
1726 case Attr_Unrestricted_Access:
1727 /* Conversions don't change the address of references but can cause
1728 build_unary_op to miss the references below, so strip them off.
1729 On the contrary, if the address-of operation causes a temporary
1730 to be created, then it must be created with the proper type. */
1731 gnu_expr = remove_conversions (gnu_prefix,
1732 !Must_Be_Byte_Aligned (gnat_node));
1733 if (REFERENCE_CLASS_P (gnu_expr))
1734 gnu_prefix = gnu_expr;
1735
1736 /* If we are taking 'Address of an unconstrained object, this is the
1737 pointer to the underlying array. */
1738 if (attribute == Attr_Address)
1739 gnu_prefix = maybe_unconstrained_array (gnu_prefix);
1740
1741 /* If we are building a static dispatch table, we have to honor
1742 TARGET_VTABLE_USES_DESCRIPTORS if we want to be compatible
1743 with the C++ ABI. We do it in the non-static case as well,
1744 see gnat_to_gnu_entity, case E_Access_Subprogram_Type. */
1745 else if (TARGET_VTABLE_USES_DESCRIPTORS
1746 && Is_Dispatch_Table_Entity (Etype (gnat_node)))
1747 {
1748 tree gnu_field, t;
1749 /* Descriptors can only be built here for top-level functions. */
1750 bool build_descriptor = (global_bindings_p () != 0);
1751 int i;
1752 vec<constructor_elt, va_gc> *gnu_vec = NULL;
1753 constructor_elt *elt;
1754
1755 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1756
1757 /* If we're not going to build the descriptor, we have to retrieve
1758 the one which will be built by the linker (or by the compiler
1759 later if a static chain is requested). */
1760 if (!build_descriptor)
1761 {
1762 gnu_result = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_prefix);
1763 gnu_result = fold_convert (build_pointer_type (gnu_result_type),
1764 gnu_result);
1765 gnu_result = build1 (INDIRECT_REF, gnu_result_type, gnu_result);
1766 }
1767
1768 vec_safe_grow (gnu_vec, TARGET_VTABLE_USES_DESCRIPTORS, true);
1769 elt = (gnu_vec->address () + TARGET_VTABLE_USES_DESCRIPTORS - 1);
1770 for (gnu_field = TYPE_FIELDS (gnu_result_type), i = 0;
1771 i < TARGET_VTABLE_USES_DESCRIPTORS;
1772 gnu_field = DECL_CHAIN (gnu_field), i++)
1773 {
1774 if (build_descriptor)
1775 {
1776 t = build2 (FDESC_EXPR, TREE_TYPE (gnu_field), gnu_prefix,
1777 build_int_cst (NULL_TREE, i));
1778 TREE_CONSTANT (t) = 1;
1779 }
1780 else
1781 t = build3 (COMPONENT_REF, ptr_void_ftype, gnu_result,
1782 gnu_field, NULL_TREE);
1783
1784 elt->index = gnu_field;
1785 elt->value = t;
1786 elt--;
1787 }
1788
1789 gnu_result = gnat_build_constructor (gnu_result_type, gnu_vec);
1790 break;
1791 }
1792
1793 /* ... fall through ... */
1794
1795 case Attr_Access:
1796 case Attr_Unchecked_Access:
1797 case Attr_Code_Address:
1798 /* Taking the address of a type does not make sense. */
1799 gcc_assert (TREE_CODE (gnu_prefix) != TYPE_DECL);
1800
1801 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1802 gnu_result
1803 = build_unary_op (((attribute == Attr_Address
1804 || attribute == Attr_Unrestricted_Access)
1805 && !Must_Be_Byte_Aligned (gnat_node))
1806 ? ATTR_ADDR_EXPR : ADDR_EXPR,
1807 gnu_result_type, gnu_prefix);
1808
1809 /* For 'Code_Address, find an inner ADDR_EXPR and mark it so that we
1810 don't try to build a trampoline. */
1811 if (attribute == Attr_Code_Address)
1812 {
1813 gnu_expr = remove_conversions (gnu_result, false);
1814
1815 if (TREE_CODE (gnu_expr) == ADDR_EXPR)
1816 TREE_NO_TRAMPOLINE (gnu_expr) = TREE_CONSTANT (gnu_expr) = 1;
1817
1818 /* On targets for which function symbols denote a descriptor, the
1819 code address is stored within the first slot of the descriptor
1820 so we do an additional dereference:
1821 result = *((result_type *) result)
1822 where we expect result to be of some pointer type already. */
1823 if (targetm.calls.custom_function_descriptors == 0)
1824 gnu_result
1825 = build_unary_op (INDIRECT_REF, NULL_TREE,
1826 convert (build_pointer_type (gnu_result_type),
1827 gnu_result));
1828 }
1829
1830 /* For 'Access, issue an error message if the prefix is a C++ method
1831 since it can use a special calling convention on some platforms,
1832 which cannot be propagated to the access type. */
1833 else if (attribute == Attr_Access
1834 && TREE_CODE (TREE_TYPE (gnu_prefix)) == METHOD_TYPE)
1835 post_error ("access to C++ constructor or member function not allowed",
1836 gnat_node);
1837
1838 /* For other address attributes applied to a nested function,
1839 find an inner ADDR_EXPR and annotate it so that we can issue
1840 a useful warning with -Wtrampolines. */
1841 else if (FUNC_OR_METHOD_TYPE_P (TREE_TYPE (gnu_prefix))
1842 && (gnu_expr = remove_conversions (gnu_result, false))
1843 && TREE_CODE (gnu_expr) == ADDR_EXPR
1844 && decl_function_context (TREE_OPERAND (gnu_expr, 0)))
1845 {
1846 set_expr_location_from_node (gnu_expr, gnat_node);
1847
1848 /* Also check the inlining status. */
1849 check_inlining_for_nested_subprog (TREE_OPERAND (gnu_expr, 0));
1850
1851 /* Moreover, for 'Access or 'Unrestricted_Access with non-
1852 foreign-compatible representation, mark the ADDR_EXPR so
1853 that we can build a descriptor instead of a trampoline. */
1854 if ((attribute == Attr_Access
1855 || attribute == Attr_Unrestricted_Access)
1856 && targetm.calls.custom_function_descriptors > 0
1857 && Can_Use_Internal_Rep (Underlying_Type (Etype (gnat_node))))
1858 FUNC_ADDR_BY_DESCRIPTOR (gnu_expr) = 1;
1859
1860 /* Otherwise, we need to check that we are not violating the
1861 No_Implicit_Dynamic_Code restriction. */
1862 else if (targetm.calls.custom_function_descriptors != 0)
1863 Check_Implicit_Dynamic_Code_Allowed (gnat_node);
1864 }
1865 break;
1866
1867 case Attr_Pool_Address:
1868 {
1869 tree gnu_ptr = gnu_prefix;
1870 tree gnu_obj_type;
1871
1872 gnu_result_type = get_unpadded_type (Etype (gnat_node));
1873
1874 /* If this is fat pointer, the object must have been allocated with the
1875 template in front of the array. So compute the template address; do
1876 it by converting to a thin pointer. */
1877 if (TYPE_IS_FAT_POINTER_P (TREE_TYPE (gnu_ptr)))
1878 gnu_ptr
1879 = convert (build_pointer_type
1880 (TYPE_OBJECT_RECORD_TYPE
1881 (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (gnu_ptr)))),
1882 gnu_ptr);
1883
1884 gnu_obj_type = TREE_TYPE (TREE_TYPE (gnu_ptr));
1885
1886 /* If this is a thin pointer, the object must have been allocated with
1887 the template in front of the array. So compute the template address
1888 and return it. */
1889 if (TYPE_IS_THIN_POINTER_P (TREE_TYPE (gnu_ptr)))
1890 gnu_ptr
1891 = build_binary_op (POINTER_PLUS_EXPR, TREE_TYPE (gnu_ptr),
1892 gnu_ptr,
1893 fold_build1 (NEGATE_EXPR, sizetype,
1894 byte_position
1895 (DECL_CHAIN
1896 TYPE_FIELDS ((gnu_obj_type)))));
1897
1898 gnu_result = convert (gnu_result_type, gnu_ptr);
1899 }
1900 break;
1901
1902 case Attr_Size:
1903 case Attr_Object_Size:
1904 case Attr_Value_Size:
1905 case Attr_Max_Size_In_Storage_Elements:
1906 /* Strip NOPs, conversions between original and packable versions, and
1907 unpadding from GNU_PREFIX. Note that we cannot simply strip every
1908 VIEW_CONVERT_EXPR because some of them may give the actual size, e.g.
1909 for nominally unconstrained packed array. We use GNU_EXPR to see
1910 if a COMPONENT_REF was involved. */
1911 while (CONVERT_EXPR_P (gnu_prefix)
1912 || TREE_CODE (gnu_prefix) == NON_LVALUE_EXPR
1913 || (TREE_CODE (gnu_prefix) == VIEW_CONVERT_EXPR
1914 && TREE_CODE (TREE_TYPE (gnu_prefix)) == RECORD_TYPE
1915 && TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0)))
1916 == RECORD_TYPE
1917 && TYPE_NAME (TREE_TYPE (gnu_prefix))
1918 == TYPE_NAME (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0)))))
1919 gnu_prefix = TREE_OPERAND (gnu_prefix, 0);
1920 gnu_expr = gnu_prefix;
1921 if (TREE_CODE (gnu_prefix) == COMPONENT_REF
1922 && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0))))
1923 gnu_prefix = TREE_OPERAND (gnu_prefix, 0);
1924 prefix_unused = true;
1925 gnu_type = TREE_TYPE (gnu_prefix);
1926
1927 /* Replace an unconstrained array type with the type of the underlying
1928 array, except for 'Max_Size_In_Storage_Elements because we need to
1929 return the (maximum) size requested for an allocator. */
1930 if (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE)
1931 {
1932 gnu_type = TYPE_OBJECT_RECORD_TYPE (gnu_type);
1933 if (attribute != Attr_Max_Size_In_Storage_Elements)
1934 gnu_type = TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (gnu_type)));
1935 }
1936
1937 /* The type must be frozen at this point. */
1938 gcc_assert (COMPLETE_TYPE_P (gnu_type));
1939
1940 /* If we're looking for the size of a field, return the field size. */
1941 if (TREE_CODE (gnu_prefix) == COMPONENT_REF)
1942 gnu_result = DECL_SIZE (TREE_OPERAND (gnu_prefix, 1));
1943
1944 /* Otherwise, if the prefix is an object, or if we are looking for
1945 'Object_Size or 'Max_Size_In_Storage_Elements, the result is the
1946 GCC size of the type. We make an exception for padded objects,
1947 as we do not take into account alignment promotions for the size.
1948 This is in keeping with the object case of gnat_to_gnu_entity. */
1949 else if ((TREE_CODE (gnu_prefix) != TYPE_DECL
1950 && !(TYPE_IS_PADDING_P (gnu_type)
1951 && TREE_CODE (gnu_expr) == COMPONENT_REF
1952 && pad_type_has_rm_size (gnu_type)))
1953 || attribute == Attr_Object_Size
1954 || attribute == Attr_Max_Size_In_Storage_Elements)
1955 {
1956 /* If this is a dereference and we have a special dynamic constrained
1957 subtype on the prefix, use it to compute the size; otherwise, use
1958 the designated subtype. */
1959 if (Nkind (gnat_prefix) == N_Explicit_Dereference)
1960 {
1961 Node_Id gnat_actual_subtype
1962 = Actual_Designated_Subtype (gnat_prefix);
1963 tree gnu_ptr_type
1964 = TREE_TYPE (gnat_to_gnu (Prefix (gnat_prefix)));
1965
1966 if (TYPE_IS_FAT_OR_THIN_POINTER_P (gnu_ptr_type)
1967 && Present (gnat_actual_subtype))
1968 {
1969 tree gnu_actual_obj_type
1970 = gnat_to_gnu_type (gnat_actual_subtype);
1971 gnu_type
1972 = build_unc_object_type_from_ptr (gnu_ptr_type,
1973 gnu_actual_obj_type,
1974 get_identifier ("SIZE"),
1975 false);
1976 }
1977 }
1978
1979 gnu_result = TYPE_SIZE (gnu_type);
1980 }
1981
1982 /* Otherwise, the result is the RM size of the type. */
1983 else
1984 gnu_result = rm_size (gnu_type);
1985
1986 /* Deal with a self-referential size by qualifying the size with the
1987 object or returning the maximum size for a type. */
1988 if (TREE_CODE (gnu_prefix) != TYPE_DECL)
1989 gnu_result = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_result, gnu_prefix);
1990 else if (CONTAINS_PLACEHOLDER_P (gnu_result))
1991 gnu_result = max_size (gnu_result, true);
1992
1993 /* If the type contains a template, subtract the padded size of the
1994 template, except for 'Max_Size_In_Storage_Elements because we need
1995 to return the (maximum) size requested for an allocator. */
1996 if (TREE_CODE (gnu_type) == RECORD_TYPE
1997 && TYPE_CONTAINS_TEMPLATE_P (gnu_type)
1998 && attribute != Attr_Max_Size_In_Storage_Elements)
1999 gnu_result
2000 = size_binop (MINUS_EXPR, gnu_result,
2001 bit_position (DECL_CHAIN (TYPE_FIELDS (gnu_type))));
2002
2003 /* For 'Max_Size_In_Storage_Elements, adjust the unit. */
2004 if (attribute == Attr_Max_Size_In_Storage_Elements)
2005 gnu_result = size_binop (CEIL_DIV_EXPR, gnu_result, bitsize_unit_node);
2006
2007 gnu_result_type = get_unpadded_type (Etype (gnat_node));
2008 break;
2009
2010 case Attr_Alignment:
2011 {
2012 unsigned int align;
2013
2014 if (TREE_CODE (gnu_prefix) == COMPONENT_REF
2015 && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0))))
2016 gnu_prefix = TREE_OPERAND (gnu_prefix, 0);
2017
2018 gnu_type = TREE_TYPE (gnu_prefix);
2019 gnu_result_type = get_unpadded_type (Etype (gnat_node));
2020 prefix_unused = true;
2021
2022 if (TREE_CODE (gnu_prefix) == COMPONENT_REF)
2023 align = DECL_ALIGN (TREE_OPERAND (gnu_prefix, 1)) / BITS_PER_UNIT;
2024 else
2025 {
2026 Entity_Id gnat_type = Etype (gnat_prefix);
2027 unsigned int double_align;
2028 bool is_capped_double, align_clause;
2029
2030 /* If the default alignment of "double" or larger scalar types is
2031 specifically capped and there is an alignment clause neither
2032 on the type nor on the prefix itself, return the cap. */
2033 if ((double_align = double_float_alignment) > 0)
2034 is_capped_double
2035 = is_double_float_or_array (gnat_type, &align_clause);
2036 else if ((double_align = double_scalar_alignment) > 0)
2037 is_capped_double
2038 = is_double_scalar_or_array (gnat_type, &align_clause);
2039 else
2040 is_capped_double = align_clause = false;
2041
2042 if (is_capped_double
2043 && Nkind (gnat_prefix) == N_Identifier
2044 && Present (Alignment_Clause (Entity (gnat_prefix))))
2045 align_clause = true;
2046
2047 if (is_capped_double && !align_clause)
2048 align = double_align;
2049 else
2050 align = TYPE_ALIGN (gnu_type) / BITS_PER_UNIT;
2051 }
2052
2053 gnu_result = size_int (align);
2054 }
2055 break;
2056
2057 case Attr_First:
2058 case Attr_Last:
2059 case Attr_Range_Length:
2060 prefix_unused = true;
2061
2062 if (INTEGRAL_TYPE_P (gnu_type) || SCALAR_FLOAT_TYPE_P (gnu_type))
2063 {
2064 gnu_result_type = get_unpadded_type (Etype (gnat_node));
2065
2066 if (attribute == Attr_First)
2067 gnu_result = TYPE_MIN_VALUE (gnu_type);
2068 else if (attribute == Attr_Last)
2069 gnu_result = TYPE_MAX_VALUE (gnu_type);
2070 else
2071 gnu_result = get_type_length (gnu_type, gnu_result_type);
2072 break;
2073 }
2074
2075 /* ... fall through ... */
2076
2077 case Attr_Length:
2078 {
2079 int Dimension = (Present (Expressions (gnat_node))
2080 ? UI_To_Int (Intval (First (Expressions (gnat_node))))
2081 : 1), i;
2082 struct parm_attr_d *pa = NULL;
2083 Entity_Id gnat_param = Empty;
2084 bool unconstrained_ptr_deref = false;
2085
2086 gnu_prefix = maybe_padded_object (gnu_prefix);
2087 gnu_prefix = maybe_unconstrained_array (gnu_prefix);
2088
2089 /* We treat unconstrained array In parameters specially. We also note
2090 whether we are dereferencing a pointer to unconstrained array. */
2091 if (!Is_Constrained (Etype (gnat_prefix)))
2092 switch (Nkind (gnat_prefix))
2093 {
2094 case N_Identifier:
2095 /* This is the direct case. */
2096 if (Ekind (Entity (gnat_prefix)) == E_In_Parameter)
2097 gnat_param = Entity (gnat_prefix);
2098 break;
2099
2100 case N_Explicit_Dereference:
2101 /* This is the indirect case. Note that we need to be sure that
2102 the access value cannot be null as we'll hoist the load. */
2103 if (Nkind (Prefix (gnat_prefix)) == N_Identifier
2104 && Ekind (Entity (Prefix (gnat_prefix))) == E_In_Parameter)
2105 {
2106 if (Can_Never_Be_Null (Entity (Prefix (gnat_prefix))))
2107 gnat_param = Entity (Prefix (gnat_prefix));
2108 }
2109 else
2110 unconstrained_ptr_deref = true;
2111 break;
2112
2113 default:
2114 break;
2115 }
2116
2117 /* If the prefix is the view conversion of a constrained array to an
2118 unconstrained form, we retrieve the constrained array because we
2119 might not be able to substitute the PLACEHOLDER_EXPR coming from
2120 the conversion. This can occur with the 'Old attribute applied
2121 to a parameter with an unconstrained type, which gets rewritten
2122 into a constrained local variable very late in the game. */
2123 if (TREE_CODE (gnu_prefix) == VIEW_CONVERT_EXPR
2124 && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (TREE_TYPE (gnu_prefix)))
2125 && !CONTAINS_PLACEHOLDER_P
2126 (TYPE_SIZE (TREE_TYPE (TREE_OPERAND (gnu_prefix, 0)))))
2127 gnu_type = TREE_TYPE (TREE_OPERAND (gnu_prefix, 0));
2128 else
2129 gnu_type = TREE_TYPE (gnu_prefix);
2130
2131 prefix_unused = true;
2132 gnu_result_type = get_unpadded_type (Etype (gnat_node));
2133
2134 if (TYPE_CONVENTION_FORTRAN_P (gnu_type))
2135 {
2136 int ndim;
2137 tree gnu_type_temp;
2138
2139 for (ndim = 1, gnu_type_temp = gnu_type;
2140 TREE_CODE (TREE_TYPE (gnu_type_temp)) == ARRAY_TYPE
2141 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type_temp));
2142 ndim++, gnu_type_temp = TREE_TYPE (gnu_type_temp))
2143 ;
2144
2145 Dimension = ndim + 1 - Dimension;
2146 }
2147
2148 for (i = 1; i < Dimension; i++)
2149 gnu_type = TREE_TYPE (gnu_type);
2150
2151 gcc_assert (TREE_CODE (gnu_type) == ARRAY_TYPE);
2152
2153 /* When not optimizing, look up the slot associated with the parameter
2154 and the dimension in the cache and create a new one on failure.
2155 Don't do this when the actual subtype needs debug info (this happens
2156 with -gnatD): in elaborate_expression_1, we create variables that
2157 hold the bounds, so caching attributes isn't very interesting and
2158 causes dependency issues between these variables and cached
2159 expressions. */
2160 if (!optimize
2161 && Present (gnat_param)
2162 && !(Present (Actual_Subtype (gnat_param))
2163 && Needs_Debug_Info (Actual_Subtype (gnat_param))))
2164 {
2165 FOR_EACH_VEC_SAFE_ELT (f_parm_attr_cache, i, pa)
2166 if (pa->id == gnat_param && pa->dim == Dimension)
2167 break;
2168
2169 if (!pa)
2170 {
2171 pa = ggc_cleared_alloc<parm_attr_d> ();
2172 pa->id = gnat_param;
2173 pa->dim = Dimension;
2174 vec_safe_push (f_parm_attr_cache, pa);
2175 }
2176 }
2177
2178 /* Return the cached expression or build a new one. */
2179 if (attribute == Attr_First)
2180 {
2181 if (pa && pa->first)
2182 {
2183 gnu_result = pa->first;
2184 break;
2185 }
2186
2187 gnu_result
2188 = TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type)));
2189 }
2190
2191 else if (attribute == Attr_Last)
2192 {
2193 if (pa && pa->last)
2194 {
2195 gnu_result = pa->last;
2196 break;
2197 }
2198
2199 gnu_result
2200 = TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type)));
2201 }
2202
2203 else /* attribute == Attr_Range_Length || attribute == Attr_Length */
2204 {
2205 if (pa && pa->length)
2206 {
2207 gnu_result = pa->length;
2208 break;
2209 }
2210
2211 gnu_result
2212 = get_type_length (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type)),
2213 gnu_result_type);
2214 }
2215
2216 /* If this has a PLACEHOLDER_EXPR, qualify it by the object we are
2217 handling. Note that these attributes could not have been used on
2218 an unconstrained array type. */
2219 gnu_result = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_result, gnu_prefix);
2220
2221 /* Cache the expression we have just computed. Since we want to do it
2222 at run time, we force the use of a SAVE_EXPR and let the gimplifier
2223 create the temporary in the outermost binding level. We will make
2224 sure in Subprogram_Body_to_gnu that it is evaluated on all possible
2225 paths by forcing its evaluation on entry of the function. */
2226 if (pa)
2227 {
2228 gnu_result
2229 = build1 (SAVE_EXPR, TREE_TYPE (gnu_result), gnu_result);
2230 switch (attribute)
2231 {
2232 case Attr_First:
2233 pa->first = gnu_result;
2234 break;
2235
2236 case Attr_Last:
2237 pa->last = gnu_result;
2238 break;
2239
2240 case Attr_Length:
2241 case Attr_Range_Length:
2242 pa->length = gnu_result;
2243 break;
2244
2245 default:
2246 gcc_unreachable ();
2247 }
2248 }
2249
2250 /* Otherwise, evaluate it each time it is referenced. */
2251 else
2252 switch (attribute)
2253 {
2254 case Attr_First:
2255 case Attr_Last:
2256 /* If we are dereferencing a pointer to unconstrained array, we
2257 need to capture the value because the pointed-to bounds may
2258 subsequently be released. */
2259 if (unconstrained_ptr_deref)
2260 gnu_result
2261 = build1 (SAVE_EXPR, TREE_TYPE (gnu_result), gnu_result);
2262 break;
2263
2264 case Attr_Length:
2265 case Attr_Range_Length:
2266 /* Set the source location onto the predicate of the condition
2267 but not if the expression is cached to avoid messing up the
2268 debug info. */
2269 if (TREE_CODE (gnu_result) == COND_EXPR
2270 && EXPR_P (TREE_OPERAND (gnu_result, 0)))
2271 set_expr_location_from_node (TREE_OPERAND (gnu_result, 0),
2272 gnat_node);
2273 break;
2274
2275 default:
2276 gcc_unreachable ();
2277 }
2278
2279 break;
2280 }
2281
2282 case Attr_Bit_Position:
2283 case Attr_Position:
2284 case Attr_First_Bit:
2285 case Attr_Last_Bit:
2286 case Attr_Bit:
2287 {
2288 poly_int64 bitsize;
2289 poly_int64 bitpos;
2290 tree gnu_offset;
2291 tree gnu_field_bitpos;
2292 tree gnu_field_offset;
2293 tree gnu_inner;
2294 machine_mode mode;
2295 int unsignedp, reversep, volatilep;
2296
2297 gnu_result_type = get_unpadded_type (Etype (gnat_node));
2298 gnu_prefix = remove_conversions (gnu_prefix, true);
2299 prefix_unused = true;
2300
2301 /* We can have 'Bit on any object, but if it isn't a COMPONENT_REF,
2302 the result is 0. Don't allow 'Bit on a bare component, though. */
2303 if (attribute == Attr_Bit
2304 && TREE_CODE (gnu_prefix) != COMPONENT_REF
2305 && TREE_CODE (gnu_prefix) != FIELD_DECL)
2306 {
2307 gnu_result = integer_zero_node;
2308 break;
2309 }
2310
2311 else
2312 gcc_assert (TREE_CODE (gnu_prefix) == COMPONENT_REF
2313 || (attribute == Attr_Bit_Position
2314 && TREE_CODE (gnu_prefix) == FIELD_DECL));
2315
2316 get_inner_reference (gnu_prefix, &bitsize, &bitpos, &gnu_offset,
2317 &mode, &unsignedp, &reversep, &volatilep);
2318
2319 if (TREE_CODE (gnu_prefix) == COMPONENT_REF)
2320 {
2321 gnu_field_bitpos = bit_position (TREE_OPERAND (gnu_prefix, 1));
2322 gnu_field_offset = byte_position (TREE_OPERAND (gnu_prefix, 1));
2323
2324 for (gnu_inner = TREE_OPERAND (gnu_prefix, 0);
2325 TREE_CODE (gnu_inner) == COMPONENT_REF
2326 && DECL_INTERNAL_P (TREE_OPERAND (gnu_inner, 1));
2327 gnu_inner = TREE_OPERAND (gnu_inner, 0))
2328 {
2329 gnu_field_bitpos
2330 = size_binop (PLUS_EXPR, gnu_field_bitpos,
2331 bit_position (TREE_OPERAND (gnu_inner, 1)));
2332 gnu_field_offset
2333 = size_binop (PLUS_EXPR, gnu_field_offset,
2334 byte_position (TREE_OPERAND (gnu_inner, 1)));
2335 }
2336 }
2337 else if (TREE_CODE (gnu_prefix) == FIELD_DECL)
2338 {
2339 gnu_field_bitpos = bit_position (gnu_prefix);
2340 gnu_field_offset = byte_position (gnu_prefix);
2341 }
2342 else
2343 {
2344 gnu_field_bitpos = bitsize_zero_node;
2345 gnu_field_offset = size_zero_node;
2346 }
2347
2348 switch (attribute)
2349 {
2350 case Attr_Position:
2351 gnu_result = gnu_field_offset;
2352 break;
2353
2354 case Attr_First_Bit:
2355 case Attr_Bit:
2356 gnu_result = size_int (num_trailing_bits (bitpos));
2357 break;
2358
2359 case Attr_Last_Bit:
2360 gnu_result = bitsize_int (num_trailing_bits (bitpos));
2361 gnu_result = size_binop (PLUS_EXPR, gnu_result,
2362 TYPE_SIZE (TREE_TYPE (gnu_prefix)));
2363 /* ??? Avoid a large unsigned result that will overflow when
2364 converted to the signed universal_integer. */
2365 if (integer_zerop (gnu_result))
2366 gnu_result = integer_minus_one_node;
2367 else
2368 gnu_result
2369 = size_binop (MINUS_EXPR, gnu_result, bitsize_one_node);
2370 break;
2371
2372 case Attr_Bit_Position:
2373 gnu_result = gnu_field_bitpos;
2374 break;
2375 }
2376
2377 /* If this has a PLACEHOLDER_EXPR, qualify it by the object we are
2378 handling. */
2379 gnu_result = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_result, gnu_prefix);
2380 break;
2381 }
2382
2383 case Attr_Min:
2384 case Attr_Max:
2385 {
2386 tree gnu_lhs = gnat_to_gnu (First (Expressions (gnat_node)));
2387 tree gnu_rhs = gnat_to_gnu (Next (First (Expressions (gnat_node))));
2388
2389 gnu_result_type = get_unpadded_type (Etype (gnat_node));
2390
2391 /* The result of {MIN,MAX}_EXPR is unspecified if either operand is
2392 a NaN so we implement the semantics of C99 f{min,max} to make it
2393 predictable in this case: if either operand is a NaN, the other
2394 is returned; if both operands are NaN's, a NaN is returned. */
2395 if (SCALAR_FLOAT_TYPE_P (gnu_result_type)
2396 && !Machine_Overflows_On_Target)
2397 {
2398 const bool lhs_side_effects_p = TREE_SIDE_EFFECTS (gnu_lhs);
2399 const bool rhs_side_effects_p = TREE_SIDE_EFFECTS (gnu_rhs);
2400 tree t = builtin_decl_explicit (BUILT_IN_ISNAN);
2401 tree lhs_is_nan, rhs_is_nan;
2402
2403 /* If the operands have side-effects, they need to be evaluated
2404 only once in spite of the multiple references in the result. */
2405 if (lhs_side_effects_p)
2406 gnu_lhs = gnat_protect_expr (gnu_lhs);
2407 if (rhs_side_effects_p)
2408 gnu_rhs = gnat_protect_expr (gnu_rhs);
2409
2410 lhs_is_nan = fold_build2 (NE_EXPR, boolean_type_node,
2411 build_call_expr (t, 1, gnu_lhs),
2412 integer_zero_node);
2413
2414 rhs_is_nan = fold_build2 (NE_EXPR, boolean_type_node,
2415 build_call_expr (t, 1, gnu_rhs),
2416 integer_zero_node);
2417
2418 gnu_result = build_binary_op (attribute == Attr_Min
2419 ? MIN_EXPR : MAX_EXPR,
2420 gnu_result_type, gnu_lhs, gnu_rhs);
2421 gnu_result = fold_build3 (COND_EXPR, gnu_result_type,
2422 rhs_is_nan, gnu_lhs, gnu_result);
2423 gnu_result = fold_build3 (COND_EXPR, gnu_result_type,
2424 lhs_is_nan, gnu_rhs, gnu_result);
2425
2426 /* If the operands have side-effects, they need to be evaluated
2427 before doing the tests above since the place they otherwise
2428 would end up being evaluated at run time could be wrong. */
2429 if (lhs_side_effects_p)
2430 gnu_result
2431 = build2 (COMPOUND_EXPR, gnu_result_type, gnu_lhs, gnu_result);
2432
2433 if (rhs_side_effects_p)
2434 gnu_result
2435 = build2 (COMPOUND_EXPR, gnu_result_type, gnu_rhs, gnu_result);
2436 }
2437 else
2438 gnu_result = build_binary_op (attribute == Attr_Min
2439 ? MIN_EXPR : MAX_EXPR,
2440 gnu_result_type, gnu_lhs, gnu_rhs);
2441 }
2442 break;
2443
2444 case Attr_Passed_By_Reference:
2445 gnu_result = size_int (default_pass_by_ref (gnu_type)
2446 || must_pass_by_ref (gnu_type));
2447 gnu_result_type = get_unpadded_type (Etype (gnat_node));
2448 break;
2449
2450 case Attr_Component_Size:
2451 gnu_prefix = maybe_padded_object (gnu_prefix);
2452 gnu_type = TREE_TYPE (gnu_prefix);
2453
2454 if (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE)
2455 gnu_type = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_type))));
2456
2457 while (TREE_CODE (TREE_TYPE (gnu_type)) == ARRAY_TYPE
2458 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type)))
2459 gnu_type = TREE_TYPE (gnu_type);
2460
2461 gcc_assert (TREE_CODE (gnu_type) == ARRAY_TYPE);
2462
2463 /* Note this size cannot be self-referential. */
2464 gnu_result = TYPE_SIZE (TREE_TYPE (gnu_type));
2465 gnu_result_type = get_unpadded_type (Etype (gnat_node));
2466 prefix_unused = true;
2467 break;
2468
2469 case Attr_Descriptor_Size:
2470 gnu_type = TREE_TYPE (gnu_prefix);
2471 gcc_assert (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE);
2472
2473 /* Return the padded size of the template in the object record type. */
2474 gnu_type = TYPE_OBJECT_RECORD_TYPE (gnu_type);
2475 gnu_result = bit_position (DECL_CHAIN (TYPE_FIELDS (gnu_type)));
2476 gnu_result_type = get_unpadded_type (Etype (gnat_node));
2477 prefix_unused = true;
2478 break;
2479
2480 case Attr_Null_Parameter:
2481 /* This is just a zero cast to the pointer type for our prefix and
2482 dereferenced. */
2483 gnu_result_type = get_unpadded_type (Etype (gnat_node));
2484 gnu_result
2485 = build_unary_op (INDIRECT_REF, NULL_TREE,
2486 convert (build_pointer_type (gnu_result_type),
2487 integer_zero_node));
2488 break;
2489
2490 case Attr_Mechanism_Code:
2491 {
2492 Entity_Id gnat_obj = Entity (gnat_prefix);
2493 int code;
2494
2495 prefix_unused = true;
2496 gnu_result_type = get_unpadded_type (Etype (gnat_node));
2497 if (Present (Expressions (gnat_node)))
2498 {
2499 int i = UI_To_Int (Intval (First (Expressions (gnat_node))));
2500
2501 for (gnat_obj = First_Formal (gnat_obj); i > 1;
2502 i--, gnat_obj = Next_Formal (gnat_obj))
2503 ;
2504 }
2505
2506 code = Mechanism (gnat_obj);
2507 if (code == Default)
2508 code = ((present_gnu_tree (gnat_obj)
2509 && (DECL_BY_REF_P (get_gnu_tree (gnat_obj))
2510 || ((TREE_CODE (get_gnu_tree (gnat_obj))
2511 == PARM_DECL)
2512 && (DECL_BY_COMPONENT_PTR_P
2513 (get_gnu_tree (gnat_obj))))))
2514 ? By_Reference : By_Copy);
2515 gnu_result = convert (gnu_result_type, size_int (- code));
2516 }
2517 break;
2518
2519 case Attr_Model:
2520 /* We treat Model as identical to Machine. This is true for at least
2521 IEEE and some other nice floating-point systems. */
2522
2523 /* ... fall through ... */
2524
2525 case Attr_Machine:
2526 /* The trick is to force the compiler to store the result in memory so
2527 that we do not have extra precision used. But do this only when this
2528 is necessary, i.e. if FP_ARITH_MAY_WIDEN is true and the precision of
2529 the type is lower than that of the longest floating-point type. */
2530 prefix_unused = true;
2531 gnu_expr = gnat_to_gnu (First (Expressions (gnat_node)));
2532 gnu_result_type = get_unpadded_type (Etype (gnat_node));
2533 gnu_result = convert (gnu_result_type, gnu_expr);
2534
2535 if (TREE_CODE (gnu_result) != REAL_CST
2536 && fp_arith_may_widen
2537 && TYPE_PRECISION (gnu_result_type)
2538 < TYPE_PRECISION (longest_float_type_node))
2539 {
2540 tree rec_type = make_node (RECORD_TYPE);
2541 tree field
2542 = create_field_decl (get_identifier ("OBJ"), gnu_result_type,
2543 rec_type, NULL_TREE, NULL_TREE, 0, 0);
2544 tree rec_val, asm_expr;
2545
2546 finish_record_type (rec_type, field, 0, false);
2547
2548 rec_val = build_constructor_single (rec_type, field, gnu_result);
2549 rec_val = build1 (SAVE_EXPR, rec_type, rec_val);
2550
2551 asm_expr
2552 = build5 (ASM_EXPR, void_type_node,
2553 build_string (0, ""),
2554 tree_cons (build_tree_list (NULL_TREE,
2555 build_string (2, "=m")),
2556 rec_val, NULL_TREE),
2557 tree_cons (build_tree_list (NULL_TREE,
2558 build_string (1, "m")),
2559 rec_val, NULL_TREE),
2560 NULL_TREE, NULL_TREE);
2561 ASM_VOLATILE_P (asm_expr) = 1;
2562
2563 gnu_result
2564 = build_compound_expr (gnu_result_type, asm_expr,
2565 build_component_ref (rec_val, field,
2566 false));
2567 }
2568 break;
2569
2570 case Attr_Deref:
2571 prefix_unused = true;
2572 gnu_expr = gnat_to_gnu (First (Expressions (gnat_node)));
2573 gnu_result_type = get_unpadded_type (Etype (gnat_node));
2574 /* This can be a random address so build an alias-all pointer type. */
2575 gnu_expr
2576 = convert (build_pointer_type_for_mode (gnu_result_type, ptr_mode,
2577 true),
2578 gnu_expr);
2579 gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_expr);
2580 break;
2581
2582 default:
2583 /* This abort means that we have an unimplemented attribute. */
2584 gcc_unreachable ();
2585 }
2586
2587 /* If this is an attribute where the prefix was unused, force a use of it if
2588 it has a side-effect. But don't do it if the prefix is just an entity
2589 name. However, if an access check is needed, we must do it. See second
2590 example in AARM 11.6(5.e). */
2591 if (prefix_unused
2592 && TREE_SIDE_EFFECTS (gnu_prefix)
2593 && !Is_Entity_Name (gnat_prefix))
2594 gnu_result
2595 = build_compound_expr (TREE_TYPE (gnu_result), gnu_prefix, gnu_result);
2596
2597 *gnu_result_type_p = gnu_result_type;
2598 return gnu_result;
2599 }
2600
2601 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Case_Statement,
2602 to a GCC tree, which is returned. */
2603
2604 static tree
Case_Statement_to_gnu(Node_Id gnat_node)2605 Case_Statement_to_gnu (Node_Id gnat_node)
2606 {
2607 tree gnu_result, gnu_expr, gnu_type, gnu_label;
2608 Node_Id gnat_when;
2609 location_t end_locus;
2610 bool may_fallthru = false;
2611
2612 gnu_expr = gnat_to_gnu (Expression (gnat_node));
2613 gnu_expr = convert (get_base_type (TREE_TYPE (gnu_expr)), gnu_expr);
2614 gnu_expr = maybe_character_value (gnu_expr);
2615 gnu_type = TREE_TYPE (gnu_expr);
2616
2617 /* We build a SWITCH_EXPR that contains the code with interspersed
2618 CASE_LABEL_EXPRs for each label. */
2619 if (!Sloc_to_locus (End_Location (gnat_node), &end_locus))
2620 end_locus = input_location;
2621 gnu_label = create_artificial_label (end_locus);
2622 start_stmt_group ();
2623
2624 for (gnat_when = First_Non_Pragma (Alternatives (gnat_node));
2625 Present (gnat_when);
2626 gnat_when = Next_Non_Pragma (gnat_when))
2627 {
2628 bool choices_added_p = false;
2629 Node_Id gnat_choice;
2630
2631 /* First compile all the different case choices for the current WHEN
2632 alternative. */
2633 for (gnat_choice = First (Discrete_Choices (gnat_when));
2634 Present (gnat_choice);
2635 gnat_choice = Next (gnat_choice))
2636 {
2637 tree gnu_low = NULL_TREE, gnu_high = NULL_TREE;
2638 tree label = create_artificial_label (input_location);
2639
2640 switch (Nkind (gnat_choice))
2641 {
2642 case N_Range:
2643 gnu_low = gnat_to_gnu (Low_Bound (gnat_choice));
2644 gnu_high = gnat_to_gnu (High_Bound (gnat_choice));
2645 break;
2646
2647 case N_Subtype_Indication:
2648 gnu_low = gnat_to_gnu (Low_Bound (Range_Expression
2649 (Constraint (gnat_choice))));
2650 gnu_high = gnat_to_gnu (High_Bound (Range_Expression
2651 (Constraint (gnat_choice))));
2652 break;
2653
2654 case N_Identifier:
2655 case N_Expanded_Name:
2656 /* This represents either a subtype range or a static value of
2657 some kind; Ekind says which. */
2658 if (Is_Type (Entity (gnat_choice)))
2659 {
2660 tree gnu_type = get_unpadded_type (Entity (gnat_choice));
2661
2662 gnu_low = TYPE_MIN_VALUE (gnu_type);
2663 gnu_high = TYPE_MAX_VALUE (gnu_type);
2664 break;
2665 }
2666
2667 /* ... fall through ... */
2668
2669 case N_Character_Literal:
2670 case N_Integer_Literal:
2671 gnu_low = gnat_to_gnu (gnat_choice);
2672 break;
2673
2674 case N_Others_Choice:
2675 break;
2676
2677 default:
2678 gcc_unreachable ();
2679 }
2680
2681 /* Everything should be folded into constants at this point. */
2682 gcc_assert (!gnu_low || TREE_CODE (gnu_low) == INTEGER_CST);
2683 gcc_assert (!gnu_high || TREE_CODE (gnu_high) == INTEGER_CST);
2684
2685 if (gnu_low && TREE_TYPE (gnu_low) != gnu_type)
2686 gnu_low = convert (gnu_type, gnu_low);
2687 if (gnu_high && TREE_TYPE (gnu_high) != gnu_type)
2688 gnu_high = convert (gnu_type, gnu_high);
2689
2690 add_stmt_with_node (build_case_label (gnu_low, gnu_high, label),
2691 gnat_choice);
2692 choices_added_p = true;
2693 }
2694
2695 /* This construct doesn't define a scope so we shouldn't push a binding
2696 level around the statement list. Except that we have always done so
2697 historically and this makes it possible to reduce stack usage. As a
2698 compromise, we keep doing it for case statements, for which this has
2699 never been problematic, but not for case expressions in Ada 2012. */
2700 if (choices_added_p)
2701 {
2702 const bool is_case_expression
2703 = (Nkind (Parent (gnat_node)) == N_Expression_With_Actions);
2704 tree group
2705 = build_stmt_group (Statements (gnat_when), !is_case_expression);
2706 bool group_may_fallthru = block_may_fallthru (group);
2707 add_stmt (group);
2708 if (group_may_fallthru)
2709 {
2710 tree stmt = build1 (GOTO_EXPR, void_type_node, gnu_label);
2711 SET_EXPR_LOCATION (stmt, end_locus);
2712 add_stmt (stmt);
2713 may_fallthru = true;
2714 }
2715 }
2716 }
2717
2718 /* Now emit a definition of the label the cases branch to, if any. */
2719 if (may_fallthru)
2720 add_stmt (build1 (LABEL_EXPR, void_type_node, gnu_label));
2721 gnu_result = build2 (SWITCH_EXPR, gnu_type, gnu_expr, end_stmt_group ());
2722
2723 return gnu_result;
2724 }
2725
2726 /* Return true if we are in the body of a loop. */
2727
2728 static inline bool
inside_loop_p(void)2729 inside_loop_p (void)
2730 {
2731 return !vec_safe_is_empty (gnu_loop_stack);
2732 }
2733
2734 /* Find out whether EXPR is a simple additive expression based on the iteration
2735 variable of some enclosing loop in the current function. If so, return the
2736 loop and set *DISP to the displacement and *NEG_P to true if this is for a
2737 subtraction; otherwise, return NULL. */
2738
2739 static struct loop_info_d *
find_loop_for(tree expr,tree * disp,bool * neg_p)2740 find_loop_for (tree expr, tree *disp, bool *neg_p)
2741 {
2742 tree var, add, cst;
2743 bool minus_p;
2744 struct loop_info_d *iter = NULL;
2745 unsigned int i;
2746
2747 if (is_simple_additive_expression (expr, &add, &cst, &minus_p))
2748 {
2749 var = add;
2750 if (disp)
2751 *disp = cst;
2752 if (neg_p)
2753 *neg_p = minus_p;
2754 }
2755 else
2756 {
2757 var = expr;
2758 if (disp)
2759 *disp = NULL_TREE;
2760 if (neg_p)
2761 *neg_p = false;
2762 }
2763
2764 var = remove_conversions (var, false);
2765
2766 if (TREE_CODE (var) != VAR_DECL)
2767 return NULL;
2768
2769 gcc_checking_assert (vec_safe_length (gnu_loop_stack) > 0);
2770
2771 FOR_EACH_VEC_ELT_REVERSE (*gnu_loop_stack, i, iter)
2772 if (iter->loop_var == var && iter->fndecl == current_function_decl)
2773 break;
2774
2775 return iter;
2776 }
2777
2778 /* Return the innermost enclosing loop in the current function. */
2779
2780 static struct loop_info_d *
find_loop(void)2781 find_loop (void)
2782 {
2783 struct loop_info_d *iter = NULL;
2784 unsigned int i;
2785
2786 gcc_checking_assert (vec_safe_length (gnu_loop_stack) > 0);
2787
2788 FOR_EACH_VEC_ELT_REVERSE (*gnu_loop_stack, i, iter)
2789 if (iter->fndecl == current_function_decl)
2790 break;
2791
2792 return iter;
2793 }
2794
2795 /* Return true if VAL (of type TYPE) can equal the minimum value if MAX is
2796 false, or the maximum value if MAX is true, of TYPE. */
2797
2798 static bool
can_equal_min_or_max_val_p(tree val,tree type,bool max)2799 can_equal_min_or_max_val_p (tree val, tree type, bool max)
2800 {
2801 tree min_or_max_val = (max ? TYPE_MAX_VALUE (type) : TYPE_MIN_VALUE (type));
2802
2803 if (TREE_CODE (min_or_max_val) != INTEGER_CST)
2804 return true;
2805
2806 if (TREE_CODE (val) == NOP_EXPR)
2807 val = (max
2808 ? TYPE_MAX_VALUE (TREE_TYPE (TREE_OPERAND (val, 0)))
2809 : TYPE_MIN_VALUE (TREE_TYPE (TREE_OPERAND (val, 0))));
2810
2811 if (TREE_CODE (val) != INTEGER_CST)
2812 return true;
2813
2814 if (max)
2815 return tree_int_cst_lt (val, min_or_max_val) == 0;
2816 else
2817 return tree_int_cst_lt (min_or_max_val, val) == 0;
2818 }
2819
2820 /* Return true if VAL (of type TYPE) can equal the minimum value of TYPE.
2821 If REVERSE is true, minimum value is taken as maximum value. */
2822
2823 static inline bool
can_equal_min_val_p(tree val,tree type,bool reverse)2824 can_equal_min_val_p (tree val, tree type, bool reverse)
2825 {
2826 return can_equal_min_or_max_val_p (val, type, reverse);
2827 }
2828
2829 /* Return true if VAL (of type TYPE) can equal the maximum value of TYPE.
2830 If REVERSE is true, maximum value is taken as minimum value. */
2831
2832 static inline bool
can_equal_max_val_p(tree val,tree type,bool reverse)2833 can_equal_max_val_p (tree val, tree type, bool reverse)
2834 {
2835 return can_equal_min_or_max_val_p (val, type, !reverse);
2836 }
2837
2838 /* Replace EXPR1 and EXPR2 by invariant expressions if possible. Return
2839 true if both expressions have been replaced and false otherwise. */
2840
2841 static bool
make_invariant(tree * expr1,tree * expr2)2842 make_invariant (tree *expr1, tree *expr2)
2843 {
2844 tree inv_expr1 = gnat_invariant_expr (*expr1);
2845 tree inv_expr2 = gnat_invariant_expr (*expr2);
2846
2847 if (inv_expr1)
2848 *expr1 = inv_expr1;
2849
2850 if (inv_expr2)
2851 *expr2 = inv_expr2;
2852
2853 return inv_expr1 && inv_expr2;
2854 }
2855
2856 /* Helper function for walk_tree, used by independent_iterations_p below. */
2857
2858 static tree
scan_rhs_r(tree * tp,int * walk_subtrees,void * data)2859 scan_rhs_r (tree *tp, int *walk_subtrees, void *data)
2860 {
2861 bitmap *params = (bitmap *)data;
2862 tree t = *tp;
2863
2864 /* No need to walk into types or decls. */
2865 if (IS_TYPE_OR_DECL_P (t))
2866 *walk_subtrees = 0;
2867
2868 if (TREE_CODE (t) == PARM_DECL && bitmap_bit_p (*params, DECL_UID (t)))
2869 return t;
2870
2871 return NULL_TREE;
2872 }
2873
2874 /* Return true if STMT_LIST generates independent iterations in a loop. */
2875
2876 static bool
independent_iterations_p(tree stmt_list)2877 independent_iterations_p (tree stmt_list)
2878 {
2879 tree_stmt_iterator tsi;
2880 bitmap params = BITMAP_GGC_ALLOC();
2881 auto_vec<tree, 16> rhs;
2882 tree iter;
2883 int i;
2884
2885 if (TREE_CODE (stmt_list) == BIND_EXPR)
2886 stmt_list = BIND_EXPR_BODY (stmt_list);
2887
2888 /* Scan the list and return false on anything that is not either a check
2889 or an assignment to a parameter with restricted aliasing. */
2890 for (tsi = tsi_start (stmt_list); !tsi_end_p (tsi); tsi_next (&tsi))
2891 {
2892 tree stmt = tsi_stmt (tsi);
2893
2894 switch (TREE_CODE (stmt))
2895 {
2896 case COND_EXPR:
2897 {
2898 if (COND_EXPR_ELSE (stmt))
2899 return false;
2900 if (TREE_CODE (COND_EXPR_THEN (stmt)) != CALL_EXPR)
2901 return false;
2902 tree func = get_callee_fndecl (COND_EXPR_THEN (stmt));
2903 if (!(func && TREE_THIS_VOLATILE (func)))
2904 return false;
2905 break;
2906 }
2907
2908 case MODIFY_EXPR:
2909 {
2910 tree lhs = TREE_OPERAND (stmt, 0);
2911 while (handled_component_p (lhs))
2912 lhs = TREE_OPERAND (lhs, 0);
2913 if (TREE_CODE (lhs) != INDIRECT_REF)
2914 return false;
2915 lhs = TREE_OPERAND (lhs, 0);
2916 if (!(TREE_CODE (lhs) == PARM_DECL
2917 && DECL_RESTRICTED_ALIASING_P (lhs)))
2918 return false;
2919 bitmap_set_bit (params, DECL_UID (lhs));
2920 rhs.safe_push (TREE_OPERAND (stmt, 1));
2921 break;
2922 }
2923
2924 default:
2925 return false;
2926 }
2927 }
2928
2929 /* At this point we know that the list contains only statements that will
2930 modify parameters with restricted aliasing. Check that the statements
2931 don't at the time read from these parameters. */
2932 FOR_EACH_VEC_ELT (rhs, i, iter)
2933 if (walk_tree_without_duplicates (&iter, scan_rhs_r, ¶ms))
2934 return false;
2935
2936 return true;
2937 }
2938
2939 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Loop_Statement,
2940 to a GCC tree, which is returned. */
2941
2942 static tree
Loop_Statement_to_gnu(Node_Id gnat_node)2943 Loop_Statement_to_gnu (Node_Id gnat_node)
2944 {
2945 const Node_Id gnat_iter_scheme = Iteration_Scheme (gnat_node);
2946 struct loop_info_d *gnu_loop_info = ggc_cleared_alloc<loop_info_d> ();
2947 tree gnu_loop_stmt = build4 (LOOP_STMT, void_type_node, NULL_TREE,
2948 NULL_TREE, NULL_TREE, NULL_TREE);
2949 tree gnu_loop_label = create_artificial_label (input_location);
2950 tree gnu_cond_expr = NULL_TREE, gnu_low = NULL_TREE, gnu_high = NULL_TREE;
2951 tree gnu_result;
2952
2953 /* Push the loop_info structure associated with the LOOP_STMT. */
2954 gnu_loop_info->fndecl = current_function_decl;
2955 gnu_loop_info->stmt = gnu_loop_stmt;
2956 vec_safe_push (gnu_loop_stack, gnu_loop_info);
2957
2958 /* Set location information for statement and end label. */
2959 set_expr_location_from_node (gnu_loop_stmt, gnat_node);
2960 Sloc_to_locus (Sloc (End_Label (gnat_node)),
2961 &DECL_SOURCE_LOCATION (gnu_loop_label));
2962 LOOP_STMT_LABEL (gnu_loop_stmt) = gnu_loop_label;
2963
2964 /* Set the condition under which the loop must keep going. If we have an
2965 explicit condition, use it to set the location information throughout
2966 the translation of the loop statement to avoid having multiple SLOCs.
2967
2968 For the case "LOOP .... END LOOP;" the condition is always true. */
2969 if (No (gnat_iter_scheme))
2970 ;
2971
2972 /* For the case "WHILE condition LOOP ..... END LOOP;" it's immediate. */
2973 else if (Present (Condition (gnat_iter_scheme)))
2974 {
2975 LOOP_STMT_COND (gnu_loop_stmt)
2976 = gnat_to_gnu (Condition (gnat_iter_scheme));
2977
2978 set_expr_location_from_node (gnu_loop_stmt, gnat_iter_scheme);
2979 }
2980
2981 /* Otherwise we have an iteration scheme and the condition is given by the
2982 bounds of the subtype of the iteration variable. */
2983 else
2984 {
2985 Node_Id gnat_loop_spec = Loop_Parameter_Specification (gnat_iter_scheme);
2986 Entity_Id gnat_loop_var = Defining_Entity (gnat_loop_spec);
2987 Entity_Id gnat_type = Etype (gnat_loop_var);
2988 tree gnu_type = get_unpadded_type (gnat_type);
2989 tree gnu_base_type = maybe_character_type (get_base_type (gnu_type));
2990 tree gnu_one_node = build_int_cst (gnu_base_type, 1);
2991 tree gnu_loop_var, gnu_loop_iv, gnu_first, gnu_last, gnu_stmt;
2992 enum tree_code update_code, test_code, shift_code;
2993 bool reverse = Reverse_Present (gnat_loop_spec), use_iv = false;
2994
2995 gnu_low = convert (gnu_base_type, TYPE_MIN_VALUE (gnu_type));
2996 gnu_high = convert (gnu_base_type, TYPE_MAX_VALUE (gnu_type));
2997
2998 /* We must disable modulo reduction for the iteration variable, if any,
2999 in order for the loop comparison to be effective. */
3000 if (reverse)
3001 {
3002 gnu_first = gnu_high;
3003 gnu_last = gnu_low;
3004 update_code = MINUS_NOMOD_EXPR;
3005 test_code = GE_EXPR;
3006 shift_code = PLUS_NOMOD_EXPR;
3007 }
3008 else
3009 {
3010 gnu_first = gnu_low;
3011 gnu_last = gnu_high;
3012 update_code = PLUS_NOMOD_EXPR;
3013 test_code = LE_EXPR;
3014 shift_code = MINUS_NOMOD_EXPR;
3015 }
3016
3017 /* We use two different strategies to translate the loop, depending on
3018 whether optimization is enabled.
3019
3020 If it is, we generate the canonical loop form expected by the loop
3021 optimizer and the loop vectorizer, which is the do-while form:
3022
3023 ENTRY_COND
3024 loop:
3025 TOP_UPDATE
3026 BODY
3027 BOTTOM_COND
3028 GOTO loop
3029
3030 This avoids an implicit dependency on loop header copying and makes
3031 it possible to turn BOTTOM_COND into an inequality test.
3032
3033 If optimization is disabled, loop header copying doesn't come into
3034 play and we try to generate the loop form with the fewer conditional
3035 branches. First, the default form, which is:
3036
3037 loop:
3038 TOP_COND
3039 BODY
3040 BOTTOM_UPDATE
3041 GOTO loop
3042
3043 It should catch most loops with constant ending point. Then, if we
3044 cannot, we try to generate the shifted form:
3045
3046 loop:
3047 TOP_COND
3048 TOP_UPDATE
3049 BODY
3050 GOTO loop
3051
3052 which should catch loops with constant starting point. Otherwise, if
3053 we cannot, we generate the fallback form:
3054
3055 ENTRY_COND
3056 loop:
3057 BODY
3058 BOTTOM_COND
3059 BOTTOM_UPDATE
3060 GOTO loop
3061
3062 which works in all cases. */
3063
3064 if (optimize && !optimize_debug)
3065 {
3066 /* We can use the do-while form directly if GNU_FIRST-1 doesn't
3067 overflow. */
3068 if (!can_equal_min_val_p (gnu_first, gnu_base_type, reverse))
3069 ;
3070
3071 /* Otherwise, use the do-while form with the help of a special
3072 induction variable in the unsigned version of the base type
3073 or the unsigned version of the size type, whichever is the
3074 largest, in order to have wrap-around arithmetics for it. */
3075 else
3076 {
3077 if (TYPE_PRECISION (gnu_base_type)
3078 > TYPE_PRECISION (size_type_node))
3079 gnu_base_type
3080 = gnat_type_for_size (TYPE_PRECISION (gnu_base_type), 1);
3081 else
3082 gnu_base_type = size_type_node;
3083
3084 gnu_first = convert (gnu_base_type, gnu_first);
3085 gnu_last = convert (gnu_base_type, gnu_last);
3086 gnu_one_node = build_int_cst (gnu_base_type, 1);
3087 use_iv = true;
3088 }
3089
3090 gnu_first
3091 = build_binary_op (shift_code, gnu_base_type, gnu_first,
3092 gnu_one_node);
3093 LOOP_STMT_TOP_UPDATE_P (gnu_loop_stmt) = 1;
3094 LOOP_STMT_BOTTOM_COND_P (gnu_loop_stmt) = 1;
3095 }
3096 else
3097 {
3098 /* We can use the default form if GNU_LAST+1 doesn't overflow. */
3099 if (!can_equal_max_val_p (gnu_last, gnu_base_type, reverse))
3100 ;
3101
3102 /* Otherwise, we can use the shifted form if neither GNU_FIRST-1 nor
3103 GNU_LAST-1 does. */
3104 else if (!can_equal_min_val_p (gnu_first, gnu_base_type, reverse)
3105 && !can_equal_min_val_p (gnu_last, gnu_base_type, reverse))
3106 {
3107 gnu_first
3108 = build_binary_op (shift_code, gnu_base_type, gnu_first,
3109 gnu_one_node);
3110 gnu_last
3111 = build_binary_op (shift_code, gnu_base_type, gnu_last,
3112 gnu_one_node);
3113 LOOP_STMT_TOP_UPDATE_P (gnu_loop_stmt) = 1;
3114 }
3115
3116 /* Otherwise, use the fallback form. */
3117 else
3118 LOOP_STMT_BOTTOM_COND_P (gnu_loop_stmt) = 1;
3119 }
3120
3121 /* If we use the BOTTOM_COND, we can turn the test into an inequality
3122 test but we have to add ENTRY_COND to protect the empty loop. */
3123 if (LOOP_STMT_BOTTOM_COND_P (gnu_loop_stmt))
3124 {
3125 test_code = NE_EXPR;
3126 gnu_cond_expr
3127 = build3 (COND_EXPR, void_type_node,
3128 build_binary_op (LE_EXPR, boolean_type_node,
3129 gnu_low, gnu_high),
3130 NULL_TREE, alloc_stmt_list ());
3131 set_expr_location_from_node (gnu_cond_expr, gnat_iter_scheme);
3132 }
3133
3134 /* Open a new nesting level that will surround the loop to declare the
3135 iteration variable. */
3136 start_stmt_group ();
3137 gnat_pushlevel ();
3138
3139 /* If we use the special induction variable, create it and set it to
3140 its initial value. Morever, the regular iteration variable cannot
3141 itself be initialized, lest the initial value wrapped around. */
3142 if (use_iv)
3143 {
3144 gnu_loop_iv
3145 = create_init_temporary ("I", gnu_first, &gnu_stmt, gnat_loop_var);
3146 add_stmt (gnu_stmt);
3147 gnu_first = NULL_TREE;
3148 }
3149 else
3150 gnu_loop_iv = NULL_TREE;
3151
3152 /* Declare the iteration variable and set it to its initial value. */
3153 gnu_loop_var = gnat_to_gnu_entity (gnat_loop_var, gnu_first, true);
3154 if (DECL_BY_REF_P (gnu_loop_var))
3155 gnu_loop_var = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_loop_var);
3156 else if (use_iv)
3157 {
3158 gcc_assert (DECL_LOOP_PARM_P (gnu_loop_var));
3159 SET_DECL_INDUCTION_VAR (gnu_loop_var, gnu_loop_iv);
3160 }
3161 gnu_loop_info->loop_var = gnu_loop_var;
3162 gnu_loop_info->low_bound = gnu_low;
3163 gnu_loop_info->high_bound = gnu_high;
3164
3165 /* Do all the arithmetics in the base type. */
3166 gnu_loop_var = convert (gnu_base_type, gnu_loop_var);
3167
3168 /* Set either the top or bottom exit condition. */
3169 if (use_iv)
3170 LOOP_STMT_COND (gnu_loop_stmt)
3171 = build_binary_op (test_code, boolean_type_node, gnu_loop_iv,
3172 gnu_last);
3173 else
3174 LOOP_STMT_COND (gnu_loop_stmt)
3175 = build_binary_op (test_code, boolean_type_node, gnu_loop_var,
3176 gnu_last);
3177
3178 /* Set either the top or bottom update statement and give it the source
3179 location of the iteration for better coverage info. */
3180 if (use_iv)
3181 {
3182 gnu_stmt
3183 = build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_loop_iv,
3184 build_binary_op (update_code, gnu_base_type,
3185 gnu_loop_iv, gnu_one_node));
3186 set_expr_location_from_node (gnu_stmt, gnat_iter_scheme);
3187 append_to_statement_list (gnu_stmt,
3188 &LOOP_STMT_UPDATE (gnu_loop_stmt));
3189 gnu_stmt
3190 = build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_loop_var,
3191 gnu_loop_iv);
3192 set_expr_location_from_node (gnu_stmt, gnat_iter_scheme);
3193 append_to_statement_list (gnu_stmt,
3194 &LOOP_STMT_UPDATE (gnu_loop_stmt));
3195 }
3196 else
3197 {
3198 gnu_stmt
3199 = build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_loop_var,
3200 build_binary_op (update_code, gnu_base_type,
3201 gnu_loop_var, gnu_one_node));
3202 set_expr_location_from_node (gnu_stmt, gnat_iter_scheme);
3203 LOOP_STMT_UPDATE (gnu_loop_stmt) = gnu_stmt;
3204 }
3205
3206 set_expr_location_from_node (gnu_loop_stmt, gnat_iter_scheme);
3207 }
3208
3209 /* If the loop was named, have the name point to this loop. In this case,
3210 the association is not a DECL node, but the end label of the loop. */
3211 if (Present (Identifier (gnat_node)))
3212 save_gnu_tree (Entity (Identifier (gnat_node)), gnu_loop_label, true);
3213
3214 /* Make the loop body into its own block, so any allocated storage will be
3215 released every iteration. This is needed for stack allocation. */
3216 LOOP_STMT_BODY (gnu_loop_stmt)
3217 = build_stmt_group (Statements (gnat_node), true);
3218 TREE_SIDE_EFFECTS (gnu_loop_stmt) = 1;
3219
3220 /* If we have an iteration scheme, then we are in a statement group. Add
3221 the LOOP_STMT to it, finish it and make it the "loop". */
3222 if (Present (gnat_iter_scheme) && No (Condition (gnat_iter_scheme)))
3223 {
3224 /* First, if we have computed invariant conditions for range (or index)
3225 checks applied to the iteration variable, find out whether they can
3226 be evaluated to false at compile time; otherwise, if there are not
3227 too many of them, combine them with the original checks. If loop
3228 unswitching is enabled, do not require the loop bounds to be also
3229 invariant, as their evaluation will still be ahead of the loop. */
3230 if (vec_safe_length (gnu_loop_info->checks) > 0
3231 && (make_invariant (&gnu_low, &gnu_high) || optimize >= 3))
3232 {
3233 struct range_check_info_d *rci;
3234 unsigned int i, n_remaining_checks = 0;
3235
3236 FOR_EACH_VEC_ELT (*gnu_loop_info->checks, i, rci)
3237 {
3238 tree low_ok, high_ok;
3239
3240 if (rci->low_bound)
3241 {
3242 tree gnu_adjusted_low = convert (rci->type, gnu_low);
3243 if (rci->disp)
3244 gnu_adjusted_low
3245 = fold_build2 (rci->neg_p ? MINUS_EXPR : PLUS_EXPR,
3246 rci->type, gnu_adjusted_low, rci->disp);
3247 low_ok
3248 = build_binary_op (GE_EXPR, boolean_type_node,
3249 gnu_adjusted_low, rci->low_bound);
3250 }
3251 else
3252 low_ok = boolean_true_node;
3253
3254 if (rci->high_bound)
3255 {
3256 tree gnu_adjusted_high = convert (rci->type, gnu_high);
3257 if (rci->disp)
3258 gnu_adjusted_high
3259 = fold_build2 (rci->neg_p ? MINUS_EXPR : PLUS_EXPR,
3260 rci->type, gnu_adjusted_high, rci->disp);
3261 high_ok
3262 = build_binary_op (LE_EXPR, boolean_type_node,
3263 gnu_adjusted_high, rci->high_bound);
3264 }
3265 else
3266 high_ok = boolean_true_node;
3267
3268 tree range_ok
3269 = build_binary_op (TRUTH_ANDIF_EXPR, boolean_type_node,
3270 low_ok, high_ok);
3271
3272 rci->invariant_cond
3273 = build_unary_op (TRUTH_NOT_EXPR, boolean_type_node, range_ok);
3274
3275 if (rci->invariant_cond == boolean_false_node)
3276 TREE_OPERAND (rci->inserted_cond, 0) = rci->invariant_cond;
3277 else
3278 n_remaining_checks++;
3279 }
3280
3281 /* Note that loop unswitching can only be applied a small number of
3282 times to a given loop (PARAM_MAX_UNSWITCH_LEVEL default to 3). */
3283 if (IN_RANGE (n_remaining_checks, 1, 3)
3284 && optimize >= 2
3285 && !optimize_size)
3286 FOR_EACH_VEC_ELT (*gnu_loop_info->checks, i, rci)
3287 if (rci->invariant_cond != boolean_false_node)
3288 {
3289 TREE_OPERAND (rci->inserted_cond, 0) = rci->invariant_cond;
3290
3291 if (optimize >= 3)
3292 add_stmt_with_node_force (rci->inserted_cond, gnat_node);
3293 }
3294 }
3295
3296 /* Second, if we have recorded invariants to be hoisted, emit them. */
3297 if (vec_safe_length (gnu_loop_info->invariants) > 0)
3298 {
3299 tree *iter;
3300 unsigned int i;
3301 FOR_EACH_VEC_ELT (*gnu_loop_info->invariants, i, iter)
3302 add_stmt_with_node_force (*iter, gnat_node);
3303 }
3304
3305 /* Third, if loop vectorization is enabled and the iterations of the
3306 loop can easily be proved as independent, mark the loop. */
3307 if (optimize >= 3
3308 && independent_iterations_p (LOOP_STMT_BODY (gnu_loop_stmt)))
3309 LOOP_STMT_IVDEP (gnu_loop_stmt) = 1;
3310
3311 add_stmt (gnu_loop_stmt);
3312 gnat_poplevel ();
3313 gnu_loop_stmt = end_stmt_group ();
3314 }
3315
3316 /* If we have an outer COND_EXPR, that's our result and this loop is its
3317 "true" statement. Otherwise, the result is the LOOP_STMT. */
3318 if (gnu_cond_expr)
3319 {
3320 COND_EXPR_THEN (gnu_cond_expr) = gnu_loop_stmt;
3321 TREE_SIDE_EFFECTS (gnu_cond_expr) = 1;
3322 gnu_result = gnu_cond_expr;
3323 }
3324 else
3325 gnu_result = gnu_loop_stmt;
3326
3327 gnu_loop_stack->pop ();
3328
3329 return gnu_result;
3330 }
3331
3332 /* This page implements a form of Named Return Value optimization modeled
3333 on the C++ optimization of the same name. The main difference is that
3334 we disregard any semantical considerations when applying it here, the
3335 counterpart being that we don't try to apply it to semantically loaded
3336 return types, i.e. types with the TYPE_BY_REFERENCE_P flag set.
3337
3338 We consider a function body of the following GENERIC form:
3339
3340 return_type R1;
3341 [...]
3342 RETURN_EXPR [<retval> = ...]
3343 [...]
3344 RETURN_EXPR [<retval> = R1]
3345 [...]
3346 return_type Ri;
3347 [...]
3348 RETURN_EXPR [<retval> = ...]
3349 [...]
3350 RETURN_EXPR [<retval> = Ri]
3351 [...]
3352
3353 where the Ri are not addressable and we try to fulfill a simple criterion
3354 that would make it possible to replace one or several Ri variables by the
3355 single RESULT_DECL of the function.
3356
3357 The first observation is that RETURN_EXPRs that don't directly reference
3358 any of the Ri variables on the RHS of their assignment are transparent wrt
3359 the optimization. This is because the Ri variables aren't addressable so
3360 any transformation applied to them doesn't affect the RHS; moreover, the
3361 assignment writes the full <retval> object so existing values are entirely
3362 discarded.
3363
3364 This property can be extended to some forms of RETURN_EXPRs that reference
3365 the Ri variables, for example CONSTRUCTORs, but isn't true in the general
3366 case, in particular when function calls are involved.
3367
3368 Therefore the algorithm is as follows:
3369
3370 1. Collect the list of candidates for a Named Return Value (Ri variables
3371 on the RHS of assignments of RETURN_EXPRs) as well as the list of the
3372 other expressions on the RHS of such assignments.
3373
3374 2. Prune the members of the first list (candidates) that are referenced
3375 by a member of the second list (expressions).
3376
3377 3. Extract a set of candidates with non-overlapping live ranges from the
3378 first list. These are the Named Return Values.
3379
3380 4. Adjust the relevant RETURN_EXPRs and replace the occurrences of the
3381 Named Return Values in the function with the RESULT_DECL.
3382
3383 If the function returns an unconstrained type, things are a bit different
3384 because the anonymous return object is allocated on the secondary stack
3385 and RESULT_DECL is only a pointer to it. Each return object can be of a
3386 different size and is allocated separately so we need not care about the
3387 addressability and the aforementioned overlapping issues. Therefore, we
3388 don't collect the other expressions and skip step #2 in the algorithm. */
3389
3390 struct nrv_data
3391 {
3392 bitmap nrv;
3393 tree result;
3394 Node_Id gnat_ret;
3395 hash_set<tree> *visited;
3396 };
3397
3398 /* Return true if T is a Named Return Value. */
3399
3400 static inline bool
is_nrv_p(bitmap nrv,tree t)3401 is_nrv_p (bitmap nrv, tree t)
3402 {
3403 return TREE_CODE (t) == VAR_DECL && bitmap_bit_p (nrv, DECL_UID (t));
3404 }
3405
3406 /* Helper function for walk_tree, used by finalize_nrv below. */
3407
3408 static tree
prune_nrv_r(tree * tp,int * walk_subtrees,void * data)3409 prune_nrv_r (tree *tp, int *walk_subtrees, void *data)
3410 {
3411 struct nrv_data *dp = (struct nrv_data *)data;
3412 tree t = *tp;
3413
3414 /* No need to walk into types or decls. */
3415 if (IS_TYPE_OR_DECL_P (t))
3416 *walk_subtrees = 0;
3417
3418 if (is_nrv_p (dp->nrv, t))
3419 bitmap_clear_bit (dp->nrv, DECL_UID (t));
3420
3421 return NULL_TREE;
3422 }
3423
3424 /* Prune Named Return Values in BLOCK and return true if there is still a
3425 Named Return Value in BLOCK or one of its sub-blocks. */
3426
3427 static bool
prune_nrv_in_block(bitmap nrv,tree block)3428 prune_nrv_in_block (bitmap nrv, tree block)
3429 {
3430 bool has_nrv = false;
3431 tree t;
3432
3433 /* First recurse on the sub-blocks. */
3434 for (t = BLOCK_SUBBLOCKS (block); t; t = BLOCK_CHAIN (t))
3435 has_nrv |= prune_nrv_in_block (nrv, t);
3436
3437 /* Then make sure to keep at most one NRV per block. */
3438 for (t = BLOCK_VARS (block); t; t = DECL_CHAIN (t))
3439 if (is_nrv_p (nrv, t))
3440 {
3441 if (has_nrv)
3442 bitmap_clear_bit (nrv, DECL_UID (t));
3443 else
3444 has_nrv = true;
3445 }
3446
3447 return has_nrv;
3448 }
3449
3450 /* Helper function for walk_tree, used by finalize_nrv below. */
3451
3452 static tree
finalize_nrv_r(tree * tp,int * walk_subtrees,void * data)3453 finalize_nrv_r (tree *tp, int *walk_subtrees, void *data)
3454 {
3455 struct nrv_data *dp = (struct nrv_data *)data;
3456 tree t = *tp;
3457
3458 /* No need to walk into types. */
3459 if (TYPE_P (t))
3460 *walk_subtrees = 0;
3461
3462 /* Change RETURN_EXPRs of NRVs to just refer to the RESULT_DECL; this is a
3463 nop, but differs from using NULL_TREE in that it indicates that we care
3464 about the value of the RESULT_DECL. */
3465 else if (TREE_CODE (t) == RETURN_EXPR
3466 && TREE_CODE (TREE_OPERAND (t, 0)) == INIT_EXPR)
3467 {
3468 tree ret_val = TREE_OPERAND (TREE_OPERAND (t, 0), 1);
3469
3470 /* Strip useless conversions around the return value. */
3471 if (gnat_useless_type_conversion (ret_val))
3472 ret_val = TREE_OPERAND (ret_val, 0);
3473
3474 if (is_nrv_p (dp->nrv, ret_val))
3475 TREE_OPERAND (t, 0) = dp->result;
3476 }
3477
3478 /* Replace the DECL_EXPR of NRVs with an initialization of the RESULT_DECL,
3479 if needed. */
3480 else if (TREE_CODE (t) == DECL_EXPR
3481 && is_nrv_p (dp->nrv, DECL_EXPR_DECL (t)))
3482 {
3483 tree var = DECL_EXPR_DECL (t), init;
3484
3485 if (DECL_INITIAL (var))
3486 {
3487 init = build_binary_op (INIT_EXPR, NULL_TREE, dp->result,
3488 DECL_INITIAL (var));
3489 SET_EXPR_LOCATION (init, EXPR_LOCATION (t));
3490 DECL_INITIAL (var) = NULL_TREE;
3491 }
3492 else
3493 init = build_empty_stmt (EXPR_LOCATION (t));
3494 *tp = init;
3495
3496 /* Identify the NRV to the RESULT_DECL for debugging purposes. */
3497 SET_DECL_VALUE_EXPR (var, dp->result);
3498 DECL_HAS_VALUE_EXPR_P (var) = 1;
3499 /* ??? Kludge to avoid an assertion failure during inlining. */
3500 DECL_SIZE (var) = bitsize_unit_node;
3501 DECL_SIZE_UNIT (var) = size_one_node;
3502 }
3503
3504 /* And replace all uses of NRVs with the RESULT_DECL. */
3505 else if (is_nrv_p (dp->nrv, t))
3506 *tp = convert (TREE_TYPE (t), dp->result);
3507
3508 /* Avoid walking into the same tree more than once. Unfortunately, we
3509 can't just use walk_tree_without_duplicates because it would only
3510 call us for the first occurrence of NRVs in the function body. */
3511 if (dp->visited->add (*tp))
3512 *walk_subtrees = 0;
3513
3514 return NULL_TREE;
3515 }
3516
3517 /* Likewise, but used when the function returns an unconstrained type. */
3518
3519 static tree
finalize_nrv_unc_r(tree * tp,int * walk_subtrees,void * data)3520 finalize_nrv_unc_r (tree *tp, int *walk_subtrees, void *data)
3521 {
3522 struct nrv_data *dp = (struct nrv_data *)data;
3523 tree t = *tp;
3524
3525 /* No need to walk into types. */
3526 if (TYPE_P (t))
3527 *walk_subtrees = 0;
3528
3529 /* We need to see the DECL_EXPR of NRVs before any other references so we
3530 walk the body of BIND_EXPR before walking its variables. */
3531 else if (TREE_CODE (t) == BIND_EXPR)
3532 walk_tree (&BIND_EXPR_BODY (t), finalize_nrv_unc_r, data, NULL);
3533
3534 /* Change RETURN_EXPRs of NRVs to assign to the RESULT_DECL only the final
3535 return value built by the allocator instead of the whole construct. */
3536 else if (TREE_CODE (t) == RETURN_EXPR
3537 && TREE_CODE (TREE_OPERAND (t, 0)) == INIT_EXPR)
3538 {
3539 tree ret_val = TREE_OPERAND (TREE_OPERAND (t, 0), 1);
3540
3541 /* This is the construct returned by the allocator. */
3542 if (TREE_CODE (ret_val) == COMPOUND_EXPR
3543 && TREE_CODE (TREE_OPERAND (ret_val, 0)) == INIT_EXPR)
3544 {
3545 tree rhs = TREE_OPERAND (TREE_OPERAND (ret_val, 0), 1);
3546
3547 if (TYPE_IS_FAT_POINTER_P (TREE_TYPE (ret_val)))
3548 ret_val = CONSTRUCTOR_ELT (rhs, 1)->value;
3549 else
3550 ret_val = rhs;
3551 }
3552
3553 /* Strip useless conversions around the return value. */
3554 if (gnat_useless_type_conversion (ret_val)
3555 || TREE_CODE (ret_val) == VIEW_CONVERT_EXPR)
3556 ret_val = TREE_OPERAND (ret_val, 0);
3557
3558 /* Strip unpadding around the return value. */
3559 if (TREE_CODE (ret_val) == COMPONENT_REF
3560 && TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (ret_val, 0))))
3561 ret_val = TREE_OPERAND (ret_val, 0);
3562
3563 /* Assign the new return value to the RESULT_DECL. */
3564 if (is_nrv_p (dp->nrv, ret_val))
3565 TREE_OPERAND (TREE_OPERAND (t, 0), 1)
3566 = TREE_OPERAND (DECL_INITIAL (ret_val), 0);
3567 }
3568
3569 /* Adjust the DECL_EXPR of NRVs to call the allocator and save the result
3570 into a new variable. */
3571 else if (TREE_CODE (t) == DECL_EXPR
3572 && is_nrv_p (dp->nrv, DECL_EXPR_DECL (t)))
3573 {
3574 tree saved_current_function_decl = current_function_decl;
3575 tree var = DECL_EXPR_DECL (t);
3576 tree alloc, p_array, new_var, new_ret;
3577 vec<constructor_elt, va_gc> *v;
3578 vec_alloc (v, 2);
3579
3580 /* Create an artificial context to build the allocation. */
3581 current_function_decl = decl_function_context (var);
3582 start_stmt_group ();
3583 gnat_pushlevel ();
3584
3585 /* This will return a COMPOUND_EXPR with the allocation in the first
3586 arm and the final return value in the second arm. */
3587 alloc = build_allocator (TREE_TYPE (var), DECL_INITIAL (var),
3588 TREE_TYPE (dp->result),
3589 Procedure_To_Call (dp->gnat_ret),
3590 Storage_Pool (dp->gnat_ret),
3591 Empty, false);
3592
3593 /* The new variable is built as a reference to the allocated space. */
3594 new_var
3595 = build_decl (DECL_SOURCE_LOCATION (var), VAR_DECL, DECL_NAME (var),
3596 build_reference_type (TREE_TYPE (var)));
3597 DECL_BY_REFERENCE (new_var) = 1;
3598
3599 if (TYPE_IS_FAT_POINTER_P (TREE_TYPE (alloc)))
3600 {
3601 tree cst = TREE_OPERAND (alloc, 1);
3602
3603 /* The new initial value is a COMPOUND_EXPR with the allocation in
3604 the first arm and the value of P_ARRAY in the second arm. */
3605 DECL_INITIAL (new_var)
3606 = build2 (COMPOUND_EXPR, TREE_TYPE (new_var),
3607 TREE_OPERAND (alloc, 0),
3608 CONSTRUCTOR_ELT (cst, 0)->value);
3609
3610 /* Build a modified CONSTRUCTOR that references NEW_VAR. */
3611 p_array = TYPE_FIELDS (TREE_TYPE (alloc));
3612 CONSTRUCTOR_APPEND_ELT (v, p_array,
3613 fold_convert (TREE_TYPE (p_array), new_var));
3614 CONSTRUCTOR_APPEND_ELT (v, DECL_CHAIN (p_array),
3615 CONSTRUCTOR_ELT (cst, 1)->value);
3616 new_ret = build_constructor (TREE_TYPE (alloc), v);
3617 }
3618 else
3619 {
3620 /* The new initial value is just the allocation. */
3621 DECL_INITIAL (new_var) = alloc;
3622 new_ret = fold_convert (TREE_TYPE (alloc), new_var);
3623 }
3624
3625 gnat_pushdecl (new_var, Empty);
3626
3627 /* Destroy the artificial context and insert the new statements. */
3628 gnat_zaplevel ();
3629 *tp = end_stmt_group ();
3630 current_function_decl = saved_current_function_decl;
3631
3632 /* Chain NEW_VAR immediately after VAR and ignore the latter. */
3633 DECL_CHAIN (new_var) = DECL_CHAIN (var);
3634 DECL_CHAIN (var) = new_var;
3635 DECL_IGNORED_P (var) = 1;
3636
3637 /* Save the new return value and the dereference of NEW_VAR. */
3638 DECL_INITIAL (var)
3639 = build2 (COMPOUND_EXPR, TREE_TYPE (var), new_ret,
3640 build1 (INDIRECT_REF, TREE_TYPE (var), new_var));
3641 /* ??? Kludge to avoid messing up during inlining. */
3642 DECL_CONTEXT (var) = NULL_TREE;
3643 }
3644
3645 /* And replace all uses of NRVs with the dereference of NEW_VAR. */
3646 else if (is_nrv_p (dp->nrv, t))
3647 *tp = TREE_OPERAND (DECL_INITIAL (t), 1);
3648
3649 /* Avoid walking into the same tree more than once. Unfortunately, we
3650 can't just use walk_tree_without_duplicates because it would only
3651 call us for the first occurrence of NRVs in the function body. */
3652 if (dp->visited->add (*tp))
3653 *walk_subtrees = 0;
3654
3655 return NULL_TREE;
3656 }
3657
3658 /* Apply FUNC to all the sub-trees of nested functions in NODE. FUNC is called
3659 with the DATA and the address of each sub-tree. If FUNC returns a non-NULL
3660 value, the traversal is stopped. */
3661
3662 static void
walk_nesting_tree(struct cgraph_node * node,walk_tree_fn func,void * data)3663 walk_nesting_tree (struct cgraph_node *node, walk_tree_fn func, void *data)
3664 {
3665 for (node = first_nested_function (node);
3666 node; node = next_nested_function (node))
3667 {
3668 walk_tree_without_duplicates (&DECL_SAVED_TREE (node->decl), func, data);
3669 walk_nesting_tree (node, func, data);
3670 }
3671 }
3672
3673 /* Finalize the Named Return Value optimization for FNDECL. The NRV bitmap
3674 contains the candidates for Named Return Value and OTHER is a list of
3675 the other return values. GNAT_RET is a representative return node. */
3676
3677 static void
finalize_nrv(tree fndecl,bitmap nrv,vec<tree,va_gc> * other,Node_Id gnat_ret)3678 finalize_nrv (tree fndecl, bitmap nrv, vec<tree, va_gc> *other, Node_Id gnat_ret)
3679 {
3680 struct nrv_data data;
3681 walk_tree_fn func;
3682 unsigned int i;
3683 tree iter;
3684
3685 /* We shouldn't be applying the optimization to return types that we aren't
3686 allowed to manipulate freely. */
3687 gcc_assert (!TYPE_IS_BY_REFERENCE_P (TREE_TYPE (TREE_TYPE (fndecl))));
3688
3689 /* Prune the candidates that are referenced by other return values. */
3690 data.nrv = nrv;
3691 data.result = NULL_TREE;
3692 data.gnat_ret = Empty;
3693 data.visited = NULL;
3694 FOR_EACH_VEC_SAFE_ELT (other, i, iter)
3695 walk_tree_without_duplicates (&iter, prune_nrv_r, &data);
3696 if (bitmap_empty_p (nrv))
3697 return;
3698
3699 /* Prune also the candidates that are referenced by nested functions. */
3700 walk_nesting_tree (cgraph_node::get_create (fndecl), prune_nrv_r, &data);
3701 if (bitmap_empty_p (nrv))
3702 return;
3703
3704 /* Extract a set of NRVs with non-overlapping live ranges. */
3705 if (!prune_nrv_in_block (nrv, DECL_INITIAL (fndecl)))
3706 return;
3707
3708 /* Adjust the relevant RETURN_EXPRs and replace the occurrences of NRVs. */
3709 data.nrv = nrv;
3710 data.result = DECL_RESULT (fndecl);
3711 data.gnat_ret = gnat_ret;
3712 data.visited = new hash_set<tree>;
3713 if (TYPE_RETURN_UNCONSTRAINED_P (TREE_TYPE (fndecl)))
3714 func = finalize_nrv_unc_r;
3715 else
3716 func = finalize_nrv_r;
3717 walk_tree (&DECL_SAVED_TREE (fndecl), func, &data, NULL);
3718 delete data.visited;
3719 }
3720
3721 /* Return true if RET_VAL can be used as a Named Return Value for the
3722 anonymous return object RET_OBJ. */
3723
3724 static bool
return_value_ok_for_nrv_p(tree ret_obj,tree ret_val)3725 return_value_ok_for_nrv_p (tree ret_obj, tree ret_val)
3726 {
3727 if (TREE_CODE (ret_val) != VAR_DECL)
3728 return false;
3729
3730 if (TREE_THIS_VOLATILE (ret_val))
3731 return false;
3732
3733 if (DECL_CONTEXT (ret_val) != current_function_decl)
3734 return false;
3735
3736 if (TREE_STATIC (ret_val))
3737 return false;
3738
3739 /* For the constrained case, test for addressability. */
3740 if (ret_obj && TREE_ADDRESSABLE (ret_val))
3741 return false;
3742
3743 /* For the constrained case, test for overalignment. */
3744 if (ret_obj && DECL_ALIGN (ret_val) > DECL_ALIGN (ret_obj))
3745 return false;
3746
3747 /* For the unconstrained case, test for bogus initialization. */
3748 if (!ret_obj
3749 && DECL_INITIAL (ret_val)
3750 && TREE_CODE (DECL_INITIAL (ret_val)) == NULL_EXPR)
3751 return false;
3752
3753 return true;
3754 }
3755
3756 /* Build a RETURN_EXPR. If RET_VAL is non-null, build a RETURN_EXPR around
3757 the assignment of RET_VAL to RET_OBJ. Otherwise build a bare RETURN_EXPR
3758 around RESULT_OBJ, which may be null in this case. */
3759
3760 static tree
build_return_expr(tree ret_obj,tree ret_val)3761 build_return_expr (tree ret_obj, tree ret_val)
3762 {
3763 tree result_expr;
3764
3765 if (ret_val)
3766 {
3767 /* The gimplifier explicitly enforces the following invariant:
3768
3769 RETURN_EXPR
3770 |
3771 INIT_EXPR
3772 / \
3773 / \
3774 RET_OBJ ...
3775
3776 As a consequence, type consistency dictates that we use the type
3777 of the RET_OBJ as the operation type. */
3778 tree operation_type = TREE_TYPE (ret_obj);
3779
3780 /* Convert the right operand to the operation type. Note that this is
3781 the transformation applied in the INIT_EXPR case of build_binary_op,
3782 with the assumption that the type cannot involve a placeholder. */
3783 if (operation_type != TREE_TYPE (ret_val))
3784 ret_val = convert (operation_type, ret_val);
3785
3786 /* We always can use an INIT_EXPR for the return object. */
3787 result_expr = build2 (INIT_EXPR, void_type_node, ret_obj, ret_val);
3788
3789 /* If the function returns an aggregate type, find out whether this is
3790 a candidate for Named Return Value. If so, record it. Otherwise,
3791 if this is an expression of some kind, record it elsewhere. */
3792 if (optimize
3793 && !optimize_debug
3794 && AGGREGATE_TYPE_P (operation_type)
3795 && !TYPE_IS_FAT_POINTER_P (operation_type)
3796 && TYPE_MODE (operation_type) == BLKmode
3797 && aggregate_value_p (operation_type, current_function_decl))
3798 {
3799 /* Strip useless conversions around the return value. */
3800 if (gnat_useless_type_conversion (ret_val))
3801 ret_val = TREE_OPERAND (ret_val, 0);
3802
3803 /* Now apply the test to the return value. */
3804 if (return_value_ok_for_nrv_p (ret_obj, ret_val))
3805 {
3806 if (!f_named_ret_val)
3807 f_named_ret_val = BITMAP_GGC_ALLOC ();
3808 bitmap_set_bit (f_named_ret_val, DECL_UID (ret_val));
3809 }
3810
3811 /* Note that we need not care about CONSTRUCTORs here, as they are
3812 totally transparent given the read-compose-write semantics of
3813 assignments from CONSTRUCTORs. */
3814 else if (EXPR_P (ret_val))
3815 vec_safe_push (f_other_ret_val, ret_val);
3816 }
3817 }
3818 else
3819 result_expr = ret_obj;
3820
3821 return build1 (RETURN_EXPR, void_type_node, result_expr);
3822 }
3823
3824 /* Subroutine of gnat_to_gnu to process gnat_node, an N_Subprogram_Body. We
3825 don't return anything. */
3826
3827 static void
Subprogram_Body_to_gnu(Node_Id gnat_node)3828 Subprogram_Body_to_gnu (Node_Id gnat_node)
3829 {
3830 /* Defining identifier of a parameter to the subprogram. */
3831 Entity_Id gnat_param;
3832 /* The defining identifier for the subprogram body. Note that if a
3833 specification has appeared before for this body, then the identifier
3834 occurring in that specification will also be a defining identifier and all
3835 the calls to this subprogram will point to that specification. */
3836 Entity_Id gnat_subprog_id
3837 = (Present (Corresponding_Spec (gnat_node))
3838 ? Corresponding_Spec (gnat_node) : Defining_Entity (gnat_node));
3839 /* The FUNCTION_DECL node corresponding to the subprogram spec. */
3840 tree gnu_subprog_decl;
3841 /* Its RESULT_DECL node. */
3842 tree gnu_result_decl;
3843 /* Its FUNCTION_TYPE node. */
3844 tree gnu_subprog_type;
3845 /* The TYPE_CI_CO_LIST of its FUNCTION_TYPE node, if any. */
3846 tree gnu_cico_list;
3847 /* The entry in the CI_CO_LIST that represents a function return, if any. */
3848 tree gnu_return_var_elmt = NULL_TREE;
3849 tree gnu_result;
3850 location_t locus;
3851 struct language_function *gnu_subprog_language;
3852 vec<parm_attr, va_gc> *cache;
3853
3854 /* If this is a generic object or if it has been eliminated,
3855 ignore it. */
3856 if (Ekind (gnat_subprog_id) == E_Generic_Procedure
3857 || Ekind (gnat_subprog_id) == E_Generic_Function
3858 || Is_Eliminated (gnat_subprog_id))
3859 return;
3860
3861 /* If this subprogram acts as its own spec, define it. Otherwise, just get
3862 the already-elaborated tree node. However, if this subprogram had its
3863 elaboration deferred, we will already have made a tree node for it. So
3864 treat it as not being defined in that case. Such a subprogram cannot
3865 have an address clause or a freeze node, so this test is safe, though it
3866 does disable some otherwise-useful error checking. */
3867 gnu_subprog_decl
3868 = gnat_to_gnu_entity (gnat_subprog_id, NULL_TREE,
3869 Acts_As_Spec (gnat_node)
3870 && !present_gnu_tree (gnat_subprog_id));
3871 DECL_FUNCTION_IS_DEF (gnu_subprog_decl) = true;
3872 gnu_result_decl = DECL_RESULT (gnu_subprog_decl);
3873 gnu_subprog_type = TREE_TYPE (gnu_subprog_decl);
3874 gnu_cico_list = TYPE_CI_CO_LIST (gnu_subprog_type);
3875 if (gnu_cico_list && TREE_VALUE (gnu_cico_list) == void_type_node)
3876 gnu_return_var_elmt = gnu_cico_list;
3877
3878 /* If the function returns by invisible reference, make it explicit in the
3879 function body. See gnat_to_gnu_entity, E_Subprogram_Type case. */
3880 if (TREE_ADDRESSABLE (gnu_subprog_type))
3881 {
3882 TREE_TYPE (gnu_result_decl)
3883 = build_reference_type (TREE_TYPE (gnu_result_decl));
3884 relayout_decl (gnu_result_decl);
3885 }
3886
3887 /* Set the line number in the decl to correspond to that of the body. */
3888 if (DECL_IGNORED_P (gnu_subprog_decl))
3889 locus = UNKNOWN_LOCATION;
3890 else if (!Sloc_to_locus (Sloc (gnat_node), &locus, false, gnu_subprog_decl))
3891 locus = input_location;
3892 DECL_SOURCE_LOCATION (gnu_subprog_decl) = locus;
3893
3894 /* If the body comes from an expression function, arrange it to be inlined
3895 in almost all cases. */
3896 if (Was_Expression_Function (gnat_node) && !Debug_Flag_Dot_8)
3897 DECL_DISREGARD_INLINE_LIMITS (gnu_subprog_decl) = 1;
3898
3899 /* Try to create a bona-fide thunk and hand it over to the middle-end. */
3900 if (Is_Thunk (gnat_subprog_id)
3901 && maybe_make_gnu_thunk (gnat_subprog_id, gnu_subprog_decl))
3902 return;
3903
3904 /* Initialize the information structure for the function. */
3905 allocate_struct_function (gnu_subprog_decl, false);
3906 gnu_subprog_language = ggc_cleared_alloc<language_function> ();
3907 DECL_STRUCT_FUNCTION (gnu_subprog_decl)->language = gnu_subprog_language;
3908 DECL_STRUCT_FUNCTION (gnu_subprog_decl)->function_start_locus = locus;
3909 set_cfun (NULL);
3910
3911 begin_subprog_body (gnu_subprog_decl);
3912
3913 /* If there are copy-in/copy-out parameters, we need to ensure that they are
3914 properly copied out by the return statement. We do this by making a new
3915 block and converting any return into a goto to a label at the end of the
3916 block. */
3917 if (gnu_cico_list)
3918 {
3919 tree gnu_return_var = NULL_TREE;
3920
3921 vec_safe_push (gnu_return_label_stack,
3922 create_artificial_label (input_location));
3923
3924 start_stmt_group ();
3925 gnat_pushlevel ();
3926
3927 /* If this is a function with copy-in/copy-out parameters and which does
3928 not return by invisible reference, we also need a variable for the
3929 return value to be placed. */
3930 if (gnu_return_var_elmt && !TREE_ADDRESSABLE (gnu_subprog_type))
3931 {
3932 tree gnu_return_type
3933 = TREE_TYPE (TREE_PURPOSE (gnu_return_var_elmt));
3934
3935 gnu_return_var
3936 = create_var_decl (get_identifier ("RETVAL"), NULL_TREE,
3937 gnu_return_type, NULL_TREE,
3938 false, false, false, false, false,
3939 true, false, NULL, gnat_subprog_id);
3940 TREE_VALUE (gnu_return_var_elmt) = gnu_return_var;
3941 }
3942
3943 vec_safe_push (gnu_return_var_stack, gnu_return_var);
3944
3945 /* See whether there are parameters for which we don't have a GCC tree
3946 yet. These must be Out parameters. Make a VAR_DECL for them and
3947 put it into TYPE_CI_CO_LIST, which must contain an empty entry too.
3948 We can match up the entries because TYPE_CI_CO_LIST is in the order
3949 of the parameters. */
3950 for (gnat_param = First_Formal_With_Extras (gnat_subprog_id);
3951 Present (gnat_param);
3952 gnat_param = Next_Formal_With_Extras (gnat_param))
3953 if (!present_gnu_tree (gnat_param))
3954 {
3955 tree gnu_cico_entry = gnu_cico_list;
3956 tree gnu_decl;
3957
3958 /* Skip any entries that have been already filled in; they must
3959 correspond to In Out parameters. */
3960 while (gnu_cico_entry && TREE_VALUE (gnu_cico_entry))
3961 gnu_cico_entry = TREE_CHAIN (gnu_cico_entry);
3962
3963 /* Do any needed dereferences for by-ref objects. */
3964 gnu_decl = gnat_to_gnu_entity (gnat_param, NULL_TREE, true);
3965 gcc_assert (DECL_P (gnu_decl));
3966 if (DECL_BY_REF_P (gnu_decl))
3967 gnu_decl = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_decl);
3968
3969 /* Do any needed references for padded types. */
3970 TREE_VALUE (gnu_cico_entry)
3971 = convert (TREE_TYPE (TREE_PURPOSE (gnu_cico_entry)), gnu_decl);
3972 }
3973 }
3974 else
3975 vec_safe_push (gnu_return_label_stack, NULL_TREE);
3976
3977 /* Get a tree corresponding to the code for the subprogram. */
3978 start_stmt_group ();
3979 gnat_pushlevel ();
3980
3981 process_decls (Declarations (gnat_node), Empty, Empty, true, true);
3982
3983 /* Generate the code of the subprogram itself. A return statement will be
3984 present and any Out parameters will be handled there. */
3985 add_stmt (gnat_to_gnu (Handled_Statement_Sequence (gnat_node)));
3986 gnat_poplevel ();
3987 gnu_result = end_stmt_group ();
3988
3989 /* Attempt setting the end_locus of our GCC body tree, typically a BIND_EXPR,
3990 then the end_locus of our GCC subprogram declaration tree. */
3991 set_end_locus_from_node (gnu_result, gnat_node);
3992 set_end_locus_from_node (gnu_subprog_decl, gnat_node);
3993
3994 /* If we populated the parameter attributes cache, we need to make sure that
3995 the cached expressions are evaluated on all the possible paths leading to
3996 their uses. So we force their evaluation on entry of the function. */
3997 cache = gnu_subprog_language->parm_attr_cache;
3998 if (cache)
3999 {
4000 struct parm_attr_d *pa;
4001 int i;
4002
4003 start_stmt_group ();
4004
4005 FOR_EACH_VEC_ELT (*cache, i, pa)
4006 {
4007 if (pa->first)
4008 add_stmt_with_node_force (pa->first, gnat_node);
4009 if (pa->last)
4010 add_stmt_with_node_force (pa->last, gnat_node);
4011 if (pa->length)
4012 add_stmt_with_node_force (pa->length, gnat_node);
4013 }
4014
4015 add_stmt (gnu_result);
4016 gnu_result = end_stmt_group ();
4017
4018 gnu_subprog_language->parm_attr_cache = NULL;
4019 }
4020
4021 /* If we are dealing with a return from an Ada procedure with parameters
4022 passed by copy-in/copy-out, we need to return a record containing the
4023 final values of these parameters. If the list contains only one entry,
4024 return just that entry though.
4025
4026 For a full description of the copy-in/copy-out parameter mechanism, see
4027 the part of the gnat_to_gnu_entity routine dealing with the translation
4028 of subprograms.
4029
4030 We need to make a block that contains the definition of that label and
4031 the copying of the return value. It first contains the function, then
4032 the label and copy statement. */
4033 if (gnu_cico_list)
4034 {
4035 const Node_Id gnat_end_label
4036 = End_Label (Handled_Statement_Sequence (gnat_node));
4037
4038 gnu_return_var_stack->pop ();
4039
4040 add_stmt (gnu_result);
4041 add_stmt (build1 (LABEL_EXPR, void_type_node,
4042 gnu_return_label_stack->last ()));
4043
4044 /* If this is a function which returns by invisible reference, the
4045 return value has already been dealt with at the return statements,
4046 so we only need to indirectly copy out the parameters. */
4047 if (TREE_ADDRESSABLE (gnu_subprog_type))
4048 {
4049 tree gnu_ret_deref
4050 = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_result_decl);
4051 tree t;
4052
4053 gcc_assert (TREE_VALUE (gnu_cico_list) == void_type_node);
4054
4055 for (t = TREE_CHAIN (gnu_cico_list); t; t = TREE_CHAIN (t))
4056 {
4057 tree gnu_field_deref
4058 = build_component_ref (gnu_ret_deref, TREE_PURPOSE (t), true);
4059 gnu_result = build2 (MODIFY_EXPR, void_type_node,
4060 gnu_field_deref, TREE_VALUE (t));
4061 add_stmt_with_node (gnu_result, gnat_end_label);
4062 }
4063 }
4064
4065 /* Otherwise, if this is a procedure or a function which does not return
4066 by invisible reference, we can do a direct block-copy out. */
4067 else
4068 {
4069 tree gnu_retval;
4070
4071 if (list_length (gnu_cico_list) == 1)
4072 gnu_retval = TREE_VALUE (gnu_cico_list);
4073 else
4074 gnu_retval
4075 = build_constructor_from_list (TREE_TYPE (gnu_subprog_type),
4076 gnu_cico_list);
4077
4078 gnu_result = build_return_expr (gnu_result_decl, gnu_retval);
4079 add_stmt_with_node (gnu_result, gnat_end_label);
4080 }
4081
4082 gnat_poplevel ();
4083 gnu_result = end_stmt_group ();
4084 }
4085
4086 gnu_return_label_stack->pop ();
4087
4088 /* On SEH targets, install an exception handler around the main entry
4089 point to catch unhandled exceptions. */
4090 if (DECL_NAME (gnu_subprog_decl) == main_identifier_node
4091 && targetm_common.except_unwind_info (&global_options) == UI_SEH)
4092 {
4093 tree t;
4094 tree etype;
4095
4096 t = build_call_expr (builtin_decl_explicit (BUILT_IN_EH_POINTER),
4097 1, integer_zero_node);
4098 t = build_call_n_expr (unhandled_except_decl, 1, t);
4099
4100 etype = build_unary_op (ADDR_EXPR, NULL_TREE, unhandled_others_decl);
4101 etype = tree_cons (NULL_TREE, etype, NULL_TREE);
4102
4103 t = build2 (CATCH_EXPR, void_type_node, etype, t);
4104 gnu_result = build2 (TRY_CATCH_EXPR, TREE_TYPE (gnu_result),
4105 gnu_result, t);
4106 }
4107
4108 end_subprog_body (gnu_result);
4109
4110 /* Finally annotate the parameters and disconnect the trees for parameters
4111 that we have turned into variables since they are now unusable. */
4112 for (gnat_param = First_Formal_With_Extras (gnat_subprog_id);
4113 Present (gnat_param);
4114 gnat_param = Next_Formal_With_Extras (gnat_param))
4115 {
4116 tree gnu_param = get_gnu_tree (gnat_param);
4117 bool is_var_decl = (TREE_CODE (gnu_param) == VAR_DECL);
4118
4119 annotate_object (gnat_param, TREE_TYPE (gnu_param), NULL_TREE,
4120 DECL_BY_REF_P (gnu_param));
4121
4122 if (is_var_decl)
4123 save_gnu_tree (gnat_param, NULL_TREE, false);
4124 }
4125
4126 /* Disconnect the variable created for the return value. */
4127 if (gnu_return_var_elmt)
4128 TREE_VALUE (gnu_return_var_elmt) = void_type_node;
4129
4130 /* If the function returns an aggregate type and we have candidates for
4131 a Named Return Value, finalize the optimization. */
4132 if (optimize && !optimize_debug && gnu_subprog_language->named_ret_val)
4133 {
4134 finalize_nrv (gnu_subprog_decl,
4135 gnu_subprog_language->named_ret_val,
4136 gnu_subprog_language->other_ret_val,
4137 gnu_subprog_language->gnat_ret);
4138 gnu_subprog_language->named_ret_val = NULL;
4139 gnu_subprog_language->other_ret_val = NULL;
4140 }
4141
4142 /* If this is an inlined external function that has been marked uninlinable,
4143 drop the body and stop there. Otherwise compile the body. */
4144 if (DECL_EXTERNAL (gnu_subprog_decl) && DECL_UNINLINABLE (gnu_subprog_decl))
4145 DECL_SAVED_TREE (gnu_subprog_decl) = NULL_TREE;
4146 else
4147 rest_of_subprog_body_compilation (gnu_subprog_decl);
4148 }
4149
4150 /* The type of an atomic access. */
4151
4152 typedef enum { NOT_ATOMIC, SIMPLE_ATOMIC, OUTER_ATOMIC } atomic_acces_t;
4153
4154 /* Return true if GNAT_NODE references an Atomic entity. This is modeled on
4155 the Is_Atomic_Object predicate of the front-end, but additionally handles
4156 explicit dereferences. */
4157
4158 static bool
node_is_atomic(Node_Id gnat_node)4159 node_is_atomic (Node_Id gnat_node)
4160 {
4161 Entity_Id gnat_entity;
4162
4163 switch (Nkind (gnat_node))
4164 {
4165 case N_Identifier:
4166 case N_Expanded_Name:
4167 gnat_entity = Entity (gnat_node);
4168 if (Ekind (gnat_entity) != E_Variable)
4169 break;
4170 return Is_Atomic (gnat_entity) || Is_Atomic (Etype (gnat_entity));
4171
4172 case N_Selected_Component:
4173 return Is_Atomic (Etype (gnat_node))
4174 || Is_Atomic (Entity (Selector_Name (gnat_node)));
4175
4176 case N_Indexed_Component:
4177 return Is_Atomic (Etype (gnat_node))
4178 || Has_Atomic_Components (Etype (Prefix (gnat_node)))
4179 || (Is_Entity_Name (Prefix (gnat_node))
4180 && Has_Atomic_Components (Entity (Prefix (gnat_node))));
4181
4182 case N_Explicit_Dereference:
4183 return Is_Atomic (Etype (gnat_node));
4184
4185 default:
4186 break;
4187 }
4188
4189 return false;
4190 }
4191
4192 /* Return true if GNAT_NODE references a Volatile_Full_Access entity. This is
4193 modeled on the Is_Volatile_Full_Access_Object predicate of the front-end,
4194 but additionally handles explicit dereferences. */
4195
4196 static bool
node_is_volatile_full_access(Node_Id gnat_node)4197 node_is_volatile_full_access (Node_Id gnat_node)
4198 {
4199 Entity_Id gnat_entity;
4200
4201 switch (Nkind (gnat_node))
4202 {
4203 case N_Identifier:
4204 case N_Expanded_Name:
4205 gnat_entity = Entity (gnat_node);
4206 if (!Is_Object (gnat_entity))
4207 break;
4208 return Is_Volatile_Full_Access (gnat_entity)
4209 || Is_Volatile_Full_Access (Etype (gnat_entity));
4210
4211 case N_Selected_Component:
4212 return Is_Volatile_Full_Access (Etype (gnat_node))
4213 || Is_Volatile_Full_Access (Entity (Selector_Name (gnat_node)));
4214
4215 case N_Indexed_Component:
4216 case N_Explicit_Dereference:
4217 return Is_Volatile_Full_Access (Etype (gnat_node));
4218
4219 default:
4220 break;
4221 }
4222
4223 return false;
4224 }
4225
4226 /* Return true if GNAT_NODE references a component of a larger object. */
4227
4228 static inline bool
node_is_component(Node_Id gnat_node)4229 node_is_component (Node_Id gnat_node)
4230 {
4231 const Node_Kind k = Nkind (gnat_node);
4232 return
4233 (k == N_Indexed_Component || k == N_Selected_Component || k == N_Slice);
4234 }
4235
4236 /* Compute whether GNAT_NODE requires atomic access and set TYPE to the type
4237 of access and SYNC according to the associated synchronization setting.
4238
4239 We implement 3 different semantics of atomicity in this function:
4240
4241 1. the Ada 95/2005/2012 semantics of the Atomic aspect/pragma,
4242 2. the Ada 2022 semantics of the Atomic aspect/pragma,
4243 3. the semantics of the Volatile_Full_Access GNAT aspect/pragma.
4244
4245 They are mutually exclusive and the FE should have rejected conflicts. */
4246
4247 static void
get_atomic_access(Node_Id gnat_node,atomic_acces_t * type,bool * sync)4248 get_atomic_access (Node_Id gnat_node, atomic_acces_t *type, bool *sync)
4249 {
4250 Node_Id gnat_parent, gnat_temp;
4251 unsigned char attr_id;
4252
4253 /* First, scan the parent to filter out irrelevant cases. */
4254 gnat_parent = Parent (gnat_node);
4255 switch (Nkind (gnat_parent))
4256 {
4257 case N_Attribute_Reference:
4258 attr_id = Get_Attribute_Id (Attribute_Name (gnat_parent));
4259 /* Do not mess up machine code insertions. */
4260 if (attr_id == Attr_Asm_Input || attr_id == Attr_Asm_Output)
4261 goto not_atomic;
4262
4263 /* Nothing to do if we are the prefix of an attribute, since we do not
4264 want an atomic access for things like 'Size. */
4265
4266 /* ... fall through ... */
4267
4268 case N_Reference:
4269 /* The N_Reference node is like an attribute. */
4270 if (Prefix (gnat_parent) == gnat_node)
4271 goto not_atomic;
4272 break;
4273
4274 case N_Object_Renaming_Declaration:
4275 /* Nothing to do for the identifier in an object renaming declaration,
4276 the renaming itself does not need atomic access. */
4277 goto not_atomic;
4278
4279 default:
4280 break;
4281 }
4282
4283 /* Now strip any type conversion from GNAT_NODE. */
4284 if (Nkind (gnat_node) == N_Type_Conversion
4285 || Nkind (gnat_node) == N_Unchecked_Type_Conversion)
4286 gnat_node = Expression (gnat_node);
4287
4288 /* Up to Ada 2012, for Atomic itself, only reads and updates of the object as
4289 a whole require atomic access (RM C.6(15)). But, starting with Ada 2022,
4290 reads of or writes to a nonatomic subcomponent of the object also require
4291 atomic access (RM C.6(19)). */
4292 if (node_is_atomic (gnat_node))
4293 {
4294 bool as_a_whole = true;
4295
4296 /* If we are the prefix of the parent, then the access is partial. */
4297 for (gnat_temp = gnat_node, gnat_parent = Parent (gnat_temp);
4298 node_is_component (gnat_parent) && Prefix (gnat_parent) == gnat_temp;
4299 gnat_temp = gnat_parent, gnat_parent = Parent (gnat_temp))
4300 if (Ada_Version < Ada_2022 || node_is_atomic (gnat_parent))
4301 goto not_atomic;
4302 else
4303 as_a_whole = false;
4304
4305 /* We consider that partial accesses are not sequential actions and,
4306 therefore, do not require synchronization. */
4307 *type = SIMPLE_ATOMIC;
4308 *sync = as_a_whole ? Atomic_Sync_Required (gnat_node) : false;
4309 return;
4310 }
4311
4312 /* Look for an outer atomic access of a nonatomic subcomponent. Note that,
4313 for VFA, we do this before looking at the node itself because we need to
4314 access the outermost VFA object atomically, unlike for Atomic where it is
4315 the innermost atomic object (RM C.6(19)). */
4316 for (gnat_temp = gnat_node;
4317 node_is_component (gnat_temp);
4318 gnat_temp = Prefix (gnat_temp))
4319 if ((Ada_Version >= Ada_2022 && node_is_atomic (Prefix (gnat_temp)))
4320 || node_is_volatile_full_access (Prefix (gnat_temp)))
4321 {
4322 *type = OUTER_ATOMIC;
4323 *sync = false;
4324 return;
4325 }
4326
4327 /* Unlike Atomic, accessing a VFA object always requires atomic access. */
4328 if (node_is_volatile_full_access (gnat_node))
4329 {
4330 *type = SIMPLE_ATOMIC;
4331 *sync = false;
4332 return;
4333 }
4334
4335 not_atomic:
4336 *type = NOT_ATOMIC;
4337 *sync = false;
4338 }
4339
4340 /* Return true if GNAT_NODE requires simple atomic access and, if so, set SYNC
4341 according to the associated synchronization setting. */
4342
4343 static inline bool
simple_atomic_access_required_p(Node_Id gnat_node,bool * sync)4344 simple_atomic_access_required_p (Node_Id gnat_node, bool *sync)
4345 {
4346 atomic_acces_t type;
4347 get_atomic_access (gnat_node, &type, sync);
4348 return type == SIMPLE_ATOMIC;
4349 }
4350
4351 /* Create a temporary variable with PREFIX and TYPE, and return it. */
4352
4353 static tree
create_temporary(const char * prefix,tree type)4354 create_temporary (const char *prefix, tree type)
4355 {
4356 tree gnu_temp
4357 = create_var_decl (create_tmp_var_name (prefix), NULL_TREE,
4358 type, NULL_TREE,
4359 false, false, false, false, false,
4360 true, false, NULL, Empty);
4361 return gnu_temp;
4362 }
4363
4364 /* Create a temporary variable with PREFIX and initialize it with GNU_INIT.
4365 Put the initialization statement into GNU_INIT_STMT and annotate it with
4366 the SLOC of GNAT_NODE. Return the temporary variable. */
4367
4368 static tree
create_init_temporary(const char * prefix,tree gnu_init,tree * gnu_init_stmt,Node_Id gnat_node)4369 create_init_temporary (const char *prefix, tree gnu_init, tree *gnu_init_stmt,
4370 Node_Id gnat_node)
4371 {
4372 tree gnu_temp = create_temporary (prefix, TREE_TYPE (gnu_init));
4373
4374 *gnu_init_stmt = build_binary_op (INIT_EXPR, NULL_TREE, gnu_temp, gnu_init);
4375 set_expr_location_from_node (*gnu_init_stmt, gnat_node);
4376
4377 return gnu_temp;
4378 }
4379
4380 /* Return true if TYPE is an array of scalar type. */
4381
4382 static bool
is_array_of_scalar_type(tree type)4383 is_array_of_scalar_type (tree type)
4384 {
4385 if (TREE_CODE (type) != ARRAY_TYPE)
4386 return false;
4387
4388 type = TREE_TYPE (type);
4389
4390 return !AGGREGATE_TYPE_P (type) && !POINTER_TYPE_P (type);
4391 }
4392
4393 /* Helper function for walk_tree, used by return_slot_opt_for_pure_call_p. */
4394
4395 static tree
find_decls_r(tree * tp,int * walk_subtrees,void * data)4396 find_decls_r (tree *tp, int *walk_subtrees, void *data)
4397 {
4398 bitmap decls = (bitmap) data;
4399
4400 if (TYPE_P (*tp))
4401 *walk_subtrees = 0;
4402
4403 else if (DECL_P (*tp))
4404 bitmap_set_bit (decls, DECL_UID (*tp));
4405
4406 return NULL_TREE;
4407 }
4408
4409 /* Return whether the assignment TARGET = CALL can be subject to the return
4410 slot optimization, under the assumption that the called function be pure
4411 in the Ada sense and return an array of scalar type. */
4412
4413 static bool
return_slot_opt_for_pure_call_p(tree target,tree call)4414 return_slot_opt_for_pure_call_p (tree target, tree call)
4415 {
4416 /* Check that the target is a DECL. */
4417 if (!DECL_P (target))
4418 return false;
4419
4420 const bitmap decls = BITMAP_GGC_ALLOC ();
4421 call_expr_arg_iterator iter;
4422 tree arg;
4423
4424 /* Check that all the arguments have either a scalar type (we assume that
4425 this means by-copy passing mechanism) or array of scalar type. */
4426 FOR_EACH_CALL_EXPR_ARG (arg, iter, call)
4427 {
4428 tree arg_type = TREE_TYPE (arg);
4429 if (TREE_CODE (arg_type) == REFERENCE_TYPE)
4430 arg_type = TREE_TYPE (arg_type);
4431
4432 if (is_array_of_scalar_type (arg_type))
4433 walk_tree_without_duplicates (&arg, find_decls_r, decls);
4434
4435 else if (AGGREGATE_TYPE_P (arg_type) || POINTER_TYPE_P (arg_type))
4436 return false;
4437 }
4438
4439 /* Check that the target is not referenced by the non-scalar arguments. */
4440 return !bitmap_bit_p (decls, DECL_UID (target));
4441 }
4442
4443 /* Subroutine of gnat_to_gnu to translate gnat_node, either an N_Function_Call
4444 or an N_Procedure_Call_Statement, to a GCC tree, which is returned.
4445 GNU_RESULT_TYPE_P is a pointer to where we should place the result type.
4446 If GNU_TARGET is non-null, this must be a function call on the RHS of a
4447 N_Assignment_Statement and the result is to be placed into that object.
4448 ATOMIC_ACCESS is the type of atomic access to be used for the assignment
4449 to GNU_TARGET. If, in addition, ATOMIC_SYNC is true, then the assignment
4450 to GNU_TARGET requires atomic synchronization. */
4451
4452 static tree
Call_to_gnu(Node_Id gnat_node,tree * gnu_result_type_p,tree gnu_target,atomic_acces_t atomic_access,bool atomic_sync)4453 Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target,
4454 atomic_acces_t atomic_access, bool atomic_sync)
4455 {
4456 const bool function_call = (Nkind (gnat_node) == N_Function_Call);
4457 const bool returning_value = (function_call && !gnu_target);
4458 /* The GCC node corresponding to the GNAT subprogram name. This can either
4459 be a FUNCTION_DECL node if we are dealing with a standard subprogram call,
4460 or an indirect reference expression (an INDIRECT_REF node) pointing to a
4461 subprogram. */
4462 const Node_Id gnat_subprog = Name (gnat_node);
4463 tree gnu_subprog = gnat_to_gnu (gnat_subprog);
4464 /* The FUNCTION_TYPE node giving the GCC type of the subprogram. */
4465 tree gnu_subprog_type = TREE_TYPE (gnu_subprog);
4466 /* The return type of the FUNCTION_TYPE. */
4467 tree gnu_result_type = TREE_TYPE (gnu_subprog_type);
4468 const bool frontend_builtin
4469 = (TREE_CODE (gnu_subprog) == FUNCTION_DECL
4470 && DECL_BUILT_IN_CLASS (gnu_subprog) == BUILT_IN_FRONTEND);
4471 auto_vec<tree, 16> gnu_actual_vec;
4472 tree gnu_name_list = NULL_TREE;
4473 tree gnu_stmt_list = NULL_TREE;
4474 tree gnu_after_list = NULL_TREE;
4475 tree gnu_retval = NULL_TREE;
4476 tree gnu_call, gnu_result;
4477 bool went_into_elab_proc;
4478 bool pushed_binding_level;
4479 bool variadic;
4480 bool by_descriptor;
4481 Entity_Id gnat_formal;
4482 Node_Id gnat_actual;
4483 atomic_acces_t aa_type;
4484 bool aa_sync;
4485
4486 /* The only way we can make a call via an access type is if GNAT_NAME is an
4487 explicit dereference. In that case, get the list of formal args from the
4488 type the access type is pointing to. Otherwise, get the formals from the
4489 entity being called. */
4490 if (Nkind (gnat_subprog) == N_Explicit_Dereference)
4491 {
4492 const Entity_Id gnat_prefix_type
4493 = Underlying_Type (Etype (Prefix (gnat_subprog)));
4494
4495 gnat_formal = First_Formal_With_Extras (Etype (gnat_subprog));
4496 variadic = IN (Convention (gnat_prefix_type), Convention_C_Variadic);
4497
4498 /* If the access type doesn't require foreign-compatible representation,
4499 be prepared for descriptors. */
4500 by_descriptor
4501 = targetm.calls.custom_function_descriptors > 0
4502 && Can_Use_Internal_Rep (gnat_prefix_type);
4503 }
4504
4505 else if (Nkind (gnat_subprog) == N_Attribute_Reference)
4506 {
4507 /* Assume here that this must be 'Elab_Body or 'Elab_Spec. */
4508 gnat_formal = Empty;
4509 variadic = false;
4510 by_descriptor = false;
4511 }
4512
4513 else
4514 {
4515 gcc_checking_assert (Is_Entity_Name (gnat_subprog));
4516
4517 gnat_formal = First_Formal_With_Extras (Entity (gnat_subprog));
4518 variadic = IN (Convention (Entity (gnat_subprog)), Convention_C_Variadic);
4519 by_descriptor = false;
4520
4521 /* If we are calling a stubbed function, then raise Program_Error, but
4522 elaborate all our args first. */
4523 if (Convention (Entity (gnat_subprog)) == Convention_Stubbed)
4524 {
4525 tree call_expr = build_call_raise (PE_Stubbed_Subprogram_Called,
4526 gnat_node, N_Raise_Program_Error);
4527
4528 for (gnat_actual = First_Actual (gnat_node);
4529 Present (gnat_actual);
4530 gnat_actual = Next_Actual (gnat_actual))
4531 add_stmt (gnat_to_gnu (gnat_actual));
4532
4533 if (returning_value)
4534 {
4535 *gnu_result_type_p = gnu_result_type;
4536 return build1 (NULL_EXPR, gnu_result_type, call_expr);
4537 }
4538
4539 return call_expr;
4540 }
4541 }
4542
4543 gcc_assert (FUNC_OR_METHOD_TYPE_P (gnu_subprog_type));
4544
4545 if (TREE_CODE (gnu_subprog) == FUNCTION_DECL)
4546 {
4547 /* For a call to a nested function, check the inlining status. */
4548 if (decl_function_context (gnu_subprog))
4549 check_inlining_for_nested_subprog (gnu_subprog);
4550
4551 /* For a recursive call, avoid explosion due to recursive inlining. */
4552 if (gnu_subprog == current_function_decl)
4553 DECL_DISREGARD_INLINE_LIMITS (gnu_subprog) = 0;
4554 }
4555
4556 /* The lifetime of the temporaries created for the call ends right after the
4557 return value is copied, so we can give them the scope of the elaboration
4558 routine at top level. */
4559 if (!current_function_decl)
4560 {
4561 current_function_decl = get_elaboration_procedure ();
4562 went_into_elab_proc = true;
4563 }
4564 else
4565 went_into_elab_proc = false;
4566
4567 /* First, create the temporary for the return value when:
4568
4569 1. There is no target and the function has copy-in/copy-out parameters,
4570 because we need to preserve the return value before copying back the
4571 parameters.
4572
4573 2. There is no target and the call is made for neither the declaration
4574 of an object (regular or renaming), nor a return statement, nor an
4575 allocator, nor an aggregate, and the return type has variable size
4576 because in this case the gimplifier cannot create the temporary, or
4577 more generally is an aggregate type, because the gimplifier would
4578 create the temporary in the outermost scope instead of locally here.
4579 But there is an exception for an allocator of unconstrained record
4580 type with default discriminant because we allocate the actual size
4581 in this case, unlike in the other cases, so we need a temporary to
4582 fetch the discriminant and we create it here.
4583
4584 3. There is a target and it is a slice or an array with fixed size,
4585 and the return type has variable size, because the gimplifier
4586 doesn't handle these cases.
4587
4588 4. There is a target which is a bit-field and the function returns an
4589 unconstrained record type with default discriminant, because the
4590 return may copy more data than the bit-field can contain.
4591
4592 5. There is no target and we have misaligned In Out or Out parameters
4593 passed by reference, because we need to preserve the return value
4594 before copying back the parameters. However, in this case, we'll
4595 defer creating the temporary, see below.
4596
4597 This must be done before we push a binding level around the call, since
4598 we will pop it before copying the return value. */
4599 if (function_call
4600 && ((!gnu_target && TYPE_CI_CO_LIST (gnu_subprog_type))
4601 || (!gnu_target
4602 && Nkind (Parent (gnat_node)) != N_Object_Declaration
4603 && Nkind (Parent (gnat_node)) != N_Object_Renaming_Declaration
4604 && Nkind (Parent (gnat_node)) != N_Simple_Return_Statement
4605 && (!(Nkind (Parent (gnat_node)) == N_Qualified_Expression
4606 && Nkind (Parent (Parent (gnat_node))) == N_Allocator)
4607 || type_is_padding_self_referential (gnu_result_type))
4608 && Nkind (Parent (gnat_node)) != N_Aggregate
4609 && AGGREGATE_TYPE_P (gnu_result_type)
4610 && !TYPE_IS_FAT_POINTER_P (gnu_result_type))
4611 || (gnu_target
4612 && (TREE_CODE (gnu_target) == ARRAY_RANGE_REF
4613 || (TREE_CODE (TREE_TYPE (gnu_target)) == ARRAY_TYPE
4614 && TREE_CODE (TYPE_SIZE (TREE_TYPE (gnu_target)))
4615 == INTEGER_CST))
4616 && TREE_CODE (TYPE_SIZE (gnu_result_type)) != INTEGER_CST)
4617 || (gnu_target
4618 && TREE_CODE (gnu_target) == COMPONENT_REF
4619 && DECL_BIT_FIELD (TREE_OPERAND (gnu_target, 1))
4620 && DECL_SIZE (TREE_OPERAND (gnu_target, 1))
4621 != TYPE_SIZE (TREE_TYPE (gnu_target))
4622 && type_is_padding_self_referential (gnu_result_type))))
4623 {
4624 gnu_retval = create_temporary ("R", gnu_result_type);
4625 DECL_RETURN_VALUE_P (gnu_retval) = 1;
4626 }
4627
4628 /* If we don't need a value or have already created it, push a binding level
4629 around the call. This will narrow the lifetime of the temporaries we may
4630 need to make when translating the parameters as much as possible. */
4631 if (!returning_value || gnu_retval)
4632 {
4633 start_stmt_group ();
4634 gnat_pushlevel ();
4635 pushed_binding_level = true;
4636 }
4637 else
4638 pushed_binding_level = false;
4639
4640 /* Create the list of the actual parameters as GCC expects it, namely a
4641 chain of TREE_LIST nodes in which the TREE_VALUE field of each node
4642 is an expression and the TREE_PURPOSE field is null. But skip Out
4643 parameters not passed by reference and that need not be copied in. */
4644 for (gnat_actual = First_Actual (gnat_node);
4645 Present (gnat_actual);
4646 gnat_formal = Next_Formal_With_Extras (gnat_formal),
4647 gnat_actual = Next_Actual (gnat_actual))
4648 {
4649 Entity_Id gnat_formal_type = Etype (gnat_formal);
4650 tree gnu_formal_type = gnat_to_gnu_type (gnat_formal_type);
4651 tree gnu_formal = present_gnu_tree (gnat_formal)
4652 ? get_gnu_tree (gnat_formal) : NULL_TREE;
4653 const bool in_param = (Ekind (gnat_formal) == E_In_Parameter);
4654 const bool is_true_formal_parm
4655 = gnu_formal && TREE_CODE (gnu_formal) == PARM_DECL;
4656 const bool is_by_ref_formal_parm
4657 = is_true_formal_parm
4658 && (DECL_BY_REF_P (gnu_formal)
4659 || DECL_BY_COMPONENT_PTR_P (gnu_formal));
4660 /* In the In Out or Out case, we must suppress conversions that yield
4661 an lvalue but can nevertheless cause the creation of a temporary,
4662 because we need the real object in this case, either to pass its
4663 address if it's passed by reference or as target of the back copy
4664 done after the call if it uses the copy-in/copy-out mechanism.
4665 We do it in the In case too, except for an unchecked conversion
4666 to an elementary type or a constrained composite type because it
4667 alone can cause the actual to be misaligned and the addressability
4668 test is applied to the real object. */
4669 const bool suppress_type_conversion
4670 = ((Nkind (gnat_actual) == N_Unchecked_Type_Conversion
4671 && (!in_param
4672 || !is_by_ref_formal_parm
4673 || (Is_Composite_Type (Underlying_Type (gnat_formal_type))
4674 && !Is_Constrained (Underlying_Type (gnat_formal_type)))))
4675 || (Nkind (gnat_actual) == N_Type_Conversion
4676 && Is_Composite_Type (Underlying_Type (gnat_formal_type))));
4677 Node_Id gnat_name = suppress_type_conversion
4678 ? Expression (gnat_actual) : gnat_actual;
4679 tree gnu_name = gnat_to_gnu (gnat_name), gnu_name_type;
4680
4681 /* If it's possible we may need to use this expression twice, make sure
4682 that any side-effects are handled via SAVE_EXPRs; likewise if we need
4683 to force side-effects before the call. */
4684 if (!in_param && !is_by_ref_formal_parm)
4685 {
4686 tree init = NULL_TREE;
4687 gnu_name = gnat_stabilize_reference (gnu_name, true, &init);
4688 if (init)
4689 gnu_name
4690 = build_compound_expr (TREE_TYPE (gnu_name), init, gnu_name);
4691 }
4692
4693 /* If we are passing a non-addressable parameter by reference, pass the
4694 address of a copy. In the In Out or Out case, set up to copy back
4695 out after the call. */
4696 if (is_by_ref_formal_parm
4697 && (gnu_name_type = gnat_to_gnu_type (Etype (gnat_name)))
4698 && !addressable_p (gnu_name, gnu_name_type))
4699 {
4700 tree gnu_orig = gnu_name, gnu_temp, gnu_stmt;
4701
4702 /* Do not issue warnings for CONSTRUCTORs since this is not a copy
4703 but sort of an instantiation for them. */
4704 if (TREE_CODE (remove_conversions (gnu_name, true)) == CONSTRUCTOR)
4705 ;
4706
4707 /* If the formal is passed by reference, a copy is not allowed. */
4708 else if (TYPE_IS_BY_REFERENCE_P (gnu_formal_type)
4709 || Is_Aliased (gnat_formal))
4710 post_error ("misaligned actual cannot be passed by reference",
4711 gnat_actual);
4712
4713 /* If the mechanism was forced to by-ref, a copy is not allowed but
4714 we issue only a warning because this case is not strict Ada. */
4715 else if (DECL_FORCED_BY_REF_P (gnu_formal))
4716 post_error ("misaligned actual cannot be passed by reference??",
4717 gnat_actual);
4718
4719 /* If the actual type of the object is already the nominal type,
4720 we have nothing to do, except if the size is self-referential
4721 in which case we'll remove the unpadding below. */
4722 if (TREE_TYPE (gnu_name) == gnu_name_type
4723 && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_name_type)))
4724 ;
4725
4726 /* Otherwise remove the unpadding from all the objects. */
4727 else if (TREE_CODE (gnu_name) == COMPONENT_REF
4728 && TYPE_IS_PADDING_P
4729 (TREE_TYPE (TREE_OPERAND (gnu_name, 0))))
4730 gnu_orig = gnu_name = TREE_OPERAND (gnu_name, 0);
4731
4732 /* Otherwise convert to the nominal type of the object if needed.
4733 There are several cases in which we need to make the temporary
4734 using this type instead of the actual type of the object when
4735 they are distinct, because the expectations of the callee would
4736 otherwise not be met:
4737 - if it's a justified modular type,
4738 - if the actual type is a smaller form of it,
4739 - if it's a smaller form of the actual type. */
4740 else if ((TREE_CODE (gnu_name_type) == RECORD_TYPE
4741 && (TYPE_JUSTIFIED_MODULAR_P (gnu_name_type)
4742 || smaller_form_type_p (TREE_TYPE (gnu_name),
4743 gnu_name_type)))
4744 || (INTEGRAL_TYPE_P (gnu_name_type)
4745 && smaller_form_type_p (gnu_name_type,
4746 TREE_TYPE (gnu_name))))
4747 gnu_name = convert (gnu_name_type, gnu_name);
4748
4749 /* If this is an In Out or Out parameter and we're returning a value,
4750 we need to create a temporary for the return value because we must
4751 preserve it before copying back at the very end. */
4752 if (!in_param && returning_value && !gnu_retval)
4753 {
4754 gnu_retval = create_temporary ("R", gnu_result_type);
4755 DECL_RETURN_VALUE_P (gnu_retval) = 1;
4756 }
4757
4758 /* If we haven't pushed a binding level, push it now. This will
4759 narrow the lifetime of the temporary we are about to make as
4760 much as possible. */
4761 if (!pushed_binding_level && (!returning_value || gnu_retval))
4762 {
4763 start_stmt_group ();
4764 gnat_pushlevel ();
4765 pushed_binding_level = true;
4766 }
4767
4768 /* Create an explicit temporary holding the copy. */
4769 /* Do not initialize it for the _Init parameter of an initialization
4770 procedure since no data is meant to be passed in. */
4771 if (Ekind (gnat_formal) == E_Out_Parameter
4772 && Is_Entity_Name (gnat_subprog)
4773 && Is_Init_Proc (Entity (gnat_subprog)))
4774 gnu_name = gnu_temp = create_temporary ("A", TREE_TYPE (gnu_name));
4775
4776 /* Initialize it on the fly like for an implicit temporary in the
4777 other cases, as we don't necessarily have a statement list. */
4778 else
4779 {
4780 gnu_temp = create_init_temporary ("A", gnu_name, &gnu_stmt,
4781 gnat_actual);
4782 gnu_name = build_compound_expr (TREE_TYPE (gnu_name), gnu_stmt,
4783 gnu_temp);
4784 }
4785
4786 /* Set up to move the copy back to the original if needed. */
4787 if (!in_param)
4788 {
4789 /* If the original is a COND_EXPR whose first arm isn't meant to
4790 be further used, just deal with the second arm. This is very
4791 likely the conditional expression built for a check. */
4792 if (TREE_CODE (gnu_orig) == COND_EXPR
4793 && TREE_CODE (TREE_OPERAND (gnu_orig, 1)) == COMPOUND_EXPR
4794 && integer_zerop
4795 (TREE_OPERAND (TREE_OPERAND (gnu_orig, 1), 1)))
4796 gnu_orig = TREE_OPERAND (gnu_orig, 2);
4797
4798 gnu_stmt
4799 = build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_orig, gnu_temp);
4800 set_expr_location_from_node (gnu_stmt, gnat_node);
4801
4802 append_to_statement_list (gnu_stmt, &gnu_after_list);
4803 }
4804 }
4805
4806 /* Start from the real object and build the actual. */
4807 tree gnu_actual = gnu_name;
4808
4809 /* If atomic access is required for an In or In Out actual parameter,
4810 build the atomic load. */
4811 if (is_true_formal_parm
4812 && !is_by_ref_formal_parm
4813 && Ekind (gnat_formal) != E_Out_Parameter
4814 && simple_atomic_access_required_p (gnat_actual, &aa_sync))
4815 gnu_actual = build_atomic_load (gnu_actual, aa_sync);
4816
4817 /* If this was a procedure call, we may not have removed any padding.
4818 So do it here for the part we will use as an input, if any. */
4819 if (Ekind (gnat_formal) != E_Out_Parameter
4820 && TYPE_IS_PADDING_P (TREE_TYPE (gnu_actual)))
4821 gnu_actual
4822 = convert (get_unpadded_type (Etype (gnat_actual)), gnu_actual);
4823
4824 /* Put back the conversion we suppressed above in the computation of the
4825 real object. And even if we didn't suppress any conversion there, we
4826 may have suppressed a conversion to the Etype of the actual earlier,
4827 since the parent is a procedure call, so put it back here. Note that
4828 we might have a dummy type here if the actual is the dereference of a
4829 pointer to it, but that's OK when the formal is passed by reference.
4830 We also do not put back a conversion between an actual and a formal
4831 that are unconstrained array types to avoid creating local bounds. */
4832 tree gnu_actual_type = get_unpadded_type (Etype (gnat_actual));
4833 if (TYPE_IS_DUMMY_P (gnu_actual_type))
4834 gcc_assert (is_true_formal_parm && DECL_BY_REF_P (gnu_formal));
4835 else if (suppress_type_conversion
4836 && Nkind (gnat_actual) == N_Unchecked_Type_Conversion)
4837 gnu_actual = unchecked_convert (gnu_actual_type, gnu_actual,
4838 No_Truncation (gnat_actual));
4839 else if ((TREE_CODE (TREE_TYPE (gnu_actual)) == UNCONSTRAINED_ARRAY_TYPE
4840 || (TREE_CODE (TREE_TYPE (gnu_actual)) == RECORD_TYPE
4841 && TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (gnu_actual))))
4842 && TREE_CODE (gnu_formal_type) == UNCONSTRAINED_ARRAY_TYPE)
4843 ;
4844 else
4845 gnu_actual = convert (gnu_actual_type, gnu_actual);
4846
4847 gigi_checking_assert (!Do_Range_Check (gnat_actual));
4848
4849 /* First see if the parameter is passed by reference. */
4850 if (is_true_formal_parm && DECL_BY_REF_P (gnu_formal))
4851 {
4852 if (!in_param)
4853 {
4854 /* In Out or Out parameters passed by reference don't use the
4855 copy-in/copy-out mechanism so the address of the real object
4856 must be passed to the function. */
4857 gnu_actual = gnu_name;
4858
4859 /* If we have a padded type, be sure we've removed padding. */
4860 if (TYPE_IS_PADDING_P (TREE_TYPE (gnu_actual)))
4861 gnu_actual = convert (get_unpadded_type (Etype (gnat_actual)),
4862 gnu_actual);
4863
4864 /* If we have the constructed subtype of an aliased object
4865 with an unconstrained nominal subtype, the type of the
4866 actual includes the template, although it is formally
4867 constrained. So we need to convert it back to the real
4868 constructed subtype to retrieve the constrained part
4869 and takes its address. */
4870 if (TREE_CODE (TREE_TYPE (gnu_actual)) == RECORD_TYPE
4871 && TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (gnu_actual))
4872 && Is_Constr_Subt_For_UN_Aliased (Etype (gnat_actual))
4873 && Is_Array_Type (Underlying_Type (Etype (gnat_actual))))
4874 gnu_actual = convert (gnu_actual_type, gnu_actual);
4875 }
4876
4877 /* There is no need to convert the actual to the formal's type before
4878 taking its address. The only exception is for unconstrained array
4879 types because of the way we build fat pointers. */
4880 if (TREE_CODE (gnu_formal_type) == UNCONSTRAINED_ARRAY_TYPE)
4881 {
4882 /* Put back the conversion we suppressed above for In Out or Out
4883 parameters, since it may set the bounds of the actual. */
4884 if (!in_param && suppress_type_conversion)
4885 gnu_actual = convert (gnu_actual_type, gnu_actual);
4886 gnu_actual = convert (gnu_formal_type, gnu_actual);
4887 }
4888
4889 /* Take the address of the object and convert to the proper pointer
4890 type. */
4891 gnu_formal_type = TREE_TYPE (gnu_formal);
4892 gnu_actual = build_unary_op (ADDR_EXPR, gnu_formal_type, gnu_actual);
4893 }
4894
4895 /* Then see if the parameter is an array passed to a foreign convention
4896 subprogram. */
4897 else if (is_true_formal_parm && DECL_BY_COMPONENT_PTR_P (gnu_formal))
4898 {
4899 gnu_actual = maybe_padded_object (gnu_actual);
4900 gnu_actual = maybe_unconstrained_array (gnu_actual);
4901
4902 /* Take the address of the object and convert to the proper pointer
4903 type. We'd like to actually compute the address of the beginning
4904 of the array using an ADDR_EXPR of an ARRAY_REF, but there's a
4905 possibility that the ARRAY_REF might return a constant and we'd be
4906 getting the wrong address. Neither approach is exactly correct,
4907 but this is the most likely to work in all cases. */
4908 gnu_formal_type = TREE_TYPE (gnu_formal);
4909 gnu_actual = build_unary_op (ADDR_EXPR, gnu_formal_type, gnu_actual);
4910 }
4911
4912 /* Then see if the parameter is passed by copy. */
4913 else if (is_true_formal_parm)
4914 {
4915 if (!in_param)
4916 gnu_name_list = tree_cons (NULL_TREE, gnu_name, gnu_name_list);
4917
4918 gnu_actual = convert (gnu_formal_type, gnu_actual);
4919
4920 /* If this is a front-end built-in function, there is no need to
4921 convert to the type used to pass the argument. */
4922 if (!frontend_builtin)
4923 gnu_actual = convert (DECL_ARG_TYPE (gnu_formal), gnu_actual);
4924 }
4925
4926 /* Then see if this is an unnamed parameter in a variadic C function. */
4927 else if (variadic)
4928 {
4929 /* This is based on the processing done in gnat_to_gnu_param, but
4930 we expect the mechanism to be set in (almost) all cases. */
4931 const Mechanism_Type mech = Mechanism (gnat_formal);
4932
4933 /* Strip off possible padding type. */
4934 if (TYPE_IS_PADDING_P (gnu_formal_type))
4935 gnu_formal_type = TREE_TYPE (TYPE_FIELDS (gnu_formal_type));
4936
4937 /* Arrays are passed as pointers to element type. First check for
4938 unconstrained array and get the underlying array. */
4939 if (TREE_CODE (gnu_formal_type) == UNCONSTRAINED_ARRAY_TYPE)
4940 gnu_formal_type
4941 = TREE_TYPE
4942 (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_formal_type))));
4943
4944 /* Arrays are passed as pointers to element type. */
4945 if (mech != By_Copy && TREE_CODE (gnu_formal_type) == ARRAY_TYPE)
4946 {
4947 gnu_actual = maybe_padded_object (gnu_actual);
4948 gnu_actual = maybe_unconstrained_array (gnu_actual);
4949
4950 /* Strip off any multi-dimensional entries, then strip
4951 off the last array to get the component type. */
4952 while (TREE_CODE (TREE_TYPE (gnu_formal_type)) == ARRAY_TYPE
4953 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_formal_type)))
4954 gnu_formal_type = TREE_TYPE (gnu_formal_type);
4955
4956 gnu_formal_type = TREE_TYPE (gnu_formal_type);
4957 gnu_formal_type = build_pointer_type (gnu_formal_type);
4958 gnu_actual
4959 = build_unary_op (ADDR_EXPR, gnu_formal_type, gnu_actual);
4960 }
4961
4962 /* Fat pointers are passed as thin pointers. */
4963 else if (TYPE_IS_FAT_POINTER_P (gnu_formal_type))
4964 gnu_formal_type
4965 = make_type_from_size (gnu_formal_type,
4966 size_int (POINTER_SIZE), 0);
4967
4968 /* If we were requested or muss pass by reference, do so.
4969 If we were requested to pass by copy, do so.
4970 Otherwise, pass In Out or Out parameters or aggregates by
4971 reference. */
4972 else if (mech == By_Reference
4973 || must_pass_by_ref (gnu_formal_type)
4974 || (mech != By_Copy
4975 && (!in_param || AGGREGATE_TYPE_P (gnu_formal_type))))
4976 {
4977 gnu_formal_type = build_reference_type (gnu_formal_type);
4978 gnu_actual
4979 = build_unary_op (ADDR_EXPR, gnu_formal_type, gnu_actual);
4980 }
4981
4982 /* Otherwise pass by copy after applying default C promotions. */
4983 else
4984 {
4985 if (INTEGRAL_TYPE_P (gnu_formal_type)
4986 && TYPE_PRECISION (gnu_formal_type)
4987 < TYPE_PRECISION (integer_type_node))
4988 gnu_formal_type = integer_type_node;
4989
4990 else if (SCALAR_FLOAT_TYPE_P (gnu_formal_type)
4991 && TYPE_PRECISION (gnu_formal_type)
4992 < TYPE_PRECISION (double_type_node))
4993 gnu_formal_type = double_type_node;
4994 }
4995
4996 gnu_actual = convert (gnu_formal_type, gnu_actual);
4997 }
4998
4999 /* If we didn't create a PARM_DECL for the formal, this means that
5000 it is an Out parameter not passed by reference and that need not
5001 be copied in. In this case, the value of the actual need not be
5002 read. However, we still need to make sure that its side-effects
5003 are evaluated before the call, so we evaluate its address. */
5004 else
5005 {
5006 if (!in_param)
5007 gnu_name_list = tree_cons (NULL_TREE, gnu_name, gnu_name_list);
5008
5009 if (TREE_SIDE_EFFECTS (gnu_name))
5010 {
5011 tree addr = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_name);
5012 append_to_statement_list (addr, &gnu_stmt_list);
5013 }
5014
5015 continue;
5016 }
5017
5018 gnu_actual_vec.safe_push (gnu_actual);
5019 }
5020
5021 if (frontend_builtin)
5022 {
5023 tree pred_cst = build_int_cst (integer_type_node, PRED_BUILTIN_EXPECT);
5024 enum internal_fn icode = IFN_BUILTIN_EXPECT;
5025
5026 switch (DECL_FE_FUNCTION_CODE (gnu_subprog))
5027 {
5028 case BUILT_IN_EXPECT:
5029 break;
5030 case BUILT_IN_LIKELY:
5031 gnu_actual_vec.safe_push (boolean_true_node);
5032 break;
5033 case BUILT_IN_UNLIKELY:
5034 gnu_actual_vec.safe_push (boolean_false_node);
5035 break;
5036 default:
5037 gcc_unreachable ();
5038 }
5039
5040 gnu_actual_vec.safe_push (pred_cst);
5041
5042 gnu_call
5043 = build_call_expr_internal_loc_array (UNKNOWN_LOCATION,
5044 icode,
5045 gnu_result_type,
5046 gnu_actual_vec.length (),
5047 gnu_actual_vec.begin ());
5048 }
5049 else
5050 {
5051 gnu_call
5052 = build_call_array_loc (UNKNOWN_LOCATION,
5053 gnu_result_type,
5054 build_unary_op (ADDR_EXPR, NULL_TREE,
5055 gnu_subprog),
5056 gnu_actual_vec.length (),
5057 gnu_actual_vec.begin ());
5058 CALL_EXPR_BY_DESCRIPTOR (gnu_call) = by_descriptor;
5059 }
5060
5061 set_expr_location_from_node (gnu_call, gnat_node);
5062
5063 /* If we have created a temporary for the return value, initialize it. */
5064 if (gnu_retval)
5065 {
5066 tree gnu_stmt
5067 = build_binary_op (INIT_EXPR, NULL_TREE, gnu_retval, gnu_call);
5068 set_expr_location_from_node (gnu_stmt, gnat_node);
5069 append_to_statement_list (gnu_stmt, &gnu_stmt_list);
5070 gnu_call = gnu_retval;
5071 }
5072
5073 /* If this is a subprogram with copy-in/copy-out parameters, we need to
5074 unpack the valued returned from the function into the In Out or Out
5075 parameters. We deal with the function return (if this is an Ada
5076 function) below. */
5077 if (TYPE_CI_CO_LIST (gnu_subprog_type))
5078 {
5079 /* List of FIELD_DECLs associated with the PARM_DECLs of the copy-in/
5080 copy-out parameters. */
5081 tree gnu_cico_list = TYPE_CI_CO_LIST (gnu_subprog_type);
5082 const int length = list_length (gnu_cico_list);
5083
5084 /* The call sequence must contain one and only one call, even though the
5085 function is pure. Save the result into a temporary if needed. */
5086 if (length > 1)
5087 {
5088 if (!gnu_retval)
5089 {
5090 tree gnu_stmt;
5091 gnu_call
5092 = create_init_temporary ("P", gnu_call, &gnu_stmt, gnat_node);
5093 append_to_statement_list (gnu_stmt, &gnu_stmt_list);
5094 }
5095
5096 gnu_name_list = nreverse (gnu_name_list);
5097 }
5098
5099 /* The first entry is for the actual return value if this is a
5100 function, so skip it. */
5101 if (function_call)
5102 gnu_cico_list = TREE_CHAIN (gnu_cico_list);
5103
5104 if (Nkind (gnat_subprog) == N_Explicit_Dereference)
5105 gnat_formal = First_Formal_With_Extras (Etype (gnat_subprog));
5106 else
5107 gnat_formal = First_Formal_With_Extras (Entity (gnat_subprog));
5108
5109 for (gnat_actual = First_Actual (gnat_node);
5110 Present (gnat_actual);
5111 gnat_formal = Next_Formal_With_Extras (gnat_formal),
5112 gnat_actual = Next_Actual (gnat_actual))
5113 /* If we are dealing with a copy-in/copy-out parameter, we must
5114 retrieve its value from the record returned in the call. */
5115 if (!(present_gnu_tree (gnat_formal)
5116 && TREE_CODE (get_gnu_tree (gnat_formal)) == PARM_DECL
5117 && (DECL_BY_REF_P (get_gnu_tree (gnat_formal))
5118 || DECL_BY_COMPONENT_PTR_P (get_gnu_tree (gnat_formal))))
5119 && Ekind (gnat_formal) != E_In_Parameter)
5120 {
5121 /* Get the value to assign to this In Out or Out parameter. It is
5122 either the result of the function if there is only a single such
5123 parameter or the appropriate field from the record returned. */
5124 tree gnu_result
5125 = length == 1
5126 ? gnu_call
5127 : build_component_ref (gnu_call, TREE_PURPOSE (gnu_cico_list),
5128 false);
5129
5130 /* If the actual is a conversion, get the inner expression, which
5131 will be the real destination, and convert the result to the
5132 type of the actual parameter. */
5133 tree gnu_actual
5134 = maybe_unconstrained_array (TREE_VALUE (gnu_name_list));
5135
5136 /* If the result is padded, remove the padding. */
5137 gnu_result = maybe_padded_object (gnu_result);
5138
5139 /* If the actual is a type conversion, the real target object is
5140 denoted by the inner Expression and we need to convert the
5141 result to the associated type.
5142 We also need to convert our gnu assignment target to this type
5143 if the corresponding GNU_NAME was constructed from the GNAT
5144 conversion node and not from the inner Expression. */
5145 if (Nkind (gnat_actual) == N_Type_Conversion)
5146 {
5147 const Node_Id gnat_expr = Expression (gnat_actual);
5148
5149 gigi_checking_assert (!Do_Range_Check (gnat_expr));
5150
5151 gnu_result
5152 = convert_with_check (Etype (gnat_expr), gnu_result,
5153 Do_Overflow_Check (gnat_actual),
5154 Float_Truncate (gnat_actual),
5155 gnat_actual);
5156
5157 if (!Is_Composite_Type (Underlying_Type (Etype (gnat_formal))))
5158 gnu_actual = convert (TREE_TYPE (gnu_result), gnu_actual);
5159 }
5160
5161 /* Unchecked conversions as actuals for Out parameters are not
5162 allowed in user code because they are not variables, but do
5163 occur in front-end expansions. The associated GNU_NAME is
5164 always obtained from the inner expression in such cases. */
5165 else if (Nkind (gnat_actual) == N_Unchecked_Type_Conversion)
5166 gnu_result = unchecked_convert (TREE_TYPE (gnu_actual),
5167 gnu_result,
5168 No_Truncation (gnat_actual));
5169 else
5170 {
5171 gigi_checking_assert (!Do_Range_Check (gnat_actual));
5172
5173 if (!(!TREE_CONSTANT (TYPE_SIZE (TREE_TYPE (gnu_actual)))
5174 && TREE_CONSTANT (TYPE_SIZE (TREE_TYPE (gnu_result)))))
5175 gnu_result = convert (TREE_TYPE (gnu_actual), gnu_result);
5176 }
5177
5178 get_atomic_access (gnat_actual, &aa_type, &aa_sync);
5179
5180 /* If an outer atomic access is required for an actual parameter,
5181 build the load-modify-store sequence. */
5182 if (aa_type == OUTER_ATOMIC)
5183 gnu_result
5184 = build_load_modify_store (gnu_actual, gnu_result, gnat_node);
5185
5186 /* Or else, if a simple atomic access is required, build the atomic
5187 store. */
5188 else if (aa_type == SIMPLE_ATOMIC)
5189 gnu_result
5190 = build_atomic_store (gnu_actual, gnu_result, aa_sync);
5191
5192 /* Otherwise build a regular assignment. */
5193 else
5194 gnu_result = build_binary_op (MODIFY_EXPR, NULL_TREE,
5195 gnu_actual, gnu_result);
5196
5197 if (EXPR_P (gnu_result))
5198 set_expr_location_from_node (gnu_result, gnat_node);
5199 append_to_statement_list (gnu_result, &gnu_stmt_list);
5200 gnu_cico_list = TREE_CHAIN (gnu_cico_list);
5201 gnu_name_list = TREE_CHAIN (gnu_name_list);
5202 }
5203 }
5204
5205 /* If this is a function call, the result is the call expression unless a
5206 target is specified, in which case we copy the result into the target
5207 and return the assignment statement. */
5208 if (function_call)
5209 {
5210 /* If this is a function with copy-in/copy-out parameters, extract the
5211 return value from it and update the return type. */
5212 if (TYPE_CI_CO_LIST (gnu_subprog_type))
5213 {
5214 tree gnu_elmt = TYPE_CI_CO_LIST (gnu_subprog_type);
5215 gnu_call
5216 = build_component_ref (gnu_call, TREE_PURPOSE (gnu_elmt), false);
5217 gnu_result_type = TREE_TYPE (gnu_call);
5218 }
5219
5220 /* If the function returns an unconstrained array or by direct reference,
5221 we have to dereference the pointer. */
5222 if (TYPE_RETURN_UNCONSTRAINED_P (gnu_subprog_type)
5223 || TYPE_RETURN_BY_DIRECT_REF_P (gnu_subprog_type))
5224 gnu_call = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_call);
5225
5226 if (gnu_target)
5227 {
5228 Node_Id gnat_parent = Parent (gnat_node);
5229 enum tree_code op_code;
5230
5231 gigi_checking_assert (!Do_Range_Check (gnat_node));
5232
5233 /* ??? If the return type has variable size, then force the return
5234 slot optimization as we would not be able to create a temporary.
5235 That's what has been done historically. */
5236 if (return_type_with_variable_size_p (gnu_result_type))
5237 op_code = INIT_EXPR;
5238
5239 /* If this is a call to a pure function returning an array of scalar
5240 type, try to apply the return slot optimization. */
5241 else if ((TYPE_READONLY (gnu_subprog_type)
5242 || TYPE_RESTRICT (gnu_subprog_type))
5243 && is_array_of_scalar_type (gnu_result_type)
5244 && TYPE_MODE (gnu_result_type) == BLKmode
5245 && aggregate_value_p (gnu_result_type, gnu_subprog_type)
5246 && return_slot_opt_for_pure_call_p (gnu_target, gnu_call))
5247 op_code = INIT_EXPR;
5248
5249 else
5250 op_code = MODIFY_EXPR;
5251
5252 /* Use the required method to move the result to the target. */
5253 if (atomic_access == OUTER_ATOMIC)
5254 gnu_call
5255 = build_load_modify_store (gnu_target, gnu_call, gnat_node);
5256 else if (atomic_access == SIMPLE_ATOMIC)
5257 gnu_call = build_atomic_store (gnu_target, gnu_call, atomic_sync);
5258 else
5259 gnu_call
5260 = build_binary_op (op_code, NULL_TREE, gnu_target, gnu_call);
5261
5262 if (EXPR_P (gnu_call))
5263 set_expr_location_from_node (gnu_call, gnat_parent);
5264 append_to_statement_list (gnu_call, &gnu_stmt_list);
5265 }
5266 else
5267 *gnu_result_type_p = get_unpadded_type (Etype (gnat_node));
5268 }
5269
5270 /* Otherwise, if this is a procedure call statement without copy-in/copy-out
5271 parameters, the result is just the call statement. */
5272 else if (!TYPE_CI_CO_LIST (gnu_subprog_type))
5273 append_to_statement_list (gnu_call, &gnu_stmt_list);
5274
5275 /* Finally, add the copy back statements, if any. */
5276 append_to_statement_list (gnu_after_list, &gnu_stmt_list);
5277
5278 if (went_into_elab_proc)
5279 current_function_decl = NULL_TREE;
5280
5281 /* If we have pushed a binding level, pop it and finish up the enclosing
5282 statement group. */
5283 if (pushed_binding_level)
5284 {
5285 add_stmt (gnu_stmt_list);
5286 gnat_poplevel ();
5287 gnu_result = end_stmt_group ();
5288 }
5289
5290 /* Otherwise, retrieve the statement list, if any. */
5291 else if (gnu_stmt_list)
5292 gnu_result = gnu_stmt_list;
5293
5294 /* Otherwise, just return the call expression. */
5295 else
5296 return gnu_call;
5297
5298 /* If we nevertheless need a value, make a COMPOUND_EXPR to return it.
5299 But first simplify if we have only one statement in the list. */
5300 if (returning_value)
5301 {
5302 tree first = expr_first (gnu_result), last = expr_last (gnu_result);
5303 if (first == last)
5304 gnu_result = first;
5305 gnu_result
5306 = build_compound_expr (TREE_TYPE (gnu_call), gnu_result, gnu_call);
5307 }
5308
5309 return gnu_result;
5310 }
5311
5312 /* Subroutine of gnat_to_gnu to translate gnat_node, an
5313 N_Handled_Sequence_Of_Statements, to a GCC tree, which is returned. */
5314
5315 static tree
Handled_Sequence_Of_Statements_to_gnu(Node_Id gnat_node)5316 Handled_Sequence_Of_Statements_to_gnu (Node_Id gnat_node)
5317 {
5318 /* If just annotating, ignore all EH and cleanups. */
5319 const bool gcc_eh
5320 = (!type_annotate_only
5321 && Present (Exception_Handlers (gnat_node))
5322 && Back_End_Exceptions ());
5323 const bool fe_sjlj_eh
5324 = (!type_annotate_only
5325 && Present (Exception_Handlers (gnat_node))
5326 && Exception_Mechanism == Front_End_SJLJ);
5327 const bool at_end = !type_annotate_only && Present (At_End_Proc (gnat_node));
5328 const bool binding_for_block = (at_end || gcc_eh || fe_sjlj_eh);
5329 tree gnu_jmpsave_decl = NULL_TREE;
5330 tree gnu_jmpbuf_decl = NULL_TREE;
5331 tree gnu_inner_block; /* The statement(s) for the block itself. */
5332 tree gnu_result;
5333 tree gnu_expr;
5334 Node_Id gnat_temp;
5335
5336 /* The GCC exception handling mechanism can handle both ZCX and SJLJ schemes
5337 and the front-end has its own SJLJ mechanism. To call the GCC mechanism,
5338 we call add_cleanup, and when we leave the binding, end_stmt_group will
5339 create the TRY_FINALLY_EXPR construct.
5340
5341 ??? The region level calls down there have been specifically put in place
5342 for a ZCX context and currently the order in which things are emitted
5343 (region/handlers) is different from the SJLJ case. Instead of putting
5344 other calls with different conditions at other places for the SJLJ case,
5345 it seems cleaner to reorder things for the SJLJ case and generalize the
5346 condition to make it not ZCX specific.
5347
5348 If there are any exceptions or cleanup processing involved, we need an
5349 outer statement group (for front-end SJLJ) and binding level. */
5350 if (binding_for_block)
5351 {
5352 start_stmt_group ();
5353 gnat_pushlevel ();
5354 }
5355
5356 /* If using fe_sjlj_eh, make the variables for the setjmp buffer and save
5357 area for address of previous buffer. Do this first since we need to have
5358 the setjmp buf known for any decls in this block. */
5359 if (fe_sjlj_eh)
5360 {
5361 gnu_jmpsave_decl
5362 = create_var_decl (get_identifier ("JMPBUF_SAVE"), NULL_TREE,
5363 jmpbuf_ptr_type,
5364 build_call_n_expr (get_jmpbuf_decl, 0),
5365 false, false, false, false, false, true, false,
5366 NULL, gnat_node);
5367
5368 /* The __builtin_setjmp receivers will immediately reinstall it. Now
5369 because of the unstructured form of EH used by fe_sjlj_eh, there
5370 might be forward edges going to __builtin_setjmp receivers on which
5371 it is uninitialized, although they will never be actually taken. */
5372 suppress_warning (gnu_jmpsave_decl, OPT_Wuninitialized);
5373 gnu_jmpbuf_decl
5374 = create_var_decl (get_identifier ("JMP_BUF"), NULL_TREE,
5375 jmpbuf_type,
5376 NULL_TREE,
5377 false, false, false, false, false, true, false,
5378 NULL, gnat_node);
5379
5380 set_block_jmpbuf_decl (gnu_jmpbuf_decl);
5381
5382 /* When we exit this block, restore the saved value. */
5383 add_cleanup (build_call_n_expr (set_jmpbuf_decl, 1, gnu_jmpsave_decl),
5384 Present (End_Label (gnat_node))
5385 ? End_Label (gnat_node) : gnat_node);
5386 }
5387
5388 /* If we are to call a function when exiting this block, add a cleanup
5389 to the binding level we made above. Note that add_cleanup is FIFO
5390 so we must register this cleanup after the EH cleanup just above. */
5391 if (at_end)
5392 {
5393 tree proc_decl = gnat_to_gnu (At_End_Proc (gnat_node));
5394
5395 /* When not optimizing, disable inlining of finalizers as this can
5396 create a more complex CFG in the parent function. */
5397 if (!optimize || optimize_debug)
5398 DECL_DECLARED_INLINE_P (proc_decl) = 0;
5399
5400 /* If there is no end label attached, we use the location of the At_End
5401 procedure because Expand_Cleanup_Actions might reset the location of
5402 the enclosing construct to that of an inner statement. */
5403 add_cleanup (build_call_n_expr (proc_decl, 0),
5404 Present (End_Label (gnat_node))
5405 ? End_Label (gnat_node) : At_End_Proc (gnat_node));
5406 }
5407
5408 /* Now build the tree for the declarations and statements inside this block.
5409 If this is SJLJ, set our jmp_buf as the current buffer. */
5410 start_stmt_group ();
5411
5412 if (fe_sjlj_eh)
5413 {
5414 gnu_expr = build_call_n_expr (set_jmpbuf_decl, 1,
5415 build_unary_op (ADDR_EXPR, NULL_TREE,
5416 gnu_jmpbuf_decl));
5417 set_expr_location_from_node (gnu_expr, gnat_node);
5418 add_stmt (gnu_expr);
5419 }
5420
5421 if (Present (First_Real_Statement (gnat_node)))
5422 process_decls (Statements (gnat_node), Empty,
5423 First_Real_Statement (gnat_node), true, true);
5424
5425 /* Generate code for each statement in the block. */
5426 for (gnat_temp = (Present (First_Real_Statement (gnat_node))
5427 ? First_Real_Statement (gnat_node)
5428 : First (Statements (gnat_node)));
5429 Present (gnat_temp); gnat_temp = Next (gnat_temp))
5430 add_stmt (gnat_to_gnu (gnat_temp));
5431
5432 gnu_inner_block = end_stmt_group ();
5433
5434 /* Now generate code for the two exception models, if either is relevant for
5435 this block. */
5436 if (fe_sjlj_eh)
5437 {
5438 tree *gnu_else_ptr = 0;
5439 tree gnu_handler;
5440
5441 /* Make a binding level for the exception handling declarations and code
5442 and set up gnu_except_ptr_stack for the handlers to use. */
5443 start_stmt_group ();
5444 gnat_pushlevel ();
5445
5446 vec_safe_push (gnu_except_ptr_stack,
5447 create_var_decl (get_identifier ("EXCEPT_PTR"), NULL_TREE,
5448 build_pointer_type (except_type_node),
5449 build_call_n_expr (get_excptr_decl, 0),
5450 false, false, false, false, false,
5451 true, false, NULL, gnat_node));
5452
5453 /* Generate code for each handler. The N_Exception_Handler case does the
5454 real work and returns a COND_EXPR for each handler, which we chain
5455 together here. */
5456 for (gnat_temp = First_Non_Pragma (Exception_Handlers (gnat_node));
5457 Present (gnat_temp); gnat_temp = Next_Non_Pragma (gnat_temp))
5458 {
5459 gnu_expr = gnat_to_gnu (gnat_temp);
5460
5461 /* If this is the first one, set it as the outer one. Otherwise,
5462 point the "else" part of the previous handler to us. Then point
5463 to our "else" part. */
5464 if (!gnu_else_ptr)
5465 add_stmt (gnu_expr);
5466 else
5467 *gnu_else_ptr = gnu_expr;
5468
5469 gnu_else_ptr = &COND_EXPR_ELSE (gnu_expr);
5470 }
5471
5472 /* If none of the exception handlers did anything, re-raise but do not
5473 defer abortion. */
5474 gnu_expr = build_call_n_expr (raise_nodefer_decl, 1,
5475 gnu_except_ptr_stack->last ());
5476 set_expr_location_from_node
5477 (gnu_expr,
5478 Present (End_Label (gnat_node)) ? End_Label (gnat_node) : gnat_node);
5479
5480 if (gnu_else_ptr)
5481 *gnu_else_ptr = gnu_expr;
5482 else
5483 add_stmt (gnu_expr);
5484
5485 /* End the binding level dedicated to the exception handlers and get the
5486 whole statement group. */
5487 gnu_except_ptr_stack->pop ();
5488 gnat_poplevel ();
5489 gnu_handler = end_stmt_group ();
5490
5491 /* If the setjmp returns 1, we restore our incoming longjmp value and
5492 then check the handlers. */
5493 start_stmt_group ();
5494 add_stmt_with_node (build_call_n_expr (set_jmpbuf_decl, 1,
5495 gnu_jmpsave_decl),
5496 gnat_node);
5497 add_stmt (gnu_handler);
5498 gnu_handler = end_stmt_group ();
5499
5500 /* This block is now "if (setjmp) ... <handlers> else <block>". */
5501 gnu_result = build3 (COND_EXPR, void_type_node,
5502 (build_call_n_expr
5503 (setjmp_decl, 1,
5504 build_unary_op (ADDR_EXPR, NULL_TREE,
5505 gnu_jmpbuf_decl))),
5506 gnu_handler, gnu_inner_block);
5507 }
5508 else if (gcc_eh)
5509 {
5510 tree gnu_handlers;
5511 location_t locus;
5512
5513 /* First make a block containing the handlers. */
5514 start_stmt_group ();
5515 for (gnat_temp = First_Non_Pragma (Exception_Handlers (gnat_node));
5516 Present (gnat_temp);
5517 gnat_temp = Next_Non_Pragma (gnat_temp))
5518 add_stmt (gnat_to_gnu (gnat_temp));
5519 gnu_handlers = end_stmt_group ();
5520
5521 /* Now make the TRY_CATCH_EXPR for the block. */
5522 gnu_result = build2 (TRY_CATCH_EXPR, void_type_node,
5523 gnu_inner_block, gnu_handlers);
5524 /* Set a location. We need to find a unique location for the dispatching
5525 code, otherwise we can get coverage or debugging issues. Try with
5526 the location of the end label. */
5527 if (Present (End_Label (gnat_node))
5528 && Sloc_to_locus (Sloc (End_Label (gnat_node)), &locus))
5529 SET_EXPR_LOCATION (gnu_result, locus);
5530 else
5531 /* Clear column information so that the exception handler of an
5532 implicit transient block does not incorrectly inherit the slocs
5533 of a decision, which would otherwise confuse control flow based
5534 coverage analysis tools. */
5535 set_expr_location_from_node (gnu_result, gnat_node, true);
5536 }
5537 else
5538 gnu_result = gnu_inner_block;
5539
5540 /* Now close our outer block, if we had to make one. */
5541 if (binding_for_block)
5542 {
5543 add_stmt (gnu_result);
5544 gnat_poplevel ();
5545 gnu_result = end_stmt_group ();
5546 }
5547
5548 return gnu_result;
5549 }
5550
5551 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Exception_Handler,
5552 to a GCC tree, which is returned. This is the variant for front-end sjlj
5553 exception handling. */
5554
5555 static tree
Exception_Handler_to_gnu_fe_sjlj(Node_Id gnat_node)5556 Exception_Handler_to_gnu_fe_sjlj (Node_Id gnat_node)
5557 {
5558 /* Unless this is "Others" or the special "Non-Ada" exception for Ada, make
5559 an "if" statement to select the proper exceptions. For "Others", exclude
5560 exceptions where Handled_By_Others is nonzero unless the All_Others flag
5561 is set. For "Non-ada", accept an exception if "Lang" is 'V'. */
5562 tree gnu_choice = boolean_false_node;
5563 tree gnu_body = build_stmt_group (Statements (gnat_node), false);
5564 Node_Id gnat_temp;
5565
5566 for (gnat_temp = First (Exception_Choices (gnat_node));
5567 gnat_temp; gnat_temp = Next (gnat_temp))
5568 {
5569 tree this_choice;
5570
5571 if (Nkind (gnat_temp) == N_Others_Choice)
5572 {
5573 if (All_Others (gnat_temp))
5574 this_choice = boolean_true_node;
5575 else
5576 this_choice
5577 = build_binary_op
5578 (EQ_EXPR, boolean_type_node,
5579 convert
5580 (integer_type_node,
5581 build_component_ref
5582 (build_unary_op
5583 (INDIRECT_REF, NULL_TREE,
5584 gnu_except_ptr_stack->last ()),
5585 not_handled_by_others_decl,
5586 false)),
5587 integer_zero_node);
5588 }
5589
5590 else if (Nkind (gnat_temp) == N_Identifier
5591 || Nkind (gnat_temp) == N_Expanded_Name)
5592 {
5593 Entity_Id gnat_ex_id = Entity (gnat_temp);
5594 tree gnu_expr;
5595
5596 /* Exception may be a renaming. Recover original exception which is
5597 the one elaborated and registered. */
5598 if (Present (Renamed_Object (gnat_ex_id)))
5599 gnat_ex_id = Renamed_Object (gnat_ex_id);
5600
5601 gnu_expr = gnat_to_gnu_entity (gnat_ex_id, NULL_TREE, false);
5602
5603 this_choice
5604 = build_binary_op
5605 (EQ_EXPR, boolean_type_node,
5606 gnu_except_ptr_stack->last (),
5607 convert (TREE_TYPE (gnu_except_ptr_stack->last ()),
5608 build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr)));
5609 }
5610 else
5611 gcc_unreachable ();
5612
5613 gnu_choice = build_binary_op (TRUTH_ORIF_EXPR, boolean_type_node,
5614 gnu_choice, this_choice);
5615 }
5616
5617 return build3 (COND_EXPR, void_type_node, gnu_choice, gnu_body, NULL_TREE);
5618 }
5619
5620 /* Return true if no statement in GNAT_LIST can alter the control flow. */
5621
5622 static bool
stmt_list_cannot_alter_control_flow_p(List_Id gnat_list)5623 stmt_list_cannot_alter_control_flow_p (List_Id gnat_list)
5624 {
5625 if (No (gnat_list))
5626 return true;
5627
5628 /* This is very conservative, we reject everything except for simple
5629 assignments between identifiers or literals. */
5630 for (Node_Id gnat_node = First (gnat_list);
5631 Present (gnat_node);
5632 gnat_node = Next (gnat_node))
5633 {
5634 if (Nkind (gnat_node) != N_Assignment_Statement)
5635 return false;
5636
5637 if (Nkind (Name (gnat_node)) != N_Identifier)
5638 return false;
5639
5640 Node_Kind nkind = Nkind (Expression (gnat_node));
5641 if (nkind != N_Identifier
5642 && nkind != N_Integer_Literal
5643 && nkind != N_Real_Literal)
5644 return false;
5645 }
5646
5647 return true;
5648 }
5649
5650 /* Subroutine of gnat_to_gnu to translate gnat_node, an N_Exception_Handler,
5651 to a GCC tree, which is returned. This is the variant for GCC exception
5652 schemes. */
5653
5654 static tree
Exception_Handler_to_gnu_gcc(Node_Id gnat_node)5655 Exception_Handler_to_gnu_gcc (Node_Id gnat_node)
5656 {
5657 tree gnu_etypes_list = NULL_TREE;
5658
5659 /* We build a TREE_LIST of nodes representing what exception types this
5660 handler can catch, with special cases for others and all others cases.
5661
5662 Each exception type is actually identified by a pointer to the exception
5663 id, or to a dummy object for "others" and "all others". */
5664 for (Node_Id gnat_temp = First (Exception_Choices (gnat_node));
5665 gnat_temp;
5666 gnat_temp = Next (gnat_temp))
5667 {
5668 tree gnu_expr, gnu_etype;
5669
5670 if (Nkind (gnat_temp) == N_Others_Choice)
5671 {
5672 gnu_expr = All_Others (gnat_temp) ? all_others_decl : others_decl;
5673 gnu_etype = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr);
5674 }
5675 else if (Nkind (gnat_temp) == N_Identifier
5676 || Nkind (gnat_temp) == N_Expanded_Name)
5677 {
5678 Entity_Id gnat_ex_id = Entity (gnat_temp);
5679
5680 /* Exception may be a renaming. Recover original exception which is
5681 the one elaborated and registered. */
5682 if (Present (Renamed_Object (gnat_ex_id)))
5683 gnat_ex_id = Renamed_Object (gnat_ex_id);
5684
5685 gnu_expr = gnat_to_gnu_entity (gnat_ex_id, NULL_TREE, false);
5686 gnu_etype = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr);
5687 }
5688 else
5689 gcc_unreachable ();
5690
5691 /* The GCC interface expects NULL to be passed for catch all handlers, so
5692 it would be quite tempting to set gnu_etypes_list to NULL if gnu_etype
5693 is integer_zero_node. It would not work, however, because GCC's
5694 notion of "catch all" is stronger than our notion of "others". Until
5695 we correctly use the cleanup interface as well, doing that would
5696 prevent the "all others" handlers from being seen, because nothing
5697 can be caught beyond a catch all from GCC's point of view. */
5698 gnu_etypes_list = tree_cons (NULL_TREE, gnu_etype, gnu_etypes_list);
5699 }
5700
5701 start_stmt_group ();
5702 gnat_pushlevel ();
5703
5704 /* Expand a call to the begin_handler hook at the beginning of the
5705 handler, and arrange for a call to the end_handler hook to occur
5706 on every possible exit path. GDB sets a breakpoint in the
5707 begin_handler for catchpoints.
5708
5709 A v1 begin handler saves the cleanup from the exception object,
5710 and marks the exception as in use, so that it will not be
5711 released by other handlers. A v1 end handler restores the
5712 cleanup and releases the exception object, unless it is still
5713 claimed, or the exception is being propagated (reraised).
5714
5715 __builtin_eh_pointer references the exception occurrence being
5716 handled or propagated. Within the handler region, it is the
5717 former, but within the else branch of the EH_ELSE_EXPR, i.e. the
5718 exceptional cleanup path, it is the latter, so we must save the
5719 occurrence being handled early on, so that, should an exception
5720 be (re)raised, we can release the current exception, or figure
5721 out we're not to release it because we're propagating a reraise
5722 thereof.
5723
5724 We use local variables to retrieve the incoming value at handler
5725 entry time (EXPTR), the saved cleanup (EXCLN) and the token
5726 (EXVTK), and reuse them to feed the end_handler hook's argument
5727 at exit. */
5728
5729 /* CODE: void *EXPTR = __builtin_eh_pointer (0); */
5730 tree gnu_current_exc_ptr
5731 = build_call_expr (builtin_decl_explicit (BUILT_IN_EH_POINTER),
5732 1, integer_zero_node);
5733 tree exc_ptr
5734 = create_var_decl (get_identifier ("EXPTR"), NULL_TREE,
5735 ptr_type_node, gnu_current_exc_ptr,
5736 true, false, false, false, false, true, true,
5737 NULL, gnat_node);
5738
5739 tree prev_gnu_incoming_exc_ptr = gnu_incoming_exc_ptr;
5740 gnu_incoming_exc_ptr = exc_ptr;
5741
5742 /* begin_handler_decl must not throw, so we can use it as an
5743 initializer for a variable used in cleanups.
5744
5745 CODE: void *EXCLN = __gnat_begin_handler_v1 (EXPTR); */
5746 tree exc_cleanup
5747 = create_var_decl (get_identifier ("EXCLN"), NULL_TREE,
5748 ptr_type_node,
5749 build_call_n_expr (begin_handler_decl, 1,
5750 exc_ptr),
5751 true, false, false, false, false,
5752 true, true, NULL, gnat_node);
5753
5754 /* Declare and initialize the choice parameter, if present. */
5755 if (Present (Choice_Parameter (gnat_node)))
5756 {
5757 tree gnu_param
5758 = gnat_to_gnu_entity (Choice_Parameter (gnat_node), NULL_TREE, true);
5759
5760 /* CODE: __gnat_set_exception_parameter (&choice_param, EXPTR); */
5761 add_stmt (build_call_n_expr
5762 (set_exception_parameter_decl, 2,
5763 build_unary_op (ADDR_EXPR, NULL_TREE, gnu_param),
5764 gnu_incoming_exc_ptr));
5765 }
5766
5767 /* CODE: <handler proper> */
5768 add_stmt_list (Statements (gnat_node));
5769
5770 tree call = build_call_n_expr (end_handler_decl, 3,
5771 exc_ptr,
5772 exc_cleanup,
5773 null_pointer_node);
5774 /* If the handler can only end by falling off the end, don't bother
5775 with cleanups. */
5776 if (stmt_list_cannot_alter_control_flow_p (Statements (gnat_node)))
5777 /* CODE: __gnat_end_handler_v1 (EXPTR, EXCLN, NULL); */
5778 add_stmt_with_node (call, gnat_node);
5779 /* Otherwise, all of the above is after
5780 CODE: try {
5781
5782 The call above will appear after
5783 CODE: } finally {
5784
5785 And the code below will appear after
5786 CODE: } else {
5787
5788 The else block to a finally block is taken instead of the finally
5789 block when an exception propagates out of the try block. */
5790 else
5791 {
5792 start_stmt_group ();
5793 gnat_pushlevel ();
5794 /* CODE: void *EXPRP = __builtin_eh_handler (0); */
5795 tree prop_ptr
5796 = create_var_decl (get_identifier ("EXPRP"), NULL_TREE,
5797 ptr_type_node,
5798 build_call_expr (builtin_decl_explicit
5799 (BUILT_IN_EH_POINTER),
5800 1, integer_zero_node),
5801 true, false, false, false, false,
5802 true, true, NULL, gnat_node);
5803
5804 /* CODE: __gnat_end_handler_v1 (EXPTR, EXCLN, EXPRP); */
5805 tree ecall = build_call_n_expr (end_handler_decl, 3,
5806 exc_ptr,
5807 exc_cleanup,
5808 prop_ptr);
5809
5810 add_stmt_with_node (ecall, gnat_node);
5811
5812 /* CODE: } */
5813 gnat_poplevel ();
5814 tree eblk = end_stmt_group ();
5815 tree ehls = build2 (EH_ELSE_EXPR, void_type_node, call, eblk);
5816 add_cleanup (ehls, gnat_node);
5817 }
5818
5819 gnat_poplevel ();
5820
5821 gnu_incoming_exc_ptr = prev_gnu_incoming_exc_ptr;
5822
5823 return
5824 build2 (CATCH_EXPR, void_type_node, gnu_etypes_list, end_stmt_group ());
5825 }
5826
5827 /* Subroutine of gnat_to_gnu to generate code for an N_Compilation unit. */
5828
5829 static void
Compilation_Unit_to_gnu(Node_Id gnat_node)5830 Compilation_Unit_to_gnu (Node_Id gnat_node)
5831 {
5832 const Node_Id gnat_unit = Unit (gnat_node);
5833 const bool body_p = (Nkind (gnat_unit) == N_Package_Body
5834 || Nkind (gnat_unit) == N_Subprogram_Body);
5835 const Entity_Id gnat_unit_entity = Defining_Entity (gnat_unit);
5836 Entity_Id gnat_entity;
5837 Node_Id gnat_pragma, gnat_iter;
5838 /* Make the decl for the elaboration procedure. Emit debug info for it, so
5839 that users can break into their elaboration code in debuggers. Kludge:
5840 don't consider it as a definition so that we have a line map for its
5841 body, but no subprogram description in debug info. In addition, don't
5842 qualify it as artificial, even though it is not a user subprogram per se,
5843 in particular for specs. Unlike, say, clones created internally by the
5844 compiler, this subprogram materializes specific user code and flagging it
5845 artificial would take elab code away from gcov's analysis. */
5846 tree gnu_elab_proc_decl
5847 = create_subprog_decl
5848 (create_concat_name (gnat_unit_entity, body_p ? "elabb" : "elabs"),
5849 NULL_TREE, void_ftype, NULL_TREE,
5850 is_default, true, false, false, true, false, NULL, gnat_unit);
5851 struct elab_info *info;
5852
5853 vec_safe_push (gnu_elab_proc_stack, gnu_elab_proc_decl);
5854 DECL_ELABORATION_PROC_P (gnu_elab_proc_decl) = 1;
5855
5856 /* Initialize the information structure for the function. */
5857 allocate_struct_function (gnu_elab_proc_decl, false);
5858 set_cfun (NULL);
5859
5860 current_function_decl = NULL_TREE;
5861
5862 start_stmt_group ();
5863 gnat_pushlevel ();
5864
5865 /* For a body, first process the spec if there is one. */
5866 if (Nkind (gnat_unit) == N_Package_Body
5867 || (Nkind (gnat_unit) == N_Subprogram_Body && !Acts_As_Spec (gnat_node)))
5868 add_stmt (gnat_to_gnu (Library_Unit (gnat_node)));
5869
5870 if (type_annotate_only && gnat_node == Cunit (Main_Unit))
5871 {
5872 elaborate_all_entities (gnat_node);
5873
5874 if (Nkind (gnat_unit) == N_Subprogram_Declaration
5875 || Nkind (gnat_unit) == N_Generic_Package_Declaration
5876 || Nkind (gnat_unit) == N_Generic_Subprogram_Declaration)
5877 return;
5878 }
5879
5880 /* Then process any pragmas and declarations preceding the unit. */
5881 for (gnat_pragma = First (Context_Items (gnat_node));
5882 Present (gnat_pragma);
5883 gnat_pragma = Next (gnat_pragma))
5884 if (Nkind (gnat_pragma) == N_Pragma)
5885 add_stmt (gnat_to_gnu (gnat_pragma));
5886 process_decls (Declarations (Aux_Decls_Node (gnat_node)), Empty, Empty,
5887 true, true);
5888
5889 /* Process the unit itself. */
5890 add_stmt (gnat_to_gnu (gnat_unit));
5891
5892 /* Generate code for all the inlined subprograms. */
5893 for (gnat_entity = First_Inlined_Subprogram (gnat_node);
5894 Present (gnat_entity);
5895 gnat_entity = Next_Inlined_Subprogram (gnat_entity))
5896 {
5897 Node_Id gnat_body;
5898
5899 /* Without optimization, process only the required subprograms. */
5900 if (!optimize && !Has_Pragma_Inline_Always (gnat_entity))
5901 continue;
5902
5903 /* The set of inlined subprograms is computed from data recorded early
5904 during expansion and it can be a strict superset of the final set
5905 computed after semantic analysis, for example if a call to such a
5906 subprogram occurs in a pragma Assert and assertions are disabled.
5907 In that case, semantic analysis resets Is_Public to false but the
5908 entry for the subprogram in the inlining tables is stalled. */
5909 if (!Is_Public (gnat_entity))
5910 continue;
5911
5912 gnat_body = Parent (Declaration_Node (gnat_entity));
5913 if (Nkind (gnat_body) != N_Subprogram_Body)
5914 {
5915 /* ??? This happens when only the spec of a package is provided. */
5916 if (No (Corresponding_Body (gnat_body)))
5917 continue;
5918
5919 gnat_body
5920 = Parent (Declaration_Node (Corresponding_Body (gnat_body)));
5921 }
5922
5923 /* Define the entity first so we set DECL_EXTERNAL. */
5924 gnat_to_gnu_entity (gnat_entity, NULL_TREE, false);
5925 add_stmt (gnat_to_gnu (gnat_body));
5926 }
5927
5928 /* Process any pragmas and actions following the unit. */
5929 add_stmt_list (Pragmas_After (Aux_Decls_Node (gnat_node)));
5930 add_stmt_list (Actions (Aux_Decls_Node (gnat_node)));
5931 finalize_from_limited_with ();
5932
5933 /* Then process the expressions of pragma Compile_Time_{Error|Warning} to
5934 annotate types referenced therein if they have not been annotated. */
5935 for (int i = 0; gnat_compile_time_expr_list.iterate (i, &gnat_iter); i++)
5936 (void) gnat_to_gnu_external (gnat_iter);
5937 gnat_compile_time_expr_list.release ();
5938
5939 /* Save away what we've made so far and finish it up. */
5940 set_current_block_context (gnu_elab_proc_decl);
5941 gnat_poplevel ();
5942 DECL_SAVED_TREE (gnu_elab_proc_decl) = end_stmt_group ();
5943 set_end_locus_from_node (gnu_elab_proc_decl, gnat_unit);
5944 gnu_elab_proc_stack->pop ();
5945
5946 /* Record this potential elaboration procedure for later processing. */
5947 info = ggc_alloc<elab_info> ();
5948 info->next = elab_info_list;
5949 info->elab_proc = gnu_elab_proc_decl;
5950 info->gnat_node = gnat_node;
5951 elab_info_list = info;
5952
5953 /* Force the processing for all nodes that remain in the queue. */
5954 process_deferred_decl_context (true);
5955 }
5956
5957 /* Mark COND, a boolean expression, as predicating a call to a noreturn
5958 function, i.e. predict that it is very likely false, and return it.
5959
5960 The compiler will automatically predict the last edge leading to a call
5961 to a noreturn function as very unlikely taken. This function makes it
5962 possible to extend the prediction to predecessors in case the condition
5963 is made up of several short-circuit operators. */
5964
5965 static tree
build_noreturn_cond(tree cond)5966 build_noreturn_cond (tree cond)
5967 {
5968 tree pred_cst = build_int_cst (integer_type_node, PRED_NORETURN);
5969 return
5970 build_call_expr_internal_loc (UNKNOWN_LOCATION, IFN_BUILTIN_EXPECT,
5971 boolean_type_node, 3, cond,
5972 boolean_false_node, pred_cst);
5973 }
5974
5975 /* Subroutine of gnat_to_gnu to translate GNAT_RANGE, a node representing a
5976 range of values, into GNU_LOW and GNU_HIGH bounds. */
5977
5978 static void
Range_to_gnu(Node_Id gnat_range,tree * gnu_low,tree * gnu_high)5979 Range_to_gnu (Node_Id gnat_range, tree *gnu_low, tree *gnu_high)
5980 {
5981 /* GNAT_RANGE is either an N_Range or an identifier denoting a subtype. */
5982 switch (Nkind (gnat_range))
5983 {
5984 case N_Range:
5985 *gnu_low = gnat_to_gnu (Low_Bound (gnat_range));
5986 *gnu_high = gnat_to_gnu (High_Bound (gnat_range));
5987 break;
5988
5989 case N_Expanded_Name:
5990 case N_Identifier:
5991 {
5992 tree gnu_range_type = get_unpadded_type (Entity (gnat_range));
5993 tree gnu_range_base_type = get_base_type (gnu_range_type);
5994
5995 *gnu_low
5996 = convert (gnu_range_base_type, TYPE_MIN_VALUE (gnu_range_type));
5997 *gnu_high
5998 = convert (gnu_range_base_type, TYPE_MAX_VALUE (gnu_range_type));
5999 }
6000 break;
6001
6002 default:
6003 gcc_unreachable ();
6004 }
6005 }
6006
6007 /* Subroutine of gnat_to_gnu to translate GNAT_NODE, an N_Raise_xxx_Error,
6008 to a GCC tree and return it. GNU_RESULT_TYPE_P is a pointer to where
6009 we should place the result type. */
6010
6011 static tree
Raise_Error_to_gnu(Node_Id gnat_node,tree * gnu_result_type_p)6012 Raise_Error_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p)
6013 {
6014 const Node_Kind kind = Nkind (gnat_node);
6015 const Node_Id gnat_cond = Condition (gnat_node);
6016 const int reason = UI_To_Int (Reason (gnat_node));
6017 const bool with_extra_info
6018 = Exception_Extra_Info
6019 && !No_Exception_Handlers_Set ()
6020 && No (get_exception_label (kind));
6021 tree gnu_result = NULL_TREE, gnu_cond = NULL_TREE;
6022 Node_Id gnat_rcond;
6023
6024 /* The following processing is not required for correctness. Its purpose is
6025 to give more precise error messages and to record some information. */
6026 switch (reason)
6027 {
6028 case CE_Access_Check_Failed:
6029 if (with_extra_info)
6030 gnu_result = build_call_raise_column (reason, gnat_node, kind);
6031 break;
6032
6033 case CE_Index_Check_Failed:
6034 case CE_Range_Check_Failed:
6035 case CE_Invalid_Data:
6036 if (No (gnat_cond) || Nkind (gnat_cond) != N_Op_Not)
6037 break;
6038 gnat_rcond = Right_Opnd (gnat_cond);
6039 if (Nkind (gnat_rcond) == N_In
6040 || Nkind (gnat_rcond) == N_Op_Ge
6041 || Nkind (gnat_rcond) == N_Op_Le)
6042 {
6043 const Node_Id gnat_index = Left_Opnd (gnat_rcond);
6044 const Node_Id gnat_type = Etype (gnat_index);
6045 tree gnu_index = gnat_to_gnu (gnat_index);
6046 tree gnu_type = get_unpadded_type (gnat_type);
6047 tree gnu_low_bound, gnu_high_bound, disp;
6048 struct loop_info_d *loop;
6049 bool neg_p;
6050
6051 switch (Nkind (gnat_rcond))
6052 {
6053 case N_In:
6054 Range_to_gnu (Right_Opnd (gnat_rcond),
6055 &gnu_low_bound, &gnu_high_bound);
6056 break;
6057
6058 case N_Op_Ge:
6059 gnu_low_bound = gnat_to_gnu (Right_Opnd (gnat_rcond));
6060 gnu_high_bound = TYPE_MAX_VALUE (gnu_type);
6061 break;
6062
6063 case N_Op_Le:
6064 gnu_low_bound = TYPE_MIN_VALUE (gnu_type);
6065 gnu_high_bound = gnat_to_gnu (Right_Opnd (gnat_rcond));
6066 break;
6067
6068 default:
6069 gcc_unreachable ();
6070 }
6071
6072 gnu_type = maybe_character_type (gnu_type);
6073 if (TREE_TYPE (gnu_index) != gnu_type)
6074 {
6075 gnu_low_bound = convert (gnu_type, gnu_low_bound);
6076 gnu_high_bound = convert (gnu_type, gnu_high_bound);
6077 gnu_index = convert (gnu_type, gnu_index);
6078 }
6079
6080 if (with_extra_info
6081 && Known_Esize (gnat_type)
6082 && UI_To_Int (Esize (gnat_type)) <= 32)
6083 gnu_result
6084 = build_call_raise_range (reason, gnat_node, kind, gnu_index,
6085 gnu_low_bound, gnu_high_bound);
6086
6087 /* If optimization is enabled and we are inside a loop, we try to
6088 compute invariant conditions for checks applied to the iteration
6089 variable, i.e. conditions that are independent of the variable
6090 and necessary in order for the checks to fail in the course of
6091 some iteration. If we succeed, we consider an alternative:
6092
6093 1. If loop unswitching is enabled, we prepend these conditions
6094 to the original conditions of the checks. This will make it
6095 possible for the loop unswitching pass to replace the loop
6096 with two loops, one of which has the checks eliminated and
6097 the other has the original checks reinstated, and a prologue
6098 implementing a run-time selection. The former loop will be
6099 for example suitable for vectorization.
6100
6101 2. Otherwise, we instead append the conditions to the original
6102 conditions of the checks. At worse, if the conditions cannot
6103 be evaluated at compile time, they will be evaluated as true
6104 at run time only when the checks have already failed, thus
6105 contributing negatively only to the size of the executable.
6106 But the hope is that these invariant conditions be evaluated
6107 at compile time to false, thus taking away the entire checks
6108 with them. */
6109 if (optimize
6110 && inside_loop_p ()
6111 && (!gnu_low_bound
6112 || (gnu_low_bound = gnat_invariant_expr (gnu_low_bound)))
6113 && (!gnu_high_bound
6114 || (gnu_high_bound = gnat_invariant_expr (gnu_high_bound)))
6115 && (loop = find_loop_for (gnu_index, &disp, &neg_p)))
6116 {
6117 struct range_check_info_d *rci = ggc_alloc<range_check_info_d> ();
6118 rci->low_bound = gnu_low_bound;
6119 rci->high_bound = gnu_high_bound;
6120 rci->disp = disp;
6121 rci->neg_p = neg_p;
6122 rci->type = gnu_type;
6123 rci->inserted_cond
6124 = build1 (SAVE_EXPR, boolean_type_node, boolean_true_node);
6125 vec_safe_push (loop->checks, rci);
6126 gnu_cond = build_noreturn_cond (gnat_to_gnu (gnat_cond));
6127 if (optimize >= 3)
6128 gnu_cond = build_binary_op (TRUTH_ANDIF_EXPR,
6129 boolean_type_node,
6130 rci->inserted_cond,
6131 gnu_cond);
6132 else
6133 gnu_cond = build_binary_op (TRUTH_ANDIF_EXPR,
6134 boolean_type_node,
6135 gnu_cond,
6136 rci->inserted_cond);
6137 }
6138 }
6139 break;
6140
6141 default:
6142 break;
6143 }
6144
6145 /* The following processing does the real work, but we must nevertheless make
6146 sure not to override the result of the previous processing. */
6147 if (!gnu_result)
6148 gnu_result = build_call_raise (reason, gnat_node, kind);
6149 set_expr_location_from_node (gnu_result, gnat_node);
6150
6151 *gnu_result_type_p = get_unpadded_type (Etype (gnat_node));
6152
6153 /* If the type is VOID, this is a statement, so we need to generate the code
6154 for the call. Handle a condition, if there is one. */
6155 if (VOID_TYPE_P (*gnu_result_type_p))
6156 {
6157 if (Present (gnat_cond))
6158 {
6159 if (!gnu_cond)
6160 gnu_cond = gnat_to_gnu (gnat_cond);
6161 if (integer_zerop (gnu_cond))
6162 return alloc_stmt_list ();
6163 gnu_result = build3 (COND_EXPR, void_type_node, gnu_cond, gnu_result,
6164 alloc_stmt_list ());
6165 }
6166 }
6167 else
6168 {
6169 /* The condition field must not be present when the node is used as an
6170 expression form. */
6171 gigi_checking_assert (No (gnat_cond));
6172 gnu_result = build1 (NULL_EXPR, *gnu_result_type_p, gnu_result);
6173 }
6174
6175 return gnu_result;
6176 }
6177
6178 /* Return true if GNAT_NODE is on the LHS of an assignment or an actual
6179 parameter of a call. */
6180
6181 static bool
lhs_or_actual_p(Node_Id gnat_node)6182 lhs_or_actual_p (Node_Id gnat_node)
6183 {
6184 const Node_Id gnat_parent = Parent (gnat_node);
6185 const Node_Kind kind = Nkind (gnat_parent);
6186
6187 if (kind == N_Assignment_Statement && Name (gnat_parent) == gnat_node)
6188 return true;
6189
6190 if ((kind == N_Procedure_Call_Statement || kind == N_Function_Call)
6191 && Name (gnat_parent) != gnat_node)
6192 return true;
6193
6194 if (kind == N_Parameter_Association)
6195 return true;
6196
6197 return false;
6198 }
6199
6200 /* Return true if either GNAT_NODE or a view of GNAT_NODE is on the LHS
6201 of an assignment or an actual parameter of a call. */
6202
6203 static bool
present_in_lhs_or_actual_p(Node_Id gnat_node)6204 present_in_lhs_or_actual_p (Node_Id gnat_node)
6205 {
6206 if (lhs_or_actual_p (gnat_node))
6207 return true;
6208
6209 const Node_Kind kind = Nkind (Parent (gnat_node));
6210
6211 if ((kind == N_Type_Conversion || kind == N_Unchecked_Type_Conversion)
6212 && lhs_or_actual_p (Parent (gnat_node)))
6213 return true;
6214
6215 return false;
6216 }
6217
6218 /* Return true if GNAT_NODE, an unchecked type conversion, is a no-op as far
6219 as gigi is concerned. This is used to avoid conversions on the LHS. */
6220
6221 static bool
unchecked_conversion_nop(Node_Id gnat_node)6222 unchecked_conversion_nop (Node_Id gnat_node)
6223 {
6224 Entity_Id from_type, to_type;
6225
6226 /* The conversion must be on the LHS of an assignment or an actual parameter
6227 of a call. Otherwise, even if the conversion was essentially a no-op, it
6228 could de facto ensure type consistency and this should be preserved. */
6229 if (!lhs_or_actual_p (gnat_node))
6230 return false;
6231
6232 from_type = Etype (Expression (gnat_node));
6233
6234 /* We're interested in artificial conversions generated by the front-end
6235 to make private types explicit, e.g. in Expand_Assign_Array. */
6236 if (!Is_Private_Type (from_type))
6237 return false;
6238
6239 from_type = Underlying_Type (from_type);
6240 to_type = Etype (gnat_node);
6241
6242 /* The direct conversion to the underlying type is a no-op. */
6243 if (to_type == from_type)
6244 return true;
6245
6246 /* For an array subtype, the conversion to the PAIT is a no-op. */
6247 if (Ekind (from_type) == E_Array_Subtype
6248 && to_type == Packed_Array_Impl_Type (from_type))
6249 return true;
6250
6251 /* For a record subtype, the conversion to the type is a no-op. */
6252 if (Ekind (from_type) == E_Record_Subtype
6253 && to_type == Etype (from_type))
6254 return true;
6255
6256 return false;
6257 }
6258
6259 /* Return true if GNAT_NODE represents a statement. */
6260
6261 static bool
statement_node_p(Node_Id gnat_node)6262 statement_node_p (Node_Id gnat_node)
6263 {
6264 const Node_Kind kind = Nkind (gnat_node);
6265
6266 if (kind == N_Label)
6267 return true;
6268
6269 if (IN (kind, N_Statement_Other_Than_Procedure_Call))
6270 return true;
6271
6272 if (kind == N_Procedure_Call_Statement)
6273 return true;
6274
6275 if (IN (kind, N_Raise_xxx_Error) && Ekind (Etype (gnat_node)) == E_Void)
6276 return true;
6277
6278 return false;
6279 }
6280
6281 /* This function is the driver of the GNAT to GCC tree transformation process.
6282 It is the entry point of the tree transformer. GNAT_NODE is the root of
6283 some GNAT tree. Return the root of the corresponding GCC tree. If this
6284 is an expression, return the GCC equivalent of the expression. If this
6285 is a statement, return the statement or add it to the current statement
6286 group, in which case anything returned is to be interpreted as occurring
6287 after anything added. */
6288
6289 tree
gnat_to_gnu(Node_Id gnat_node)6290 gnat_to_gnu (Node_Id gnat_node)
6291 {
6292 const Node_Kind kind = Nkind (gnat_node);
6293 tree gnu_result = error_mark_node; /* Default to no value. */
6294 tree gnu_result_type = void_type_node;
6295 tree gnu_expr, gnu_lhs, gnu_rhs;
6296 Node_Id gnat_temp;
6297 atomic_acces_t aa_type;
6298 bool went_into_elab_proc;
6299 bool aa_sync;
6300
6301 /* Save node number for error message and set location information. */
6302 Current_Error_Node = gnat_node;
6303 Sloc_to_locus (Sloc (gnat_node), &input_location);
6304
6305 /* If we are only annotating types and this node is a statement, return
6306 an empty statement list. */
6307 if (type_annotate_only && statement_node_p (gnat_node))
6308 return alloc_stmt_list ();
6309
6310 /* If we are only annotating types and this node is a subexpression, return
6311 a NULL_EXPR, but filter out nodes appearing in the expressions attached
6312 to packed array implementation types. */
6313 if (type_annotate_only
6314 && IN (kind, N_Subexpr)
6315 && !(((IN (kind, N_Op) && kind != N_Op_Expon)
6316 || kind == N_Type_Conversion)
6317 && Is_Integer_Type (Etype (gnat_node)))
6318 && !(kind == N_Attribute_Reference
6319 && (Get_Attribute_Id (Attribute_Name (gnat_node)) == Attr_Length
6320 || Get_Attribute_Id (Attribute_Name (gnat_node)) == Attr_Size)
6321 && Is_Constrained (Etype (Prefix (gnat_node)))
6322 && !Is_Constr_Subt_For_U_Nominal (Etype (Prefix (gnat_node))))
6323 && kind != N_Expanded_Name
6324 && kind != N_Identifier
6325 && !Compile_Time_Known_Value (gnat_node))
6326 return build1 (NULL_EXPR, get_unpadded_type (Etype (gnat_node)),
6327 build_call_raise (CE_Range_Check_Failed, gnat_node,
6328 N_Raise_Constraint_Error));
6329
6330 /* If this is a statement and we are at top level, it must be part of the
6331 elaboration procedure, so mark us as being in that procedure. */
6332 if ((statement_node_p (gnat_node)
6333 || kind == N_Handled_Sequence_Of_Statements
6334 || kind == N_Implicit_Label_Declaration)
6335 && !current_function_decl)
6336 {
6337 current_function_decl = get_elaboration_procedure ();
6338 went_into_elab_proc = true;
6339 }
6340 else
6341 went_into_elab_proc = false;
6342
6343 switch (kind)
6344 {
6345 /********************************/
6346 /* Chapter 2: Lexical Elements */
6347 /********************************/
6348
6349 case N_Identifier:
6350 case N_Expanded_Name:
6351 case N_Operator_Symbol:
6352 case N_Defining_Identifier:
6353 case N_Defining_Operator_Symbol:
6354 gnu_result = Identifier_to_gnu (gnat_node, &gnu_result_type);
6355
6356 /* If atomic access is required on the RHS, build the atomic load. */
6357 if (simple_atomic_access_required_p (gnat_node, &aa_sync)
6358 && !present_in_lhs_or_actual_p (gnat_node))
6359 gnu_result = build_atomic_load (gnu_result, aa_sync);
6360 break;
6361
6362 case N_Integer_Literal:
6363 {
6364 tree gnu_type;
6365
6366 /* Get the type of the result, looking inside any padding and
6367 justified modular types. Then get the value in that type. */
6368 gnu_type = gnu_result_type = get_unpadded_type (Etype (gnat_node));
6369
6370 if (TREE_CODE (gnu_type) == RECORD_TYPE
6371 && TYPE_JUSTIFIED_MODULAR_P (gnu_type))
6372 gnu_type = TREE_TYPE (TYPE_FIELDS (gnu_type));
6373
6374 gnu_result = UI_To_gnu (Intval (gnat_node), gnu_type);
6375
6376 /* If the result overflows (meaning it doesn't fit in its base type),
6377 abort, unless this is for a named number because that's not fatal.
6378 We would like to check that the value is within the range of the
6379 subtype, but that causes problems with subtypes whose usage will
6380 raise Constraint_Error and also with biased representation. */
6381 if (TREE_OVERFLOW (gnu_result))
6382 {
6383 if (Nkind (Parent (gnat_node)) == N_Number_Declaration)
6384 gnu_result = error_mark_node;
6385 else
6386 gcc_unreachable ();
6387 }
6388 }
6389 break;
6390
6391 case N_Character_Literal:
6392 /* If a Entity is present, it means that this was one of the
6393 literals in a user-defined character type. In that case,
6394 just return the value in the CONST_DECL. Otherwise, use the
6395 character code. In that case, the base type should be an
6396 INTEGER_TYPE, but we won't bother checking for that. */
6397 gnu_result_type = get_unpadded_type (Etype (gnat_node));
6398 if (Present (Entity (gnat_node)))
6399 gnu_result = DECL_INITIAL (get_gnu_tree (Entity (gnat_node)));
6400 else
6401 gnu_result
6402 = build_int_cst (gnu_result_type,
6403 UI_To_CC (Char_Literal_Value (gnat_node)));
6404 break;
6405
6406 case N_Real_Literal:
6407 gnu_result_type = get_unpadded_type (Etype (gnat_node));
6408
6409 /* If this is of a fixed-point type, the value we want is the value of
6410 the corresponding integer. */
6411 if (Is_Fixed_Point_Type (Underlying_Type (Etype (gnat_node))))
6412 {
6413 gnu_result = UI_To_gnu (Corresponding_Integer_Value (gnat_node),
6414 gnu_result_type);
6415 gcc_assert (!TREE_OVERFLOW (gnu_result));
6416 }
6417
6418 else
6419 {
6420 Ureal ur_realval = Realval (gnat_node);
6421
6422 /* First convert the value to a machine number if it isn't already.
6423 That will force the base to 2 for non-zero values and simplify
6424 the rest of the logic. */
6425 if (!Is_Machine_Number (gnat_node))
6426 ur_realval
6427 = Machine (Base_Type (Underlying_Type (Etype (gnat_node))),
6428 ur_realval, Round_Even, gnat_node);
6429
6430 if (UR_Is_Zero (ur_realval))
6431 gnu_result = build_real (gnu_result_type, dconst0);
6432 else
6433 {
6434 REAL_VALUE_TYPE tmp;
6435
6436 gnu_result = UI_To_gnu (Numerator (ur_realval), gnu_result_type);
6437
6438 /* The base must be 2 as Machine guarantees this, so we scale
6439 the value, which we know can fit in the mantissa of the type
6440 (hence the use of that type above). */
6441 gcc_assert (Rbase (ur_realval) == 2);
6442 real_ldexp (&tmp, &TREE_REAL_CST (gnu_result),
6443 - UI_To_Int (Denominator (ur_realval)));
6444 gnu_result = build_real (gnu_result_type, tmp);
6445 }
6446
6447 /* Now see if we need to negate the result. Do it this way to
6448 properly handle -0. */
6449 if (UR_Is_Negative (Realval (gnat_node)))
6450 gnu_result
6451 = build_unary_op (NEGATE_EXPR, get_base_type (gnu_result_type),
6452 gnu_result);
6453 }
6454
6455 break;
6456
6457 case N_String_Literal:
6458 gnu_result_type = get_unpadded_type (Etype (gnat_node));
6459 if (TYPE_PRECISION (TREE_TYPE (gnu_result_type)) == HOST_BITS_PER_CHAR)
6460 {
6461 String_Id gnat_string = Strval (gnat_node);
6462 int length = String_Length (gnat_string);
6463 int i;
6464 char *string;
6465 if (length >= ALLOCA_THRESHOLD)
6466 string = XNEWVEC (char, length);
6467 else
6468 string = (char *) alloca (length);
6469
6470 /* Build the string with the characters in the literal. Note
6471 that Ada strings are 1-origin. */
6472 for (i = 0; i < length; i++)
6473 string[i] = Get_String_Char (gnat_string, i + 1);
6474
6475 gnu_result = build_string (length, string);
6476
6477 /* Strings in GCC don't normally have types, but we want
6478 this to not be converted to the array type. */
6479 TREE_TYPE (gnu_result) = gnu_result_type;
6480
6481 if (length >= ALLOCA_THRESHOLD)
6482 free (string);
6483 }
6484 else
6485 {
6486 /* Build a list consisting of each character, then make
6487 the aggregate. */
6488 String_Id gnat_string = Strval (gnat_node);
6489 int length = String_Length (gnat_string);
6490 int i;
6491 tree gnu_idx = TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_result_type));
6492 tree gnu_one_node = convert (TREE_TYPE (gnu_idx), integer_one_node);
6493 vec<constructor_elt, va_gc> *gnu_vec;
6494 vec_alloc (gnu_vec, length);
6495
6496 for (i = 0; i < length; i++)
6497 {
6498 tree t = build_int_cst (TREE_TYPE (gnu_result_type),
6499 Get_String_Char (gnat_string, i + 1));
6500
6501 CONSTRUCTOR_APPEND_ELT (gnu_vec, gnu_idx, t);
6502 gnu_idx = int_const_binop (PLUS_EXPR, gnu_idx, gnu_one_node);
6503 }
6504
6505 gnu_result = gnat_build_constructor (gnu_result_type, gnu_vec);
6506 }
6507 break;
6508
6509 case N_Pragma:
6510 gnu_result = Pragma_to_gnu (gnat_node);
6511 break;
6512
6513 /**************************************/
6514 /* Chapter 3: Declarations and Types */
6515 /**************************************/
6516
6517 case N_Subtype_Declaration:
6518 case N_Full_Type_Declaration:
6519 case N_Incomplete_Type_Declaration:
6520 case N_Private_Type_Declaration:
6521 case N_Private_Extension_Declaration:
6522 case N_Task_Type_Declaration:
6523 process_type (Defining_Entity (gnat_node));
6524 gnu_result = alloc_stmt_list ();
6525 break;
6526
6527 case N_Object_Declaration:
6528 case N_Number_Declaration:
6529 case N_Exception_Declaration:
6530 gnat_temp = Defining_Entity (gnat_node);
6531 gnu_result = alloc_stmt_list ();
6532
6533 /* If we are just annotating types and this object has an unconstrained
6534 or task type, don't elaborate it. */
6535 if (type_annotate_only
6536 && (((Is_Array_Type (Etype (gnat_temp))
6537 || Is_Record_Type (Etype (gnat_temp)))
6538 && !Is_Constrained (Etype (gnat_temp)))
6539 || Is_Concurrent_Type (Etype (gnat_temp))))
6540 break;
6541
6542 if (Present (Expression (gnat_node))
6543 && !(kind == N_Object_Declaration && No_Initialization (gnat_node))
6544 && (!type_annotate_only
6545 || Compile_Time_Known_Value (Expression (gnat_node))))
6546 {
6547 gigi_checking_assert (!Do_Range_Check (Expression (gnat_node)));
6548
6549 gnu_expr = gnat_to_gnu (Expression (gnat_node));
6550
6551 /* First deal with erroneous expressions. */
6552 if (TREE_CODE (gnu_expr) == ERROR_MARK)
6553 {
6554 /* If this is a named number for which we cannot manipulate
6555 the value, just skip the declaration altogether. */
6556 if (kind == N_Number_Declaration)
6557 break;
6558 else if (type_annotate_only)
6559 gnu_expr = NULL_TREE;
6560 }
6561
6562 /* Then a special case: we do not want the SLOC of the expression
6563 of the tag to pop up every time it is referenced somewhere. */
6564 else if (EXPR_P (gnu_expr) && Is_Tag (gnat_temp))
6565 SET_EXPR_LOCATION (gnu_expr, UNKNOWN_LOCATION);
6566 }
6567 else
6568 gnu_expr = NULL_TREE;
6569
6570 /* If this is a deferred constant with an address clause, we ignore the
6571 full view since the clause is on the partial view and we cannot have
6572 2 different GCC trees for the object. The only bits of the full view
6573 we will use is the initializer, but it will be directly fetched. */
6574 if (Ekind (gnat_temp) == E_Constant
6575 && Present (Address_Clause (gnat_temp))
6576 && Present (Full_View (gnat_temp)))
6577 save_gnu_tree (Full_View (gnat_temp), error_mark_node, true);
6578
6579 /* If this object has its elaboration delayed, we must force evaluation
6580 of GNU_EXPR now and save it for the freeze point. Note that we need
6581 not do anything special at the global level since the lifetime of the
6582 temporary is fully contained within the elaboration routine. */
6583 if (Present (Freeze_Node (gnat_temp)))
6584 {
6585 if (gnu_expr)
6586 {
6587 gnu_result = gnat_save_expr (gnu_expr);
6588 save_gnu_tree (gnat_node, gnu_result, true);
6589 }
6590 }
6591 else
6592 gnat_to_gnu_entity (gnat_temp, gnu_expr, true);
6593 break;
6594
6595 case N_Object_Renaming_Declaration:
6596 gnat_temp = Defining_Entity (gnat_node);
6597 gnu_result = alloc_stmt_list ();
6598
6599 /* Don't do anything if this renaming is handled by the front end and it
6600 does not need debug info. Note that we consider renamings don't need
6601 debug info when optimizing: our way to describe them has a
6602 memory/elaboration footprint.
6603
6604 Don't do anything neither if we are just annotating types and this
6605 object has a composite or task type, don't elaborate it. */
6606 if ((!Is_Renaming_Of_Object (gnat_temp)
6607 || (Needs_Debug_Info (gnat_temp)
6608 && !optimize
6609 && can_materialize_object_renaming_p
6610 (Renamed_Object (gnat_temp))))
6611 && ! (type_annotate_only
6612 && (Is_Array_Type (Etype (gnat_temp))
6613 || Is_Record_Type (Etype (gnat_temp))
6614 || Is_Concurrent_Type (Etype (gnat_temp)))))
6615 gnat_to_gnu_entity (gnat_temp,
6616 gnat_to_gnu (Renamed_Object (gnat_temp)),
6617 true);
6618 break;
6619
6620 case N_Exception_Renaming_Declaration:
6621 gnat_temp = Defining_Entity (gnat_node);
6622 gnu_result = alloc_stmt_list ();
6623
6624 if (Present (Renamed_Entity (gnat_temp)))
6625 gnat_to_gnu_entity (gnat_temp,
6626 gnat_to_gnu (Renamed_Entity (gnat_temp)),
6627 true);
6628 break;
6629
6630 case N_Subprogram_Renaming_Declaration:
6631 {
6632 const Node_Id gnat_renaming = Defining_Entity (gnat_node);
6633 const Node_Id gnat_renamed = Renamed_Entity (gnat_renaming);
6634
6635 gnu_result = alloc_stmt_list ();
6636
6637 /* Materializing renamed subprograms will only benefit the debugging
6638 information as they aren't referenced in the generated code. So
6639 skip them when they aren't needed. Avoid doing this if:
6640
6641 - there is a freeze node: in this case the renamed entity is not
6642 elaborated yet,
6643 - the renamed subprogram is intrinsic: it will not be available in
6644 the debugging information (note that both or only one of the
6645 renaming and the renamed subprograms can be intrinsic). */
6646 if (!type_annotate_only
6647 && Needs_Debug_Info (gnat_renaming)
6648 && No (Freeze_Node (gnat_renaming))
6649 && Present (gnat_renamed)
6650 && (Ekind (gnat_renamed) == E_Function
6651 || Ekind (gnat_renamed) == E_Procedure)
6652 && !Is_Intrinsic_Subprogram (gnat_renaming)
6653 && !Is_Intrinsic_Subprogram (gnat_renamed))
6654 gnat_to_gnu_entity (gnat_renaming, gnat_to_gnu (gnat_renamed), true);
6655 break;
6656 }
6657
6658 case N_Implicit_Label_Declaration:
6659 gnat_to_gnu_entity (Defining_Entity (gnat_node), NULL_TREE, true);
6660 gnu_result = alloc_stmt_list ();
6661 break;
6662
6663 case N_Package_Renaming_Declaration:
6664 /* These are fully handled in the front end. */
6665 /* ??? For package renamings, find a way to use GENERIC namespaces so
6666 that we get proper debug information for them. */
6667 gnu_result = alloc_stmt_list ();
6668 break;
6669
6670 /*************************************/
6671 /* Chapter 4: Names and Expressions */
6672 /*************************************/
6673
6674 case N_Explicit_Dereference:
6675 /* Make sure the designated type is complete before dereferencing. */
6676 gnu_result_type = get_unpadded_type (Etype (gnat_node));
6677 gnu_result = gnat_to_gnu (Prefix (gnat_node));
6678 gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_result);
6679
6680 /* If atomic access is required on the RHS, build the atomic load. */
6681 if (simple_atomic_access_required_p (gnat_node, &aa_sync)
6682 && !present_in_lhs_or_actual_p (gnat_node))
6683 gnu_result = build_atomic_load (gnu_result, aa_sync);
6684 break;
6685
6686 case N_Indexed_Component:
6687 {
6688 tree gnu_array_object = gnat_to_gnu ((Prefix (gnat_node)));
6689 tree gnu_type;
6690 int ndim, i;
6691 Node_Id *gnat_expr_array;
6692
6693 gnu_array_object = maybe_padded_object (gnu_array_object);
6694 gnu_array_object = maybe_unconstrained_array (gnu_array_object);
6695
6696 /* Convert vector inputs to their representative array type, to fit
6697 what the code below expects. */
6698 if (VECTOR_TYPE_P (TREE_TYPE (gnu_array_object)))
6699 {
6700 if (present_in_lhs_or_actual_p (gnat_node))
6701 gnat_mark_addressable (gnu_array_object);
6702 gnu_array_object = maybe_vector_array (gnu_array_object);
6703 }
6704
6705 /* The failure of this assertion will very likely come from a missing
6706 expansion for a packed array access. */
6707 gcc_assert (TREE_CODE (TREE_TYPE (gnu_array_object)) == ARRAY_TYPE);
6708
6709 /* First compute the number of dimensions of the array, then
6710 fill the expression array, the order depending on whether
6711 this is a Convention_Fortran array or not. */
6712 for (ndim = 1, gnu_type = TREE_TYPE (gnu_array_object);
6713 TREE_CODE (TREE_TYPE (gnu_type)) == ARRAY_TYPE
6714 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type));
6715 ndim++, gnu_type = TREE_TYPE (gnu_type))
6716 ;
6717
6718 gnat_expr_array = XALLOCAVEC (Node_Id, ndim);
6719
6720 if (TYPE_CONVENTION_FORTRAN_P (TREE_TYPE (gnu_array_object)))
6721 for (i = ndim - 1, gnat_temp = First (Expressions (gnat_node));
6722 i >= 0;
6723 i--, gnat_temp = Next (gnat_temp))
6724 gnat_expr_array[i] = gnat_temp;
6725 else
6726 for (i = 0, gnat_temp = First (Expressions (gnat_node));
6727 i < ndim;
6728 i++, gnat_temp = Next (gnat_temp))
6729 gnat_expr_array[i] = gnat_temp;
6730
6731 /* Start with the prefix and build the successive references. */
6732 gnu_result = gnu_array_object;
6733
6734 for (i = 0, gnu_type = TREE_TYPE (gnu_array_object);
6735 i < ndim;
6736 i++, gnu_type = TREE_TYPE (gnu_type))
6737 {
6738 gcc_assert (TREE_CODE (gnu_type) == ARRAY_TYPE);
6739 gnat_temp = gnat_expr_array[i];
6740 gnu_expr = maybe_character_value (gnat_to_gnu (gnat_temp));
6741
6742 gnu_result
6743 = build_binary_op (ARRAY_REF, NULL_TREE, gnu_result, gnu_expr);
6744 }
6745
6746 gnu_result_type = get_unpadded_type (Etype (gnat_node));
6747
6748 /* If atomic access is required on the RHS, build the atomic load. */
6749 if (simple_atomic_access_required_p (gnat_node, &aa_sync)
6750 && !present_in_lhs_or_actual_p (gnat_node))
6751 gnu_result = build_atomic_load (gnu_result, aa_sync);
6752 }
6753 break;
6754
6755 case N_Slice:
6756 {
6757 tree gnu_array_object = gnat_to_gnu (Prefix (gnat_node));
6758
6759 gnu_result_type = get_unpadded_type (Etype (gnat_node));
6760
6761 gnu_array_object = maybe_padded_object (gnu_array_object);
6762 gnu_array_object = maybe_unconstrained_array (gnu_array_object);
6763
6764 gnu_expr = TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_result_type));
6765 gnu_expr = maybe_character_value (gnu_expr);
6766
6767 /* If this is a slice with non-constant size of an array with constant
6768 size, set the maximum size for the allocation of temporaries. */
6769 if (!TREE_CONSTANT (TYPE_SIZE_UNIT (gnu_result_type))
6770 && TREE_CONSTANT (TYPE_SIZE_UNIT (TREE_TYPE (gnu_array_object))))
6771 TYPE_ARRAY_MAX_SIZE (gnu_result_type)
6772 = TYPE_SIZE_UNIT (TREE_TYPE (gnu_array_object));
6773
6774 gnu_result = build_binary_op (ARRAY_RANGE_REF, gnu_result_type,
6775 gnu_array_object, gnu_expr);
6776 }
6777 break;
6778
6779 case N_Selected_Component:
6780 {
6781 const Entity_Id gnat_prefix = Prefix (gnat_node);
6782 Entity_Id gnat_field = Entity (Selector_Name (gnat_node));
6783 tree gnu_prefix = gnat_to_gnu (gnat_prefix);
6784
6785 gnu_prefix = maybe_padded_object (gnu_prefix);
6786
6787 /* gnat_to_gnu_entity does not save the GNU tree made for renamed
6788 discriminants so avoid making recursive calls on each reference
6789 to them by following the appropriate link directly here. */
6790 if (Ekind (gnat_field) == E_Discriminant)
6791 {
6792 /* For discriminant references in tagged types always substitute
6793 the corresponding discriminant as the actual component. */
6794 if (Is_Tagged_Type (Underlying_Type (Etype (gnat_prefix))))
6795 while (Present (Corresponding_Discriminant (gnat_field)))
6796 gnat_field = Corresponding_Discriminant (gnat_field);
6797
6798 /* For discriminant references in untagged types always substitute
6799 the corresponding stored discriminant. */
6800 else if (Present (Corresponding_Discriminant (gnat_field)))
6801 gnat_field = Original_Record_Component (gnat_field);
6802 }
6803
6804 /* Handle extracting the real or imaginary part of a complex.
6805 The real part is the first field and the imaginary the last. */
6806 if (TREE_CODE (TREE_TYPE (gnu_prefix)) == COMPLEX_TYPE)
6807 gnu_result = build_unary_op (Present (Next_Entity (gnat_field))
6808 ? REALPART_EXPR : IMAGPART_EXPR,
6809 NULL_TREE, gnu_prefix);
6810 else
6811 {
6812 tree gnu_field = gnat_to_gnu_field_decl (gnat_field);
6813 tree gnu_offset;
6814 struct loop_info_d *loop;
6815
6816 gnu_result
6817 = build_component_ref (gnu_prefix, gnu_field,
6818 (Nkind (Parent (gnat_node))
6819 == N_Attribute_Reference)
6820 && lvalue_required_for_attribute_p
6821 (Parent (gnat_node)));
6822
6823 /* If optimization is enabled and we are inside a loop, we try to
6824 hoist nonconstant but invariant offset computations outside of
6825 the loop, since they very likely contain loads that could turn
6826 out to be hard to move if they end up in active EH regions. */
6827 if (optimize
6828 && inside_loop_p ()
6829 && TREE_CODE (gnu_result) == COMPONENT_REF
6830 && (gnu_offset = component_ref_field_offset (gnu_result))
6831 && !TREE_CONSTANT (gnu_offset)
6832 && (gnu_offset = gnat_invariant_expr (gnu_offset))
6833 && (loop = find_loop ()))
6834 {
6835 tree invariant
6836 = build1 (SAVE_EXPR, TREE_TYPE (gnu_offset), gnu_offset);
6837 vec_safe_push (loop->invariants, invariant);
6838 tree field = TREE_OPERAND (gnu_result, 1);
6839 tree factor
6840 = size_int (DECL_OFFSET_ALIGN (field) / BITS_PER_UNIT);
6841 /* Divide the offset by its alignment. */
6842 TREE_OPERAND (gnu_result, 2)
6843 = size_binop (EXACT_DIV_EXPR, invariant, factor);
6844 }
6845 }
6846
6847 gnu_result_type = get_unpadded_type (Etype (gnat_node));
6848
6849 /* If atomic access is required on the RHS, build the atomic load. */
6850 if (simple_atomic_access_required_p (gnat_node, &aa_sync)
6851 && !present_in_lhs_or_actual_p (gnat_node))
6852 gnu_result = build_atomic_load (gnu_result, aa_sync);
6853 }
6854 break;
6855
6856 case N_Attribute_Reference:
6857 {
6858 /* The attribute designator. */
6859 const int attr = Get_Attribute_Id (Attribute_Name (gnat_node));
6860
6861 /* The Elab_Spec and Elab_Body attributes are special in that Prefix
6862 is a unit, not an object with a GCC equivalent. */
6863 if (attr == Attr_Elab_Spec || attr == Attr_Elab_Body)
6864 return
6865 create_subprog_decl (create_concat_name
6866 (Entity (Prefix (gnat_node)),
6867 attr == Attr_Elab_Body ? "elabb" : "elabs"),
6868 NULL_TREE, void_ftype, NULL_TREE, is_default,
6869 true, true, true, true, false, NULL,
6870 gnat_node);
6871
6872 gnu_result = Attribute_to_gnu (gnat_node, &gnu_result_type, attr);
6873 }
6874 break;
6875
6876 case N_Reference:
6877 /* Like 'Access as far as we are concerned. */
6878 gnu_result = gnat_to_gnu (Prefix (gnat_node));
6879 gnu_result = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_result);
6880 gnu_result_type = get_unpadded_type (Etype (gnat_node));
6881 break;
6882
6883 case N_Aggregate:
6884 case N_Extension_Aggregate:
6885 {
6886 tree gnu_aggr_type;
6887
6888 /* Check that this aggregate has not slipped through the cracks. */
6889 gcc_assert (!Expansion_Delayed (gnat_node));
6890
6891 gnu_result_type = get_unpadded_type (Etype (gnat_node));
6892
6893 if (TREE_CODE (gnu_result_type) == RECORD_TYPE
6894 && TYPE_CONTAINS_TEMPLATE_P (gnu_result_type))
6895 gnu_aggr_type
6896 = TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (gnu_result_type)));
6897 else if (TREE_CODE (gnu_result_type) == VECTOR_TYPE)
6898 gnu_aggr_type = TYPE_REPRESENTATIVE_ARRAY (gnu_result_type);
6899 else
6900 gnu_aggr_type = gnu_result_type;
6901
6902 if (Null_Record_Present (gnat_node))
6903 gnu_result = gnat_build_constructor (gnu_aggr_type, NULL);
6904
6905 else if (TREE_CODE (gnu_aggr_type) == RECORD_TYPE
6906 || TREE_CODE (gnu_aggr_type) == UNION_TYPE)
6907 gnu_result
6908 = assoc_to_constructor (Etype (gnat_node),
6909 First (Component_Associations (gnat_node)),
6910 gnu_aggr_type);
6911 else if (TREE_CODE (gnu_aggr_type) == ARRAY_TYPE)
6912 gnu_result = pos_to_constructor (First (Expressions (gnat_node)),
6913 gnu_aggr_type);
6914 else if (TREE_CODE (gnu_aggr_type) == COMPLEX_TYPE)
6915 gnu_result
6916 = build_binary_op
6917 (COMPLEX_EXPR, gnu_aggr_type,
6918 gnat_to_gnu (Expression (First
6919 (Component_Associations (gnat_node)))),
6920 gnat_to_gnu (Expression
6921 (Next
6922 (First (Component_Associations (gnat_node))))));
6923 else
6924 gcc_unreachable ();
6925
6926 gnu_result = convert (gnu_result_type, gnu_result);
6927 }
6928 break;
6929
6930 case N_Null:
6931 if (TARGET_VTABLE_USES_DESCRIPTORS
6932 && Ekind (Etype (gnat_node)) == E_Access_Subprogram_Type
6933 && Is_Dispatch_Table_Entity (Etype (gnat_node)))
6934 gnu_result = null_fdesc_node;
6935 else
6936 gnu_result = null_pointer_node;
6937 gnu_result_type = get_unpadded_type (Etype (gnat_node));
6938 break;
6939
6940 case N_Type_Conversion:
6941 case N_Qualified_Expression:
6942 gnu_expr = maybe_character_value (gnat_to_gnu (Expression (gnat_node)));
6943 gnu_result_type = get_unpadded_type (Etype (gnat_node));
6944
6945 /* If this is a qualified expression for a tagged type, we mark the type
6946 as used. Because of polymorphism, this might be the only reference to
6947 the tagged type in the program while objects have it as dynamic type.
6948 The debugger needs to see it to display these objects properly. */
6949 if (kind == N_Qualified_Expression && Is_Tagged_Type (Etype (gnat_node)))
6950 used_types_insert (gnu_result_type);
6951
6952 gigi_checking_assert (!Do_Range_Check (Expression (gnat_node)));
6953
6954 gnu_result
6955 = convert_with_check (Etype (gnat_node), gnu_expr,
6956 Do_Overflow_Check (gnat_node),
6957 kind == N_Type_Conversion
6958 && Float_Truncate (gnat_node), gnat_node);
6959 break;
6960
6961 case N_Unchecked_Type_Conversion:
6962 gnu_result_type = get_unpadded_type (Etype (gnat_node));
6963 gnu_expr = maybe_character_value (gnat_to_gnu (Expression (gnat_node)));
6964
6965 /* Skip further processing if the conversion is deemed a no-op. */
6966 if (unchecked_conversion_nop (gnat_node))
6967 {
6968 gnu_result = gnu_expr;
6969 gnu_result_type = TREE_TYPE (gnu_result);
6970 break;
6971 }
6972
6973 /* If the result is a pointer type, see if we are improperly
6974 converting to a stricter alignment. */
6975 if (STRICT_ALIGNMENT && POINTER_TYPE_P (gnu_result_type)
6976 && Is_Access_Type (Etype (gnat_node)))
6977 {
6978 unsigned int align = known_alignment (gnu_expr);
6979 tree gnu_obj_type = TREE_TYPE (gnu_result_type);
6980 unsigned int oalign = TYPE_ALIGN (gnu_obj_type);
6981
6982 if (align != 0 && align < oalign && !TYPE_ALIGN_OK (gnu_obj_type))
6983 post_error_ne_tree_2
6984 ("??source alignment (^) '< alignment of & (^)",
6985 gnat_node, Designated_Type (Etype (gnat_node)),
6986 size_int (align / BITS_PER_UNIT), oalign / BITS_PER_UNIT);
6987 }
6988
6989 /* If we are converting a descriptor to a function pointer, first
6990 build the pointer. */
6991 if (TARGET_VTABLE_USES_DESCRIPTORS
6992 && TREE_TYPE (gnu_expr) == fdesc_type_node
6993 && POINTER_TYPE_P (gnu_result_type))
6994 gnu_expr = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr);
6995
6996 gnu_result = unchecked_convert (gnu_result_type, gnu_expr,
6997 No_Truncation (gnat_node));
6998 break;
6999
7000 case N_In:
7001 case N_Not_In:
7002 {
7003 tree gnu_obj = gnat_to_gnu (Left_Opnd (gnat_node));
7004 tree gnu_low, gnu_high;
7005
7006 Range_to_gnu (Right_Opnd (gnat_node), &gnu_low, &gnu_high);
7007 gnu_result_type = get_unpadded_type (Etype (gnat_node));
7008
7009 tree gnu_op_type = maybe_character_type (TREE_TYPE (gnu_obj));
7010 if (TREE_TYPE (gnu_obj) != gnu_op_type)
7011 {
7012 gnu_obj = convert (gnu_op_type, gnu_obj);
7013 gnu_low = convert (gnu_op_type, gnu_low);
7014 gnu_high = convert (gnu_op_type, gnu_high);
7015 }
7016
7017 /* If LOW and HIGH are identical, perform an equality test. Otherwise,
7018 ensure that GNU_OBJ is evaluated only once and perform a full range
7019 test. */
7020 if (operand_equal_p (gnu_low, gnu_high, 0))
7021 gnu_result
7022 = build_binary_op (EQ_EXPR, gnu_result_type, gnu_obj, gnu_low);
7023 else
7024 {
7025 tree t1, t2;
7026 gnu_obj = gnat_protect_expr (gnu_obj);
7027 t1 = build_binary_op (GE_EXPR, gnu_result_type, gnu_obj, gnu_low);
7028 if (EXPR_P (t1))
7029 set_expr_location_from_node (t1, gnat_node);
7030 t2 = build_binary_op (LE_EXPR, gnu_result_type, gnu_obj, gnu_high);
7031 if (EXPR_P (t2))
7032 set_expr_location_from_node (t2, gnat_node);
7033 gnu_result
7034 = build_binary_op (TRUTH_ANDIF_EXPR, gnu_result_type, t1, t2);
7035 }
7036
7037 if (kind == N_Not_In)
7038 gnu_result
7039 = invert_truthvalue_loc (EXPR_LOCATION (gnu_result), gnu_result);
7040 }
7041 break;
7042
7043 case N_Op_Divide:
7044 gnu_lhs = gnat_to_gnu (Left_Opnd (gnat_node));
7045 gnu_rhs = gnat_to_gnu (Right_Opnd (gnat_node));
7046 gnu_result_type = get_unpadded_type (Etype (gnat_node));
7047 gnu_result = build_binary_op (FLOAT_TYPE_P (gnu_result_type)
7048 ? RDIV_EXPR
7049 : (Rounded_Result (gnat_node)
7050 ? ROUND_DIV_EXPR : TRUNC_DIV_EXPR),
7051 gnu_result_type, gnu_lhs, gnu_rhs);
7052 break;
7053
7054 case N_Op_Eq:
7055 case N_Op_Ne:
7056 case N_Op_Lt:
7057 case N_Op_Le:
7058 case N_Op_Gt:
7059 case N_Op_Ge:
7060 case N_Op_Add:
7061 case N_Op_Subtract:
7062 case N_Op_Multiply:
7063 case N_Op_Mod:
7064 case N_Op_Rem:
7065 case N_Op_Rotate_Left:
7066 case N_Op_Rotate_Right:
7067 case N_Op_Shift_Left:
7068 case N_Op_Shift_Right:
7069 case N_Op_Shift_Right_Arithmetic:
7070 case N_Op_And:
7071 case N_Op_Or:
7072 case N_Op_Xor:
7073 case N_And_Then:
7074 case N_Or_Else:
7075 {
7076 enum tree_code code = gnu_codes[kind];
7077 bool ignore_lhs_overflow = false;
7078 location_t saved_location = input_location;
7079 tree gnu_type, gnu_max_shift = NULL_TREE;
7080
7081 /* Fix operations set up for boolean types in GNU_CODES above. */
7082 if (Is_Modular_Integer_Type (Underlying_Type (Etype (gnat_node))))
7083 switch (kind)
7084 {
7085 case N_Op_And:
7086 code = BIT_AND_EXPR;
7087 break;
7088 case N_Op_Or:
7089 code = BIT_IOR_EXPR;
7090 break;
7091 case N_Op_Xor:
7092 code = BIT_XOR_EXPR;
7093 break;
7094 default:
7095 break;
7096 }
7097
7098 gnu_lhs = gnat_to_gnu (Left_Opnd (gnat_node));
7099 gnu_rhs = gnat_to_gnu (Right_Opnd (gnat_node));
7100 gnu_type = gnu_result_type = get_unpadded_type (Etype (gnat_node));
7101
7102 /* If this is a shift, take the count as unsigned since that is what
7103 most machines do and will generate simpler adjustments below. */
7104 if (IN (kind, N_Op_Shift))
7105 {
7106 tree gnu_count_type
7107 = gnat_unsigned_type_for (get_base_type (TREE_TYPE (gnu_rhs)));
7108 gnu_rhs = convert (gnu_count_type, gnu_rhs);
7109 gnu_max_shift
7110 = convert (TREE_TYPE (gnu_rhs), TYPE_SIZE (gnu_type));
7111 }
7112
7113 /* Pending generic support for efficient vector logical operations in
7114 GCC, convert vectors to their representative array type view and
7115 fallthrough. */
7116 gnu_lhs = maybe_vector_array (gnu_lhs);
7117 gnu_rhs = maybe_vector_array (gnu_rhs);
7118
7119 /* If this is a comparison operator, convert any references to an
7120 unconstrained array value into a reference to the actual array. */
7121 if (TREE_CODE_CLASS (code) == tcc_comparison)
7122 {
7123 gnu_lhs = maybe_unconstrained_array (gnu_lhs);
7124 gnu_rhs = maybe_unconstrained_array (gnu_rhs);
7125
7126 tree gnu_op_type = maybe_character_type (TREE_TYPE (gnu_lhs));
7127 if (TREE_TYPE (gnu_lhs) != gnu_op_type)
7128 {
7129 gnu_lhs = convert (gnu_op_type, gnu_lhs);
7130 gnu_rhs = convert (gnu_op_type, gnu_rhs);
7131 }
7132 }
7133
7134 /* If this is a shift whose count is not guaranteed to be correct,
7135 we need to adjust the shift count. */
7136 if ((kind == N_Op_Rotate_Left || kind == N_Op_Rotate_Right)
7137 && !Shift_Count_OK (gnat_node))
7138 gnu_rhs = build_binary_op (TRUNC_MOD_EXPR, TREE_TYPE (gnu_rhs),
7139 gnu_rhs, gnu_max_shift);
7140 else if (kind == N_Op_Shift_Right_Arithmetic
7141 && !Shift_Count_OK (gnat_node))
7142 gnu_rhs
7143 = build_binary_op (MIN_EXPR, TREE_TYPE (gnu_rhs),
7144 build_binary_op (MINUS_EXPR,
7145 TREE_TYPE (gnu_rhs),
7146 gnu_max_shift,
7147 build_int_cst
7148 (TREE_TYPE (gnu_rhs), 1)),
7149 gnu_rhs);
7150
7151 /* For right shifts, the type says what kind of shift to do,
7152 so we may need to choose a different type. In this case,
7153 we have to ignore integer overflow lest it propagates all
7154 the way down and causes a CE to be explicitly raised. */
7155 if (kind == N_Op_Shift_Right && !TYPE_UNSIGNED (gnu_type))
7156 {
7157 gnu_type = gnat_unsigned_type_for (gnu_type);
7158 ignore_lhs_overflow = true;
7159 }
7160 else if (kind == N_Op_Shift_Right_Arithmetic
7161 && TYPE_UNSIGNED (gnu_type))
7162 {
7163 gnu_type = gnat_signed_type_for (gnu_type);
7164 ignore_lhs_overflow = true;
7165 }
7166
7167 if (gnu_type != gnu_result_type)
7168 {
7169 tree gnu_old_lhs = gnu_lhs;
7170 gnu_lhs = convert (gnu_type, gnu_lhs);
7171 if (TREE_CODE (gnu_lhs) == INTEGER_CST && ignore_lhs_overflow)
7172 TREE_OVERFLOW (gnu_lhs) = TREE_OVERFLOW (gnu_old_lhs);
7173 gnu_rhs = convert (gnu_type, gnu_rhs);
7174 if (gnu_max_shift)
7175 gnu_max_shift = convert (gnu_type, gnu_max_shift);
7176 }
7177
7178 /* For signed integer addition, subtraction and multiplication, do an
7179 overflow check if required. */
7180 if (Do_Overflow_Check (gnat_node)
7181 && (code == PLUS_EXPR || code == MINUS_EXPR || code == MULT_EXPR)
7182 && !TYPE_UNSIGNED (gnu_type)
7183 && !FLOAT_TYPE_P (gnu_type))
7184 gnu_result
7185 = build_binary_op_trapv (code, gnu_type, gnu_lhs, gnu_rhs,
7186 gnat_node);
7187 else
7188 {
7189 /* Some operations, e.g. comparisons of arrays, generate complex
7190 trees that need to be annotated while they are being built. */
7191 input_location = saved_location;
7192 gnu_result = build_binary_op (code, gnu_type, gnu_lhs, gnu_rhs);
7193 }
7194
7195 /* If this is a logical shift with the shift count not verified,
7196 we must return zero if it is too large. We cannot compensate
7197 beforehand in this case. */
7198 if ((kind == N_Op_Shift_Left || kind == N_Op_Shift_Right)
7199 && !Shift_Count_OK (gnat_node))
7200 gnu_result
7201 = build_cond_expr (gnu_type,
7202 build_binary_op (GE_EXPR, boolean_type_node,
7203 gnu_rhs, gnu_max_shift),
7204 build_int_cst (gnu_type, 0),
7205 gnu_result);
7206 }
7207 break;
7208
7209 case N_If_Expression:
7210 {
7211 tree gnu_cond = gnat_to_gnu (First (Expressions (gnat_node)));
7212 tree gnu_true = gnat_to_gnu (Next (First (Expressions (gnat_node))));
7213 tree gnu_false
7214 = gnat_to_gnu (Next (Next (First (Expressions (gnat_node)))));
7215
7216 gnu_result_type = get_unpadded_type (Etype (gnat_node));
7217 gnu_result
7218 = build_cond_expr (gnu_result_type, gnu_cond, gnu_true, gnu_false);
7219 }
7220 break;
7221
7222 case N_Op_Plus:
7223 gnu_result = gnat_to_gnu (Right_Opnd (gnat_node));
7224 gnu_result_type = get_unpadded_type (Etype (gnat_node));
7225 break;
7226
7227 case N_Op_Not:
7228 /* This case can apply to a boolean or a modular type.
7229 Fall through for a boolean operand since GNU_CODES is set
7230 up to handle this. */
7231 if (Is_Modular_Integer_Type (Underlying_Type (Etype (gnat_node))))
7232 {
7233 gnu_expr = gnat_to_gnu (Right_Opnd (gnat_node));
7234 gnu_result_type = get_unpadded_type (Etype (gnat_node));
7235 gnu_result = build_unary_op (BIT_NOT_EXPR, gnu_result_type,
7236 gnu_expr);
7237 break;
7238 }
7239
7240 /* ... fall through ... */
7241
7242 case N_Op_Minus:
7243 case N_Op_Abs:
7244 gnu_expr = gnat_to_gnu (Right_Opnd (gnat_node));
7245 gnu_result_type = get_unpadded_type (Etype (gnat_node));
7246
7247 /* For signed integer negation and absolute value, do an overflow check
7248 if required. */
7249 if (Do_Overflow_Check (gnat_node)
7250 && !TYPE_UNSIGNED (gnu_result_type)
7251 && !FLOAT_TYPE_P (gnu_result_type))
7252 gnu_result
7253 = build_unary_op_trapv (gnu_codes[kind], gnu_result_type, gnu_expr,
7254 gnat_node);
7255 else
7256 gnu_result
7257 = build_unary_op (gnu_codes[kind], gnu_result_type, gnu_expr);
7258 break;
7259
7260 case N_Allocator:
7261 {
7262 tree gnu_type, gnu_init;
7263 bool ignore_init_type;
7264
7265 gnat_temp = Expression (gnat_node);
7266
7267 /* The expression can be either an N_Identifier or an Expanded_Name,
7268 which must represent a type, or a N_Qualified_Expression, which
7269 contains both the type and an initial value for the object. */
7270 if (Nkind (gnat_temp) == N_Identifier
7271 || Nkind (gnat_temp) == N_Expanded_Name)
7272 {
7273 ignore_init_type = false;
7274 gnu_init = NULL_TREE;
7275 gnu_type = gnat_to_gnu_type (Entity (gnat_temp));
7276 }
7277
7278 else if (Nkind (gnat_temp) == N_Qualified_Expression)
7279 {
7280 const Entity_Id gnat_desig_type
7281 = Designated_Type (Underlying_Type (Etype (gnat_node)));
7282
7283 ignore_init_type = Has_Constrained_Partial_View (gnat_desig_type);
7284
7285 gnu_init = gnat_to_gnu (Expression (gnat_temp));
7286 gnu_init = maybe_unconstrained_array (gnu_init);
7287
7288 gigi_checking_assert (!Do_Range_Check (Expression (gnat_temp)));
7289
7290 if (Is_Elementary_Type (gnat_desig_type)
7291 || Is_Constrained (gnat_desig_type))
7292 gnu_type = gnat_to_gnu_type (gnat_desig_type);
7293 else
7294 {
7295 gnu_type = gnat_to_gnu_type (Etype (Expression (gnat_temp)));
7296 if (TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE)
7297 gnu_type = TREE_TYPE (gnu_init);
7298 }
7299
7300 /* See the N_Qualified_Expression case for the rationale. */
7301 if (Is_Tagged_Type (gnat_desig_type))
7302 used_types_insert (gnu_type);
7303
7304 gnu_init = convert (gnu_type, gnu_init);
7305 }
7306 else
7307 gcc_unreachable ();
7308
7309 gnu_result_type = get_unpadded_type (Etype (gnat_node));
7310 return build_allocator (gnu_type, gnu_init, gnu_result_type,
7311 Procedure_To_Call (gnat_node),
7312 Storage_Pool (gnat_node), gnat_node,
7313 ignore_init_type);
7314 }
7315 break;
7316
7317 /**************************/
7318 /* Chapter 5: Statements */
7319 /**************************/
7320
7321 case N_Label:
7322 gnu_result = build1 (LABEL_EXPR, void_type_node,
7323 gnat_to_gnu (Identifier (gnat_node)));
7324 break;
7325
7326 case N_Null_Statement:
7327 /* When not optimizing, turn null statements from source into gotos to
7328 the next statement that the middle-end knows how to preserve. */
7329 if (!optimize && Comes_From_Source (gnat_node))
7330 {
7331 tree stmt, label = create_label_decl (NULL_TREE, gnat_node);
7332 DECL_IGNORED_P (label) = 1;
7333 start_stmt_group ();
7334 stmt = build1 (GOTO_EXPR, void_type_node, label);
7335 set_expr_location_from_node (stmt, gnat_node);
7336 add_stmt (stmt);
7337 stmt = build1 (LABEL_EXPR, void_type_node, label);
7338 set_expr_location_from_node (stmt, gnat_node);
7339 add_stmt (stmt);
7340 gnu_result = end_stmt_group ();
7341 }
7342 else
7343 gnu_result = alloc_stmt_list ();
7344 break;
7345
7346 case N_Assignment_Statement:
7347 /* Get the LHS and RHS of the statement and convert any reference to an
7348 unconstrained array into a reference to the underlying array. */
7349 gnu_lhs = maybe_unconstrained_array (gnat_to_gnu (Name (gnat_node)));
7350
7351 /* If the type has a size that overflows, convert this into raise of
7352 Storage_Error: execution shouldn't have gotten here anyway. */
7353 if (TREE_CODE (TYPE_SIZE_UNIT (TREE_TYPE (gnu_lhs))) == INTEGER_CST
7354 && !valid_constant_size_p (TYPE_SIZE_UNIT (TREE_TYPE (gnu_lhs))))
7355 gnu_result = build_call_raise (SE_Object_Too_Large, gnat_node,
7356 N_Raise_Storage_Error);
7357 else if (Nkind (Expression (gnat_node)) == N_Function_Call)
7358 {
7359 get_atomic_access (Name (gnat_node), &aa_type, &aa_sync);
7360 gnu_result
7361 = Call_to_gnu (Expression (gnat_node), &gnu_result_type, gnu_lhs,
7362 aa_type, aa_sync);
7363 }
7364 else
7365 {
7366 const Node_Id gnat_expr = Expression (gnat_node);
7367 const Node_Id gnat_inner
7368 = Nkind (gnat_expr) == N_Qualified_Expression
7369 ? Expression (gnat_expr)
7370 : gnat_expr;
7371 const Entity_Id gnat_type
7372 = Underlying_Type (Etype (Name (gnat_node)));
7373 const bool use_memset_p
7374 = Is_Array_Type (gnat_type)
7375 && Nkind (gnat_inner) == N_Aggregate
7376 && Is_Single_Aggregate (gnat_inner);
7377
7378 /* If we use memset, we need to find the innermost expression. */
7379 if (use_memset_p)
7380 {
7381 gnat_temp = gnat_inner;
7382 do {
7383 gnat_temp
7384 = Expression (First (Component_Associations (gnat_temp)));
7385 } while (Nkind (gnat_temp) == N_Aggregate
7386 && Is_Single_Aggregate (gnat_temp));
7387 gnu_rhs = gnat_to_gnu (gnat_temp);
7388 }
7389 else
7390 gnu_rhs = maybe_unconstrained_array (gnat_to_gnu (gnat_expr));
7391
7392 gigi_checking_assert (!Do_Range_Check (gnat_expr));
7393
7394 get_atomic_access (Name (gnat_node), &aa_type, &aa_sync);
7395
7396 /* If an outer atomic access is required on the LHS, build the load-
7397 modify-store sequence. */
7398 if (aa_type == OUTER_ATOMIC)
7399 gnu_result = build_load_modify_store (gnu_lhs, gnu_rhs, gnat_node);
7400
7401 /* Or else, if a simple atomic access is required, build the atomic
7402 store. */
7403 else if (aa_type == SIMPLE_ATOMIC)
7404 gnu_result = build_atomic_store (gnu_lhs, gnu_rhs, aa_sync);
7405
7406 /* Or else, use memset when the conditions are met. This has already
7407 been validated by Aggr_Assignment_OK_For_Backend in the front-end
7408 and the RHS is thus guaranteed to be of the appropriate form. */
7409 else if (use_memset_p)
7410 {
7411 tree value
7412 = real_zerop (gnu_rhs)
7413 ? integer_zero_node
7414 : fold_convert (integer_type_node, gnu_rhs);
7415 tree dest = build_fold_addr_expr (gnu_lhs);
7416 tree t = builtin_decl_explicit (BUILT_IN_MEMSET);
7417 /* Be extra careful not to write too much data. */
7418 tree size;
7419 if (TREE_CODE (gnu_lhs) == COMPONENT_REF)
7420 size = DECL_SIZE_UNIT (TREE_OPERAND (gnu_lhs, 1));
7421 else if (DECL_P (gnu_lhs))
7422 size = DECL_SIZE_UNIT (gnu_lhs);
7423 else
7424 size = TYPE_SIZE_UNIT (TREE_TYPE (gnu_lhs));
7425 size = SUBSTITUTE_PLACEHOLDER_IN_EXPR (size, gnu_lhs);
7426 if (TREE_CODE (value) == INTEGER_CST && !integer_zerop (value))
7427 {
7428 tree mask
7429 = build_int_cst (integer_type_node,
7430 ((HOST_WIDE_INT) 1 << BITS_PER_UNIT) - 1);
7431 value = int_const_binop (BIT_AND_EXPR, value, mask);
7432 }
7433 gnu_result = build_call_expr (t, 3, dest, value, size);
7434 }
7435
7436 /* Otherwise build a regular assignment. */
7437 else
7438 gnu_result
7439 = build_binary_op (MODIFY_EXPR, NULL_TREE, gnu_lhs, gnu_rhs);
7440
7441 /* If the assignment type is a regular array and the two sides are
7442 not completely disjoint, play safe and use memmove. But don't do
7443 it for a bit-packed array as it might not be byte-aligned. */
7444 if (TREE_CODE (gnu_result) == MODIFY_EXPR
7445 && Is_Array_Type (gnat_type)
7446 && !Is_Bit_Packed_Array (gnat_type)
7447 && !(Forwards_OK (gnat_node) && Backwards_OK (gnat_node)))
7448 {
7449 tree to = TREE_OPERAND (gnu_result, 0);
7450 tree from = TREE_OPERAND (gnu_result, 1);
7451 tree type = TREE_TYPE (from);
7452 tree size
7453 = SUBSTITUTE_PLACEHOLDER_IN_EXPR (TYPE_SIZE_UNIT (type), from);
7454 tree to_ptr = build_fold_addr_expr (to);
7455 tree from_ptr = build_fold_addr_expr (from);
7456 tree t = builtin_decl_explicit (BUILT_IN_MEMMOVE);
7457 gnu_result = build_call_expr (t, 3, to_ptr, from_ptr, size);
7458 }
7459 }
7460 break;
7461
7462 case N_If_Statement:
7463 {
7464 tree *gnu_else_ptr; /* Point to put next "else if" or "else". */
7465
7466 /* Make the outer COND_EXPR. Avoid non-determinism. */
7467 gnu_result = build3 (COND_EXPR, void_type_node,
7468 gnat_to_gnu (Condition (gnat_node)),
7469 NULL_TREE, NULL_TREE);
7470 COND_EXPR_THEN (gnu_result)
7471 = build_stmt_group (Then_Statements (gnat_node), false);
7472 TREE_SIDE_EFFECTS (gnu_result) = 1;
7473 gnu_else_ptr = &COND_EXPR_ELSE (gnu_result);
7474
7475 /* Now make a COND_EXPR for each of the "else if" parts. Put each
7476 into the previous "else" part and point to where to put any
7477 outer "else". Also avoid non-determinism. */
7478 if (Present (Elsif_Parts (gnat_node)))
7479 for (gnat_temp = First (Elsif_Parts (gnat_node));
7480 Present (gnat_temp); gnat_temp = Next (gnat_temp))
7481 {
7482 gnu_expr = build3 (COND_EXPR, void_type_node,
7483 gnat_to_gnu (Condition (gnat_temp)),
7484 NULL_TREE, NULL_TREE);
7485 COND_EXPR_THEN (gnu_expr)
7486 = build_stmt_group (Then_Statements (gnat_temp), false);
7487 TREE_SIDE_EFFECTS (gnu_expr) = 1;
7488 set_expr_location_from_node (gnu_expr, gnat_temp);
7489 *gnu_else_ptr = gnu_expr;
7490 gnu_else_ptr = &COND_EXPR_ELSE (gnu_expr);
7491 }
7492
7493 *gnu_else_ptr = build_stmt_group (Else_Statements (gnat_node), false);
7494 }
7495 break;
7496
7497 case N_Case_Statement:
7498 gnu_result = Case_Statement_to_gnu (gnat_node);
7499 break;
7500
7501 case N_Loop_Statement:
7502 gnu_result = Loop_Statement_to_gnu (gnat_node);
7503 break;
7504
7505 case N_Block_Statement:
7506 /* The only way to enter the block is to fall through to it. */
7507 if (stmt_group_may_fallthru ())
7508 {
7509 start_stmt_group ();
7510 gnat_pushlevel ();
7511 process_decls (Declarations (gnat_node), Empty, Empty, true, true);
7512 add_stmt (gnat_to_gnu (Handled_Statement_Sequence (gnat_node)));
7513 gnat_poplevel ();
7514 gnu_result = end_stmt_group ();
7515 }
7516 else
7517 gnu_result = alloc_stmt_list ();
7518 break;
7519
7520 case N_Exit_Statement:
7521 gnu_result
7522 = build2 (EXIT_STMT, void_type_node,
7523 (Present (Condition (gnat_node))
7524 ? gnat_to_gnu (Condition (gnat_node)) : NULL_TREE),
7525 (Present (Name (gnat_node))
7526 ? get_gnu_tree (Entity (Name (gnat_node)))
7527 : LOOP_STMT_LABEL (gnu_loop_stack->last ()->stmt)));
7528 break;
7529
7530 case N_Simple_Return_Statement:
7531 {
7532 tree gnu_ret_obj, gnu_ret_val;
7533
7534 /* If the subprogram is a function, we must return the expression. */
7535 if (Present (Expression (gnat_node)))
7536 {
7537 tree gnu_subprog_type = TREE_TYPE (current_function_decl);
7538
7539 /* If this function has copy-in/copy-out parameters parameters and
7540 doesn't return by invisible reference, get the real object for
7541 the return. See Subprogram_Body_to_gnu. */
7542 if (TYPE_CI_CO_LIST (gnu_subprog_type)
7543 && !TREE_ADDRESSABLE (gnu_subprog_type))
7544 gnu_ret_obj = gnu_return_var_stack->last ();
7545 else
7546 gnu_ret_obj = DECL_RESULT (current_function_decl);
7547
7548 /* Get the GCC tree for the expression to be returned. */
7549 gnu_ret_val = gnat_to_gnu (Expression (gnat_node));
7550
7551 /* Do not remove the padding from GNU_RET_VAL if the inner type is
7552 self-referential since we want to allocate the fixed size. */
7553 if (TREE_CODE (gnu_ret_val) == COMPONENT_REF
7554 && type_is_padding_self_referential
7555 (TREE_TYPE (TREE_OPERAND (gnu_ret_val, 0))))
7556 gnu_ret_val = TREE_OPERAND (gnu_ret_val, 0);
7557
7558 /* If the function returns by direct reference, return a pointer
7559 to the return value. */
7560 if (TYPE_RETURN_BY_DIRECT_REF_P (gnu_subprog_type)
7561 || By_Ref (gnat_node))
7562 gnu_ret_val = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_ret_val);
7563
7564 /* Otherwise, if it returns an unconstrained array, we have to
7565 allocate a new version of the result and return it. */
7566 else if (TYPE_RETURN_UNCONSTRAINED_P (gnu_subprog_type))
7567 {
7568 gnu_ret_val = maybe_unconstrained_array (gnu_ret_val);
7569
7570 /* And find out whether this is a candidate for Named Return
7571 Value. If so, record it. */
7572 if (optimize
7573 && !optimize_debug
7574 && !TYPE_CI_CO_LIST (gnu_subprog_type))
7575 {
7576 tree ret_val = gnu_ret_val;
7577
7578 /* Strip useless conversions around the return value. */
7579 if (gnat_useless_type_conversion (ret_val))
7580 ret_val = TREE_OPERAND (ret_val, 0);
7581
7582 /* Strip unpadding around the return value. */
7583 if (TREE_CODE (ret_val) == COMPONENT_REF
7584 && TYPE_IS_PADDING_P
7585 (TREE_TYPE (TREE_OPERAND (ret_val, 0))))
7586 ret_val = TREE_OPERAND (ret_val, 0);
7587
7588 /* Now apply the test to the return value. */
7589 if (return_value_ok_for_nrv_p (NULL_TREE, ret_val))
7590 {
7591 if (!f_named_ret_val)
7592 f_named_ret_val = BITMAP_GGC_ALLOC ();
7593 bitmap_set_bit (f_named_ret_val, DECL_UID (ret_val));
7594 if (!f_gnat_ret)
7595 f_gnat_ret = gnat_node;
7596 }
7597 }
7598
7599 gnu_ret_val = build_allocator (TREE_TYPE (gnu_ret_val),
7600 gnu_ret_val,
7601 TREE_TYPE (gnu_ret_obj),
7602 Procedure_To_Call (gnat_node),
7603 Storage_Pool (gnat_node),
7604 gnat_node, false);
7605 }
7606
7607 /* Otherwise, if it returns by invisible reference, dereference
7608 the pointer it is passed using the type of the return value
7609 and build the copy operation manually. This ensures that we
7610 don't copy too much data, for example if the return type is
7611 unconstrained with a maximum size. */
7612 else if (TREE_ADDRESSABLE (gnu_subprog_type))
7613 {
7614 tree gnu_ret_deref
7615 = build_unary_op (INDIRECT_REF, TREE_TYPE (gnu_ret_val),
7616 gnu_ret_obj);
7617 gnu_result = build2 (INIT_EXPR, void_type_node,
7618 gnu_ret_deref, gnu_ret_val);
7619 add_stmt_with_node (gnu_result, gnat_node);
7620 gnu_ret_val = NULL_TREE;
7621 }
7622 }
7623
7624 else
7625 gnu_ret_obj = gnu_ret_val = NULL_TREE;
7626
7627 /* If we have a return label defined, convert this into a branch to
7628 that label. The return proper will be handled elsewhere. */
7629 if (gnu_return_label_stack->last ())
7630 {
7631 if (gnu_ret_val)
7632 add_stmt_with_node (build_binary_op (MODIFY_EXPR,
7633 NULL_TREE, gnu_ret_obj,
7634 gnu_ret_val),
7635 gnat_node);
7636
7637 gnu_result = build1 (GOTO_EXPR, void_type_node,
7638 gnu_return_label_stack->last ());
7639
7640 /* When not optimizing, make sure the return is preserved. */
7641 if (!optimize && Comes_From_Source (gnat_node))
7642 DECL_ARTIFICIAL (gnu_return_label_stack->last ()) = 0;
7643 }
7644
7645 /* Otherwise, build a regular return. */
7646 else
7647 gnu_result = build_return_expr (gnu_ret_obj, gnu_ret_val);
7648 }
7649 break;
7650
7651 case N_Goto_Statement:
7652 gnu_expr = gnat_to_gnu (Name (gnat_node));
7653 gnu_result = build1 (GOTO_EXPR, void_type_node, gnu_expr);
7654 TREE_USED (gnu_expr) = 1;
7655 break;
7656
7657 /***************************/
7658 /* Chapter 6: Subprograms */
7659 /***************************/
7660
7661 case N_Subprogram_Declaration:
7662 /* Unless there is a freeze node, declare the entity. We consider
7663 this a definition even though we're not generating code for the
7664 subprogram because we will be making the corresponding GCC node.
7665 When there is a freeze node, it is considered the definition of
7666 the subprogram and we do nothing until after it is encountered.
7667 That's an efficiency issue: the types involved in the profile
7668 are far more likely to be frozen between the declaration and
7669 the freeze node than before the declaration, so we save some
7670 updates of the GCC node by waiting until the freeze node.
7671 The counterpart is that we assume that there is no reference
7672 to the subprogram between the declaration and the freeze node
7673 in the expanded code; otherwise, it will be interpreted as an
7674 external reference and very likely give rise to a link failure. */
7675 if (No (Freeze_Node (Defining_Entity (Specification (gnat_node)))))
7676 gnat_to_gnu_entity (Defining_Entity (Specification (gnat_node)),
7677 NULL_TREE, true);
7678 gnu_result = alloc_stmt_list ();
7679 break;
7680
7681 case N_Abstract_Subprogram_Declaration:
7682 /* This subprogram doesn't exist for code generation purposes, but we
7683 have to elaborate the types of any parameters and result, unless
7684 they are imported types (nothing to generate in this case).
7685
7686 The parameter list may contain types with freeze nodes, e.g. not null
7687 subtypes, so the subprogram itself may carry a freeze node, in which
7688 case its elaboration must be deferred. */
7689
7690 /* Process the parameter types first. */
7691 if (No (Freeze_Node (Defining_Entity (Specification (gnat_node)))))
7692 for (gnat_temp
7693 = First_Formal_With_Extras
7694 (Defining_Entity (Specification (gnat_node)));
7695 Present (gnat_temp);
7696 gnat_temp = Next_Formal_With_Extras (gnat_temp))
7697 if (Is_Itype (Etype (gnat_temp))
7698 && !From_Limited_With (Etype (gnat_temp)))
7699 gnat_to_gnu_entity (Etype (gnat_temp), NULL_TREE, false);
7700
7701 /* Then the result type, set to Standard_Void_Type for procedures. */
7702 {
7703 Entity_Id gnat_temp_type
7704 = Etype (Defining_Entity (Specification (gnat_node)));
7705
7706 if (Is_Itype (gnat_temp_type) && !From_Limited_With (gnat_temp_type))
7707 gnat_to_gnu_entity (Etype (gnat_temp_type), NULL_TREE, false);
7708 }
7709
7710 gnu_result = alloc_stmt_list ();
7711 break;
7712
7713 case N_Defining_Program_Unit_Name:
7714 /* For a child unit identifier go up a level to get the specification.
7715 We get this when we try to find the spec of a child unit package
7716 that is the compilation unit being compiled. */
7717 gnu_result = gnat_to_gnu (Parent (gnat_node));
7718 break;
7719
7720 case N_Subprogram_Body:
7721 Subprogram_Body_to_gnu (gnat_node);
7722 gnu_result = alloc_stmt_list ();
7723 break;
7724
7725 case N_Function_Call:
7726 case N_Procedure_Call_Statement:
7727 gnu_result = Call_to_gnu (gnat_node, &gnu_result_type, NULL_TREE,
7728 NOT_ATOMIC, false);
7729 break;
7730
7731 /************************/
7732 /* Chapter 7: Packages */
7733 /************************/
7734
7735 case N_Package_Declaration:
7736 gnu_result = gnat_to_gnu (Specification (gnat_node));
7737 break;
7738
7739 case N_Package_Specification:
7740
7741 start_stmt_group ();
7742 process_decls (Visible_Declarations (gnat_node),
7743 Private_Declarations (gnat_node), Empty, true, true);
7744 gnu_result = end_stmt_group ();
7745 break;
7746
7747 case N_Package_Body:
7748
7749 /* If this is the body of a generic package - do nothing. */
7750 if (Ekind (Corresponding_Spec (gnat_node)) == E_Generic_Package)
7751 {
7752 gnu_result = alloc_stmt_list ();
7753 break;
7754 }
7755
7756 start_stmt_group ();
7757 process_decls (Declarations (gnat_node), Empty, Empty, true, true);
7758
7759 if (Present (Handled_Statement_Sequence (gnat_node)))
7760 add_stmt (gnat_to_gnu (Handled_Statement_Sequence (gnat_node)));
7761
7762 gnu_result = end_stmt_group ();
7763 break;
7764
7765 /********************************/
7766 /* Chapter 8: Visibility Rules */
7767 /********************************/
7768
7769 case N_Use_Package_Clause:
7770 case N_Use_Type_Clause:
7771 /* Nothing to do here - but these may appear in list of declarations. */
7772 gnu_result = alloc_stmt_list ();
7773 break;
7774
7775 /*********************/
7776 /* Chapter 9: Tasks */
7777 /*********************/
7778
7779 case N_Protected_Type_Declaration:
7780 gnu_result = alloc_stmt_list ();
7781 break;
7782
7783 case N_Single_Task_Declaration:
7784 gnat_to_gnu_entity (Defining_Entity (gnat_node), NULL_TREE, true);
7785 gnu_result = alloc_stmt_list ();
7786 break;
7787
7788 /*********************************************************/
7789 /* Chapter 10: Program Structure and Compilation Issues */
7790 /*********************************************************/
7791
7792 case N_Compilation_Unit:
7793 /* This is not called for the main unit on which gigi is invoked. */
7794 Compilation_Unit_to_gnu (gnat_node);
7795 gnu_result = alloc_stmt_list ();
7796 break;
7797
7798 case N_Subunit:
7799 gnu_result = gnat_to_gnu (Proper_Body (gnat_node));
7800 break;
7801
7802 case N_Entry_Body:
7803 case N_Protected_Body:
7804 case N_Task_Body:
7805 /* These nodes should only be present when annotating types. */
7806 gcc_assert (type_annotate_only);
7807 process_decls (Declarations (gnat_node), Empty, Empty, true, true);
7808 gnu_result = alloc_stmt_list ();
7809 break;
7810
7811 case N_Subprogram_Body_Stub:
7812 case N_Package_Body_Stub:
7813 case N_Protected_Body_Stub:
7814 case N_Task_Body_Stub:
7815 /* Simply process whatever unit is being inserted. */
7816 if (Present (Library_Unit (gnat_node)))
7817 gnu_result = gnat_to_gnu (Unit (Library_Unit (gnat_node)));
7818 else
7819 {
7820 gcc_assert (type_annotate_only);
7821 gnu_result = alloc_stmt_list ();
7822 }
7823 break;
7824
7825 /***************************/
7826 /* Chapter 11: Exceptions */
7827 /***************************/
7828
7829 case N_Handled_Sequence_Of_Statements:
7830 /* If there is an At_End procedure attached to this node, and the EH
7831 mechanism is front-end, we must have at least a corresponding At_End
7832 handler, unless the No_Exception_Handlers restriction is set. */
7833 gcc_assert (type_annotate_only
7834 || !Front_End_Exceptions ()
7835 || No (At_End_Proc (gnat_node))
7836 || Present (Exception_Handlers (gnat_node))
7837 || No_Exception_Handlers_Set ());
7838
7839 gnu_result = Handled_Sequence_Of_Statements_to_gnu (gnat_node);
7840 break;
7841
7842 case N_Exception_Handler:
7843 if (Back_End_Exceptions ())
7844 gnu_result = Exception_Handler_to_gnu_gcc (gnat_node);
7845 else if (Exception_Mechanism == Front_End_SJLJ)
7846 gnu_result = Exception_Handler_to_gnu_fe_sjlj (gnat_node);
7847 else
7848 gcc_unreachable ();
7849 break;
7850
7851 case N_Raise_Statement:
7852 /* Only for reraise in back-end exceptions mode. */
7853 gcc_assert (No (Name (gnat_node)) && Back_End_Exceptions ());
7854
7855 start_stmt_group ();
7856
7857 add_stmt_with_node (build_call_n_expr (reraise_zcx_decl, 1,
7858 gnu_incoming_exc_ptr),
7859 gnat_node);
7860
7861 gnu_result = end_stmt_group ();
7862 break;
7863
7864 case N_Push_Constraint_Error_Label:
7865 gnu_constraint_error_label_stack.safe_push (Exception_Label (gnat_node));
7866 break;
7867
7868 case N_Push_Storage_Error_Label:
7869 gnu_storage_error_label_stack.safe_push (Exception_Label (gnat_node));
7870 break;
7871
7872 case N_Push_Program_Error_Label:
7873 gnu_program_error_label_stack.safe_push (Exception_Label (gnat_node));
7874 break;
7875
7876 case N_Pop_Constraint_Error_Label:
7877 gnat_temp = gnu_constraint_error_label_stack.pop ();
7878 if (Present (gnat_temp)
7879 && !TREE_USED (gnat_to_gnu_entity (gnat_temp, NULL_TREE, false))
7880 && No_Exception_Propagation_Active ())
7881 Warn_If_No_Local_Raise (gnat_temp);
7882 break;
7883
7884 case N_Pop_Storage_Error_Label:
7885 gnat_temp = gnu_storage_error_label_stack.pop ();
7886 if (Present (gnat_temp)
7887 && !TREE_USED (gnat_to_gnu_entity (gnat_temp, NULL_TREE, false))
7888 && No_Exception_Propagation_Active ())
7889 Warn_If_No_Local_Raise (gnat_temp);
7890 break;
7891
7892 case N_Pop_Program_Error_Label:
7893 gnat_temp = gnu_program_error_label_stack.pop ();
7894 if (Present (gnat_temp)
7895 && !TREE_USED (gnat_to_gnu_entity (gnat_temp, NULL_TREE, false))
7896 && No_Exception_Propagation_Active ())
7897 Warn_If_No_Local_Raise (gnat_temp);
7898 break;
7899
7900 /******************************/
7901 /* Chapter 12: Generic Units */
7902 /******************************/
7903
7904 case N_Generic_Function_Renaming_Declaration:
7905 case N_Generic_Package_Renaming_Declaration:
7906 case N_Generic_Procedure_Renaming_Declaration:
7907 case N_Generic_Package_Declaration:
7908 case N_Generic_Subprogram_Declaration:
7909 case N_Package_Instantiation:
7910 case N_Procedure_Instantiation:
7911 case N_Function_Instantiation:
7912 /* These nodes can appear on a declaration list but there is nothing to
7913 to be done with them. */
7914 gnu_result = alloc_stmt_list ();
7915 break;
7916
7917 /**************************************************/
7918 /* Chapter 13: Representation Clauses and */
7919 /* Implementation-Dependent Features */
7920 /**************************************************/
7921
7922 case N_Attribute_Definition_Clause:
7923 gnu_result = alloc_stmt_list ();
7924
7925 /* The only one we need to deal with is 'Address since, for the others,
7926 the front-end puts the information elsewhere. */
7927 if (Get_Attribute_Id (Chars (gnat_node)) != Attr_Address)
7928 break;
7929
7930 /* And we only deal with 'Address if the object has a Freeze node. */
7931 gnat_temp = Entity (Name (gnat_node));
7932 if (Freeze_Node (gnat_temp))
7933 {
7934 tree gnu_address = gnat_to_gnu (Expression (gnat_node)), gnu_temp;
7935
7936 /* Get the value to use as the address and save it as the equivalent
7937 for the object; when it is frozen, gnat_to_gnu_entity will do the
7938 right thing. For a subprogram, put the naked address but build a
7939 meaningfull expression for an object in case its address is taken
7940 before the Freeze node is encountered; this can happen if the type
7941 of the object is limited and it is initialized with the result of
7942 a function call. */
7943 if (Is_Subprogram (gnat_temp))
7944 gnu_temp = gnu_address;
7945 else
7946 {
7947 tree gnu_type = gnat_to_gnu_type (Etype (gnat_temp));
7948 /* Drop atomic and volatile qualifiers for the expression. */
7949 gnu_type = TYPE_MAIN_VARIANT (gnu_type);
7950 gnu_type
7951 = build_reference_type_for_mode (gnu_type, ptr_mode, true);
7952 gnu_address = convert (gnu_type, gnu_address);
7953 gnu_temp
7954 = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_address);
7955 }
7956
7957 save_gnu_tree (gnat_temp, gnu_temp, true);
7958 }
7959 break;
7960
7961 case N_Enumeration_Representation_Clause:
7962 case N_Record_Representation_Clause:
7963 case N_At_Clause:
7964 /* We do nothing with these. SEM puts the information elsewhere. */
7965 gnu_result = alloc_stmt_list ();
7966 break;
7967
7968 case N_Code_Statement:
7969 if (!type_annotate_only)
7970 {
7971 tree gnu_template = gnat_to_gnu (Asm_Template (gnat_node));
7972 tree gnu_inputs = NULL_TREE, gnu_outputs = NULL_TREE;
7973 tree gnu_clobbers = NULL_TREE, tail;
7974 bool allows_mem, allows_reg, fake;
7975 int ninputs, noutputs, i;
7976 const char **oconstraints;
7977 const char *constraint;
7978 char *clobber;
7979
7980 /* First retrieve the 3 operand lists built by the front-end. */
7981 Setup_Asm_Outputs (gnat_node);
7982 while (Present (gnat_temp = Asm_Output_Variable ()))
7983 {
7984 tree gnu_value = gnat_to_gnu (gnat_temp);
7985 tree gnu_constr = build_tree_list (NULL_TREE, gnat_to_gnu
7986 (Asm_Output_Constraint ()));
7987
7988 gnu_outputs = tree_cons (gnu_constr, gnu_value, gnu_outputs);
7989 Next_Asm_Output ();
7990 }
7991
7992 Setup_Asm_Inputs (gnat_node);
7993 while (Present (gnat_temp = Asm_Input_Value ()))
7994 {
7995 tree gnu_value = gnat_to_gnu (gnat_temp);
7996 tree gnu_constr = build_tree_list (NULL_TREE, gnat_to_gnu
7997 (Asm_Input_Constraint ()));
7998
7999 gnu_inputs = tree_cons (gnu_constr, gnu_value, gnu_inputs);
8000 Next_Asm_Input ();
8001 }
8002
8003 Clobber_Setup (gnat_node);
8004 while ((clobber = (char *) Clobber_Get_Next ()))
8005 gnu_clobbers
8006 = tree_cons (NULL_TREE,
8007 build_string (strlen (clobber) + 1, clobber),
8008 gnu_clobbers);
8009
8010 /* Then perform some standard checking and processing on the
8011 operands. In particular, mark them addressable if needed. */
8012 gnu_outputs = nreverse (gnu_outputs);
8013 noutputs = list_length (gnu_outputs);
8014 gnu_inputs = nreverse (gnu_inputs);
8015 ninputs = list_length (gnu_inputs);
8016 oconstraints = XALLOCAVEC (const char *, noutputs);
8017
8018 for (i = 0, tail = gnu_outputs; tail; ++i, tail = TREE_CHAIN (tail))
8019 {
8020 tree output = TREE_VALUE (tail);
8021 constraint
8022 = TREE_STRING_POINTER (TREE_VALUE (TREE_PURPOSE (tail)));
8023 oconstraints[i] = constraint;
8024
8025 if (parse_output_constraint (&constraint, i, ninputs, noutputs,
8026 &allows_mem, &allows_reg, &fake))
8027 {
8028 /* If the operand is going to end up in memory,
8029 mark it addressable. Note that we don't test
8030 allows_mem like in the input case below; this
8031 is modeled on the C front-end. */
8032 if (!allows_reg)
8033 {
8034 output = remove_conversions (output, false);
8035 if (TREE_CODE (output) == CONST_DECL
8036 && DECL_CONST_CORRESPONDING_VAR (output))
8037 output = DECL_CONST_CORRESPONDING_VAR (output);
8038 if (!gnat_mark_addressable (output))
8039 output = error_mark_node;
8040 }
8041 }
8042 else
8043 output = error_mark_node;
8044
8045 TREE_VALUE (tail) = output;
8046 }
8047
8048 for (i = 0, tail = gnu_inputs; tail; ++i, tail = TREE_CHAIN (tail))
8049 {
8050 tree input = TREE_VALUE (tail);
8051 constraint
8052 = TREE_STRING_POINTER (TREE_VALUE (TREE_PURPOSE (tail)));
8053
8054 if (parse_input_constraint (&constraint, i, ninputs, noutputs,
8055 0, oconstraints,
8056 &allows_mem, &allows_reg))
8057 {
8058 /* If the operand is going to end up in memory,
8059 mark it addressable. */
8060 if (!allows_reg && allows_mem)
8061 {
8062 input = remove_conversions (input, false);
8063 if (TREE_CODE (input) == CONST_DECL
8064 && DECL_CONST_CORRESPONDING_VAR (input))
8065 input = DECL_CONST_CORRESPONDING_VAR (input);
8066 if (!gnat_mark_addressable (input))
8067 input = error_mark_node;
8068 }
8069 }
8070 else
8071 input = error_mark_node;
8072
8073 TREE_VALUE (tail) = input;
8074 }
8075
8076 gnu_result = build5 (ASM_EXPR, void_type_node,
8077 gnu_template, gnu_outputs,
8078 gnu_inputs, gnu_clobbers, NULL_TREE);
8079 ASM_VOLATILE_P (gnu_result) = Is_Asm_Volatile (gnat_node);
8080 }
8081 else
8082 gnu_result = alloc_stmt_list ();
8083
8084 break;
8085
8086 /****************/
8087 /* Added Nodes */
8088 /****************/
8089
8090 /* Markers are created by the ABE mechanism to capture information which
8091 is either unavailable of expensive to recompute. Markers do not have
8092 and runtime semantics, and should be ignored. */
8093
8094 case N_Call_Marker:
8095 case N_Variable_Reference_Marker:
8096 gnu_result = alloc_stmt_list ();
8097 break;
8098
8099 case N_Expression_With_Actions:
8100 /* This construct doesn't define a scope so we don't push a binding
8101 level around the statement list, but we wrap it in a SAVE_EXPR to
8102 protect it from unsharing. Elaborate the expression as part of the
8103 same statement group as the actions so that the type declaration
8104 gets inserted there as well. This ensures that the type elaboration
8105 code is issued past the actions computing values on which it might
8106 depend. */
8107 start_stmt_group ();
8108 add_stmt_list (Actions (gnat_node));
8109 gnu_expr = gnat_to_gnu (Expression (gnat_node));
8110 gnu_result = end_stmt_group ();
8111
8112 gnu_result = build1 (SAVE_EXPR, void_type_node, gnu_result);
8113 TREE_SIDE_EFFECTS (gnu_result) = 1;
8114
8115 gnu_result
8116 = build_compound_expr (TREE_TYPE (gnu_expr), gnu_result, gnu_expr);
8117 gnu_result_type = get_unpadded_type (Etype (gnat_node));
8118 break;
8119
8120 case N_Freeze_Entity:
8121 start_stmt_group ();
8122 process_freeze_entity (gnat_node);
8123 process_decls (Actions (gnat_node), Empty, Empty, true, true);
8124 gnu_result = end_stmt_group ();
8125 break;
8126
8127 case N_Freeze_Generic_Entity:
8128 gnu_result = alloc_stmt_list ();
8129 break;
8130
8131 case N_Itype_Reference:
8132 if (!present_gnu_tree (Itype (gnat_node)))
8133 process_type (Itype (gnat_node));
8134 gnu_result = alloc_stmt_list ();
8135 break;
8136
8137 case N_Free_Statement:
8138 gnat_temp = Expression (gnat_node);
8139
8140 if (!type_annotate_only)
8141 {
8142 tree gnu_ptr, gnu_ptr_type, gnu_obj_type, gnu_actual_obj_type;
8143
8144 const Entity_Id gnat_desig_type
8145 = Designated_Type (Underlying_Type (Etype (gnat_temp)));
8146
8147 /* Make sure the designated type is complete before dereferencing,
8148 in case it is a Taft Amendment type. */
8149 (void) gnat_to_gnu_entity (gnat_desig_type, NULL_TREE, false);
8150
8151 gnu_ptr = gnat_to_gnu (gnat_temp);
8152 gnu_ptr_type = TREE_TYPE (gnu_ptr);
8153
8154 /* If this is a thin pointer, we must first dereference it to create
8155 a fat pointer, then go back below to a thin pointer. The reason
8156 for this is that we need to have a fat pointer someplace in order
8157 to properly compute the size. */
8158 if (TYPE_IS_THIN_POINTER_P (TREE_TYPE (gnu_ptr)))
8159 gnu_ptr = build_unary_op (ADDR_EXPR, NULL_TREE,
8160 build_unary_op (INDIRECT_REF, NULL_TREE,
8161 gnu_ptr));
8162
8163 /* If this is a fat pointer, the object must have been allocated with
8164 the template in front of the array. So pass the template address,
8165 and get the total size; do it by converting to a thin pointer. */
8166 if (TYPE_IS_FAT_POINTER_P (TREE_TYPE (gnu_ptr)))
8167 gnu_ptr
8168 = convert (build_pointer_type
8169 (TYPE_OBJECT_RECORD_TYPE
8170 (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (gnu_ptr)))),
8171 gnu_ptr);
8172
8173 gnu_obj_type = TREE_TYPE (TREE_TYPE (gnu_ptr));
8174
8175 /* If this is a thin pointer, the object must have been allocated with
8176 the template in front of the array. So pass the template address,
8177 and get the total size. */
8178 if (TYPE_IS_THIN_POINTER_P (TREE_TYPE (gnu_ptr)))
8179 gnu_ptr
8180 = build_binary_op (POINTER_PLUS_EXPR, TREE_TYPE (gnu_ptr),
8181 gnu_ptr,
8182 fold_build1 (NEGATE_EXPR, sizetype,
8183 byte_position
8184 (DECL_CHAIN
8185 TYPE_FIELDS ((gnu_obj_type)))));
8186
8187 /* If we have a special dynamic constrained subtype on the node, use
8188 it to compute the size; otherwise, use the designated subtype. */
8189 if (Present (Actual_Designated_Subtype (gnat_node)))
8190 {
8191 gnu_actual_obj_type
8192 = gnat_to_gnu_type (Actual_Designated_Subtype (gnat_node));
8193
8194 if (TYPE_IS_FAT_OR_THIN_POINTER_P (gnu_ptr_type))
8195 gnu_actual_obj_type
8196 = build_unc_object_type_from_ptr (gnu_ptr_type,
8197 gnu_actual_obj_type,
8198 get_identifier ("DEALLOC"),
8199 false);
8200 }
8201 else
8202 gnu_actual_obj_type = gnu_obj_type;
8203
8204 tree gnu_size = TYPE_SIZE_UNIT (gnu_actual_obj_type);
8205 gnu_size = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_size, gnu_ptr);
8206
8207 gnu_result
8208 = build_call_alloc_dealloc (gnu_ptr, gnu_size, gnu_obj_type,
8209 Procedure_To_Call (gnat_node),
8210 Storage_Pool (gnat_node),
8211 gnat_node);
8212 }
8213 break;
8214
8215 case N_Raise_Constraint_Error:
8216 case N_Raise_Program_Error:
8217 case N_Raise_Storage_Error:
8218 if (type_annotate_only)
8219 gnu_result = alloc_stmt_list ();
8220 else
8221 gnu_result = Raise_Error_to_gnu (gnat_node, &gnu_result_type);
8222 break;
8223
8224 case N_Validate_Unchecked_Conversion:
8225 /* The only validation we currently do on an unchecked conversion is
8226 that of aliasing assumptions. */
8227 if (flag_strict_aliasing)
8228 gnat_validate_uc_list.safe_push (gnat_node);
8229 gnu_result = alloc_stmt_list ();
8230 break;
8231
8232 case N_Function_Specification:
8233 case N_Procedure_Specification:
8234 case N_Op_Concat:
8235 case N_Component_Association:
8236 /* These nodes should only be present when annotating types. */
8237 gcc_assert (type_annotate_only);
8238 gnu_result = alloc_stmt_list ();
8239 break;
8240
8241 default:
8242 /* Other nodes are not supposed to reach here. */
8243 gcc_unreachable ();
8244 }
8245
8246 /* If we are in the elaboration procedure, check if we are violating the
8247 No_Elaboration_Code restriction by having a non-empty statement. */
8248 if (statement_node_p (gnat_node)
8249 && !(TREE_CODE (gnu_result) == STATEMENT_LIST
8250 && empty_stmt_list_p (gnu_result))
8251 && current_function_decl == get_elaboration_procedure ())
8252 Check_Elaboration_Code_Allowed (gnat_node);
8253
8254 /* If we pushed the processing of the elaboration routine, pop it back. */
8255 if (went_into_elab_proc)
8256 current_function_decl = NULL_TREE;
8257
8258 /* When not optimizing, turn boolean rvalues B into B != false tests
8259 so that we can put the location information of the reference to B on
8260 the inequality operator for better debug info. */
8261 if (!optimize
8262 && TREE_CODE (gnu_result) != INTEGER_CST
8263 && TREE_CODE (gnu_result) != TYPE_DECL
8264 && (kind == N_Identifier
8265 || kind == N_Expanded_Name
8266 || kind == N_Explicit_Dereference
8267 || kind == N_Indexed_Component
8268 || kind == N_Selected_Component)
8269 && TREE_CODE (get_base_type (gnu_result_type)) == BOOLEAN_TYPE
8270 && Nkind (Parent (gnat_node)) != N_Attribute_Reference
8271 && Nkind (Parent (gnat_node)) != N_Pragma_Argument_Association
8272 && Nkind (Parent (gnat_node)) != N_Variant_Part
8273 && !lvalue_required_p (gnat_node, gnu_result_type, false, false))
8274 {
8275 gnu_result
8276 = build_binary_op (NE_EXPR, gnu_result_type,
8277 convert (gnu_result_type, gnu_result),
8278 convert (gnu_result_type, boolean_false_node));
8279 if (TREE_CODE (gnu_result) != INTEGER_CST)
8280 set_gnu_expr_location_from_node (gnu_result, gnat_node);
8281 }
8282
8283 /* Set the location information on the result if it's not a simple name
8284 or something that contains a simple name, for example a tag, because
8285 we don"t want all the references to get the location of the first use.
8286 Note that we may have no result if we tried to build a CALL_EXPR node
8287 to a procedure with no side-effects and optimization is enabled. */
8288 else if (kind != N_Identifier
8289 && !(kind == N_Selected_Component
8290 && Chars (Selector_Name (gnat_node)) == Name_uTag)
8291 && gnu_result
8292 && EXPR_P (gnu_result))
8293 set_gnu_expr_location_from_node (gnu_result, gnat_node);
8294
8295 /* If we're supposed to return something of void_type, it means we have
8296 something we're elaborating for effect, so just return. */
8297 if (TREE_CODE (gnu_result_type) == VOID_TYPE)
8298 return gnu_result;
8299
8300 /* If the result is a constant that overflowed, raise Constraint_Error. */
8301 if (TREE_CODE (gnu_result) == INTEGER_CST && TREE_OVERFLOW (gnu_result))
8302 {
8303 post_error ("??`Constraint_Error` will be raised at run time", gnat_node);
8304 gnu_result
8305 = build1 (NULL_EXPR, gnu_result_type,
8306 build_call_raise (CE_Overflow_Check_Failed, gnat_node,
8307 N_Raise_Constraint_Error));
8308 }
8309
8310 /* If the result has side-effects and is of an unconstrained type, protect
8311 the expression in case it will be referenced multiple times, i.e. for
8312 its value and to compute the size of an object. But do it neither for
8313 an object nor a renaming declaration, nor a return statement of a call
8314 to a function that returns an unconstrained record type with default
8315 discriminant, because there is no size to be computed in these cases
8316 and this will create a useless temporary. We must do this before any
8317 conversions. */
8318 if (TREE_SIDE_EFFECTS (gnu_result)
8319 && (TREE_CODE (gnu_result_type) == UNCONSTRAINED_ARRAY_TYPE
8320 || CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_result_type)))
8321 && !(TREE_CODE (gnu_result) == CALL_EXPR
8322 && type_is_padding_self_referential (TREE_TYPE (gnu_result))
8323 && (Nkind (Parent (gnat_node)) == N_Object_Declaration
8324 || Nkind (Parent (gnat_node)) == N_Object_Renaming_Declaration
8325 || Nkind (Parent (gnat_node)) == N_Simple_Return_Statement)))
8326 gnu_result = gnat_protect_expr (gnu_result);
8327
8328 /* Now convert the result to the result type, unless we are in one of the
8329 following cases:
8330
8331 1. If this is the LHS of an assignment or an actual parameter of a
8332 call, return the result almost unmodified since the RHS will have
8333 to be converted to our type in that case, unless the result type
8334 has a simpler size or for array types because this size might be
8335 changed in-between. Likewise if there is just a no-op unchecked
8336 conversion in-between. Similarly, don't convert integral types
8337 that are the operands of an unchecked conversion since we need
8338 to ignore those conversions (for 'Valid).
8339
8340 2. If we have a label (which doesn't have any well-defined type), a
8341 field or an error, return the result almost unmodified. Similarly,
8342 if the two types are record types with the same name, don't convert.
8343 This will be the case when we are converting from a packable version
8344 of a type to its original type and we need those conversions to be
8345 NOPs in order for assignments into these types to work properly.
8346
8347 3. If the type is void or if we have no result, return error_mark_node
8348 to show we have no result.
8349
8350 4. If this is a call to a function that returns with variable size and
8351 the call is used as the expression in either an object or a renaming
8352 declaration, return the result unmodified because we want to use the
8353 return slot optimization in this case.
8354
8355 5. If this is a reference to an unconstrained array which is used as the
8356 prefix of an attribute reference that requires an lvalue, return the
8357 result unmodified because we want to return the original bounds.
8358
8359 6. Finally, if the type of the result is already correct. */
8360
8361 if (Present (Parent (gnat_node))
8362 && (lhs_or_actual_p (gnat_node)
8363 || (Nkind (Parent (gnat_node)) == N_Unchecked_Type_Conversion
8364 && unchecked_conversion_nop (Parent (gnat_node)))
8365 || (Nkind (Parent (gnat_node)) == N_Unchecked_Type_Conversion
8366 && !AGGREGATE_TYPE_P (gnu_result_type)
8367 && !AGGREGATE_TYPE_P (TREE_TYPE (gnu_result))))
8368 && !(TYPE_SIZE (gnu_result_type)
8369 && TYPE_SIZE (TREE_TYPE (gnu_result))
8370 && AGGREGATE_TYPE_P (gnu_result_type)
8371 == AGGREGATE_TYPE_P (TREE_TYPE (gnu_result))
8372 && ((TREE_CODE (TYPE_SIZE (gnu_result_type)) == INTEGER_CST
8373 && (TREE_CODE (TYPE_SIZE (TREE_TYPE (gnu_result)))
8374 != INTEGER_CST))
8375 || (TREE_CODE (TYPE_SIZE (gnu_result_type)) != INTEGER_CST
8376 && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_result_type))
8377 && (CONTAINS_PLACEHOLDER_P
8378 (TYPE_SIZE (TREE_TYPE (gnu_result)))))
8379 || (TREE_CODE (gnu_result_type) == ARRAY_TYPE
8380 && TREE_CODE (TREE_TYPE (gnu_result)) == ARRAY_TYPE))
8381 && !(TREE_CODE (gnu_result_type) == RECORD_TYPE
8382 && TYPE_JUSTIFIED_MODULAR_P (gnu_result_type))))
8383 {
8384 /* Remove padding only if the inner object is of self-referential
8385 size: in that case it must be an object of unconstrained type
8386 with a default discriminant and we want to avoid copying too
8387 much data. But do not remove it if it is already too small. */
8388 if (type_is_padding_self_referential (TREE_TYPE (gnu_result))
8389 && !(TREE_CODE (gnu_result) == COMPONENT_REF
8390 && DECL_BIT_FIELD (TREE_OPERAND (gnu_result, 1))
8391 && DECL_SIZE (TREE_OPERAND (gnu_result, 1))
8392 != TYPE_SIZE (TREE_TYPE (gnu_result))))
8393 gnu_result = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_result))),
8394 gnu_result);
8395 }
8396
8397 else if (TREE_CODE (gnu_result) == LABEL_DECL
8398 || TREE_CODE (gnu_result) == FIELD_DECL
8399 || TREE_CODE (gnu_result) == ERROR_MARK
8400 || (TYPE_NAME (gnu_result_type)
8401 == TYPE_NAME (TREE_TYPE (gnu_result))
8402 && TREE_CODE (gnu_result_type) == RECORD_TYPE
8403 && TREE_CODE (TREE_TYPE (gnu_result)) == RECORD_TYPE))
8404 {
8405 /* Remove any padding. */
8406 gnu_result = maybe_padded_object (gnu_result);
8407 }
8408
8409 else if (gnu_result == error_mark_node || gnu_result_type == void_type_node)
8410 gnu_result = error_mark_node;
8411
8412 else if (TREE_CODE (gnu_result) == CALL_EXPR
8413 && Present (Parent (gnat_node))
8414 && (Nkind (Parent (gnat_node)) == N_Object_Declaration
8415 || Nkind (Parent (gnat_node)) == N_Object_Renaming_Declaration)
8416 && return_type_with_variable_size_p (TREE_TYPE (gnu_result)))
8417 ;
8418
8419 else if (TREE_CODE (gnu_result) == UNCONSTRAINED_ARRAY_REF
8420 && Present (Parent (gnat_node))
8421 && Nkind (Parent (gnat_node)) == N_Attribute_Reference
8422 && lvalue_required_for_attribute_p (Parent (gnat_node)))
8423 ;
8424
8425 else if (TREE_TYPE (gnu_result) != gnu_result_type)
8426 gnu_result = convert (gnu_result_type, gnu_result);
8427
8428 /* We don't need any NOP_EXPR or NON_LVALUE_EXPR on the result. */
8429 while ((TREE_CODE (gnu_result) == NOP_EXPR
8430 || TREE_CODE (gnu_result) == NON_LVALUE_EXPR)
8431 && TREE_TYPE (TREE_OPERAND (gnu_result, 0)) == TREE_TYPE (gnu_result))
8432 gnu_result = TREE_OPERAND (gnu_result, 0);
8433
8434 return gnu_result;
8435 }
8436
8437 /* Similar to gnat_to_gnu, but discard any object that might be created in
8438 the course of the translation of GNAT_NODE, which must be an "external"
8439 expression in the sense that it will be elaborated elsewhere. */
8440
8441 tree
gnat_to_gnu_external(Node_Id gnat_node)8442 gnat_to_gnu_external (Node_Id gnat_node)
8443 {
8444 const int save_force_global = force_global;
8445 bool went_into_elab_proc;
8446
8447 /* Force the local context and create a fake scope that we zap
8448 at the end so declarations will not be stuck either in the
8449 global varpool or in the current scope. */
8450 if (!current_function_decl)
8451 {
8452 current_function_decl = get_elaboration_procedure ();
8453 went_into_elab_proc = true;
8454 }
8455 else
8456 went_into_elab_proc = false;
8457 force_global = 0;
8458 gnat_pushlevel ();
8459
8460 tree gnu_result = gnat_to_gnu (gnat_node);
8461
8462 gnat_zaplevel ();
8463 force_global = save_force_global;
8464 if (went_into_elab_proc)
8465 current_function_decl = NULL_TREE;
8466
8467 /* Do not import locations from external units. */
8468 if (gnu_result && EXPR_P (gnu_result))
8469 SET_EXPR_LOCATION (gnu_result, UNKNOWN_LOCATION);
8470
8471 return gnu_result;
8472 }
8473
8474 /* Return true if the statement list STMT_LIST is empty. */
8475
8476 static bool
empty_stmt_list_p(tree stmt_list)8477 empty_stmt_list_p (tree stmt_list)
8478 {
8479 tree_stmt_iterator tsi;
8480
8481 for (tsi = tsi_start (stmt_list); !tsi_end_p (tsi); tsi_next (&tsi))
8482 {
8483 tree stmt = tsi_stmt (tsi);
8484
8485 /* Anything else than an empty STMT_STMT counts as something. */
8486 if (TREE_CODE (stmt) != STMT_STMT || STMT_STMT_STMT (stmt))
8487 return false;
8488 }
8489
8490 return true;
8491 }
8492
8493 /* Record the current code position in GNAT_NODE. */
8494
8495 static void
record_code_position(Node_Id gnat_node)8496 record_code_position (Node_Id gnat_node)
8497 {
8498 tree stmt_stmt = build1 (STMT_STMT, void_type_node, NULL_TREE);
8499
8500 add_stmt_with_node (stmt_stmt, gnat_node);
8501 save_gnu_tree (gnat_node, stmt_stmt, true);
8502 }
8503
8504 /* Insert the code for GNAT_NODE at the position saved for that node. */
8505
8506 static void
insert_code_for(Node_Id gnat_node)8507 insert_code_for (Node_Id gnat_node)
8508 {
8509 tree code = gnat_to_gnu (gnat_node);
8510
8511 /* It's too late to remove the STMT_STMT itself at this point. */
8512 if (!empty_stmt_list_p (code))
8513 STMT_STMT_STMT (get_gnu_tree (gnat_node)) = code;
8514
8515 save_gnu_tree (gnat_node, NULL_TREE, true);
8516 }
8517
8518 /* Start a new statement group chained to the previous group. */
8519
8520 void
start_stmt_group(void)8521 start_stmt_group (void)
8522 {
8523 struct stmt_group *group = stmt_group_free_list;
8524
8525 /* First see if we can get one from the free list. */
8526 if (group)
8527 stmt_group_free_list = group->previous;
8528 else
8529 group = ggc_alloc<stmt_group> ();
8530
8531 group->previous = current_stmt_group;
8532 group->stmt_list = group->block = group->cleanups = NULL_TREE;
8533 current_stmt_group = group;
8534 }
8535
8536 /* Add GNU_STMT to the current statement group. If it is an expression with
8537 no effects, it is ignored. */
8538
8539 void
add_stmt(tree gnu_stmt)8540 add_stmt (tree gnu_stmt)
8541 {
8542 append_to_statement_list (gnu_stmt, ¤t_stmt_group->stmt_list);
8543 }
8544
8545 /* Similar, but the statement is always added, regardless of side-effects. */
8546
8547 void
add_stmt_force(tree gnu_stmt)8548 add_stmt_force (tree gnu_stmt)
8549 {
8550 append_to_statement_list_force (gnu_stmt, ¤t_stmt_group->stmt_list);
8551 }
8552
8553 /* Like add_stmt, but set the location of GNU_STMT to that of GNAT_NODE. */
8554
8555 void
add_stmt_with_node(tree gnu_stmt,Node_Id gnat_node)8556 add_stmt_with_node (tree gnu_stmt, Node_Id gnat_node)
8557 {
8558 if (Present (gnat_node))
8559 set_expr_location_from_node (gnu_stmt, gnat_node);
8560 add_stmt (gnu_stmt);
8561 }
8562
8563 /* Similar, but the statement is always added, regardless of side-effects. */
8564
8565 void
add_stmt_with_node_force(tree gnu_stmt,Node_Id gnat_node)8566 add_stmt_with_node_force (tree gnu_stmt, Node_Id gnat_node)
8567 {
8568 if (Present (gnat_node))
8569 set_expr_location_from_node (gnu_stmt, gnat_node);
8570 add_stmt_force (gnu_stmt);
8571 }
8572
8573 /* Add a declaration statement for GNU_DECL to the current statement group.
8574 Get the SLOC to be put onto the statement from GNAT_NODE. */
8575
8576 void
add_decl_expr(tree gnu_decl,Node_Id gnat_node)8577 add_decl_expr (tree gnu_decl, Node_Id gnat_node)
8578 {
8579 tree type = TREE_TYPE (gnu_decl);
8580 tree gnu_stmt, gnu_init;
8581
8582 /* If this is a variable that Gigi is to ignore, we may have been given
8583 an ERROR_MARK. So test for it. We also might have been given a
8584 reference for a renaming. So only do something for a decl. Also
8585 ignore a TYPE_DECL for an UNCONSTRAINED_ARRAY_TYPE. */
8586 if (!DECL_P (gnu_decl)
8587 || (TREE_CODE (gnu_decl) == TYPE_DECL
8588 && TREE_CODE (type) == UNCONSTRAINED_ARRAY_TYPE))
8589 return;
8590
8591 gnu_stmt = build1 (DECL_EXPR, void_type_node, gnu_decl);
8592
8593 /* If we are external or global, we don't want to output the DECL_EXPR for
8594 this DECL node since we already have evaluated the expressions in the
8595 sizes and positions as globals and doing it again would be wrong. */
8596 if (DECL_EXTERNAL (gnu_decl) || global_bindings_p ())
8597 {
8598 /* Mark everything as used to prevent node sharing with subprograms.
8599 Note that walk_tree knows how to deal with TYPE_DECL, but neither
8600 VAR_DECL nor CONST_DECL. This appears to be somewhat arbitrary. */
8601 MARK_VISITED (gnu_stmt);
8602 if (TREE_CODE (gnu_decl) == VAR_DECL
8603 || TREE_CODE (gnu_decl) == CONST_DECL)
8604 {
8605 MARK_VISITED (DECL_SIZE (gnu_decl));
8606 MARK_VISITED (DECL_SIZE_UNIT (gnu_decl));
8607 MARK_VISITED (DECL_INITIAL (gnu_decl));
8608 }
8609 }
8610 else
8611 add_stmt_with_node (gnu_stmt, gnat_node);
8612
8613 /* Mark our TYPE_ADA_SIZE field now since it will not be gimplified. */
8614 if (TREE_CODE (gnu_decl) == TYPE_DECL
8615 && RECORD_OR_UNION_TYPE_P (type)
8616 && !TYPE_FAT_POINTER_P (type))
8617 MARK_VISITED (TYPE_ADA_SIZE (type));
8618
8619 /* If this is a variable and an initializer is attached to it, it must be
8620 valid for the context. Similar to init_const in create_var_decl. */
8621 if (TREE_CODE (gnu_decl) == VAR_DECL
8622 && (gnu_init = DECL_INITIAL (gnu_decl))
8623 && (!gnat_types_compatible_p (type, TREE_TYPE (gnu_init))
8624 || (TREE_STATIC (gnu_decl)
8625 && !initializer_constant_valid_p (gnu_init,
8626 TREE_TYPE (gnu_init)))))
8627 {
8628 DECL_INITIAL (gnu_decl) = NULL_TREE;
8629 if (TREE_READONLY (gnu_decl))
8630 {
8631 TREE_READONLY (gnu_decl) = 0;
8632 DECL_READONLY_ONCE_ELAB (gnu_decl) = 1;
8633 }
8634
8635 /* Remove any padding so the assignment is done properly. */
8636 gnu_decl = maybe_padded_object (gnu_decl);
8637
8638 gnu_stmt = build_binary_op (INIT_EXPR, NULL_TREE, gnu_decl, gnu_init);
8639 add_stmt_with_node (gnu_stmt, gnat_node);
8640 }
8641 }
8642
8643 /* Callback for walk_tree to mark the visited trees rooted at *TP. */
8644
8645 static tree
mark_visited_r(tree * tp,int * walk_subtrees,void * data ATTRIBUTE_UNUSED)8646 mark_visited_r (tree *tp, int *walk_subtrees, void *data ATTRIBUTE_UNUSED)
8647 {
8648 tree t = *tp;
8649
8650 if (TREE_VISITED (t))
8651 *walk_subtrees = 0;
8652
8653 /* Don't mark a dummy type as visited because we want to mark its sizes
8654 and fields once it's filled in. */
8655 else if (!TYPE_IS_DUMMY_P (t))
8656 TREE_VISITED (t) = 1;
8657
8658 /* The test in gimplify_type_sizes is on the main variant. */
8659 if (TYPE_P (t))
8660 TYPE_SIZES_GIMPLIFIED (TYPE_MAIN_VARIANT (t)) = 1;
8661
8662 return NULL_TREE;
8663 }
8664
8665 /* Mark nodes rooted at T with TREE_VISITED and types as having their
8666 sized gimplified. We use this to indicate all variable sizes and
8667 positions in global types may not be shared by any subprogram. */
8668
8669 void
mark_visited(tree t)8670 mark_visited (tree t)
8671 {
8672 walk_tree (&t, mark_visited_r, NULL, NULL);
8673 }
8674
8675 /* Add GNU_CLEANUP, a cleanup action, to the current code group and
8676 set its location to that of GNAT_NODE if present, but with column info
8677 cleared so that conditional branches generated as part of the cleanup
8678 code do not interfere with coverage analysis tools. */
8679
8680 static void
add_cleanup(tree gnu_cleanup,Node_Id gnat_node)8681 add_cleanup (tree gnu_cleanup, Node_Id gnat_node)
8682 {
8683 if (Present (gnat_node))
8684 set_expr_location_from_node (gnu_cleanup, gnat_node, true);
8685
8686 /* An EH_ELSE_EXPR must be by itself, and that's all we need when we
8687 use it. The assert below makes sure that is so. Should we ever
8688 need more than that, we could combine EH_ELSE_EXPRs, and copy
8689 non-EH_ELSE_EXPR stmts into both cleanup paths of an
8690 EH_ELSE_EXPR. */
8691 if (TREE_CODE (gnu_cleanup) == EH_ELSE_EXPR)
8692 {
8693 gcc_assert (!current_stmt_group->cleanups);
8694 current_stmt_group->cleanups = gnu_cleanup;
8695 }
8696 else
8697 {
8698 gcc_assert (!current_stmt_group->cleanups
8699 || (TREE_CODE (current_stmt_group->cleanups)
8700 != EH_ELSE_EXPR));
8701 append_to_statement_list (gnu_cleanup, ¤t_stmt_group->cleanups);
8702 }
8703 }
8704
8705 /* Set the BLOCK node corresponding to the current code group to GNU_BLOCK. */
8706
8707 void
set_block_for_group(tree gnu_block)8708 set_block_for_group (tree gnu_block)
8709 {
8710 gcc_assert (!current_stmt_group->block);
8711 current_stmt_group->block = gnu_block;
8712 }
8713
8714 /* Return code corresponding to the current code group. It is normally
8715 a STATEMENT_LIST, but may also be a BIND_EXPR or TRY_FINALLY_EXPR if
8716 BLOCK or cleanups were set. */
8717
8718 tree
end_stmt_group(void)8719 end_stmt_group (void)
8720 {
8721 struct stmt_group *group = current_stmt_group;
8722 tree gnu_retval = group->stmt_list;
8723
8724 /* If this is a null list, allocate a new STATEMENT_LIST. Then, if there
8725 are cleanups, make a TRY_FINALLY_EXPR. Last, if there is a BLOCK,
8726 make a BIND_EXPR. Note that we nest in that because the cleanup may
8727 reference variables in the block. */
8728 if (!gnu_retval)
8729 gnu_retval = alloc_stmt_list ();
8730
8731 if (group->cleanups)
8732 gnu_retval = build2 (TRY_FINALLY_EXPR, void_type_node, gnu_retval,
8733 group->cleanups);
8734
8735 if (current_stmt_group->block)
8736 gnu_retval = build3 (BIND_EXPR, void_type_node, BLOCK_VARS (group->block),
8737 gnu_retval, group->block);
8738
8739 /* Remove this group from the stack and add it to the free list. */
8740 current_stmt_group = group->previous;
8741 group->previous = stmt_group_free_list;
8742 stmt_group_free_list = group;
8743
8744 return gnu_retval;
8745 }
8746
8747 /* Return whether the current statement group may fall through. */
8748
8749 static inline bool
stmt_group_may_fallthru(void)8750 stmt_group_may_fallthru (void)
8751 {
8752 if (current_stmt_group->stmt_list)
8753 return block_may_fallthru (current_stmt_group->stmt_list);
8754 else
8755 return true;
8756 }
8757
8758 /* Add a list of statements from GNAT_LIST, a possibly-empty list of
8759 statements.*/
8760
8761 static void
add_stmt_list(List_Id gnat_list)8762 add_stmt_list (List_Id gnat_list)
8763 {
8764 Node_Id gnat_node;
8765
8766 if (Present (gnat_list))
8767 for (gnat_node = First (gnat_list); Present (gnat_node);
8768 gnat_node = Next (gnat_node))
8769 add_stmt (gnat_to_gnu (gnat_node));
8770 }
8771
8772 /* Build a tree from GNAT_LIST, a possibly-empty list of statements.
8773 If BINDING_P is true, push and pop a binding level around the list. */
8774
8775 static tree
build_stmt_group(List_Id gnat_list,bool binding_p)8776 build_stmt_group (List_Id gnat_list, bool binding_p)
8777 {
8778 start_stmt_group ();
8779
8780 if (binding_p)
8781 gnat_pushlevel ();
8782
8783 add_stmt_list (gnat_list);
8784
8785 if (binding_p)
8786 gnat_poplevel ();
8787
8788 return end_stmt_group ();
8789 }
8790
8791 /* Generate GIMPLE in place for the expression at *EXPR_P. */
8792
8793 int
gnat_gimplify_expr(tree * expr_p,gimple_seq * pre_p,gimple_seq * post_p ATTRIBUTE_UNUSED)8794 gnat_gimplify_expr (tree *expr_p, gimple_seq *pre_p,
8795 gimple_seq *post_p ATTRIBUTE_UNUSED)
8796 {
8797 tree expr = *expr_p;
8798 tree type = TREE_TYPE (expr);
8799 tree op;
8800
8801 if (IS_ADA_STMT (expr))
8802 return gnat_gimplify_stmt (expr_p);
8803
8804 switch (TREE_CODE (expr))
8805 {
8806 case NULL_EXPR:
8807 /* If this is an aggregate type, build a null pointer of the appropriate
8808 type and dereference it. */
8809 if (AGGREGATE_TYPE_P (type)
8810 || TREE_CODE (type) == UNCONSTRAINED_ARRAY_TYPE)
8811 *expr_p = build_unary_op (INDIRECT_REF, NULL_TREE,
8812 convert (build_pointer_type (type),
8813 integer_zero_node));
8814 /* Otherwise, just make a VAR_DECL. */
8815 else
8816 {
8817 *expr_p = create_tmp_var (type, NULL);
8818 suppress_warning (*expr_p);
8819 }
8820
8821 gimplify_and_add (TREE_OPERAND (expr, 0), pre_p);
8822 return GS_OK;
8823
8824 case UNCONSTRAINED_ARRAY_REF:
8825 /* We should only do this if we are just elaborating for side-effects,
8826 but we can't know that yet. */
8827 *expr_p = TREE_OPERAND (*expr_p, 0);
8828 return GS_OK;
8829
8830 case ADDR_EXPR:
8831 op = TREE_OPERAND (expr, 0);
8832
8833 /* If we are taking the address of a constant CONSTRUCTOR, make sure it
8834 is put into static memory. We know that it's going to be read-only
8835 given the semantics we have and it must be in static memory when the
8836 reference is in an elaboration procedure. */
8837 if (TREE_CODE (op) == CONSTRUCTOR && TREE_CONSTANT (op))
8838 {
8839 tree addr = build_fold_addr_expr (tree_output_constant_def (op));
8840 *expr_p = fold_convert (type, addr);
8841 return GS_ALL_DONE;
8842 }
8843
8844 /* Replace atomic loads with their first argument. That's necessary
8845 because the gimplifier would create a temporary otherwise. */
8846 if (TREE_SIDE_EFFECTS (op))
8847 while (handled_component_p (op) || CONVERT_EXPR_P (op))
8848 {
8849 tree inner = TREE_OPERAND (op, 0);
8850 if (TREE_CODE (inner) == CALL_EXPR && call_is_atomic_load (inner))
8851 {
8852 tree t = CALL_EXPR_ARG (inner, 0);
8853 if (TREE_CODE (t) == NOP_EXPR)
8854 t = TREE_OPERAND (t, 0);
8855 if (TREE_CODE (t) == ADDR_EXPR)
8856 TREE_OPERAND (op, 0) = TREE_OPERAND (t, 0);
8857 else
8858 TREE_OPERAND (op, 0) = build_fold_indirect_ref (t);
8859 }
8860 else
8861 op = inner;
8862 }
8863
8864 return GS_UNHANDLED;
8865
8866 case CALL_EXPR:
8867 /* If we are passing a constant fat pointer CONSTRUCTOR, make sure it is
8868 put into static memory; this performs a restricted version of constant
8869 propagation on fat pointers in calls. But do not do it for strings to
8870 avoid blocking concatenation in the caller when it is inlined. */
8871 for (int i = 0; i < call_expr_nargs (expr); i++)
8872 {
8873 tree arg = *(CALL_EXPR_ARGP (expr) + i);
8874
8875 if (TREE_CODE (arg) == CONSTRUCTOR
8876 && TREE_CONSTANT (arg)
8877 && TYPE_IS_FAT_POINTER_P (TREE_TYPE (arg)))
8878 {
8879 tree t = CONSTRUCTOR_ELT (arg, 0)->value;
8880 if (TREE_CODE (t) == NOP_EXPR)
8881 t = TREE_OPERAND (t, 0);
8882 if (TREE_CODE (t) == ADDR_EXPR)
8883 t = TREE_OPERAND (t, 0);
8884 if (TREE_CODE (t) != STRING_CST)
8885 *(CALL_EXPR_ARGP (expr) + i) = tree_output_constant_def (arg);
8886 }
8887 }
8888
8889 return GS_UNHANDLED;
8890
8891 case VIEW_CONVERT_EXPR:
8892 op = TREE_OPERAND (expr, 0);
8893
8894 /* If we are view-converting a CONSTRUCTOR or a call from an aggregate
8895 type to a scalar one, explicitly create the local temporary. That's
8896 required if the type is passed by reference. */
8897 if ((TREE_CODE (op) == CONSTRUCTOR || TREE_CODE (op) == CALL_EXPR)
8898 && AGGREGATE_TYPE_P (TREE_TYPE (op))
8899 && !AGGREGATE_TYPE_P (type))
8900 {
8901 tree mod, new_var = create_tmp_var_raw (TREE_TYPE (op), "C");
8902 gimple_add_tmp_var (new_var);
8903
8904 mod = build2 (INIT_EXPR, TREE_TYPE (new_var), new_var, op);
8905 gimplify_and_add (mod, pre_p);
8906
8907 TREE_OPERAND (expr, 0) = new_var;
8908 return GS_OK;
8909 }
8910
8911 return GS_UNHANDLED;
8912
8913 case DECL_EXPR:
8914 op = DECL_EXPR_DECL (expr);
8915
8916 /* The expressions for the RM bounds must be gimplified to ensure that
8917 they are properly elaborated. See gimplify_decl_expr. */
8918 if ((TREE_CODE (op) == TYPE_DECL || TREE_CODE (op) == VAR_DECL)
8919 && !TYPE_SIZES_GIMPLIFIED (TREE_TYPE (op)))
8920 switch (TREE_CODE (TREE_TYPE (op)))
8921 {
8922 case INTEGER_TYPE:
8923 case ENUMERAL_TYPE:
8924 case BOOLEAN_TYPE:
8925 case REAL_TYPE:
8926 {
8927 tree type = TYPE_MAIN_VARIANT (TREE_TYPE (op)), t, val;
8928
8929 val = TYPE_RM_MIN_VALUE (type);
8930 if (val)
8931 {
8932 gimplify_one_sizepos (&val, pre_p);
8933 for (t = type; t; t = TYPE_NEXT_VARIANT (t))
8934 SET_TYPE_RM_MIN_VALUE (t, val);
8935 }
8936
8937 val = TYPE_RM_MAX_VALUE (type);
8938 if (val)
8939 {
8940 gimplify_one_sizepos (&val, pre_p);
8941 for (t = type; t; t = TYPE_NEXT_VARIANT (t))
8942 SET_TYPE_RM_MAX_VALUE (t, val);
8943 }
8944
8945 }
8946 break;
8947
8948 default:
8949 break;
8950 }
8951
8952 /* ... fall through ... */
8953
8954 default:
8955 return GS_UNHANDLED;
8956 }
8957 }
8958
8959 /* Generate GIMPLE in place for the statement at *STMT_P. */
8960
8961 static enum gimplify_status
gnat_gimplify_stmt(tree * stmt_p)8962 gnat_gimplify_stmt (tree *stmt_p)
8963 {
8964 tree stmt = *stmt_p;
8965
8966 switch (TREE_CODE (stmt))
8967 {
8968 case STMT_STMT:
8969 *stmt_p = STMT_STMT_STMT (stmt);
8970 return GS_OK;
8971
8972 case LOOP_STMT:
8973 {
8974 tree gnu_start_label = create_artificial_label (input_location);
8975 tree gnu_cond = LOOP_STMT_COND (stmt);
8976 tree gnu_update = LOOP_STMT_UPDATE (stmt);
8977 tree gnu_end_label = LOOP_STMT_LABEL (stmt);
8978
8979 /* Build the condition expression from the test, if any. */
8980 if (gnu_cond)
8981 {
8982 /* Deal with the optimization hints. */
8983 if (LOOP_STMT_IVDEP (stmt))
8984 gnu_cond = build3 (ANNOTATE_EXPR, TREE_TYPE (gnu_cond), gnu_cond,
8985 build_int_cst (integer_type_node,
8986 annot_expr_ivdep_kind),
8987 integer_zero_node);
8988 if (LOOP_STMT_NO_UNROLL (stmt))
8989 gnu_cond = build3 (ANNOTATE_EXPR, TREE_TYPE (gnu_cond), gnu_cond,
8990 build_int_cst (integer_type_node,
8991 annot_expr_unroll_kind),
8992 integer_one_node);
8993 if (LOOP_STMT_UNROLL (stmt))
8994 gnu_cond = build3 (ANNOTATE_EXPR, TREE_TYPE (gnu_cond), gnu_cond,
8995 build_int_cst (integer_type_node,
8996 annot_expr_unroll_kind),
8997 build_int_cst (NULL_TREE, USHRT_MAX));
8998 if (LOOP_STMT_NO_VECTOR (stmt))
8999 gnu_cond = build3 (ANNOTATE_EXPR, TREE_TYPE (gnu_cond), gnu_cond,
9000 build_int_cst (integer_type_node,
9001 annot_expr_no_vector_kind),
9002 integer_zero_node);
9003 if (LOOP_STMT_VECTOR (stmt))
9004 gnu_cond = build3 (ANNOTATE_EXPR, TREE_TYPE (gnu_cond), gnu_cond,
9005 build_int_cst (integer_type_node,
9006 annot_expr_vector_kind),
9007 integer_zero_node);
9008
9009 gnu_cond
9010 = build3 (COND_EXPR, void_type_node, gnu_cond, NULL_TREE,
9011 build1 (GOTO_EXPR, void_type_node, gnu_end_label));
9012 }
9013
9014 /* Set to emit the statements of the loop. */
9015 *stmt_p = NULL_TREE;
9016
9017 /* We first emit the start label and then a conditional jump to the
9018 end label if there's a top condition, then the update if it's at
9019 the top, then the body of the loop, then a conditional jump to
9020 the end label if there's a bottom condition, then the update if
9021 it's at the bottom, and finally a jump to the start label and the
9022 definition of the end label. */
9023 append_to_statement_list (build1 (LABEL_EXPR, void_type_node,
9024 gnu_start_label),
9025 stmt_p);
9026
9027 if (gnu_cond && !LOOP_STMT_BOTTOM_COND_P (stmt))
9028 append_to_statement_list (gnu_cond, stmt_p);
9029
9030 if (gnu_update && LOOP_STMT_TOP_UPDATE_P (stmt))
9031 append_to_statement_list (gnu_update, stmt_p);
9032
9033 append_to_statement_list (LOOP_STMT_BODY (stmt), stmt_p);
9034
9035 if (gnu_cond && LOOP_STMT_BOTTOM_COND_P (stmt))
9036 append_to_statement_list (gnu_cond, stmt_p);
9037
9038 if (gnu_update && !LOOP_STMT_TOP_UPDATE_P (stmt))
9039 append_to_statement_list (gnu_update, stmt_p);
9040
9041 tree t = build1 (GOTO_EXPR, void_type_node, gnu_start_label);
9042 SET_EXPR_LOCATION (t, DECL_SOURCE_LOCATION (gnu_end_label));
9043 append_to_statement_list (t, stmt_p);
9044
9045 append_to_statement_list (build1 (LABEL_EXPR, void_type_node,
9046 gnu_end_label),
9047 stmt_p);
9048 return GS_OK;
9049 }
9050
9051 case EXIT_STMT:
9052 /* Build a statement to jump to the corresponding end label, then
9053 see if it needs to be conditional. */
9054 *stmt_p = build1 (GOTO_EXPR, void_type_node, EXIT_STMT_LABEL (stmt));
9055 if (EXIT_STMT_COND (stmt))
9056 *stmt_p = build3 (COND_EXPR, void_type_node,
9057 EXIT_STMT_COND (stmt), *stmt_p, alloc_stmt_list ());
9058 return GS_OK;
9059
9060 default:
9061 gcc_unreachable ();
9062 }
9063 }
9064
9065 /* Force a reference to each of the entities in GNAT_PACKAGE recursively.
9066
9067 This routine is exclusively called in type_annotate mode, to compute DDA
9068 information for types in withed units, for ASIS use. */
9069
9070 static void
elaborate_all_entities_for_package(Entity_Id gnat_package)9071 elaborate_all_entities_for_package (Entity_Id gnat_package)
9072 {
9073 Entity_Id gnat_entity;
9074
9075 for (gnat_entity = First_Entity (gnat_package);
9076 Present (gnat_entity);
9077 gnat_entity = Next_Entity (gnat_entity))
9078 {
9079 const Entity_Kind kind = Ekind (gnat_entity);
9080
9081 /* We are interested only in entities visible from the main unit. */
9082 if (!Is_Public (gnat_entity))
9083 continue;
9084
9085 /* Skip stuff internal to the compiler. */
9086 if (Is_Intrinsic_Subprogram (gnat_entity))
9087 continue;
9088 if (kind == E_Operator)
9089 continue;
9090 if (IN (kind, Subprogram_Kind)
9091 && (Present (Alias (gnat_entity))
9092 || Is_Intrinsic_Subprogram (gnat_entity)))
9093 continue;
9094 if (Is_Itype (gnat_entity))
9095 continue;
9096
9097 /* Skip named numbers. */
9098 if (IN (kind, Named_Kind))
9099 continue;
9100
9101 /* Skip generic declarations. */
9102 if (IN (kind, Generic_Unit_Kind))
9103 continue;
9104
9105 /* Skip formal objects. */
9106 if (IN (kind, Formal_Object_Kind))
9107 continue;
9108
9109 /* Skip package bodies. */
9110 if (kind == E_Package_Body)
9111 continue;
9112
9113 /* Skip limited views that point back to the main unit. */
9114 if (IN (kind, Incomplete_Kind)
9115 && From_Limited_With (gnat_entity)
9116 && In_Extended_Main_Code_Unit (Non_Limited_View (gnat_entity)))
9117 continue;
9118
9119 /* Skip types that aren't frozen. */
9120 if (IN (kind, Type_Kind) && !Is_Frozen (gnat_entity))
9121 continue;
9122
9123 /* Recurse on real packages that aren't in the main unit. */
9124 if (kind == E_Package)
9125 {
9126 if (No (Renamed_Entity (gnat_entity))
9127 && !In_Extended_Main_Code_Unit (gnat_entity))
9128 elaborate_all_entities_for_package (gnat_entity);
9129 }
9130 else
9131 gnat_to_gnu_entity (gnat_entity, NULL_TREE, false);
9132 }
9133 }
9134
9135 /* Force a reference to each of the entities in packages withed by GNAT_NODE.
9136 Operate recursively but check that we aren't elaborating something more
9137 than once.
9138
9139 This routine is exclusively called in type_annotate mode, to compute DDA
9140 information for types in withed units, for ASIS use. */
9141
9142 static void
elaborate_all_entities(Node_Id gnat_node)9143 elaborate_all_entities (Node_Id gnat_node)
9144 {
9145 Entity_Id gnat_with_clause;
9146
9147 /* Process each unit only once. As we trace the context of all relevant
9148 units transitively, including generic bodies, we may encounter the
9149 same generic unit repeatedly. */
9150 if (!present_gnu_tree (gnat_node))
9151 save_gnu_tree (gnat_node, integer_zero_node, true);
9152
9153 /* Save entities in all context units. A body may have an implicit_with
9154 on its own spec, if the context includes a child unit, so don't save
9155 the spec twice. */
9156 for (gnat_with_clause = First (Context_Items (gnat_node));
9157 Present (gnat_with_clause);
9158 gnat_with_clause = Next (gnat_with_clause))
9159 if (Nkind (gnat_with_clause) == N_With_Clause
9160 && !present_gnu_tree (Library_Unit (gnat_with_clause))
9161 && Library_Unit (gnat_with_clause) != Library_Unit (Cunit (Main_Unit)))
9162 {
9163 Node_Id gnat_unit = Library_Unit (gnat_with_clause);
9164 Entity_Id gnat_entity = Entity (Name (gnat_with_clause));
9165
9166 elaborate_all_entities (gnat_unit);
9167
9168 if (Ekind (gnat_entity) == E_Package
9169 && No (Renamed_Entity (gnat_entity)))
9170 elaborate_all_entities_for_package (gnat_entity);
9171
9172 else if (Ekind (gnat_entity) == E_Generic_Package)
9173 {
9174 Node_Id gnat_body = Corresponding_Body (Unit (gnat_unit));
9175
9176 /* Retrieve compilation unit node of generic body. */
9177 while (Present (gnat_body)
9178 && Nkind (gnat_body) != N_Compilation_Unit)
9179 gnat_body = Parent (gnat_body);
9180
9181 /* If body is available, elaborate its context. */
9182 if (Present (gnat_body))
9183 elaborate_all_entities (gnat_body);
9184 }
9185 }
9186
9187 if (Nkind (Unit (gnat_node)) == N_Package_Body)
9188 elaborate_all_entities (Library_Unit (gnat_node));
9189 }
9190
9191 /* Do the processing of GNAT_NODE, an N_Freeze_Entity. */
9192
9193 static void
process_freeze_entity(Node_Id gnat_node)9194 process_freeze_entity (Node_Id gnat_node)
9195 {
9196 const Entity_Id gnat_entity = Entity (gnat_node);
9197 const Entity_Kind kind = Ekind (gnat_entity);
9198 tree gnu_old, gnu_new;
9199
9200 /* If this is a package, generate code for the package body, if any. */
9201 if (kind == E_Package)
9202 {
9203 const Node_Id gnat_decl = Parent (Declaration_Node (gnat_entity));
9204 if (Present (Corresponding_Body (gnat_decl)))
9205 insert_code_for (Parent (Corresponding_Body (gnat_decl)));
9206 return;
9207 }
9208
9209 /* Don't do anything for class-wide types as they are always transformed
9210 into their root type. */
9211 if (kind == E_Class_Wide_Type)
9212 return;
9213
9214 /* Check for an old definition if this isn't an object with address clause,
9215 since the saved GCC tree is the address expression in that case. */
9216 gnu_old
9217 = present_gnu_tree (gnat_entity) && No (Address_Clause (gnat_entity))
9218 ? get_gnu_tree (gnat_entity) : NULL_TREE;
9219
9220 /* Don't do anything for subprograms that may have been elaborated before
9221 their freeze nodes. This can happen, for example, because of an inner
9222 call in an instance body or because of previous compilation of a spec
9223 for inlining purposes. */
9224 if (gnu_old
9225 && ((TREE_CODE (gnu_old) == FUNCTION_DECL
9226 && (kind == E_Function || kind == E_Procedure))
9227 || (FUNC_OR_METHOD_TYPE_P (TREE_TYPE (gnu_old))
9228 && kind == E_Subprogram_Type)))
9229 return;
9230
9231 /* If we have a non-dummy type old tree, we have nothing to do, except for
9232 aborting, since this node was never delayed as it should have been. We
9233 let this happen for concurrent types and their Corresponding_Record_Type,
9234 however, because each might legitimately be elaborated before its own
9235 freeze node, e.g. while processing the other. */
9236 if (gnu_old
9237 && !(TREE_CODE (gnu_old) == TYPE_DECL
9238 && TYPE_IS_DUMMY_P (TREE_TYPE (gnu_old))))
9239 {
9240 gcc_assert (Is_Concurrent_Type (gnat_entity)
9241 || (Is_Record_Type (gnat_entity)
9242 && Is_Concurrent_Record_Type (gnat_entity)));
9243 return;
9244 }
9245
9246 /* Reset the saved tree, if any, and elaborate the object or type for real.
9247 If there is a full view, elaborate it and use the result. And, if this
9248 is the root type of a class-wide type, reuse it for the latter. */
9249 if (gnu_old)
9250 {
9251 save_gnu_tree (gnat_entity, NULL_TREE, false);
9252
9253 if (Is_Incomplete_Or_Private_Type (gnat_entity)
9254 && Present (Full_View (gnat_entity)))
9255 {
9256 Entity_Id full_view = Full_View (gnat_entity);
9257
9258 save_gnu_tree (full_view, NULL_TREE, false);
9259
9260 if (Is_Private_Type (full_view)
9261 && Present (Underlying_Full_View (full_view)))
9262 {
9263 full_view = Underlying_Full_View (full_view);
9264 save_gnu_tree (full_view, NULL_TREE, false);
9265 }
9266 }
9267
9268 if (Is_Type (gnat_entity)
9269 && Present (Class_Wide_Type (gnat_entity))
9270 && Root_Type (Class_Wide_Type (gnat_entity)) == gnat_entity)
9271 save_gnu_tree (Class_Wide_Type (gnat_entity), NULL_TREE, false);
9272 }
9273
9274 if (Is_Incomplete_Or_Private_Type (gnat_entity)
9275 && Present (Full_View (gnat_entity)))
9276 {
9277 Entity_Id full_view = Full_View (gnat_entity);
9278
9279 if (Is_Private_Type (full_view)
9280 && Present (Underlying_Full_View (full_view)))
9281 full_view = Underlying_Full_View (full_view);
9282
9283 gnu_new = gnat_to_gnu_entity (full_view, NULL_TREE, true);
9284
9285 /* Propagate back-annotations from full view to partial view. */
9286 if (!Known_Alignment (gnat_entity))
9287 Copy_Alignment (gnat_entity, full_view);
9288
9289 if (!Known_Esize (gnat_entity))
9290 Copy_Esize (gnat_entity, full_view);
9291
9292 if (!Known_RM_Size (gnat_entity))
9293 Copy_RM_Size (gnat_entity, full_view);
9294
9295 /* The above call may have defined this entity (the simplest example
9296 of this is when we have a private enumeral type since the bounds
9297 will have the public view). */
9298 if (!present_gnu_tree (gnat_entity))
9299 save_gnu_tree (gnat_entity, gnu_new, false);
9300 }
9301 else
9302 {
9303 tree gnu_init
9304 = (Nkind (Declaration_Node (gnat_entity)) == N_Object_Declaration
9305 && present_gnu_tree (Declaration_Node (gnat_entity)))
9306 ? get_gnu_tree (Declaration_Node (gnat_entity)) : NULL_TREE;
9307
9308 gnu_new = gnat_to_gnu_entity (gnat_entity, gnu_init, true);
9309 }
9310
9311 if (Is_Type (gnat_entity)
9312 && Present (Class_Wide_Type (gnat_entity))
9313 && Root_Type (Class_Wide_Type (gnat_entity)) == gnat_entity)
9314 save_gnu_tree (Class_Wide_Type (gnat_entity), gnu_new, false);
9315
9316 /* If we have an old type and we've made pointers to this type, update those
9317 pointers. If this is a Taft amendment type in the main unit, we need to
9318 mark the type as used since other units referencing it don't see the full
9319 declaration and, therefore, cannot mark it as used themselves. */
9320 if (gnu_old)
9321 {
9322 update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_old)),
9323 TREE_TYPE (gnu_new));
9324 if (TYPE_DUMMY_IN_PROFILE_P (TREE_TYPE (gnu_old)))
9325 update_profiles_with (TREE_TYPE (gnu_old));
9326 if (DECL_TAFT_TYPE_P (gnu_old))
9327 used_types_insert (TREE_TYPE (gnu_new));
9328 }
9329 }
9330
9331 /* Elaborate decls in the lists GNAT_DECLS and GNAT_DECLS2, if present.
9332 We make two passes, one to elaborate anything other than bodies (but
9333 we declare a function if there was no spec). The second pass
9334 elaborates the bodies.
9335
9336 GNAT_END_LIST gives the element in the list past the end. Normally,
9337 this is Empty, but can be First_Real_Statement for a
9338 Handled_Sequence_Of_Statements.
9339
9340 We make a complete pass through both lists if PASS1P is true, then make
9341 the second pass over both lists if PASS2P is true. The lists usually
9342 correspond to the public and private parts of a package. */
9343
9344 static void
process_decls(List_Id gnat_decls,List_Id gnat_decls2,Node_Id gnat_end_list,bool pass1p,bool pass2p)9345 process_decls (List_Id gnat_decls, List_Id gnat_decls2,
9346 Node_Id gnat_end_list, bool pass1p, bool pass2p)
9347 {
9348 List_Id gnat_decl_array[2];
9349 Node_Id gnat_decl;
9350 int i;
9351
9352 gnat_decl_array[0] = gnat_decls, gnat_decl_array[1] = gnat_decls2;
9353
9354 if (pass1p)
9355 for (i = 0; i <= 1; i++)
9356 if (Present (gnat_decl_array[i]))
9357 for (gnat_decl = First (gnat_decl_array[i]);
9358 gnat_decl != gnat_end_list; gnat_decl = Next (gnat_decl))
9359 {
9360 /* For package specs, we recurse inside the declarations,
9361 thus taking the two pass approach inside the boundary. */
9362 if (Nkind (gnat_decl) == N_Package_Declaration
9363 && (Nkind (Specification (gnat_decl)
9364 == N_Package_Specification)))
9365 process_decls (Visible_Declarations (Specification (gnat_decl)),
9366 Private_Declarations (Specification (gnat_decl)),
9367 Empty, true, false);
9368
9369 /* Similarly for any declarations in the actions of a
9370 freeze node. */
9371 else if (Nkind (gnat_decl) == N_Freeze_Entity)
9372 {
9373 process_freeze_entity (gnat_decl);
9374 process_decls (Actions (gnat_decl), Empty, Empty, true, false);
9375 }
9376
9377 /* Package bodies with freeze nodes get their elaboration deferred
9378 until the freeze node, but the code must be placed in the right
9379 place, so record the code position now. */
9380 else if (Nkind (gnat_decl) == N_Package_Body
9381 && Present (Freeze_Node (Corresponding_Spec (gnat_decl))))
9382 record_code_position (gnat_decl);
9383
9384 else if (Nkind (gnat_decl) == N_Package_Body_Stub
9385 && Present (Library_Unit (gnat_decl))
9386 && Present (Freeze_Node
9387 (Corresponding_Spec
9388 (Proper_Body (Unit
9389 (Library_Unit (gnat_decl)))))))
9390 record_code_position
9391 (Proper_Body (Unit (Library_Unit (gnat_decl))));
9392
9393 /* We defer most subprogram bodies to the second pass. */
9394 else if (Nkind (gnat_decl) == N_Subprogram_Body)
9395 {
9396 if (Acts_As_Spec (gnat_decl))
9397 {
9398 Node_Id gnat_subprog_id = Defining_Entity (gnat_decl);
9399
9400 if (Ekind (gnat_subprog_id) != E_Generic_Procedure
9401 && Ekind (gnat_subprog_id) != E_Generic_Function)
9402 gnat_to_gnu_entity (gnat_subprog_id, NULL_TREE, true);
9403 }
9404 }
9405
9406 /* For bodies and stubs that act as their own specs, the entity
9407 itself must be elaborated in the first pass, because it may
9408 be used in other declarations. */
9409 else if (Nkind (gnat_decl) == N_Subprogram_Body_Stub)
9410 {
9411 Node_Id gnat_subprog_id
9412 = Defining_Entity (Specification (gnat_decl));
9413
9414 if (Ekind (gnat_subprog_id) != E_Subprogram_Body
9415 && Ekind (gnat_subprog_id) != E_Generic_Procedure
9416 && Ekind (gnat_subprog_id) != E_Generic_Function)
9417 gnat_to_gnu_entity (gnat_subprog_id, NULL_TREE, true);
9418 }
9419
9420 /* Concurrent stubs stand for the corresponding subprogram bodies,
9421 which are deferred like other bodies. */
9422 else if (Nkind (gnat_decl) == N_Task_Body_Stub
9423 || Nkind (gnat_decl) == N_Protected_Body_Stub)
9424 ;
9425
9426 /* Renamed subprograms may not be elaborated yet at this point
9427 since renamings do not trigger freezing. Wait for the second
9428 pass to take care of them. */
9429 else if (Nkind (gnat_decl) == N_Subprogram_Renaming_Declaration)
9430 ;
9431
9432 else
9433 add_stmt (gnat_to_gnu (gnat_decl));
9434 }
9435
9436 /* Here we elaborate everything we deferred above except for package bodies,
9437 which are elaborated at their freeze nodes. Note that we must also
9438 go inside things (package specs and freeze nodes) the first pass did. */
9439 if (pass2p)
9440 for (i = 0; i <= 1; i++)
9441 if (Present (gnat_decl_array[i]))
9442 for (gnat_decl = First (gnat_decl_array[i]);
9443 gnat_decl != gnat_end_list; gnat_decl = Next (gnat_decl))
9444 {
9445 if (Nkind (gnat_decl) == N_Subprogram_Body
9446 || Nkind (gnat_decl) == N_Subprogram_Body_Stub
9447 || Nkind (gnat_decl) == N_Task_Body_Stub
9448 || Nkind (gnat_decl) == N_Protected_Body_Stub)
9449 add_stmt (gnat_to_gnu (gnat_decl));
9450
9451 else if (Nkind (gnat_decl) == N_Package_Declaration
9452 && (Nkind (Specification (gnat_decl)
9453 == N_Package_Specification)))
9454 process_decls (Visible_Declarations (Specification (gnat_decl)),
9455 Private_Declarations (Specification (gnat_decl)),
9456 Empty, false, true);
9457
9458 else if (Nkind (gnat_decl) == N_Freeze_Entity)
9459 process_decls (Actions (gnat_decl), Empty, Empty, false, true);
9460
9461 else if (Nkind (gnat_decl) == N_Subprogram_Renaming_Declaration)
9462 add_stmt (gnat_to_gnu (gnat_decl));
9463 }
9464 }
9465
9466 /* Make a unary operation of kind CODE using build_unary_op, but guard
9467 the operation by an overflow check. CODE can be one of NEGATE_EXPR
9468 or ABS_EXPR. GNU_TYPE is the type desired for the result. Usually
9469 the operation is to be performed in that type. GNAT_NODE is the gnat
9470 node conveying the source location for which the error should be
9471 signaled. */
9472
9473 static tree
build_unary_op_trapv(enum tree_code code,tree gnu_type,tree operand,Node_Id gnat_node)9474 build_unary_op_trapv (enum tree_code code, tree gnu_type, tree operand,
9475 Node_Id gnat_node)
9476 {
9477 gcc_assert (code == NEGATE_EXPR || code == ABS_EXPR);
9478
9479 operand = gnat_protect_expr (operand);
9480
9481 return emit_check (build_binary_op (EQ_EXPR, boolean_type_node,
9482 operand, TYPE_MIN_VALUE (gnu_type)),
9483 build_unary_op (code, gnu_type, operand),
9484 CE_Overflow_Check_Failed, gnat_node);
9485 }
9486
9487 /* Make a binary operation of kind CODE using build_binary_op, but guard
9488 the operation by an overflow check. CODE can be one of PLUS_EXPR,
9489 MINUS_EXPR or MULT_EXPR. GNU_TYPE is the type desired for the result.
9490 Usually the operation is to be performed in that type. GNAT_NODE is
9491 the GNAT node conveying the source location for which the error should
9492 be signaled. */
9493
9494 static tree
build_binary_op_trapv(enum tree_code code,tree gnu_type,tree left,tree right,Node_Id gnat_node)9495 build_binary_op_trapv (enum tree_code code, tree gnu_type, tree left,
9496 tree right, Node_Id gnat_node)
9497 {
9498 const unsigned int precision = TYPE_PRECISION (gnu_type);
9499 tree lhs = gnat_protect_expr (left);
9500 tree rhs = gnat_protect_expr (right);
9501 tree type_max = TYPE_MAX_VALUE (gnu_type);
9502 tree type_min = TYPE_MIN_VALUE (gnu_type);
9503 tree gnu_expr, check;
9504 int sgn;
9505
9506 /* Assert that the precision is a power of 2. */
9507 gcc_assert ((precision & (precision - 1)) == 0);
9508
9509 /* Prefer a constant on the RHS to simplify checks. */
9510 if (TREE_CODE (rhs) != INTEGER_CST
9511 && TREE_CODE (lhs) == INTEGER_CST
9512 && (code == PLUS_EXPR || code == MULT_EXPR))
9513 {
9514 tree tmp = lhs;
9515 lhs = rhs;
9516 rhs = tmp;
9517 }
9518
9519 gnu_expr = build_binary_op (code, gnu_type, lhs, rhs);
9520
9521 /* If we can fold the expression to a constant, just return it.
9522 The caller will deal with overflow, no need to generate a check. */
9523 if (TREE_CODE (gnu_expr) == INTEGER_CST)
9524 return gnu_expr;
9525
9526 /* If no operand is a constant, we use the generic implementation. */
9527 if (TREE_CODE (lhs) != INTEGER_CST && TREE_CODE (rhs) != INTEGER_CST)
9528 {
9529 /* First convert the operands to the result type like build_binary_op.
9530 This is where the bias is made explicit for biased types. */
9531 lhs = convert (gnu_type, lhs);
9532 rhs = convert (gnu_type, rhs);
9533
9534 /* Never inline a 64-bit mult for a 32-bit target, it's way too long. */
9535 if (code == MULT_EXPR && precision == 64 && BITS_PER_WORD < 64)
9536 {
9537 tree int64 = gnat_type_for_size (64, 0);
9538 return convert (gnu_type, build_call_n_expr (mulv64_decl, 2,
9539 convert (int64, lhs),
9540 convert (int64, rhs)));
9541 }
9542
9543 /* Likewise for a 128-bit mult and a 64-bit target. */
9544 else if (code == MULT_EXPR && precision == 128 && BITS_PER_WORD < 128)
9545 {
9546 tree int128 = gnat_type_for_size (128, 0);
9547 return convert (gnu_type, build_call_n_expr (mulv128_decl, 2,
9548 convert (int128, lhs),
9549 convert (int128, rhs)));
9550 }
9551
9552 enum internal_fn icode;
9553
9554 switch (code)
9555 {
9556 case PLUS_EXPR:
9557 icode = IFN_ADD_OVERFLOW;
9558 break;
9559 case MINUS_EXPR:
9560 icode = IFN_SUB_OVERFLOW;
9561 break;
9562 case MULT_EXPR:
9563 icode = IFN_MUL_OVERFLOW;
9564 break;
9565 default:
9566 gcc_unreachable ();
9567 }
9568
9569 tree gnu_ctype = build_complex_type (gnu_type);
9570 tree call
9571 = build_call_expr_internal_loc (UNKNOWN_LOCATION, icode, gnu_ctype, 2,
9572 lhs, rhs);
9573 tree tgt = save_expr (call);
9574 gnu_expr = build1 (REALPART_EXPR, gnu_type, tgt);
9575 check = fold_build2 (NE_EXPR, boolean_type_node,
9576 build1 (IMAGPART_EXPR, gnu_type, tgt),
9577 build_int_cst (gnu_type, 0));
9578 return
9579 emit_check (check, gnu_expr, CE_Overflow_Check_Failed, gnat_node);
9580 }
9581
9582 /* If one operand is a constant, we expose the overflow condition to enable
9583 a subsequent simplication or even elimination. */
9584 switch (code)
9585 {
9586 case PLUS_EXPR:
9587 sgn = tree_int_cst_sgn (rhs);
9588 if (sgn > 0)
9589 /* When rhs > 0, overflow when lhs > type_max - rhs. */
9590 check = build_binary_op (GT_EXPR, boolean_type_node, lhs,
9591 build_binary_op (MINUS_EXPR, gnu_type,
9592 type_max, rhs));
9593 else if (sgn < 0)
9594 /* When rhs < 0, overflow when lhs < type_min - rhs. */
9595 check = build_binary_op (LT_EXPR, boolean_type_node, lhs,
9596 build_binary_op (MINUS_EXPR, gnu_type,
9597 type_min, rhs));
9598 else
9599 return gnu_expr;
9600 break;
9601
9602 case MINUS_EXPR:
9603 if (TREE_CODE (lhs) == INTEGER_CST)
9604 {
9605 sgn = tree_int_cst_sgn (lhs);
9606 if (sgn > 0)
9607 /* When lhs > 0, overflow when rhs < lhs - type_max. */
9608 check = build_binary_op (LT_EXPR, boolean_type_node, rhs,
9609 build_binary_op (MINUS_EXPR, gnu_type,
9610 lhs, type_max));
9611 else if (sgn < 0)
9612 /* When lhs < 0, overflow when rhs > lhs - type_min. */
9613 check = build_binary_op (GT_EXPR, boolean_type_node, rhs,
9614 build_binary_op (MINUS_EXPR, gnu_type,
9615 lhs, type_min));
9616 else
9617 return gnu_expr;
9618 }
9619 else
9620 {
9621 sgn = tree_int_cst_sgn (rhs);
9622 if (sgn > 0)
9623 /* When rhs > 0, overflow when lhs < type_min + rhs. */
9624 check = build_binary_op (LT_EXPR, boolean_type_node, lhs,
9625 build_binary_op (PLUS_EXPR, gnu_type,
9626 type_min, rhs));
9627 else if (sgn < 0)
9628 /* When rhs < 0, overflow when lhs > type_max + rhs. */
9629 check = build_binary_op (GT_EXPR, boolean_type_node, lhs,
9630 build_binary_op (PLUS_EXPR, gnu_type,
9631 type_max, rhs));
9632 else
9633 return gnu_expr;
9634 }
9635 break;
9636
9637 case MULT_EXPR:
9638 sgn = tree_int_cst_sgn (rhs);
9639 if (sgn > 0)
9640 {
9641 if (integer_onep (rhs))
9642 return gnu_expr;
9643
9644 tree lb = build_binary_op (TRUNC_DIV_EXPR, gnu_type, type_min, rhs);
9645 tree ub = build_binary_op (TRUNC_DIV_EXPR, gnu_type, type_max, rhs);
9646
9647 /* When rhs > 1, overflow outside [type_min/rhs; type_max/rhs]. */
9648 check
9649 = build_binary_op (TRUTH_ORIF_EXPR, boolean_type_node,
9650 build_binary_op (LT_EXPR, boolean_type_node,
9651 lhs, lb),
9652 build_binary_op (GT_EXPR, boolean_type_node,
9653 lhs, ub));
9654 }
9655 else if (sgn < 0)
9656 {
9657 tree lb = build_binary_op (TRUNC_DIV_EXPR, gnu_type, type_max, rhs);
9658 tree ub = build_binary_op (TRUNC_DIV_EXPR, gnu_type, type_min, rhs);
9659
9660 if (integer_minus_onep (rhs))
9661 /* When rhs == -1, overflow if lhs == type_min. */
9662 check
9663 = build_binary_op (EQ_EXPR, boolean_type_node, lhs, type_min);
9664 else
9665 /* When rhs < -1, overflow outside [type_max/rhs; type_min/rhs]. */
9666 check
9667 = build_binary_op (TRUTH_ORIF_EXPR, boolean_type_node,
9668 build_binary_op (LT_EXPR, boolean_type_node,
9669 lhs, lb),
9670 build_binary_op (GT_EXPR, boolean_type_node,
9671 lhs, ub));
9672 }
9673 else
9674 return gnu_expr;
9675 break;
9676
9677 default:
9678 gcc_unreachable ();
9679 }
9680
9681 return emit_check (check, gnu_expr, CE_Overflow_Check_Failed, gnat_node);
9682 }
9683
9684 /* GNU_COND contains the condition corresponding to an index, overflow or
9685 range check of value GNU_EXPR. Build a COND_EXPR that returns GNU_EXPR
9686 if GNU_COND is false and raises a CONSTRAINT_ERROR if GNU_COND is true.
9687 REASON is the code that says why the exception is raised. GNAT_NODE is
9688 the node conveying the source location for which the error should be
9689 signaled.
9690
9691 We used to propagate TREE_SIDE_EFFECTS from GNU_EXPR to the COND_EXPR,
9692 overwriting the setting inherited from the call statement, on the ground
9693 that the expression need not be evaluated just for the check. However
9694 that's incorrect because, in the GCC type system, its value is presumed
9695 to be valid so its comparison against the type bounds always yields true
9696 and, therefore, could be done without evaluating it; given that it can
9697 be a computation that overflows the bounds, the language may require the
9698 check to fail and thus the expression to be evaluated in this case. */
9699
9700 static tree
emit_check(tree gnu_cond,tree gnu_expr,int reason,Node_Id gnat_node)9701 emit_check (tree gnu_cond, tree gnu_expr, int reason, Node_Id gnat_node)
9702 {
9703 tree gnu_call
9704 = build_call_raise (reason, gnat_node, N_Raise_Constraint_Error);
9705 return
9706 fold_build3 (COND_EXPR, TREE_TYPE (gnu_expr), gnu_cond,
9707 build2 (COMPOUND_EXPR, TREE_TYPE (gnu_expr), gnu_call,
9708 SCALAR_FLOAT_TYPE_P (TREE_TYPE (gnu_expr))
9709 ? build_real (TREE_TYPE (gnu_expr), dconst0)
9710 : build_int_cst (TREE_TYPE (gnu_expr), 0)),
9711 gnu_expr);
9712 }
9713
9714 /* Return an expression that converts GNU_EXPR to GNAT_TYPE, doing overflow
9715 checks if OVERFLOW_P is true. If TRUNCATE_P is true, do a fp-to-integer
9716 conversion with truncation, otherwise round. GNAT_NODE is the GNAT node
9717 conveying the source location for which the error should be signaled. */
9718
9719 static tree
convert_with_check(Entity_Id gnat_type,tree gnu_expr,bool overflow_p,bool truncate_p,Node_Id gnat_node)9720 convert_with_check (Entity_Id gnat_type, tree gnu_expr, bool overflow_p,
9721 bool truncate_p, Node_Id gnat_node)
9722 {
9723 tree gnu_type = get_unpadded_type (gnat_type);
9724 tree gnu_base_type = get_base_type (gnu_type);
9725 tree gnu_in_type = TREE_TYPE (gnu_expr);
9726 tree gnu_in_base_type = get_base_type (gnu_in_type);
9727 tree gnu_result = gnu_expr;
9728
9729 /* If we are not doing any checks, the output is an integral type and the
9730 input is not a floating-point type, just do the conversion. This is
9731 required for packed array types and is simpler in all cases anyway. */
9732 if (!overflow_p
9733 && INTEGRAL_TYPE_P (gnu_base_type)
9734 && !FLOAT_TYPE_P (gnu_in_base_type))
9735 return convert (gnu_type, gnu_expr);
9736
9737 /* If the mode of the input base type is larger, then converting to it below
9738 may pessimize the final conversion step, for example generate a libcall
9739 instead of a simple instruction, so use a narrower type in this case. */
9740 if (TYPE_MODE (gnu_in_base_type) != TYPE_MODE (gnu_in_type)
9741 && !(TREE_CODE (gnu_in_type) == INTEGER_TYPE
9742 && TYPE_BIASED_REPRESENTATION_P (gnu_in_type)))
9743 gnu_in_base_type = gnat_type_for_mode (TYPE_MODE (gnu_in_type),
9744 TYPE_UNSIGNED (gnu_in_type));
9745
9746 /* First convert the expression to the base type. This will never generate
9747 code, but makes the tests below simpler. But don't do this if converting
9748 from an integer type to an unconstrained array type since then we need to
9749 get the bounds from the original (unpacked) type. */
9750 if (TREE_CODE (gnu_type) != UNCONSTRAINED_ARRAY_TYPE)
9751 gnu_result = convert (gnu_in_base_type, gnu_result);
9752
9753 /* If overflow checks are requested, we need to be sure the result will fit
9754 in the output base type. But don't do this if the input is integer and
9755 the output floating-point. */
9756 if (overflow_p
9757 && !(FLOAT_TYPE_P (gnu_base_type) && INTEGRAL_TYPE_P (gnu_in_base_type)))
9758 {
9759 /* Ensure GNU_EXPR only gets evaluated once. */
9760 tree gnu_input = gnat_protect_expr (gnu_result);
9761 tree gnu_cond = boolean_false_node;
9762 tree gnu_in_lb = TYPE_MIN_VALUE (gnu_in_base_type);
9763 tree gnu_in_ub = TYPE_MAX_VALUE (gnu_in_base_type);
9764 tree gnu_out_lb = TYPE_MIN_VALUE (gnu_base_type);
9765 tree gnu_out_ub
9766 = (TREE_CODE (gnu_base_type) == INTEGER_TYPE
9767 && TYPE_MODULAR_P (gnu_base_type))
9768 ? fold_build2 (MINUS_EXPR, gnu_base_type,
9769 TYPE_MODULUS (gnu_base_type),
9770 build_int_cst (gnu_base_type, 1))
9771 : TYPE_MAX_VALUE (gnu_base_type);
9772
9773 /* Convert the lower bounds to signed types, so we're sure we're
9774 comparing them properly. Likewise, convert the upper bounds
9775 to unsigned types. */
9776 if (INTEGRAL_TYPE_P (gnu_in_base_type)
9777 && TYPE_UNSIGNED (gnu_in_base_type))
9778 gnu_in_lb
9779 = convert (gnat_signed_type_for (gnu_in_base_type), gnu_in_lb);
9780
9781 if (INTEGRAL_TYPE_P (gnu_in_base_type)
9782 && !TYPE_UNSIGNED (gnu_in_base_type))
9783 gnu_in_ub
9784 = convert (gnat_unsigned_type_for (gnu_in_base_type), gnu_in_ub);
9785
9786 if (INTEGRAL_TYPE_P (gnu_base_type) && TYPE_UNSIGNED (gnu_base_type))
9787 gnu_out_lb
9788 = convert (gnat_signed_type_for (gnu_base_type), gnu_out_lb);
9789
9790 if (INTEGRAL_TYPE_P (gnu_base_type) && !TYPE_UNSIGNED (gnu_base_type))
9791 gnu_out_ub
9792 = convert (gnat_unsigned_type_for (gnu_base_type), gnu_out_ub);
9793
9794 /* Check each bound separately and only if the result bound
9795 is tighter than the bound on the input type. Note that all the
9796 types are base types, so the bounds must be constant. Also,
9797 the comparison is done in the base type of the input, which
9798 always has the proper signedness. First check for input
9799 integer (which means output integer), output float (which means
9800 both float), or mixed, in which case we always compare.
9801 Note that we have to do the comparison which would *fail* in the
9802 case of an error since if it's an FP comparison and one of the
9803 values is a NaN or Inf, the comparison will fail. */
9804 if (INTEGRAL_TYPE_P (gnu_in_base_type)
9805 ? tree_int_cst_lt (gnu_in_lb, gnu_out_lb)
9806 : (FLOAT_TYPE_P (gnu_base_type)
9807 ? real_less (&TREE_REAL_CST (gnu_in_lb),
9808 &TREE_REAL_CST (gnu_out_lb))
9809 : 1))
9810 gnu_cond
9811 = invert_truthvalue
9812 (build_binary_op (GE_EXPR, boolean_type_node,
9813 gnu_input, convert (gnu_in_base_type,
9814 gnu_out_lb)));
9815
9816 if (INTEGRAL_TYPE_P (gnu_in_base_type)
9817 ? tree_int_cst_lt (gnu_out_ub, gnu_in_ub)
9818 : (FLOAT_TYPE_P (gnu_base_type)
9819 ? real_less (&TREE_REAL_CST (gnu_out_ub),
9820 &TREE_REAL_CST (gnu_in_ub))
9821 : 1))
9822 gnu_cond
9823 = build_binary_op (TRUTH_ORIF_EXPR, boolean_type_node, gnu_cond,
9824 invert_truthvalue
9825 (build_binary_op (LE_EXPR, boolean_type_node,
9826 gnu_input,
9827 convert (gnu_in_base_type,
9828 gnu_out_ub))));
9829
9830 if (!integer_zerop (gnu_cond))
9831 gnu_result = emit_check (gnu_cond, gnu_input,
9832 CE_Overflow_Check_Failed, gnat_node);
9833 }
9834
9835 /* Now convert to the result base type. If this is a non-truncating
9836 float-to-integer conversion, round. */
9837 if (INTEGRAL_TYPE_P (gnu_base_type)
9838 && FLOAT_TYPE_P (gnu_in_base_type)
9839 && !truncate_p)
9840 {
9841 REAL_VALUE_TYPE half_minus_pred_half, pred_half;
9842 tree gnu_conv, gnu_zero, gnu_comp, calc_type;
9843 tree gnu_pred_half, gnu_add_pred_half, gnu_subtract_pred_half;
9844 const struct real_format *fmt;
9845
9846 /* The following calculations depend on proper rounding to even
9847 of each arithmetic operation. In order to prevent excess
9848 precision from spoiling this property, use the widest hardware
9849 floating-point type if FP_ARITH_MAY_WIDEN is true. */
9850 calc_type
9851 = fp_arith_may_widen ? longest_float_type_node : gnu_in_base_type;
9852
9853 /* Compute the exact value calc_type'Pred (0.5) at compile time. */
9854 fmt = REAL_MODE_FORMAT (TYPE_MODE (calc_type));
9855 real_2expN (&half_minus_pred_half, -(fmt->p) - 1, TYPE_MODE (calc_type));
9856 real_arithmetic (&pred_half, MINUS_EXPR, &dconsthalf,
9857 &half_minus_pred_half);
9858 gnu_pred_half = build_real (calc_type, pred_half);
9859
9860 /* If the input is strictly negative, subtract this value
9861 and otherwise add it from the input. For 0.5, the result
9862 is exactly between 1.0 and the machine number preceding 1.0
9863 (for calc_type). Since the last bit of 1.0 is even, this 0.5
9864 will round to 1.0, while all other number with an absolute
9865 value less than 0.5 round to 0.0. For larger numbers exactly
9866 halfway between integers, rounding will always be correct as
9867 the true mathematical result will be closer to the higher
9868 integer compared to the lower one. So, this constant works
9869 for all floating-point numbers.
9870
9871 The reason to use the same constant with subtract/add instead
9872 of a positive and negative constant is to allow the comparison
9873 to be scheduled in parallel with retrieval of the constant and
9874 conversion of the input to the calc_type (if necessary). */
9875
9876 gnu_zero = build_real (gnu_in_base_type, dconst0);
9877 gnu_result = gnat_protect_expr (gnu_result);
9878 gnu_conv = convert (calc_type, gnu_result);
9879 gnu_comp
9880 = fold_build2 (GE_EXPR, boolean_type_node, gnu_result, gnu_zero);
9881 gnu_add_pred_half
9882 = fold_build2 (PLUS_EXPR, calc_type, gnu_conv, gnu_pred_half);
9883 gnu_subtract_pred_half
9884 = fold_build2 (MINUS_EXPR, calc_type, gnu_conv, gnu_pred_half);
9885 gnu_result = fold_build3 (COND_EXPR, calc_type, gnu_comp,
9886 gnu_add_pred_half, gnu_subtract_pred_half);
9887 }
9888
9889 if (TREE_CODE (gnu_base_type) == INTEGER_TYPE
9890 && TYPE_HAS_ACTUAL_BOUNDS_P (gnu_base_type)
9891 && TREE_CODE (gnu_result) == UNCONSTRAINED_ARRAY_REF)
9892 gnu_result = unchecked_convert (gnu_base_type, gnu_result, false);
9893 else
9894 gnu_result = convert (gnu_base_type, gnu_result);
9895
9896 return convert (gnu_type, gnu_result);
9897 }
9898
9899 /* Return true if GNU_EXPR can be directly addressed. This is the case
9900 unless it is an expression involving computation or if it involves a
9901 reference to a bitfield or to an object not sufficiently aligned for
9902 its type. If GNU_TYPE is non-null, return true only if GNU_EXPR can
9903 be directly addressed as an object of this type.
9904
9905 *** Notes on addressability issues in the Ada compiler ***
9906
9907 This predicate is necessary in order to bridge the gap between Gigi
9908 and the middle-end about addressability of GENERIC trees. A tree
9909 is said to be addressable if it can be directly addressed, i.e. if
9910 its address can be taken, is a multiple of the type's alignment on
9911 strict-alignment architectures and returns the first storage unit
9912 assigned to the object represented by the tree.
9913
9914 In the C family of languages, everything is in practice addressable
9915 at the language level, except for bit-fields. This means that these
9916 compilers will take the address of any tree that doesn't represent
9917 a bit-field reference and expect the result to be the first storage
9918 unit assigned to the object. Even in cases where this will result
9919 in unaligned accesses at run time, nothing is supposed to be done
9920 and the program is considered as erroneous instead (see PR c/18287).
9921
9922 The implicit assumptions made in the middle-end are in keeping with
9923 the C viewpoint described above:
9924 - the address of a bit-field reference is supposed to be never
9925 taken; the compiler (generally) will stop on such a construct,
9926 - any other tree is addressable if it is formally addressable,
9927 i.e. if it is formally allowed to be the operand of ADDR_EXPR.
9928
9929 In Ada, the viewpoint is the opposite one: nothing is addressable
9930 at the language level unless explicitly declared so. This means
9931 that the compiler will both make sure that the trees representing
9932 references to addressable ("aliased" in Ada parlance) objects are
9933 addressable and make no real attempts at ensuring that the trees
9934 representing references to non-addressable objects are addressable.
9935
9936 In the first case, Ada is effectively equivalent to C and handing
9937 down the direct result of applying ADDR_EXPR to these trees to the
9938 middle-end works flawlessly. In the second case, Ada cannot afford
9939 to consider the program as erroneous if the address of trees that
9940 are not addressable is requested for technical reasons, unlike C;
9941 as a consequence, the Ada compiler must arrange for either making
9942 sure that this address is not requested in the middle-end or for
9943 compensating by inserting temporaries if it is requested in Gigi.
9944
9945 The first goal can be achieved because the middle-end should not
9946 request the address of non-addressable trees on its own; the only
9947 exception is for the invocation of low-level block operations like
9948 memcpy, for which the addressability requirements are lower since
9949 the type's alignment can be disregarded. In practice, this means
9950 that Gigi must make sure that such operations cannot be applied to
9951 non-BLKmode bit-fields.
9952
9953 The second goal is achieved by means of the addressable_p predicate,
9954 which computes whether a temporary must be inserted by Gigi when the
9955 address of a tree is requested; if so, the address of the temporary
9956 will be used in lieu of that of the original tree and some glue code
9957 generated to connect everything together. */
9958
9959 static bool
addressable_p(tree gnu_expr,tree gnu_type)9960 addressable_p (tree gnu_expr, tree gnu_type)
9961 {
9962 /* For an integral type, the size of the actual type of the object may not
9963 be greater than that of the expected type, otherwise an indirect access
9964 in the latter type wouldn't correctly set all the bits of the object. */
9965 if (gnu_type
9966 && INTEGRAL_TYPE_P (gnu_type)
9967 && smaller_form_type_p (gnu_type, TREE_TYPE (gnu_expr)))
9968 return false;
9969
9970 /* The size of the actual type of the object may not be smaller than that
9971 of the expected type, otherwise an indirect access in the latter type
9972 would be larger than the object. But only record types need to be
9973 considered in practice for this case. */
9974 if (gnu_type
9975 && TREE_CODE (gnu_type) == RECORD_TYPE
9976 && smaller_form_type_p (TREE_TYPE (gnu_expr), gnu_type))
9977 return false;
9978
9979 switch (TREE_CODE (gnu_expr))
9980 {
9981 case VAR_DECL:
9982 case PARM_DECL:
9983 case FUNCTION_DECL:
9984 case RESULT_DECL:
9985 /* All DECLs are addressable: if they are in a register, we can force
9986 them to memory. */
9987 return true;
9988
9989 case UNCONSTRAINED_ARRAY_REF:
9990 case INDIRECT_REF:
9991 /* Taking the address of a dereference yields the original pointer. */
9992 return true;
9993
9994 case STRING_CST:
9995 case INTEGER_CST:
9996 case REAL_CST:
9997 /* Taking the address yields a pointer to the constant pool. */
9998 return true;
9999
10000 case CONSTRUCTOR:
10001 /* Taking the address of a static constructor yields a pointer to the
10002 tree constant pool. */
10003 return TREE_STATIC (gnu_expr) ? true : false;
10004
10005 case NULL_EXPR:
10006 case ADDR_EXPR:
10007 case SAVE_EXPR:
10008 case CALL_EXPR:
10009 case PLUS_EXPR:
10010 case MINUS_EXPR:
10011 case BIT_IOR_EXPR:
10012 case BIT_XOR_EXPR:
10013 case BIT_AND_EXPR:
10014 case BIT_NOT_EXPR:
10015 /* All rvalues are deemed addressable since taking their address will
10016 force a temporary to be created by the middle-end. */
10017 return true;
10018
10019 case COMPOUND_EXPR:
10020 /* The address of a compound expression is that of its 2nd operand. */
10021 return addressable_p (TREE_OPERAND (gnu_expr, 1), gnu_type);
10022
10023 case COND_EXPR:
10024 /* We accept &COND_EXPR as soon as both operands are addressable and
10025 expect the outcome to be the address of the selected operand. */
10026 return (addressable_p (TREE_OPERAND (gnu_expr, 1), NULL_TREE)
10027 && addressable_p (TREE_OPERAND (gnu_expr, 2), NULL_TREE));
10028
10029 case COMPONENT_REF:
10030 return (((!DECL_BIT_FIELD (TREE_OPERAND (gnu_expr, 1))
10031 /* Even with DECL_BIT_FIELD cleared, we have to ensure that
10032 the field is sufficiently aligned, in case it is subject
10033 to a pragma Component_Alignment. But we don't need to
10034 check the alignment of the containing record, as it is
10035 guaranteed to be not smaller than that of its most
10036 aligned field that is not a bit-field. */
10037 && (!STRICT_ALIGNMENT
10038 || DECL_ALIGN (TREE_OPERAND (gnu_expr, 1))
10039 >= TYPE_ALIGN (TREE_TYPE (gnu_expr))))
10040 /* The field of a padding record is always addressable. */
10041 || TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_expr, 0))))
10042 && addressable_p (TREE_OPERAND (gnu_expr, 0), NULL_TREE));
10043
10044 case ARRAY_REF: case ARRAY_RANGE_REF:
10045 case REALPART_EXPR: case IMAGPART_EXPR:
10046 case NOP_EXPR:
10047 return addressable_p (TREE_OPERAND (gnu_expr, 0), NULL_TREE);
10048
10049 case CONVERT_EXPR:
10050 return (AGGREGATE_TYPE_P (TREE_TYPE (gnu_expr))
10051 && addressable_p (TREE_OPERAND (gnu_expr, 0), NULL_TREE));
10052
10053 case VIEW_CONVERT_EXPR:
10054 {
10055 /* This is addressable if we can avoid a copy. */
10056 tree type = TREE_TYPE (gnu_expr);
10057 tree inner_type = TREE_TYPE (TREE_OPERAND (gnu_expr, 0));
10058 return (((TYPE_MODE (type) == TYPE_MODE (inner_type)
10059 && (!STRICT_ALIGNMENT
10060 || TYPE_ALIGN (type) <= TYPE_ALIGN (inner_type)
10061 || TYPE_ALIGN (inner_type) >= BIGGEST_ALIGNMENT))
10062 || ((TYPE_MODE (type) == BLKmode
10063 || TYPE_MODE (inner_type) == BLKmode)
10064 && (!STRICT_ALIGNMENT
10065 || TYPE_ALIGN (type) <= TYPE_ALIGN (inner_type)
10066 || TYPE_ALIGN (inner_type) >= BIGGEST_ALIGNMENT
10067 || TYPE_ALIGN_OK (type)
10068 || TYPE_ALIGN_OK (inner_type))))
10069 && addressable_p (TREE_OPERAND (gnu_expr, 0), NULL_TREE));
10070 }
10071
10072 default:
10073 return false;
10074 }
10075 }
10076
10077 /* Do the processing for the declaration of a GNAT_ENTITY, a type or subtype.
10078 If a Freeze node exists for the entity, delay the bulk of the processing.
10079 Otherwise make a GCC type for GNAT_ENTITY and set up the correspondence. */
10080
10081 void
process_type(Entity_Id gnat_entity)10082 process_type (Entity_Id gnat_entity)
10083 {
10084 tree gnu_old
10085 = present_gnu_tree (gnat_entity) ? get_gnu_tree (gnat_entity) : NULL_TREE;
10086
10087 /* If we are to delay elaboration of this type, just do any elaboration
10088 needed for expressions within the declaration and make a dummy node
10089 for it and its Full_View (if any), in case something points to it.
10090 Do not do this if it has already been done (the only way that can
10091 happen is if the private completion is also delayed). */
10092 if (Present (Freeze_Node (gnat_entity)))
10093 {
10094 elaborate_entity (gnat_entity);
10095
10096 if (!gnu_old)
10097 {
10098 tree gnu_decl = TYPE_STUB_DECL (make_dummy_type (gnat_entity));
10099 save_gnu_tree (gnat_entity, gnu_decl, false);
10100 if (Is_Incomplete_Or_Private_Type (gnat_entity)
10101 && Present (Full_View (gnat_entity)))
10102 {
10103 if (Has_Completion_In_Body (gnat_entity))
10104 DECL_TAFT_TYPE_P (gnu_decl) = 1;
10105 save_gnu_tree (Full_View (gnat_entity), gnu_decl, false);
10106 }
10107 }
10108
10109 return;
10110 }
10111
10112 /* If we saved away a dummy type for this node, it means that this made the
10113 type that corresponds to the full type of an incomplete type. Clear that
10114 type for now and then update the type in the pointers below. But, if the
10115 saved type is not dummy, it very likely means that we have a use before
10116 declaration for the type in the tree, what we really cannot handle. */
10117 if (gnu_old)
10118 {
10119 gcc_assert (TREE_CODE (gnu_old) == TYPE_DECL
10120 && TYPE_IS_DUMMY_P (TREE_TYPE (gnu_old)));
10121
10122 save_gnu_tree (gnat_entity, NULL_TREE, false);
10123 }
10124
10125 /* Now fully elaborate the type. */
10126 tree gnu_new = gnat_to_gnu_entity (gnat_entity, NULL_TREE, true);
10127 gcc_assert (TREE_CODE (gnu_new) == TYPE_DECL);
10128
10129 /* If we have an old type and we've made pointers to this type, update those
10130 pointers. If this is a Taft amendment type in the main unit, we need to
10131 mark the type as used since other units referencing it don't see the full
10132 declaration and, therefore, cannot mark it as used themselves. */
10133 if (gnu_old)
10134 {
10135 update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_old)),
10136 TREE_TYPE (gnu_new));
10137 if (DECL_TAFT_TYPE_P (gnu_old))
10138 used_types_insert (TREE_TYPE (gnu_new));
10139 }
10140
10141 /* If this is a record type corresponding to a task or protected type
10142 that is a completion of an incomplete type, perform a similar update
10143 on the type. ??? Including protected types here is a guess. */
10144 if (Is_Record_Type (gnat_entity)
10145 && Is_Concurrent_Record_Type (gnat_entity)
10146 && present_gnu_tree (Corresponding_Concurrent_Type (gnat_entity)))
10147 {
10148 tree gnu_task_old
10149 = get_gnu_tree (Corresponding_Concurrent_Type (gnat_entity));
10150
10151 save_gnu_tree (Corresponding_Concurrent_Type (gnat_entity),
10152 NULL_TREE, false);
10153 save_gnu_tree (Corresponding_Concurrent_Type (gnat_entity),
10154 gnu_new, false);
10155
10156 update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_task_old)),
10157 TREE_TYPE (gnu_new));
10158 }
10159 }
10160
10161 /* Subroutine of assoc_to_constructor: VALUES is a list of field associations,
10162 some of which are from RECORD_TYPE. Return a CONSTRUCTOR consisting of the
10163 associations that are from RECORD_TYPE. If we see an internal record, make
10164 a recursive call to fill it in as well. */
10165
10166 static tree
extract_values(tree values,tree record_type)10167 extract_values (tree values, tree record_type)
10168 {
10169 vec<constructor_elt, va_gc> *v = NULL;
10170 tree field;
10171
10172 for (field = TYPE_FIELDS (record_type); field; field = DECL_CHAIN (field))
10173 {
10174 tree tem, value = NULL_TREE;
10175
10176 /* _Parent is an internal field, but may have values in the aggregate,
10177 so check for values first. */
10178 if ((tem = purpose_member (field, values)))
10179 {
10180 value = TREE_VALUE (tem);
10181 TREE_ADDRESSABLE (tem) = 1;
10182 }
10183
10184 else if (DECL_INTERNAL_P (field))
10185 {
10186 value = extract_values (values, TREE_TYPE (field));
10187 if (TREE_CODE (value) == CONSTRUCTOR
10188 && vec_safe_is_empty (CONSTRUCTOR_ELTS (value)))
10189 value = NULL_TREE;
10190 }
10191 else
10192 /* If we have a record subtype, the names will match, but not the
10193 actual FIELD_DECLs. */
10194 for (tem = values; tem; tem = TREE_CHAIN (tem))
10195 if (DECL_NAME (TREE_PURPOSE (tem)) == DECL_NAME (field))
10196 {
10197 value = convert (TREE_TYPE (field), TREE_VALUE (tem));
10198 TREE_ADDRESSABLE (tem) = 1;
10199 }
10200
10201 if (!value)
10202 continue;
10203
10204 CONSTRUCTOR_APPEND_ELT (v, field, value);
10205 }
10206
10207 return gnat_build_constructor (record_type, v);
10208 }
10209
10210 /* GNAT_ENTITY is the type of the resulting constructor, GNAT_ASSOC is the
10211 front of the Component_Associations of an N_Aggregate and GNU_TYPE is the
10212 GCC type of the corresponding record type. Return the CONSTRUCTOR. */
10213
10214 static tree
assoc_to_constructor(Entity_Id gnat_entity,Node_Id gnat_assoc,tree gnu_type)10215 assoc_to_constructor (Entity_Id gnat_entity, Node_Id gnat_assoc, tree gnu_type)
10216 {
10217 tree gnu_list = NULL_TREE, gnu_result;
10218
10219 /* We test for GNU_FIELD being empty in the case where a variant
10220 was the last thing since we don't take things off GNAT_ASSOC in
10221 that case. We check GNAT_ASSOC in case we have a variant, but it
10222 has no fields. */
10223
10224 for (; Present (gnat_assoc); gnat_assoc = Next (gnat_assoc))
10225 {
10226 const Node_Id gnat_field = First (Choices (gnat_assoc));
10227 const Node_Id gnat_expr = Expression (gnat_assoc);
10228 tree gnu_field = gnat_to_gnu_field_decl (Entity (gnat_field));
10229 tree gnu_expr = gnat_to_gnu (Expression (gnat_assoc));
10230
10231 /* The expander is supposed to put a single component selector name
10232 in every record component association. */
10233 gcc_assert (No (Next (gnat_field)));
10234
10235 /* Ignore discriminants that have Corresponding_Discriminants in tagged
10236 types since we'll be setting those fields in the parent subtype. */
10237 if (Ekind (Entity (gnat_field)) == E_Discriminant
10238 && Present (Corresponding_Discriminant (Entity (gnat_field)))
10239 && Is_Tagged_Type (Scope (Entity (gnat_field))))
10240 continue;
10241
10242 /* Also ignore discriminants of Unchecked_Unions. */
10243 if (Ekind (Entity (gnat_field)) == E_Discriminant
10244 && Is_Unchecked_Union (gnat_entity))
10245 continue;
10246
10247 gigi_checking_assert (!Do_Range_Check (gnat_expr));
10248
10249 /* Convert to the type of the field. */
10250 gnu_expr = convert (TREE_TYPE (gnu_field), gnu_expr);
10251
10252 /* Add the field and expression to the list. */
10253 gnu_list = tree_cons (gnu_field, gnu_expr, gnu_list);
10254 }
10255
10256 gnu_result = extract_values (gnu_list, gnu_type);
10257
10258 if (flag_checking)
10259 {
10260 /* Verify that every entry in GNU_LIST was used. */
10261 for (; gnu_list; gnu_list = TREE_CHAIN (gnu_list))
10262 gcc_assert (TREE_ADDRESSABLE (gnu_list));
10263 }
10264
10265 return gnu_result;
10266 }
10267
10268 /* Build a possibly nested constructor for array aggregates. GNAT_EXPR is
10269 the first element of an array aggregate. It may itself be an aggregate.
10270 GNU_ARRAY_TYPE is the GCC type corresponding to the array aggregate. */
10271
10272 static tree
pos_to_constructor(Node_Id gnat_expr,tree gnu_array_type)10273 pos_to_constructor (Node_Id gnat_expr, tree gnu_array_type)
10274 {
10275 tree gnu_index = TYPE_MIN_VALUE (TYPE_DOMAIN (gnu_array_type));
10276 vec<constructor_elt, va_gc> *gnu_expr_vec = NULL;
10277
10278 for (; Present (gnat_expr); gnat_expr = Next (gnat_expr))
10279 {
10280 tree gnu_expr;
10281
10282 /* If the expression is itself an array aggregate then first build the
10283 innermost constructor if it is part of our array (multi-dimensional
10284 case). */
10285 if (Nkind (gnat_expr) == N_Aggregate
10286 && TREE_CODE (TREE_TYPE (gnu_array_type)) == ARRAY_TYPE
10287 && TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_array_type)))
10288 gnu_expr = pos_to_constructor (First (Expressions (gnat_expr)),
10289 TREE_TYPE (gnu_array_type));
10290 else
10291 {
10292 /* If the expression is a conversion to an unconstrained array type,
10293 skip it to avoid spilling to memory. */
10294 if (Nkind (gnat_expr) == N_Type_Conversion
10295 && Is_Array_Type (Etype (gnat_expr))
10296 && !Is_Constrained (Etype (gnat_expr)))
10297 gnu_expr = gnat_to_gnu (Expression (gnat_expr));
10298 else
10299 gnu_expr = gnat_to_gnu (gnat_expr);
10300
10301 gigi_checking_assert (!Do_Range_Check (gnat_expr));
10302 }
10303
10304 CONSTRUCTOR_APPEND_ELT (gnu_expr_vec, gnu_index,
10305 convert (TREE_TYPE (gnu_array_type), gnu_expr));
10306
10307 gnu_index = int_const_binop (PLUS_EXPR, gnu_index,
10308 convert (TREE_TYPE (gnu_index),
10309 integer_one_node));
10310 }
10311
10312 return gnat_build_constructor (gnu_array_type, gnu_expr_vec);
10313 }
10314
10315 /* Process a N_Validate_Unchecked_Conversion node. */
10316
10317 static void
validate_unchecked_conversion(Node_Id gnat_node)10318 validate_unchecked_conversion (Node_Id gnat_node)
10319 {
10320 tree gnu_source_type = gnat_to_gnu_type (Source_Type (gnat_node));
10321 tree gnu_target_type = gnat_to_gnu_type (Target_Type (gnat_node));
10322
10323 /* If the target is a pointer type, see if we are either converting from a
10324 non-pointer or from a pointer to a type with a different alias set and
10325 warn if so, unless the pointer has been marked to alias everything. */
10326 if (POINTER_TYPE_P (gnu_target_type)
10327 && !TYPE_REF_CAN_ALIAS_ALL (gnu_target_type))
10328 {
10329 tree gnu_source_desig_type = POINTER_TYPE_P (gnu_source_type)
10330 ? TREE_TYPE (gnu_source_type)
10331 : NULL_TREE;
10332 tree gnu_target_desig_type = TREE_TYPE (gnu_target_type);
10333 alias_set_type target_alias_set = get_alias_set (gnu_target_desig_type);
10334
10335 if (target_alias_set != 0
10336 && (!POINTER_TYPE_P (gnu_source_type)
10337 || !alias_sets_conflict_p (get_alias_set (gnu_source_desig_type),
10338 target_alias_set)))
10339 {
10340 post_error_ne ("??possible aliasing problem for type&",
10341 gnat_node, Target_Type (gnat_node));
10342 post_error ("\\?use -fno-strict-aliasing switch for references",
10343 gnat_node);
10344 post_error_ne ("\\?or use `pragma No_Strict_Aliasing (&);`",
10345 gnat_node, Target_Type (gnat_node));
10346 }
10347 }
10348
10349 /* Likewise if the target is a fat pointer type, but we have no mechanism to
10350 mitigate the problem in this case, so we unconditionally warn. */
10351 else if (TYPE_IS_FAT_POINTER_P (gnu_target_type))
10352 {
10353 tree gnu_source_desig_type
10354 = TYPE_IS_FAT_POINTER_P (gnu_source_type)
10355 ? TREE_TYPE (TREE_TYPE (TYPE_FIELDS (gnu_source_type)))
10356 : NULL_TREE;
10357 tree gnu_target_desig_type
10358 = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (gnu_target_type)));
10359 alias_set_type target_alias_set = get_alias_set (gnu_target_desig_type);
10360
10361 if (target_alias_set != 0
10362 && (!TYPE_IS_FAT_POINTER_P (gnu_source_type)
10363 || !alias_sets_conflict_p (get_alias_set (gnu_source_desig_type),
10364 target_alias_set)))
10365 {
10366 post_error_ne ("??possible aliasing problem for type&",
10367 gnat_node, Target_Type (gnat_node));
10368 post_error ("\\?use -fno-strict-aliasing switch for references",
10369 gnat_node);
10370 }
10371 }
10372 }
10373
10374 /* Convert SLOC into LOCUS. Return true if SLOC corresponds to a
10375 source code location and false if it doesn't. If CLEAR_COLUMN is
10376 true, set the column information to 0. If DECL is given and SLOC
10377 refers to a File with an instance, map DECL to that instance. */
10378
10379 bool
Sloc_to_locus(Source_Ptr Sloc,location_t * locus,bool clear_column,const_tree decl)10380 Sloc_to_locus (Source_Ptr Sloc, location_t *locus, bool clear_column,
10381 const_tree decl)
10382 {
10383 if (Sloc == No_Location)
10384 return false;
10385
10386 if (Sloc <= Standard_Location)
10387 {
10388 *locus = BUILTINS_LOCATION;
10389 return false;
10390 }
10391
10392 Source_File_Index file = Get_Source_File_Index (Sloc);
10393 Line_Number_Type line = Get_Logical_Line_Number (Sloc);
10394 Column_Number_Type column = (clear_column ? 0 : Get_Column_Number (Sloc));
10395 line_map_ordinary *map = LINEMAPS_ORDINARY_MAP_AT (line_table, file - 1);
10396
10397 /* We can have zero if pragma Source_Reference is in effect. */
10398 if (line < 1)
10399 line = 1;
10400
10401 /* Translate the location. */
10402 *locus
10403 = linemap_position_for_line_and_column (line_table, map, line, column);
10404
10405 if (file_map && file_map[file - 1].Instance)
10406 decl_to_instance_map->put (decl, file_map[file - 1].Instance);
10407
10408 return true;
10409 }
10410
10411 /* Return whether GNAT_NODE is a defining identifier for a renaming that comes
10412 from the parameter association for the instantiation of a generic. We do
10413 not want to emit source location for them: the code generated for their
10414 initialization is likely to disturb debugging. */
10415
10416 bool
renaming_from_instantiation_p(Node_Id gnat_node)10417 renaming_from_instantiation_p (Node_Id gnat_node)
10418 {
10419 if (Nkind (gnat_node) != N_Defining_Identifier
10420 || !Is_Object (gnat_node)
10421 || Comes_From_Source (gnat_node)
10422 || !Present (Renamed_Object (gnat_node)))
10423 return false;
10424
10425 /* Get the object declaration of the renamed object, if any and if the
10426 renamed object is a mere identifier. */
10427 gnat_node = Renamed_Object (gnat_node);
10428 if (Nkind (gnat_node) != N_Identifier)
10429 return false;
10430
10431 gnat_node = Parent (Entity (gnat_node));
10432 return (Present (gnat_node)
10433 && Nkind (gnat_node) == N_Object_Declaration
10434 && Present (Corresponding_Generic_Association (gnat_node)));
10435 }
10436
10437 /* Similar to set_expr_location, but start with the Sloc of GNAT_NODE and
10438 don't do anything if it doesn't correspond to a source location. And,
10439 if CLEAR_COLUMN is true, set the column information to 0. */
10440
10441 static void
set_expr_location_from_node(tree node,Node_Id gnat_node,bool clear_column)10442 set_expr_location_from_node (tree node, Node_Id gnat_node, bool clear_column)
10443 {
10444 location_t locus;
10445
10446 /* Do not set a location for constructs likely to disturb debugging. */
10447 if (Nkind (gnat_node) == N_Defining_Identifier)
10448 {
10449 if (Is_Type (gnat_node) && Is_Actual_Subtype (gnat_node))
10450 return;
10451
10452 if (renaming_from_instantiation_p (gnat_node))
10453 return;
10454 }
10455
10456 if (!Sloc_to_locus (Sloc (gnat_node), &locus, clear_column))
10457 return;
10458
10459 SET_EXPR_LOCATION (node, locus);
10460 }
10461
10462 /* More elaborate version of set_expr_location_from_node to be used in more
10463 general contexts, for example the result of the translation of a generic
10464 GNAT node. */
10465
10466 static void
set_gnu_expr_location_from_node(tree node,Node_Id gnat_node)10467 set_gnu_expr_location_from_node (tree node, Node_Id gnat_node)
10468 {
10469 /* Set the location information on the node if it is a real expression.
10470 References can be reused for multiple GNAT nodes and they would get
10471 the location information of their last use. Also make sure not to
10472 overwrite an existing location as it is probably more precise. */
10473
10474 switch (TREE_CODE (node))
10475 {
10476 CASE_CONVERT:
10477 case NON_LVALUE_EXPR:
10478 case SAVE_EXPR:
10479 break;
10480
10481 case COMPOUND_EXPR:
10482 if (EXPR_P (TREE_OPERAND (node, 1)))
10483 set_gnu_expr_location_from_node (TREE_OPERAND (node, 1), gnat_node);
10484
10485 /* ... fall through ... */
10486
10487 default:
10488 if (!REFERENCE_CLASS_P (node) && !EXPR_HAS_LOCATION (node))
10489 {
10490 set_expr_location_from_node (node, gnat_node);
10491 set_end_locus_from_node (node, gnat_node);
10492 }
10493 break;
10494 }
10495 }
10496
10497 /* Set the end_locus information for GNU_NODE, if any, from an explicit end
10498 location associated with GNAT_NODE or GNAT_NODE itself, whichever makes
10499 most sense. Return true if a sensible assignment was performed. */
10500
10501 static bool
set_end_locus_from_node(tree gnu_node,Node_Id gnat_node)10502 set_end_locus_from_node (tree gnu_node, Node_Id gnat_node)
10503 {
10504 Node_Id gnat_end_label;
10505 location_t end_locus;
10506
10507 /* Pick the GNAT node of which we'll take the sloc to assign to the GCC node
10508 end_locus when there is one. We consider only GNAT nodes with a possible
10509 End_Label attached. If the End_Label actually was unassigned, fallback
10510 on the original node. We'd better assign an explicit sloc associated with
10511 the outer construct in any case. */
10512
10513 switch (Nkind (gnat_node))
10514 {
10515 case N_Package_Body:
10516 case N_Subprogram_Body:
10517 case N_Block_Statement:
10518 if (Present (Handled_Statement_Sequence (gnat_node)))
10519 gnat_end_label = End_Label (Handled_Statement_Sequence (gnat_node));
10520 else
10521 gnat_end_label = Empty;
10522
10523 break;
10524
10525 case N_Package_Declaration:
10526 gcc_checking_assert (Present (Specification (gnat_node)));
10527 gnat_end_label = End_Label (Specification (gnat_node));
10528 break;
10529
10530 default:
10531 return false;
10532 }
10533
10534 if (Present (gnat_end_label))
10535 gnat_node = gnat_end_label;
10536
10537 /* Some expanded subprograms have neither an End_Label nor a Sloc
10538 attached. Notify that to callers. For a block statement with no
10539 End_Label, clear column information, so that the tree for a
10540 transient block does not receive the sloc of a source condition. */
10541 if (!Sloc_to_locus (Sloc (gnat_node), &end_locus,
10542 No (gnat_end_label)
10543 && (Nkind (gnat_node) == N_Block_Statement)))
10544 return false;
10545
10546 switch (TREE_CODE (gnu_node))
10547 {
10548 case BIND_EXPR:
10549 BLOCK_SOURCE_END_LOCATION (BIND_EXPR_BLOCK (gnu_node)) = end_locus;
10550 return true;
10551
10552 case FUNCTION_DECL:
10553 DECL_STRUCT_FUNCTION (gnu_node)->function_end_locus = end_locus;
10554 return true;
10555
10556 default:
10557 return false;
10558 }
10559 }
10560
10561 /* Post an error message. MSG is the error message, properly annotated.
10562 NODE is the node at which to post the error and the node to use for the
10563 '&' substitution. */
10564
10565 void
post_error(const char * msg,Node_Id node)10566 post_error (const char *msg, Node_Id node)
10567 {
10568 String_Template temp;
10569 String_Pointer sp;
10570
10571 if (No (node))
10572 return;
10573
10574 temp.Low_Bound = 1;
10575 temp.High_Bound = strlen (msg);
10576 sp.Bounds = &temp;
10577 sp.Array = msg;
10578 Error_Msg_N (sp, node);
10579 }
10580
10581 /* Similar to post_error, but NODE is the node at which to post the error and
10582 ENT is the node to use for the '&' substitution. */
10583
10584 void
post_error_ne(const char * msg,Node_Id node,Entity_Id ent)10585 post_error_ne (const char *msg, Node_Id node, Entity_Id ent)
10586 {
10587 String_Template temp;
10588 String_Pointer sp;
10589
10590 if (No (node))
10591 return;
10592
10593 temp.Low_Bound = 1;
10594 temp.High_Bound = strlen (msg);
10595 sp.Bounds = &temp;
10596 sp.Array = msg;
10597 Error_Msg_NE (sp, node, ent);
10598 }
10599
10600 /* Similar to post_error_ne, but NUM is the number to use for the '^'. */
10601
10602 void
post_error_ne_num(const char * msg,Node_Id node,Entity_Id ent,int num)10603 post_error_ne_num (const char *msg, Node_Id node, Entity_Id ent, int num)
10604 {
10605 Error_Msg_Uint_1 = UI_From_Int (num);
10606 post_error_ne (msg, node, ent);
10607 }
10608
10609 /* Similar to post_error_ne, but T is a GCC tree representing the number to
10610 write. If T represents a constant, the text inside curly brackets in
10611 MSG will be output (presumably including a '^'). Otherwise it will not
10612 be output and the text inside square brackets will be output instead. */
10613
10614 void
post_error_ne_tree(const char * msg,Node_Id node,Entity_Id ent,tree t)10615 post_error_ne_tree (const char *msg, Node_Id node, Entity_Id ent, tree t)
10616 {
10617 char *new_msg = XALLOCAVEC (char, strlen (msg) + 1);
10618 char start_yes, end_yes, start_no, end_no;
10619 const char *p;
10620 char *q;
10621
10622 if (TREE_CODE (t) == INTEGER_CST)
10623 {
10624 Error_Msg_Uint_1 = UI_From_gnu (t);
10625 start_yes = '{', end_yes = '}', start_no = '[', end_no = ']';
10626 }
10627 else
10628 start_yes = '[', end_yes = ']', start_no = '{', end_no = '}';
10629
10630 for (p = msg, q = new_msg; *p; p++)
10631 {
10632 if (*p == start_yes)
10633 for (p++; *p != end_yes; p++)
10634 *q++ = *p;
10635 else if (*p == start_no)
10636 for (p++; *p != end_no; p++)
10637 ;
10638 else
10639 *q++ = *p;
10640 }
10641
10642 *q = 0;
10643
10644 post_error_ne (new_msg, node, ent);
10645 }
10646
10647 /* Similar to post_error_ne_tree, but NUM is a second integer to write. */
10648
10649 void
post_error_ne_tree_2(const char * msg,Node_Id node,Entity_Id ent,tree t,int num)10650 post_error_ne_tree_2 (const char *msg, Node_Id node, Entity_Id ent, tree t,
10651 int num)
10652 {
10653 Error_Msg_Uint_2 = UI_From_Int (num);
10654 post_error_ne_tree (msg, node, ent, t);
10655 }
10656
10657 /* Return a label to branch to for the exception type in KIND or Empty
10658 if none. */
10659
10660 Entity_Id
get_exception_label(char kind)10661 get_exception_label (char kind)
10662 {
10663 switch (kind)
10664 {
10665 case N_Raise_Constraint_Error:
10666 return gnu_constraint_error_label_stack.last ();
10667
10668 case N_Raise_Storage_Error:
10669 return gnu_storage_error_label_stack.last ();
10670
10671 case N_Raise_Program_Error:
10672 return gnu_program_error_label_stack.last ();
10673
10674 default:
10675 return Empty;
10676 }
10677
10678 gcc_unreachable ();
10679 }
10680
10681 /* Return the decl for the current elaboration procedure. */
10682
10683 static tree
get_elaboration_procedure(void)10684 get_elaboration_procedure (void)
10685 {
10686 return gnu_elab_proc_stack->last ();
10687 }
10688
10689 /* Return the controlling type of a dispatching subprogram. */
10690
10691 static Entity_Id
get_controlling_type(Entity_Id subprog)10692 get_controlling_type (Entity_Id subprog)
10693 {
10694 /* This is modeled on Expand_Interface_Thunk. */
10695 Entity_Id controlling_type = Etype (First_Formal (subprog));
10696 if (Is_Access_Type (controlling_type))
10697 controlling_type = Directly_Designated_Type (controlling_type);
10698 controlling_type = Underlying_Type (controlling_type);
10699 if (Is_Concurrent_Type (controlling_type))
10700 controlling_type = Corresponding_Record_Type (controlling_type);
10701 controlling_type = Base_Type (controlling_type);
10702 return controlling_type;
10703 }
10704
10705 /* Return whether we should use an alias for the TARGET of a thunk
10706 in order to make the call generated in the thunk local. */
10707
10708 static bool
use_alias_for_thunk_p(tree target)10709 use_alias_for_thunk_p (tree target)
10710 {
10711 /* We cannot generate a local call in this case. */
10712 if (DECL_EXTERNAL (target))
10713 return false;
10714
10715 /* The call is already local in this case. */
10716 if (TREE_CODE (DECL_CONTEXT (target)) == FUNCTION_DECL)
10717 return false;
10718
10719 return TARGET_USE_LOCAL_THUNK_ALIAS_P (target);
10720 }
10721
10722 static GTY(()) unsigned long thunk_labelno = 0;
10723
10724 /* Create an alias for TARGET to be used as the target of a thunk. */
10725
10726 static tree
make_alias_for_thunk(tree target)10727 make_alias_for_thunk (tree target)
10728 {
10729 char buf[64];
10730 targetm.asm_out.generate_internal_label (buf, "LTHUNK", thunk_labelno++);
10731
10732 tree alias = build_decl (DECL_SOURCE_LOCATION (target), TREE_CODE (target),
10733 get_identifier (buf), TREE_TYPE (target));
10734
10735 DECL_LANG_SPECIFIC (alias) = DECL_LANG_SPECIFIC (target);
10736 DECL_CONTEXT (alias) = DECL_CONTEXT (target);
10737 TREE_READONLY (alias) = TREE_READONLY (target);
10738 TREE_THIS_VOLATILE (alias) = TREE_THIS_VOLATILE (target);
10739 DECL_ARTIFICIAL (alias) = 1;
10740 DECL_INITIAL (alias) = error_mark_node;
10741 DECL_ARGUMENTS (alias) = copy_list (DECL_ARGUMENTS (target));
10742 TREE_ADDRESSABLE (alias) = 1;
10743 SET_DECL_ASSEMBLER_NAME (alias, DECL_NAME (alias));
10744
10745 cgraph_node *n = cgraph_node::create_same_body_alias (alias, target);
10746 gcc_assert (n);
10747
10748 return alias;
10749 }
10750
10751 /* Create the local covariant part of {GNAT,GNU}_THUNK. */
10752
10753 static tree
make_covariant_thunk(Entity_Id gnat_thunk,tree gnu_thunk)10754 make_covariant_thunk (Entity_Id gnat_thunk, tree gnu_thunk)
10755 {
10756 tree gnu_name = create_concat_name (gnat_thunk, "CV");
10757 tree gnu_cv_thunk
10758 = build_decl (DECL_SOURCE_LOCATION (gnu_thunk), TREE_CODE (gnu_thunk),
10759 gnu_name, TREE_TYPE (gnu_thunk));
10760
10761 DECL_ARGUMENTS (gnu_cv_thunk) = copy_list (DECL_ARGUMENTS (gnu_thunk));
10762 for (tree param_decl = DECL_ARGUMENTS (gnu_cv_thunk);
10763 param_decl;
10764 param_decl = DECL_CHAIN (param_decl))
10765 DECL_CONTEXT (param_decl) = gnu_cv_thunk;
10766
10767 DECL_RESULT (gnu_cv_thunk) = copy_node (DECL_RESULT (gnu_thunk));
10768 DECL_CONTEXT (DECL_RESULT (gnu_cv_thunk)) = gnu_cv_thunk;
10769
10770 DECL_LANG_SPECIFIC (gnu_cv_thunk) = DECL_LANG_SPECIFIC (gnu_thunk);
10771 DECL_CONTEXT (gnu_cv_thunk) = DECL_CONTEXT (gnu_thunk);
10772 TREE_READONLY (gnu_cv_thunk) = TREE_READONLY (gnu_thunk);
10773 TREE_THIS_VOLATILE (gnu_cv_thunk) = TREE_THIS_VOLATILE (gnu_thunk);
10774 DECL_ARTIFICIAL (gnu_cv_thunk) = 1;
10775
10776 return gnu_cv_thunk;
10777 }
10778
10779 /* Try to create a GNU thunk for {GNAT,GNU}_THUNK and return true on success.
10780
10781 GNU thunks are more efficient than GNAT thunks because they don't call into
10782 the runtime to retrieve the offset used in the displacement operation, but
10783 they are tailored to C++ and thus too limited to support the full range of
10784 thunks generated in Ada. Here's the complete list of limitations:
10785
10786 1. Multi-controlling thunks, i.e thunks with more than one controlling
10787 parameter, are simply not supported.
10788
10789 2. Covariant thunks, i.e. thunks for which the result is also controlling,
10790 are split into a pair of (this, covariant-only) thunks.
10791
10792 3. Variable-offset thunks, i.e. thunks for which the offset depends on the
10793 object and not only on its type, are supported as 2nd class citizens.
10794
10795 4. External thunks, i.e. thunks for which the target is not declared in
10796 the same unit as the thunk, are supported as 2nd class citizens.
10797
10798 5. Local thunks, i.e. thunks generated for a local type, are supported as
10799 2nd class citizens. */
10800
10801 static bool
maybe_make_gnu_thunk(Entity_Id gnat_thunk,tree gnu_thunk)10802 maybe_make_gnu_thunk (Entity_Id gnat_thunk, tree gnu_thunk)
10803 {
10804 const Entity_Id gnat_target = Thunk_Entity (gnat_thunk);
10805
10806 /* Check that the first formal of the target is the only controlling one. */
10807 Entity_Id gnat_formal = First_Formal (gnat_target);
10808 if (!Is_Controlling_Formal (gnat_formal))
10809 return false;
10810 for (gnat_formal = Next_Formal (gnat_formal);
10811 Present (gnat_formal);
10812 gnat_formal = Next_Formal (gnat_formal))
10813 if (Is_Controlling_Formal (gnat_formal))
10814 return false;
10815
10816 /* Look for the types that control the target and the thunk. */
10817 const Entity_Id gnat_controlling_type = get_controlling_type (gnat_target);
10818 const Entity_Id gnat_interface_type = get_controlling_type (gnat_thunk);
10819
10820 /* We must have an interface type at this point. */
10821 gcc_assert (Is_Interface (gnat_interface_type));
10822
10823 /* Now compute whether the former covers the latter. */
10824 const Entity_Id gnat_interface_tag
10825 = Find_Interface_Tag (gnat_controlling_type, gnat_interface_type);
10826 tree gnu_interface_tag
10827 = Present (gnat_interface_tag)
10828 ? gnat_to_gnu_field_decl (gnat_interface_tag)
10829 : NULL_TREE;
10830 tree gnu_interface_offset
10831 = gnu_interface_tag ? byte_position (gnu_interface_tag) : NULL_TREE;
10832
10833 /* There are three ways to retrieve the offset between the interface view
10834 and the base object. Either the controlling type covers the interface
10835 type and the offset of the corresponding tag is fixed, in which case it
10836 can be statically encoded in the thunk (see FIXED_OFFSET below). Or the
10837 controlling type doesn't cover the interface type but is of fixed size,
10838 in which case the offset is stored in the dispatch table, two pointers
10839 above the dispatch table address (see VIRTUAL_VALUE below). Otherwise,
10840 the offset is variable and is stored right after the tag in every object
10841 (see INDIRECT_OFFSET below). See also a-tags.ads for more details. */
10842 HOST_WIDE_INT fixed_offset, virtual_value, indirect_offset;
10843 tree virtual_offset;
10844
10845 if (gnu_interface_offset && TREE_CODE (gnu_interface_offset) == INTEGER_CST)
10846 {
10847 fixed_offset = - tree_to_shwi (gnu_interface_offset);
10848 virtual_value = 0;
10849 virtual_offset = NULL_TREE;
10850 indirect_offset = 0;
10851 }
10852 else if (!gnu_interface_offset
10853 && !Is_Variable_Size_Record (gnat_controlling_type))
10854 {
10855 fixed_offset = 0;
10856 virtual_value = - 2 * (HOST_WIDE_INT) (POINTER_SIZE / BITS_PER_UNIT);
10857 virtual_offset = build_int_cst (integer_type_node, virtual_value);
10858 indirect_offset = 0;
10859 }
10860 else
10861 {
10862 /* Covariant thunks with variable offset are not supported. */
10863 if (Has_Controlling_Result (gnat_target))
10864 return false;
10865
10866 fixed_offset = 0;
10867 virtual_value = 0;
10868 virtual_offset = NULL_TREE;
10869 indirect_offset = (HOST_WIDE_INT) (POINTER_SIZE / BITS_PER_UNIT);
10870 }
10871
10872 tree gnu_target = gnat_to_gnu_entity (gnat_target, NULL_TREE, false);
10873
10874 /* If the target is local, then thunk and target must have the same context
10875 because cgraph_node::expand_thunk can only forward the static chain. */
10876 if (DECL_STATIC_CHAIN (gnu_target)
10877 && DECL_CONTEXT (gnu_thunk) != DECL_CONTEXT (gnu_target))
10878 return false;
10879
10880 /* If the target returns by invisible reference and is external, apply the
10881 same transformation as Subprogram_Body_to_gnu here. */
10882 if (TREE_ADDRESSABLE (TREE_TYPE (gnu_target))
10883 && DECL_EXTERNAL (gnu_target)
10884 && !POINTER_TYPE_P (TREE_TYPE (DECL_RESULT (gnu_target))))
10885 {
10886 TREE_TYPE (DECL_RESULT (gnu_target))
10887 = build_reference_type (TREE_TYPE (DECL_RESULT (gnu_target)));
10888 relayout_decl (DECL_RESULT (gnu_target));
10889 }
10890
10891 /* The thunk expander requires the return types of thunk and target to be
10892 compatible, which is not fully the case with the CICO mechanism. */
10893 if (TYPE_CI_CO_LIST (TREE_TYPE (gnu_thunk)))
10894 {
10895 tree gnu_target_type = TREE_TYPE (gnu_target);
10896 gcc_assert (TYPE_CI_CO_LIST (gnu_target_type));
10897 TYPE_CANONICAL (TREE_TYPE (TREE_TYPE (gnu_thunk)))
10898 = TYPE_CANONICAL (TREE_TYPE (gnu_target_type));
10899 }
10900
10901 cgraph_node *target_node = cgraph_node::get_create (gnu_target);
10902
10903 /* We may also need to create an alias for the target in order to make
10904 the call local, depending on the linkage of the target. */
10905 tree gnu_alias = use_alias_for_thunk_p (gnu_target)
10906 ? make_alias_for_thunk (gnu_target)
10907 : gnu_target;
10908
10909 /* If the return type of the target is a controlling type, then we need
10910 both an usual this thunk and a covariant thunk in this order:
10911
10912 this thunk --> covariant thunk --> target
10913
10914 For covariant thunks, we can only handle a fixed offset. */
10915 if (Has_Controlling_Result (gnat_target))
10916 {
10917 gcc_assert (fixed_offset < 0);
10918 tree gnu_cv_thunk = make_covariant_thunk (gnat_thunk, gnu_thunk);
10919 target_node->create_thunk (gnu_cv_thunk, gnu_target, false,
10920 - fixed_offset, 0, 0,
10921 NULL_TREE, gnu_alias);
10922
10923 gnu_alias = gnu_target = gnu_cv_thunk;
10924 }
10925
10926 target_node->create_thunk (gnu_thunk, gnu_target, true,
10927 fixed_offset, virtual_value, indirect_offset,
10928 virtual_offset, gnu_alias);
10929
10930 return true;
10931 }
10932
10933 /* Initialize the table that maps GNAT codes to GCC codes for simple
10934 binary and unary operations. */
10935
10936 static void
init_code_table(void)10937 init_code_table (void)
10938 {
10939 gnu_codes[N_Op_And] = TRUTH_AND_EXPR;
10940 gnu_codes[N_Op_Or] = TRUTH_OR_EXPR;
10941 gnu_codes[N_Op_Xor] = TRUTH_XOR_EXPR;
10942 gnu_codes[N_Op_Eq] = EQ_EXPR;
10943 gnu_codes[N_Op_Ne] = NE_EXPR;
10944 gnu_codes[N_Op_Lt] = LT_EXPR;
10945 gnu_codes[N_Op_Le] = LE_EXPR;
10946 gnu_codes[N_Op_Gt] = GT_EXPR;
10947 gnu_codes[N_Op_Ge] = GE_EXPR;
10948 gnu_codes[N_Op_Add] = PLUS_EXPR;
10949 gnu_codes[N_Op_Subtract] = MINUS_EXPR;
10950 gnu_codes[N_Op_Multiply] = MULT_EXPR;
10951 gnu_codes[N_Op_Mod] = FLOOR_MOD_EXPR;
10952 gnu_codes[N_Op_Rem] = TRUNC_MOD_EXPR;
10953 gnu_codes[N_Op_Minus] = NEGATE_EXPR;
10954 gnu_codes[N_Op_Abs] = ABS_EXPR;
10955 gnu_codes[N_Op_Not] = TRUTH_NOT_EXPR;
10956 gnu_codes[N_Op_Rotate_Left] = LROTATE_EXPR;
10957 gnu_codes[N_Op_Rotate_Right] = RROTATE_EXPR;
10958 gnu_codes[N_Op_Shift_Left] = LSHIFT_EXPR;
10959 gnu_codes[N_Op_Shift_Right] = RSHIFT_EXPR;
10960 gnu_codes[N_Op_Shift_Right_Arithmetic] = RSHIFT_EXPR;
10961 gnu_codes[N_And_Then] = TRUTH_ANDIF_EXPR;
10962 gnu_codes[N_Or_Else] = TRUTH_ORIF_EXPR;
10963 }
10964
10965 #include "gt-ada-trans.h"
10966