diff options
Diffstat (limited to 'gcc')
141 files changed, 6476 insertions, 2874 deletions
diff --git a/gcc/ChangeLog b/gcc/ChangeLog index 9d3d5152d08..db516599680 100644 --- a/gcc/ChangeLog +++ b/gcc/ChangeLog @@ -1,3 +1,279 @@ +2012-04-03 Tristan Gingold <gingold@adacore.com> + + * configure.ac: Use GCC_AC_FUNC_MMAP_BLACKLIST instead + of gcc_AC_FUNC_MMAP_BLACKLIST. + * acinclude.m4 (gcc_AC_FUNC_MMAP_BLACKLIST): Remove. + * Makefile.in (aclocal_deps): Add mmap.m4. + * configure: Regenerate. + * aclocal.m4: Regenerate. + +2012-04-03 Richard Guenther <rguenther@suse.de> + + PR tree-optimization/52808 + * tracer.c (tail_duplicate): Return whether we have duplicated + any block. + (tracer): If we have duplicated any block, cleanup the CFG. + * cfghooks.c (duplicate_block): If we duplicated a loop + header but not its loop, destroy the loop because it now has + multiple entries. + * tree-ssa-threadupdate.c (thread_through_loop_header): Tell + the cfg manipulation routines we are not creating a multiple + entry loop. + +2012-04-03 Tristan Gingold <gingold@adacore.com> + + * config/vms/vms-c.c (vms_pragma_nomember_alignment): Handle + 'byte' alignment. + (vms_c_common_override_options): Allow parameterless variadic + functions. + +2012-04-03 Jakub Jelinek <jakub@redhat.com> + + PR tree-optimization/52835 + * tree-data-ref.c (build_rdg): Return NULL if + compute_data_dependences_for_loop failed. + +2012-04-03 Eric Botcazou <ebotcazou@adacore.com> + + * varasm.c (initializer_constant_valid_for_bitfield_p): Return true + for REAL_CST as well. + (output_constructor): Use RECORD_OR_UNION_TYPE_P predicate. + In the bitfield case, if the value is a REAL_CST, convert it first to + an INTEGER_CST. + +2012-04-02 H.J. Lu <hongjiu.lu@intel.com> + + * config.gcc: Use i386/biarchx32.h instead of i386/biarch64.h + for --with-abi={x32|mx32} or --with-multilib-list=mx32. + (supported_defaults): Add abi for i[34567]86-*-* and x86_64-*-*. + + * config/i386/biarchx32.h: New. + +2012-04-02 Anatoly Sokolov <aesok@post.ru> + + * config/arm/arm.h (PREFERRED_RELOAD_CLASS): Remove. + * config/arm/arm.c (TARGET_PREFERRED_RELOAD_CLASS): Define. + (arm_preferred_reload_class): New function. + +2012-04-02 Richard Guenther <rguenther@suse.de> + + PR tree-optimization/52756 + * tree-ssa-threadupdate.c (def_split_header_continue_p): New function. + (thread_through_loop_header): After threading through the loop latch + remove the split part from the loop and clear further threading + opportunities that would create a multiple entry loop. + +2012-04-02 Richard Guenther <rguenther@suse.de> + + PR rtl-optimization/52800 + * cprop.c (execute_rtl_cprop): Call cleanup_cfg with + CLEANUP_CFG_CHANGED. + +2012-04-02 Richard Guenther <rguenther@suse.de> + + PR middle-end/52803 + * loop-init.c (gate_handle_loop2): Destroy loops here if + we don't enter RTL loop optimizers. + +2012-04-02 Uros Bizjak <ubizjak@gmail.com> + + Partially revert: + 2012-03-29 Richard Guenther <rguenther@suse.de> + + * rtl.h (extended_count): Remove. + * combine.c (extended_count): Remove. + +2012-04-02 Dodji Seketeli <dodji@redhat.com> + + PR c++/40942 + * pt.c (more_specialized_fn): Don't apply decay conversion to + types of function parameters. + +2012-04-02 Tristan Gingold <gingold@adacore.com> + + * ggc-page.c (PAGE_L1_SIZE, PAGE_L2_SIZE, LOOKUP_L1, LOOKUP_L2) + (ggc_allocated_p, lookup_page_table_entry, set_page_table_entry) + (alloc_page, init_ggc, clear_marks, struct ggc_pch_data) + (ggc_pch_this_base): Use uintptr_t instead of size_t. + +2012-03-31 H.J. Lu <hongjiu.lu@intel.com> + + PR bootstrap/52784 + * config/i386/i386.c (ix86_option_override_internal): Don't + check TARGET_64BIT if TARGET_64BIT_DEFAULT is false. + +2012-03-31 Eric Botcazou <ebotcazou@adacore.com> + + * tree-cfg.c (call_can_make_abnormal_goto): New predicate. + (stmt_can_make_abnormal_goto): Use it. + (is_ctrl_altering_stmt): Likewise. + +2012-03-30 Naveen H.S <naveen.S@kpitcummins.com> + Kaz Kojima <kkojima@gcc.gnu.org> + + * config/sh/sh.c (push_regs): Skip banked registers when + resbank attribute is specified. + (sh_expand_epilogue): Likewise. + +2012-03-30 Richard Henderson <rth@redhat.com> + + PR debug/52727 + * combine-stack-adj.c (prev_active_insn_bb): New. + (next_active_insn_bb): New. + (force_move_args_size_note): New. + (combine_stack_adjustments_for_block): Use it. + +2012-03-30 Richard Henderson <rth@redhat.com> + + * config/i386/i386.c (struct expand_vec_perm_d): Add one_operand_p. + (ix86_expand_vector_init_duplicate): Initialize it. + (expand_vec_perm_palignr): Likewise. + (ix86_expand_vec_perm_const): Likewise. + (ix86_vectorize_vec_perm_const_ok): Likewise. + (expand_vec_perm_blend): Use it. + (expand_vec_perm_vpermil): Likewise. + (expand_vec_perm_pshufb): Likewise. + (expand_vec_perm_1): Likewise. + (expand_vec_perm_pshuflw_pshufhw): Likewise. + (expand_vec_perm_interleave2): Likewise. + (expand_vec_perm_vpermq_perm_1): Likewise. + (expand_vec_perm_vperm2f128): Likewise. + (expand_vec_perm_interleave3): Likewise. + (expand_vec_perm_vperm2f128_vblend): Likewise. + (expand_vec_perm_vpshufb2_vpermq): Likewise. + (expand_vec_perm_vpshufb2_vpermq_even_odd): Likewise,. + (expand_vec_perm_broadcast): Likewise. + (expand_vec_perm_vpshufb4_vpermq2): Likewise. + +2012-03-30 Richard Henderson <rth@redhat.com> + + * dwarf2out.c (gen_variable_die): Initialize off. + +2012-03-30 Tristan Gingold <gingold@adacore.com> + + * config/vms/vms-f.c: New file. + * config/vms/t-vms (vms-f.o): New rule. + * config.gcc (*-*-*vms*): Define fortran_target_objs. + +2012-03-30 Richard Guenther <rguenther@suse.de> + + PR tree-optimization/52754 + * tree-ssa-forwprop.c (forward_propagate_addr_expr_1): Only + propagate arbitrary addresses into really plain dereferences. + +2012-03-30 Richard Guenther <rguenther@suse.de> + + PR middle-end/52772 + * except.c (emit_to_new_bb_before): Move loop updating ... + (dw2_build_landing_pads): ... here. Use a proper block for + querying the loop father. + +2012-03-30 Tristan Gingold <gingold@adacore.com> + + * config/ia64/ia64.c (ia64_section_type_flags): Remove + common_object attribute handling. + (SECTION_VMS_OVERLAY): Remove + (ia64_vms_common_object_attribute): Replace abort with an assert. + Do not set DECL_SECTION_NAME. + (ia64_vms_output_aligned_decl_common): Handle common_object + attribute. + (ia64_vms_elf_asm_named_section): Remove. + * config/ia64/vms.h (TARGET_ASM_NAMED_SECTION): Remove. + +2012-03-30 Richard Guenther <rguenther@suse.de> + + PR middle-end/52786 + * double-int.c (rshift_double): Remove not needed cast. + +2012-03-30 Richard Guenther <rguenther@suse.de> + + * tree-affine.h (print_aff): Remove. + * tree-affine.c (print_aff): Make static. + * tree-data-ref.h (access_matrix_get_index_for_parameter): Remove. + (get_references_in_stmt): Likewise. + (print_direction_vector): Likewise. + (print_dir_vectors): Likewise. + (print_dist_vectors): Likewise. + (dump_subscript): Likewise. + (dump_ddrs): Likewise. + (dump_dist_dir_vectors): Likewise. + (dump_data_references): Likewise. + (dump_data_dependence_relation): Likewise. + (dump_data_dependence_direction): Likewise. + (dump_rdg_vertex): Likewise. + (dump_rdg_component): Likewise. + (debug_ddrs): Declare. + (struct data_ref_loc_d): Move ... + * tree-data-ref.c (struct data_ref_loc_d): ... here. + (get_references_in_stmt): Make static. + (dump_data_references): Likewise. + (dump_subscript): Likewise. + (print_direction_vector): Likewise. + (print_dir_vectors): Likewise. + (print_dist_vectors): Likewise. + (dump_data_dependence_relation): Likewise. + (dump_dist_dir_vectors): Likewise. + (dump_ddrs): Likewise. + (dump_rdg_vertex): Likewise. + (dump_rdg_component): Likewise. + (debug_ddrs): New function. + (access_matrix_get_index_for_parameter): Remove. + +2012-03-30 Tristan Gingold <gingold@adacore.com> + + * config/vms/vms.c (VMS_CRTL_FLOAT32): Rename. + (VMS_CRTL_FLOAT64, VMS_CRTL_FLOAT64_VAXD): New. + (VMS_CRTL_FLOAT128, VMS_CRTL_DPML, VMS_CRTL_NODMPL) + (VMS_CRTL_32ONLY, VMS_CRTL_G_MASK, VMS_CRTL_G_NONE) + (VMS_CRTL_GA, VMS_CRTL_GL, VMS_CRTL_FLOATV2): New. + (vms_patch_builtins): Handle new flags + * config/vms/vms-crtlmap.map: Completed using nm on + c and math system libraries. + * config/vms/make-crtlmap.awk: Handle any number of flags. + +2012-03-30 Martin Jambor <mjambor@suse.cz> + + * tree-ssa-ccp.c (insert_clobbers_for_var): Do not assert that there + is a builtin_stack_save in a dominating BB. + +2012-03-29 Uros Bizjak <ubizjak@gmail.com> + + * config/i386/sse.md (avx_h<plusminus_insn>v4df3): Fix results + crossing 128bit lane boundary. + +2012-03-29 Vladimir Makarov <vmakarov@redhat.com> + + * ira-color.c (setup_left_conflict_sizes_p): Process all + conflicting objects. + +2012-03-29 Jakub Jelinek <jakub@redhat.com> + + PR tree-optimization/52760 + * tree-vect-slp.c (vect_get_constant_vectors): Convert constant_p + shift count for {L,R}{SHIFT,ROTATE}_EXPR to TREE_TYPE (vector_type). + +2012-03-29 Richard Guenther <rguenther@suse.de> + + * cgraph.h (cgraph_materialize_all_clones): Remove. + (reset_inline_failed): Likewise. + * cgraphunit.c (cgraph_materialize_all_clones): Make static. + * cgraphbuild.c (reset_inline_failed): Remove. + * rtl.h (cse_main): Remove. + (extended_count): Likewise. + * cse.c (dump_class): Mark as DEBUG_FUNCTION. + (cse_main): Make static. + * combine.c (extended_count): Remove. + (dump_combine_stats): Mark as DEBUG_FUNCTION. + * basic-block.h (reorder_basic_blocks): Remove. + * bb-reorder.c (reorder_basic_blocks): Make static. + * Makefile.in (dse.o): Remove dse.h dependency. + * dse.h: Remove. + * dse.c (gate_dse): Remove. + (clear_alias_mode_eq): Likewise. + (clear_alias_mode_hash): Likewise. + (dse_record_singleton_alias_set): Likewise. + (dse_invalidate_singleton_alias_set): Likewise. + 2012-03-29 H.J. Lu <hongjiu.lu@intel.com> * config/linux-android.h (ANDROID_STARTFILE_SPEC): Use diff --git a/gcc/DATESTAMP b/gcc/DATESTAMP index 72fd57d8921..7fc43becf8f 100644 --- a/gcc/DATESTAMP +++ b/gcc/DATESTAMP @@ -1 +1 @@ -20120329 +20120403 diff --git a/gcc/Makefile.in b/gcc/Makefile.in index d50faccca52..8fd82089563 100644 --- a/gcc/Makefile.in +++ b/gcc/Makefile.in @@ -1650,6 +1650,7 @@ aclocal_deps = \ $(srcdir)/../config/unwind_ipinfo.m4 \ $(srcdir)/../config/warnings.m4 \ $(srcdir)/../config/dfp.m4 \ + $(srcdir)/../config/mmap.m4 \ $(srcdir)/acinclude.m4 $(srcdir)/configure: @MAINT@ $(srcdir)/configure.ac $(srcdir)/aclocal.m4 @@ -3011,7 +3012,7 @@ dce.o : dce.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) $(RTL_H) \ dse.o : dse.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) $(RTL_H) \ $(TREE_H) $(TM_P_H) $(REGS_H) hard-reg-set.h $(FLAGS_H) insn-config.h \ $(RECOG_H) $(EXPR_H) $(DF_H) cselib.h $(DBGCNT_H) $(TIMEVAR_H) \ - $(TREE_PASS_H) alloc-pool.h $(ALIAS_H) dse.h $(OPTABS_H) $(TARGET_H) \ + $(TREE_PASS_H) alloc-pool.h $(ALIAS_H) $(OPTABS_H) $(TARGET_H) \ $(BITMAP_H) $(PARAMS_H) fwprop.o : fwprop.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) $(RTL_H) \ $(DIAGNOSTIC_CORE_H) insn-config.h $(RECOG_H) $(FLAGS_H) $(OBSTACK_H) $(BASIC_BLOCK_H) \ diff --git a/gcc/acinclude.m4 b/gcc/acinclude.m4 index 84b828fe598..c24464b5977 100644 --- a/gcc/acinclude.m4 +++ b/gcc/acinclude.m4 @@ -221,99 +221,6 @@ test -z "$INSTALL_DATA" && INSTALL_DATA='${INSTALL} -m 644' AC_SUBST(INSTALL_DATA)dnl ]) -# mmap(2) blacklisting. Some platforms provide the mmap library routine -# but don't support all of the features we need from it. -AC_DEFUN([gcc_AC_FUNC_MMAP_BLACKLIST], -[ -AC_CHECK_HEADER([sys/mman.h], - [gcc_header_sys_mman_h=yes], [gcc_header_sys_mman_h=no]) -AC_CHECK_FUNC([mmap], [gcc_func_mmap=yes], [gcc_func_mmap=no]) -if test "$gcc_header_sys_mman_h" != yes \ - || test "$gcc_func_mmap" != yes; then - gcc_cv_func_mmap_file=no - gcc_cv_func_mmap_dev_zero=no - gcc_cv_func_mmap_anon=no -else - AC_CACHE_CHECK([whether read-only mmap of a plain file works], - gcc_cv_func_mmap_file, - [# Add a system to this blacklist if - # mmap(0, stat_size, PROT_READ, MAP_PRIVATE, fd, 0) doesn't return a - # memory area containing the same data that you'd get if you applied - # read() to the same fd. The only system known to have a problem here - # is VMS, where text files have record structure. - case "$host_os" in - vms* | ultrix*) - gcc_cv_func_mmap_file=no ;; - *) - gcc_cv_func_mmap_file=yes;; - esac]) - AC_CACHE_CHECK([whether mmap from /dev/zero works], - gcc_cv_func_mmap_dev_zero, - [# Add a system to this blacklist if it has mmap() but /dev/zero - # does not exist, or if mmapping /dev/zero does not give anonymous - # zeroed pages with both the following properties: - # 1. If you map N consecutive pages in with one call, and then - # unmap any subset of those pages, the pages that were not - # explicitly unmapped remain accessible. - # 2. If you map two adjacent blocks of memory and then unmap them - # both at once, they must both go away. - # Systems known to be in this category are Windows (all variants), - # VMS, and Darwin. - case "$host_os" in - vms* | cygwin* | pe | mingw* | darwin* | ultrix* | hpux10* | hpux11.00) - gcc_cv_func_mmap_dev_zero=no ;; - *) - gcc_cv_func_mmap_dev_zero=yes;; - esac]) - - # Unlike /dev/zero, the MAP_ANON(YMOUS) defines can be probed for. - AC_CACHE_CHECK([for MAP_ANON(YMOUS)], gcc_cv_decl_map_anon, - [AC_COMPILE_IFELSE([AC_LANG_PROGRAM( -[#include <sys/types.h> -#include <sys/mman.h> -#include <unistd.h> - -#ifndef MAP_ANONYMOUS -#define MAP_ANONYMOUS MAP_ANON -#endif -], -[int n = MAP_ANONYMOUS;])], - gcc_cv_decl_map_anon=yes, - gcc_cv_decl_map_anon=no)]) - - if test $gcc_cv_decl_map_anon = no; then - gcc_cv_func_mmap_anon=no - else - AC_CACHE_CHECK([whether mmap with MAP_ANON(YMOUS) works], - gcc_cv_func_mmap_anon, - [# Add a system to this blacklist if it has mmap() and MAP_ANON or - # MAP_ANONYMOUS, but using mmap(..., MAP_PRIVATE|MAP_ANONYMOUS, -1, 0) - # doesn't give anonymous zeroed pages with the same properties listed - # above for use of /dev/zero. - # Systems known to be in this category are Windows, VMS, and SCO Unix. - case "$host_os" in - vms* | cygwin* | pe | mingw* | sco* | udk* ) - gcc_cv_func_mmap_anon=no ;; - *) - gcc_cv_func_mmap_anon=yes;; - esac]) - fi -fi - -if test $gcc_cv_func_mmap_file = yes; then - AC_DEFINE(HAVE_MMAP_FILE, 1, - [Define if read-only mmap of a plain file works.]) -fi -if test $gcc_cv_func_mmap_dev_zero = yes; then - AC_DEFINE(HAVE_MMAP_DEV_ZERO, 1, - [Define if mmap of /dev/zero works.]) -fi -if test $gcc_cv_func_mmap_anon = yes; then - AC_DEFINE(HAVE_MMAP_ANON, 1, - [Define if mmap with MAP_ANON(YMOUS) works.]) -fi -]) - dnl Determine if enumerated bitfields are unsigned. ISO C says they can dnl be either signed or unsigned. dnl diff --git a/gcc/aclocal.m4 b/gcc/aclocal.m4 index 06028cc051f..a992c3a96ed 100644 --- a/gcc/aclocal.m4 +++ b/gcc/aclocal.m4 @@ -113,6 +113,7 @@ m4_include([../config/lcmessage.m4]) m4_include([../config/lib-ld.m4]) m4_include([../config/lib-link.m4]) m4_include([../config/lib-prefix.m4]) +m4_include([../config/mmap.m4]) m4_include([../config/override.m4]) m4_include([../config/picflag.m4]) m4_include([../config/progtest.m4]) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 7b8832d2992..69c2a847d78 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,319 @@ +2012-04-02 Robert Dewar <dewar@adacore.com> + + * s-atopri.ads: Minor reformatting. + +2012-04-02 Thomas Quinot <quinot@adacore.com> + + * sem_util.adb: Minor reformatting, minor code cleanup. + +2012-04-02 Ed Schonberg <schonberg@adacore.com> + + * lib-xref.adb (Generate_Reference): For a reference to an + operator symbol, set the sloc to point to the first character + of the operator name, and not to the initial quaote. + (Output_References): Ditto for the definition of an operator + symbol. + +2012-04-02 Vincent Celier <celier@adacore.com> + + * ali.adb (Scan_Ali): Recognize Z lines. Set + Implicit_With_From_Instantiation to True in the With_Record for + Z lines. + * ali.ads (With_Record): New Boolean component + Implicit_With_From_Instantiation, defaulted to False. + * csinfo.adb: Indicate that Implicit_With_From_Instantiation + is special + * lib-writ.adb (Write_ALI): New array Implicit_With. + (Collect_Withs): Set Implicit_With for the unit is it is not Yes. + (Write_With_Lines): Write a Z line instead of a W line if + Implicit_With is Yes for the unit. + * sem_ch12.adb (Inherit_Context): Only add a unit in the context + if it is not there yet. + * sinfo.ads: New flag Implicit_With_From_Instantiation (Flag12) + added. + +2012-04-02 Yannick Moy <moy@adacore.com> + + * osint.adb, osint.ads (Add_Default_Search_Dirs): Add library + search dirs in file specified with option -gnateO. + +2012-04-02 Robert Dewar <dewar@adacore.com> + + * sem_ch5.adb, exp_util.adb, sem_util.adb, exp_ch4.adb: Minor + reformatting. + +2012-04-02 Olivier Hainque <hainque@adacore.com> + + * g-sse.ads: Add x86-solaris and x86_64-darwin to the set of + platforms where the use of this spec is supported. Add current + year to the copyright notice. + * gcc-interfaces/Makefile.in: Add g-sse.o and g-ssvety.o to + EXTRA_GNATRTL_NONTASKING_OBJS on x86 32/64 targets that support + it and where they were missing (x86-solaris, x86-freebsd, + x86_64-freebsd, and x86-darwin). + +2012-04-02 Gary Dismukes <dismukes@adacore.com> + + * bindgen.adb (Gen_Ada_Init): When compiling for the AAMP small + library, where we no longer suppress the Standard_Library, + generate an empty body rather than the usual generation of + assignments to imported globals, since those aren't present in + the small library. + +2012-04-02 Ed Schonberg <schonberg@adacore.com> + + * sinfo.ads: Minor documentation fix. + +2012-04-02 Hristian Kirtchev <kirtchev@adacore.com> + + * sem_res.adb (Resolve_Conditional_Expression): Add local variables + Else_Typ and Then_Typ. Add missing type conversions to the "then" and + "else" expressions when their respective types are scalar. + +2012-04-02 Vincent Pucci <pucci@adacore.com> + + * exp_ch9.adb: Reordering of the local subprograms. New Table + for the lock free implementation that maps each protected + subprograms with the protected component it references. + (Allow_Lock_Free_Implementation): New routine. Check if + the protected body enables the lock free implementation. + (Build_Lock_Free_Protected_Subprogram_Body): New routine. + (Build_Lock_Free_Unprotected_Subprogram_Body): New routine. + (Comp_Of): New routine. + * Makefile.rtl: Add s-atopri.o + * debug.adb: New compiler debug flag -gnatd9 for lock free + implementation. + * rtsfind.ads: RE_Atomic_Compare_Exchange_8, + RE_Atomic_Compare_Exchange_16, RE_Atomic_Compare_Exchange_32, + RE_Atomic_Compare_Exchange_64, RE_Atomic_Load_8, + RE_Atomic_Load_16, RE_Atomic_Load_32, RE_Atomic_Load_64, RE_Uint8, + RE_Uint16, RE_Uint32, RE_Uint64 added. + * s-atropi.ads: New file. Defines atomic primitives used + by the lock free implementation. + +2012-04-02 Emmanuel Briot <briot@adacore.com> + + * g-expect.adb (Expect_Internal): Fix leak of the input file descriptor. + +2012-04-02 Hristian Kirtchev <kirtchev@adacore.com> + + * exp_ch4.adb (Expand_N_Quantified_Expression): Reimplemented. + The expansion no longer uses the copy of the original QE created + during analysis. + * sem.adb (Analyze): Add processing for loop parameter specifications. + * sem_ch4.adb (Analyze_Quantified_Expression): Reimplemented. The + routine no longer creates a copy of the original QE. All + constituents of a QE are now preanalyzed and resolved. + * sem_ch5.adb (Analyze_Iteration_Scheme): Remove the guard which + bypasses all processing when the iteration scheme is related to a + QE. Relovate the code which analyzes loop parameter specifications + to a separate routine. (Analyze_Iterator_Specification): + Preanalyze the iterator name. This action was originally + done in Analyze_Iteration_Scheme. Update the check which + detects an iterator specification in the context of a QE. + (Analyze_Loop_Parameter_Specification): New routine. This + procedure allows for a stand-alone analysis of a loop parameter + specification without the need of a parent iteration scheme. Add + code to update the type of the loop variable when the range + generates an itype and the context is a QE. + (Pre_Analyze_Range): Renamed to Preanalyze_Range. Update all references + to the routine. + * sem_ch5.ads: Code reformatting. + (Analyze_Loop_Parameter_Specification): New routine. + * sem_ch6.adb (Fully_Conformant_Expressions): Detect a case + when establishing conformance between two QEs utilizing different + specifications. + * sem_res.adb (Proper_Current_Scope): New routine. + (Resolve): Do not resolve a QE as there is nothing to be done now. + Ignore any loop scopes generated for QEs when detecting an expression + function as the scopes are cosmetic and do not appear in the tree. + (Resolve_Quantified_Expression): Removed. All resolution of + QE constituents is now performed during analysis. This ensures + that loop variables appearing in array aggregates are properly + resolved. + +2012-04-02 Ed Schonberg <schonberg@adacore.com> + + * sem_util.adb (Build_Default_Subtype): If the base type is + private and its full view is available, use the full view in + the subtype declaration. + +2012-04-02 Jose Ruiz <ruiz@adacore.com> + + * gnat_ugn.texi: Add some minimal documentation about how to + use GNATtest for cross platforms. + +2012-04-02 Vincent Celier <celier@adacore.com> + + * opt.ads (Object_Path_File_Name): New variable. + * prj-attr.adb: New Compiler attribute Object_Path_Switches. + * prj-nmsc.adb (Process_Compiler): Recognize new attribute + Object_Path_Switches. + * snames.ads-tmpl: New standard name Object_Path_Switches. + * switch-c.adb (Scan_Front_End_Switches): Recognize new switch + -gnateO= and put its value in Opt.Object_Path_File_Name. + +2012-04-02 Hristian Kirtchev <kirtchev@adacore.com> + + * exp_ch7.adb (Process_Declarations): Detect a case where + a source object was initialized by another source object, + but the expression was rewritten as a class-wide conversion + of Ada.Tags.Displace. + * exp_util.adb (Initialized_By_Ctrl_Function): Removed. + (Is_Controlled_Function_Call): New routine. + (Is_Displacement_Of_Ctrl_Function_Result): Removed. + (Is_Displacement_Of_Object_Or_Function_Result): New routine. + (Is_Source_Object): New routine. + (Requires_Cleanup_Actions): Detect a case where a source object was + initialized by another source object, but the expression was rewritten + as a class-wide conversion of Ada.Tags.Displace. + * exp_util.ads (Is_Displacement_Of_Ctrl_Function_Result): Removed. + (Is_Displacement_Of_Object_Or_Function_Result): New routine. + +2012-04-02 Ed Schonberg <schonberg@adacore.com> + + * sem_res.adb (Resolve_Call): A call to an expression function + does not freeze if it appears in a different scope from the + expression function itself. Such calls appear in the generated + bodies of other expression functions, or in pre/postconditions + of subsequent subprograms. + +2012-04-02 Yannick Moy <moy@adacore.com> + + * lib-xref-alfa.adb: Code clean up. + +2012-04-02 Ed Schonberg <schonberg@adacore.com> + + * sem_ch12.adb (Analyze_Subprogram_Instantiation): Do not suppress + style checks, because the subprogram instance itself may contain + violations of syle rules. + * style.adb (Missing_Overriding): Check for missing overriding + indicator on a subprogram instance. + +2012-04-02 Hristian Kirtchev <kirtchev@adacore.com> + + * sem_ch6.adb (Last_Implicit_Declaration): New routine. + (Process_PPCs): Insert the body of _postconditions after the + last internally generated declaration. This ensures that actual + subtypes created for formal parameters are visible and properly + frozen as _postconditions may reference them. + +2012-04-02 Robert Dewar <dewar@adacore.com> + + * einfo.adb (First_Component_Or_Discriminant) Now applies to + all types with discriminants, not just records. + * exp_attr.adb (Expand_N_Attribute): Add Scalar_Values handling + for arrays, scalars and non-variant records. + * sem_attr.adb (Analyze_Attribute): Handle Valid_Scalars + * sem_attr.ads (Valid_Scalars): Update description + * sem_util.ads, sem_util.adb (No_Scalar_Parts): New function. + +2012-03-31 Eric Botcazou <ebotcazou@adacore.com> + + Revert + 2012-03-25 Eric Botcazou <ebotcazou@adacore.com> + + * gcc-interface/decl.c (SS_MARK_NAME): New define. + (gnat_to_gnu_entity) <E_Function>: Prepend leaf attribute on entities + whose name is SS_MARK_NAME. + +2012-03-30 Robert Dewar <dewar@adacore.com> + + * exp_ch5.adb, sem_util.adb, exp_ch4.adb: Minor comment updates. + +2012-03-30 Yannick Moy <moy@adacore.com> + + * lib-xref-alfa.adb (Add_Alfa_File): Treat possibly 2 units at the same + time, putting all scopes in the same Alfa file. + (Add_Alfa_Xrefs): Correct errors in comparison function. Correct value + of Def component. + (Collect_Alfa): Possibly pass 2 units to Add_Alfa_File. + +2012-03-30 Hristian Kirtchev <kirtchev@adacore.com> + + * exp_util.adb (Is_Secondary_Stack_BIP_Func_Call): Handle a case where + a build-in-place call appears as Prefix'Reference'Reference. + +2012-03-30 Yannick Moy <moy@adacore.com> + + * lib-xref-alfa.adb: Minor refactoring to remove internal package. + +2012-03-30 Hristian Kirtchev <kirtchev@adacore.com> + + * sem_ch5.adb (Analyze_Iteration_Scheme): Preanalyze the subtype + definition of a loop when the context is a quantified expression. + +2012-03-30 Vincent Celier <celier@adacore.com> + + * prj.ads: Minor comment update. + +2012-03-30 Yannick Moy <moy@adacore.com> + + * lib-xref-alfa.adb, alloc.ads, lib-xref.ads: Minor addition of + comments and refactoring. + +2012-03-30 Robert Dewar <dewar@adacore.com> + + * lib-xref.adb, lib-xref-alfa.adb: Minor reformatting & code + reorganization. + +2012-03-30 Yannick Moy <moy@adacore.com> + + * lib-xref-alfa.adb (Generate_Dereference): Use Get_Code_Unit + instead of Get_Source_Unit to get file for reference. + (Traverse_Compilation_Unit): Do not add scopes for generic units. + * lib-xref.adb (Generate_Reference): Use Get_Code_Unit instead + of Get_Source_Unit to get file for reference. + * sem_ch12.adb (Analyze_Package_Instantiation): Enable + instantiation in Alfa mode. + +2012-03-30 Hristian Kirtchev <kirtchev@adacore.com> + + * exp_ch7.adb (Process_Declarations): Replace + the call to Is_Null_Access_BIP_Func_Call with + Is_Secondary_Stack_BIP_Func_Call. Update the related comment. + * exp_util.adb (Is_Null_Access_BIP_Func_Call): Removed. + (Is_Secondary_Stack_BIP_Func_Call): New routine. + (Requires_Cleanup_Actions): Replace + the call to Is_Null_Access_BIP_Func_Call with + Is_Secondary_Stack_BIP_Func_Call. Update the related comment. + * exp_util.ads (Is_Null_Access_BIP_Func_Call): Removed. + (Is_Secondary_Stack_BIP_Func_Call): New routine. + +2012-03-30 Yannick Moy <moy@adacore.com> + + * lib-xref-alfa.adb, lib-xref.adb: Code clean ups. + +2012-03-30 Gary Dismukes <dismukes@adacore.com> + + * exp_ch5.adb (Expand_Iterator_Loop_Over_Array): For the case of a + loop entity which is rewritten as a renaming + of the indexed array, explicitly mark the entity as needing + debug info so that Materialize entity will be set later by + Debug_Renaming_Declaration when the renaming is expanded. + +2012-03-30 Robert Dewar <dewar@adacore.com> + + * sem_attr.ads: Update comment. + +2012-03-30 Vincent Celier <celier@adacore.com> + + * prj.ads: New Dependency_Kind: ALI_Closure. + +2012-03-30 Thomas Quinot <quinot@adacore.com> + + * exp_pakd.adb: Minor reformatting. + +2012-03-30 Yannick Moy <moy@adacore.com> + + * lib-xref-alfa.adb (Add_Alfa_File): Take into account possible absence + of compilation unit for unit in Sdep_Table. + +2012-03-30 Thomas Quinot <quinot@adacore.com> + + * freeze.adb (Freeze_Record_Type): For a type with reversed bit + order and reversed storage order, disable front-end relayout. + 2012-03-25 Eric Botcazou <ebotcazou@adacore.com> * gcc-interface/decl.c (gnat_to_gnu_entity) <E_Record_Subtype>: Copy diff --git a/gcc/ada/Makefile.rtl b/gcc/ada/Makefile.rtl index 71696585458..d3212b20559 100644 --- a/gcc/ada/Makefile.rtl +++ b/gcc/ada/Makefile.rtl @@ -479,6 +479,7 @@ GNATRTL_NONTASKING_OBJS= \ s-assert$(objext) \ s-atacco$(objext) \ s-atocou$(objext) \ + s-atopri$(objext) \ s-auxdec$(objext) \ s-bitops$(objext) \ s-boarop$(objext) \ diff --git a/gcc/ada/ali.adb b/gcc/ada/ali.adb index 93dd10956cc..28307ac72a4 100644 --- a/gcc/ada/ali.adb +++ b/gcc/ada/ali.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -55,6 +55,7 @@ package body ALI is 'X' => True, -- xref 'S' => True, -- specific dispatching 'Y' => True, -- limited_with + 'Z' => True, -- implicit with from instantiation 'C' => True, -- SCO information 'F' => True, -- Alfa information others => False); @@ -782,7 +783,8 @@ package body ALI is -- Acquire lines to be ignored if Read_Xref then - Ignore := ('U' | 'W' | 'Y' | 'D' | 'X' => False, others => True); + Ignore := + ('U' | 'W' | 'Y' | 'Z' | 'D' | 'X' => False, others => True); -- Read_Lines parameter given @@ -1717,7 +1719,7 @@ package body ALI is With_Loop : loop Check_Unknown_Line; - exit With_Loop when C /= 'W' and then C /= 'Y'; + exit With_Loop when C /= 'W' and then C /= 'Y' and then C /= 'Z'; if Ignore ('W') then Skip_Line; @@ -1733,6 +1735,8 @@ package body ALI is Withs.Table (Withs.Last).Elab_All_Desirable := False; Withs.Table (Withs.Last).SAL_Interface := False; Withs.Table (Withs.Last).Limited_With := (C = 'Y'); + Withs.Table (Withs.Last).Implicit_With_From_Instantiation + := (C = 'Z'); -- Generic case with no object file available diff --git a/gcc/ada/ali.ads b/gcc/ada/ali.ads index b2b9b3d7ffc..39943c4fcc7 100644 --- a/gcc/ada/ali.ads +++ b/gcc/ada/ali.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -558,6 +558,9 @@ package ALI is Limited_With : Boolean := False; -- True if unit is named in a limited_with_clause + + Implicit_With_From_Instantiation : Boolean := False; + -- True if this is an implicit with from a generic instantiation end record; package Withs is new Table.Table ( diff --git a/gcc/ada/alloc.ads b/gcc/ada/alloc.ads index c5cad729652..18a2be62157 100644 --- a/gcc/ada/alloc.ads +++ b/gcc/ada/alloc.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -157,4 +157,7 @@ package Alloc is Xrefs_Initial : constant := 5_000; -- Cross-refs Xrefs_Increment : constant := 300; + Drefs_Initial : constant := 5; -- Dereferences + Drefs_Increment : constant := 1_000; + end Alloc; diff --git a/gcc/ada/bindgen.adb b/gcc/ada/bindgen.adb index a4b7d394deb..c44a648e210 100644 --- a/gcc/ada/bindgen.adb +++ b/gcc/ada/bindgen.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -511,6 +511,14 @@ package body Bindgen is if CodePeer_Mode then WBI (" begin"); + -- When compiling for the AAMP small library, where the standard library + -- is no longer suppressed, we still want to exclude the setting of the + -- various imported globals, which aren't present for that library. + + elsif AAMP_On_Target and then Configurable_Run_Time_On_Target then + WBI (" begin"); + WBI (" null;"); + -- If the standard library is suppressed, then the only global variables -- that might be needed (by the Ravenscar profile) are the priority and -- the processor for the environment task. diff --git a/gcc/ada/csinfo.adb b/gcc/ada/csinfo.adb index ef319cff9e5..024af66479c 100644 --- a/gcc/ada/csinfo.adb +++ b/gcc/ada/csinfo.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -218,6 +218,7 @@ begin Set (Special, "Has_Dynamic_Range_Check", True); Set (Special, "Has_Dynamic_Length_Check", True); Set (Special, "Has_Private_View", True); + Set (Special, "Implicit_With_From_Instantiation", True); Set (Special, "Is_Controlling_Actual", True); Set (Special, "Is_Overloaded", True); Set (Special, "Is_Static_Expression", True); diff --git a/gcc/ada/debug.adb b/gcc/ada/debug.adb index bb3e4857ad5..cbcdf0cbb51 100644 --- a/gcc/ada/debug.adb +++ b/gcc/ada/debug.adb @@ -153,7 +153,7 @@ package body Debug is -- d6 Default access unconstrained to thin pointers -- d7 Do not output version & file time stamp in -gnatv or -gnatl mode -- d8 Force opposite endianness in packed stuff - -- d9 + -- d9 Allow lock free implementation -- Debug flags for binder (GNATBIND) @@ -710,6 +710,9 @@ package body Debug is -- opposite endianness from the actual correct value. Useful in -- testing out code generation from the packed routines. + -- d9 This allows lock free implementation for protected objects + -- (see Exp_Ch9). + ------------------------------------------ -- Documentation for Binder Debug Flags -- ------------------------------------------ diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index 0fdc83c3086..0f597a1f941 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -5880,7 +5880,9 @@ package body Einfo is begin pragma Assert - (Is_Record_Type (Id) or else Is_Incomplete_Or_Private_Type (Id)); + (Is_Record_Type (Id) + or else Is_Incomplete_Or_Private_Type (Id) + or else Has_Discriminants (Id)); Comp_Id := First_Entity (Id); while Present (Comp_Id) loop diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index b8058ae2442..355770186db 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -76,6 +76,14 @@ package body Exp_Attr is -- Local Subprograms -- ----------------------- + function Build_Array_VS_Func + (A_Type : Entity_Id; + Nod : Node_Id) return Entity_Id; + -- Build function to test Valid_Scalars for array type A_Type. Nod is the + -- Valid_Scalars attribute node, used to insert the function body, and the + -- value returned is the entity of the constructed function body. We do not + -- bother to generate a separate spec for this subprogram. + procedure Compile_Stream_Body_In_Scope (N : Node_Id; Decl : Node_Id; @@ -174,6 +182,149 @@ package body Exp_Attr is -- expansion. Typically used for rounding and truncation attributes that -- appear directly inside a conversion to integer. + ------------------------- + -- Build_Array_VS_Func -- + ------------------------- + + function Build_Array_VS_Func + (A_Type : Entity_Id; + Nod : Node_Id) return Entity_Id + is + Loc : constant Source_Ptr := Sloc (Nod); + Comp_Type : constant Entity_Id := Component_Type (A_Type); + Body_Stmts : List_Id; + Index_List : List_Id; + Func_Id : Entity_Id; + Formals : List_Id; + + function Test_Component return List_Id; + -- Create one statement to test validity of one component designated by + -- a full set of indexes. Returns statement list containing test. + + function Test_One_Dimension (N : Int) return List_Id; + -- Create loop to test one dimension of the array. The single statement + -- in the loop body tests the inner dimensions if any, or else the + -- single component. Note that this procedure is called recursively, + -- with N being the dimension to be initialized. A call with N greater + -- than the number of dimensions simply generates the component test, + -- terminating the recursion. Returns statement list containing tests. + + -------------------- + -- Test_Component -- + -------------------- + + function Test_Component return List_Id is + Comp : Node_Id; + Anam : Name_Id; + + begin + Comp := + Make_Indexed_Component (Loc, + Prefix => Make_Identifier (Loc, Name_uA), + Expressions => Index_List); + + if Is_Scalar_Type (Comp_Type) then + Anam := Name_Valid; + else + Anam := Name_Valid_Scalars; + end if; + + return New_List ( + Make_If_Statement (Loc, + Condition => + Make_Op_Not (Loc, + Right_Opnd => + Make_Attribute_Reference (Loc, + Attribute_Name => Anam, + Prefix => Comp)), + Then_Statements => New_List ( + Make_Simple_Return_Statement (Loc, + Expression => New_Occurrence_Of (Standard_False, Loc))))); + end Test_Component; + + ------------------------ + -- Test_One_Dimension -- + ------------------------ + + function Test_One_Dimension (N : Int) return List_Id is + Index : Entity_Id; + + begin + -- If all dimensions dealt with, we simply test the component + + if N > Number_Dimensions (A_Type) then + return Test_Component; + + -- Here we generate the required loop + + else + Index := + Make_Defining_Identifier (Loc, New_External_Name ('J', N)); + + Append (New_Reference_To (Index, Loc), Index_List); + + return New_List ( + Make_Implicit_Loop_Statement (Nod, + Identifier => Empty, + Iteration_Scheme => + Make_Iteration_Scheme (Loc, + Loop_Parameter_Specification => + Make_Loop_Parameter_Specification (Loc, + Defining_Identifier => Index, + Discrete_Subtype_Definition => + Make_Attribute_Reference (Loc, + Prefix => Make_Identifier (Loc, Name_uA), + Attribute_Name => Name_Range, + Expressions => New_List ( + Make_Integer_Literal (Loc, N))))), + Statements => Test_One_Dimension (N + 1)), + Make_Simple_Return_Statement (Loc, + Expression => New_Occurrence_Of (Standard_True, Loc))); + end if; + end Test_One_Dimension; + + -- Start of processing for Build_Array_VS_Func + + begin + Index_List := New_List; + Func_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('V')); + + Body_Stmts := Test_One_Dimension (1); + + -- Parameter is always (A : A_Typ) + + Formals := New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => Make_Defining_Identifier (Loc, Name_uA), + In_Present => True, + Out_Present => False, + Parameter_Type => New_Reference_To (A_Type, Loc))); + + -- Build body + + Set_Ekind (Func_Id, E_Function); + Set_Is_Internal (Func_Id); + + Insert_Action (Nod, + Make_Subprogram_Body (Loc, + Specification => + Make_Function_Specification (Loc, + Defining_Unit_Name => Func_Id, + Parameter_Specifications => Formals, + Result_Definition => + New_Occurrence_Of (Standard_Boolean, Loc)), + Declarations => New_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Body_Stmts))); + + if not Debug_Generated_Code then + Set_Debug_Info_Off (Func_Id); + end if; + + return Func_Id; + end Build_Array_VS_Func; + ---------------------------------- -- Compile_Stream_Body_In_Scope -- ---------------------------------- @@ -5373,8 +5524,89 @@ package body Exp_Attr is ------------------- when Attribute_Valid_Scalars => Valid_Scalars : declare + Ftyp : Entity_Id; + begin - raise Program_Error; + if Present (Underlying_Type (Ptyp)) then + Ftyp := Underlying_Type (Ptyp); + else + Ftyp := Ptyp; + end if; + + -- For scalar types, Valid_Scalars is the same as Valid + + if Is_Scalar_Type (Ftyp) then + Rewrite (N, + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Valid, + Prefix => Pref)); + Analyze_And_Resolve (N, Standard_Boolean); + + -- For array types, we construct a function that determines if there + -- are any non-valid scalar subcomponents, and call the function. + -- We only do this for arrays whose component type needs checking + + elsif Is_Array_Type (Ftyp) + and then not No_Scalar_Parts (Component_Type (Ftyp)) + then + Rewrite (N, + Make_Function_Call (Loc, + Name => + New_Occurrence_Of (Build_Array_VS_Func (Ftyp, N), Loc), + Parameter_Associations => New_List (Pref))); + + Analyze_And_Resolve (N, Standard_Boolean); + + -- For record types, we build a big conditional expression, applying + -- Valid or Valid_Scalars as appropriate to all relevant components. + + elsif (Is_Record_Type (Ptyp) or else Has_Discriminants (Ptyp)) + and then not No_Scalar_Parts (Ptyp) + then + declare + C : Entity_Id; + X : Node_Id; + A : Name_Id; + + begin + X := New_Occurrence_Of (Standard_True, Loc); + C := First_Component_Or_Discriminant (Ptyp); + while Present (C) loop + if No_Scalar_Parts (Etype (C)) then + goto Continue; + elsif Is_Scalar_Type (Etype (C)) then + A := Name_Valid; + else + A := Name_Valid_Scalars; + end if; + + X := + Make_And_Then (Loc, + Left_Opnd => X, + Right_Opnd => + Make_Attribute_Reference (Loc, + Attribute_Name => A, + Prefix => + Make_Selected_Component (Loc, + Prefix => + Duplicate_Subexpr (Pref, Name_Req => True), + Selector_Name => + New_Occurrence_Of (C, Loc)))); + <<Continue>> + Next_Component_Or_Discriminant (C); + end loop; + + Rewrite (N, X); + Analyze_And_Resolve (N, Standard_Boolean); + end; + + -- For all other types, result is True (but not static) + + else + Rewrite (N, New_Occurrence_Of (Standard_Boolean, Loc)); + Analyze_And_Resolve (N, Standard_Boolean); + Set_Is_Static_Expression (N, False); + end if; end Valid_Scalars; ----------- diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index d04512ad5e1..02a733cee88 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -3072,7 +3072,7 @@ package body Exp_Ch4 is Low_Bound := Opnd_Low_Bound (1); -- OK, we don't know the lower bound, we have to build a horrible - -- expression actions node of the form + -- conditional expression node of the form -- if Cond1'Length /= 0 then -- Opnd1 low bound @@ -3998,9 +3998,9 @@ package body Exp_Ch4 is end if; end; - -- We set the allocator as analyzed so that when we analyze the - -- expression actions node, we do not get an unwanted recursive - -- expansion of the allocator expression. + -- We set the allocator as analyzed so that when we analyze + -- the conditional expression node, we do not get an unwanted + -- recursive expansion of the allocator expression. Set_Analyzed (N, True); Nod := Relocate_Node (N); @@ -4279,7 +4279,7 @@ package body Exp_Ch4 is -- Expand_N_Conditional_Expression -- ------------------------------------- - -- Deal with limited types and expression actions + -- Deal with limited types and condition actions procedure Expand_N_Conditional_Expression (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); @@ -7832,9 +7832,7 @@ package body Exp_Ch4 is begin -- Do validity check if validity checking operands - if Validity_Checks_On - and then Validity_Check_Operands - then + if Validity_Checks_On and then Validity_Check_Operands then Ensure_Valid (Operand); end if; @@ -7866,7 +7864,7 @@ package body Exp_Ch4 is -- end if; -- end loop; - -- Conversely, an existentially quantified expression: + -- Similarly, an existentially quantified expression: -- for some X in range => Cond @@ -7884,75 +7882,79 @@ package body Exp_Ch4 is -- given by an iterator specification, not a loop parameter specification. procedure Expand_N_Quantified_Expression (N : Node_Id) is - Loc : constant Source_Ptr := Sloc (N); - Is_Universal : constant Boolean := All_Present (N); - Actions : constant List_Id := New_List; - Tnn : constant Entity_Id := Make_Temporary (Loc, 'T', N); - Cond : Node_Id; - Decl : Node_Id; - I_Scheme : Node_Id; - Original_N : Node_Id; - Test : Node_Id; + Actions : constant List_Id := New_List; + For_All : constant Boolean := All_Present (N); + Iter_Spec : constant Node_Id := Iterator_Specification (N); + Loc : constant Source_Ptr := Sloc (N); + Loop_Spec : constant Node_Id := Loop_Parameter_Specification (N); + Cond : Node_Id; + Flag : Entity_Id; + Scheme : Node_Id; + Stmts : List_Id; begin - -- Retrieve the original quantified expression (non analyzed) + -- Create the declaration of the flag which tracks the status of the + -- quantified expression. Generate: - if Present (Loop_Parameter_Specification (N)) then - Original_N := Parent (Parent (Loop_Parameter_Specification (N))); - else - Original_N := Parent (Parent (Iterator_Specification (N))); - end if; + -- Flag : Boolean := (True | False); - -- Rewrite N with the original quantified expression + Flag := Make_Temporary (Loc, 'T', N); - Rewrite (N, Original_N); - - Decl := + Append_To (Actions, Make_Object_Declaration (Loc, - Defining_Identifier => Tnn, + Defining_Identifier => Flag, Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc), Expression => - New_Occurrence_Of (Boolean_Literals (Is_Universal), Loc)); - Append_To (Actions, Decl); + New_Occurrence_Of (Boolean_Literals (For_All), Loc))); + + -- Construct the circuitry which tracks the status of the quantified + -- expression. Generate: + + -- if [not] Cond then + -- Flag := (False | True); + -- exit; + -- end if; Cond := Relocate_Node (Condition (N)); - if Is_Universal then + if For_All then Cond := Make_Op_Not (Loc, Cond); end if; - Test := + Stmts := New_List ( Make_Implicit_If_Statement (N, Condition => Cond, Then_Statements => New_List ( Make_Assignment_Statement (Loc, - Name => New_Occurrence_Of (Tnn, Loc), + Name => New_Occurrence_Of (Flag, Loc), Expression => - New_Occurrence_Of (Boolean_Literals (not Is_Universal), Loc)), - Make_Exit_Statement (Loc))); + New_Occurrence_Of (Boolean_Literals (not For_All), Loc)), + Make_Exit_Statement (Loc)))); - if Present (Loop_Parameter_Specification (N)) then - I_Scheme := + -- Build the loop equivalent of the quantified expression + + if Present (Iter_Spec) then + Scheme := Make_Iteration_Scheme (Loc, - Loop_Parameter_Specification => - Loop_Parameter_Specification (N)); + Iterator_Specification => Iter_Spec); else - I_Scheme := + Scheme := Make_Iteration_Scheme (Loc, - Iterator_Specification => Iterator_Specification (N)); + Loop_Parameter_Specification => Loop_Spec); end if; Append_To (Actions, Make_Loop_Statement (Loc, - Iteration_Scheme => I_Scheme, - Statements => New_List (Test), + Iteration_Scheme => Scheme, + Statements => Stmts, End_Label => Empty)); + -- Transform the quantified expression + Rewrite (N, Make_Expression_With_Actions (Loc, - Expression => New_Occurrence_Of (Tnn, Loc), + Expression => New_Occurrence_Of (Flag, Loc), Actions => Actions)); - Analyze_And_Resolve (N, Standard_Boolean); end Expand_N_Quantified_Expression; diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index 6d00dc806ae..82fc705ecff 100644 --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -2777,7 +2777,7 @@ package body Exp_Ch5 is end loop; -- Loop through elsif parts, dealing with constant conditions and - -- possible expression actions that are present. + -- possible condition actions that are present. if Present (Elsif_Parts (N)) then E := First (Elsif_Parts (N)); @@ -3303,6 +3303,14 @@ package body Exp_Ch5 is New_Reference_To (Component_Type (Array_Typ), Loc), Name => Ind_Comp)); + -- Mark the loop variable as needing debug info, so that expansion + -- of the renaming will result in Materialize_Entity getting set via + -- Debug_Renaming_Declaration. (This setting is needed here because + -- the setting in Freeze_Entity comes after the expansion, which is + -- too late. ???) + + Set_Debug_Info_Needed (Id); + -- for Index in Array loop -- This case utilizes the already given iterator name diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index 0347dcc5bd7..f8730f3d9ab 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -1824,15 +1824,14 @@ package body Exp_Ch7 is -- Obj : Access_Typ := Non_BIP_Function_Call'reference; -- Obj : Access_Typ := - -- BIP_Function_Call - -- (..., BIPaccess => null, ...)'reference; + -- BIP_Function_Call (BIPalloc => 2, ...)'reference; elsif Is_Access_Type (Obj_Typ) and then Needs_Finalization (Available_View (Designated_Type (Obj_Typ))) and then Present (Expr) and then - (Is_Null_Access_BIP_Func_Call (Expr) + (Is_Secondary_Stack_BIP_Func_Call (Expr) or else (Is_Non_BIP_Func_Call (Expr) and then not Is_Related_To_Func_Return (Obj_Id))) @@ -1918,16 +1917,17 @@ package body Exp_Ch7 is Processing_Actions (Has_No_Init => True); -- Detect a case where a source object has been initialized by - -- a controlled function call which was later rewritten as a - -- class-wide conversion of Ada.Tags.Displace. + -- a controlled function call or another object which was later + -- rewritten as a class-wide conversion of Ada.Tags.Displace. - -- Obj : Class_Wide_Type := Function_Call (...); + -- Obj1 : CW_Type := Src_Obj; + -- Obj2 : CW_Type := Function_Call (...); - -- Temp : ... := Function_Call (...)'reference; - -- Obj : Class_Wide_Type renames - -- (... Ada.Tags.Displace (Temp)); + -- Obj1 : CW_Type renames (... Ada.Tags.Displace (Src_Obj)); + -- Tmp : ... := Function_Call (...)'reference; + -- Obj2 : CW_Type renames (... Ada.Tags.Displace (Tmp)); - elsif Is_Displacement_Of_Ctrl_Function_Result (Obj_Id) then + elsif Is_Displacement_Of_Object_Or_Function_Result (Obj_Id) then Processing_Actions (Has_No_Init => True); end if; diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index a827284ff63..212ed30cebd 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -25,6 +25,7 @@ with Atree; use Atree; with Checks; use Checks; +with Debug; use Debug; with Einfo; use Einfo; with Elists; use Elists; with Errout; use Errout; @@ -60,6 +61,7 @@ with Sinfo; use Sinfo; with Snames; use Snames; with Stand; use Stand; with Stringt; use Stringt; +with Table; with Targparm; use Targparm; with Tbuild; use Tbuild; with Uintp; use Uintp; @@ -75,6 +77,34 @@ package body Exp_Ch9 is Entry_Family_Bound : constant Int := 2**16; + ------------------------------ + -- Lock Free Data Structure -- + ------------------------------ + + -- A data structure used for the Lock Free (LF) implementation of protected + -- objects. Since a protected subprogram can only access a single protected + -- component in the LF implementation, this structure stores each protected + -- subprogram and its accessed protected component when the protected + -- object allows the LF implementation. + + type Lock_Free_Sub_Type is record + Sub_Body : Node_Id; + Comp_Id : Entity_Id; + end record; + + subtype Subprogram_Id is Nat; + + -- The following table used for the Lock Free implementation of protected + -- objects maps Lock_Free_Sub_Type to Subprogram_Id. + + package LF_Sub_Table is new Table.Table ( + Table_Component_Type => Lock_Free_Sub_Type, + Table_Index_Type => Subprogram_Id, + Table_Low_Bound => 1, + Table_Initial => 5, + Table_Increment => 5, + Table_Name => "LF_Sub_Table"); + ----------------------- -- Local Subprograms -- ----------------------- @@ -109,6 +139,10 @@ package body Exp_Ch9 is -- Decls is the list of declarations to be enhanced. -- Ent is the entity for the original entry body. + function Allow_Lock_Free_Implementation (N : Node_Id) return Boolean; + -- Given a protected body N, return True if N permits a lock free + -- implementation. + function Build_Accept_Body (Astat : Node_Id) return Node_Id; -- Transform accept statement into a block with added exception handler. -- Used both for simple accept statements and for accept alternatives in @@ -144,6 +178,32 @@ package body Exp_Ch9 is -- of the range of each entry family. A single array with that size is -- allocated for each concurrent object of the type. + function Build_Find_Body_Index (Typ : Entity_Id) return Node_Id; + -- Build the function that translates the entry index in the call + -- (which depends on the size of entry families) into an index into the + -- Entry_Bodies_Array, to determine the body and barrier function used + -- in a protected entry call. A pointer to this function appears in every + -- protected object. + + function Build_Find_Body_Index_Spec (Typ : Entity_Id) return Node_Id; + -- Build subprogram declaration for previous one + + function Build_Lock_Free_Protected_Subprogram_Body + (N : Node_Id; + Pid : Node_Id; + N_Op_Spec : Node_Id) return Node_Id; + -- This function is used to construct the lock free version of a protected + -- subprogram when the protected type denoted by Pid allows the lock free + -- implementation. It only contains a call to the unprotected version of + -- the subprogram body. + + function Build_Lock_Free_Unprotected_Subprogram_Body + (N : Node_Id; + Pid : Node_Id) return Node_Id; + -- This function is used to construct the lock free version of an + -- unprotected subprogram when the protected type denoted by Pid allows the + -- lock free implementation. + function Build_Parameter_Block (Loc : Source_Ptr; Actuals : List_Id; @@ -169,49 +229,6 @@ package body Exp_Ch9 is -- and Decl is the enclosing synchronized type declaration at whose -- freeze point the generated body is analyzed. - function Build_Renamed_Formal_Declaration - (New_F : Entity_Id; - Formal : Entity_Id; - Comp : Entity_Id; - Renamed_Formal : Node_Id) return Node_Id; - -- Create a renaming declaration for a formal, within a protected entry - -- body or an accept body. The renamed object is a component of the - -- parameter block that is a parameter in the entry call. - - -- In Ada 2012, if the formal is an incomplete tagged type, the renaming - -- does not dereference the corresponding component to prevent an illegal - -- use of the incomplete type (AI05-0151). - - procedure Build_Wrapper_Bodies - (Loc : Source_Ptr; - Typ : Entity_Id; - N : Node_Id); - -- Ada 2005 (AI-345): Typ is either a concurrent type or the corresponding - -- record of a concurrent type. N is the insertion node where all bodies - -- will be placed. This routine builds the bodies of the subprograms which - -- serve as an indirection mechanism to overriding primitives of concurrent - -- types, entries and protected procedures. Any new body is analyzed. - - procedure Build_Wrapper_Specs - (Loc : Source_Ptr; - Typ : Entity_Id; - N : in out Node_Id); - -- Ada 2005 (AI-345): Typ is either a concurrent type or the corresponding - -- record of a concurrent type. N is the insertion node where all specs - -- will be placed. This routine builds the specs of the subprograms which - -- serve as an indirection mechanism to overriding primitives of concurrent - -- types, entries and protected procedures. Any new spec is analyzed. - - function Build_Find_Body_Index (Typ : Entity_Id) return Node_Id; - -- Build the function that translates the entry index in the call - -- (which depends on the size of entry families) into an index into the - -- Entry_Bodies_Array, to determine the body and barrier function used - -- in a protected entry call. A pointer to this function appears in every - -- protected object. - - function Build_Find_Body_Index_Spec (Typ : Entity_Id) return Node_Id; - -- Build subprogram declaration for previous one - function Build_Protected_Entry (N : Node_Id; Ent : Entity_Id; @@ -252,6 +269,19 @@ package body Exp_Ch9 is -- a cleanup handler that unlocks the object in all cases. -- (see Exp_Ch7.Expand_Cleanup_Actions). + function Build_Renamed_Formal_Declaration + (New_F : Entity_Id; + Formal : Entity_Id; + Comp : Entity_Id; + Renamed_Formal : Node_Id) return Node_Id; + -- Create a renaming declaration for a formal, within a protected entry + -- body or an accept body. The renamed object is a component of the + -- parameter block that is a parameter in the entry call. + -- + -- In Ada 2012, if the formal is an incomplete tagged type, the renaming + -- does not dereference the corresponding component to prevent an illegal + -- use of the incomplete type (AI05-0151). + function Build_Selected_Name (Prefix : Entity_Id; Selector : Entity_Id; @@ -291,6 +321,26 @@ package body Exp_Ch9 is -- subprogram that is called from all protected operations on the same -- object, including the protected version of the same subprogram. + procedure Build_Wrapper_Bodies + (Loc : Source_Ptr; + Typ : Entity_Id; + N : Node_Id); + -- Ada 2005 (AI-345): Typ is either a concurrent type or the corresponding + -- record of a concurrent type. N is the insertion node where all bodies + -- will be placed. This routine builds the bodies of the subprograms which + -- serve as an indirection mechanism to overriding primitives of concurrent + -- types, entries and protected procedures. Any new body is analyzed. + + procedure Build_Wrapper_Specs + (Loc : Source_Ptr; + Typ : Entity_Id; + N : in out Node_Id); + -- Ada 2005 (AI-345): Typ is either a concurrent type or the corresponding + -- record of a concurrent type. N is the insertion node where all specs + -- will be placed. This routine builds the specs of the subprograms which + -- serve as an indirection mechanism to overriding primitives of concurrent + -- types, entries and protected procedures. Any new spec is analyzed. + procedure Collect_Entry_Families (Loc : Source_Ptr; Cdecls : List_Id; @@ -299,6 +349,10 @@ package body Exp_Ch9 is -- For each entry family in a concurrent type, create an anonymous array -- type of the right size, and add a component to the corresponding_record. + function Comp_Of (Sub_Body : Node_Id) return Entity_Id; + -- For the lock free implementation, return the protected component entity + -- referenced in Sub_Body using LF_Sub_Table. + function Concurrent_Object (Spec_Id : Entity_Id; Conc_Typ : Entity_Id) return Entity_Id; @@ -322,6 +376,26 @@ package body Exp_Ch9 is -- step of the expansion must to be done after private data has been moved -- to its final resting scope to ensure proper visibility of debug objects. + procedure Extract_Dispatching_Call + (N : Node_Id; + Call_Ent : out Entity_Id; + Object : out Entity_Id; + Actuals : out List_Id; + Formals : out List_Id); + -- Given a dispatching call, extract the entity of the name of the call, + -- its actual dispatching object, its actual parameters and the formal + -- parameters of the overridden interface-level version. If the type of + -- the dispatching object is an access type then an explicit dereference + -- is returned in Object. + + procedure Extract_Entry + (N : Node_Id; + Concval : out Node_Id; + Ename : out Node_Id; + Index : out Node_Id); + -- Given an entry call, returns the associated concurrent object, + -- the entry name, and the entry family index. + function Family_Offset (Loc : Source_Ptr; Hi : Node_Id; @@ -358,26 +432,6 @@ package body Exp_Ch9 is -- the scope of Context_Id and Context_Decls is the declarative list of -- Context. - procedure Extract_Dispatching_Call - (N : Node_Id; - Call_Ent : out Entity_Id; - Object : out Entity_Id; - Actuals : out List_Id; - Formals : out List_Id); - -- Given a dispatching call, extract the entity of the name of the call, - -- its actual dispatching object, its actual parameters and the formal - -- parameters of the overridden interface-level version. If the type of - -- the dispatching object is an access type then an explicit dereference - -- is returned in Object. - - procedure Extract_Entry - (N : Node_Id; - Concval : out Node_Id; - Ename : out Node_Id; - Index : out Node_Id); - -- Given an entry call, returns the associated concurrent object, - -- the entry name, and the entry family index. - function Find_Task_Or_Protected_Pragma (T : Node_Id; P : Name_Id) return Node_Id; @@ -393,6 +447,9 @@ package body Exp_Ch9 is -- Task_Body_Procedure of Spec_Id. The returned entity denotes formal -- parameter _E. + function Is_Exception_Safe (Subprogram : Node_Id) return Boolean; + -- Tell whether a given subprogram cannot raise an exception + function Is_Potentially_Large_Family (Base_Index : Entity_Id; Conctyp : Entity_Id; @@ -762,6 +819,263 @@ package body Exp_Ch9 is Prepend_To (Decls, Decl); end Add_Object_Pointer; + ------------------------------------ + -- Allow_Lock_Free_Implementation -- + ------------------------------------ + + -- Here are the restrictions for the Lock Free implementation + + -- Implementation Restrictions on protected declaration + + -- There must be only protected scalar components (at least one) + + -- Component types must support an atomic compare_exchange primitive + -- (size equals to 1, 2, 4 or 8 bytes). + + -- No entries + + -- Implementation Restrictions on protected operations + + -- Cannot refer to non-constant outside of the scope of the protected + -- operation. + + -- Can only access a single protected component: all protected + -- component names appearing in a scope (including nested scopes) + -- must statically denote the same protected component. + + -- Fundamental Restrictions on protected operations + + -- No loop and procedure call statements + + -- Any function call and attribute reference must be static + + function Allow_Lock_Free_Implementation (N : Node_Id) return Boolean is + Decls : constant List_Id := Declarations (N); + Spec : constant Entity_Id := Corresponding_Spec (N); + Pro_Def : constant Node_Id := Protected_Definition (Parent (Spec)); + Pri_Decls : constant List_Id := Private_Declarations (Pro_Def); + Vis_Decls : constant List_Id := Visible_Declarations (Pro_Def); + + Comp_Id : Entity_Id; + Comp_Size : Int; + Comp_Type : Entity_Id; + No_Component : Boolean := True; + N_Decl : Node_Id; + + function Permit_Lock_Free (Sub_Body : Node_Id) return Boolean; + -- Return True if the protected subprogram body Sub_Body doesn't + -- prevent the lock free code expansion, i.e. Sub_Body meets all the + -- restrictions listed below that allow the lock free implementation. + -- + -- Can only access a single protected component + -- + -- No loop and procedure call statements + + -- Any function call and attribute reference must be static + + -- Cannot refer to non-constant outside of the scope of the protected + -- subprogram. + + ---------------------- + -- Permit_Lock_Free -- + ---------------------- + + function Permit_Lock_Free (Sub_Body : Node_Id) return Boolean is + Sub_Id : constant Entity_Id := Corresponding_Spec (Sub_Body); + Comp_Id : Entity_Id := Empty; + LF_Sub : Lock_Free_Sub_Type; + + function Check_Node (N : Node_Id) return Traverse_Result; + -- Check the node N meet the lock free restrictions + + function Check_All_Nodes is new Traverse_Func (Check_Node); + + ---------------- + -- Check_Node -- + ---------------- + + function Check_Node (N : Node_Id) return Traverse_Result is + Comp_Decl : Node_Id; + Id : Entity_Id; + + begin + case Nkind (N) is + + -- Function call or attribute reference case + + when N_Function_Call | N_Attribute_Reference => + + -- Any function call and attribute reference must be static + + if not Is_Static_Expression (N) then + return Abandon; + end if; + + -- Loop and procedure call statement case + + when N_Procedure_Call_Statement | N_Loop_Statement => + -- No loop and procedure call statements + return Abandon; + + -- Identifier case + + when N_Identifier => + if Present (Entity (N)) then + Id := Entity (N); + + -- Cannot refer to non-constant entities outside of the + -- scope of the protected subprogram. + + if Ekind (Id) in Assignable_Kind + and then Sloc (Scope (Id)) > No_Location + and then not Scope_Within_Or_Same (Scope (Id), Sub_Id) + and then not Scope_Within_Or_Same (Scope (Id), + Protected_Body_Subprogram (Sub_Id)) + then + return Abandon; + end if; + + -- Can only access a single protected component + + if Ekind_In (Id, E_Constant, E_Variable) + and then Present (Prival_Link (Id)) + then + Comp_Decl := Parent (Prival_Link (Id)); + + if Nkind (Comp_Decl) = N_Component_Declaration + and then Is_List_Member (Comp_Decl) + and then List_Containing (Comp_Decl) = Pri_Decls + then + -- Check if another protected component has already + -- been accessed by the subprogram body. + + if Present (Comp_Id) + and then Comp_Id /= Prival_Link (Id) + then + return Abandon; + + elsif not Present (Comp_Id) then + Comp_Id := Prival_Link (Id); + end if; + end if; + end if; + end if; + + -- Ok for all other nodes + + when others => return OK; + end case; + + return OK; + end Check_Node; + + -- Start of processing for Permit_Lock_Free + + begin + if Check_All_Nodes (Sub_Body) = OK then + + -- Fill LF_Sub with Sub_Body and its corresponding protected + -- component entity and then store LF_Sub in the lock free + -- subprogram table LF_Sub_Table. + + LF_Sub.Sub_Body := Sub_Body; + LF_Sub.Comp_Id := Comp_Id; + LF_Sub_Table.Append (LF_Sub); + return True; + + else + return False; + end if; + end Permit_Lock_Free; + + -- Start of processing for Allow_Lock_Free_Implementation + + begin + -- Debug switch -gnatd9 enables Lock Free implementation + + if not Debug_Flag_9 then + return False; + end if; + + -- Look for any entries declared in the visible part of the protected + -- declaration. + + N_Decl := First (Vis_Decls); + while Present (N_Decl) loop + if Nkind (N_Decl) = N_Entry_Declaration then + return False; + end if; + + N_Decl := Next (N_Decl); + end loop; + + -- Look for any entry, plus look for any scalar component declared in + -- the private part of the protected declaration. + + N_Decl := First (Pri_Decls); + while Present (N_Decl) loop + + -- Check at least one scalar component is declared + + if Nkind (N_Decl) = N_Component_Declaration then + if No_Component then + No_Component := False; + end if; + + Comp_Id := Defining_Identifier (N_Decl); + Comp_Type := Etype (Comp_Id); + + -- Verify the component is a scalar + + if not Is_Scalar_Type (Comp_Type) then + return False; + end if; + + Comp_Size := UI_To_Int (Esize (Base_Type (Comp_Type))); + + -- Check the size of the component is 8, 16, 32 or 64 bits + + case Comp_Size is + when 8 | 16 | 32 | 64 => + null; + when others => + return False; + end case; + + -- Check there is no entry declared in the private part. + + else + if Nkind (N_Decl) = N_Entry_Declaration then + return False; + end if; + end if; + + N_Decl := Next (N_Decl); + end loop; + + -- One scalar component must be present + + if No_Component then + return False; + end if; + + -- Ensure all protected subprograms meet the restrictions that allow the + -- lock free implementation. + + N_Decl := First (Decls); + while Present (N_Decl) loop + if Nkind (N_Decl) = N_Subprogram_Body + and then not Permit_Lock_Free (N_Decl) + then + return False; + end if; + + Next (N_Decl); + end loop; + + return True; + end Allow_Lock_Free_Implementation; + ----------------------- -- Build_Accept_Body -- ----------------------- @@ -2720,18 +3034,16 @@ package body Exp_Ch9 is if No (If_St) then If_St := Make_Implicit_If_Statement (Typ, - Condition => Cond, + Condition => Cond, Then_Statements => Stats, - Elsif_Parts => New_List); - + Elsif_Parts => New_List); Ret := If_St; else - Append ( + Append_To (Elsif_Parts (If_St), Make_Elsif_Part (Loc, Condition => Cond, - Then_Statements => Stats), - Elsif_Parts (If_St)); + Then_Statements => Stats)); end if; end Add_If_Clause; @@ -2788,7 +3100,7 @@ package body Exp_Ch9 is else -- Suppose entries e1, e2, ... have size l1, l2, ... we generate -- the following: - -- + -- if E <= l1 then return 1; -- elsif E <= l1 + l2 then return 2; -- ... @@ -2834,8 +3146,8 @@ package body Exp_Ch9 is return Make_Subprogram_Body (Loc, - Specification => Spec, - Declarations => Decls, + Specification => Spec, + Declarations => Decls, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, Statements => New_List (Ret))); @@ -2856,21 +3168,543 @@ package body Exp_Ch9 is begin return Make_Function_Specification (Loc, - Defining_Unit_Name => Id, + Defining_Unit_Name => Id, Parameter_Specifications => New_List ( Make_Parameter_Specification (Loc, Defining_Identifier => Parm1, - Parameter_Type => + Parameter_Type => New_Reference_To (RTE (RE_Address), Loc)), Make_Parameter_Specification (Loc, Defining_Identifier => Parm2, - Parameter_Type => + Parameter_Type => New_Reference_To (RTE (RE_Protected_Entry_Index), Loc))), - Result_Definition => New_Occurrence_Of ( + + Result_Definition => New_Occurrence_Of ( RTE (RE_Protected_Entry_Index), Loc)); end Build_Find_Body_Index_Spec; + ----------------------------------------------- + -- Build_Lock_Free_Protected_Subprogram_Body -- + ----------------------------------------------- + + function Build_Lock_Free_Protected_Subprogram_Body + (N : Node_Id; + Pid : Node_Id; + N_Op_Spec : Node_Id) return Node_Id + is + Loc : constant Source_Ptr := Sloc (N); + Op_Spec : Node_Id; + P_Op_Spec : Node_Id; + Uactuals : List_Id; + Pformal : Node_Id; + Unprot_Call : Node_Id; + R : Node_Id; + Return_Stmt : Node_Id := Empty; -- init to avoid gcc 3 warning + Exc_Safe : Boolean; + + begin + Op_Spec := Specification (N); + Exc_Safe := Is_Exception_Safe (N); + + P_Op_Spec := + Build_Protected_Sub_Specification (N, Pid, Protected_Mode); + + -- Build a list of the formal parameters of the protected version of + -- the subprogram to use as the actual parameters of the unprotected + -- version. + + Uactuals := New_List; + Pformal := First (Parameter_Specifications (P_Op_Spec)); + while Present (Pformal) loop + Append_To (Uactuals, + Make_Identifier (Loc, Chars (Defining_Identifier (Pformal)))); + Next (Pformal); + end loop; + + -- Make a call to the unprotected version of the subprogram built above + -- for use by the protected version built below. + + if Nkind (Op_Spec) = N_Function_Specification then + if Exc_Safe then + R := Make_Temporary (Loc, 'R'); + Unprot_Call := + Make_Object_Declaration (Loc, + Defining_Identifier => R, + Constant_Present => True, + Object_Definition => New_Copy (Result_Definition (N_Op_Spec)), + Expression => + Make_Function_Call (Loc, + Name => Make_Identifier (Loc, + Chars => Chars (Defining_Unit_Name (N_Op_Spec))), + Parameter_Associations => Uactuals)); + + Return_Stmt := + Make_Simple_Return_Statement (Loc, + Expression => New_Reference_To (R, Loc)); + + else + Unprot_Call := Make_Simple_Return_Statement (Loc, + Expression => Make_Function_Call (Loc, + Name => + Make_Identifier (Loc, + Chars => Chars (Defining_Unit_Name (N_Op_Spec))), + Parameter_Associations => Uactuals)); + end if; + + else + Unprot_Call := + Make_Procedure_Call_Statement (Loc, + Name => + Make_Identifier (Loc, Chars (Defining_Unit_Name (N_Op_Spec))), + Parameter_Associations => Uactuals); + end if; + + if Nkind (Op_Spec) = N_Function_Specification + and then Exc_Safe + then + Unprot_Call := + Make_Block_Statement (Loc, + Declarations => New_List (Unprot_Call), + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List (Return_Stmt))); + end if; + + return + Make_Subprogram_Body (Loc, + Declarations => Empty_List, + Specification => P_Op_Spec, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List (Unprot_Call))); + end Build_Lock_Free_Protected_Subprogram_Body; + + ------------------------------------------------- + -- Build_Lock_Free_Unprotected_Subprogram_Body -- + ------------------------------------------------- + + function Build_Lock_Free_Unprotected_Subprogram_Body + (N : Node_Id; + Pid : Node_Id) return Node_Id + is + Decls : constant List_Id := Declarations (N); + Is_Procedure : constant Boolean := + Ekind (Corresponding_Spec (N)) = E_Procedure; + Loc : constant Source_Ptr := Sloc (N); + + function Ren_Comp_Id (Decls : List_Id) return Entity_Id; + -- Given the list of delaration Decls, return the renamed entity + -- of the protected component accessed by the subprogram body. + + ----------------- + -- Ren_Comp_Id -- + ----------------- + + function Ren_Comp_Id (Decls : List_Id) return Entity_Id is + N_Decl : Node_Id; + Pri_Link : Node_Id; + + begin + N_Decl := First (Decls); + while Present (N_Decl) loop + + -- Look for a renaming declaration + + if Nkind (N_Decl) = N_Object_Renaming_Declaration then + Pri_Link := Prival_Link (Defining_Identifier (N_Decl)); + + -- Compare the renamed entity and the accessed component entity + -- in the LF_Sub_Table. + + if Present (Pri_Link) and then Pri_Link = Comp_Of (N) then + return Defining_Identifier (N_Decl); + end if; + end if; + + Next (N_Decl); + end loop; + + return Empty; + end Ren_Comp_Id; + + Obj_Id : constant Entity_Id := Ren_Comp_Id (Decls); + At_Comp_Id : Entity_Id; + At_Load_Id : Entity_Id; + Copy_Id : Entity_Id; + Exit_Stmt : Node_Id; + Label : Node_Id := Empty; + Label_Id : Entity_Id; + New_Body : Node_Id; + New_Decls : List_Id; + New_Stmts : List_Id; + Obj_Typ : Entity_Id; + Old_Id : Entity_Id; + Typ_Size : Int; + Unsigned_Id : Entity_Id; + + function Make_If (Stmt : Node_Id) return Node_Id; + -- Given the statement Stmt, return an if statement with Stmt at the end + -- of the list of statements. + + procedure Process_Stmts (Stmts : List_Id); + -- Wrap each return and raise statements in Stmts into an if statement + -- generated by Make_If. Replace all references to the protected object + -- Obj by a reference to its copy Obj_Copy. + + ------------- + -- Make_If -- + ------------- + + function Make_If (Stmt : Node_Id) return Node_Id is + begin + -- Generate (for Typ_Size = 32): + + -- if System.Atomic_Primitives.Atomic_Compare_Exchange_32 + -- (Obj'Address, + -- Interfaces.Unsigned_32! (Obj_Old), + -- Interfaces.Unsigned_32! (Obj_Copy)); + -- then + -- < Stmt > + -- else + -- goto L0; + -- end if; + + -- Check whether a label has already been created + + if not Present (Label) then + + -- Create a label which will point just after the last + -- statement of the loop statement generated in step 3. + + -- Generate: + + -- L0 : Label; + + Label_Id := + Make_Identifier (Loc, New_External_Name ('L', 0)); + + Set_Entity (Label_Id, + Make_Defining_Identifier (Loc, Chars (Label_Id))); + Label := Make_Label (Loc, Label_Id); + + Append_To (Decls, + Make_Implicit_Label_Declaration (Loc, + Defining_Identifier => Entity (Label_Id), + Label_Construct => Label)); + end if; + + return + Make_If_Statement (Loc, + Condition => + Make_Function_Call (Loc, + Name => New_Reference_To (At_Comp_Id, Loc), + Parameter_Associations => New_List ( + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Obj_Id, Loc), + Attribute_Name => Name_Address), + Unchecked_Convert_To (Unsigned_Id, + New_Reference_To (Old_Id, Loc)), + Unchecked_Convert_To (Unsigned_Id, + New_Reference_To (Copy_Id, Loc)))), + + Then_Statements => New_List ( + Relocate_Node (Stmt)), + + Else_Statements => New_List ( + Make_Goto_Statement (Loc, + Name => New_Reference_To (Entity (Label_Id), Loc)))); + end Make_If; + + ------------------- + -- Process_Stmts -- + ------------------- + + procedure Process_Stmts (Stmts : List_Id) is + Stmt : Node_Id; + + function Check_Node (N : Node_Id) return Traverse_Result; + -- Recognize a return and raise statement and wrap it into an if + -- statement. Replace all references to the protected object by + -- a reference to its copy. Reset all Analyzed flags in order to + -- reanalyze statments inside the new unprotected subprogram body. + + procedure Process_Nodes is + new Traverse_Proc (Check_Node); + + ---------------- + -- Check_Node -- + ---------------- + + function Check_Node (N : Node_Id) return Traverse_Result is + begin + -- In case of a procedure, wrap each return and raise statements + -- inside an if statement created by Make_If. + + if Is_Procedure + and then Nkind_In (N, N_Simple_Return_Statement, + N_Extended_Return_Statement, + N_Raise_Statement) + and then + (Nkind (N) /= N_Simple_Return_Statement + or else N /= Last (Stmts)) + then + Rewrite (N, Make_If (N)); + return Skip; + + -- Replace all references to the protected object by a reference + -- to the new copy. + + elsif Nkind (N) = N_Identifier + and then Present (Entity (N)) + and then Entity (N) = Obj_Id + then + Rewrite (N, Make_Identifier (Loc, Chars (Copy_Id))); + return Skip; + end if; + + -- We mark the node as unanalyzed in order to reanalyze it inside + -- the unprotected subprogram body. + + Set_Analyzed (N, False); + + return OK; + end Check_Node; + + -- Start of processing for Process_Stmts + + begin + -- Process_Nodes for each statement in Stmts + + Stmt := First (Stmts); + while Present (Stmt) loop + Process_Nodes (Stmt); + Next (Stmt); + end loop; + end Process_Stmts; + + -- Start of processing for Build_Lock_Free_Unprotected_Subprogram_Body + + begin + New_Stmts := New_Copy_List (Statements (Handled_Statement_Sequence (N))); + + -- Do the transformation only if the subprogram accesses a protected + -- component. + + if not Present (Obj_Id) then + goto Continue; + end if; + + Copy_Id := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Chars (Obj_Id), Suffix => "_copy")); + + Obj_Typ := Etype (Obj_Id); + Typ_Size := UI_To_Int (Esize (Base_Type (Obj_Typ))); + + Process_Stmts (New_Stmts); + + -- Procedure case + + if Is_Procedure then + case Typ_Size is + when 8 => + At_Comp_Id := RTE (RE_Atomic_Compare_Exchange_8); + At_Load_Id := RTE (RE_Atomic_Load_8); + Unsigned_Id := RTE (RE_Uint8); + + when 16 => + At_Comp_Id := RTE (RE_Atomic_Compare_Exchange_16); + At_Load_Id := RTE (RE_Atomic_Load_16); + Unsigned_Id := RTE (RE_Uint16); + + when 32 => + At_Comp_Id := RTE (RE_Atomic_Compare_Exchange_32); + At_Load_Id := RTE (RE_Atomic_Load_32); + Unsigned_Id := RTE (RE_Uint32); + + when 64 => + At_Comp_Id := RTE (RE_Atomic_Compare_Exchange_64); + At_Load_Id := RTE (RE_Atomic_Load_64); + Unsigned_Id := RTE (RE_Uint64); + when others => null; + end case; + + -- Generate (e.g. for Typ_Size = 32): + + -- begin + -- loop + -- declare + -- Obj_Old : constant Obj_Typ := + -- Obj_Typ! + -- (System.Atomic_Primitives.Atomic_Load_32 + -- (Obj'Address)); + -- Obj_Copy : Obj_Typ := Obj_Old; + -- begin + -- < New_Stmts > + -- exit when + -- System.Atomic_Primitives.Atomic_Compare_Exchange_32 + -- (Obj'Address, + -- Interfaces.Unsigned_32! (Obj_Old), + -- Interfaces.Unsigned_32! (Obj_Copy)); + -- end; + -- end loop; + -- end; + + -- Step 1: Define a copy and save the old value of the protected + -- object. The copy replaces all the references to the object present + -- in the body of the procedure. + + -- Generate: + + -- Obj_Old : constant Obj_Typ := + -- Obj_Typ! + -- (System.Atomic_Primitives.Atomic_Load_32 + -- (Obj'Address)); + -- Obj_Copy : Obj_Typ := Obj_Old; + + Old_Id := Make_Defining_Identifier (Loc, + New_External_Name (Chars (Obj_Id), Suffix => "_old")); + + New_Decls := New_List ( + Make_Object_Declaration (Loc, + Defining_Identifier => Old_Id, + Constant_Present => True, + Object_Definition => New_Reference_To (Obj_Typ, Loc), + Expression => Unchecked_Convert_To (Obj_Typ, + Make_Function_Call (Loc, + Name => New_Reference_To (At_Load_Id, Loc), + Parameter_Associations => New_List ( + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Obj_Id, Loc), + Attribute_Name => Name_Address))))), + Make_Object_Declaration (Loc, + Defining_Identifier => Copy_Id, + Object_Definition => New_Reference_To (Obj_Typ, Loc), + Expression => New_Reference_To (Old_Id, Loc))); + + -- Step 2: Create an exit statement of the loop statement generated + -- in step 3. + + -- Generate (for Typ_Size = 32): + + -- exit when System.Atomic_Primitives.Atomic_Compare_Exchange_32 + -- (Obj'Address, + -- Interfaces.Unsigned_32! (Obj_Old), + -- Interfaces.Unsigned_32! (Obj_Copy)); + + Exit_Stmt := + Make_Exit_Statement (Loc, + Condition => + Make_Function_Call (Loc, + Name => New_Reference_To (At_Comp_Id, Loc), + Parameter_Associations => New_List ( + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Obj_Id, Loc), + Attribute_Name => Name_Address), + Unchecked_Convert_To (Unsigned_Id, + New_Reference_To (Old_Id, Loc)), + Unchecked_Convert_To (Unsigned_Id, + New_Reference_To (Copy_Id, Loc))))); + + -- Check the last statement is a return statement + + if Nkind (Last (New_Stmts)) = N_Simple_Return_Statement then + Rewrite (Last (New_Stmts), Exit_Stmt); + else + Append_To (New_Stmts, Exit_Stmt); + end if; + + -- Step 3: Create the loop statement which encloses a block + -- declaration that contains all the statements of the original + -- procedure body. + + -- Generate: + + -- loop + -- declare + -- < New_Decls > + -- begin + -- < New_Stmts > + -- end; + -- end loop; + + New_Stmts := New_List ( + Make_Loop_Statement (Loc, + Statements => New_List ( + Make_Block_Statement (Loc, + Declarations => New_Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_Stmts))), + End_Label => Empty)); + + -- Append the label to the statements of the loop when needed + + if Present (Label) then + Append_To (Statements (First (New_Stmts)), Label); + end if; + + -- Function case + + else + case Typ_Size is + when 8 => + At_Load_Id := RTE (RE_Atomic_Load_8); + when 16 => + At_Load_Id := RTE (RE_Atomic_Load_16); + when 32 => + At_Load_Id := RTE (RE_Atomic_Load_32); + when 64 => + At_Load_Id := RTE (RE_Atomic_Load_64); + when others => null; + end case; + + -- Define a copy of the protected object which replaces all the + -- references to the object present in the body of the function. + + -- Generate: + + -- Obj_Copy : constant Obj_Typ := + -- Obj_Typ! + -- (System.Atomic_Primitives.Atomic_Load_32 + -- (Obj'Address)); + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Copy_Id, + Constant_Present => True, + Object_Definition => New_Reference_To (Obj_Typ, Loc), + Expression => Unchecked_Convert_To (Obj_Typ, + Make_Function_Call (Loc, + Name => New_Reference_To (At_Load_Id, Loc), + Parameter_Associations => New_List ( + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Obj_Id, Loc), + Attribute_Name => Name_Address)))))); + end if; + + << Continue >> + + -- Add renamings for the Protection object, discriminals, privals and + -- the entry index constant for use by debugger. + + Debug_Private_Data_Declarations (Decls); + + -- Make an unprotected version of the subprogram for use within the same + -- object, with new name and extra parameter representing the object. + + New_Body := + Make_Subprogram_Body (Loc, + Specification => + Build_Protected_Sub_Specification (N, Pid, Unprotected_Mode), + Declarations => Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_Stmts)); + return New_Body; + end Build_Lock_Free_Unprotected_Subprogram_Body; + ------------------------- -- Build_Master_Entity -- ------------------------- @@ -3442,102 +4276,6 @@ package body Exp_Ch9 is Exc_Safe : Boolean; Lock_Kind : RE_Id; - function Is_Exception_Safe (Subprogram : Node_Id) return Boolean; - -- Tell whether a given subprogram cannot raise an exception - - ----------------------- - -- Is_Exception_Safe -- - ----------------------- - - function Is_Exception_Safe (Subprogram : Node_Id) return Boolean is - - function Has_Side_Effect (N : Node_Id) return Boolean; - -- Return True whenever encountering a subprogram call or raise - -- statement of any kind in the sequence of statements - - --------------------- - -- Has_Side_Effect -- - --------------------- - - -- What is this doing buried two levels down in exp_ch9. It seems - -- like a generally useful function, and indeed there may be code - -- duplication going on here ??? - - function Has_Side_Effect (N : Node_Id) return Boolean is - Stmt : Node_Id; - Expr : Node_Id; - - function Is_Call_Or_Raise (N : Node_Id) return Boolean; - -- Indicate whether N is a subprogram call or a raise statement - - ---------------------- - -- Is_Call_Or_Raise -- - ---------------------- - - function Is_Call_Or_Raise (N : Node_Id) return Boolean is - begin - return Nkind_In (N, N_Procedure_Call_Statement, - N_Function_Call, - N_Raise_Statement, - N_Raise_Constraint_Error, - N_Raise_Program_Error, - N_Raise_Storage_Error); - end Is_Call_Or_Raise; - - -- Start of processing for Has_Side_Effect - - begin - Stmt := N; - while Present (Stmt) loop - if Is_Call_Or_Raise (Stmt) then - return True; - end if; - - -- An object declaration can also contain a function call - -- or a raise statement - - if Nkind (Stmt) = N_Object_Declaration then - Expr := Expression (Stmt); - - if Present (Expr) and then Is_Call_Or_Raise (Expr) then - return True; - end if; - end if; - - Next (Stmt); - end loop; - - return False; - end Has_Side_Effect; - - -- Start of processing for Is_Exception_Safe - - begin - -- If the checks handled by the back end are not disabled, we cannot - -- ensure that no exception will be raised. - - if not Access_Checks_Suppressed (Empty) - or else not Discriminant_Checks_Suppressed (Empty) - or else not Range_Checks_Suppressed (Empty) - or else not Index_Checks_Suppressed (Empty) - or else Opt.Stack_Checking_Enabled - then - return False; - end if; - - if Has_Side_Effect (First (Declarations (Subprogram))) - or else - Has_Side_Effect ( - First (Statements (Handled_Statement_Sequence (Subprogram)))) - then - return False; - else - return True; - end if; - end Is_Exception_Safe; - - -- Start of processing for Build_Protected_Subprogram_Body - begin Op_Spec := Specification (N); Exc_Safe := Is_Exception_Safe (N); @@ -4698,6 +5436,21 @@ package body Exp_Ch9 is end loop; end Collect_Entry_Families; + ------------- + -- Comp_Of -- + ------------- + + function Comp_Of (Sub_Body : Node_Id) return Entity_Id is + begin + for Sub_Id in 1 .. LF_Sub_Table.Last loop + if Sub_Body = LF_Sub_Table.Table (Sub_Id).Sub_Body then + return LF_Sub_Table.Table (Sub_Id).Comp_Id; + end if; + end loop; + + return Empty; + end Comp_Of; + ----------------------- -- Concurrent_Object -- ----------------------- @@ -7715,6 +8468,9 @@ package body Exp_Ch9 is Loc : constant Source_Ptr := Sloc (N); Pid : constant Entity_Id := Corresponding_Spec (N); + Lock_Free_On : constant Boolean := Allow_Lock_Free_Implementation (N); + -- This flag indicates whether the lock free implementation is active + Current_Node : Node_Id; Disp_Op_Body : Node_Id; New_Op_Body : Node_Id; @@ -7843,8 +8599,14 @@ package body Exp_Ch9 is if not Is_Eliminated (Defining_Entity (Op_Body)) and then not Is_Eliminated (Corresponding_Spec (Op_Body)) then - New_Op_Body := - Build_Unprotected_Subprogram_Body (Op_Body, Pid); + if Lock_Free_On then + New_Op_Body := + Build_Lock_Free_Unprotected_Subprogram_Body + (Op_Body, Pid); + else + New_Op_Body := + Build_Unprotected_Subprogram_Body (Op_Body, Pid); + end if; Insert_After (Current_Node, New_Op_Body); Current_Node := New_Op_Body; @@ -7854,6 +8616,7 @@ package body Exp_Ch9 is -- appear that this is needed only if this is a visible -- operation of the type, or if it is an interrupt handler, -- and this was the strategy used previously in GNAT. + -- However, the operation may be exported through a 'Access -- to an external caller. This is the common idiom in code -- that uses the Ada 2005 Timing_Events package. As a result @@ -7863,9 +8626,15 @@ package body Exp_Ch9 is -- declaration in the protected body itself. if Present (Corresponding_Spec (Op_Body)) then - New_Op_Body := - Build_Protected_Subprogram_Body ( - Op_Body, Pid, Specification (New_Op_Body)); + if Lock_Free_On then + New_Op_Body := + Build_Lock_Free_Protected_Subprogram_Body + (Op_Body, Pid, Specification (New_Op_Body)); + else + New_Op_Body := + Build_Protected_Subprogram_Body + (Op_Body, Pid, Specification (New_Op_Body)); + end if; Insert_After (Current_Node, New_Op_Body); Analyze (New_Op_Body); @@ -12688,6 +13457,97 @@ package body Exp_Ch9 is end if; end Install_Private_Data_Declarations; + ----------------------- + -- Is_Exception_Safe -- + ----------------------- + + function Is_Exception_Safe (Subprogram : Node_Id) return Boolean is + + function Has_Side_Effect (N : Node_Id) return Boolean; + -- Return True whenever encountering a subprogram call or raise + -- statement of any kind in the sequence of statements + + --------------------- + -- Has_Side_Effect -- + --------------------- + + -- What is this doing buried two levels down in exp_ch9. It seems like a + -- generally useful function, and indeed there may be code duplication + -- going on here ??? + + function Has_Side_Effect (N : Node_Id) return Boolean is + Stmt : Node_Id; + Expr : Node_Id; + + function Is_Call_Or_Raise (N : Node_Id) return Boolean; + -- Indicate whether N is a subprogram call or a raise statement + + ---------------------- + -- Is_Call_Or_Raise -- + ---------------------- + + function Is_Call_Or_Raise (N : Node_Id) return Boolean is + begin + return Nkind_In (N, N_Procedure_Call_Statement, + N_Function_Call, + N_Raise_Statement, + N_Raise_Constraint_Error, + N_Raise_Program_Error, + N_Raise_Storage_Error); + end Is_Call_Or_Raise; + + -- Start of processing for Has_Side_Effect + + begin + Stmt := N; + while Present (Stmt) loop + if Is_Call_Or_Raise (Stmt) then + return True; + end if; + + -- An object declaration can also contain a function call or a + -- raise statement. + + if Nkind (Stmt) = N_Object_Declaration then + Expr := Expression (Stmt); + + if Present (Expr) and then Is_Call_Or_Raise (Expr) then + return True; + end if; + end if; + + Next (Stmt); + end loop; + + return False; + end Has_Side_Effect; + + -- Start of processing for Is_Exception_Safe + + begin + -- If the checks handled by the back end are not disabled, we cannot + -- ensure that no exception will be raised. + + if not Access_Checks_Suppressed (Empty) + or else not Discriminant_Checks_Suppressed (Empty) + or else not Range_Checks_Suppressed (Empty) + or else not Index_Checks_Suppressed (Empty) + or else Opt.Stack_Checking_Enabled + then + return False; + end if; + + if Has_Side_Effect (First (Declarations (Subprogram))) + or else + Has_Side_Effect + (First (Statements (Handled_Statement_Sequence (Subprogram)))) + then + return False; + else + return True; + end if; + end Is_Exception_Safe; + --------------------------------- -- Is_Potentially_Large_Family -- --------------------------------- @@ -12702,11 +13562,12 @@ package body Exp_Ch9 is return Scope (Base_Index) = Standard_Standard and then Base_Index = Base_Type (Standard_Integer) and then Has_Discriminants (Conctyp) - and then Present - (Discriminant_Default_Value (First_Discriminant (Conctyp))) + and then + Present (Discriminant_Default_Value (First_Discriminant (Conctyp))) and then (Denotes_Discriminant (Lo, True) - or else Denotes_Discriminant (Hi, True)); + or else + Denotes_Discriminant (Hi, True)); end Is_Potentially_Large_Family; ------------------------------------- diff --git a/gcc/ada/exp_pakd.adb b/gcc/ada/exp_pakd.adb index 8a95ec5c876..756a3d19be3 100644 --- a/gcc/ada/exp_pakd.adb +++ b/gcc/ada/exp_pakd.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -509,7 +509,7 @@ package body Exp_Pakd is Shift : out Node_Id); -- This procedure performs common processing on the N_Indexed_Component -- parameter given as N, whose prefix is a reference to a packed array. - -- This is used for the get and set when the component size is 1,2,4 + -- This is used for the get and set when the component size is 1, 2, 4, -- or for other component sizes when the packed array type is a modular -- type (i.e. the cases that are handled with inline code). -- @@ -1472,10 +1472,10 @@ package body Exp_Pakd is end if; end if; - -- Now create copies removing side effects. Note that in some - -- complex cases, this may cause the fact that we have already - -- set a packed array type on Obj to get lost. So we save the - -- type of Obj, and make sure it is reset properly. + -- Now create copies removing side effects. Note that in some complex + -- cases, this may cause the fact that we have already set a packed + -- array type on Obj to get lost. So we save the type of Obj, and + -- make sure it is reset properly. declare T : constant Entity_Id := Etype (Obj); diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index ae7f2b95467..ae5470f659c 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -3940,27 +3940,29 @@ package body Exp_Util is return True; end Is_All_Null_Statements; - --------------------------------------------- - -- Is_Displacement_Of_Ctrl_Function_Result -- - --------------------------------------------- + -------------------------------------------------- + -- Is_Displacement_Of_Object_Or_Function_Result -- + -------------------------------------------------- - function Is_Displacement_Of_Ctrl_Function_Result + function Is_Displacement_Of_Object_Or_Function_Result (Obj_Id : Entity_Id) return Boolean is - function Initialized_By_Ctrl_Function (N : Node_Id) return Boolean; - -- Determine whether object declaration N is initialized by a controlled - -- function call. + function Is_Controlled_Function_Call (N : Node_Id) return Boolean; + -- Determine if particular node denotes a controlled function call function Is_Displace_Call (N : Node_Id) return Boolean; -- Determine whether a particular node is a call to Ada.Tags.Displace. -- The call might be nested within other actions such as conversions. - ---------------------------------- - -- Initialized_By_Ctrl_Function -- - ---------------------------------- + function Is_Source_Object (N : Node_Id) return Boolean; + -- Determine whether a particular node denotes a source object + + --------------------------------- + -- Is_Controlled_Function_Call -- + --------------------------------- - function Initialized_By_Ctrl_Function (N : Node_Id) return Boolean is - Expr : Node_Id := Original_Node (Expression (N)); + function Is_Controlled_Function_Call (N : Node_Id) return Boolean is + Expr : Node_Id := Original_Node (N); begin if Nkind (Expr) = N_Function_Call then @@ -3977,7 +3979,7 @@ package body Exp_Util is Nkind_In (Expr, N_Expanded_Name, N_Identifier) and then Ekind (Entity (Expr)) = E_Function and then Needs_Finalization (Etype (Entity (Expr))); - end Initialized_By_Ctrl_Function; + end Is_Controlled_Function_Call; ---------------------- -- Is_Displace_Call -- @@ -4004,39 +4006,66 @@ package body Exp_Util is end loop; return - Nkind (Call) = N_Function_Call + Present (Call) + and then Nkind (Call) = N_Function_Call and then Is_RTE (Entity (Name (Call)), RE_Displace); end Is_Displace_Call; + ---------------------- + -- Is_Source_Object -- + ---------------------- + + function Is_Source_Object (N : Node_Id) return Boolean is + begin + return + Present (N) + and then Nkind (N) in N_Has_Entity + and then Is_Object (Entity (N)) + and then Comes_From_Source (N); + end Is_Source_Object; + -- Local variables Decl : constant Node_Id := Parent (Obj_Id); Obj_Typ : constant Entity_Id := Base_Type (Etype (Obj_Id)); Orig_Decl : constant Node_Id := Original_Node (Decl); - -- Start of processing for Is_Displacement_Of_Ctrl_Function_Result + -- Start of processing for Is_Displacement_Of_Object_Or_Function_Result begin - -- Detect the following case: + -- Case 1: + + -- Obj : CW_Type := Function_Call (...); + + -- rewritten into: + + -- Tmp : ... := Function_Call (...)'reference; + -- Obj : CW_Type renames (... Ada.Tags.Displace (Tmp)); + + -- where the return type of the function and the class-wide type require + -- dispatch table pointer displacement. + + -- Case 2: - -- Obj : Class_Wide_Type := Function_Call (...); + -- Obj : CW_Type := Src_Obj; - -- which is rewritten into: + -- rewritten into: - -- Temp : ... := Function_Call (...)'reference; - -- Obj : Class_Wide_Type renames (... Ada.Tags.Displace (Temp)); + -- Obj : CW_Type renames (... Ada.Tags.Displace (Src_Obj)); - -- when the return type of the function and the class-wide type require + -- where the type of the source object and the class-wide type require -- dispatch table pointer displacement. return Nkind (Decl) = N_Object_Renaming_Declaration and then Nkind (Orig_Decl) = N_Object_Declaration and then Comes_From_Source (Orig_Decl) - and then Initialized_By_Ctrl_Function (Orig_Decl) and then Is_Class_Wide_Type (Obj_Typ) - and then Is_Displace_Call (Renamed_Object (Obj_Id)); - end Is_Displacement_Of_Ctrl_Function_Result; + and then Is_Displace_Call (Renamed_Object (Obj_Id)) + and then + (Is_Controlled_Function_Call (Expression (Orig_Decl)) + or else Is_Source_Object (Expression (Orig_Decl))); + end Is_Displacement_Of_Object_Or_Function_Result; ------------------------------ -- Is_Finalizable_Transient -- @@ -4475,74 +4504,6 @@ package body Exp_Util is and then Is_Library_Level_Entity (Typ); end Is_Library_Level_Tagged_Type; - ---------------------------------- - -- Is_Null_Access_BIP_Func_Call -- - ---------------------------------- - - function Is_Null_Access_BIP_Func_Call (Expr : Node_Id) return Boolean is - Call : Node_Id := Expr; - - begin - -- Build-in-place calls usually appear in 'reference format - - if Nkind (Call) = N_Reference then - Call := Prefix (Call); - end if; - - if Nkind_In (Call, N_Qualified_Expression, - N_Unchecked_Type_Conversion) - then - Call := Expression (Call); - end if; - - if Is_Build_In_Place_Function_Call (Call) then - declare - Access_Nam : Name_Id := No_Name; - Actual : Node_Id; - Param : Node_Id; - Formal : Node_Id; - - begin - -- Examine all parameter associations of the function call - - Param := First (Parameter_Associations (Call)); - while Present (Param) loop - if Nkind (Param) = N_Parameter_Association - and then Nkind (Selector_Name (Param)) = N_Identifier - then - Formal := Selector_Name (Param); - Actual := Explicit_Actual_Parameter (Param); - - -- Construct the name of formal BIPaccess. It is much easier - -- to extract the name of the function using an arbitrary - -- formal's scope rather than the Name field of Call. - - if Access_Nam = No_Name - and then Present (Entity (Formal)) - then - Access_Nam := - New_External_Name - (Chars (Scope (Entity (Formal))), - BIP_Formal_Suffix (BIP_Object_Access)); - end if; - - -- A match for BIPaccess => null has been found - - if Chars (Formal) = Access_Nam - and then Nkind (Actual) = N_Null - then - return True; - end if; - end if; - - Next (Param); - end loop; - end; - end if; - - return False; - end Is_Null_Access_BIP_Func_Call; - -------------------------- -- Is_Non_BIP_Func_Call -- -------------------------- @@ -4949,6 +4910,77 @@ package body Exp_Util is end if; end Is_Renamed_Object; + -------------------------------------- + -- Is_Secondary_Stack_BIP_Func_Call -- + -------------------------------------- + + function Is_Secondary_Stack_BIP_Func_Call (Expr : Node_Id) return Boolean is + Call : Node_Id := Expr; + + begin + -- Build-in-place calls usually appear in 'reference format. Note that + -- the accessibility check machinery may add an extra 'reference due to + -- side effect removal. + + while Nkind (Call) = N_Reference loop + Call := Prefix (Call); + end loop; + + if Nkind_In (Call, N_Qualified_Expression, + N_Unchecked_Type_Conversion) + then + Call := Expression (Call); + end if; + + if Is_Build_In_Place_Function_Call (Call) then + declare + Access_Nam : Name_Id := No_Name; + Actual : Node_Id; + Param : Node_Id; + Formal : Node_Id; + + begin + -- Examine all parameter associations of the function call + + Param := First (Parameter_Associations (Call)); + while Present (Param) loop + if Nkind (Param) = N_Parameter_Association + and then Nkind (Selector_Name (Param)) = N_Identifier + then + Formal := Selector_Name (Param); + Actual := Explicit_Actual_Parameter (Param); + + -- Construct the name of formal BIPalloc. It is much easier + -- to extract the name of the function using an arbitrary + -- formal's scope rather than the Name field of Call. + + if Access_Nam = No_Name + and then Present (Entity (Formal)) + then + Access_Nam := + New_External_Name + (Chars (Scope (Entity (Formal))), + BIP_Formal_Suffix (BIP_Alloc_Form)); + end if; + + -- A match for BIPalloc => 2 has been found + + if Chars (Formal) = Access_Nam + and then Nkind (Actual) = N_Integer_Literal + and then Intval (Actual) = Uint_2 + then + return True; + end if; + end if; + + Next (Param); + end loop; + end; + end if; + + return False; + end Is_Secondary_Stack_BIP_Func_Call; + ------------------------------------- -- Is_Tag_To_Class_Wide_Conversion -- ------------------------------------- @@ -7123,18 +7155,17 @@ package body Exp_Util is -- Obj : Access_Typ := Non_BIP_Function_Call'reference; -- -- Obj : Access_Typ := - -- BIP_Function_Call - -- (..., BIPaccess => null, ...)'reference; + -- BIP_Function_Call (BIPalloc => 2, ...)'reference; elsif Is_Access_Type (Obj_Typ) and then Needs_Finalization (Available_View (Designated_Type (Obj_Typ))) and then Present (Expr) and then - (Is_Null_Access_BIP_Func_Call (Expr) - or else - (Is_Non_BIP_Func_Call (Expr) - and then not Is_Related_To_Func_Return (Obj_Id))) + (Is_Secondary_Stack_BIP_Func_Call (Expr) + or else + (Is_Non_BIP_Func_Call (Expr) + and then not Is_Related_To_Func_Return (Obj_Id))) then return True; @@ -7187,17 +7218,18 @@ package body Exp_Util is then return True; - -- Detect a case where a source object has been initialized by a - -- controlled function call which was later rewritten as a class- - -- wide conversion of Ada.Tags.Displace. + -- Detect a case where a source object has been initialized by + -- a controlled function call or another object which was later + -- rewritten as a class-wide conversion of Ada.Tags.Displace. - -- Obj : Class_Wide_Type := Function_Call (...); + -- Obj1 : CW_Type := Src_Obj; + -- Obj2 : CW_Type := Function_Call (...); - -- Temp : ... := Function_Call (...)'reference; - -- Obj : Class_Wide_Type renames - -- (... Ada.Tags.Displace (Temp)); + -- Obj1 : CW_Type renames (... Ada.Tags.Displace (Src_Obj)); + -- Tmp : ... := Function_Call (...)'reference; + -- Obj2 : CW_Type renames (... Ada.Tags.Displace (Tmp)); - elsif Is_Displacement_Of_Ctrl_Function_Result (Obj_Id) then + elsif Is_Displacement_Of_Object_Or_Function_Result (Obj_Id) then return True; end if; diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads index 97e9b5c9a56..9f3ae2a2554 100644 --- a/gcc/ada/exp_util.ads +++ b/gcc/ada/exp_util.ads @@ -521,11 +521,12 @@ package Exp_Util is -- False otherwise. True for an empty list. It is an error to call this -- routine with No_List as the argument. - function Is_Displacement_Of_Ctrl_Function_Result + function Is_Displacement_Of_Object_Or_Function_Result (Obj_Id : Entity_Id) return Boolean; - -- Determine whether Obj_Id is a source object that has been initialized by - -- a controlled function call later rewritten as a class-wide conversion of - -- Ada.Tags.Displace. + -- Determine whether Obj_Id is a source entity that has been initialized by + -- either a controlled function call or the assignment of another source + -- object. In both cases the initialization expression is rewritten as a + -- class-wide conversion of Ada.Tags.Displace. function Is_Finalizable_Transient (Decl : Node_Id; @@ -548,13 +549,20 @@ package Exp_Util is -- Return True if Typ is a library level tagged type. Currently we use -- this information to build statically allocated dispatch tables. - function Is_Null_Access_BIP_Func_Call (Expr : Node_Id) return Boolean; - -- Determine whether node Expr denotes a build-in-place function call with - -- a value of "null" for extra formal BIPaccess. - function Is_Non_BIP_Func_Call (Expr : Node_Id) return Boolean; -- Determine whether node Expr denotes a non build-in-place function call + function Is_Possibly_Unaligned_Object (N : Node_Id) return Boolean; + -- Node N is an object reference. This function returns True if it is + -- possible that the object may not be aligned according to the normal + -- default alignment requirement for its type (e.g. if it appears in a + -- packed record, or as part of a component that has a component clause.) + + function Is_Possibly_Unaligned_Slice (N : Node_Id) return Boolean; + -- Determine whether the node P is a slice of an array where the slice + -- result may cause alignment problems because it has an alignment that + -- is not compatible with the type. Return True if so. + function Is_Ref_To_Bit_Packed_Array (N : Node_Id) return Boolean; -- Determine whether the node P is a reference to a bit packed array, i.e. -- whether the designated object is a component of a bit packed array, or a @@ -571,17 +579,6 @@ package Exp_Util is -- Determine whether object Id is related to an expanded return statement. -- The case concerned is "return Id.all;". - function Is_Possibly_Unaligned_Slice (N : Node_Id) return Boolean; - -- Determine whether the node P is a slice of an array where the slice - -- result may cause alignment problems because it has an alignment that - -- is not compatible with the type. Return True if so. - - function Is_Possibly_Unaligned_Object (N : Node_Id) return Boolean; - -- Node N is an object reference. This function returns True if it is - -- possible that the object may not be aligned according to the normal - -- default alignment requirement for its type (e.g. if it appears in a - -- packed record, or as part of a component that has a component clause.) - function Is_Renamed_Object (N : Node_Id) return Boolean; -- Returns True if the node N is a renamed object. An expression is -- considered to be a renamed object if either it is the Name of an object @@ -593,6 +590,10 @@ package Exp_Util is -- We consider that a (1 .. 2) is a renamed object since it is the prefix -- of the name in the renaming declaration. + function Is_Secondary_Stack_BIP_Func_Call (Expr : Node_Id) return Boolean; + -- Determine whether Expr denotes a build-in-place function which returns + -- its result on the secondary stack. + function Is_Tag_To_Class_Wide_Conversion (Obj_Id : Entity_Id) return Boolean; -- Determine whether object Obj_Id is the result of a tag-to-class-wide diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index fc7600070f7..3eae40e036b 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -2161,8 +2161,16 @@ package body Freeze is -- Here is where we do the processing for reversed bit order - else + elsif not Reverse_Storage_Order (Rec) then Adjust_Record_For_Reverse_Bit_Order (Rec); + + -- Case where we have both a reverse Bit_Order and a corresponding + -- Scalar_Storage_Order: leave record untouched, the back-end + -- will take care of required layout conversions. + + else + null; + end if; end if; diff --git a/gcc/ada/g-expect.adb b/gcc/ada/g-expect.adb index c6e18efa5b7..94f69642af4 100644 --- a/gcc/ada/g-expect.adb +++ b/gcc/ada/g-expect.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2000-2011, AdaCore -- +-- Copyright (C) 2000-2012, AdaCore -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -33,7 +33,7 @@ with System; use System; with System.OS_Constants; use System.OS_Constants; with Ada.Calendar; use Ada.Calendar; -with GNAT.IO; +with GNAT.IO; use GNAT.IO; with GNAT.OS_Lib; use GNAT.OS_Lib; with GNAT.Regpat; use GNAT.Regpat; @@ -678,6 +678,7 @@ package body GNAT.Expect is -- ??? Note that ddd tries again up to three times -- in that case. See LiterateA.C:174 + Close (Descriptors (D).Input_Fd); Descriptors (D).Input_Fd := Invalid_FD; Result := Expect_Process_Died; return; @@ -893,7 +894,8 @@ package body GNAT.Expect is begin Non_Blocking_Spawn - (Process, Command, Arguments, Err_To_Out => Err_To_Out); + (Process, Command, Arguments, Err_To_Out => Err_To_Out, + Buffer_Size => 0); if Input'Length > 0 then Send (Process, Input); @@ -1055,17 +1057,18 @@ package body GNAT.Expect is Command_With_Path : String_Access; begin - -- Create the rest of the pipes - - Set_Up_Communications - (Descriptor, Err_To_Out, Pipe1'Access, Pipe2'Access, Pipe3'Access); - Command_With_Path := Locate_Exec_On_Path (Command); if Command_With_Path = null then raise Invalid_Process; end if; + -- Create the rest of the pipes once we know we will be able to + -- execute the process. + + Set_Up_Communications + (Descriptor, Err_To_Out, Pipe1'Access, Pipe2'Access, Pipe3'Access); + -- Fork a new process Descriptor.Pid := Fork; @@ -1365,6 +1368,8 @@ package body GNAT.Expect is end if; if Create_Pipe (Pipe2) /= 0 then + Close (Pipe1.Input); + Close (Pipe1.Output); return; end if; @@ -1389,7 +1394,7 @@ package body GNAT.Expect is -- Create a separate pipe for standard error if Create_Pipe (Pipe3) /= 0 then - return; + Pipe3.all := Pipe2.all; end if; end if; diff --git a/gcc/ada/g-sse.ads b/gcc/ada/g-sse.ads index 706516b9830..60d3577ad41 100644 --- a/gcc/ada/g-sse.ads +++ b/gcc/ada/g-sse.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2009, Free Software Foundation, Inc. -- +-- Copyright (C) 2009-2012, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -40,6 +40,8 @@ -- GNU/Linux x86 and x86_64 -- Windows XP/Vista x86 and x86_64 +-- Solaris x86 +-- Darwin x86_64 -- This unit exposes vector _component_ types together with general comments -- on the binding contents. diff --git a/gcc/ada/gcc-interface/Makefile.in b/gcc/ada/gcc-interface/Makefile.in index 9991405e3cc..5c4acda5388 100644 --- a/gcc/ada/gcc-interface/Makefile.in +++ b/gcc/ada/gcc-interface/Makefile.in @@ -1083,6 +1083,8 @@ ifeq ($(strip $(filter-out %86 %x86_64 solaris2%,$(arch) $(osys))),) TOOLS_TARGET_PAIRS=mlib-tgt-specific.adb<mlib-tgt-specific-solaris.adb + EXTRA_GNATRTL_NONTASKING_OBJS=g-sse.o g-ssvety.o + EH_MECHANISM=-gcc THREADSLIB = -lposix4 -lthread MISCLIB = -lposix4 -lnsl -lsocket @@ -1175,6 +1177,8 @@ ifeq ($(strip $(filter-out %86 kfreebsd%,$(arch) $(osys))),) mlib-tgt-specific.adb<mlib-tgt-specific-linux.adb \ indepsw.adb<indepsw-gnu.adb + EXTRA_GNATRTL_NONTASKING_OBJS=g-sse.o g-ssvety.o + EH_MECHANISM=-gcc THREADSLIB = -lpthread GNATLIB_SHARED = gnatlib-shared-dual @@ -1231,6 +1235,8 @@ ifeq ($(strip $(filter-out %86 freebsd%,$(arch) $(osys))),) mlib-tgt-specific.adb<mlib-tgt-specific-linux.adb GNATLIB_SHARED = gnatlib-shared-dual + EXTRA_GNATRTL_NONTASKING_OBJS=g-sse.o g-ssvety.o + EH_MECHANISM=-gcc THREADSLIB= -lpthread GMEM_LIB = gmemlib @@ -1259,6 +1265,8 @@ ifeq ($(strip $(filter-out %86_64 freebsd%,$(arch) $(osys))),) mlib-tgt-specific.adb<mlib-tgt-specific-linux.adb GNATLIB_SHARED = gnatlib-shared-dual + EXTRA_GNATRTL_NONTASKING_OBJS=g-sse.o g-ssvety.o + EH_MECHANISM=-gcc THREADSLIB= -lpthread GMEM_LIB = gmemlib @@ -2160,6 +2168,8 @@ ifeq ($(strip $(filter-out darwin%,$(osys))),) $(X86_TARGET_PAIRS) \ system.ads<system-darwin-x86.ads endif + + EXTRA_GNATRTL_NONTASKING_OBJS=g-sse.o g-ssvety.o endif ifeq ($(strip $(filter-out %x86_64,$(arch))),) @@ -2178,6 +2188,8 @@ ifeq ($(strip $(filter-out darwin%,$(osys))),) $(X86_64_TARGET_PAIRS) \ system.ads<system-darwin-x86_64.ads endif + + EXTRA_GNATRTL_NONTASKING_OBJS=g-sse.o g-ssvety.o endif ifeq ($(strip $(filter-out powerpc%,$(arch))),) diff --git a/gcc/ada/gcc-interface/decl.c b/gcc/ada/gcc-interface/decl.c index b925f422a21..dac9942237f 100644 --- a/gcc/ada/gcc-interface/decl.c +++ b/gcc/ada/gcc-interface/decl.c @@ -81,9 +81,6 @@ #define FOREIGN_FORCE_REALIGN_STACK 0 #endif -/* The (internal) name of the System.Secondary_Stack.SS_Mark function. */ -#define SS_MARK_NAME "system__secondary_stack__ss_mark" - struct incomplete { struct incomplete *next; @@ -4409,21 +4406,6 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition) get_identifier ("force_align_arg_pointer"), NULL_TREE, gnat_entity); - /* ??? Declare System.Secondary_Stack.SS_Mark as leaf, in order to - avoid creating abnormal edges in SJLJ mode, which can break the - dominance relationship if there is a dynamic stack allocation. - We cannot do this in System.Secondary_Stack directly since it's - a compiler unit and this would introduce bootstrap path issues. */ - if (IDENTIFIER_LENGTH (gnu_entity_name) == strlen (SS_MARK_NAME) - && IDENTIFIER_POINTER (gnu_entity_name)[0] == SS_MARK_NAME[0] - && IDENTIFIER_POINTER (gnu_entity_name)[1] == SS_MARK_NAME[1] - && IDENTIFIER_POINTER (gnu_entity_name)[2] == SS_MARK_NAME[2] - && gnu_entity_name == get_identifier (SS_MARK_NAME)) - prepend_one_attribute_to - (&attr_list, ATTR_MACHINE_ATTRIBUTE, - get_identifier ("leaf"), NULL_TREE, - gnat_entity); - /* The lists have been built in reverse. */ gnu_param_list = nreverse (gnu_param_list); if (has_stub) diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi index 5c313ac76f0..e8e4d6e978c 100644 --- a/gcc/ada/gnat_ugn.texi +++ b/gcc/ada/gnat_ugn.texi @@ -94,10 +94,12 @@ Texts. A copy of the license is included in the section entitled @ifset unw @set PLATFORM +@set TITLESUFFIX @end ifset @ifset vms @set PLATFORM OpenVMS +@set TITLESUFFIX for OpenVMS @end ifset @c @ovar(ARG) @@ -115,7 +117,7 @@ Texts. A copy of the license is included in the section entitled @c of the @ovar macro have been expanded inline. -@settitle @value{EDITION} User's Guide @value{PLATFORM} +@settitle @value{EDITION} User's Guide @value{TITLESUFFIX} @dircategory GNU Ada tools @direntry * @value{EDITION} User's Guide: (gnat_ugn). @value{PLATFORM} @@ -484,6 +486,7 @@ Creating Unit Tests Using gnattest * Tagged Types Substitutability Testing:: * Testing with Contracts:: * Additional Tests:: +* Support for other platforms/run-times:: * Current Limitations:: Other Utility Programs @@ -3077,7 +3080,7 @@ $ gnatlink ada_unit file1.o file2.o --LINK=./my_script Where CC is the name of the non-GNU C++ compiler. If the @code{zero cost} exception mechanism is used, and the platform -supports automatic registration of exception tables (e.g.@: Solaris or IRIX), +supports automatic registration of exception tables (e.g.@: Solaris), paths to more objects are required: @smallexample @@ -17988,6 +17991,7 @@ default location. * Tagged Types Substitutability Testing:: * Testing with Contracts:: * Additional Tests:: +* Support for other platforms/run-times:: * Current Limitations:: @end menu @@ -18474,6 +18478,25 @@ gnatmake -Pmixing/test_driver.gpr mixing/test_runner @end smallexample +@node Support for other platforms/run-times +@section Support for other platforms/run-times + +@noindent +@command{gnattest} can be used to generate the test harness for platforms +and run-time libraries others than the default native target with the +default full run-time. For example, when using a limited run-time library +such as Zero FootPrint (ZFP), a simplified harness is generated. + +Two variables are used to tell the underlying AUnit framework how to generate +the test harness: @code{PLATFORM}, which identifies the target, and +@code{RUNTIME}, used to determine the run-time library for which the harness +is generated. For example, the following options are used to generate the +AUnit test harness for a PowerPC ELF target using the ZFP run-time library: + +@smallexample +gnattest -Psimple.gpr -XPLATFORM=powerpc-elf -XRUNTIME=zfp +@end smallexample + @node Current Limitations @section Current Limitations diff --git a/gcc/ada/lib-writ.adb b/gcc/ada/lib-writ.adb index 2d67ea03ccd..e25355bfc30 100644 --- a/gcc/ada/lib-writ.adb +++ b/gcc/ada/lib-writ.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -196,6 +196,10 @@ package body Lib.Writ is Elab_All_Des_Flags : array (Units.First .. Last_Unit) of Boolean; -- Array of flags to show which units have Elaborate_All_Desirable set + type Yes_No is (Unknown, Yes, No); + + Implicit_With : array (Units.First .. Last_Unit) of Yes_No; + Sdep_Table : Unit_Ref_Table (1 .. Pos (Last_Unit - Units.First + 2)); -- Sorted table of source dependencies. One extra entry in case we -- have to add a dummy entry for System. @@ -276,6 +280,15 @@ package body Lib.Writ is else Set_From_With_Type (Cunit_Entity (Unum)); end if; + + if Implicit_With (Unum) /= Yes then + if Implicit_With_From_Instantiation (Item) then + Implicit_With (Unum) := Yes; + + else + Implicit_With (Unum) := No; + end if; + end if; end if; Next (Item); @@ -552,6 +565,7 @@ package body Lib.Writ is Elab_All_Flags (J) := False; Elab_Des_Flags (J) := False; Elab_All_Des_Flags (J) := False; + Implicit_With (J) := Unknown; end loop; Collect_Withs (Unode); @@ -770,10 +784,14 @@ package body Lib.Writ is Uname := Units.Table (Unum).Unit_Name; Fname := Units.Table (Unum).Unit_File_Name; - if Ekind (Cunit_Entity (Unum)) = E_Package + if Implicit_With (Unum) = Yes then + Write_Info_Initiate ('Z'); + + elsif Ekind (Cunit_Entity (Unum)) = E_Package and then From_With_Type (Cunit_Entity (Unum)) then Write_Info_Initiate ('Y'); + else Write_Info_Initiate ('W'); end if; diff --git a/gcc/ada/lib-xref-alfa.adb b/gcc/ada/lib-xref-alfa.adb index 4961fedc8c1..c9ab1e03b10 100644 --- a/gcc/ada/lib-xref-alfa.adb +++ b/gcc/ada/lib-xref-alfa.adb @@ -40,102 +40,19 @@ package body Alfa is -- Table of Alfa_Entities, True for each entity kind used in Alfa Alfa_Entities : constant array (Entity_Kind) of Boolean := - (E_Void => False, - E_Variable => True, - E_Component => False, - E_Constant => True, - E_Discriminant => False, - - E_Loop_Parameter => True, - E_In_Parameter => True, - E_Out_Parameter => True, - E_In_Out_Parameter => True, - E_Generic_In_Out_Parameter => False, - - E_Generic_In_Parameter => False, - E_Named_Integer => False, - E_Named_Real => False, - E_Enumeration_Type => False, - E_Enumeration_Subtype => False, - - E_Signed_Integer_Type => False, - E_Signed_Integer_Subtype => False, - E_Modular_Integer_Type => False, - E_Modular_Integer_Subtype => False, - E_Ordinary_Fixed_Point_Type => False, - - E_Ordinary_Fixed_Point_Subtype => False, - E_Decimal_Fixed_Point_Type => False, - E_Decimal_Fixed_Point_Subtype => False, - E_Floating_Point_Type => False, - E_Floating_Point_Subtype => False, - - E_Access_Type => False, - E_Access_Subtype => False, - E_Access_Attribute_Type => False, - E_Allocator_Type => False, - E_General_Access_Type => False, - - E_Access_Subprogram_Type => False, - E_Access_Protected_Subprogram_Type => False, - E_Anonymous_Access_Subprogram_Type => False, - E_Anonymous_Access_Protected_Subprogram_Type => False, - E_Anonymous_Access_Type => False, - - E_Array_Type => False, - E_Array_Subtype => False, - E_String_Type => False, - E_String_Subtype => False, - E_String_Literal_Subtype => False, - - E_Class_Wide_Type => False, - E_Class_Wide_Subtype => False, - E_Record_Type => False, - E_Record_Subtype => False, - E_Record_Type_With_Private => False, - - E_Record_Subtype_With_Private => False, - E_Private_Type => False, - E_Private_Subtype => False, - E_Limited_Private_Type => False, - E_Limited_Private_Subtype => False, - - E_Incomplete_Type => False, - E_Incomplete_Subtype => False, - E_Task_Type => False, - E_Task_Subtype => False, - E_Protected_Type => False, - - E_Protected_Subtype => False, - E_Exception_Type => False, - E_Subprogram_Type => False, - E_Enumeration_Literal => False, - E_Function => True, - - E_Operator => True, - E_Procedure => True, - E_Entry => False, - E_Entry_Family => False, - E_Block => False, - - E_Entry_Index_Parameter => False, - E_Exception => False, - E_Generic_Function => False, - E_Generic_Package => False, - E_Generic_Procedure => False, - - E_Label => False, - E_Loop => False, - E_Return_Statement => False, - E_Package => False, - - E_Package_Body => False, - E_Protected_Object => False, - E_Protected_Body => False, - E_Task_Body => False, - E_Subprogram_Body => False); + (E_Constant => True, + E_Function => True, + E_In_Out_Parameter => True, + E_In_Parameter => True, + E_Loop_Parameter => True, + E_Operator => True, + E_Out_Parameter => True, + E_Procedure => True, + E_Variable => True, + others => False); -- True for each reference type used in Alfa + Alfa_References : constant array (Character) of Boolean := ('m' => True, 'r' => True, @@ -149,12 +66,15 @@ package body Alfa is -- Local Variables -- --------------------- + Heap : Entity_Id := Empty; + -- A special entity which denotes the heap object + package Drefs is new Table.Table ( Table_Component_Type => Xref_Entry, Table_Index_Type => Xref_Entry_Number, Table_Low_Bound => 1, - Table_Initial => Alloc.Xrefs_Initial, - Table_Increment => Alloc.Xrefs_Increment, + Table_Initial => Alloc.Drefs_Initial, + Table_Increment => Alloc.Drefs_Increment, Table_Name => "Drefs"); -- Table of cross-references for reads and writes through explicit -- dereferences, that are output as reads/writes to the special variable @@ -165,9 +85,12 @@ package body Alfa is -- Local Subprograms -- ----------------------- - procedure Add_Alfa_File (U : Unit_Number_Type; D : Nat); - -- Add file U and all scopes in U to the tables Alfa_File_Table and - -- Alfa_Scope_Table. + procedure Add_Alfa_File (Ubody, Uspec : Unit_Number_Type; Dspec : Nat); + -- Add file and corresponding scopes for unit to the tables Alfa_File_Table + -- and Alfa_Scope_Table. When two units are present for the same + -- compilation unit, as it happens for library-level instantiations of + -- generics, then Ubody /= Uspec, and all scopes are added to the same + -- Alfa file. Otherwise Ubody = Uspec. procedure Add_Alfa_Scope (N : Node_Id); -- Add scope N to the table Alfa_Scope_Table @@ -202,16 +125,15 @@ package body Alfa is (N : Node_Id; Process : Node_Processing; Inside_Stubs : Boolean); - -- Traverse the corresponding constructs, calling Process on all - -- declarations. + -- Traverse corresponding construct, calling Process on all declarations ------------------- -- Add_Alfa_File -- ------------------- - procedure Add_Alfa_File (U : Unit_Number_Type; D : Nat) is + procedure Add_Alfa_File (Ubody, Uspec : Unit_Number_Type; Dspec : Nat) is + File : constant Source_File_Index := Source_Index (Uspec); From : Scope_Index; - S : constant Source_File_Index := Source_Index (U); File_Name : String_Ptr; Unit_File_Name : String_Ptr; @@ -220,69 +142,84 @@ package body Alfa is -- Source file could be inexistant as a result of an error, if option -- gnatQ is used. - if S = No_Source_File then + if File = No_Source_File then return; end if; From := Alfa_Scope_Table.Last + 1; - Traverse_Compilation_Unit (Cunit (U), Detect_And_Add_Alfa_Scope'Access, - Inside_Stubs => False); + -- Unit might not have an associated compilation unit, as seen in code + -- filling Sdep_Table in Write_ALI. + + if Present (Cunit (Ubody)) then + Traverse_Compilation_Unit + (CU => Cunit (Ubody), + Process => Detect_And_Add_Alfa_Scope'Access, + Inside_Stubs => False); + end if; + + -- When two units are present for the same compilation unit, as it + -- happens for library-level instantiations of generics, then add all + -- scopes to the same Alfa file. + + if Ubody /= Uspec then + if Present (Cunit (Uspec)) then + Traverse_Compilation_Unit + (CU => Cunit (Uspec), + Process => Detect_And_Add_Alfa_Scope'Access, + Inside_Stubs => False); + end if; + end if; -- Update scope numbers declare - Count : Nat; - + Scope_Id : Int; begin - Count := 1; - for S in From .. Alfa_Scope_Table.Last loop + Scope_Id := 1; + for Index in From .. Alfa_Scope_Table.Last loop declare - E : Entity_Id renames Alfa_Scope_Table.Table (S).Scope_Entity; - + S : Alfa_Scope_Record renames Alfa_Scope_Table.Table (Index); begin - if Lib.Get_Source_Unit (E) = U then - Alfa_Scope_Table.Table (S).Scope_Num := Count; - Alfa_Scope_Table.Table (S).File_Num := D; - Count := Count + 1; - - else - -- Mark for removal a scope S which is not located in unit - -- U, for example for scope inside generics that get - -- instantiated. - - Alfa_Scope_Table.Table (S).Scope_Num := 0; - end if; + S.Scope_Num := Scope_Id; + S.File_Num := Dspec; + Scope_Id := Scope_Id + 1; end; end loop; end; + -- Remove those scopes previously marked for removal + declare - Snew : Scope_Index; + Scope_Id : Scope_Index; begin - Snew := From; - for S in From .. Alfa_Scope_Table.Last loop - -- Remove those scopes previously marked for removal - - if Alfa_Scope_Table.Table (S).Scope_Num /= 0 then - Alfa_Scope_Table.Table (Snew) := Alfa_Scope_Table.Table (S); - Snew := Snew + 1; - end if; + Scope_Id := From; + for Index in From .. Alfa_Scope_Table.Last loop + declare + S : Alfa_Scope_Record renames Alfa_Scope_Table.Table (Index); + begin + if S.Scope_Num /= 0 then + Alfa_Scope_Table.Table (Scope_Id) := S; + Scope_Id := Scope_Id + 1; + end if; + end; end loop; - Alfa_Scope_Table.Set_Last (Snew - 1); + Alfa_Scope_Table.Set_Last (Scope_Id - 1); end; -- Make entry for new file in file table - Get_Name_String (Reference_Name (S)); + Get_Name_String (Reference_Name (File)); File_Name := new String'(Name_Buffer (1 .. Name_Len)); - -- For subunits, also retrieve the file name of the unit + -- For subunits, also retrieve the file name of the unit. Only do so if + -- unit has an associated compilation unit. - if Present (Cunit (Unit (S))) - and then Nkind (Unit (Cunit (Unit (S)))) = N_Subunit + if Present (Cunit (Uspec)) + and then Present (Cunit (Unit (File))) + and then Nkind (Unit (Cunit (Unit (File)))) = N_Subunit then Get_Name_String (Reference_Name (Main_Source_File)); Unit_File_Name := new String'(Name_Buffer (1 .. Name_Len)); @@ -291,7 +228,7 @@ package body Alfa is Alfa_File_Table.Append ( (File_Name => File_Name, Unit_File_Name => Unit_File_Name, - File_Num => D, + File_Num => Dspec, From_Scope => From, To_Scope => Alfa_Scope_Table.Last)); end Add_Alfa_File; @@ -376,55 +313,69 @@ package body Alfa is -------------------- procedure Add_Alfa_Xrefs is - Cur_Scope_Idx : Scope_Index; - From_Xref_Idx : Xref_Index; - Cur_Entity : Entity_Id; - Cur_Entity_Name : String_Ptr; - - package Scopes is - No_Scope : constant Nat := 0; - function Get_Scope_Num (N : Entity_Id) return Nat; - procedure Set_Scope_Num (N : Entity_Id; Num : Nat); - end Scopes; - - ------------ - -- Scopes -- - ------------ - - package body Scopes is - type Scope is record - Num : Nat; - Entity : Entity_Id; - end record; - - package Scopes is new GNAT.HTable.Simple_HTable - (Header_Num => Entity_Hashed_Range, - Element => Scope, - No_Element => (Num => No_Scope, Entity => Empty), - Key => Entity_Id, - Hash => Entity_Hash, - Equal => "="); - - ------------------- - -- Get_Scope_Num -- - ------------------- - - function Get_Scope_Num (N : Entity_Id) return Nat is - begin - return Scopes.Get (N).Num; - end Get_Scope_Num; + function Entity_Of_Scope (S : Scope_Index) return Entity_Id; + -- Return the entity which maps to the input scope index - ------------------- - -- Set_Scope_Num -- - ------------------- + function Get_Entity_Type (E : Entity_Id) return Character; + -- Return a character representing the type of entity - procedure Set_Scope_Num (N : Entity_Id; Num : Nat) is - begin - Scopes.Set (K => N, E => Scope'(Num => Num, Entity => N)); - end Set_Scope_Num; - end Scopes; + function Is_Alfa_Reference + (E : Entity_Id; + Typ : Character) return Boolean; + -- Return whether entity reference E meets Alfa requirements. Typ is the + -- reference type. + + function Is_Alfa_Scope (E : Entity_Id) return Boolean; + -- Return whether the entity or reference scope meets requirements for + -- being an Alfa scope. + + function Is_Future_Scope_Entity + (E : Entity_Id; + S : Scope_Index) return Boolean; + -- Check whether entity E is in Alfa_Scope_Table at index S or higher + + function Is_Global_Constant (E : Entity_Id) return Boolean; + -- Return True if E is a global constant for which we should ignore + -- reads in Alfa. + + function Lt (Op1 : Natural; Op2 : Natural) return Boolean; + -- Comparison function for Sort call + + procedure Move (From : Natural; To : Natural); + -- Move procedure for Sort call + + procedure Update_Scope_Range + (S : Scope_Index; + From : Xref_Index; + To : Xref_Index); + -- Update the scope which maps to S with the new range From .. To + + package Sorting is new GNAT.Heap_Sort_G (Move, Lt); + + function Get_Scope_Num (N : Entity_Id) return Nat; + -- Return the scope number associated to entity N + + procedure Set_Scope_Num (N : Entity_Id; Num : Nat); + -- Associate entity N to scope number Num + + No_Scope : constant Nat := 0; + -- Initial scope counter - use Scopes; + type Scope_Rec is record + Num : Nat; + Entity : Entity_Id; + end record; + -- Type used to relate an entity and a scope number + + package Scopes is new GNAT.HTable.Simple_HTable + (Header_Num => Entity_Hashed_Range, + Element => Scope_Rec, + No_Element => (Num => No_Scope, Entity => Empty), + Key => Entity_Id, + Hash => Entity_Hash, + Equal => "="); + -- Package used to build a correspondance between entities and scope + -- numbers used in Alfa cross references. Nrefs : Nat := Xrefs.Last; -- Number of references in table. This value may get reset (reduced) @@ -432,6 +383,8 @@ package body Alfa is -- not suitable for local cross-references. Nrefs_Add : constant Nat := Drefs.Last; + -- Number of additional references which correspond to dereferences in + -- the source code. Rnums : array (0 .. Nrefs + Nrefs_Add) of Nat; -- This array contains numbers of references in the Xrefs table. This @@ -439,13 +392,149 @@ package body Alfa is -- for the call to sort. When we sort the table, we move the entries in -- Rnums around, but we do not move the original table entries. - function Lt (Op1, Op2 : Natural) return Boolean; - -- Comparison function for Sort call + --------------------- + -- Entity_Of_Scope -- + --------------------- - procedure Move (From : Natural; To : Natural); - -- Move procedure for Sort call + function Entity_Of_Scope (S : Scope_Index) return Entity_Id is + begin + return Alfa_Scope_Table.Table (S).Scope_Entity; + end Entity_Of_Scope; - package Sorting is new GNAT.Heap_Sort_G (Move, Lt); + --------------------- + -- Get_Entity_Type -- + --------------------- + + function Get_Entity_Type (E : Entity_Id) return Character is + begin + case Ekind (E) is + when E_Out_Parameter => return '<'; + when E_In_Out_Parameter => return '='; + when E_In_Parameter => return '>'; + when others => return '*'; + end case; + end Get_Entity_Type; + + ------------------- + -- Get_Scope_Num -- + ------------------- + + function Get_Scope_Num (N : Entity_Id) return Nat is + begin + return Scopes.Get (N).Num; + end Get_Scope_Num; + + ----------------------- + -- Is_Alfa_Reference -- + ----------------------- + + function Is_Alfa_Reference + (E : Entity_Id; + Typ : Character) return Boolean + is + begin + -- The only references of interest on callable entities are calls. On + -- non-callable entities, the only references of interest are reads + -- and writes. + + if Ekind (E) in Overloadable_Kind then + return Typ = 's'; + + -- References to constant objects are not considered in Alfa section, + -- as these will be translated as constants in the intermediate + -- language for formal verification, and should therefore never + -- appear in frame conditions. + + elsif Is_Constant_Object (E) then + return False; + + -- Objects of Task type or protected type are not Alfa references + + elsif Present (Etype (E)) + and then Ekind (Etype (E)) in Concurrent_Kind + then + return False; + + -- In all other cases, result is true for reference/modify cases, + -- and false for all other cases. + + else + return Typ = 'r' or else Typ = 'm'; + end if; + end Is_Alfa_Reference; + + ------------------- + -- Is_Alfa_Scope -- + ------------------- + + function Is_Alfa_Scope (E : Entity_Id) return Boolean is + begin + return Present (E) + and then not Is_Generic_Unit (E) + and then Renamed_Entity (E) = Empty + and then Get_Scope_Num (E) /= No_Scope; + end Is_Alfa_Scope; + + ---------------------------- + -- Is_Future_Scope_Entity -- + ---------------------------- + + function Is_Future_Scope_Entity + (E : Entity_Id; + S : Scope_Index) return Boolean + is + function Is_Past_Scope_Entity return Boolean; + -- Check whether entity E is in Alfa_Scope_Table at index strictly + -- lower than S. + + -------------------------- + -- Is_Past_Scope_Entity -- + -------------------------- + + function Is_Past_Scope_Entity return Boolean is + begin + for Index in Alfa_Scope_Table.First .. S - 1 loop + if Alfa_Scope_Table.Table (Index).Scope_Entity = E then + declare + Dummy : constant Alfa_Scope_Record := + Alfa_Scope_Table.Table (Index); + pragma Unreferenced (Dummy); + begin + return True; + end; + end if; + end loop; + + return False; + end Is_Past_Scope_Entity; + + -- Start of processing for Is_Future_Scope_Entity + + begin + for Index in S .. Alfa_Scope_Table.Last loop + if Alfa_Scope_Table.Table (Index).Scope_Entity = E then + return True; + end if; + end loop; + + -- If this assertion fails, this means that the scope which we are + -- looking for has been treated already, which reveals a problem in + -- the order of cross-references. + + pragma Assert (not Is_Past_Scope_Entity); + + return False; + end Is_Future_Scope_Entity; + + ------------------------ + -- Is_Global_Constant -- + ------------------------ + + function Is_Global_Constant (E : Entity_Id) return Boolean is + begin + return Ekind (E) = E_Constant + and then Ekind_In (Scope (E), E_Package, E_Package_Body); + end Is_Global_Constant; -------- -- Lt -- @@ -464,7 +553,7 @@ package body Alfa is if T1.Ent_Scope_File /= T2.Ent_Scope_File then return Dependency_Num (T1.Ent_Scope_File) < - Dependency_Num (T2.Ent_Scope_File); + Dependency_Num (T2.Ent_Scope_File); -- Second test: within same unit, sort by location of the scope of -- the entity definition. @@ -473,7 +562,7 @@ package body Alfa is Get_Scope_Num (T2.Key.Ent_Scope) then return Get_Scope_Num (T1.Key.Ent_Scope) < - Get_Scope_Num (T2.Key.Ent_Scope); + Get_Scope_Num (T2.Key.Ent_Scope); -- Third test: within same unit and scope, sort by location of -- entity definition. @@ -481,59 +570,68 @@ package body Alfa is elsif T1.Def /= T2.Def then return T1.Def < T2.Def; - -- Fourth test: if reference is in same unit as entity definition, - -- sort first. + else + -- Both entities must be equal at this point - elsif - T1.Key.Lun /= T2.Key.Lun and then T1.Ent_Scope_File = T1.Key.Lun - then - return True; + pragma Assert (T1.Key.Ent = T2.Key.Ent); - elsif - T1.Key.Lun /= T2.Key.Lun and then T2.Ent_Scope_File = T2.Key.Lun - then - return False; + -- Fourth test: if reference is in same unit as entity definition, + -- sort first. - -- Fifth test: if reference is in same unit and same scope as entity - -- definition, sort first. + if T1.Key.Lun /= T2.Key.Lun + and then T1.Ent_Scope_File = T1.Key.Lun + then + return True; - elsif T1.Ent_Scope_File = T1.Key.Lun - and then T1.Key.Ref_Scope /= T2.Key.Ref_Scope - and then T1.Key.Ent_Scope = T1.Key.Ref_Scope - then - return True; - elsif T1.Ent_Scope_File = T1.Key.Lun - and then T1.Key.Ref_Scope /= T2.Key.Ref_Scope - and then T2.Key.Ent_Scope = T2.Key.Ref_Scope - then - return False; + elsif T1.Key.Lun /= T2.Key.Lun + and then T2.Ent_Scope_File = T2.Key.Lun + then + return False; - -- Sixth test: for same entity, sort by reference location unit + -- Fifth test: if reference is in same unit and same scope as + -- entity definition, sort first. - elsif T1.Key.Lun /= T2.Key.Lun then - return Dependency_Num (T1.Key.Lun) < Dependency_Num (T2.Key.Lun); + elsif T1.Ent_Scope_File = T1.Key.Lun + and then T1.Key.Ref_Scope /= T2.Key.Ref_Scope + and then T1.Key.Ent_Scope = T1.Key.Ref_Scope + then + return True; - -- Seventh test: for same entity, sort by reference location scope + elsif T2.Ent_Scope_File = T2.Key.Lun + and then T1.Key.Ref_Scope /= T2.Key.Ref_Scope + and then T2.Key.Ent_Scope = T2.Key.Ref_Scope + then + return False; - elsif Get_Scope_Num (T1.Key.Ref_Scope) /= - Get_Scope_Num (T2.Key.Ref_Scope) - then - return Get_Scope_Num (T1.Key.Ref_Scope) < - Get_Scope_Num (T2.Key.Ref_Scope); + -- Sixth test: for same entity, sort by reference location unit - -- Eighth test: order of location within referencing unit + elsif T1.Key.Lun /= T2.Key.Lun then + return Dependency_Num (T1.Key.Lun) < + Dependency_Num (T2.Key.Lun); - elsif T1.Key.Loc /= T2.Key.Loc then - return T1.Key.Loc < T2.Key.Loc; + -- Seventh test: for same entity, sort by reference location scope - -- Finally, for two locations at the same address prefer the one that - -- does NOT have the type 'r', so that a modification or extension - -- takes preference, when there are more than one reference at the - -- same location. As a result, in the case of entities that are - -- in-out actuals, the read reference follows the modify reference. + elsif Get_Scope_Num (T1.Key.Ref_Scope) /= + Get_Scope_Num (T2.Key.Ref_Scope) + then + return Get_Scope_Num (T1.Key.Ref_Scope) < + Get_Scope_Num (T2.Key.Ref_Scope); - else - return T2.Key.Typ = 'r'; + -- Eighth test: order of location within referencing unit + + elsif T1.Key.Loc /= T2.Key.Loc then + return T1.Key.Loc < T2.Key.Loc; + + -- Finally, for two locations at the same address prefer the one + -- that does NOT have the type 'r', so that a modification or + -- extension takes preference, when there are more than one + -- reference at the same location. As a result, in the case of + -- entities that are in-out actuals, the read reference follows + -- the modify reference. + + else + return T2.Key.Typ = 'r'; + end if; end if; end Lt; @@ -546,308 +644,167 @@ package body Alfa is Rnums (Nat (To)) := Rnums (Nat (From)); end Move; - Heap : Entity_Id; + ------------------- + -- Set_Scope_Num -- + ------------------- + + procedure Set_Scope_Num (N : Entity_Id; Num : Nat) is + begin + Scopes.Set (K => N, E => Scope_Rec'(Num => Num, Entity => N)); + end Set_Scope_Num; + + ------------------------ + -- Update_Scope_Range -- + ------------------------ + + procedure Update_Scope_Range + (S : Scope_Index; + From : Xref_Index; + To : Xref_Index) + is + begin + Alfa_Scope_Table.Table (S).From_Xref := From; + Alfa_Scope_Table.Table (S).To_Xref := To; + end Update_Scope_Range; + + -- Local variables + + Col : Nat; + From_Index : Xref_Index; + Line : Nat; + Loc : Source_Ptr; + Prev_Typ : Character; + Ref_Count : Nat; + Ref_Id : Entity_Id; + Ref_Name : String_Ptr; + Scope_Id : Scope_Index; -- Start of processing for Add_Alfa_Xrefs begin - for J in Alfa_Scope_Table.First .. Alfa_Scope_Table.Last loop - Set_Scope_Num (N => Alfa_Scope_Table.Table (J).Scope_Entity, - Num => Alfa_Scope_Table.Table (J).Scope_Num); + for Index in Alfa_Scope_Table.First .. Alfa_Scope_Table.Last loop + declare + S : Alfa_Scope_Record renames Alfa_Scope_Table.Table (Index); + begin + Set_Scope_Num (S.Scope_Entity, S.Scope_Num); + end; end loop; -- Set up the pointer vector for the sort - for J in 1 .. Nrefs loop - Rnums (J) := J; + for Index in 1 .. Nrefs loop + Rnums (Index) := Index; end loop; - -- Add dereferences to the set of regular references, by creating a - -- special "Heap" variable for these special references. - - Name_Len := Name_Of_Heap_Variable'Length; - Name_Buffer (1 .. Name_Len) := Name_Of_Heap_Variable; - - Atree.Unlock; - Nlists.Unlock; - Heap := Make_Defining_Identifier (Standard_Location, Name_Enter); - Atree.Lock; - Nlists.Lock; - - Set_Ekind (Heap, E_Variable); - Set_Is_Internal (Heap, True); - Set_Has_Fully_Qualified_Name (Heap); - - for J in Drefs.First .. Drefs.Last loop - Xrefs.Append (Drefs.Table (J)); - - -- Set entity at this point with newly created "Heap" variable - - Xrefs.Table (Xrefs.Last).Key.Ent := Heap; + for Index in Drefs.First .. Drefs.Last loop + Xrefs.Append (Drefs.Table (Index)); Nrefs := Nrefs + 1; Rnums (Nrefs) := Xrefs.Last; end loop; + -- Capture the definition Sloc values. As in the case of normal cross + -- references, we have to wait until now to get the correct value. + + for Index in 1 .. Nrefs loop + Xrefs.Table (Index).Def := Sloc (Xrefs.Table (Index).Key.Ent); + end loop; + -- Eliminate entries not appropriate for Alfa. Done prior to sorting -- cross-references, as it discards useless references which do not have -- a proper format for the comparison function (like no location). - Eliminate_Before_Sort : declare - NR : Nat; - - function Is_Alfa_Reference - (E : Entity_Id; - Typ : Character) return Boolean; - -- Return whether entity reference E meets Alfa requirements. Typ - -- is the reference type. - - function Is_Alfa_Scope (E : Entity_Id) return Boolean; - -- Return whether the entity or reference scope meets requirements - -- for being an Alfa scope. + Ref_Count := Nrefs; + Nrefs := 0; - function Is_Global_Constant (E : Entity_Id) return Boolean; - -- Return True if E is a global constant for which we should ignore - -- reads in Alfa. + for Index in 1 .. Ref_Count loop + declare + Ref : Xref_Key renames Xrefs.Table (Rnums (Index)).Key; - ----------------------- - -- Is_Alfa_Reference -- - ----------------------- - - function Is_Alfa_Reference - (E : Entity_Id; - Typ : Character) return Boolean - is begin - -- The only references of interest on callable entities are calls. - -- On non-callable entities, the only references of interest are - -- reads and writes. - - if Ekind (E) in Overloadable_Kind then - return Typ = 's'; - - -- References to constant objects are not considered in Alfa - -- section, as these will be translated as constants in the - -- intermediate language for formal verification, and should - -- therefore never appear in frame conditions. - - elsif Is_Constant_Object (E) then - return False; + if Alfa_Entities (Ekind (Ref.Ent)) + and then Alfa_References (Ref.Typ) + and then Is_Alfa_Scope (Ref.Ent_Scope) + and then Is_Alfa_Scope (Ref.Ref_Scope) + and then not Is_Global_Constant (Ref.Ent) + and then Is_Alfa_Reference (Ref.Ent, Ref.Typ) - -- Objects of Task type or protected type are not Alfa references + -- Discard references from unknown scopes, e.g. generic scopes - elsif Present (Etype (E)) - and then Ekind (Etype (E)) in Concurrent_Kind - then - return False; - - -- In all other cases, result is true for reference/modify cases, - -- and false for all other cases. - - else - return Typ = 'r' or else Typ = 'm'; - end if; - end Is_Alfa_Reference; - - ------------------- - -- Is_Alfa_Scope -- - ------------------- - - function Is_Alfa_Scope (E : Entity_Id) return Boolean is - begin - return Present (E) - and then not Is_Generic_Unit (E) - and then Renamed_Entity (E) = Empty - and then Get_Scope_Num (E) /= No_Scope; - end Is_Alfa_Scope; - - ------------------------ - -- Is_Global_Constant -- - ------------------------ - - function Is_Global_Constant (E : Entity_Id) return Boolean is - begin - return Ekind (E) = E_Constant - and then Ekind_In (Scope (E), E_Package, E_Package_Body); - end Is_Global_Constant; - - -- Start of processing for Eliminate_Before_Sort - - begin - NR := Nrefs; - Nrefs := 0; - - for J in 1 .. NR loop - if Alfa_Entities (Ekind (Xrefs.Table (Rnums (J)).Key.Ent)) - and then Alfa_References (Xrefs.Table (Rnums (J)).Key.Typ) - and then Is_Alfa_Scope (Xrefs.Table (Rnums (J)).Key.Ent_Scope) - and then Is_Alfa_Scope (Xrefs.Table (Rnums (J)).Key.Ref_Scope) - and then not Is_Global_Constant (Xrefs.Table (Rnums (J)).Key.Ent) - and then Is_Alfa_Reference (Xrefs.Table (Rnums (J)).Key.Ent, - Xrefs.Table (Rnums (J)).Key.Typ) + and then Get_Scope_Num (Ref.Ent_Scope) /= No_Scope + and then Get_Scope_Num (Ref.Ref_Scope) /= No_Scope then Nrefs := Nrefs + 1; - Rnums (Nrefs) := Rnums (J); + Rnums (Nrefs) := Rnums (Index); end if; - end loop; - end Eliminate_Before_Sort; + end; + end loop; -- Sort the references Sorting.Sort (Integer (Nrefs)); - Eliminate_After_Sort : declare - NR : Nat; + -- Eliminate duplicate entries - Crloc : Source_Ptr; - -- Current reference location + -- We need this test for Ref_Count because if we force ALI file + -- generation in case of errors detected, it may be the case that + -- Nrefs is 0, so we should not reset it here. - Prevt : Character; - -- reference kind of previous reference + if Nrefs >= 2 then + Ref_Count := Nrefs; + Nrefs := 1; - begin - -- Eliminate duplicate entries - - -- We need this test for NR because if we force ALI file generation - -- in case of errors detected, it may be the case that Nrefs is 0, so - -- we should not reset it here - - if Nrefs >= 2 then - NR := Nrefs; - Nrefs := 1; + for Index in 2 .. Ref_Count loop + if Xrefs.Table (Rnums (Index)) /= + Xrefs.Table (Rnums (Nrefs)) + then + Nrefs := Nrefs + 1; + Rnums (Nrefs) := Rnums (Index); + end if; + end loop; + end if; - for J in 2 .. NR loop - if Xrefs.Table (Rnums (J)) /= - Xrefs.Table (Rnums (Nrefs)) - then - Nrefs := Nrefs + 1; - Rnums (Nrefs) := Rnums (J); - end if; - end loop; - end if; + -- Eliminate the reference if it is at the same location as the previous + -- one, unless it is a read-reference indicating that the entity is an + -- in-out actual in a call. - -- Eliminate the reference if it is at the same location as the - -- previous one, unless it is a read-reference indicating that the - -- entity is an in-out actual in a call. + Ref_Count := Nrefs; + Nrefs := 0; + Loc := No_Location; + Prev_Typ := 'm'; - NR := Nrefs; - Nrefs := 0; - Crloc := No_Location; - Prevt := 'm'; + for Index in 1 .. Ref_Count loop + declare + Ref : Xref_Key renames Xrefs.Table (Rnums (Index)).Key; - for J in 1 .. NR loop - if Xrefs.Table (Rnums (J)).Key.Loc /= Crloc - or else (Prevt = 'm' - and then Xrefs.Table (Rnums (J)).Key.Typ = 'r') + begin + if Ref.Loc /= Loc + or else (Prev_Typ = 'm' and then Ref.Typ = 'r') then - Crloc := Xrefs.Table (Rnums (J)).Key.Loc; - Prevt := Xrefs.Table (Rnums (J)).Key.Typ; + Loc := Ref.Loc; + Prev_Typ := Ref.Typ; Nrefs := Nrefs + 1; - Rnums (Nrefs) := Rnums (J); + Rnums (Nrefs) := Rnums (Index); end if; - end loop; - end Eliminate_After_Sort; - - -- Initialize loop + end; + end loop; - Cur_Scope_Idx := 1; - From_Xref_Idx := 1; - Cur_Entity := Empty; + -- The two steps have eliminated all references, nothing to do if Alfa_Scope_Table.Last = 0 then return; end if; + Ref_Id := Empty; + Scope_Id := 1; + From_Index := 1; + -- Loop to output references for Refno in 1 .. Nrefs loop - Add_One_Xref : declare - - ----------------------- - -- Local Subprograms -- - ----------------------- - - function Cur_Scope return Node_Id; - -- Return scope entity which corresponds to index Cur_Scope_Idx in - -- table Alfa_Scope_Table. - - function Get_Entity_Type (E : Entity_Id) return Character; - -- Return a character representing the type of entity - - function Is_Future_Scope_Entity (E : Entity_Id) return Boolean; - -- Check whether entity E is in Alfa_Scope_Table at index - -- Cur_Scope_Idx or higher. - - function Is_Past_Scope_Entity (E : Entity_Id) return Boolean; - -- Check whether entity E is in Alfa_Scope_Table at index strictly - -- lower than Cur_Scope_Idx. - - --------------- - -- Cur_Scope -- - --------------- - - function Cur_Scope return Node_Id is - begin - return Alfa_Scope_Table.Table (Cur_Scope_Idx).Scope_Entity; - end Cur_Scope; - - --------------------- - -- Get_Entity_Type -- - --------------------- - - function Get_Entity_Type (E : Entity_Id) return Character is - C : Character; - begin - case Ekind (E) is - when E_Out_Parameter => C := '<'; - when E_In_Out_Parameter => C := '='; - when E_In_Parameter => C := '>'; - when others => C := '*'; - end case; - return C; - end Get_Entity_Type; - - ---------------------------- - -- Is_Future_Scope_Entity -- - ---------------------------- - - function Is_Future_Scope_Entity (E : Entity_Id) return Boolean is - begin - for J in Cur_Scope_Idx .. Alfa_Scope_Table.Last loop - if E = Alfa_Scope_Table.Table (J).Scope_Entity then - return True; - end if; - end loop; - - -- If this assertion fails, this means that the scope which we - -- are looking for has been treated already, which reveals a - -- problem in the order of cross-references. - - pragma Assert (not Is_Past_Scope_Entity (E)); - - return False; - end Is_Future_Scope_Entity; - - -------------------------- - -- Is_Past_Scope_Entity -- - -------------------------- - - function Is_Past_Scope_Entity (E : Entity_Id) return Boolean is - begin - for J in Alfa_Scope_Table.First .. Cur_Scope_Idx - 1 loop - if E = Alfa_Scope_Table.Table (J).Scope_Entity then - return True; - end if; - end loop; - - return False; - end Is_Past_Scope_Entity; - - --------------------- - -- Local Variables -- - --------------------- - - XE : Xref_Entry renames Xrefs.Table (Rnums (Refno)); + declare + Ref_Entry : Xref_Entry renames Xrefs.Table (Rnums (Refno)); + Ref : Xref_Key renames Ref_Entry.Key; begin -- If this assertion fails, the scope which we are looking for is @@ -855,61 +812,57 @@ package body Alfa is -- construction of the scope table, or an erroneous scope for the -- current cross-reference. - pragma Assert (Is_Future_Scope_Entity (XE.Key.Ent_Scope)); + pragma Assert (Is_Future_Scope_Entity (Ref.Ent_Scope, Scope_Id)); -- Update the range of cross references to which the current scope -- refers to. This may be the empty range only for the first scope -- considered. - if XE.Key.Ent_Scope /= Cur_Scope then - Alfa_Scope_Table.Table (Cur_Scope_Idx).From_Xref := - From_Xref_Idx; - Alfa_Scope_Table.Table (Cur_Scope_Idx).To_Xref := - Alfa_Xref_Table.Last; - From_Xref_Idx := Alfa_Xref_Table.Last + 1; + if Ref.Ent_Scope /= Entity_Of_Scope (Scope_Id) then + Update_Scope_Range + (S => Scope_Id, + From => From_Index, + To => Alfa_Xref_Table.Last); + + From_Index := Alfa_Xref_Table.Last + 1; end if; - while XE.Key.Ent_Scope /= Cur_Scope loop - Cur_Scope_Idx := Cur_Scope_Idx + 1; - pragma Assert (Cur_Scope_Idx <= Alfa_Scope_Table.Last); + while Ref.Ent_Scope /= Entity_Of_Scope (Scope_Id) loop + Scope_Id := Scope_Id + 1; + pragma Assert (Scope_Id <= Alfa_Scope_Table.Last); end loop; - if XE.Key.Ent /= Cur_Entity then - Cur_Entity_Name := - new String'(Unique_Name (XE.Key.Ent)); + if Ref.Ent /= Ref_Id then + Ref_Name := new String'(Unique_Name (Ref.Ent)); end if; - if XE.Key.Ent = Heap then - Alfa_Xref_Table.Append ( - (Entity_Name => Cur_Entity_Name, - Entity_Line => 0, - Etype => Get_Entity_Type (XE.Key.Ent), - Entity_Col => 0, - File_Num => Dependency_Num (XE.Key.Lun), - Scope_Num => Get_Scope_Num (XE.Key.Ref_Scope), - Line => Int (Get_Logical_Line_Number (XE.Key.Loc)), - Rtype => XE.Key.Typ, - Col => Int (Get_Column_Number (XE.Key.Loc)))); - + if Ref.Ent = Heap then + Line := 0; + Col := 0; else - Alfa_Xref_Table.Append ( - (Entity_Name => Cur_Entity_Name, - Entity_Line => Int (Get_Logical_Line_Number (XE.Def)), - Etype => Get_Entity_Type (XE.Key.Ent), - Entity_Col => Int (Get_Column_Number (XE.Def)), - File_Num => Dependency_Num (XE.Key.Lun), - Scope_Num => Get_Scope_Num (XE.Key.Ref_Scope), - Line => Int (Get_Logical_Line_Number (XE.Key.Loc)), - Rtype => XE.Key.Typ, - Col => Int (Get_Column_Number (XE.Key.Loc)))); + Line := Int (Get_Logical_Line_Number (Ref_Entry.Def)); + Col := Int (Get_Column_Number (Ref_Entry.Def)); end if; - end Add_One_Xref; + + Alfa_Xref_Table.Append ( + (Entity_Name => Ref_Name, + Entity_Line => Line, + Etype => Get_Entity_Type (Ref.Ent), + Entity_Col => Col, + File_Num => Dependency_Num (Ref.Lun), + Scope_Num => Get_Scope_Num (Ref.Ref_Scope), + Line => Int (Get_Logical_Line_Number (Ref.Loc)), + Rtype => Ref.Typ, + Col => Int (Get_Column_Number (Ref.Loc)))); + end; end loop; -- Update the range of cross references to which the scope refers to - Alfa_Scope_Table.Table (Cur_Scope_Idx).From_Xref := From_Xref_Idx; - Alfa_Scope_Table.Table (Cur_Scope_Idx).To_Xref := Alfa_Xref_Table.Last; + Update_Scope_Range + (S => Scope_Id, + From => From_Index, + To => Alfa_Xref_Table.Last); end Add_Alfa_Xrefs; ------------------ @@ -917,6 +870,9 @@ package body Alfa is ------------------ procedure Collect_Alfa (Sdep_Table : Unit_Ref_Table; Num_Sdep : Nat) is + D1 : Nat; + D2 : Nat; + begin -- Cross-references should have been computed first @@ -926,8 +882,28 @@ package body Alfa is -- Generate file and scope Alfa information - for D in 1 .. Num_Sdep loop - Add_Alfa_File (U => Sdep_Table (D), D => D); + D1 := 1; + while D1 <= Num_Sdep loop + + -- In rare cases, when treating the library-level instantiation of a + -- generic, two consecutive units refer to the same compilation unit + -- node and entity. In that case, treat them as a single unit for the + -- sake of Alfa cross references by passing to Add_Alfa_File. + + if D1 < Num_Sdep + and then Cunit_Entity (Sdep_Table (D1)) = + Cunit_Entity (Sdep_Table (D1 + 1)) + then + D2 := D1 + 1; + else + D2 := D1; + end if; + + Add_Alfa_File + (Ubody => Sdep_Table (D1), + Uspec => Sdep_Table (D2), + Dspec => D2); + D1 := D2 + 1; end loop; -- Fill in the spec information when relevant @@ -965,8 +941,7 @@ package body Alfa is Entity_Hash_Table.Get (Spec_Entity); begin - -- Spec of generic may be missing, in which case Spec_Scope is - -- zero. + -- Generic spec may be missing in which case Spec_Scope is zero if Spec_Entity /= Srec.Scope_Entity and then Spec_Scope /= 0 @@ -1020,9 +995,7 @@ package body Alfa is Result := N; end if; - loop - exit when No (Result); - + while Present (Result) loop case Nkind (Result) is when N_Package_Specification => Result := Defining_Unit_Name (Result); @@ -1068,7 +1041,7 @@ package body Alfa is Result := Defining_Identifier (Result); end if; - -- Do no return a scope without a proper location + -- Do not return a scope without a proper location if Present (Result) and then Sloc (Result) = No_Location @@ -1097,36 +1070,67 @@ package body Alfa is (N : Node_Id; Typ : Character := 'r') is - Indx : Nat; - Ref : Source_Ptr; + procedure Create_Heap; + -- Create and decorate the special entity which denotes the heap + + ----------------- + -- Create_Heap -- + ----------------- + + procedure Create_Heap is + begin + Name_Len := Name_Of_Heap_Variable'Length; + Name_Buffer (1 .. Name_Len) := Name_Of_Heap_Variable; + + Heap := Make_Defining_Identifier (Standard_Location, Name_Enter); + + Set_Ekind (Heap, E_Variable); + Set_Is_Internal (Heap, True); + Set_Has_Fully_Qualified_Name (Heap); + end Create_Heap; + + -- Local variables + + Loc : constant Source_Ptr := Sloc (N); + Index : Nat; Ref_Scope : Entity_Id; + -- Start of processing for Generate_Dereference + begin - Ref := Original_Location (Sloc (N)); - if Ref > No_Location then + if Loc > No_Location then Drefs.Increment_Last; - Indx := Drefs.Last; + Index := Drefs.Last; + + declare + Deref_Entry : Xref_Entry renames Drefs.Table (Index); + Deref : Xref_Key renames Deref_Entry.Key; + + begin + if No (Heap) then + Create_Heap; + end if; - Ref_Scope := Enclosing_Subprogram_Or_Package (N); + Ref_Scope := Enclosing_Subprogram_Or_Package (N); - -- Entity is filled later on with the special "Heap" variable + Deref.Ent := Heap; + Deref.Loc := Loc; + Deref.Typ := Typ; - Drefs.Table (Indx).Key.Ent := Empty; + -- It is as if the special "Heap" was defined in every scope where + -- it is referenced. - Drefs.Table (Indx).Def := No_Location; - Drefs.Table (Indx).Key.Loc := Ref; - Drefs.Table (Indx).Key.Typ := Typ; + Deref.Eun := Get_Code_Unit (Loc); + Deref.Lun := Get_Code_Unit (Loc); - -- It is as if the special "Heap" was defined in every scope where it - -- is referenced. + Deref.Ref_Scope := Ref_Scope; + Deref.Ent_Scope := Ref_Scope; - Drefs.Table (Indx).Key.Eun := Get_Source_Unit (Ref); - Drefs.Table (Indx).Key.Lun := Get_Source_Unit (Ref); + Deref_Entry.Def := No_Location; - Drefs.Table (Indx).Key.Ref_Scope := Ref_Scope; - Drefs.Table (Indx).Key.Ent_Scope := Ref_Scope; - Drefs.Table (Indx).Ent_Scope_File := Get_Source_Unit (Ref_Scope); + Deref_Entry.Ent_Scope_File := Get_Code_Unit (N); + end; end if; end Generate_Dereference; @@ -1161,6 +1165,14 @@ package body Alfa is Lu := Proper_Body (Lu); end if; + -- Do not add scopes for generic units + + if Nkind (Lu) = N_Package_Body + and then Ekind (Corresponding_Spec (Lu)) in Generic_Unit_Kind + then + return; + end if; + -- Call Process on all declarations if Nkind (Lu) in N_Declaration @@ -1183,18 +1195,8 @@ package body Alfa is elsif Nkind (Lu) = N_Package_Body then Traverse_Package_Body (Lu, Process, Inside_Stubs); - -- ??? TBD - - elsif Nkind (Lu) = N_Generic_Package_Declaration then - null; - - -- ??? TBD - - elsif Nkind (Lu) in N_Generic_Instantiation then - null; - -- All other cases of compilation units (e.g. renamings), are not - -- declarations. + -- declarations, or else generic declarations which are ignored. else null; @@ -1233,11 +1235,6 @@ package body Alfa is when N_Package_Declaration => Traverse_Package_Declaration (N, Process, Inside_Stubs); - -- Generic package declaration ??? TBD - - when N_Generic_Package_Declaration => - null; - -- Package body when N_Package_Body => @@ -1264,11 +1261,6 @@ package body Alfa is when N_Subprogram_Declaration => null; - -- Generic subprogram declaration ??? TBD - - when N_Generic_Subprogram_Declaration => - null; - -- Subprogram body when N_Subprogram_Body => @@ -1355,6 +1347,8 @@ package body Alfa is Traverse_Declarations_Or_Statements (Statements (N), Process, Inside_Stubs); + -- Generic declarations are ignored + when others => null; end case; @@ -1429,7 +1423,8 @@ package body Alfa is procedure Traverse_Subprogram_Body (N : Node_Id; Process : Node_Processing; - Inside_Stubs : Boolean) is + Inside_Stubs : Boolean) + is begin Traverse_Declarations_Or_Statements (Declarations (N), Process, Inside_Stubs); diff --git a/gcc/ada/lib-xref.adb b/gcc/ada/lib-xref.adb index 0e8337f70c6..b6595b336a4 100644 --- a/gcc/ada/lib-xref.adb +++ b/gcc/ada/lib-xref.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1998-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1998-2012, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -161,6 +161,9 @@ package body Lib.Xref is -- Local Subprograms -- ------------------------ + procedure Add_Entry (Key : Xref_Key; Ent_Scope_File : Unit_Number_Type); + -- Add an entry to the tables of Xref_Entries, avoiding duplicates + procedure Generate_Prim_Op_References (Typ : Entity_Id); -- For a tagged type, generate implicit references to its primitive -- operations, for source navigation. This is done right before emitting @@ -170,9 +173,6 @@ package body Lib.Xref is function Lt (T1, T2 : Xref_Entry) return Boolean; -- Order cross-references - procedure Add_Entry (Key : Xref_Key; Ent_Scope_File : Unit_Number_Type); - -- Add an entry to the tables of Xref_Entries, avoiding duplicates - --------------- -- Add_Entry -- --------------- @@ -373,23 +373,16 @@ package body Lib.Xref is Set_Ref : Boolean := True; Force : Boolean := False) is - Nod : Node_Id; - Ref : Source_Ptr; - Def : Source_Ptr; - Ent : Entity_Id; - - Actual_Typ : Character := Typ; - - Ref_Scope : Entity_Id; + Actual_Typ : Character := Typ; + Call : Node_Id; + Def : Source_Ptr; + Ent : Entity_Id; Ent_Scope : Entity_Id; - Ent_Scope_File : Unit_Number_Type; - - Call : Node_Id; - Formal : Entity_Id; - -- Used for call to Find_Actual - - Kind : Entity_Kind; - -- If Formal is non-Empty, then its Ekind, otherwise E_Void + Formal : Entity_Id; + Kind : Entity_Kind; + Nod : Node_Id; + Ref : Source_Ptr; + Ref_Scope : Entity_Id; function Get_Through_Renamings (E : Entity_Id) return Entity_Id; -- Get the enclosing entity through renamings, which may come from @@ -639,6 +632,14 @@ package body Lib.Xref is or else Typ = 'i' or else Typ = 'k' or else (Typ = 'b' and then Is_Generic_Instance (E)) + + -- Allow the generation of references to reads, writes and calls + -- in Alfa mode when the related context comes from an instance. + + or else + (Alfa_Mode + and then In_Extended_Main_Code_Unit (N) + and then (Typ = 'm' or else Typ = 'r' or else Typ = 's')) then null; else @@ -884,37 +885,31 @@ package body Lib.Xref is and then Sloc (E) > No_Location and then Sloc (N) > No_Location - -- We ignore references from within an instance, except for default - -- subprograms, for which we generate an implicit reference. + -- Ignore references from within an instance. The only exceptions to + -- this are default subprograms, for which we generate an implicit + -- reference and compilations in Alfa_Mode. and then - (Instantiation_Location (Sloc (N)) = No_Location or else Typ = 'i') + (Instantiation_Location (Sloc (N)) = No_Location + or else Typ = 'i' + or else Alfa_Mode) - -- Ignore dummy references + -- Ignore dummy references and then Typ /= ' ' then - if Nkind (N) = N_Identifier - or else - Nkind (N) = N_Defining_Identifier - or else - Nkind (N) in N_Op - or else - Nkind (N) = N_Defining_Operator_Symbol - or else - Nkind (N) = N_Operator_Symbol - or else - (Nkind (N) = N_Character_Literal - and then Sloc (Entity (N)) /= Standard_Location) - or else - Nkind (N) = N_Defining_Character_Literal + if Nkind_In (N, N_Identifier, + N_Defining_Identifier, + N_Defining_Operator_Symbol, + N_Operator_Symbol, + N_Defining_Character_Literal) + or else Nkind (N) in N_Op + or else (Nkind (N) = N_Character_Literal + and then Sloc (Entity (N)) /= Standard_Location) then Nod := N; - elsif Nkind (N) = N_Expanded_Name - or else - Nkind (N) = N_Selected_Component - then + elsif Nkind_In (N, N_Expanded_Name, N_Selected_Component) then Nod := Selector_Name (N); else @@ -999,18 +994,18 @@ package body Lib.Xref is -- Record reference to entity - Ref := Original_Location (Sloc (Nod)); - Def := Original_Location (Sloc (Ent)); - if Actual_Typ = 'p' - and then Is_Subprogram (N) - and then Present (Overridden_Operation (N)) + and then Is_Subprogram (Nod) + and then Present (Overridden_Operation (Nod)) then Actual_Typ := 'P'; end if; if Alfa_Mode then - Ref_Scope := Alfa.Enclosing_Subprogram_Or_Package (N); + Ref := Sloc (Nod); + Def := Sloc (Ent); + + Ref_Scope := Alfa.Enclosing_Subprogram_Or_Package (Nod); Ent_Scope := Alfa.Enclosing_Subprogram_Or_Package (Ent); -- Since we are reaching through renamings in Alfa mode, we may @@ -1022,22 +1017,39 @@ package body Lib.Xref is return; end if; - Ent_Scope_File := Get_Source_Unit (Ent_Scope); + Add_Entry + ((Ent => Ent, + Loc => Ref, + Typ => Actual_Typ, + Eun => Get_Code_Unit (Def), + Lun => Get_Code_Unit (Ref), + Ref_Scope => Ref_Scope, + Ent_Scope => Ent_Scope), + Ent_Scope_File => Get_Code_Unit (Ent)); + else - Ref_Scope := Empty; - Ent_Scope := Empty; - Ent_Scope_File := No_Unit; - end if; + Ref := Original_Location (Sloc (Nod)); + Def := Original_Location (Sloc (Ent)); - Add_Entry - ((Ent => Ent, - Loc => Ref, - Typ => Actual_Typ, - Eun => Get_Source_Unit (Def), - Lun => Get_Source_Unit (Ref), - Ref_Scope => Ref_Scope, - Ent_Scope => Ent_Scope), - Ent_Scope_File => Ent_Scope_File); + -- If this is an operator symbol, skip the initial + -- quote, for navigation purposes. + + if Nkind (N) = N_Defining_Operator_Symbol + or else Nkind (Nod) = N_Operator_Symbol + then + Ref := Ref + 1; + end if; + + Add_Entry + ((Ent => Ent, + Loc => Ref, + Typ => Actual_Typ, + Eun => Get_Source_Unit (Def), + Lun => Get_Source_Unit (Ref), + Ref_Scope => Empty, + Ent_Scope => Empty), + Ent_Scope_File => No_Unit); + end if; end if; end Generate_Reference; @@ -1715,11 +1727,24 @@ package body Lib.Xref is -- since at the time the reference or definition is made, private -- types may be swapped, and the Sloc value may be incorrect. We -- also set up the pointer vector for the sort. + -- For user-defined operators we need to skip the initial + -- quote and point to the first character of the name, for + -- navigation purposes. for J in 1 .. Nrefs loop - Rnums (J) := J; - Xrefs.Table (J).Def := - Original_Location (Sloc (Xrefs.Table (J).Key.Ent)); + declare + E : constant Entity_Id := Xrefs.Table (J).Key.Ent; + Loc : constant Source_Ptr := Original_Location (Sloc (E)); + + begin + Rnums (J) := J; + + if Nkind (E) = N_Defining_Operator_Symbol then + Xrefs.Table (J).Def := Loc + 1; + else + Xrefs.Table (J).Def := Loc; + end if; + end; end loop; -- Sort the references @@ -2434,6 +2459,8 @@ package body Lib.Xref is end Output_Refs; end Output_References; +-- Start of elaboration for Lib.Xref + begin -- Reset is necessary because Elmt_Ptr does not default to Null_Ptr, -- because it's not an access type. diff --git a/gcc/ada/lib-xref.ads b/gcc/ada/lib-xref.ads index ecac26fabb3..7bdc1582b5e 100644 --- a/gcc/ada/lib-xref.ads +++ b/gcc/ada/lib-xref.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1998-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1998-2012, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -605,10 +605,13 @@ package Lib.Xref is (CU : Node_Id; Process : Node_Processing; Inside_Stubs : Boolean); - -- This procedure is undocumented ??? + -- Call Process on all declarations in compilation unit CU. If + -- Inside_Stubs is True, then the body of stubs is also traversed. + -- Generic declarations are ignored. procedure Traverse_All_Compilation_Units (Process : Node_Processing); - -- Call Process on all declarations through all compilation units + -- Call Process on all declarations through all compilation units. + -- Generic declarations are ignored. procedure Collect_Alfa (Sdep_Table : Unit_Ref_Table; Num_Sdep : Nat); -- Collect Alfa information from library units (for files and scopes) diff --git a/gcc/ada/opt.ads b/gcc/ada/opt.ads index a1dc37cf51c..e59e67eb8e8 100644 --- a/gcc/ada/opt.ads +++ b/gcc/ada/opt.ads @@ -987,6 +987,11 @@ package Opt is -- GNATMAKE -- Set to True when an object directory is specified with option -D + Object_Path_File_Name : String_Ptr := null; + -- GNAT2WHY + -- Path of the temporary file that contains a list of object directories + -- passed by -gnateO=<obj_pat_file>. + One_Compilation_Per_Obj_Dir : Boolean := False; -- GNATMAKE, GPRBUILD -- Set to True with switch --single-compile-per-obj-dir. When True, there diff --git a/gcc/ada/osint.adb b/gcc/ada/osint.adb index 8da01c2468a..9a2e7ee26f3 100644 --- a/gcc/ada/osint.adb +++ b/gcc/ada/osint.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -444,6 +444,15 @@ package body Osint is -- Start of processing for Add_Default_Search_Dirs begin + -- If there was a -gnateO switch, add all object directories from the + -- file given in argument to the library search list. + + if Object_Path_File_Name /= null then + Path_File_Name := String_Access (Object_Path_File_Name); + pragma Assert (Path_File_Name'Length > 0); + Get_Dirs_From_File (Additional_Source_Dir => False); + end if; + -- After the locations specified on the command line, the next places -- to look for files are the directories specified by the appropriate -- environment variable. Get this value, extract the directory names diff --git a/gcc/ada/osint.ads b/gcc/ada/osint.ads index a4fc33412e4..48663f519e8 100644 --- a/gcc/ada/osint.ads +++ b/gcc/ada/osint.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -324,7 +324,8 @@ package Osint is procedure Add_Default_Search_Dirs; -- This routine adds the default search dirs indicated by the environment - -- variables and sdefault package. + -- variables and sdefault package, as well as the library search dirs set + -- by option -gnateO for GNAT2WHY. procedure Add_Lib_Search_Dir (Dir : String); -- Add Dir at the end of the library file search path diff --git a/gcc/ada/prj-attr.adb b/gcc/ada/prj-attr.adb index ba569e119e6..8d3d855e789 100644 --- a/gcc/ada/prj-attr.adb +++ b/gcc/ada/prj-attr.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 2001-2012, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -226,6 +226,7 @@ package body Prj.Attr is "Lainclude_switches#" & "Sainclude_path#" & "Sainclude_path_file#" & + "Laobject_path_switches#" & -- package Builder diff --git a/gcc/ada/prj-nmsc.adb b/gcc/ada/prj-nmsc.adb index 284f9f0b6e5..01b39c69d73 100644 --- a/gcc/ada/prj-nmsc.adb +++ b/gcc/ada/prj-nmsc.adb @@ -1440,6 +1440,12 @@ package body Prj.Nmsc is From_List => Element.Value.Values, In_Tree => Data.Tree); + when Name_Object_Path_Switches => + Put (Into_List => + Lang_Index.Config.Object_Path_Switches, + From_List => Element.Value.Values, + In_Tree => Data.Tree); + -- Attribute Compiler_Pic_Option (<language>) when Name_Pic_Option => diff --git a/gcc/ada/prj.adb b/gcc/ada/prj.adb index c8c5958aad5..9a5e2607aa1 100644 --- a/gcc/ada/prj.adb +++ b/gcc/ada/prj.adb @@ -296,7 +296,7 @@ package body Prj is when Makefile => return Extend_Name (Source_File_Name, Makefile_Dependency_Suffix); - when ALI_File => + when ALI_File | ALI_Closure => return Extend_Name (Source_File_Name, ALI_Dependency_Suffix); end case; end Dependency_Name; diff --git a/gcc/ada/prj.ads b/gcc/ada/prj.ads index 877d1b59b39..a95ac732813 100644 --- a/gcc/ada/prj.ads +++ b/gcc/ada/prj.ads @@ -298,9 +298,26 @@ package Prj is -- Type for the kind of language. All languages are file based, except Ada -- which is unit based. - type Dependency_File_Kind is (None, Makefile, ALI_File); - -- Type of dependency to be checked: no dependency file, Makefile fragment - -- or ALI file (for Ada). + -- Type of dependency to be checked + + type Dependency_File_Kind is + (None, + -- There is no dependency file, the source must always be recompiled + + Makefile, + -- The dependency file is a Makefile fragment indicating all the files + -- the source depends on. If the object file or the dependency file is + -- more recent than any of these files, the source must be recompiled. + + ALI_File, + -- The dependency file is an ALI file and the source must be recompiled + -- if the object or ALI file is more recent than any of the sources + -- listed in the D lines. + + ALI_Closure); + -- The dependency file is an ALI file and the source must be recompiled + -- if the object or ALI file is more recent than any source in the full + -- closure. Makefile_Dependency_Suffix : constant String := ".d"; ALI_Dependency_Suffix : constant String := ".ali"; @@ -472,6 +489,11 @@ package Prj is -- are used to specify the object file. The object file name is appended -- to the last switch in the list. Example: ("-o", ""). + Object_Path_Switches : Name_List_Index := No_Name_List; + -- List of switches to specify to the compiler the path name of a + -- temporary file containing the list of object directories in the + -- correct order. + Compilation_PIC_Option : Name_List_Index := No_Name_List; -- The option(s) to compile a source in Position Independent Code for -- shared libraries. Specified in the configuration. When not specified, @@ -602,6 +624,7 @@ package Prj is Source_File_Switches => No_Name_List, Object_File_Suffix => No_Name, Object_File_Switches => No_Name_List, + Object_Path_Switches => No_Name_List, Compilation_PIC_Option => No_Name_List, Object_Generated => True, Objects_Linked => True, @@ -1233,6 +1256,10 @@ package Prj is -- The path name of the exec directory of this project file. Default is -- equal to Object_Directory. + Object_Path_File : Path_Name_Type := No_Path; + -- Store the name of the temporary file that contains the list of object + -- directories, when attribute Object_Path_Switches is declared. + ------------- -- Library -- ------------- diff --git a/gcc/ada/rtsfind.ads b/gcc/ada/rtsfind.ads index 88e61dc893c..e02f575d7d5 100644 --- a/gcc/ada/rtsfind.ads +++ b/gcc/ada/rtsfind.ads @@ -211,6 +211,7 @@ package Rtsfind is System_Arith_64, System_AST_Handling, System_Assertions, + System_Atomic_Primitives, System_Aux_DEC, System_Bit_Ops, System_Boolean_Array_Operations, @@ -730,6 +731,19 @@ package Rtsfind is RE_Assert_Failure, -- System.Assertions RE_Raise_Assert_Failure, -- System.Assertions + RE_Atomic_Compare_Exchange_8, -- System.Atomic_Primitives + RE_Atomic_Compare_Exchange_16, -- System.Atomic_Primitives + RE_Atomic_Compare_Exchange_32, -- System.Atomic_Primitives + RE_Atomic_Compare_Exchange_64, -- System.Atomic_Primitives + RE_Atomic_Load_8, -- System.Atomic_Primitives + RE_Atomic_Load_16, -- System.Atomic_Primitives + RE_Atomic_Load_32, -- System.Atomic_Primitives + RE_Atomic_Load_64, -- System.Atomic_Primitives + RE_Uint8, -- System.Atomic_Primitives + RE_Uint16, -- System.Atomic_Primitives + RE_Uint32, -- System.Atomic_Primitives + RE_Uint64, -- System.Atomic_Primitives + RE_AST_Handler, -- System.Aux_DEC RE_Import_Value, -- System.Aux_DEC RE_No_AST_Handler, -- System.Aux_DEC @@ -1938,6 +1952,19 @@ package Rtsfind is RE_Assert_Failure => System_Assertions, RE_Raise_Assert_Failure => System_Assertions, + RE_Atomic_Compare_Exchange_8 => System_Atomic_Primitives, + RE_Atomic_Compare_Exchange_16 => System_Atomic_Primitives, + RE_Atomic_Compare_Exchange_32 => System_Atomic_Primitives, + RE_Atomic_Compare_Exchange_64 => System_Atomic_Primitives, + RE_Atomic_Load_8 => System_Atomic_Primitives, + RE_Atomic_Load_16 => System_Atomic_Primitives, + RE_Atomic_Load_32 => System_Atomic_Primitives, + RE_Atomic_Load_64 => System_Atomic_Primitives, + RE_Uint8 => System_Atomic_Primitives, + RE_Uint16 => System_Atomic_Primitives, + RE_Uint32 => System_Atomic_Primitives, + RE_Uint64 => System_Atomic_Primitives, + RE_AST_Handler => System_Aux_DEC, RE_Import_Value => System_Aux_DEC, RE_No_AST_Handler => System_Aux_DEC, diff --git a/gcc/ada/s-atopri.ads b/gcc/ada/s-atopri.ads new file mode 100644 index 00000000000..c8c75f2ff72 --- /dev/null +++ b/gcc/ada/s-atopri.ads @@ -0,0 +1,122 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . A T O M I C _ P R I M I T I V E S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2012, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- ??? Need header saying what this unit is!!! + +package System.Atomic_Primitives is + pragma Preelaborate; + + type uint8 is mod 2**8 + with Size => 8; + + type uint16 is mod 2**16 + with Size => 16; + + type uint32 is mod 2**32 + with Size => 32; + + type uint64 is mod 2**64 + with Size => 64; + + Relaxed : constant := 0; + Consume : constant := 1; + Acquire : constant := 2; + Release : constant := 3; + Acq_Rel : constant := 4; + Seq_Cst : constant := 5; + Last : constant := 6; + + subtype Mem_Model is Integer range Relaxed .. Last; + + function Atomic_Compare_Exchange_8 + (X : Address; + X_Old : uint8; + X_Copy : uint8) return Boolean; + pragma Import (Intrinsic, + Atomic_Compare_Exchange_8, + "__sync_bool_compare_and_swap_1"); + + -- ??? Should use __atomic_compare_exchange_1 (doesn't work yet): + -- function Atomic_Compare_Exchange_8 + -- (X : Address; + -- X_Old : Address; + -- X_Copy : uint8; + -- Success_Model : Mem_Model := Seq_Cst; + -- Failure_Model : Mem_Model := Seq_Cst) return Boolean; + -- pragma Import (Intrinsic, + -- Atomic_Compare_Exchange_8, + -- "__atomic_compare_exchange_1"); + + function Atomic_Compare_Exchange_16 + (X : Address; + X_Old : uint16; + X_Copy : uint16) return Boolean; + pragma Import (Intrinsic, + Atomic_Compare_Exchange_16, + "__sync_bool_compare_and_swap_2"); + + function Atomic_Compare_Exchange_32 + (X : Address; + X_Old : uint32; + X_Copy : uint32) return Boolean; + pragma Import (Intrinsic, + Atomic_Compare_Exchange_32, + "__sync_bool_compare_and_swap_4"); + + function Atomic_Compare_Exchange_64 + (X : Address; + X_Old : uint64; + X_Copy : uint64) return Boolean; + pragma Import (Intrinsic, + Atomic_Compare_Exchange_64, + "__sync_bool_compare_and_swap_8"); + + function Atomic_Load_8 + (X : Address; + Model : Mem_Model := Seq_Cst) return uint8; + pragma Import (Intrinsic, Atomic_Load_8, "__atomic_load_1"); + + function Atomic_Load_16 + (X : Address; + Model : Mem_Model := Seq_Cst) return uint16; + pragma Import (Intrinsic, Atomic_Load_16, "__atomic_load_2"); + + function Atomic_Load_32 + (X : Address; + Model : Mem_Model := Seq_Cst) return uint32; + pragma Import (Intrinsic, Atomic_Load_32, "__atomic_load_4"); + + function Atomic_Load_64 + (X : Address; + Model : Mem_Model := Seq_Cst) return uint64; + pragma Import (Intrinsic, Atomic_Load_64, "__atomic_load_8"); + +end System.Atomic_Primitives; diff --git a/gcc/ada/sem.adb b/gcc/ada/sem.adb index 2e50d3dc73b..503d1f40d43 100644 --- a/gcc/ada/sem.adb +++ b/gcc/ada/sem.adb @@ -314,6 +314,9 @@ package body Sem is when N_Label => Analyze_Label (N); + when N_Loop_Parameter_Specification => + Analyze_Loop_Parameter_Specification (N); + when N_Loop_Statement => Analyze_Loop_Statement (N); @@ -681,7 +684,6 @@ package body Sem is N_Generic_Association | N_Index_Or_Discriminant_Constraint | N_Iteration_Scheme | - N_Loop_Parameter_Specification | N_Mod_Clause | N_Modular_Type_Definition | N_Ordinary_Fixed_Point_Definition | diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index 77db15ed21e..10af9e2d054 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -323,7 +323,7 @@ package body Sem_Attr is -- type or a private type for which no full view has been given. procedure Check_Object_Reference (P : Node_Id); - -- Check that P (the prefix of the attribute) is an object reference + -- Check that P is an object reference procedure Check_Program_Unit; -- Verify that prefix of attribute N is a program unit @@ -5202,8 +5202,13 @@ package body Sem_Attr is when Attribute_Valid_Scalars => Check_E0; - Check_Type; - -- More stuff TBD ??? + Check_Object_Reference (P); + + if No_Scalar_Parts (P_Type) then + Error_Attr_P ("?attribute % always True, no scalars to check"); + end if; + + Set_Etype (N, Standard_Boolean); ----------- -- Value -- diff --git a/gcc/ada/sem_attr.ads b/gcc/ada/sem_attr.ads index 71ac668c757..7258593aabf 100644 --- a/gcc/ada/sem_attr.ads +++ b/gcc/ada/sem_attr.ads @@ -554,12 +554,33 @@ package Sem_Attr is ------------------- Attribute_Valid_Scalars => True, - -- Obj'Valid_Scalars applies to objects of scalar types, on which it is - -- equivalent to Obj'Valid, and objects of array and record types, on - -- which it amounts to applying 'Valid to each subcomponent of Obj. It - -- does not apply to prefixes of classwide type, or of a formal generic - -- type that has an unknown discriminant (which could be instantiated - -- with a classwide type). + -- Obj'Valid_Scalars can be applied to any object. The result depends + -- on the type of the object: + -- + -- For a scalar type, the result is the same as obj'Valid + -- + -- For an array object, the result is True if the result of applying + -- Valid_Scalars to every component is True. For an empty array the + -- result is True. + -- + -- For a record object, the result is True if the result of applying + -- Valid_Scalars to every component is True. For class-wide types, + -- only the components of the base type are checked. For variant + -- records, only the components actually present are checked. The + -- discriminants, if any, are also checked. If there are no components + -- or discriminants, the result is True. + -- + -- For any other type that has discriminants, the result is True if + -- the result of applying Valid_Scalars to each discriminant is True. + -- + -- For all other types, the result is always True + -- + -- A warning is given for a trivially True result, when the attribute + -- is applied to an object that is not of scalar, array, or record + -- type, or in the composite case if no scalar subcomponents exist. For + -- a variant record, the warning is given only if none of the variants + -- have scalar subcomponents. In addition, the warning is suppressed + -- for private types, or generic formal types in an instance. ---------------- -- Value_Size -- diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index 054772964ef..d0525633681 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -3704,7 +3704,6 @@ package body Sem_Ch12 is or else Might_Inline_Subp) and then not Is_Actual_Pack and then not Inline_Now - and then not Alfa_Mode and then (Operating_Mode = Generate_Code or else (Operating_Mode = Check_Semantics and then ASIS_Mode)); @@ -4405,9 +4404,6 @@ package body Sem_Ch12 is Parent_Installed : Boolean := False; Renaming_List : List_Id; - Save_Style_Check : constant Boolean := Style_Check; - -- Save style check mode for restore on exit - procedure Analyze_Instance_And_Renamings; -- The instance must be analyzed in a context that includes the mappings -- of generic parameters into actuals. We create a package declaration @@ -4588,11 +4584,13 @@ package body Sem_Ch12 is Instantiation_Node := N; - -- Turn off style checking in instances. If the check is enabled on the - -- generic unit, a warning in an instance would just be noise. If not - -- enabled on the generic, then a warning in an instance is just wrong. + -- For package instantiations we turn off style checks, because they + -- will have been emitted in the generic. For subprogram instantiations + -- we want to apply at least the check on overriding indicators so we + -- do not modify the style check status. - Style_Check := False; + -- The renaming declarations for the actuals do not come from source and + -- will not generate spurious warnings. Preanalyze_Actuals (N); @@ -4860,8 +4858,6 @@ package body Sem_Ch12 is Generic_Renamings_HTable.Reset; end if; - Style_Check := Save_Style_Check; - <<Leave>> if Has_Aspects (N) then Analyze_Aspect_Specifications (N, Act_Decl_Id); @@ -4876,8 +4872,6 @@ package body Sem_Ch12 is if Env_Installed then Restore_Env; end if; - - Style_Check := Save_Style_Check; end Analyze_Subprogram_Instantiation; ------------------------- @@ -7767,6 +7761,9 @@ package body Sem_Ch12 is Item : Node_Id; New_I : Node_Id; + Clause : Node_Id; + OK : Boolean; + begin if Nkind (Parent (Gen_Decl)) = N_Compilation_Unit then @@ -7788,17 +7785,30 @@ package body Sem_Ch12 is while Present (Item) loop if Nkind (Item) = N_With_Clause then - -- Take care to prevent direct cyclic with's, which can happen - -- if the generic body with's the current unit. Such a case - -- would result in binder errors (or run-time errors if the - -- -gnatE switch is in effect), but we want to prevent it here, - -- because Sem.Walk_Library_Items doesn't like cycles. Note - -- that we don't bother to detect indirect cycles. + -- Take care to prevent direct cyclic with's. if Library_Unit (Item) /= Current_Unit then - New_I := New_Copy (Item); - Set_Implicit_With (New_I, True); - Append (New_I, Current_Context); + -- Do not add a unit if it is already in the context + + Clause := First (Current_Context); + OK := True; + while Present (Clause) loop + if Nkind (Clause) = N_With_Clause and then + Chars (Name (Clause)) = Chars (Name (Item)) + then + OK := False; + exit; + end if; + + Next (Clause); + end loop; + + if OK then + New_I := New_Copy (Item); + Set_Implicit_With (New_I, True); + Set_Implicit_With_From_Instantiation (New_I, True); + Append (New_I, Current_Context); + end if; end if; end if; diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index d56da36f3fa..55238e2ca11 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -47,7 +47,6 @@ with Sem_Aux; use Sem_Aux; with Sem_Case; use Sem_Case; with Sem_Cat; use Sem_Cat; with Sem_Ch3; use Sem_Ch3; -with Sem_Ch5; use Sem_Ch5; with Sem_Ch6; use Sem_Ch6; with Sem_Ch8; use Sem_Ch8; with Sem_Dim; use Sem_Dim; @@ -3403,101 +3402,38 @@ package body Sem_Ch4 is ----------------------------------- procedure Analyze_Quantified_Expression (N : Node_Id) is - Loc : constant Source_Ptr := Sloc (N); - Ent : constant Entity_Id := - New_Internal_Entity (E_Loop, Current_Scope, Sloc (N), 'L'); - - Need_Preanalysis : constant Boolean := - Operating_Mode /= Check_Semantics - and then not Alfa_Mode; - - Iterator : Node_Id; - Original_N : Node_Id; + QE_Scop : Entity_Id; begin - -- The approach in this procedure is very non-standard and at the - -- very least, extensive comments are required saying why this very - -- non-standard approach is needed??? - - -- Also general comments are needed in any case saying what is going - -- on here, since tree rewriting of this kind should normally be done - -- by the expander and not by the analyzer ??? Probably Ent, Iterator, - -- and Original_N, and Needs_Preanalysis, all need comments above ??? - - -- Preserve the original node used for the expansion of the quantified - -- expression. - - -- This is a very unusual use of Copy_Separate_Tree, needs looking at??? - - if Need_Preanalysis then - Original_N := Copy_Separate_Tree (N); - end if; - - Set_Etype (Ent, Standard_Void_Type); - Set_Scope (Ent, Current_Scope); - Set_Parent (Ent, N); - Check_SPARK_Restriction ("quantified expression is not allowed", N); - -- The following seems like expansion activity done at analysis - -- time, which seems weird ??? + -- Create a scope to emulate the loop-like behavior of the quantified + -- expression. The scope is needed to provide proper visibility of the + -- loop variable. - if Present (Loop_Parameter_Specification (N)) then - Iterator := - Make_Iteration_Scheme (Loc, - Loop_Parameter_Specification => - Loop_Parameter_Specification (N)); - else - Iterator := - Make_Iteration_Scheme (Loc, - Iterator_Specification => - Iterator_Specification (N)); - end if; + QE_Scop := New_Internal_Entity (E_Loop, Current_Scope, Sloc (N), 'L'); + Set_Etype (QE_Scop, Standard_Void_Type); + Set_Scope (QE_Scop, Current_Scope); + Set_Parent (QE_Scop, N); - Push_Scope (Ent); - Set_Parent (Iterator, N); - Analyze_Iteration_Scheme (Iterator); + Push_Scope (QE_Scop); - -- The loop specification may have been converted into an iterator - -- specification during its analysis. Update the quantified node - -- accordingly. + -- All constituents are preanalyzed and resolved to avoid untimely + -- generation of various temporaries and types. Full analysis and + -- expansion is carried out when the quantified expression is + -- transformed into an expression with actions. - if Present (Iterator_Specification (Iterator)) then - Set_Iterator_Specification - (N, Iterator_Specification (Iterator)); - Set_Loop_Parameter_Specification (N, Empty); - Set_Parent (Iterator_Specification (Iterator), Iterator); - end if; - - if Need_Preanalysis then - - -- The full analysis will be performed during the expansion of the - -- quantified expression, only a preanalysis of the condition needs - -- to be done. - - -- This is strange for two reasons - - -- First, there is almost no situation in which Preanalyze vs - -- Analyze should be conditioned on -gnatc mode (since error msgs - -- must be 100% unaffected by -gnatc). Seconed doing a Preanalyze - -- with no resolution almost certainly means that some messages are - -- either missed, or flagged differently in the two cases. - - Preanalyze (Condition (N)); + if Present (Iterator_Specification (N)) then + Preanalyze (Iterator_Specification (N)); else - Analyze (Condition (N)); + Preanalyze (Loop_Parameter_Specification (N)); end if; + Preanalyze_And_Resolve (Condition (N), Standard_Boolean); + End_Scope; Set_Etype (N, Standard_Boolean); - - -- Attach the original node to the iteration scheme created above - - if Need_Preanalysis then - Set_Etype (Original_N, Standard_Boolean); - Set_Parent (Iterator, Original_N); - end if; end Analyze_Quantified_Expression; ------------------- diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index 834d2f1b143..6feb84cdefa 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -76,7 +76,7 @@ package body Sem_Ch5 is -- messages. This variable is recursively saved on entry to processing the -- construct, and restored on exit. - procedure Pre_Analyze_Range (R_Copy : Node_Id); + procedure Preanalyze_Range (R_Copy : Node_Id); -- Determine expected type of range or domain of iteration of Ada 2012 -- loop by analyzing separate copy. Do the analysis and resolution of the -- copy of the bound(s) with expansion disabled, to prevent the generation @@ -1607,615 +1607,32 @@ package body Sem_Ch5 is ------------------------------ procedure Analyze_Iteration_Scheme (N : Node_Id) is - - procedure Process_Bounds (R : Node_Id); - -- If the iteration is given by a range, create temporaries and - -- assignment statements block to capture the bounds and perform - -- required finalization actions in case a bound includes a function - -- call that uses the temporary stack. We first pre-analyze a copy of - -- the range in order to determine the expected type, and analyze and - -- resolve the original bounds. - - procedure Check_Controlled_Array_Attribute (DS : Node_Id); - -- If the bounds are given by a 'Range reference on a function call - -- that returns a controlled array, introduce an explicit declaration - -- to capture the bounds, so that the function result can be finalized - -- in timely fashion. - - function Has_Call_Using_Secondary_Stack (N : Node_Id) return Boolean; - -- N is the node for an arbitrary construct. This function searches the - -- construct N to see if any expressions within it contain function - -- calls that use the secondary stack, returning True if any such call - -- is found, and False otherwise. - - -------------------- - -- Process_Bounds -- - -------------------- - - procedure Process_Bounds (R : Node_Id) is - Loc : constant Source_Ptr := Sloc (N); - R_Copy : constant Node_Id := New_Copy_Tree (R); - Lo : constant Node_Id := Low_Bound (R); - Hi : constant Node_Id := High_Bound (R); - New_Lo_Bound : Node_Id; - New_Hi_Bound : Node_Id; - Typ : Entity_Id; - - function One_Bound - (Original_Bound : Node_Id; - Analyzed_Bound : Node_Id) return Node_Id; - -- Capture value of bound and return captured value - - --------------- - -- One_Bound -- - --------------- - - function One_Bound - (Original_Bound : Node_Id; - Analyzed_Bound : Node_Id) return Node_Id - is - Assign : Node_Id; - Decl : Node_Id; - Id : Entity_Id; - - begin - -- If the bound is a constant or an object, no need for a separate - -- declaration. If the bound is the result of previous expansion - -- it is already analyzed and should not be modified. Note that - -- the Bound will be resolved later, if needed, as part of the - -- call to Make_Index (literal bounds may need to be resolved to - -- type Integer). - - if Analyzed (Original_Bound) then - return Original_Bound; - - elsif Nkind_In (Analyzed_Bound, N_Integer_Literal, - N_Character_Literal) - or else Is_Entity_Name (Analyzed_Bound) - then - Analyze_And_Resolve (Original_Bound, Typ); - return Original_Bound; - end if; - - -- Normally, the best approach is simply to generate a constant - -- declaration that captures the bound. However, there is a nasty - -- case where this is wrong. If the bound is complex, and has a - -- possible use of the secondary stack, we need to generate a - -- separate assignment statement to ensure the creation of a block - -- which will release the secondary stack. - - -- We prefer the constant declaration, since it leaves us with a - -- proper trace of the value, useful in optimizations that get rid - -- of junk range checks. - - if not Has_Call_Using_Secondary_Stack (Analyzed_Bound) then - Analyze_And_Resolve (Original_Bound, Typ); - Force_Evaluation (Original_Bound); - return Original_Bound; - end if; - - Id := Make_Temporary (Loc, 'R', Original_Bound); - - -- Here we make a declaration with a separate assignment - -- statement, and insert before loop header. - - Decl := - Make_Object_Declaration (Loc, - Defining_Identifier => Id, - Object_Definition => New_Occurrence_Of (Typ, Loc)); - - Assign := - Make_Assignment_Statement (Loc, - Name => New_Occurrence_Of (Id, Loc), - Expression => Relocate_Node (Original_Bound)); - - Insert_Actions (Parent (N), New_List (Decl, Assign)); - - -- Now that this temporary variable is initialized we decorate it - -- as safe-to-reevaluate to inform to the backend that no further - -- asignment will be issued and hence it can be handled as side - -- effect free. Note that this decoration must be done when the - -- assignment has been analyzed because otherwise it will be - -- rejected (see Analyze_Assignment). - - Set_Is_Safe_To_Reevaluate (Id); - - Rewrite (Original_Bound, New_Occurrence_Of (Id, Loc)); - - if Nkind (Assign) = N_Assignment_Statement then - return Expression (Assign); - else - return Original_Bound; - end if; - end One_Bound; - - -- Start of processing for Process_Bounds - - begin - Set_Parent (R_Copy, Parent (R)); - Pre_Analyze_Range (R_Copy); - Typ := Etype (R_Copy); - - -- If the type of the discrete range is Universal_Integer, then the - -- bound's type must be resolved to Integer, and any object used to - -- hold the bound must also have type Integer, unless the literal - -- bounds are constant-folded expressions with a user-defined type. - - if Typ = Universal_Integer then - if Nkind (Lo) = N_Integer_Literal - and then Present (Etype (Lo)) - and then Scope (Etype (Lo)) /= Standard_Standard - then - Typ := Etype (Lo); - - elsif Nkind (Hi) = N_Integer_Literal - and then Present (Etype (Hi)) - and then Scope (Etype (Hi)) /= Standard_Standard - then - Typ := Etype (Hi); - - else - Typ := Standard_Integer; - end if; - end if; - - Set_Etype (R, Typ); - - New_Lo_Bound := One_Bound (Lo, Low_Bound (R_Copy)); - New_Hi_Bound := One_Bound (Hi, High_Bound (R_Copy)); - - -- Propagate staticness to loop range itself, in case the - -- corresponding subtype is static. - - if New_Lo_Bound /= Lo - and then Is_Static_Expression (New_Lo_Bound) - then - Rewrite (Low_Bound (R), New_Copy (New_Lo_Bound)); - end if; - - if New_Hi_Bound /= Hi - and then Is_Static_Expression (New_Hi_Bound) - then - Rewrite (High_Bound (R), New_Copy (New_Hi_Bound)); - end if; - end Process_Bounds; - - -------------------------------------- - -- Check_Controlled_Array_Attribute -- - -------------------------------------- - - procedure Check_Controlled_Array_Attribute (DS : Node_Id) is - begin - if Nkind (DS) = N_Attribute_Reference - and then Is_Entity_Name (Prefix (DS)) - and then Ekind (Entity (Prefix (DS))) = E_Function - and then Is_Array_Type (Etype (Entity (Prefix (DS)))) - and then - Is_Controlled ( - Component_Type (Etype (Entity (Prefix (DS))))) - and then Expander_Active - then - declare - Loc : constant Source_Ptr := Sloc (N); - Arr : constant Entity_Id := Etype (Entity (Prefix (DS))); - Indx : constant Entity_Id := - Base_Type (Etype (First_Index (Arr))); - Subt : constant Entity_Id := Make_Temporary (Loc, 'S'); - Decl : Node_Id; - - begin - Decl := - Make_Subtype_Declaration (Loc, - Defining_Identifier => Subt, - Subtype_Indication => - Make_Subtype_Indication (Loc, - Subtype_Mark => New_Reference_To (Indx, Loc), - Constraint => - Make_Range_Constraint (Loc, - Relocate_Node (DS)))); - Insert_Before (Parent (N), Decl); - Analyze (Decl); - - Rewrite (DS, - Make_Attribute_Reference (Loc, - Prefix => New_Reference_To (Subt, Loc), - Attribute_Name => Attribute_Name (DS))); - Analyze (DS); - end; - end if; - end Check_Controlled_Array_Attribute; - - ------------------------------------ - -- Has_Call_Using_Secondary_Stack -- - ------------------------------------ - - function Has_Call_Using_Secondary_Stack (N : Node_Id) return Boolean is - - function Check_Call (N : Node_Id) return Traverse_Result; - -- Check if N is a function call which uses the secondary stack - - ---------------- - -- Check_Call -- - ---------------- - - function Check_Call (N : Node_Id) return Traverse_Result is - Nam : Node_Id; - Subp : Entity_Id; - Return_Typ : Entity_Id; - - begin - if Nkind (N) = N_Function_Call then - Nam := Name (N); - - -- Call using access to subprogram with explicit dereference - - if Nkind (Nam) = N_Explicit_Dereference then - Subp := Etype (Nam); - - -- Call using a selected component notation or Ada 2005 object - -- operation notation - - elsif Nkind (Nam) = N_Selected_Component then - Subp := Entity (Selector_Name (Nam)); - - -- Common case - - else - Subp := Entity (Nam); - end if; - - Return_Typ := Etype (Subp); - - if Is_Composite_Type (Return_Typ) - and then not Is_Constrained (Return_Typ) - then - return Abandon; - - elsif Sec_Stack_Needed_For_Return (Subp) then - return Abandon; - end if; - end if; - - -- Continue traversing the tree - - return OK; - end Check_Call; - - function Check_Calls is new Traverse_Func (Check_Call); - - -- Start of processing for Has_Call_Using_Secondary_Stack - - begin - return Check_Calls (N) = Abandon; - end Has_Call_Using_Secondary_Stack; - - -- Start of processing for Analyze_Iteration_Scheme + Cond : Node_Id; + Iter_Spec : Node_Id; + Loop_Spec : Node_Id; begin - -- If this is a rewritten quantified expression, the iteration scheme - -- has been analyzed already. Do no repeat analysis because the loop - -- variable is already declared. - - if Analyzed (N) then - return; - end if; - -- For an infinite loop, there is no iteration scheme if No (N) then return; end if; - -- Iteration scheme is present + Cond := Condition (N); + Iter_Spec := Iterator_Specification (N); + Loop_Spec := Loop_Parameter_Specification (N); - declare - Cond : constant Node_Id := Condition (N); - - begin - -- For WHILE loop, verify that the condition is a Boolean expression - -- and resolve and check it. - - if Present (Cond) then - Analyze_And_Resolve (Cond, Any_Boolean); - Check_Unset_Reference (Cond); - Set_Current_Value_Condition (N); - return; - - -- For an iterator specification with "of", pre-analyze range to - -- capture function calls that may require finalization actions. - - elsif Present (Iterator_Specification (N)) then - Pre_Analyze_Range (Name (Iterator_Specification (N))); - Analyze_Iterator_Specification (Iterator_Specification (N)); - - -- Else we have a FOR loop - - else - declare - LP : constant Node_Id := Loop_Parameter_Specification (N); - Id : constant Entity_Id := Defining_Identifier (LP); - DS : constant Node_Id := Discrete_Subtype_Definition (LP); - - D_Copy : Node_Id; - - begin - Enter_Name (Id); - - -- We always consider the loop variable to be referenced, since - -- the loop may be used just for counting purposes. - - Generate_Reference (Id, N, ' '); - - -- Check for the case of loop variable hiding a local variable - -- (used later on to give a nice warning if the hidden variable - -- is never assigned). - - declare - H : constant Entity_Id := Homonym (Id); - begin - if Present (H) - and then Enclosing_Dynamic_Scope (H) = - Enclosing_Dynamic_Scope (Id) - and then Ekind (H) = E_Variable - and then Is_Discrete_Type (Etype (H)) - then - Set_Hiding_Loop_Variable (H, Id); - end if; - end; - - -- Loop parameter specification must include subtype mark in - -- SPARK. - - if Nkind (DS) = N_Range then - Check_SPARK_Restriction - ("loop parameter specification must include subtype mark", - N); - end if; - - -- Now analyze the subtype definition. If it is a range, create - -- temporaries for bounds. - - if Nkind (DS) = N_Range - and then Expander_Active - then - Process_Bounds (DS); - - -- Expander not active or else range of iteration is a subtype - -- indication, an entity, or a function call that yields an - -- aggregate or a container. - - else - D_Copy := New_Copy_Tree (DS); - Set_Parent (D_Copy, Parent (DS)); - Pre_Analyze_Range (D_Copy); - - -- Ada 2012: If the domain of iteration is a function call, - -- it is the new iterator form. - - -- We have also implemented the shorter form : for X in S - -- for Alfa use. In this case, 'Old and 'Result must be - -- treated as entity names over which iterators are legal. - - if Nkind (D_Copy) = N_Function_Call - or else - (Alfa_Mode - and then (Nkind (D_Copy) = N_Attribute_Reference - and then - (Attribute_Name (D_Copy) = Name_Result - or else Attribute_Name (D_Copy) = Name_Old))) - or else - (Is_Entity_Name (D_Copy) - and then not Is_Type (Entity (D_Copy))) - then - -- This is an iterator specification. Rewrite as such - -- and analyze, to capture function calls that may - -- require finalization actions. - - declare - I_Spec : constant Node_Id := - Make_Iterator_Specification (Sloc (LP), - Defining_Identifier => - Relocate_Node (Id), - Name => D_Copy, - Subtype_Indication => Empty, - Reverse_Present => - Reverse_Present (LP)); - begin - Set_Iterator_Specification (N, I_Spec); - Set_Loop_Parameter_Specification (N, Empty); - Analyze_Iterator_Specification (I_Spec); - - -- In a generic context, analyze the original domain - -- of iteration, for name capture. - - if not Expander_Active then - Analyze (DS); - end if; - - -- Set kind of loop parameter, which may be used in - -- the subsequent analysis of the condition in a - -- quantified expression. - - Set_Ekind (Id, E_Loop_Parameter); - return; - end; - - -- Domain of iteration is not a function call, and is - -- side-effect free. - - else - Analyze (DS); - end if; - end if; - - if DS = Error then - return; - end if; - - -- Some additional checks if we are iterating through a type - - if Is_Entity_Name (DS) - and then Present (Entity (DS)) - and then Is_Type (Entity (DS)) - then - -- The subtype indication may denote the completion of an - -- incomplete type declaration. - - if Ekind (Entity (DS)) = E_Incomplete_Type then - Set_Entity (DS, Get_Full_View (Entity (DS))); - Set_Etype (DS, Entity (DS)); - end if; - - -- Attempt to iterate through non-static predicate - - if Is_Discrete_Type (Entity (DS)) - and then Present (Predicate_Function (Entity (DS))) - and then No (Static_Predicate (Entity (DS))) - then - Bad_Predicated_Subtype_Use - ("cannot use subtype& with non-static " - & "predicate for loop iteration", DS, Entity (DS)); - end if; - end if; - - -- Error if not discrete type - - if not Is_Discrete_Type (Etype (DS)) then - Wrong_Type (DS, Any_Discrete); - Set_Etype (DS, Any_Type); - end if; - - Check_Controlled_Array_Attribute (DS); - - -- The index is not processed during analysis of a quantified - -- expression but delayed to its expansion where the quantified - -- expression is transformed into an expression with actions. - - if Nkind (Parent (N)) /= N_Quantified_Expression - or else Operating_Mode = Check_Semantics - or else Alfa_Mode - then - Make_Index (DS, LP, In_Iter_Schm => True); - end if; - - Set_Ekind (Id, E_Loop_Parameter); - - -- If the loop is part of a predicate or precondition, it may - -- be analyzed twice, once in the source and once on the copy - -- used to check conformance. Preserve the original itype - -- because the second one may be created in a different scope, - -- e.g. a precondition procedure, leading to a crash in GIGI. - - if No (Etype (Id)) or else Etype (Id) = Any_Type then - Set_Etype (Id, Etype (DS)); - end if; - - -- Treat a range as an implicit reference to the type, to - -- inhibit spurious warnings. - - Generate_Reference (Base_Type (Etype (DS)), N, ' '); - Set_Is_Known_Valid (Id, True); - - -- The loop is not a declarative part, so the only entity - -- declared "within" must be frozen explicitly. - - declare - Flist : constant List_Id := Freeze_Entity (Id, N); - begin - if Is_Non_Empty_List (Flist) then - Insert_Actions (N, Flist); - end if; - end; - - -- Check for null or possibly null range and issue warning. We - -- suppress such messages in generic templates and instances, - -- because in practice they tend to be dubious in these cases. - - if Nkind (DS) = N_Range and then Comes_From_Source (N) then - declare - L : constant Node_Id := Low_Bound (DS); - H : constant Node_Id := High_Bound (DS); - - begin - -- If range of loop is null, issue warning - - if Compile_Time_Compare - (L, H, Assume_Valid => True) = GT - then - -- Suppress the warning if inside a generic template - -- or instance, since in practice they tend to be - -- dubious in these cases since they can result from - -- intended parametrization. - - if not Inside_A_Generic - and then not In_Instance - then - -- Specialize msg if invalid values could make the - -- loop non-null after all. - - if Compile_Time_Compare - (L, H, Assume_Valid => False) = GT - then - Error_Msg_N - ("?loop range is null, loop will not execute", - DS); - - -- Since we know the range of the loop is null, - -- set the appropriate flag to remove the loop - -- entirely during expansion. - - Set_Is_Null_Loop (Parent (N)); - - -- Here is where the loop could execute because - -- of invalid values, so issue appropriate - -- message and in this case we do not set the - -- Is_Null_Loop flag since the loop may execute. - - else - Error_Msg_N - ("?loop range may be null, " - & "loop may not execute", - DS); - Error_Msg_N - ("?can only execute if invalid values " - & "are present", - DS); - end if; - end if; - - -- In either case, suppress warnings in the body of - -- the loop, since it is likely that these warnings - -- will be inappropriate if the loop never actually - -- executes, which is likely. - - Set_Suppress_Loop_Warnings (Parent (N)); - - -- The other case for a warning is a reverse loop - -- where the upper bound is the integer literal zero - -- or one, and the lower bound can be positive. - - -- For example, we have - - -- for J in reverse N .. 1 loop + if Present (Cond) then + Analyze_And_Resolve (Cond, Any_Boolean); + Check_Unset_Reference (Cond); + Set_Current_Value_Condition (N); - -- In practice, this is very likely to be a case of - -- reversing the bounds incorrectly in the range. + elsif Present (Iter_Spec) then + Analyze_Iterator_Specification (Iter_Spec); - elsif Reverse_Present (LP) - and then Nkind (Original_Node (H)) = - N_Integer_Literal - and then (Intval (Original_Node (H)) = Uint_0 - or else - Intval (Original_Node (H)) = Uint_1) - then - Error_Msg_N ("?loop range may be null", DS); - Error_Msg_N ("\?bounds may be wrong way round", DS); - end if; - end; - end if; - end; - end if; - end; + else + Analyze_Loop_Parameter_Specification (Loop_Spec); + end if; end Analyze_Iteration_Scheme; ------------------------------------ @@ -2233,22 +1650,25 @@ package body Sem_Ch5 is begin Enter_Name (Def_Id); - Set_Ekind (Def_Id, E_Variable); if Present (Subt) then Analyze (Subt); end if; - -- If domain of iteration is an expression, create a declaration for + Preanalyze_Range (Iter_Name); + + -- If the domain of iteration is an expression, create a declaration for -- it, so that finalization actions are introduced outside of the loop. -- The declaration must be a renaming because the body of the loop may - -- assign to elements. In case of a quantified expression, this - -- declaration is delayed to its expansion where the node is rewritten - -- as an expression with actions. + -- assign to elements. When the context is a quantified expression, the + -- renaming declaration is delayed until the expansion phase. if not Is_Entity_Name (Iter_Name) - and then (Nkind (Parent (Parent (N))) /= N_Quantified_Expression + and then (Nkind (Parent (N)) /= N_Quantified_Expression + + -- The following two tests need comments ??? + or else Operating_Mode = Check_Semantics or else Alfa_Mode) then @@ -2442,6 +1862,571 @@ package body Sem_Ch5 is Set_Reachable (E, True); end Analyze_Label_Entity; + ------------------------------------------ + -- Analyze_Loop_Parameter_Specification -- + ------------------------------------------ + + procedure Analyze_Loop_Parameter_Specification (N : Node_Id) is + Loop_Nod : constant Node_Id := Parent (Parent (N)); + + procedure Check_Controlled_Array_Attribute (DS : Node_Id); + -- If the bounds are given by a 'Range reference on a function call + -- that returns a controlled array, introduce an explicit declaration + -- to capture the bounds, so that the function result can be finalized + -- in timely fashion. + + function Has_Call_Using_Secondary_Stack (N : Node_Id) return Boolean; + -- N is the node for an arbitrary construct. This function searches the + -- construct N to see if any expressions within it contain function + -- calls that use the secondary stack, returning True if any such call + -- is found, and False otherwise. + + procedure Process_Bounds (R : Node_Id); + -- If the iteration is given by a range, create temporaries and + -- assignment statements block to capture the bounds and perform + -- required finalization actions in case a bound includes a function + -- call that uses the temporary stack. We first pre-analyze a copy of + -- the range in order to determine the expected type, and analyze and + -- resolve the original bounds. + + -------------------------------------- + -- Check_Controlled_Array_Attribute -- + -------------------------------------- + + procedure Check_Controlled_Array_Attribute (DS : Node_Id) is + begin + if Nkind (DS) = N_Attribute_Reference + and then Is_Entity_Name (Prefix (DS)) + and then Ekind (Entity (Prefix (DS))) = E_Function + and then Is_Array_Type (Etype (Entity (Prefix (DS)))) + and then + Is_Controlled (Component_Type (Etype (Entity (Prefix (DS))))) + and then Expander_Active + then + declare + Loc : constant Source_Ptr := Sloc (N); + Arr : constant Entity_Id := Etype (Entity (Prefix (DS))); + Indx : constant Entity_Id := + Base_Type (Etype (First_Index (Arr))); + Subt : constant Entity_Id := Make_Temporary (Loc, 'S'); + Decl : Node_Id; + + begin + Decl := + Make_Subtype_Declaration (Loc, + Defining_Identifier => Subt, + Subtype_Indication => + Make_Subtype_Indication (Loc, + Subtype_Mark => New_Reference_To (Indx, Loc), + Constraint => + Make_Range_Constraint (Loc, Relocate_Node (DS)))); + Insert_Before (Loop_Nod, Decl); + Analyze (Decl); + + Rewrite (DS, + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Subt, Loc), + Attribute_Name => Attribute_Name (DS))); + + Analyze (DS); + end; + end if; + end Check_Controlled_Array_Attribute; + + ------------------------------------ + -- Has_Call_Using_Secondary_Stack -- + ------------------------------------ + + function Has_Call_Using_Secondary_Stack (N : Node_Id) return Boolean is + + function Check_Call (N : Node_Id) return Traverse_Result; + -- Check if N is a function call which uses the secondary stack + + ---------------- + -- Check_Call -- + ---------------- + + function Check_Call (N : Node_Id) return Traverse_Result is + Nam : Node_Id; + Subp : Entity_Id; + Return_Typ : Entity_Id; + + begin + if Nkind (N) = N_Function_Call then + Nam := Name (N); + + -- Call using access to subprogram with explicit dereference + + if Nkind (Nam) = N_Explicit_Dereference then + Subp := Etype (Nam); + + -- Call using a selected component notation or Ada 2005 object + -- operation notation + + elsif Nkind (Nam) = N_Selected_Component then + Subp := Entity (Selector_Name (Nam)); + + -- Common case + + else + Subp := Entity (Nam); + end if; + + Return_Typ := Etype (Subp); + + if Is_Composite_Type (Return_Typ) + and then not Is_Constrained (Return_Typ) + then + return Abandon; + + elsif Sec_Stack_Needed_For_Return (Subp) then + return Abandon; + end if; + end if; + + -- Continue traversing the tree + + return OK; + end Check_Call; + + function Check_Calls is new Traverse_Func (Check_Call); + + -- Start of processing for Has_Call_Using_Secondary_Stack + + begin + return Check_Calls (N) = Abandon; + end Has_Call_Using_Secondary_Stack; + + -------------------- + -- Process_Bounds -- + -------------------- + + procedure Process_Bounds (R : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + + function One_Bound + (Original_Bound : Node_Id; + Analyzed_Bound : Node_Id; + Typ : Entity_Id) return Node_Id; + -- Capture value of bound and return captured value + + --------------- + -- One_Bound -- + --------------- + + function One_Bound + (Original_Bound : Node_Id; + Analyzed_Bound : Node_Id; + Typ : Entity_Id) return Node_Id + is + Assign : Node_Id; + Decl : Node_Id; + Id : Entity_Id; + + begin + -- If the bound is a constant or an object, no need for a separate + -- declaration. If the bound is the result of previous expansion + -- it is already analyzed and should not be modified. Note that + -- the Bound will be resolved later, if needed, as part of the + -- call to Make_Index (literal bounds may need to be resolved to + -- type Integer). + + if Analyzed (Original_Bound) then + return Original_Bound; + + elsif Nkind_In (Analyzed_Bound, N_Integer_Literal, + N_Character_Literal) + or else Is_Entity_Name (Analyzed_Bound) + then + Analyze_And_Resolve (Original_Bound, Typ); + return Original_Bound; + end if; + + -- Normally, the best approach is simply to generate a constant + -- declaration that captures the bound. However, there is a nasty + -- case where this is wrong. If the bound is complex, and has a + -- possible use of the secondary stack, we need to generate a + -- separate assignment statement to ensure the creation of a block + -- which will release the secondary stack. + + -- We prefer the constant declaration, since it leaves us with a + -- proper trace of the value, useful in optimizations that get rid + -- of junk range checks. + + if not Has_Call_Using_Secondary_Stack (Analyzed_Bound) then + Analyze_And_Resolve (Original_Bound, Typ); + Force_Evaluation (Original_Bound); + return Original_Bound; + end if; + + Id := Make_Temporary (Loc, 'R', Original_Bound); + + -- Here we make a declaration with a separate assignment + -- statement, and insert before loop header. + + Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Id, + Object_Definition => New_Occurrence_Of (Typ, Loc)); + + Assign := + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Id, Loc), + Expression => Relocate_Node (Original_Bound)); + + Insert_Actions (Loop_Nod, New_List (Decl, Assign)); + + -- Now that this temporary variable is initialized we decorate it + -- as safe-to-reevaluate to inform to the backend that no further + -- asignment will be issued and hence it can be handled as side + -- effect free. Note that this decoration must be done when the + -- assignment has been analyzed because otherwise it will be + -- rejected (see Analyze_Assignment). + + Set_Is_Safe_To_Reevaluate (Id); + + Rewrite (Original_Bound, New_Occurrence_Of (Id, Loc)); + + if Nkind (Assign) = N_Assignment_Statement then + return Expression (Assign); + else + return Original_Bound; + end if; + end One_Bound; + + Hi : constant Node_Id := High_Bound (R); + Lo : constant Node_Id := Low_Bound (R); + R_Copy : constant Node_Id := New_Copy_Tree (R); + New_Hi : Node_Id; + New_Lo : Node_Id; + Typ : Entity_Id; + + -- Start of processing for Process_Bounds + + begin + Set_Parent (R_Copy, Parent (R)); + Preanalyze_Range (R_Copy); + Typ := Etype (R_Copy); + + -- If the type of the discrete range is Universal_Integer, then the + -- bound's type must be resolved to Integer, and any object used to + -- hold the bound must also have type Integer, unless the literal + -- bounds are constant-folded expressions with a user-defined type. + + if Typ = Universal_Integer then + if Nkind (Lo) = N_Integer_Literal + and then Present (Etype (Lo)) + and then Scope (Etype (Lo)) /= Standard_Standard + then + Typ := Etype (Lo); + + elsif Nkind (Hi) = N_Integer_Literal + and then Present (Etype (Hi)) + and then Scope (Etype (Hi)) /= Standard_Standard + then + Typ := Etype (Hi); + + else + Typ := Standard_Integer; + end if; + end if; + + Set_Etype (R, Typ); + + New_Lo := One_Bound (Lo, Low_Bound (R_Copy), Typ); + New_Hi := One_Bound (Hi, High_Bound (R_Copy), Typ); + + -- Propagate staticness to loop range itself, in case the + -- corresponding subtype is static. + + if New_Lo /= Lo + and then Is_Static_Expression (New_Lo) + then + Rewrite (Low_Bound (R), New_Copy (New_Lo)); + end if; + + if New_Hi /= Hi + and then Is_Static_Expression (New_Hi) + then + Rewrite (High_Bound (R), New_Copy (New_Hi)); + end if; + end Process_Bounds; + + -- Local variables + + DS : constant Node_Id := Discrete_Subtype_Definition (N); + Id : constant Entity_Id := Defining_Identifier (N); + + DS_Copy : Node_Id; + + -- Start of processing for Analyze_Loop_Parameter_Specification + + begin + Enter_Name (Id); + + -- We always consider the loop variable to be referenced, since the loop + -- may be used just for counting purposes. + + Generate_Reference (Id, N, ' '); + + -- Check for the case of loop variable hiding a local variable (used + -- later on to give a nice warning if the hidden variable is never + -- assigned). + + declare + H : constant Entity_Id := Homonym (Id); + begin + if Present (H) + and then Ekind (H) = E_Variable + and then Is_Discrete_Type (Etype (H)) + and then Enclosing_Dynamic_Scope (H) = Enclosing_Dynamic_Scope (Id) + then + Set_Hiding_Loop_Variable (H, Id); + end if; + end; + + -- Loop parameter specification must include subtype mark in SPARK + + if Nkind (DS) = N_Range then + Check_SPARK_Restriction + ("loop parameter specification must include subtype mark", N); + end if; + + -- Analyze the subtype definition and create temporaries for the bounds. + -- Do not evaluate the range when preanalyzing a quantified expression + -- because bounds expressed as function calls with side effects will be + -- erroneously replicated. + + if Nkind (DS) = N_Range + and then Expander_Active + and then Nkind (Parent (N)) /= N_Quantified_Expression + then + Process_Bounds (DS); + + -- Either the expander not active or the range of iteration is a subtype + -- indication, an entity, or a function call that yields an aggregate or + -- a container. + + else + DS_Copy := New_Copy_Tree (DS); + Set_Parent (DS_Copy, Parent (DS)); + Preanalyze_Range (DS_Copy); + + -- Ada 2012: If the domain of iteration is a function call, it is the + -- new iterator form. + + -- We have also implemented the shorter form : for X in S for Alfa + -- use. In this case, 'Old and 'Result must be treated as entity + -- names over which iterators are legal. + + if Nkind (DS_Copy) = N_Function_Call + or else + (Alfa_Mode + and then (Nkind (DS_Copy) = N_Attribute_Reference + and then + (Attribute_Name (DS_Copy) = Name_Result + or else Attribute_Name (DS_Copy) = Name_Old))) + or else + (Is_Entity_Name (DS_Copy) + and then not Is_Type (Entity (DS_Copy))) + then + -- This is an iterator specification. Rewrite it as such and + -- analyze it to capture function calls that may require + -- finalization actions. + + declare + I_Spec : constant Node_Id := + Make_Iterator_Specification (Sloc (N), + Defining_Identifier => Relocate_Node (Id), + Name => DS_Copy, + Subtype_Indication => Empty, + Reverse_Present => Reverse_Present (N)); + Scheme : constant Node_Id := Parent (N); + + begin + Set_Iterator_Specification (Scheme, I_Spec); + Set_Loop_Parameter_Specification (Scheme, Empty); + Analyze_Iterator_Specification (I_Spec); + + -- In a generic context, analyze the original domain of + -- iteration, for name capture. + + if not Expander_Active then + Analyze (DS); + end if; + + -- Set kind of loop parameter, which may be used in the + -- subsequent analysis of the condition in a quantified + -- expression. + + Set_Ekind (Id, E_Loop_Parameter); + return; + end; + + -- Domain of iteration is not a function call, and is side-effect + -- free. + + else + Analyze (DS); + end if; + end if; + + if DS = Error then + return; + end if; + + -- Some additional checks if we are iterating through a type + + if Is_Entity_Name (DS) + and then Present (Entity (DS)) + and then Is_Type (Entity (DS)) + then + -- The subtype indication may denote the completion of an incomplete + -- type declaration. + + if Ekind (Entity (DS)) = E_Incomplete_Type then + Set_Entity (DS, Get_Full_View (Entity (DS))); + Set_Etype (DS, Entity (DS)); + end if; + + -- Attempt to iterate through non-static predicate + + if Is_Discrete_Type (Entity (DS)) + and then Present (Predicate_Function (Entity (DS))) + and then No (Static_Predicate (Entity (DS))) + then + Bad_Predicated_Subtype_Use + ("cannot use subtype& with non-static predicate for loop " & + "iteration", DS, Entity (DS)); + end if; + end if; + + -- Error if not discrete type + + if not Is_Discrete_Type (Etype (DS)) then + Wrong_Type (DS, Any_Discrete); + Set_Etype (DS, Any_Type); + end if; + + Check_Controlled_Array_Attribute (DS); + + Make_Index (DS, N, In_Iter_Schm => True); + Set_Ekind (Id, E_Loop_Parameter); + + -- A quantified expression which appears in a pre- or post-condition may + -- be analyzed multiple times. The analysis of the range creates several + -- itypes which reside in different scopes depending on whether the pre- + -- or post-condition has been expanded. Update the type of the loop + -- variable to reflect the proper itype at each stage of analysis. + + if No (Etype (Id)) + or else Etype (Id) = Any_Type + or else + (Present (Etype (Id)) + and then Is_Itype (Etype (Id)) + and then Nkind (Parent (Loop_Nod)) = N_Expression_With_Actions + and then Nkind (Original_Node (Parent (Loop_Nod))) = + N_Quantified_Expression) + then + Set_Etype (Id, Etype (DS)); + end if; + + -- Treat a range as an implicit reference to the type, to inhibit + -- spurious warnings. + + Generate_Reference (Base_Type (Etype (DS)), N, ' '); + Set_Is_Known_Valid (Id, True); + + -- The loop is not a declarative part, so the only entity declared + -- "within" must be frozen explicitly. + + declare + Flist : constant List_Id := Freeze_Entity (Id, N); + begin + if Is_Non_Empty_List (Flist) then + Insert_Actions (N, Flist); + end if; + end; + + -- Check for null or possibly null range and issue warning. We suppress + -- such messages in generic templates and instances, because in practice + -- they tend to be dubious in these cases. + + if Nkind (DS) = N_Range and then Comes_From_Source (N) then + declare + L : constant Node_Id := Low_Bound (DS); + H : constant Node_Id := High_Bound (DS); + + begin + -- If range of loop is null, issue warning + + if Compile_Time_Compare (L, H, Assume_Valid => True) = GT then + + -- Suppress the warning if inside a generic template or + -- instance, since in practice they tend to be dubious in these + -- cases since they can result from intended parametrization. + + if not Inside_A_Generic + and then not In_Instance + then + -- Specialize msg if invalid values could make the loop + -- non-null after all. + + if Compile_Time_Compare + (L, H, Assume_Valid => False) = GT + then + Error_Msg_N + ("?loop range is null, loop will not execute", DS); + + -- Since we know the range of the loop is null, set the + -- appropriate flag to remove the loop entirely during + -- expansion. + + Set_Is_Null_Loop (Loop_Nod); + + -- Here is where the loop could execute because of invalid + -- values, so issue appropriate message and in this case we + -- do not set the Is_Null_Loop flag since the loop may + -- execute. + + else + Error_Msg_N + ("?loop range may be null, loop may not execute", DS); + Error_Msg_N + ("?can only execute if invalid values are present", DS); + end if; + end if; + + -- In either case, suppress warnings in the body of the loop, + -- since it is likely that these warnings will be inappropriate + -- if the loop never actually executes, which is likely. + + Set_Suppress_Loop_Warnings (Loop_Nod); + + -- The other case for a warning is a reverse loop where the + -- upper bound is the integer literal zero or one, and the + -- lower bound can be positive. + + -- For example, we have + + -- for J in reverse N .. 1 loop + + -- In practice, this is very likely to be a case of reversing + -- the bounds incorrectly in the range. + + elsif Reverse_Present (N) + and then Nkind (Original_Node (H)) = N_Integer_Literal + and then + (Intval (Original_Node (H)) = Uint_0 + or else Intval (Original_Node (H)) = Uint_1) + then + Error_Msg_N ("?loop range may be null", DS); + Error_Msg_N ("\?bounds may be wrong way round", DS); + end if; + end; + end if; + end Analyze_Loop_Parameter_Specification; + ---------------------------- -- Analyze_Loop_Statement -- ---------------------------- @@ -2482,7 +2467,7 @@ package body Sem_Ch5 is begin Nam_Copy := New_Copy_Tree (Nam); Set_Parent (Nam_Copy, Parent (Nam)); - Pre_Analyze_Range (Nam_Copy); + Preanalyze_Range (Nam_Copy); -- The only two options here are iteration over a container or -- an array. @@ -2501,7 +2486,7 @@ package body Sem_Ch5 is begin DS_Copy := New_Copy_Tree (DS); Set_Parent (DS_Copy, Parent (DS)); - Pre_Analyze_Range (DS_Copy); + Preanalyze_Range (DS_Copy); -- Check for a call to Iterate () @@ -2907,11 +2892,11 @@ package body Sem_Ch5 is end if; end Check_Unreachable_Code; - ----------------------- - -- Pre_Analyze_Range -- - ----------------------- + ---------------------- + -- Preanalyze_Range -- + ---------------------- - procedure Pre_Analyze_Range (R_Copy : Node_Id) is + procedure Preanalyze_Range (R_Copy : Node_Id) is Save_Analysis : constant Boolean := Full_Analysis; begin @@ -2977,6 +2962,6 @@ package body Sem_Ch5 is Expander_Mode_Restore; Full_Analysis := Save_Analysis; - end Pre_Analyze_Range; + end Preanalyze_Range; end Sem_Ch5; diff --git a/gcc/ada/sem_ch5.ads b/gcc/ada/sem_ch5.ads index fdf09db32d5..86a92b76c5e 100644 --- a/gcc/ada/sem_ch5.ads +++ b/gcc/ada/sem_ch5.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -27,19 +27,20 @@ with Types; use Types; package Sem_Ch5 is - procedure Analyze_Assignment (N : Node_Id); - procedure Analyze_Block_Statement (N : Node_Id); - procedure Analyze_Case_Statement (N : Node_Id); - procedure Analyze_Exit_Statement (N : Node_Id); - procedure Analyze_Goto_Statement (N : Node_Id); - procedure Analyze_If_Statement (N : Node_Id); - procedure Analyze_Implicit_Label_Declaration (N : Node_Id); - procedure Analyze_Iterator_Specification (N : Node_Id); - procedure Analyze_Iteration_Scheme (N : Node_Id); - procedure Analyze_Label (N : Node_Id); - procedure Analyze_Loop_Statement (N : Node_Id); - procedure Analyze_Null_Statement (N : Node_Id); - procedure Analyze_Statements (L : List_Id); + procedure Analyze_Assignment (N : Node_Id); + procedure Analyze_Block_Statement (N : Node_Id); + procedure Analyze_Case_Statement (N : Node_Id); + procedure Analyze_Exit_Statement (N : Node_Id); + procedure Analyze_Goto_Statement (N : Node_Id); + procedure Analyze_If_Statement (N : Node_Id); + procedure Analyze_Implicit_Label_Declaration (N : Node_Id); + procedure Analyze_Iterator_Specification (N : Node_Id); + procedure Analyze_Iteration_Scheme (N : Node_Id); + procedure Analyze_Label (N : Node_Id); + procedure Analyze_Loop_Parameter_Specification (N : Node_Id); + procedure Analyze_Loop_Statement (N : Node_Id); + procedure Analyze_Null_Statement (N : Node_Id); + procedure Analyze_Statements (L : List_Id); procedure Analyze_Label_Entity (E : Entity_Id); -- This procedure performs direct analysis of the label entity E. It diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 8ec60c7abb3..4c7f2e47224 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -8702,7 +8702,9 @@ package body Sem_Ch6 is Discrete_Subtype_Definition (L2)); end; - else -- quantified expression with an iterator + elsif Present (Iterator_Specification (E1)) + and then Present (Iterator_Specification (E2)) + then declare I1 : constant Node_Id := Iterator_Specification (E1); I2 : constant Node_Id := Iterator_Specification (E2); @@ -8719,6 +8721,12 @@ package body Sem_Ch6 is and then FCE (Subtype_Indication (I1), Subtype_Indication (I2)); end; + + -- The quantified expressions used different specifications to + -- walk their respective ranges. + + else + return False; end if; when N_Range => @@ -11057,6 +11065,9 @@ package body Sem_Ch6 is -- that an invariant check is required (for an IN OUT parameter, or -- the returned value of a function. + function Last_Implicit_Declaration return Node_Id; + -- Return the last internally-generated declaration of N + ------------- -- Grab_CC -- ------------- @@ -11307,6 +11318,50 @@ package body Sem_Ch6 is end if; end Is_Public_Subprogram_For; + ------------------------------- + -- Last_Implicit_Declaration -- + ------------------------------- + + function Last_Implicit_Declaration return Node_Id is + Loc : constant Source_Ptr := Sloc (N); + Decls : List_Id := Declarations (N); + Decl : Node_Id; + Succ : Node_Id; + + begin + if No (Decls) then + Decls := New_List (Make_Null_Statement (Loc)); + Set_Declarations (N, Decls); + + elsif Is_Empty_List (Declarations (N)) then + Append_To (Decls, Make_Null_Statement (Loc)); + end if; + + -- Implicit and source declarations may be interspersed. Search for + -- the last implicit declaration which is either succeeded by a + -- source construct or is the last node in the declarative list. + + Decl := First (Declarations (N)); + while Present (Decl) loop + Succ := Next (Decl); + + -- The current declaration is the last one, do not return Empty + + if No (Succ) then + exit; + + -- The successor is a source construct + + elsif Comes_From_Source (Succ) then + exit; + end if; + + Next (Decl); + end loop; + + return Decl; + end Last_Implicit_Declaration; + -- Start of processing for Process_PPCs begin @@ -11712,7 +11767,7 @@ package body Sem_Ch6 is -- The entity for the _Postconditions procedure begin - Prepend_To (Declarations (N), + Insert_After (Last_Implicit_Declaration, Make_Subprogram_Body (Loc, Specification => Make_Procedure_Specification (Loc, diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 46a8b194853..ef5f8b4ed50 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -193,7 +193,6 @@ package body Sem_Res is procedure Resolve_Op_Expon (N : Node_Id; Typ : Entity_Id); procedure Resolve_Op_Not (N : Node_Id; Typ : Entity_Id); procedure Resolve_Qualified_Expression (N : Node_Id; Typ : Entity_Id); - procedure Resolve_Quantified_Expression (N : Node_Id; Typ : Entity_Id); procedure Resolve_Range (N : Node_Id; Typ : Entity_Id); procedure Resolve_Real_Literal (N : Node_Id; Typ : Entity_Id); procedure Resolve_Reference (N : Node_Id; Typ : Entity_Id); @@ -1770,6 +1769,10 @@ package body Sem_Res is -- Try and fix up a literal so that it matches its expected type. New -- literals are manufactured if necessary to avoid cascaded errors. + function Proper_Current_Scope return Entity_Id; + -- Return the current scope. Skip loop scopes created for the purpose of + -- quantified expression analysis since those do not appear in the tree. + procedure Report_Ambiguous_Argument; -- Additional diagnostics when an ambiguous call has an ambiguous -- argument (typically a controlling actual). @@ -1832,6 +1835,30 @@ package body Sem_Res is end if; end Patch_Up_Value; + -------------------------- + -- Proper_Current_Scope -- + -------------------------- + + function Proper_Current_Scope return Entity_Id is + S : Entity_Id := Current_Scope; + + begin + while Present (S) loop + + -- Skip a loop scope created for quantified expression analysis + + if Ekind (S) = E_Loop + and then Nkind (Parent (S)) = N_Quantified_Expression + then + S := Scope (S); + else + exit; + end if; + end loop; + + return S; + end Proper_Current_Scope; + ------------------------------- -- Report_Ambiguous_Argument -- ------------------------------- @@ -2597,10 +2624,10 @@ package body Sem_Res is -- an error. We can't do this earlier, because it would cause legal -- cases to get errors (when some other type has an abstract "+"). - if Ada_Version >= Ada_2005 and then - Nkind (N) in N_Op and then - Is_Overloaded (N) and then - Is_Universal_Numeric_Type (Etype (Entity (N))) + if Ada_Version >= Ada_2005 + and then Nkind (N) in N_Op + and then Is_Overloaded (N) + and then Is_Universal_Numeric_Type (Etype (Entity (N))) then Get_First_Interp (N, I, It); while Present (It.Typ) loop @@ -2761,8 +2788,7 @@ package body Sem_Res is when N_Qualified_Expression => Resolve_Qualified_Expression (N, Ctx_Type); - when N_Quantified_Expression - => Resolve_Quantified_Expression (N, Ctx_Type); + when N_Quantified_Expression => null; when N_Raise_xxx_Error => Set_Etype (N, Ctx_Type); @@ -2857,10 +2883,9 @@ package body Sem_Res is -- Ada 2012 (AI05-177): Expression functions do not freeze. Only -- their use (in an expanded call) freezes. - if Ekind (Current_Scope) /= E_Function - or else - Nkind (Original_Node (Unit_Declaration_Node (Current_Scope))) /= - N_Expression_Function + if Ekind (Proper_Current_Scope) /= E_Function + or else Nkind (Original_Node (Unit_Declaration_Node + (Proper_Current_Scope))) /= N_Expression_Function then Freeze_Expression (N); end if; @@ -5316,7 +5341,18 @@ package body Sem_Res is -- needs extending because we can generate procedure calls that need -- freezing. - if Is_Entity_Name (Subp) and then not In_Spec_Expression then + -- In Ada 2012, expression functions may be called within pre/post + -- conditions of subsequent functions or expression functions. Such + -- calls do not freeze when they appear within generated bodies, which + -- would place the freeze node in the wrong scope. An expression + -- function is frozen in the usual fashion, by the appearance of a real + -- body, or at the end of a declarative part. + + if Is_Entity_Name (Subp) and then not In_Spec_Expression + and then + (not Is_Expression_Function (Entity (Subp)) + or else Scope (Entity (Subp)) = Current_Scope) + then Freeze_Expression (Subp); end if; @@ -6082,15 +6118,36 @@ package body Sem_Res is Condition : constant Node_Id := First (Expressions (N)); Then_Expr : constant Node_Id := Next (Condition); Else_Expr : Node_Id := Next (Then_Expr); + Else_Typ : Entity_Id; + Then_Typ : Entity_Id; begin Resolve (Condition, Any_Boolean); Resolve (Then_Expr, Typ); + Then_Typ := Etype (Then_Expr); + + -- When the "then" and "else" expressions are of a scalar type, insert + -- a conversion to ensure the generation of a constraint check. + + if Is_Scalar_Type (Then_Typ) + and then Then_Typ /= Typ + then + Rewrite (Then_Expr, Convert_To (Typ, Then_Expr)); + Analyze_And_Resolve (Then_Expr, Typ); + end if; -- If ELSE expression present, just resolve using the determined type if Present (Else_Expr) then Resolve (Else_Expr, Typ); + Else_Typ := Etype (Else_Expr); + + if Is_Scalar_Type (Else_Typ) + and then Else_Typ /= Typ + then + Rewrite (Else_Expr, Convert_To (Typ, Else_Expr)); + Analyze_And_Resolve (Else_Expr, Typ); + end if; -- If no ELSE expression is present, root type must be Standard.Boolean -- and we provide a Standard.True result converted to the appropriate @@ -8279,31 +8336,6 @@ package body Sem_Res is Eval_Qualified_Expression (N); end Resolve_Qualified_Expression; - ----------------------------------- - -- Resolve_Quantified_Expression -- - ----------------------------------- - - procedure Resolve_Quantified_Expression (N : Node_Id; Typ : Entity_Id) is - begin - if not Alfa_Mode then - - -- The loop structure is already resolved during its analysis, only - -- the resolution of the condition needs to be done. Expansion is - -- disabled so that checks and other generated code are inserted in - -- the tree after expression has been rewritten as a loop. - - Expander_Mode_Save_And_Set (False); - Resolve (Condition (N), Typ); - Expander_Mode_Restore; - - -- In Alfa mode, we need normal expansion in order to properly introduce - -- the necessary transient scopes. - - else - Resolve (Condition (N), Typ); - end if; - end Resolve_Quantified_Expression; - ------------------- -- Resolve_Range -- ------------------- diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 6519221cbe6..b5255177b2c 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -742,11 +742,25 @@ package body Sem_Util is Loc : constant Source_Ptr := Sloc (N); Disc : Entity_Id; + Bas : Entity_Id; + -- The base type that is to be constrained by the defaults + begin if not Has_Discriminants (T) or else Is_Constrained (T) then return T; end if; + Bas := Base_Type (T); + + -- If T is non-private but its base type is private, this is the + -- completion of a subtype declaration whose parent type is private + -- (see Complete_Private_Subtype in Sem_Ch3). The proper discriminants + -- are to be found in the full view of the base. + + if Is_Private_Type (Bas) and then Present (Full_View (Bas)) then + Bas := Full_View (Bas); + end if; + Disc := First_Discriminant (T); if No (Discriminant_Default_Value (Disc)) then @@ -768,10 +782,10 @@ package body Sem_Util is Decl := Make_Subtype_Declaration (Loc, Defining_Identifier => Act, - Subtype_Indication => + Subtype_Indication => Make_Subtype_Indication (Loc, - Subtype_Mark => New_Occurrence_Of (T, Loc), - Constraint => + Subtype_Mark => New_Occurrence_Of (Bas, Loc), + Constraint => Make_Index_Or_Discriminant_Constraint (Loc, Constraints => Constraints))); @@ -798,8 +812,8 @@ package body Sem_Util is -- of the prefix. function Build_Discriminal_Record_Constraint return List_Id; - -- Similar to previous one, for discriminated components constrained - -- by the discriminant of the enclosing object. + -- Similar to previous one, for discriminated components constrained by + -- the discriminant of the enclosing object. ---------------------------------------- -- Build_Discriminal_Array_Constraint -- @@ -955,12 +969,7 @@ package body Sem_Util is -- and thus will not have the unit name automatically prepended. Set_Package_Name (Spec_Id); - - -- Append _E - - Name_Buffer (Name_Len + 1) := '_'; - Name_Buffer (Name_Len + 2) := 'E'; - Name_Len := Name_Len + 2; + Add_Str_To_Name_Buffer ("_E"); -- Create elaboration counter @@ -986,9 +995,9 @@ package body Sem_Util is Set_Current_Value (Elab_Ent, Empty); Set_Last_Assignment (Elab_Ent, Empty); - -- We do not want any further qualification of the name (if we did - -- not do this, we would pick up the name of the generic package - -- in the case of a library level generic instantiation). + -- We do not want any further qualification of the name (if we did not + -- do this, we would pick up the name of the generic package in the case + -- of a library level generic instantiation). Set_Has_Qualified_Name (Elab_Ent); Set_Has_Fully_Qualified_Name (Elab_Ent); @@ -1073,8 +1082,7 @@ package body Sem_Util is then return False; else - return - Cannot_Raise_Constraint_Error (Expression (Expr)); + return Cannot_Raise_Constraint_Error (Expression (Expr)); end if; when N_Unchecked_Type_Conversion => @@ -1084,8 +1092,7 @@ package body Sem_Util is if Do_Overflow_Check (Expr) then return False; else - return - Cannot_Raise_Constraint_Error (Right_Opnd (Expr)); + return Cannot_Raise_Constraint_Error (Right_Opnd (Expr)); end if; when N_Op_Divide | @@ -1142,8 +1149,7 @@ package body Sem_Util is -- Check_Implicit_Dereference -- -------------------------------- - procedure Check_Implicit_Dereference (Nam : Node_Id; Typ : Entity_Id) - is + procedure Check_Implicit_Dereference (Nam : Node_Id; Typ : Entity_Id) is Disc : Entity_Id; Desig : Entity_Id; @@ -8674,7 +8680,6 @@ package body Sem_Util is -- only affects the generation of internal expanded code, since -- calls to instantiations of Unchecked_Conversion are never -- considered variables (since they are function calls). - -- This is also true for expression actions. when N_Unchecked_Type_Conversion => return Is_Variable (Expression (Orig_Node)); @@ -10500,6 +10505,34 @@ package body Sem_Util is Actual_Id := Next_Actual (Actual_Id); end Next_Actual; + --------------------- + -- No_Scalar_Parts -- + --------------------- + + function No_Scalar_Parts (T : Entity_Id) return Boolean is + C : Entity_Id; + + begin + if Is_Scalar_Type (T) then + return False; + + elsif Is_Array_Type (T) then + return No_Scalar_Parts (Component_Type (T)); + + elsif Is_Record_Type (T) or else Has_Discriminants (T) then + C := First_Component_Or_Discriminant (T); + while Present (C) loop + if not No_Scalar_Parts (Etype (C)) then + return False; + else + Next_Component_Or_Discriminant (C); + end if; + end loop; + end if; + + return True; + end No_Scalar_Parts; + ----------------------- -- Normalize_Actuals -- ----------------------- diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 34d2fc0383c..607bd8e72e0 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -1221,6 +1221,11 @@ package Sem_Util is -- Note that the result produced is always an expression, not a parameter -- association node, even if named notation was used. + function No_Scalar_Parts (T : Entity_Id) return Boolean; + -- Tests if type T can be determined at compile time to have no scalar + -- parts in the sense of the Valid_Scalars attribute. Returns True if + -- this is the case, meaning that the result of Valid_Scalars is True. + procedure Normalize_Actuals (N : Node_Id; S : Entity_Id; diff --git a/gcc/ada/sinfo.adb b/gcc/ada/sinfo.adb index a8388b19344..a89f9b26269 100644 --- a/gcc/ada/sinfo.adb +++ b/gcc/ada/sinfo.adb @@ -1624,6 +1624,14 @@ package body Sinfo is return Flag16 (N); end Implicit_With; + function Implicit_With_From_Instantiation + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_With_Clause); + return Flag12 (N); + end Implicit_With_From_Instantiation; + function Interface_List (N : Node_Id) return List_Id is begin @@ -4704,6 +4712,14 @@ package body Sinfo is Set_Flag16 (N, Val); end Set_Implicit_With; + procedure Set_Implicit_With_From_Instantiation + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_With_Clause); + Set_Flag12 (N, Val); + end Set_Implicit_With_From_Instantiation; + procedure Set_Interface_List (N : Node_Id; Val : List_Id) is begin diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index 0972d9c1603..fa7dbee35aa 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -1226,6 +1226,9 @@ package Sinfo is -- 'Address or 'Tag attribute. ???There are other implicit with clauses -- as well. + -- Implicit_With_From_Instantiation (Flag12-Sem) + -- Set in N_With_Clause nodes from generic instantiations. + -- Import_Interface_Present (Flag16-Sem) -- This flag is set in an Interface or Import pragma if a matching -- pragma of the other kind is also present. This is used to avoid @@ -1252,7 +1255,7 @@ package Sinfo is -- to the node for the spec of the instance, inserted as part of the -- semantic processing for instantiations in Sem_Ch12. - -- Is_Accessibility_Actual (Flag12-Sem) + -- Is_Accessibility_Actual (Flag13-Sem) -- Present in N_Parameter_Association nodes. True if the parameter is -- an extra actual that carries the accessibility level of the actual -- for an access parameter, in a function that dispatches on result and @@ -5805,6 +5808,7 @@ package Sinfo is -- Elaborate_Desirable (Flag11-Sem) -- Private_Present (Flag15) set if with_clause has private keyword -- Implicit_With (Flag16-Sem) + -- Implicit_With_From_Instantiation (Flag12-Sem) -- Limited_Present (Flag17) set if LIMITED is present -- Limited_View_Installed (Flag18-Sem) -- Unreferenced_In_Spec (Flag7-Sem) @@ -8592,6 +8596,9 @@ package Sinfo is function Implicit_With (N : Node_Id) return Boolean; -- Flag16 + function Implicit_With_From_Instantiation + (N : Node_Id) return Boolean; -- Flag12 + function Import_Interface_Present (N : Node_Id) return Boolean; -- Flag16 @@ -9573,6 +9580,9 @@ package Sinfo is procedure Set_Implicit_With (N : Node_Id; Val : Boolean := True); -- Flag16 + procedure Set_Implicit_With_From_Instantiation + (N : Node_Id; Val : Boolean := True); -- Flag12 + procedure Set_Import_Interface_Present (N : Node_Id; Val : Boolean := True); -- Flag16 @@ -11959,6 +11969,7 @@ package Sinfo is pragma Inline (High_Bound); pragma Inline (Identifier); pragma Inline (Implicit_With); + pragma Inline (Implicit_With_From_Instantiation); pragma Inline (Interface_List); pragma Inline (Interface_Present); pragma Inline (Includes_Infinities); diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl index ed30b9b5aac..c85fdd01d19 100644 --- a/gcc/ada/snames.ads-tmpl +++ b/gcc/ada/snames.ads-tmpl @@ -1199,6 +1199,7 @@ package Snames is Name_Object_File_Switches : constant Name_Id := N + $; Name_Object_Generated : constant Name_Id := N + $; Name_Object_List : constant Name_Id := N + $; + Name_Object_Path_Switches : constant Name_Id := N + $; Name_Objects_Linked : constant Name_Id := N + $; Name_Objects_Path : constant Name_Id := N + $; Name_Objects_Path_File : constant Name_Id := N + $; diff --git a/gcc/ada/style.adb b/gcc/ada/style.adb index 727a0cdf452..b60370231b1 100644 --- a/gcc/ada/style.adb +++ b/gcc/ada/style.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -236,7 +236,13 @@ package body Style is procedure Missing_Overriding (N : Node_Id; E : Entity_Id) is begin - if Style_Check_Missing_Overriding and then Comes_From_Source (N) then + + -- Perform the check on source subprograms and on subprogram instances, + -- because these can be primitives of untagged types. + + if Style_Check_Missing_Overriding + and then (Comes_From_Source (N) or else Is_Generic_Instance (E)) + then if Nkind (N) = N_Subprogram_Body then Error_Msg_NE -- CODEFIX ("(style) missing OVERRIDING indicator in body of&", N, E); diff --git a/gcc/ada/switch-c.adb b/gcc/ada/switch-c.adb index 789fb9b5b4d..7cb0ee06a65 100644 --- a/gcc/ada/switch-c.adb +++ b/gcc/ada/switch-c.adb @@ -516,6 +516,24 @@ package body Switch.C is new String'(Switch_Chars (Ptr .. Max)); return; + -- -gnateO= (object path file) + + when 'O' => + Store_Switch := False; + Ptr := Ptr + 1; + + -- Check for '=' + + if Ptr >= Max or else Switch_Chars (Ptr) /= '=' then + Bad_Switch ("-gnateO"); + + else + Object_Path_File_Name := + new String'(Switch_Chars (Ptr + 1 .. Max)); + end if; + + return; + -- -gnatep (preprocessing data file) when 'p' => diff --git a/gcc/basic-block.h b/gcc/basic-block.h index fb17bad9d05..f8cdea0085d 100644 --- a/gcc/basic-block.h +++ b/gcc/basic-block.h @@ -830,9 +830,6 @@ extern bool inside_basic_block_p (const_rtx); extern bool control_flow_insn_p (const_rtx); extern rtx get_last_bb_insn (basic_block); -/* In bb-reorder.c */ -extern void reorder_basic_blocks (void); - /* In dominance.c */ enum cdi_direction diff --git a/gcc/bb-reorder.c b/gcc/bb-reorder.c index a35b8e62942..c7f9c920d76 100644 --- a/gcc/bb-reorder.c +++ b/gcc/bb-reorder.c @@ -1903,7 +1903,7 @@ verify_hot_cold_block_grouping (void) /* Reorder basic blocks. The main entry point to this file. FLAGS is the set of flags to pass to cfg_layout_initialize(). */ -void +static void reorder_basic_blocks (void) { int n_traces; diff --git a/gcc/cfghooks.c b/gcc/cfghooks.c index 1dca79a70cf..bc1b7a2f582 100644 --- a/gcc/cfghooks.c +++ b/gcc/cfghooks.c @@ -1009,18 +1009,28 @@ duplicate_block (basic_block bb, edge e, basic_block after) { struct loop *cloop = bb->loop_father; struct loop *copy = get_loop_copy (cloop); - add_bb_to_loop (new_bb, copy ? copy : cloop); - /* If we copied the loop latch block but not the loop, adjust - loop state. - ??? If we copied the loop header block but not the loop - we might either have created a loop copy or a loop with - multiple entries. In both cases we probably have to - ditch the loops and arrange for a fixup. */ + /* If we copied the loop header block but not the loop + we have created a loop with multiple entries. Ditch the loop, + add the new block to the outer loop and arrange for a fixup. */ if (!copy - && cloop->latch == bb) + && cloop->header == bb) { + add_bb_to_loop (new_bb, loop_outer (cloop)); + cloop->header = NULL; cloop->latch = NULL; - loops_state_set (LOOPS_MAY_HAVE_MULTIPLE_LATCHES); + loops_state_set (LOOPS_NEED_FIXUP); + } + else + { + add_bb_to_loop (new_bb, copy ? copy : cloop); + /* If we copied the loop latch block but not the loop, adjust + loop state. */ + if (!copy + && cloop->latch == bb) + { + cloop->latch = NULL; + loops_state_set (LOOPS_MAY_HAVE_MULTIPLE_LATCHES); + } } } diff --git a/gcc/cgraph.h b/gcc/cgraph.h index 93efd94d9ba..726285989fc 100644 --- a/gcc/cgraph.h +++ b/gcc/cgraph.h @@ -613,13 +613,11 @@ struct cgraph_2edge_hook_list *cgraph_add_edge_duplication_hook (cgraph_2edge_ho void cgraph_remove_edge_duplication_hook (struct cgraph_2edge_hook_list *); struct cgraph_2node_hook_list *cgraph_add_node_duplication_hook (cgraph_2node_hook, void *); void cgraph_remove_node_duplication_hook (struct cgraph_2node_hook_list *); -void cgraph_materialize_all_clones (void); gimple cgraph_redirect_edge_call_stmt_to_callee (struct cgraph_edge *); bool cgraph_propagate_frequency (struct cgraph_node *node); /* In cgraphbuild.c */ unsigned int rebuild_cgraph_edges (void); void cgraph_rebuild_references (void); -void reset_inline_failed (struct cgraph_node *); int compute_call_stmt_bb_frequency (tree, basic_block bb); /* In ipa.c */ diff --git a/gcc/cgraphbuild.c b/gcc/cgraphbuild.c index 8bf88300593..d7ef7f9d99d 100644 --- a/gcc/cgraphbuild.c +++ b/gcc/cgraphbuild.c @@ -200,20 +200,6 @@ record_eh_tables (struct cgraph_node *node, struct function *fun) } } -/* Reset inlining information of all incoming call edges of NODE. */ - -void -reset_inline_failed (struct cgraph_node *node) -{ - struct cgraph_edge *e; - - for (e = node->callers; e; e = e->next_caller) - { - e->callee->global.inlined_to = NULL; - initialize_inline_failed (e); - } -} - /* Computes the frequency of the call statement so that it can be stored in cgraph_edge. BB is the basic block of the call statement. */ int diff --git a/gcc/cgraphunit.c b/gcc/cgraphunit.c index 516f187fedd..9e5820fc901 100644 --- a/gcc/cgraphunit.c +++ b/gcc/cgraphunit.c @@ -1294,59 +1294,6 @@ handle_alias_pairs (void) } -/* Analyze the whole compilation unit once it is parsed completely. */ - -void -cgraph_finalize_compilation_unit (void) -{ - timevar_push (TV_CGRAPH); - - /* If LTO is enabled, initialize the streamer hooks needed by GIMPLE. */ - if (flag_lto) - lto_streamer_hooks_init (); - - /* If we're here there's no current function anymore. Some frontends - are lazy in clearing these. */ - current_function_decl = NULL; - set_cfun (NULL); - - /* Do not skip analyzing the functions if there were errors, we - miss diagnostics for following functions otherwise. */ - - /* Emit size functions we didn't inline. */ - finalize_size_functions (); - - /* Mark alias targets necessary and emit diagnostics. */ - finish_aliases_1 (); - handle_alias_pairs (); - - if (!quiet_flag) - { - fprintf (stderr, "\nAnalyzing compilation unit\n"); - fflush (stderr); - } - - if (flag_dump_passes) - dump_passes (); - - /* Gimplify and lower all functions, compute reachability and - remove unreachable nodes. */ - cgraph_analyze_functions (); - - /* Mark alias targets necessary and emit diagnostics. */ - finish_aliases_1 (); - handle_alias_pairs (); - - /* Gimplify and lower thunks. */ - cgraph_analyze_functions (); - - /* Finally drive the pass manager. */ - cgraph_optimize (); - - timevar_pop (TV_CGRAPH); -} - - /* Figure out what functions we want to assemble. */ static void @@ -2134,124 +2081,6 @@ output_weakrefs (void) } -/* Perform simple optimizations based on callgraph. */ - -void -cgraph_optimize (void) -{ - if (seen_error ()) - return; - -#ifdef ENABLE_CHECKING - verify_cgraph (); -#endif - - /* Frontend may output common variables after the unit has been finalized. - It is safe to deal with them here as they are always zero initialized. */ - varpool_analyze_pending_decls (); - - timevar_push (TV_CGRAPHOPT); - if (pre_ipa_mem_report) - { - fprintf (stderr, "Memory consumption before IPA\n"); - dump_memory_report (false); - } - if (!quiet_flag) - fprintf (stderr, "Performing interprocedural optimizations\n"); - cgraph_state = CGRAPH_STATE_IPA; - - /* Don't run the IPA passes if there was any error or sorry messages. */ - if (!seen_error ()) - ipa_passes (); - - /* Do nothing else if any IPA pass found errors or if we are just streaming LTO. */ - if (seen_error () - || (!in_lto_p && flag_lto && !flag_fat_lto_objects)) - { - timevar_pop (TV_CGRAPHOPT); - return; - } - - /* This pass remove bodies of extern inline functions we never inlined. - Do this later so other IPA passes see what is really going on. */ - cgraph_remove_unreachable_nodes (false, dump_file); - cgraph_global_info_ready = true; - if (cgraph_dump_file) - { - fprintf (cgraph_dump_file, "Optimized "); - dump_cgraph (cgraph_dump_file); - dump_varpool (cgraph_dump_file); - } - if (post_ipa_mem_report) - { - fprintf (stderr, "Memory consumption after IPA\n"); - dump_memory_report (false); - } - timevar_pop (TV_CGRAPHOPT); - - /* Output everything. */ - (*debug_hooks->assembly_start) (); - if (!quiet_flag) - fprintf (stderr, "Assembling functions:\n"); -#ifdef ENABLE_CHECKING - verify_cgraph (); -#endif - - cgraph_materialize_all_clones (); - bitmap_obstack_initialize (NULL); - execute_ipa_pass_list (all_late_ipa_passes); - cgraph_remove_unreachable_nodes (true, dump_file); -#ifdef ENABLE_CHECKING - verify_cgraph (); -#endif - bitmap_obstack_release (NULL); - cgraph_mark_functions_to_output (); - output_weakrefs (); - - cgraph_state = CGRAPH_STATE_EXPANSION; - if (!flag_toplevel_reorder) - cgraph_output_in_order (); - else - { - cgraph_output_pending_asms (); - - cgraph_expand_all_functions (); - varpool_remove_unreferenced_decls (); - - varpool_assemble_pending_decls (); - } - - cgraph_process_new_functions (); - cgraph_state = CGRAPH_STATE_FINISHED; - - if (cgraph_dump_file) - { - fprintf (cgraph_dump_file, "\nFinal "); - dump_cgraph (cgraph_dump_file); - dump_varpool (cgraph_dump_file); - } -#ifdef ENABLE_CHECKING - verify_cgraph (); - /* Double check that all inline clones are gone and that all - function bodies have been released from memory. */ - if (!seen_error ()) - { - struct cgraph_node *node; - bool error_found = false; - - for (node = cgraph_nodes; node; node = node->next) - if (node->analyzed - && (node->global.inlined_to - || gimple_has_body_p (node->decl))) - { - error_found = true; - dump_cgraph_node (stderr, node); - } - if (error_found) - internal_error ("nodes with unreleased memory found"); - } -#endif -} void init_cgraph (void) @@ -2549,7 +2378,7 @@ cgraph_redirect_edge_call_stmt_to_callee (struct cgraph_edge *e) bring all functions to memory prior compilation, but current WHOPR implementation does that and it is is bit easier to keep everything right in this order. */ -void +static void cgraph_materialize_all_clones (void) { struct cgraph_node *node; @@ -2628,4 +2457,178 @@ cgraph_materialize_all_clones (void) cgraph_remove_unreachable_nodes (false, cgraph_dump_file); } + +/* Perform simple optimizations based on callgraph. */ + +void +cgraph_optimize (void) +{ + if (seen_error ()) + return; + +#ifdef ENABLE_CHECKING + verify_cgraph (); +#endif + + /* Frontend may output common variables after the unit has been finalized. + It is safe to deal with them here as they are always zero initialized. */ + varpool_analyze_pending_decls (); + + timevar_push (TV_CGRAPHOPT); + if (pre_ipa_mem_report) + { + fprintf (stderr, "Memory consumption before IPA\n"); + dump_memory_report (false); + } + if (!quiet_flag) + fprintf (stderr, "Performing interprocedural optimizations\n"); + cgraph_state = CGRAPH_STATE_IPA; + + /* Don't run the IPA passes if there was any error or sorry messages. */ + if (!seen_error ()) + ipa_passes (); + + /* Do nothing else if any IPA pass found errors or if we are just streaming LTO. */ + if (seen_error () + || (!in_lto_p && flag_lto && !flag_fat_lto_objects)) + { + timevar_pop (TV_CGRAPHOPT); + return; + } + + /* This pass remove bodies of extern inline functions we never inlined. + Do this later so other IPA passes see what is really going on. */ + cgraph_remove_unreachable_nodes (false, dump_file); + cgraph_global_info_ready = true; + if (cgraph_dump_file) + { + fprintf (cgraph_dump_file, "Optimized "); + dump_cgraph (cgraph_dump_file); + dump_varpool (cgraph_dump_file); + } + if (post_ipa_mem_report) + { + fprintf (stderr, "Memory consumption after IPA\n"); + dump_memory_report (false); + } + timevar_pop (TV_CGRAPHOPT); + + /* Output everything. */ + (*debug_hooks->assembly_start) (); + if (!quiet_flag) + fprintf (stderr, "Assembling functions:\n"); +#ifdef ENABLE_CHECKING + verify_cgraph (); +#endif + + cgraph_materialize_all_clones (); + bitmap_obstack_initialize (NULL); + execute_ipa_pass_list (all_late_ipa_passes); + cgraph_remove_unreachable_nodes (true, dump_file); +#ifdef ENABLE_CHECKING + verify_cgraph (); +#endif + bitmap_obstack_release (NULL); + cgraph_mark_functions_to_output (); + output_weakrefs (); + + cgraph_state = CGRAPH_STATE_EXPANSION; + if (!flag_toplevel_reorder) + cgraph_output_in_order (); + else + { + cgraph_output_pending_asms (); + + cgraph_expand_all_functions (); + varpool_remove_unreferenced_decls (); + + varpool_assemble_pending_decls (); + } + + cgraph_process_new_functions (); + cgraph_state = CGRAPH_STATE_FINISHED; + + if (cgraph_dump_file) + { + fprintf (cgraph_dump_file, "\nFinal "); + dump_cgraph (cgraph_dump_file); + dump_varpool (cgraph_dump_file); + } +#ifdef ENABLE_CHECKING + verify_cgraph (); + /* Double check that all inline clones are gone and that all + function bodies have been released from memory. */ + if (!seen_error ()) + { + struct cgraph_node *node; + bool error_found = false; + + for (node = cgraph_nodes; node; node = node->next) + if (node->analyzed + && (node->global.inlined_to + || gimple_has_body_p (node->decl))) + { + error_found = true; + dump_cgraph_node (stderr, node); + } + if (error_found) + internal_error ("nodes with unreleased memory found"); + } +#endif +} + + +/* Analyze the whole compilation unit once it is parsed completely. */ + +void +cgraph_finalize_compilation_unit (void) +{ + timevar_push (TV_CGRAPH); + + /* If LTO is enabled, initialize the streamer hooks needed by GIMPLE. */ + if (flag_lto) + lto_streamer_hooks_init (); + + /* If we're here there's no current function anymore. Some frontends + are lazy in clearing these. */ + current_function_decl = NULL; + set_cfun (NULL); + + /* Do not skip analyzing the functions if there were errors, we + miss diagnostics for following functions otherwise. */ + + /* Emit size functions we didn't inline. */ + finalize_size_functions (); + + /* Mark alias targets necessary and emit diagnostics. */ + finish_aliases_1 (); + handle_alias_pairs (); + + if (!quiet_flag) + { + fprintf (stderr, "\nAnalyzing compilation unit\n"); + fflush (stderr); + } + + if (flag_dump_passes) + dump_passes (); + + /* Gimplify and lower all functions, compute reachability and + remove unreachable nodes. */ + cgraph_analyze_functions (); + + /* Mark alias targets necessary and emit diagnostics. */ + finish_aliases_1 (); + handle_alias_pairs (); + + /* Gimplify and lower thunks. */ + cgraph_analyze_functions (); + + /* Finally drive the pass manager. */ + cgraph_optimize (); + + timevar_pop (TV_CGRAPH); +} + + #include "gt-cgraphunit.h" diff --git a/gcc/combine-stack-adj.c b/gcc/combine-stack-adj.c index 3cffd662f92..6b6f74b4b25 100644 --- a/gcc/combine-stack-adj.c +++ b/gcc/combine-stack-adj.c @@ -320,6 +320,107 @@ maybe_move_args_size_note (rtx last, rtx insn, bool after) add_reg_note (last, REG_ARGS_SIZE, XEXP (note, 0)); } +/* Return the next (or previous) active insn within BB. */ + +static rtx +prev_active_insn_bb (basic_block bb, rtx insn) +{ + for (insn = PREV_INSN (insn); + insn != PREV_INSN (BB_HEAD (bb)); + insn = PREV_INSN (insn)) + if (active_insn_p (insn)) + return insn; + return NULL_RTX; +} + +static rtx +next_active_insn_bb (basic_block bb, rtx insn) +{ + for (insn = NEXT_INSN (insn); + insn != NEXT_INSN (BB_END (bb)); + insn = NEXT_INSN (insn)) + if (active_insn_p (insn)) + return insn; + return NULL_RTX; +} + +/* If INSN has a REG_ARGS_SIZE note, if possible move it to PREV. Otherwise + search for a nearby candidate within BB where we can stick the note. */ + +static void +force_move_args_size_note (basic_block bb, rtx prev, rtx insn) +{ + rtx note, test, next_candidate, prev_candidate; + + /* If PREV exists, tail-call to the logic in the other function. */ + if (prev) + { + maybe_move_args_size_note (prev, insn, false); + return; + } + + /* First, make sure there's anything that needs doing. */ + note = find_reg_note (insn, REG_ARGS_SIZE, NULL_RTX); + if (note == NULL) + return; + + /* We need to find a spot between the previous and next exception points + where we can place the note and "properly" deallocate the arguments. */ + next_candidate = prev_candidate = NULL; + + /* It is often the case that we have insns in the order: + call + add sp (previous deallocation) + sub sp (align for next arglist) + push arg + and the add/sub cancel. Therefore we begin by searching forward. */ + + test = insn; + while ((test = next_active_insn_bb (bb, test)) != NULL) + { + /* Found an existing note: nothing to do. */ + if (find_reg_note (test, REG_ARGS_SIZE, NULL_RTX)) + return; + /* Found something that affects unwinding. Stop searching. */ + if (CALL_P (test) || !insn_nothrow_p (test)) + break; + if (next_candidate == NULL) + next_candidate = test; + } + + test = insn; + while ((test = prev_active_insn_bb (bb, test)) != NULL) + { + rtx tnote; + /* Found a place that seems logical to adjust the stack. */ + tnote = find_reg_note (test, REG_ARGS_SIZE, NULL_RTX); + if (tnote) + { + XEXP (tnote, 0) = XEXP (note, 0); + return; + } + if (prev_candidate == NULL) + prev_candidate = test; + /* Found something that affects unwinding. Stop searching. */ + if (CALL_P (test) || !insn_nothrow_p (test)) + break; + } + + if (prev_candidate) + test = prev_candidate; + else if (next_candidate) + test = next_candidate; + else + { + /* ??? We *must* have a place, lest we ICE on the lost adjustment. + Options are: dummy clobber insn, nop, or prevent the removal of + the sp += 0 insn. Defer that decision until we can prove this + can actually happen. */ + gcc_unreachable (); + } + add_reg_note (test, REG_ARGS_SIZE, XEXP (note, 0)); +} + /* Subroutine of combine_stack_adjustments, called for each basic block. */ static void @@ -327,6 +428,7 @@ combine_stack_adjustments_for_block (basic_block bb) { HOST_WIDE_INT last_sp_adjust = 0; rtx last_sp_set = NULL_RTX; + rtx last2_sp_set = NULL_RTX; struct csa_reflist *reflist = NULL; rtx insn, next, set; struct record_stack_refs_data data; @@ -391,9 +493,8 @@ combine_stack_adjustments_for_block (basic_block bb) last_sp_adjust + this_adjust, this_adjust)) { - maybe_move_args_size_note (last_sp_set, insn, false); - /* It worked! */ + maybe_move_args_size_note (last_sp_set, insn, false); delete_insn (insn); last_sp_adjust += this_adjust; continue; @@ -409,9 +510,8 @@ combine_stack_adjustments_for_block (basic_block bb) last_sp_adjust + this_adjust, -last_sp_adjust)) { - maybe_move_args_size_note (insn, last_sp_set, true); - /* It worked! */ + maybe_move_args_size_note (insn, last_sp_set, true); delete_insn (last_sp_set); last_sp_set = insn; last_sp_adjust += this_adjust; @@ -424,8 +524,16 @@ combine_stack_adjustments_for_block (basic_block bb) /* Combination failed. Restart processing from here. If deallocation+allocation conspired to cancel, we can delete the old deallocation insn. */ - if (last_sp_set && last_sp_adjust == 0) - delete_insn (last_sp_set); + if (last_sp_set) + { + if (last_sp_adjust == 0) + { + maybe_move_args_size_note (insn, last_sp_set, true); + delete_insn (last_sp_set); + } + else + last2_sp_set = last_sp_set; + } free_csa_reflist (reflist); reflist = NULL; last_sp_set = insn; @@ -461,6 +569,10 @@ combine_stack_adjustments_for_block (basic_block bb) && try_apply_stack_adjustment (insn, reflist, 0, -last_sp_adjust)) { + if (last2_sp_set) + maybe_move_args_size_note (last2_sp_set, last_sp_set, false); + else + maybe_move_args_size_note (insn, last_sp_set, true); delete_insn (last_sp_set); free_csa_reflist (reflist); reflist = NULL; @@ -487,16 +599,23 @@ combine_stack_adjustments_for_block (basic_block bb) || reg_mentioned_p (stack_pointer_rtx, PATTERN (insn)))) { if (last_sp_set && last_sp_adjust == 0) - delete_insn (last_sp_set); + { + force_move_args_size_note (bb, last2_sp_set, last_sp_set); + delete_insn (last_sp_set); + } free_csa_reflist (reflist); reflist = NULL; + last2_sp_set = NULL_RTX; last_sp_set = NULL_RTX; last_sp_adjust = 0; } } if (last_sp_set && last_sp_adjust == 0) - delete_insn (last_sp_set); + { + force_move_args_size_note (bb, last2_sp_set, last_sp_set); + delete_insn (last_sp_set); + } if (reflist) free_csa_reflist (reflist); diff --git a/gcc/combine.c b/gcc/combine.c index e3c8209a153..7eaaf476c6e 100644 --- a/gcc/combine.c +++ b/gcc/combine.c @@ -9698,7 +9698,7 @@ extended_count (const_rtx x, enum machine_mode mode, int unsignedp) : 0) : num_sign_bit_copies (x, mode) - 1); } - + /* This function is called from `simplify_shift_const' to merge two outer operations. Specifically, we have already found that we need to perform operation *POP0 with constant *PCONST0 at the outermost @@ -13912,7 +13912,7 @@ unmentioned_reg_p (rtx equiv, rtx expr) return for_each_rtx (&equiv, unmentioned_reg_p_1, expr); } -void +DEBUG_FUNCTION void dump_combine_stats (FILE *file) { fprintf diff --git a/gcc/config.gcc b/gcc/config.gcc index 1f2baeec05a..3eb2c7002df 100644 --- a/gcc/config.gcc +++ b/gcc/config.gcc @@ -488,6 +488,10 @@ fi case ${target} in i[34567]86-*-*) + if test "x$with_abi" != x; then + echo "This target does not support --with-abi." + exit 1 + fi if test "x$enable_cld" = xyes; then tm_defines="${tm_defines} USE_IX86_CLD=1" fi @@ -497,7 +501,24 @@ i[34567]86-*-*) tm_file="vxworks-dummy.h ${tm_file}" ;; x86_64-*-*) - tm_file="i386/biarch64.h ${tm_file}" + case ${with_abi} in + "") + if test "x$with_multilib_list" = xmx32; then + tm_file="i386/biarchx32.h ${tm_file}" + else + tm_file="i386/biarch64.h ${tm_file}" + fi + ;; + 64 | m64) + tm_file="i386/biarch64.h ${tm_file}" + ;; + x32 | mx32) + tm_file="i386/biarchx32.h ${tm_file}" + ;; + *) + echo "Unknown ABI used in --with-abi=$with_abi" + exit 1 + esac if test "x$enable_cld" = xyes; then tm_defines="${tm_defines} USE_IX86_CLD=1" fi @@ -740,6 +761,7 @@ case ${target} in xm_file="vms/xm-vms.h" c_target_objs="vms-c.o" cxx_target_objs="vms-c.o" + fortran_target_objs="vms-f.o" use_gcc_stdint=provide tm_file="${tm_file} vms/vms-stdint.h" if test x$gnu_ld != xyes; then @@ -3137,7 +3159,7 @@ case "${target}" in ;; i[34567]86-*-* | x86_64-*-*) - supported_defaults="arch arch_32 arch_64 cpu cpu_32 cpu_64 tune tune_32 tune_64" + supported_defaults="abi arch arch_32 arch_64 cpu cpu_32 cpu_64 tune tune_32 tune_64" for which in arch arch_32 arch_64 cpu cpu_32 cpu_64 tune tune_32 tune_64; do eval "val=\$with_$which" case ${val} in diff --git a/gcc/config/arm/arm.c b/gcc/config/arm/arm.c index 9af66dd8ace..5522fc12172 100644 --- a/gcc/config/arm/arm.c +++ b/gcc/config/arm/arm.c @@ -82,6 +82,7 @@ static int arm_legitimate_index_p (enum machine_mode, rtx, RTX_CODE, int); static int thumb2_legitimate_index_p (enum machine_mode, rtx, int); static int thumb1_base_register_rtx_p (rtx, enum machine_mode, int); static rtx arm_legitimize_address (rtx, rtx, enum machine_mode); +static reg_class_t arm_preferred_reload_class (rtx, reg_class_t); static rtx thumb_legitimize_address (rtx, rtx, enum machine_mode); inline static int thumb1_index_register_rtx_p (rtx, int); static bool arm_legitimate_address_p (enum machine_mode, rtx, bool); @@ -576,6 +577,9 @@ static const struct attribute_spec arm_attribute_table[] = #undef TARGET_LEGITIMATE_ADDRESS_P #define TARGET_LEGITIMATE_ADDRESS_P arm_legitimate_address_p +#undef TARGET_PREFERRED_RELOAD_CLASS +#define TARGET_PREFERRED_RELOAD_CLASS arm_preferred_reload_class + #undef TARGET_INVALID_PARAMETER_TYPE #define TARGET_INVALID_PARAMETER_TYPE arm_invalid_parameter_type @@ -6226,6 +6230,30 @@ arm_legitimate_address_p (enum machine_mode mode, rtx x, bool strict_p) return thumb1_legitimate_address_p (mode, x, strict_p); } +/* Worker function for TARGET_PREFERRED_RELOAD_CLASS. + + Given an rtx X being reloaded into a reg required to be + in class CLASS, return the class of reg to actually use. + In general this is just CLASS, but for the Thumb core registers and + immediate constants we prefer a LO_REGS class or a subset. */ + +static reg_class_t +arm_preferred_reload_class (rtx x ATTRIBUTE_UNUSED, reg_class_t rclass) +{ + if (TARGET_32BIT) + return rclass; + else + { + if (rclass == GENERAL_REGS + || rclass == HI_REGS + || rclass == NO_REGS + || rclass == STACK_REG) + return LO_REGS; + else + return rclass; + } +} + /* Build the SYMBOL_REF for __tls_get_addr. */ static GTY(()) rtx tls_get_addr_libfunc; diff --git a/gcc/config/arm/arm.h b/gcc/config/arm/arm.h index 443d2ed168d..c6b4cc09a46 100644 --- a/gcc/config/arm/arm.h +++ b/gcc/config/arm/arm.h @@ -1151,16 +1151,6 @@ enum reg_class #define TARGET_SMALL_REGISTER_CLASSES_FOR_MODE_P \ arm_small_register_classes_for_mode_p -/* Given an rtx X being reloaded into a reg required to be - in class CLASS, return the class of reg to actually use. - In general this is just CLASS, but for the Thumb core registers and - immediate constants we prefer a LO_REGS class or a subset. */ -#define PREFERRED_RELOAD_CLASS(X, CLASS) \ - (TARGET_32BIT ? (CLASS) : \ - ((CLASS) == GENERAL_REGS || (CLASS) == HI_REGS \ - || (CLASS) == NO_REGS || (CLASS) == STACK_REG \ - ? LO_REGS : (CLASS))) - /* Must leave BASE_REGS reloads alone */ #define THUMB_SECONDARY_INPUT_RELOAD_CLASS(CLASS, MODE, X) \ ((CLASS) != LO_REGS && (CLASS) != BASE_REGS \ diff --git a/gcc/config/i386/biarchx32.h b/gcc/config/i386/biarchx32.h new file mode 100644 index 00000000000..69d672216ac --- /dev/null +++ b/gcc/config/i386/biarchx32.h @@ -0,0 +1,28 @@ +/* Make configure files to produce biarch compiler defaulting to x32 mode. + This file must be included very first, while the OS specific file later + to overwrite otherwise wrong defaults. + Copyright (C) 2012 Free Software Foundation, Inc. + +This file is part of GCC. + +GCC is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 3, or (at your option) +any later version. + +GCC is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +<http://www.gnu.org/licenses/>. */ + +#define TARGET_64BIT_DEFAULT (OPTION_MASK_ISA_64BIT | OPTION_MASK_ABI_X32) +#define TARGET_BI_ARCH 2 diff --git a/gcc/config/i386/i386.c b/gcc/config/i386/i386.c index 42746e474d3..d58dafc157d 100644 --- a/gcc/config/i386/i386.c +++ b/gcc/config/i386/i386.c @@ -3118,8 +3118,8 @@ ix86_option_override_internal (bool main_args_p) #endif /* Turn off both OPTION_MASK_ABI_64 and OPTION_MASK_ABI_X32 if - TARGET_64BIT is false. */ - if (!TARGET_64BIT) + TARGET_64BIT_DEFAULT is true and TARGET_64BIT is false. */ + if (TARGET_64BIT_DEFAULT && !TARGET_64BIT) ix86_isa_flags &= ~(OPTION_MASK_ABI_64 | OPTION_MASK_ABI_X32); #ifdef TARGET_BI_ARCH else @@ -32938,6 +32938,7 @@ struct expand_vec_perm_d unsigned char perm[MAX_VECT_LEN]; enum machine_mode vmode; unsigned char nelt; + bool one_operand_p; bool testing_p; }; @@ -33038,6 +33039,7 @@ ix86_expand_vector_init_duplicate (bool mmx_ok, enum machine_mode mode, dperm.vmode = mode; dperm.nelt = GET_MODE_NUNITS (mode); dperm.op0 = dperm.op1 = gen_reg_rtx (mode); + dperm.one_operand_p = true; /* Extend to SImode using a paradoxical SUBREG. */ tmp1 = gen_reg_rtx (SImode); @@ -35735,7 +35737,7 @@ expand_vec_perm_blend (struct expand_vec_perm_d *d) rtx target, op0, op1, x; rtx rperm[32], vperm; - if (d->op0 == d->op1) + if (d->one_operand_p) return false; if (TARGET_AVX2 && GET_MODE_SIZE (vmode) == 32) ; @@ -35922,7 +35924,7 @@ expand_vec_perm_vpermil (struct expand_vec_perm_d *d) rtx rperm[8], vperm; unsigned i; - if (!TARGET_AVX || d->vmode != V8SFmode || d->op0 != d->op1) + if (!TARGET_AVX || d->vmode != V8SFmode || !d->one_operand_p) return false; /* We can only permute within the 128-bit lane. */ @@ -35998,7 +36000,7 @@ expand_vec_perm_pshufb (struct expand_vec_perm_d *d) nelt = d->nelt; - if (d->op0 != d->op1) + if (!d->one_operand_p) { if (!TARGET_XOP || GET_MODE_SIZE (d->vmode) != 16) { @@ -36086,7 +36088,7 @@ expand_vec_perm_pshufb (struct expand_vec_perm_d *d) else { eltsz = GET_MODE_SIZE (GET_MODE_INNER (d->vmode)); - if (d->op0 != d->op1) + if (!d->one_operand_p) mask = 2 * nelt - 1; else if (vmode == V16QImode) mask = nelt - 1; @@ -36113,7 +36115,7 @@ expand_vec_perm_pshufb (struct expand_vec_perm_d *d) target = gen_lowpart (vmode, d->target); op0 = gen_lowpart (vmode, d->op0); - if (d->op0 == d->op1) + if (d->one_operand_p) { if (vmode == V16QImode) emit_insn (gen_ssse3_pshufbv16qi3 (target, op0, vperm)); @@ -36145,7 +36147,7 @@ expand_vec_perm_1 (struct expand_vec_perm_d *d) /* Check plain VEC_SELECT first, because AVX has instructions that could match both SEL and SEL+CONCAT, but the plain SEL will allow a memory input where SEL+CONCAT may not. */ - if (d->op0 == d->op1) + if (d->one_operand_p) { int mask = nelt - 1; bool identity_perm = true; @@ -36242,7 +36244,7 @@ expand_vec_perm_1 (struct expand_vec_perm_d *d) return true; /* Recognize interleave style patterns with reversed operands. */ - if (d->op0 != d->op1) + if (!d->one_operand_p) { for (i = 0; i < nelt; ++i) { @@ -36285,7 +36287,7 @@ expand_vec_perm_pshuflw_pshufhw (struct expand_vec_perm_d *d) unsigned i; bool ok; - if (d->vmode != V8HImode || d->op0 != d->op1) + if (d->vmode != V8HImode || !d->one_operand_p) return false; /* The two permutations only operate in 64-bit lanes. */ @@ -36357,6 +36359,7 @@ expand_vec_perm_palignr (struct expand_vec_perm_d *d) gen_lowpart (TImode, d->op0), shift)); d->op0 = d->op1 = d->target; + d->one_operand_p = true; in_order = true; for (i = 0; i < nelt; ++i) @@ -36396,14 +36399,14 @@ expand_vec_perm_interleave2 (struct expand_vec_perm_d *d) if (GET_MODE_SIZE (d->vmode) == 16) { - if (d->op0 == d->op1) + if (d->one_operand_p) return false; } else if (GET_MODE_SIZE (d->vmode) == 32) { if (!TARGET_AVX) return false; - /* For 32-byte modes allow even d->op0 == d->op1. + /* For 32-byte modes allow even d->one_operand_p. The lack of cross-lane shuffling in some instructions might prevent a single insn shuffle. */ dfinal = *d; @@ -36528,11 +36531,11 @@ expand_vec_perm_interleave2 (struct expand_vec_perm_d *d) if (nzcnt == 1) { - gcc_assert (d->op0 == d->op1); + gcc_assert (d->one_operand_p); nonzero_halves[1] = nonzero_halves[0]; same_halves = true; } - else if (d->op0 == d->op1) + else if (d->one_operand_p) { gcc_assert (nonzero_halves[0] == 0); gcc_assert (nonzero_halves[1] == 1); @@ -36571,7 +36574,7 @@ expand_vec_perm_interleave2 (struct expand_vec_perm_d *d) } } } - else if (d->op0 == d->op1) + else if (d->one_operand_p) return false; else if (TARGET_AVX2 && (contents & (q[0] | q[2] | q[4] | q[6])) == contents) @@ -36628,6 +36631,7 @@ expand_vec_perm_interleave2 (struct expand_vec_perm_d *d) } dfinal.op0 = gen_reg_rtx (dfinal.vmode); dfinal.op1 = dfinal.op0; + dfinal.one_operand_p = true; dremap.target = dfinal.op0; /* Test if the final remap can be done with a single insn. For V4SFmode or @@ -36671,7 +36675,7 @@ expand_vec_perm_vpermq_perm_1 (struct expand_vec_perm_d *d) if (!(TARGET_AVX2 && (d->vmode == V32QImode || d->vmode == V16HImode) - && d->op0 == d->op1)) + && d->one_operand_p)) return false; contents[0] = 0; @@ -36699,6 +36703,7 @@ expand_vec_perm_vpermq_perm_1 (struct expand_vec_perm_d *d) dremap.target = gen_reg_rtx (V4DImode); dremap.op0 = gen_lowpart (V4DImode, d->op0); dremap.op1 = dremap.op0; + dremap.one_operand_p = true; for (i = 0; i < 2; ++i) { unsigned int cnt = 0; @@ -36712,6 +36717,7 @@ expand_vec_perm_vpermq_perm_1 (struct expand_vec_perm_d *d) dfinal = *d; dfinal.op0 = gen_lowpart (dfinal.vmode, dremap.target); dfinal.op1 = dfinal.op0; + dfinal.one_operand_p = true; for (i = 0, j = 0; i < nelt; ++i) { if (i == nelt2) @@ -36751,8 +36757,7 @@ expand_vec_perm_vperm2f128 (struct expand_vec_perm_d *d) return false; dsecond = *d; - if (d->op0 == d->op1) - dsecond.op1 = gen_reg_rtx (d->vmode); + dsecond.one_operand_p = false; dsecond.testing_p = true; /* ((perm << 2)|perm) & 0x33 is the vperm2[fi]128 @@ -36821,10 +36826,7 @@ expand_vec_perm_vperm2f128 (struct expand_vec_perm_d *d) vperm2f128 on d->op0 and d->op1. */ dsecond.testing_p = false; dfirst = *d; - if (d->op0 == d->op1) - dfirst.target = dsecond.op1; - else - dfirst.target = gen_reg_rtx (d->vmode); + dfirst.target = gen_reg_rtx (d->vmode); for (i = 0; i < nelt; i++) dfirst.perm[i] = (i & (nelt2 - 1)) + ((perm >> (2 * (i >= nelt2))) & 3) * nelt2; @@ -36845,9 +36847,8 @@ expand_vec_perm_vperm2f128 (struct expand_vec_perm_d *d) return true; } - /* For d->op0 == d->op1 the only useful vperm2f128 permutation - is 0x10. */ - if (d->op0 == d->op1) + /* For one operand, the only useful vperm2f128 permutation is 0x10. */ + if (d->one_operand_p) return false; } @@ -36864,7 +36865,7 @@ expand_vec_perm_interleave3 (struct expand_vec_perm_d *d) unsigned i, nelt; rtx (*gen) (rtx, rtx, rtx); - if (d->op0 == d->op1) + if (d->one_operand_p) return false; if (TARGET_AVX2 && GET_MODE_SIZE (d->vmode) == 32) ; @@ -36947,7 +36948,7 @@ expand_vec_perm_vperm2f128_vblend (struct expand_vec_perm_d *d) if (!TARGET_AVX || TARGET_AVX2 || (d->vmode != V8SFmode && d->vmode != V4DFmode) - || d->op0 != d->op1) + || !d->one_operand_p) return false; dfirst = *d; @@ -36985,6 +36986,7 @@ expand_vec_perm_vperm2f128_vblend (struct expand_vec_perm_d *d) dsecond = *d; dsecond.op0 = dfirst.target; dsecond.op1 = dfirst.target; + dsecond.one_operand_p = true; dsecond.target = gen_reg_rtx (dsecond.vmode); for (i = 0; i < nelt; i++) dsecond.perm[i] = i ^ nelt2; @@ -37009,7 +37011,7 @@ expand_vec_perm_pshufb2 (struct expand_vec_perm_d *d) if (!TARGET_SSSE3 || GET_MODE_SIZE (d->vmode) != 16) return false; - gcc_assert (d->op0 != d->op1); + gcc_assert (!d->one_operand_p); nelt = d->nelt; eltsz = GET_MODE_SIZE (GET_MODE_INNER (d->vmode)); @@ -37064,7 +37066,7 @@ expand_vec_perm_vpshufb2_vpermq (struct expand_vec_perm_d *d) unsigned int i, nelt, eltsz; if (!TARGET_AVX2 - || d->op0 != d->op1 + || !d->one_operand_p || (d->vmode != V32QImode && d->vmode != V16HImode)) return false; @@ -37132,7 +37134,7 @@ expand_vec_perm_vpshufb2_vpermq_even_odd (struct expand_vec_perm_d *d) unsigned int i, nelt, eltsz; if (!TARGET_AVX2 - || d->op0 == d->op1 + || d->one_operand_p || (d->vmode != V32QImode && d->vmode != V16HImode)) return false; @@ -37491,7 +37493,7 @@ expand_vec_perm_broadcast (struct expand_vec_perm_d *d) { unsigned i, elt, nelt = d->nelt; - if (d->op0 != d->op1) + if (!d->one_operand_p) return false; elt = d->perm[0]; @@ -37514,7 +37516,7 @@ expand_vec_perm_vpshufb4_vpermq2 (struct expand_vec_perm_d *d) bool used[4]; if (!TARGET_AVX2 - || d->op0 == d->op1 + || d->one_operand_p || (d->vmode != V32QImode && d->vmode != V16HImode)) return false; @@ -37715,6 +37717,7 @@ ix86_expand_vec_perm_const (rtx operands[4]) perm[i] = ei; } + d.one_operand_p = true; switch (which) { default: @@ -37722,51 +37725,39 @@ ix86_expand_vec_perm_const (rtx operands[4]) case 3: if (!rtx_equal_p (d.op0, d.op1)) - break; - + { + d.one_operand_p = false; + break; + } /* The elements of PERM do not suggest that only the first operand is used, but both operands are identical. Allow easier matching of the permutation by folding the permutation into the single input vector. */ - for (i = 0; i < nelt; ++i) - if (d.perm[i] >= nelt) - d.perm[i] -= nelt; /* FALLTHRU */ - case 1: - d.op1 = d.op0; - break; - case 2: for (i = 0; i < nelt; ++i) - d.perm[i] -= nelt; + d.perm[i] &= nelt - 1; d.op0 = d.op1; break; + + case 1: + d.op1 = d.op0; + break; } if (ix86_expand_vec_perm_const_1 (&d)) return true; - /* If the mask says both arguments are needed, but they are the same, - the above tried to expand with d.op0 == d.op1. If that didn't work, - retry with d.op0 != d.op1 as that is what testing has been done with. */ - if (which == 3 && d.op0 == d.op1) + /* If the selector says both arguments are needed, but the operands are the + same, the above tried to expand with one_operand_p and flattened selector. + If that didn't work, retry without one_operand_p; we succeeded with that + during testing. */ + if (which == 3 && d.one_operand_p) { - rtx seq; - bool ok; - + d.one_operand_p = false; memcpy (d.perm, perm, sizeof (perm)); - d.op1 = gen_reg_rtx (d.vmode); - start_sequence (); - ok = ix86_expand_vec_perm_const_1 (&d); - seq = get_insns (); - end_sequence (); - if (ok) - { - emit_move_insn (d.op1, d.op0); - emit_insn (seq); - return true; - } + return ix86_expand_vec_perm_const_1 (&d); } return false; @@ -37780,7 +37771,7 @@ ix86_vectorize_vec_perm_const_ok (enum machine_mode vmode, { struct expand_vec_perm_d d; unsigned int i, nelt, which; - bool ret, one_vec; + bool ret; d.vmode = vmode; d.nelt = nelt = GET_MODE_NUNITS (d.vmode); @@ -37817,17 +37808,17 @@ ix86_vectorize_vec_perm_const_ok (enum machine_mode vmode, d.perm[i] -= nelt; /* Check whether the mask can be applied to the vector type. */ - one_vec = (which != 3); + d.one_operand_p = (which != 3); /* Implementable with shufps or pshufd. */ - if (one_vec && (d.vmode == V4SFmode || d.vmode == V4SImode)) + if (d.one_operand_p && (d.vmode == V4SFmode || d.vmode == V4SImode)) return true; /* Otherwise we have to go through the motions and see if we can figure out how to generate the requested permutation. */ d.target = gen_raw_REG (d.vmode, LAST_VIRTUAL_REGISTER + 1); d.op1 = d.op0 = gen_raw_REG (d.vmode, LAST_VIRTUAL_REGISTER + 2); - if (!one_vec) + if (!d.one_operand_p) d.op1 = gen_raw_REG (d.vmode, LAST_VIRTUAL_REGISTER + 3); start_sequence (); @@ -37848,6 +37839,7 @@ ix86_expand_vec_extract_even_odd (rtx targ, rtx op0, rtx op1, unsigned odd) d.op1 = op1; d.vmode = GET_MODE (targ); d.nelt = nelt = GET_MODE_NUNITS (d.vmode); + d.one_operand_p = false; d.testing_p = false; for (i = 0; i < nelt; ++i) diff --git a/gcc/config/i386/sse.md b/gcc/config/i386/sse.md index 96e43a22ca9..b63d774e43f 100644 --- a/gcc/config/i386/sse.md +++ b/gcc/config/i386/sse.md @@ -1175,14 +1175,14 @@ (parallel [(const_int 0)])) (vec_select:DF (match_dup 1) (parallel [(const_int 1)]))) (plusminus:DF - (vec_select:DF (match_dup 1) (parallel [(const_int 2)])) - (vec_select:DF (match_dup 1) (parallel [(const_int 3)])))) - (vec_concat:V2DF - (plusminus:DF (vec_select:DF (match_operand:V4DF 2 "nonimmediate_operand" "xm") (parallel [(const_int 0)])) - (vec_select:DF (match_dup 2) (parallel [(const_int 1)]))) + (vec_select:DF (match_dup 2) (parallel [(const_int 1)])))) + (vec_concat:V2DF + (plusminus:DF + (vec_select:DF (match_dup 1) (parallel [(const_int 2)])) + (vec_select:DF (match_dup 1) (parallel [(const_int 3)]))) (plusminus:DF (vec_select:DF (match_dup 2) (parallel [(const_int 2)])) (vec_select:DF (match_dup 2) (parallel [(const_int 3)]))))))] diff --git a/gcc/config/ia64/ia64.c b/gcc/config/ia64/ia64.c index 98a6120c975..4b8a6929b1e 100644 --- a/gcc/config/ia64/ia64.c +++ b/gcc/config/ia64/ia64.c @@ -740,9 +740,6 @@ ia64_handle_model_attribute (tree *node, tree name, tree args, return NULL_TREE; } -/* The section must have global and overlaid attributes. */ -#define SECTION_VMS_OVERLAY SECTION_MACH_DEP - /* Part of the low level implementation of DEC Ada pragma Common_Object which enables the shared use of variables stored in overlaid linker areas corresponding to the use of Fortran COMMON. */ @@ -753,24 +750,18 @@ ia64_vms_common_object_attribute (tree *node, tree name, tree args, bool *no_add_attrs) { tree decl = *node; - tree id, val; - if (! DECL_P (decl)) - abort (); + tree id; + + gcc_assert (DECL_P (decl)); DECL_COMMON (decl) = 1; id = TREE_VALUE (args); - if (TREE_CODE (id) == IDENTIFIER_NODE) - val = build_string (IDENTIFIER_LENGTH (id), IDENTIFIER_POINTER (id)); - else if (TREE_CODE (id) == STRING_CST) - val = id; - else + if (TREE_CODE (id) != IDENTIFIER_NODE && TREE_CODE (id) != STRING_CST) { - warning (OPT_Wattributes, - "%qE attribute requires a string constant argument", name); + error ("%qE attribute requires a string constant argument", name); *no_add_attrs = true; return NULL_TREE; } - DECL_SECTION_NAME (decl) = val; return NULL_TREE; } @@ -783,50 +774,31 @@ ia64_vms_output_aligned_decl_common (FILE *file, tree decl, const char *name, { tree attr = DECL_ATTRIBUTES (decl); - /* As common_object attribute set DECL_SECTION_NAME check it before - looking up the attribute. */ - if (DECL_SECTION_NAME (decl) && attr) + if (attr) attr = lookup_attribute ("common_object", attr); - else - attr = NULL_TREE; - - if (!attr) - { - /* Code from elfos.h. */ - fprintf (file, "%s", COMMON_ASM_OP); - assemble_name (file, name); - fprintf (file, ","HOST_WIDE_INT_PRINT_UNSIGNED",%u\n", - size, align / BITS_PER_UNIT); - } - else + if (attr) { - ASM_OUTPUT_ALIGN (file, floor_log2 (align / BITS_PER_UNIT)); - ASM_OUTPUT_LABEL (file, name); - ASM_OUTPUT_SKIP (file, size ? size : 1); - } -} + tree id = TREE_VALUE (TREE_VALUE (attr)); + const char *name; -/* Definition of TARGET_ASM_NAMED_SECTION for VMS. */ + if (TREE_CODE (id) == IDENTIFIER_NODE) + name = IDENTIFIER_POINTER (id); + else if (TREE_CODE (id) == STRING_CST) + name = TREE_STRING_POINTER (id); + else + abort (); -void -ia64_vms_elf_asm_named_section (const char *name, unsigned int flags, - tree decl) -{ - if (!(flags & SECTION_VMS_OVERLAY)) - { - default_elf_asm_named_section (name, flags, decl); - return; + fprintf (file, "\t.vms_common\t\"%s\",", name); } - if (flags != (SECTION_VMS_OVERLAY | SECTION_WRITE)) - abort (); + else + fprintf (file, "%s", COMMON_ASM_OP); - if (flags & SECTION_DECLARED) - { - fprintf (asm_out_file, "\t.section\t%s\n", name); - return; - } + /* Code from elfos.h. */ + assemble_name (file, name); + fprintf (file, ","HOST_WIDE_INT_PRINT_UNSIGNED",%u", + size, align / BITS_PER_UNIT); - fprintf (asm_out_file, "\t.section\t%s,\"awgO\"\n", name); + fputc ('\n', file); } static void @@ -10536,12 +10508,6 @@ ia64_section_type_flags (tree decl, const char *name, int reloc) || strncmp (name, ".gnu.linkonce.sb.", 17) == 0) flags = SECTION_SMALL; -#if TARGET_ABI_OPEN_VMS - if (decl && DECL_ATTRIBUTES (decl) - && lookup_attribute ("common_object", DECL_ATTRIBUTES (decl))) - flags |= SECTION_VMS_OVERLAY; -#endif - flags |= default_section_type_flags (decl, name, reloc); return flags; } diff --git a/gcc/config/ia64/vms.h b/gcc/config/ia64/vms.h index 11f017663b5..3e81d769897 100644 --- a/gcc/config/ia64/vms.h +++ b/gcc/config/ia64/vms.h @@ -121,9 +121,6 @@ STATIC func_ptr __CTOR_LIST__[1] \ #undef TARGET_VALID_POINTER_MODE #define TARGET_VALID_POINTER_MODE ia64_vms_valid_pointer_mode -#undef TARGET_ASM_NAMED_SECTION -#define TARGET_ASM_NAMED_SECTION ia64_vms_elf_asm_named_section - /* Define this macro if it is advisable to hold scalars in registers in a wider mode than that declared by the program. In such cases, the value is constrained to be within the bounds of the declared diff --git a/gcc/config/sh/sh.c b/gcc/config/sh/sh.c index 19973005be7..3e85fcf3e6c 100644 --- a/gcc/config/sh/sh.c +++ b/gcc/config/sh/sh.c @@ -6487,7 +6487,9 @@ push_regs (HARD_REG_SET *mask, int interrupt_handler) use_movml = true; } - if (use_movml) + if (sh_cfun_resbank_handler_p ()) + ; /* Do nothing. */ + else if (use_movml) { rtx x, mem, reg, set; rtx sp_reg = gen_rtx_REG (SImode, STACK_POINTER_REGNUM); @@ -7485,7 +7487,9 @@ sh_expand_epilogue (bool sibcall_p) use_movml = true; } - if (use_movml) + if (sh_cfun_resbank_handler_p ()) + ; /* Do nothing. */ + else if (use_movml) { rtx sp_reg = gen_rtx_REG (SImode, STACK_POINTER_REGNUM); diff --git a/gcc/config/vms/make-crtlmap.awk b/gcc/config/vms/make-crtlmap.awk index 6f82dee7aa8..63be6e708ab 100644 --- a/gcc/config/vms/make-crtlmap.awk +++ b/gcc/config/vms/make-crtlmap.awk @@ -40,13 +40,13 @@ BEGIN { print "{ \"" $1 "\", " if (NF == 1) print "0 }" - else if (NF == 2) - printf "VMS_CRTL_" $2 " }" - else if (NF == 3) - printf "VMS_CRTL_" $2 " | VMS_CRTL_" $3 " }" else - # To be fixed. - exit 1 + { + printf "VMS_CRTL_" $2 + for (i = 3; i <= NF; i++) + printf " | VMS_CRTL_" $i + printf " }" + } } END { diff --git a/gcc/config/vms/t-vms b/gcc/config/vms/t-vms index 4e20bde8070..f2161b7861b 100644 --- a/gcc/config/vms/t-vms +++ b/gcc/config/vms/t-vms @@ -34,3 +34,8 @@ vms-c.o: $(srcdir)/config/vms/vms-c.c $(CONFIG_H) $(SYSTEM_H) coretypes.h \ $(TM_P_H) $(COMPILER) -c $(ALL_COMPILERFLAGS) $(ALL_CPPFLAGS) $(INCLUDES) \ $(PREPROCESSOR_DEFINES) $< -o $@ + +vms-f.o: $(srcdir)/config/vms/vms-f.c $(CONFIG_H) $(SYSTEM_H) coretypes.h \ + $(TM_H) + $(COMPILER) -c $(ALL_COMPILERFLAGS) $(ALL_CPPFLAGS) $(INCLUDES) \ + $(PREPROCESSOR_DEFINES) $< -o $@ diff --git a/gcc/config/vms/vms-c.c b/gcc/config/vms/vms-c.c index 6f8a1cf6138..09172b261ab 100644 --- a/gcc/config/vms/vms-c.c +++ b/gcc/config/vms/vms-c.c @@ -120,7 +120,9 @@ vms_pragma_nomember_alignment (cpp_reader *pfile ATTRIBUTE_UNUSED) if (arg[0] == '_' && arg[1] == '_') arg += 2; - if (strcmp (arg, "word") == 0) + if (strcmp (arg, "byte") == 0) + maximum_field_alignment = 1 * BITS_PER_UNIT; + else if (strcmp (arg, "word") == 0) maximum_field_alignment = 2 * BITS_PER_UNIT; else if (strcmp (arg, "longword") == 0) maximum_field_alignment = 4 * BITS_PER_UNIT; @@ -453,6 +455,9 @@ vms_c_register_includes (const char *sysroot, void vms_c_common_override_options (void) { + /* Allow variadic functions without parameters (as declared in starlet). */ + flag_allow_parameterless_variadic_functions = TRUE; + /* Initialize c_default_pointer_mode. */ switch (flag_vms_pointer_size) { diff --git a/gcc/config/vms/vms-crtlmap.map b/gcc/config/vms/vms-crtlmap.map index d98afacc17f..e80e2afe493 100644 --- a/gcc/config/vms/vms-crtlmap.map +++ b/gcc/config/vms/vms-crtlmap.map @@ -12,130 +12,483 @@ # - Comment lines start with '#' in the first column. # - map lines consist in an identifier optionnaly followed by at most 2 # space-separated flags. -# Flags are: -# FLOAT: will be prefixed by 't'/'g'/'d'. -# 64: There is a 64-bit variant. -# GLOBAL: name will be prefixed by ga_ -# BSD44: name will be prefixed by __bsd44__. -# LDBL: a 'x' prefix will be added if 128 bit long doubles are enabled. -# MALLOC: malloc related function. +# Flags are described in vms.c (prefixed by VMS_CRTL_). # # Keep entries alpha-sorted - this is enforced by the awk script. # +__32_getpwent +__32_getpwnam +__32_getpwuid +__32_sigaction __32_signal __32_ssignal +__64_getpwent +__64_getpwnam +__64_getpwuid +__64_sigaction __64_signal __64_ssignal +__assert +__dl__xpv +__freeaddrinfo32 +__freeaddrinfo64 +__getaddrinfo32 +__getaddrinfo64 +__getaddrinfo_compat4332 +__getaddrinfo_compat4364 +__getgrent64 +__getgrgid64 +__getgrgid_r64 +__getgrnam64 +__getgrnam_r64 +__lgamma FLOAT64 FLOATV2 +__lgammaf FLOAT32 FLOATV2 +__lgammal FLOAT64 FLOAT128 FLOATV2 +__long_gid___32_getpwnam +__long_gid___32_getpwuid +__long_gid___64_getpwnam +__long_gid___64_getpwuid +__long_gid_access +__long_gid_chmod +__long_gid_chown +__long_gid_fchmod +__long_gid_fchown +__long_gid_fstat +__long_gid_ftw +__long_gid_getegid +__long_gid_geteuid +__long_gid_getgid +__long_gid_getgroups +__long_gid_getpwnam +__long_gid_getpwnam_r 64 +__long_gid_getpwuid +__long_gid_getpwuid_r 64 +__long_gid_getuid +__long_gid_lchown +__long_gid_lstat +__long_gid_setgid +__long_gid_setuid +__long_gid_stat +__non_utc_ftw +__nw__xui +__off64_fcntl +__off64_fseeko +__off64_fstat +__off64_ftello +__off64_ftruncate +__off64_ftw +__off64_long_gid_fstat +__off64_long_gid_ftw +__off64_long_gid_lstat +__off64_long_gid_stat +__off64_lseek +__off64_lstat +__off64_mmap 64 +__off64_non_utc_ftw +__off64_pread +__off64_pwrite +__off64_stat +__off64_truncate +__off64_utc_fstat +__off64_utc_lstat +__off64_utc_stat +__pdam_wcsftime +__pdam_wcstok 64 __posix__exit __posix_exit __posix_kill __posix_long_gid_kill +__posix_system +__posix_wait +__read_rnd +__recvmsg32 BSD44 +__recvmsg64 BSD44 +__sendmsg32 BSD44 +__sendmsg64 BSD44 +__short_gid___32_getpwent +__short_gid___64_getpwent +__short_gid_getpwent +__std_fstat +__std_ftw +__std_lstat +__std_stat +__unix_geteuid __unix_getuid +__utc_ctime +__utc_ctime_r __utc_fstat +__utc_ftime +__utc_gmtime +__utc_gmtime_r __utc_localtime __utc_localtime_r __utc_lstat +__utc_mktime +__utc_pdam_wcsftime __utc_stat __utc_strftime __utc_time +__utc_utime +__utc_utimes +__utc_wcsftime __utctz_gmtime +__utctz_gmtime_r __utctz_localtime __utctz_localtime_r +__vms_pclose +__vms_wait3 +__vms_wait4 +__vms_waitpid +__writev32 +__writev64 +_exit +_fstat +a64l abort abs -accept +accept BSD44 access -acos FLOAT +acos FLOAT64 DPML +acosd FLOAT64_VAXD DPML +acosdl FLOAT64_VAXD +acosh FLOAT64_VAXD DPML +acoshl FLOAT64_VAXD +acosl FLOAT64_VAXD alarm asctime asctime_r -asin FLOAT -atan FLOAT -atan2 FLOAT +asin FLOAT64 DPML +asind FLOAT64_VAXD DPML +asindl FLOAT64_VAXD +asinh FLOAT64_VAXD DPML +asinhl FLOAT64_VAXD +asinl FLOAT64_VAXD +atan FLOAT64 DPML +atan2 FLOAT64 DPML +atan2l FLOAT64_VAXD +atand FLOAT64_VAXD DPML +atand2 FLOAT64_VAXD DPML +atand2l FLOAT64_VAXD +atandl FLOAT64_VAXD +atanh FLOAT64_VAXD DPML +atanhl FLOAT64_VAXD +atanl FLOAT64_VAXD atexit -atof FLOAT +atof FLOAT64 atoi atol atoll atoq -basename 64 +basename 64 bcmp bcopy -bsearch 64 +bind BSD44 +box +# brk +bsd_mh GA +bsd_waddbytes +bsd_waddstr +bsearch 64 +btowc bzero -calloc 64 MALLOC -ceil FLOAT +cabs FLOAT64 FLOATV2 +cabsf FLOAT32 FLOATV2 +cabsl FLOAT64 FLOAT128 FLOATV2 +cacos DPML +cacosh DPML +calloc 64 MALLOC +calloc_opt +carg DPML +casin DPML +casinh DPML +catan DPML +catanh DPML +catclose +catgets 64 +catopen +cbrt FLOAT64_VAXD +cbrtl FLOAT64_VAXD +ccos DPML +ccosh DPML +cdiv DPML +ceil FLOAT64 DPML +ceill FLOAT64_VAXD +cexp DPML +cfree +cfree_opt chdir chmod chown clearerr +clearerr_unlocked clock +clock_getres +clock_gettime +clock_settime +clog DPML close closedir -connect -cos FLOAT -ctermid 64 +cmul DPML +cols GA +confstr +connect BSD44 +copysign FLOAT64_VAXD DPML +copysignl FLOAT64_VAXD +cos FLOAT64 DPML +cosd FLOAT64_VAXD DPML +cosdl FLOAT64_VAXD +cosh FLOAT64 DPML +coshl FLOAT64_VAXD +cosl FLOAT64_VAXD +cot FLOAT64_VAXD DPML +cotd FLOAT64_VAXD DPML +cotdl FLOAT64_VAXD +cotl FLOAT64_VAXD +cpow DPML +creat +crtl_init +crypt 64 +csin DPML +csinh DPML +csqrt DPML +ctan DPML +ctanh DPML +ctermid 64 ctime +ctime_r +cuserid 64 +daylight GL +delete +delwin +difftime FLOAT64 +dirname 64 +div dlclose dlerror dlopen dlsym +drand48 FLOAT64 +drem DPML dup dup2 -environ GLOBAL +ecvt FLOAT64 +encrypt +endgrent +endhostent +endnetent +endprotoent +endpwent +endservent +endwin +environ GA +erand48 FLOAT64 +erf FLOAT64_VAXD DPML +erfc FLOAT64_VAXD DPML +erfcl FLOAT64_VAXD +erfl FLOAT64_VAXD +errno GA +execl +execle +execlp execv execve execvp exit -exp FLOAT -fabs FLOAT +exp FLOAT64 DPML +expl FLOAT64_VAXD +expm1 FLOAT64_VAXD DPML +expm1l FLOAT64_VAXD +fabs FLOAT64 DPML +fabsl FLOAT64_VAXD +fchmod +fchown fclose fcntl +fcvt FLOAT64 fdopen feof +feof_unlocked ferror +ferror_unlocked fflush ffs fgetc -fgetname 64 MALLOC -fgets 64 +fgetc_unlocked +fgetname 64 +fgetpos +fgets 64 +fgetwc +fgetws 64 fileno -floor FLOAT +finite FLOAT64_VAXD DPML +finitel FLOAT64_VAXD +flockfile +floor FLOAT64 DPML +floorl FLOAT64_VAXD +fmod FLOAT64 DPML NODPML FLOATV2 +fmodf FLOAT32 NODPML FLOATV2 +fmodl FLOAT64 FLOAT128 NODPML FLOATV2 +# fnmatch # Overridden by libiberty. fopen +fp_class FLOAT64_VAXD DPML +fp_classl FLOAT64_VAXD fpathconf -fprintf FLOAT LDBL +fprintf FLOAT64 FLOAT128 +fprintf__cf FLOAT64 FLOAT128 fputc +fputc_unlocked fputs +fputwc +fputws fread free +free_opt +freeaddrinfo +freehostent freopen -frexp FLOAT +frexp FLOAT64 DPML +frexpl FLOAT64_VAXD +fscanf FLOAT64 FLOAT128 fseek +fseeko +fsetpos +fstat +fstatvfs +fsync ftell +ftello +ftime +ftruncate +ftrylockfile +ftw +funlockfile +fwait +fwide +fwprintf FLOAT64 FLOAT128 fwrite +fwscanf FLOAT64 FLOAT128 +gai_strerror +gamma FLOAT64 FLOATV2 +gammaf FLOAT32 FLOATV2 +gammal FLOAT64 FLOAT128 FLOATV2 +gbsd_mvprintw +gbsd_mvscanw +gbsd_mvwprintw +gbsd_mvwscanw +gbsd_printw +gbsd_scanw +gbsd_wprintw +gbsd_wscanw +gcvt FLOAT64 64 +get_errno_addr +get_vms_errno_addr +getaddrinfo +getaddrinfo_compat43 getc +getc_unlocked getchar -getcwd 64 +getchar_unlocked +getclock +getcwd 64 +getdtablesize getegid getenv geteuid getgid -gethostbyaddr -gethostbyname -getname +getgrent +getgrgid +getgrgid_r +getgrnam +getgrnam_r +getgroups +gethostaddr +gethostbyaddr BSD44 +gethostbyname BSD44 +gethostent +gethostname +getipnodebyaddr +getipnodebyname +getitimer +getlogin +getlogin_r +getname 64 +getnameinfo +getnetbyaddr +getnetbyname +getnetent +getopt 32ONLY getpagesize +getpeername BSD44 +getpgid +getpgrp getpid +getppid +getprotobyname +getprotobynumber +getprotoent getpwent getpwnam +getpwnam_r 64 +getpwuid +getpwuid_r 64 +gets 64 getservbyname getservbyport +getservent +getsid +getsockname BSD44 getsockopt gettimeofday getuid +getw +getwc +getwchar +glob 64 +globfree 64 gmtime +gmtime_r +gsignal +herror +hostalias +hstrerror +htonl htons +hypot FLOAT64 DPML NODPML FLOATV2 +hypotf FLOAT32 NODPML FLOATV2 +hypotl FLOAT64 FLOAT128 NODPML FLOATV2 iconv -index 64 +iconv_close +iconv_open +if_freenameindex +if_indextoname +if_nameindex +if_nametoindex +ilogb DPML +index 64 +inet6_opt_append +inet6_opt_find +inet6_opt_finish +inet6_opt_get_val +inet6_opt_init +inet6_opt_next +inet6_opt_set_val +inet6_rth_add +inet6_rth_getaddr +inet6_rth_init +inet6_rth_reverse +inet6_rth_segments +inet6_rth_space +inet_addr +inet_aton +inet_lnaof +inet_makeaddr +inet_netof +inet_network +inet_ntoa +inet_ntop +inet_pton +initscr +initstate ioctl isalnum isalpha @@ -146,128 +499,432 @@ iscntrl isdigit isgraph islower +isnan FLOAT64_VAXD DPML +isnanl FLOAT64_VAXD isprint ispunct isspace isupper +iswalnum +iswalpha +iswcntrl +iswctype +iswdigit +iswgraph +iswlower +iswprint +iswpunct +iswspace +iswupper +iswxdigit isxdigit +j0 FLOAT64_VAXD DPML +j0l FLOAT64_VAXD +j1 FLOAT64_VAXD DPML +j1l FLOAT64_VAXD +jn FLOAT64_VAXD DPML +jnl FLOAT64_VAXD +jrand48 kill -ldexp FLOAT +l64a +l64a_r +labs +lchown +lcong48 +ldexp FLOAT64 DPML +ldexpl FLOAT64_VAXD +ldiv +lgamma FLOAT64 DPML NODPML FLOATV2 +lgammaf FLOAT32 NODPML FLOATV2 +lgammal FLOAT64 FLOAT128 NODPML FLOATV2 +lines GA +link +listen +llabs +lldiv locale localeconv localtime localtime_r -log FLOAT -log10 FLOAT +# ln -> log DPML +log FLOAT64 FLOATV2 +log10 FLOAT64 DPML +log10l FLOAT64_VAXD +log1p FLOAT64_VAXD DPML +log1pl FLOAT64_VAXD +log2 FLOAT64_VAXD DPML +log2l FLOAT64_VAXD +logb FLOAT64_VAXD DPML +logbl FLOAT64_VAXD +logf FLOAT32 FLOATV2 +logl FLOAT64 FLOAT128 FLOATV2 longjmp +longname 64 +lrand48 +lround DPML lseek -malloc 64 MALLOC -mbstowcs 64 -memchr 64 +lstat +lwait +malloc 64 MALLOC +malloc_opt +mblen +mbrlen +mbrtowc +mbsinit +mbsrtowcs 64 +mbstowcs +mbtowc +memccpy 64 +memchr 64 memcmp -memcpy 64 -memmove 64 -memset 64 +memcpy 64 +memmove 64 +memset 64 mkdir mkstemp -mktemp 64 -mmap 64 +mktemp 64 +mktime +mmap 64 +modf FLOAT64 DPML +modfl FLOAT64_VAXD +mprotect +mrand48 +msync munmap +mvwaddstr +mvwin nanosleep +newwin +nextafter FLOAT64_VAXD DPML +nextafterl FLOAT64_VAXD +nice +nint FLOAT64_VAXD DPML +nintl FLOAT64_VAXD nl_langinfo +nrand48 +ntohl +ntohs open opendir +optarg GA 32ONLY +opterr GL 32ONLY +optind GL 32ONLY +optopt GL 32ONLY +overlay +overwrite pathconf +pause pclose perror pipe +poll popen -pow FLOAT -printf FLOAT LDBL +# pow DPML version ??? +pow FLOAT64 FLOATV2 +powf FLOAT32 FLOATV2 +powl FLOAT64 FLOAT128 FLOATV2 +pread +printf FLOAT64 FLOAT128 +printf__cf FLOAT64 FLOAT128 +printw FLOAT64 FLOAT128 putc +putc_unlocked putchar +putchar_unlocked putenv puts -qsort 64 +putw +putwc +putwchar +pwrite +qabs +qdiv +qsort 64 raise +rand +rand_r random read readdir -realloc 64 MALLOC +readdir_r 64 +readlink +readv 64 +realloc 64 MALLOC +realloc_opt +realpath 64 +record_read recv -recvfrom -recvmsg BSD44 64 +recvfrom BSD44 +recvmsg BSD44 +remainder DPML remove rename rewind -rindex 64 +rewinddir +rindex 64 +rint FLOAT64_VAXD DPML +rintl FLOAT64_VAXD rmdir -scanf FLOAT LDBL +rtl_private +# sbrk # Makes libiberty/xmalloc.c fails to build. +scalb FLOAT64_VAXD DPML +scalbl FLOAT64_VAXD +scanf FLOAT64 FLOAT128 +scanw FLOAT64 FLOAT128 +scroll +seed48 +seekdir select send -sendmsg BSD44 64 -sendto +sendmsg BSD44 +sendto BSD44 +set_new_handler__xpxv_v setbuf setenv +seteuid +setgid +setgrent +sethostent +setitimer +setkey setlocale +setnetent +setpgid +setpgrp +setprotoent setpwent +setregid +setreuid +setservent +setsid setsockopt +setstate +setuid setvbuf +shm_open +shm_unlink +shutdown +sigaction +sigaddset +sigblock +sigdelset +sigemptyset +sigfillset +sighold +sigignore +sigismember siglongjmp +sigmask signal +signgam GL +sigpause +sigpending +sigprocmask +sigrelse sigsetjmp sigsetmask -sin FLOAT +sigstack +sigsuspend +sigtimedwait +sigvec +sigwait +sigwaitinfo +sin FLOAT64 DPML +sincos DPML +sincosd DPML +sind FLOAT64_VAXD DPML +sindl FLOAT64_VAXD +sinh FLOAT64 DPML +sinhcosh DPML +sinhl FLOAT64_VAXD +sinl FLOAT64_VAXD sleep -snprintf FLOAT LDBL +snprintf FLOAT64 FLOAT128 socket -sprintf FLOAT LDBL -sqrt FLOAT -sscanf FLOAT LDBL +socketpair +sprintf FLOAT64 FLOAT128 +sprintf__cf FLOAT64 FLOAT128 +sqrt FLOAT64 DPML +sqrtl FLOAT64_VAXD +srand +srand48 +srandom +sscanf FLOAT64 FLOAT128 +ssignal stat +statvfs strcasecmp -strcat 64 -strchr 64 +strcat 64 +strchr 64 strcmp -strcpy 64 +strcoll +strcpy 64 strcspn -strdup 64 MALLOC +strdup 64 MALLOC strerror +strfmon FLOAT64 +strftime strlen strncasecmp -strncat 64 +strncat 64 strncmp -strncpy 64 -strpbrk 64 -strrchr 64 +strncpy 64 +strnlen +strpbrk 64 +strptime 64 +strptime_xpg4 +strrchr 64 +strsep 64 strspn -strstr 64 -strtod 64 FLOAT -strtok 64 MALLOC -strtok_r 64 MALLOC -strtol 64 -strtoul 64 +strstr 64 +strtod FLOAT64 64 +strtok 64 +strtok_r 64 +strtol 64 +strtoll 64 +strtoq 64 +strtoul 64 +strtoull 64 +strtouq 64 +strxfrm +subwin +swab +swprintf FLOAT64 FLOAT128 +swscanf FLOAT64 FLOAT128 +symlink +sys_errlist GA +sys_nerr GL sysconf system -tan FLOAT +tan FLOAT64 DPML +tand FLOAT64_VAXD DPML +tandl FLOAT64_VAXD +tanh FLOAT64 DPML +tanhl FLOAT64_VAXD +tanl FLOAT64_VAXD +telldir tempnam +tgamma DPML time times +timezone GL tmpfile -tmpnam 64 +tmpnam 64 +toascii tolower +touchwin toupper +towctrans +towlower +towupper +trunc FLOAT64_VAXD DPML +truncate +truncl FLOAT64_VAXD ttyname +ttyname_r +tzname GA +tzset +ualarm umask +uname ungetc +ungetwc unlink +unordered FLOAT64_VAXD DPML +unorderedl FLOAT64_VAXD +unsetenv usleep utime -vfprintf FLOAT LDBL -vprintf FLOAT LDBL -vsnprintf FLOAT LDBL -vsprintf FLOAT LDBL +utimes +vaxc$calloc_opt +vaxc$cfree_opt +vaxc$crtl_init +vaxc$errno GA +vaxc$free_opt +vaxc$get_sdc +vaxc$malloc_opt +vaxc$realloc_opt +vfprintf FLOAT64 FLOAT128 +vfscanf FLOAT64 FLOAT128 +vfwprintf FLOAT64 FLOAT128 +vfwscanf FLOAT64 FLOAT128 +vprintf FLOAT64 FLOAT128 +vscanf FLOAT64 FLOAT128 +vsnprintf FLOAT64 FLOAT128 +vsprintf FLOAT64 FLOAT128 +vsscanf FLOAT64 FLOAT128 +vswprintf FLOAT64 FLOAT128 +vswscanf FLOAT64 FLOAT128 +vwprintf FLOAT64 FLOAT128 +vwscanf FLOAT64 FLOAT128 +waddch +waddstr wait +wait3 +wait4 waitpid +wclear +wclrattr +wclrtobot +wclrtoeol +wcrtomb +wcscat 64 +wcschr 64 +wcscmp +wcscoll +wcscpy 64 +wcscspn +wcsftime +wcslen +wcsncat 64 +wcsncmp +wcsncpy 64 +wcspbrk 64 +wcsrchr 64 +wcsrtombs 64 +wcsspn +wcsstr 64 +wcstod FLOAT64 64 +wcstok 64 +wcstol 64 +wcstombs +wcstoul 64 +wcswcs 64 wcswidth +wcsxfrm +wctob +wctomb +wctrans +wctype +wcwidth +wdelch +wdeleteln +werase +wgetch +wgetstr +winch +winsch +winsertln +winsstr +wmemchr 64 +wmemcmp +wmemcpy 64 +wmemmove 64 +wmemset 64 +wmove +wprintf FLOAT64 FLOAT128 +wprintw FLOAT64 FLOAT128 +wrefresh write +writev +wscanf FLOAT64 FLOAT128 +wscanw FLOAT64 FLOAT128 +wsetattr +wstandend +wstandout +y0 FLOAT64_VAXD DPML +y0l FLOAT64_VAXD +y1 FLOAT64_VAXD DPML +y1l FLOAT64_VAXD +yn FLOAT64_VAXD DPML +ynl FLOAT64_VAXD diff --git a/gcc/config/vms/vms-f.c b/gcc/config/vms/vms-f.c new file mode 100644 index 00000000000..3c3ba414380 --- /dev/null +++ b/gcc/config/vms/vms-f.c @@ -0,0 +1,31 @@ +/* VMS support needed only by Fortran frontends. + Copyright (C) 2012 Free Software Foundation, Inc. + +This file is part of GCC. + +GCC is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 3, or (at your option) +any later version. + +GCC is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GCC; see the file COPYING3. If not see +<http://www.gnu.org/licenses/>. */ + +#include "config.h" +#include "system.h" +#include "coretypes.h" +#include "tm.h" + +void +vms_c_register_includes (const char *sysroot ATTRIBUTE_UNUSED, + const char *iprefix ATTRIBUTE_UNUSED, + int stdinc ATTRIBUTE_UNUSED) +{ + /* No-op for fortran. */ +} diff --git a/gcc/config/vms/vms.c b/gcc/config/vms/vms.c index a85fb3fb209..d4ebd18730b 100644 --- a/gcc/config/vms/vms.c +++ b/gcc/config/vms/vms.c @@ -26,6 +26,8 @@ along with GCC; see the file COPYING3. If not see #include "ggc.h" #include "target.h" #include "output.h" +#include "tm.h" +#include "dwarf2out.h" /* Correlation of standard CRTL names with DECCRTL function names. */ @@ -36,19 +38,46 @@ along with GCC; see the file COPYING3. If not see /* If long pointer are enabled, use _NAME64 instead. */ #define VMS_CRTL_64 (1 << 1) -/* Use tNAME instead. To be applied after the previous rule. */ -#define VMS_CRTL_FLOAT (1 << 2) +/* Prepend s/f before the name. To be applied after the previous rule. + use 's' for S float, 'f' for IEEE 32. */ +#define VMS_CRTL_FLOAT32 (1 << 2) -/* Prepend __bsd44__ before the name. To be applied after the P64 - rule. */ -#define VMS_CRTL_BSD44 (1 << 3) +/* Prepend t/g/d before the name. To be applied after the previous rule. + use 'g' for VAX G float, 'd' for VAX D float, 't' for IEEE 64. */ +#define VMS_CRTL_FLOAT64 (1 << 3) + +/* Prepend d before the name, only if using VAX fp. */ +#define VMS_CRTL_FLOAT64_VAXD (1 << 4) /* Prepend x before the name for if 128 bit long doubles are enabled. This concern mostly 'printf'-like functions. */ -#define VMS_CRTL_LDBL (1 << 4) +#define VMS_CRTL_FLOAT128 (1 << 5) + +/* From xxx, create xxx, xxxf, xxxl using MATH$XXX_T, MATH$XXX_S + and MATH$XXX{_X} if DPML is used. */ +#define VMS_CRTL_DPML (1 << 6) -/* Prepend ga_ for global data. */ -#define VMS_CRTL_GLOBAL (1 << 5) +/* Together with DPML, it means that all variant (ie xxx, xxxf and xxxl) are + overridden by decc. Without DPML, it means this is a variant (ie xxxf + or xxxl) of a function. */ +#define VMS_CRTL_NODPML (1 << 7) + +/* Prepend __bsd44_ before the name. To be applied after the P64 + rule. */ +#define VMS_CRTL_BSD44 (1 << 8) + +/* Define only in 32 bits mode, as this has no 64 bit variants. + Concerns getopt/getarg. */ +#define VMS_CRTL_32ONLY (1 << 9) + +/* GLobal data prefix (ga_, gl_...) */ +#define VMS_CRTL_G_MASK (7 << 10) +#define VMS_CRTL_G_NONE (0 << 10) +#define VMS_CRTL_GA (1 << 10) +#define VMS_CRTL_GL (2 << 10) + +/* Append '_2'. Not compatible with 64. */ +#define VMS_CRTL_FLOATV2 (1 << 13) struct vms_crtl_name { @@ -84,14 +113,14 @@ vms_add_crtl_xlat (const char *name, size_t nlen, { tree targ; + /* printf ("vms crtl: %.*s -> %.*s\n", nlen, name, id_len, id_str); */ + targ = get_identifier_with_length (name, nlen); gcc_assert (!IDENTIFIER_TRANSPARENT_ALIAS (targ)); IDENTIFIER_TRANSPARENT_ALIAS (targ) = 1; TREE_CHAIN (targ) = get_identifier_with_length (id_str, id_len); VEC_safe_push (tree, gc, aliases_id, targ); - - /* printf ("vms: %s (%p) -> %.*s\n", name, targ, id_len, id_str); */ } /* Do VMS specific stuff on builtins: disable the ones that are not @@ -116,7 +145,48 @@ vms_patch_builtins (void) const struct vms_crtl_name *n = &vms_crtl_names[i]; char res[VMS_CRTL_MAXLEN + 3 + 9 + 1 + 1]; int rlen; - int nlen; + int nlen = strlen (n->name); + + /* Discard 32ONLY if using 64 bit pointers. */ + if ((n->flags & VMS_CRTL_32ONLY) + && flag_vms_pointer_size == VMS_POINTER_SIZE_64) + continue; + + /* Handle DPML unless overridden by decc. */ + if ((n->flags & VMS_CRTL_DPML) + && !(n->flags & VMS_CRTL_NODPML)) + { + const char *p; + char alt[VMS_CRTL_MAXLEN + 3]; + + memcpy (res, "MATH$", 5); + rlen = 5; + for (p = n->name; *p; p++) + res[rlen++] = TOUPPER (*p); + res[rlen++] = '_'; + res[rlen++] = 'T'; + + /* Double version. */ + if (!(n->flags & VMS_CRTL_FLOAT64)) + vms_add_crtl_xlat (n->name, nlen, res, rlen); + + /* Float version. */ + res[rlen - 1] = 'S'; + memcpy (alt, n->name, nlen); + alt[nlen] = 'f'; + vms_add_crtl_xlat (alt, nlen + 1, res, rlen); + + /* Long double version. */ + res[rlen - 1] = (LONG_DOUBLE_TYPE_SIZE == 128 ? 'X' : 'T'); + alt[nlen] = 'l'; + vms_add_crtl_xlat (alt, nlen + 1, res, rlen); + + if (!(n->flags & (VMS_CRTL_FLOAT32 | VMS_CRTL_FLOAT64))) + continue; + } + + if (n->flags & VMS_CRTL_FLOAT64_VAXD) + continue; /* Add the dec-c prefix. */ memcpy (res, "decc$", 5); @@ -124,27 +194,49 @@ vms_patch_builtins (void) if (n->flags & VMS_CRTL_BSD44) { - memcpy (res + rlen, "__bsd44__", 9); - rlen += 9; + memcpy (res + rlen, "__bsd44_", 8); + rlen += 8; } - if (n->flags & VMS_CRTL_GLOBAL) + if ((n->flags & VMS_CRTL_G_MASK) != VMS_CRTL_G_NONE) { - memcpy (res + rlen, "ga_", 3); - rlen += 3; + res[rlen++] = 'g'; + switch (n->flags & VMS_CRTL_G_MASK) + { + case VMS_CRTL_GA: + res[rlen++] = 'a'; + break; + case VMS_CRTL_GL: + res[rlen++] = 'l'; + break; + default: + gcc_unreachable (); + } + res[rlen++] = '_'; } - if (n->flags & VMS_CRTL_FLOAT) + if (n->flags & VMS_CRTL_FLOAT32) + res[rlen++] = 'f'; + + if (n->flags & VMS_CRTL_FLOAT64) res[rlen++] = 't'; - if (n->flags & VMS_CRTL_LDBL) + if ((n->flags & VMS_CRTL_FLOAT128) && LONG_DOUBLE_TYPE_SIZE == 128) res[rlen++] = 'x'; - nlen = strlen (n->name); memcpy (res + rlen, n->name, nlen); if ((n->flags & VMS_CRTL_64) == 0) - vms_add_crtl_xlat (n->name, nlen, res, rlen + nlen); + { + rlen += nlen; + + if (n->flags & VMS_CRTL_FLOATV2) + { + res[rlen++] = '_'; + res[rlen++] = '2'; + } + vms_add_crtl_xlat (n->name, nlen, res, rlen); + } else { char alt[VMS_CRTL_MAXLEN + 3]; diff --git a/gcc/configure b/gcc/configure index db5459a42ad..c1b0e465c35 100755 --- a/gcc/configure +++ b/gcc/configure @@ -9182,7 +9182,7 @@ else # read() to the same fd. The only system known to have a problem here # is VMS, where text files have record structure. case "$host_os" in - vms* | ultrix*) + *vms* | ultrix*) gcc_cv_func_mmap_file=no ;; *) gcc_cv_func_mmap_file=yes;; @@ -9206,7 +9206,7 @@ else # Systems known to be in this category are Windows (all variants), # VMS, and Darwin. case "$host_os" in - vms* | cygwin* | pe | mingw* | darwin* | ultrix* | hpux10* | hpux11.00) + *vms* | cygwin* | pe | mingw* | darwin* | ultrix* | hpux10* | hpux11.00) gcc_cv_func_mmap_dev_zero=no ;; *) gcc_cv_func_mmap_dev_zero=yes;; @@ -9263,7 +9263,7 @@ else # above for use of /dev/zero. # Systems known to be in this category are Windows, VMS, and SCO Unix. case "$host_os" in - vms* | cygwin* | pe | mingw* | sco* | udk* ) + *vms* | cygwin* | pe | mingw* | sco* | udk* ) gcc_cv_func_mmap_anon=no ;; *) gcc_cv_func_mmap_anon=yes;; diff --git a/gcc/configure.ac b/gcc/configure.ac index d860b2b153f..8869121f768 100644 --- a/gcc/configure.ac +++ b/gcc/configure.ac @@ -1059,7 +1059,7 @@ fi AC_CHECK_TYPE(ssize_t, int) AC_CHECK_TYPE(caddr_t, char *) -gcc_AC_FUNC_MMAP_BLACKLIST +GCC_AC_FUNC_MMAP_BLACKLIST case "${host}" in *-*-*vms*) diff --git a/gcc/cp/ChangeLog b/gcc/cp/ChangeLog index b8a6b5cb4c5..89ea02d1935 100644 --- a/gcc/cp/ChangeLog +++ b/gcc/cp/ChangeLog @@ -1,3 +1,36 @@ +2012-04-01 Paolo Carlini <paolo.carlini@oracle.com> + + PR c++/50043 + * class.c (deduce_noexcept_on_destructor, + deduce_noexcept_on_destructors): New. + (check_bases_and_members): Call the latter. + * decl.c (grokfndecl): Call the former. + * method.c (implicitly_declare_fn): Not static. + * cp-tree.h (deduce_noexcept_on_destructor, implicitly_declare_fn): + Declare + +2012-03-29 Paolo Carlini <paolo.carlini@oracle.com> + + PR c++/52718 + * decl.c (check_default_argument): With -Wzero-as-null-pointer-constant + warn for a zero as null pointer constant default argument. + +2012-03-29 Jason Merrill <jason@redhat.com> + + PR c++/52685 + * tree.c (copy_binfo): Handle BINFO_DEPENDENT_BASE_P. + +2012-03-29 Jakub Jelinek <jakub@redhat.com> + + PR c++/52759 + * decl.c (start_decl): Don't call maybe_apply_pragma_weak + if processing_template_decl. + +2012-03-29 Jason Merrill <jason@redhat.com> + + PR c++/52743 + * call.c (compare_ics): Handle ck_aggr like ck_list. + 2012-03-28 Jason Merrill <jason@redhat.com> PR c++/52746 diff --git a/gcc/cp/call.c b/gcc/cp/call.c index 88733f50227..3c3dabb74a0 100644 --- a/gcc/cp/call.c +++ b/gcc/cp/call.c @@ -7620,7 +7620,7 @@ compare_ics (conversion *ics1, conversion *ics2) Specifically, we need to do the reference binding comparison at the end of this function. */ - if (ics1->user_conv_p || ics1->kind == ck_list) + if (ics1->user_conv_p || ics1->kind == ck_list || ics1->kind == ck_aggr) { conversion *t1; conversion *t2; diff --git a/gcc/cp/class.c b/gcc/cp/class.c index bc17c82c6a0..7b6559c4231 100644 --- a/gcc/cp/class.c +++ b/gcc/cp/class.c @@ -4321,6 +4321,41 @@ clone_constructors_and_destructors (tree t) clone_function_decl (OVL_CURRENT (fns), /*update_method_vec_p=*/1); } +/* Deduce noexcept for a destructor DTOR. */ + +void +deduce_noexcept_on_destructor (tree dtor) +{ + if (!TYPE_RAISES_EXCEPTIONS (TREE_TYPE (dtor))) + { + tree ctx = DECL_CONTEXT (dtor); + tree implicit_fn = implicitly_declare_fn (sfk_destructor, ctx, + /*const_p=*/false); + tree eh_spec = TYPE_RAISES_EXCEPTIONS (TREE_TYPE (implicit_fn)); + TREE_TYPE (dtor) = build_exception_variant (TREE_TYPE (dtor), eh_spec); + } +} + +/* For each destructor in T, deduce noexcept: + + 12.4/3: A declaration of a destructor that does not have an + exception-specification is implicitly considered to have the + same exception-specification as an implicit declaration (15.4). */ + +static void +deduce_noexcept_on_destructors (tree t) +{ + tree fns; + + /* If for some reason we don't have a CLASSTYPE_METHOD_VEC, we bail + out now. */ + if (!CLASSTYPE_METHOD_VEC (t)) + return; + + for (fns = CLASSTYPE_DESTRUCTORS (t); fns; fns = OVL_NEXT (fns)) + deduce_noexcept_on_destructor (OVL_CURRENT (fns)); +} + /* Subroutine of set_one_vmethod_tm_attributes. Search base classes of TYPE for virtual functions which FNDECL overrides. Return a mask of the tm attributes found therein. */ @@ -4994,6 +5029,10 @@ check_bases_and_members (tree t) cant_have_const_ctor = 0; no_const_asn_ref = 0; + /* Deduce noexcept on destructors. */ + if (cxx_dialect >= cxx0x) + deduce_noexcept_on_destructors (t); + /* Check all the base-classes. */ check_bases (t, &cant_have_const_ctor, &no_const_asn_ref); diff --git a/gcc/cp/cp-tree.h b/gcc/cp/cp-tree.h index 7d986a8cf73..8bca1fa0b63 100644 --- a/gcc/cp/cp-tree.h +++ b/gcc/cp/cp-tree.h @@ -4978,6 +4978,7 @@ extern void fixup_attribute_variants (tree); extern tree* decl_cloned_function_p (const_tree, bool); extern void clone_function_decl (tree, int); extern void adjust_clone_args (tree); +extern void deduce_noexcept_on_destructor (tree); /* in cvt.c */ extern tree convert_to_reference (tree, tree, int, int, tree); @@ -5264,6 +5265,8 @@ extern tree get_copy_assign (tree); extern tree get_default_ctor (tree); extern tree get_dtor (tree, tsubst_flags_t); extern tree locate_ctor (tree); +extern tree implicitly_declare_fn (special_function_kind, tree, + bool); /* In optimize.c */ extern bool maybe_clone_body (tree); diff --git a/gcc/cp/decl.c b/gcc/cp/decl.c index f021edf36e5..d210f199a2d 100644 --- a/gcc/cp/decl.c +++ b/gcc/cp/decl.c @@ -4431,7 +4431,8 @@ start_decl (const cp_declarator *declarator, } /* If #pragma weak was used, mark the decl weak now. */ - maybe_apply_pragma_weak (decl); + if (!processing_template_decl) + maybe_apply_pragma_weak (decl); if (TREE_CODE (decl) == FUNCTION_DECL && DECL_DECLARED_INLINE_P (decl) @@ -7447,6 +7448,13 @@ grokfndecl (tree ctype, if (ctype != NULL_TREE) grokclassfn (ctype, decl, flags); + /* 12.4/3 */ + if (cxx_dialect >= cxx0x + && DECL_DESTRUCTOR_P (decl) + && !TYPE_BEING_DEFINED (DECL_CONTEXT (decl)) + && !processing_template_decl) + deduce_noexcept_on_destructor (decl); + decl = check_explicit_specialization (orig_declarator, decl, template_count, 2 * funcdef_flag + @@ -10595,6 +10603,17 @@ check_default_argument (tree decl, tree arg) return error_mark_node; } + if (warn_zero_as_null_pointer_constant + && c_inhibit_evaluation_warnings == 0 + && (POINTER_TYPE_P (decl_type) || TYPE_PTR_TO_MEMBER_P (decl_type)) + && null_ptr_cst_p (arg) + && !NULLPTR_TYPE_P (TREE_TYPE (arg))) + { + warning (OPT_Wzero_as_null_pointer_constant, + "zero as null pointer constant"); + return nullptr_node; + } + /* [dcl.fct.default] Local variables shall not be used in default argument diff --git a/gcc/cp/method.c b/gcc/cp/method.c index 0d4793eb23b..79bed4a053f 100644 --- a/gcc/cp/method.c +++ b/gcc/cp/method.c @@ -1444,7 +1444,7 @@ explain_implicit_non_constexpr (tree decl) reference argument or a non-const reference. Returns the FUNCTION_DECL for the implicitly declared function. */ -static tree +tree implicitly_declare_fn (special_function_kind kind, tree type, bool const_p) { tree fn; diff --git a/gcc/cp/pt.c b/gcc/cp/pt.c index 9b410a75fd4..04ba37d25e7 100644 --- a/gcc/cp/pt.c +++ b/gcc/cp/pt.c @@ -17132,46 +17132,6 @@ more_specialized_fn (tree pat1, tree pat2, int len) quals2 = cp_type_quals (arg2); } - if ((quals1 < 0) != (quals2 < 0)) - { - /* Only of the args is a reference, see if we should apply - array/function pointer decay to it. This is not part of - DR214, but is, IMHO, consistent with the deduction rules - for the function call itself, and with our earlier - implementation of the underspecified partial ordering - rules. (nathan). */ - if (quals1 >= 0) - { - switch (TREE_CODE (arg1)) - { - case ARRAY_TYPE: - arg1 = TREE_TYPE (arg1); - /* FALLTHROUGH. */ - case FUNCTION_TYPE: - arg1 = build_pointer_type (arg1); - break; - - default: - break; - } - } - else - { - switch (TREE_CODE (arg2)) - { - case ARRAY_TYPE: - arg2 = TREE_TYPE (arg2); - /* FALLTHROUGH. */ - case FUNCTION_TYPE: - arg2 = build_pointer_type (arg2); - break; - - default: - break; - } - } - } - arg1 = TYPE_MAIN_VARIANT (arg1); arg2 = TYPE_MAIN_VARIANT (arg2); diff --git a/gcc/cp/tree.c b/gcc/cp/tree.c index 87e9be84ecc..30ad5e1b7be 100644 --- a/gcc/cp/tree.c +++ b/gcc/cp/tree.c @@ -1237,12 +1237,11 @@ copy_binfo (tree binfo, tree type, tree t, tree *igo_prev, int virt) TREE_CHAIN (*igo_prev) = new_binfo; *igo_prev = new_binfo; - if (binfo) + if (binfo && !BINFO_DEPENDENT_BASE_P (binfo)) { int ix; tree base_binfo; - gcc_assert (!BINFO_DEPENDENT_BASE_P (binfo)); gcc_assert (SAME_BINFO_TYPE_P (BINFO_TYPE (binfo), type)); BINFO_OFFSET (new_binfo) = BINFO_OFFSET (binfo); @@ -1255,8 +1254,6 @@ copy_binfo (tree binfo, tree type, tree t, tree *igo_prev, int virt) for (ix = 0; BINFO_BASE_ITERATE (binfo, ix, base_binfo); ix++) { tree new_base_binfo; - - gcc_assert (!BINFO_DEPENDENT_BASE_P (base_binfo)); new_base_binfo = copy_binfo (base_binfo, BINFO_TYPE (base_binfo), t, igo_prev, BINFO_VIRTUAL_P (base_binfo)); diff --git a/gcc/cprop.c b/gcc/cprop.c index 024dd207655..ea6909195ac 100644 --- a/gcc/cprop.c +++ b/gcc/cprop.c @@ -1916,7 +1916,7 @@ execute_rtl_cprop (void) changed = one_cprop_pass (); flag_rerun_cse_after_global_opts |= changed; if (changed) - cleanup_cfg (0); + cleanup_cfg (CLEANUP_CFG_CHANGED); return 0; } diff --git a/gcc/cse.c b/gcc/cse.c index d8f07e95eac..5c32336c596 100644 --- a/gcc/cse.c +++ b/gcc/cse.c @@ -653,7 +653,7 @@ fixed_base_plus_p (rtx x) /* Dump the expressions in the equivalence class indicated by CLASSP. This function is used only for debugging. */ -void +DEBUG_FUNCTION void dump_class (struct table_elt *classp) { struct table_elt *elt; @@ -6519,7 +6519,7 @@ cse_extended_basic_block (struct cse_basic_block_data *ebb_data) Return 1 if the CFG should be cleaned up because it has been modified. Return 0 otherwise. */ -int +static int cse_main (rtx f ATTRIBUTE_UNUSED, int nregs) { struct cse_basic_block_data ebb_data; diff --git a/gcc/double-int.c b/gcc/double-int.c index 0f954425093..d0fde0ed89f 100644 --- a/gcc/double-int.c +++ b/gcc/double-int.c @@ -228,7 +228,7 @@ rshift_double (unsigned HOST_WIDE_INT l1, HOST_WIDE_INT h1, /* Zero / sign extend all bits that are beyond the precision. */ - if (count >= (HOST_WIDE_INT)prec) + if (count >= prec) { *hv = signmask; *lv = signmask; diff --git a/gcc/dse.c b/gcc/dse.c index a9fe9249369..d6c8de7fad8 100644 --- a/gcc/dse.c +++ b/gcc/dse.c @@ -44,7 +44,6 @@ along with GCC; see the file COPYING3. If not see #include "insn-config.h" #include "expr.h" #include "recog.h" -#include "dse.h" #include "optabs.h" #include "dbgcnt.h" #include "target.h" @@ -614,7 +613,6 @@ static bitmap kill_on_calls; static unsigned int current_position; -static bool gate_dse (void); static bool gate_dse1 (void); static bool gate_dse2 (void); @@ -625,28 +623,6 @@ static bool gate_dse2 (void); Initialization. ----------------------------------------------------------------------------*/ -/* Hashtable callbacks for maintaining the "bases" field of - store_group_info, given that the addresses are function invariants. */ - -static int -clear_alias_mode_eq (const void *p1, const void *p2) -{ - const struct clear_alias_mode_holder * h1 - = (const struct clear_alias_mode_holder *) p1; - const struct clear_alias_mode_holder * h2 - = (const struct clear_alias_mode_holder *) p2; - return h1->alias_set == h2->alias_set; -} - - -static hashval_t -clear_alias_mode_hash (const void *p) -{ - const struct clear_alias_mode_holder *holder - = (const struct clear_alias_mode_holder *) p; - return holder->alias_set; -} - /* Find the entry associated with ALIAS_SET. */ @@ -3044,85 +3020,6 @@ dse_step2_spill (void) ----------------------------------------------------------------------------*/ -/* Note that this is NOT a general purpose function. Any mem that has - an alias set registered here expected to be COMPLETELY unaliased: - i.e it's addresses are not and need not be examined. - - It is known that all references to this address will have this - alias set and there are NO other references to this address in the - function. - - Currently the only place that is known to be clean enough to use - this interface is the code that assigns the spill locations. - - All of the mems that have alias_sets registered are subjected to a - very powerful form of dse where function calls, volatile reads and - writes, and reads from random location are not taken into account. - - It is also assumed that these locations go dead when the function - returns. This assumption could be relaxed if there were found to - be places that this assumption was not correct. - - The MODE is passed in and saved. The mode of each load or store to - a mem with ALIAS_SET is checked against MEM. If the size of that - load or store is different from MODE, processing is halted on this - alias set. For the vast majority of aliases sets, all of the loads - and stores will use the same mode. But vectors are treated - differently: the alias set is established for the entire vector, - but reload will insert loads and stores for individual elements and - we do not necessarily have the information to track those separate - elements. So when we see a mode mismatch, we just bail. */ - - -void -dse_record_singleton_alias_set (alias_set_type alias_set, - enum machine_mode mode) -{ - struct clear_alias_mode_holder tmp_holder; - struct clear_alias_mode_holder *entry; - void **slot; - - /* If we are not going to run dse, we need to return now or there - will be problems with allocating the bitmaps. */ - if ((!gate_dse()) || !alias_set) - return; - - if (!clear_alias_sets) - { - clear_alias_sets = BITMAP_ALLOC (NULL); - disqualified_clear_alias_sets = BITMAP_ALLOC (NULL); - clear_alias_mode_table = htab_create (11, clear_alias_mode_hash, - clear_alias_mode_eq, NULL); - clear_alias_mode_pool = create_alloc_pool ("clear_alias_mode_pool", - sizeof (struct clear_alias_mode_holder), 100); - } - - bitmap_set_bit (clear_alias_sets, alias_set); - - tmp_holder.alias_set = alias_set; - - slot = htab_find_slot (clear_alias_mode_table, &tmp_holder, INSERT); - gcc_assert (*slot == NULL); - - *slot = entry = - (struct clear_alias_mode_holder *) pool_alloc (clear_alias_mode_pool); - entry->alias_set = alias_set; - entry->mode = mode; -} - - -/* Remove ALIAS_SET from the sets of stack slots being considered. */ - -void -dse_invalidate_singleton_alias_set (alias_set_type alias_set) -{ - if ((!gate_dse()) || !alias_set) - return; - - bitmap_clear_bit (clear_alias_sets, alias_set); -} - - /* Look up the bitmap index for OFFSET in GROUP_INFO. If it is not there, return 0. */ @@ -4015,12 +3912,6 @@ rest_of_handle_dse (void) } static bool -gate_dse (void) -{ - return gate_dse1 () || gate_dse2 (); -} - -static bool gate_dse1 (void) { return optimize > 0 && flag_dse diff --git a/gcc/dse.h b/gcc/dse.h deleted file mode 100644 index dca6ea04f9b..00000000000 --- a/gcc/dse.h +++ /dev/null @@ -1,30 +0,0 @@ -/* RTL dead store elimination. - Copyright (C) 2007, 2010 Free Software Foundation, Inc. - - Contributed by Richard Sandiford <rsandifor@codesourcery.com> - and Kenneth Zadeck <zadeck@naturalbridge.com> - -This file is part of GCC. - -GCC is free software; you can redistribute it and/or modify it under -the terms of the GNU General Public License as published by the Free -Software Foundation; either version 3, or (at your option) any later -version. - -GCC is distributed in the hope that it will be useful, but WITHOUT ANY -WARRANTY; without even the implied warranty of MERCHANTABILITY or -FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License - for more details. - -You should have received a copy of the GNU General Public License -along with GCC; see the file COPYING3. If not see -<http://www.gnu.org/licenses/>. */ - -#ifndef GCC_DSE_H -#define GCC_DSE_H - -extern void dse_record_singleton_alias_set (alias_set_type, enum machine_mode); -extern void dse_invalidate_singleton_alias_set (alias_set_type); - -#endif /* GCC_DSE_H */ - diff --git a/gcc/dwarf2out.c b/gcc/dwarf2out.c index 828e996edb4..ca88fc56b10 100644 --- a/gcc/dwarf2out.c +++ b/gcc/dwarf2out.c @@ -17765,7 +17765,7 @@ common_block_die_table_eq (const void *x, const void *y) static void gen_variable_die (tree decl, tree origin, dw_die_ref context_die) { - HOST_WIDE_INT off; + HOST_WIDE_INT off = 0; tree com_decl; tree decl_or_origin = decl ? decl : origin; tree ultimate_origin; diff --git a/gcc/except.c b/gcc/except.c index ddc865217bd..e3a9ef07422 100644 --- a/gcc/except.c +++ b/gcc/except.c @@ -918,12 +918,6 @@ emit_to_new_bb_before (rtx seq, rtx insn) bb = create_basic_block (seq, last, prev_bb); update_bb_for_insn (bb); bb->flags |= BB_SUPERBLOCK; - if (current_loops) - { - add_bb_to_loop (bb, prev_bb->loop_father); - if (prev_bb->loop_father->header == prev_bb) - prev_bb->loop_father->header = bb; - } return bb; } @@ -995,6 +989,16 @@ dw2_build_landing_pads (void) e = make_edge (bb, bb->next_bb, e_flags); e->count = bb->count; e->probability = REG_BR_PROB_BASE; + if (current_loops) + { + struct loop *loop = bb->next_bb->loop_father; + /* If we created a pre-header block, add the new block to the + outer loop, otherwise to the loop itself. */ + if (bb->next_bb == loop->header) + add_bb_to_loop (bb, loop_outer (loop)); + else + add_bb_to_loop (bb, loop); + } } } diff --git a/gcc/ggc-page.c b/gcc/ggc-page.c index ee796cbb7e9..ff23092b1d7 100644 --- a/gcc/ggc-page.c +++ b/gcc/ggc-page.c @@ -121,14 +121,14 @@ along with GCC; see the file COPYING3. If not see #define PAGE_L1_BITS (8) #define PAGE_L2_BITS (32 - PAGE_L1_BITS - G.lg_pagesize) -#define PAGE_L1_SIZE ((size_t) 1 << PAGE_L1_BITS) -#define PAGE_L2_SIZE ((size_t) 1 << PAGE_L2_BITS) +#define PAGE_L1_SIZE ((uintptr_t) 1 << PAGE_L1_BITS) +#define PAGE_L2_SIZE ((uintptr_t) 1 << PAGE_L2_BITS) #define LOOKUP_L1(p) \ - (((size_t) (p) >> (32 - PAGE_L1_BITS)) & ((1 << PAGE_L1_BITS) - 1)) + (((uintptr_t) (p) >> (32 - PAGE_L1_BITS)) & ((1 << PAGE_L1_BITS) - 1)) #define LOOKUP_L2(p) \ - (((size_t) (p) >> G.lg_pagesize) & ((1 << PAGE_L2_BITS) - 1)) + (((uintptr_t) (p) >> G.lg_pagesize) & ((1 << PAGE_L2_BITS) - 1)) /* The number of objects per allocation page, for objects on a page of the indicated ORDER. */ @@ -560,7 +560,7 @@ ggc_allocated_p (const void *p) base = &G.lookup[0]; #else page_table table = G.lookup; - size_t high_bits = (size_t) p & ~ (size_t) 0xffffffff; + uintptr_t high_bits = (uintptr_t) p & ~ (uintptr_t) 0xffffffff; while (1) { if (table == NULL) @@ -592,7 +592,7 @@ lookup_page_table_entry (const void *p) base = &G.lookup[0]; #else page_table table = G.lookup; - size_t high_bits = (size_t) p & ~ (size_t) 0xffffffff; + uintptr_t high_bits = (uintptr_t) p & ~ (uintptr_t) 0xffffffff; while (table->high_bits != high_bits) table = table->next; base = &table->table[0]; @@ -617,7 +617,7 @@ set_page_table_entry (void *p, page_entry *entry) base = &G.lookup[0]; #else page_table table; - size_t high_bits = (size_t) p & ~ (size_t) 0xffffffff; + uintptr_t high_bits = (uintptr_t) p & ~ (uintptr_t) 0xffffffff; for (table = G.lookup; table; table = table->next) if (table->high_bits == high_bits) goto found; @@ -826,7 +826,7 @@ alloc_page (unsigned order) alloc_size = entry_size + G.pagesize - 1; allocation = XNEWVEC (char, alloc_size); - page = (char *) (((size_t) allocation + G.pagesize - 1) & -G.pagesize); + page = (char *) (((uintptr_t) allocation + G.pagesize - 1) & -G.pagesize); head_slop = page - allocation; if (multiple_pages) tail_slop = ((size_t) allocation + alloc_size) & (G.pagesize - 1); @@ -1662,13 +1662,13 @@ init_ggc (void) { char *p = alloc_anon (NULL, G.pagesize, true); struct page_entry *e; - if ((size_t)p & (G.pagesize - 1)) + if ((uintptr_t)p & (G.pagesize - 1)) { /* How losing. Discard this one and try another. If we still can't get something useful, give up. */ p = alloc_anon (NULL, G.pagesize, true); - gcc_assert (!((size_t)p & (G.pagesize - 1))); + gcc_assert (!((uintptr_t)p & (G.pagesize - 1))); } /* We have a good page, might as well hold onto it... */ @@ -1782,7 +1782,7 @@ clear_marks (void) size_t bitmap_size = BITMAP_SIZE (num_objects + 1); /* The data should be page-aligned. */ - gcc_assert (!((size_t) p->page & (G.pagesize - 1))); + gcc_assert (!((uintptr_t) p->page & (G.pagesize - 1))); /* Pages that aren't in the topmost context are not collected; nevertheless, we need their in-use bit vectors to store GC @@ -2204,7 +2204,7 @@ struct ggc_pch_ondisk struct ggc_pch_data { struct ggc_pch_ondisk d; - size_t base[NUM_ORDERS]; + uintptr_t base[NUM_ORDERS]; size_t written[NUM_ORDERS]; }; @@ -2247,7 +2247,7 @@ ggc_pch_total_size (struct ggc_pch_data *d) void ggc_pch_this_base (struct ggc_pch_data *d, void *base) { - size_t a = (size_t) base; + uintptr_t a = (uintptr_t) base; unsigned i; for (i = 0; i < NUM_ORDERS; i++) diff --git a/gcc/go/gofrontend/expressions.cc b/gcc/go/gofrontend/expressions.cc index 06e85eb8de2..baff0c9a5d9 100644 --- a/gcc/go/gofrontend/expressions.cc +++ b/gcc/go/gofrontend/expressions.cc @@ -10967,9 +10967,15 @@ class Struct_construction_expression : public Expression Struct_construction_expression(Type* type, Expression_list* vals, Location location) : Expression(EXPRESSION_STRUCT_CONSTRUCTION, location), - type_(type), vals_(vals) + type_(type), vals_(vals), traverse_order_(NULL) { } + // Set the traversal order, used to ensure that we implement the + // order of evaluation rules. Takes ownership of the argument. + void + set_traverse_order(std::vector<int>* traverse_order) + { this->traverse_order_ = traverse_order; } + // Return whether this is a constant initializer. bool is_constant_struct() const; @@ -10991,8 +10997,12 @@ class Struct_construction_expression : public Expression Expression* do_copy() { - return new Struct_construction_expression(this->type_, this->vals_->copy(), - this->location()); + Struct_construction_expression* ret = + new Struct_construction_expression(this->type_, this->vals_->copy(), + this->location()); + if (this->traverse_order_ != NULL) + ret->set_traverse_order(this->traverse_order_); + return ret; } tree @@ -11010,6 +11020,9 @@ class Struct_construction_expression : public Expression // The list of values, in order of the fields in the struct. A NULL // entry means that the field should be zero-initialized. Expression_list* vals_; + // If not NULL, the order in which to traverse vals_. This is used + // so that we implement the order of evaluation rules correctly. + std::vector<int>* traverse_order_; }; // Traversal. @@ -11017,9 +11030,26 @@ class Struct_construction_expression : public Expression int Struct_construction_expression::do_traverse(Traverse* traverse) { - if (this->vals_ != NULL - && this->vals_->traverse(traverse) == TRAVERSE_EXIT) - return TRAVERSE_EXIT; + if (this->vals_ != NULL) + { + if (this->traverse_order_ == NULL) + { + if (this->vals_->traverse(traverse) == TRAVERSE_EXIT) + return TRAVERSE_EXIT; + } + else + { + for (std::vector<int>::const_iterator p = + this->traverse_order_->begin(); + p != this->traverse_order_->end(); + ++p) + { + if (Expression::traverse(&this->vals_->at(*p), traverse) + == TRAVERSE_EXIT) + return TRAVERSE_EXIT; + } + } + } if (Type::traverse(this->type_, traverse) == TRAVERSE_EXIT) return TRAVERSE_EXIT; return TRAVERSE_CONTINUE; @@ -12198,6 +12228,7 @@ Composite_literal_expression::lower_struct(Gogo* gogo, Type* type) size_t field_count = st->field_count(); std::vector<Expression*> vals(field_count); + std::vector<int>* traverse_order = new(std::vector<int>); Expression_list::const_iterator p = this->vals_->begin(); while (p != this->vals_->end()) { @@ -12350,6 +12381,7 @@ Composite_literal_expression::lower_struct(Gogo* gogo, Type* type) type->named_type()->message_name().c_str()); vals[index] = val; + traverse_order->push_back(index); } Expression_list* list = new Expression_list; @@ -12357,7 +12389,10 @@ Composite_literal_expression::lower_struct(Gogo* gogo, Type* type) for (size_t i = 0; i < field_count; ++i) list->push_back(vals[i]); - return new Struct_construction_expression(type, list, location); + Struct_construction_expression* ret = + new Struct_construction_expression(type, list, location); + ret->set_traverse_order(traverse_order); + return ret; } // Lower an array composite literal. diff --git a/gcc/go/gofrontend/expressions.h b/gcc/go/gofrontend/expressions.h index 090e893f25e..d58e6c5fcb0 100644 --- a/gcc/go/gofrontend/expressions.h +++ b/gcc/go/gofrontend/expressions.h @@ -842,6 +842,11 @@ class Expression_list bool contains_error() const; + // Retrieve an element by index. + Expression*& + at(size_t i) + { return this->entries_.at(i); } + // Return the first and last elements. Expression*& front() diff --git a/gcc/ira-color.c b/gcc/ira-color.c index a01d050fbb7..45f52444122 100644 --- a/gcc/ira-color.c +++ b/gcc/ira-color.c @@ -821,7 +821,6 @@ setup_left_conflict_sizes_p (ira_allocno_t a) node_preorder_num = node->preorder_num; COPY_HARD_REG_SET (node_set, node->hard_regs->set); node_check_tick++; - curr_allocno_process++; for (k = 0; k < nobj; k++) { ira_object_t obj = ALLOCNO_OBJECT (a, k); @@ -838,12 +837,10 @@ setup_left_conflict_sizes_p (ira_allocno_t a) conflict_data = ALLOCNO_COLOR_DATA (conflict_a); if (! ALLOCNO_COLOR_DATA (conflict_a)->in_graph_p - || conflict_data->last_process == curr_allocno_process || ! hard_reg_set_intersect_p (profitable_hard_regs, conflict_data ->profitable_hard_regs)) continue; - conflict_data->last_process = curr_allocno_process; conflict_node = conflict_data->hard_regs_node; COPY_HARD_REG_SET (conflict_node_set, conflict_node->hard_regs->set); if (hard_reg_set_subset_p (node_set, conflict_node_set)) diff --git a/gcc/java/ChangeLog b/gcc/java/ChangeLog index 974b83f15ec..3e6cb4d9dc9 100644 --- a/gcc/java/ChangeLog +++ b/gcc/java/ChangeLog @@ -1,3 +1,16 @@ +2012-04-02 Rainer Orth <ro@CeBiTec.Uni-Bielefeld.DE> + + * class.c (emit_register_classes_in_jcr_section): Set DECL_USER_ALIGN. + Clear TREE_READONLY. + +2012-03-29 Steven Bosscher <steven@gcc.gnu.org> + + PR java/52730 + * class.c (emit_register_classes_in_jcr_section): New function. + (emit_Jv_RegisterClass_calls): New function, split out from ... + (emit_register_classes): ... here. Reorganize. Do not call + output_constant. + 2012-01-23 Andreas Schwab <schwab@linux-m68k.org> * lang.c (java_init_options_struct): Set diff --git a/gcc/java/class.c b/gcc/java/class.c index ac69319349a..3c34abad7fe 100644 --- a/gcc/java/class.c +++ b/gcc/java/class.c @@ -2786,10 +2786,79 @@ emit_indirect_register_classes (tree *list_p) append_to_statement_list (t, list_p); } +/* Emit a list of pointers to all classes we have emitted to JCR_SECTION. */ + +static void +emit_register_classes_in_jcr_section (void) +{ + tree klass, cdecl, class_array_type; + int i; + int size = VEC_length (tree, registered_class); + VEC(constructor_elt,gc) *init = VEC_alloc (constructor_elt, gc, size); + +#ifndef JCR_SECTION_NAME + /* A target has defined TARGET_USE_JCR_SECTION, + but doesn't have a JCR_SECTION_NAME. */ + gcc_unreachable (); +#endif + + FOR_EACH_VEC_ELT (tree, registered_class, i, klass) + CONSTRUCTOR_APPEND_ELT (init, NULL_TREE, build_fold_addr_expr (klass)); + + /* ??? I would like to use tree_output_constant_def() but there is no way + to put the data in a named section name, or to set the alignment, + via that function. So do everything manually here. */ + class_array_type = build_prim_array_type (ptr_type_node, size); + cdecl = build_decl (UNKNOWN_LOCATION, + VAR_DECL, get_identifier ("_Jv_JCR_SECTION_data"), + class_array_type); + DECL_SECTION_NAME (cdecl) = build_string (strlen (JCR_SECTION_NAME), + JCR_SECTION_NAME); + DECL_ALIGN (cdecl) = POINTER_SIZE; + DECL_USER_ALIGN (cdecl) = 1; + DECL_INITIAL (cdecl) = build_constructor (class_array_type, init); + TREE_CONSTANT (DECL_INITIAL (cdecl)) = 1; + TREE_STATIC (cdecl) = 1; + TREE_READONLY (cdecl) = 0; + TREE_CONSTANT (cdecl) = 1; + DECL_ARTIFICIAL (cdecl) = 1; + DECL_IGNORED_P (cdecl) = 1; + pushdecl_top_level (cdecl); + relayout_decl (cdecl); + rest_of_decl_compilation (cdecl, 1, 0); + mark_decl_referenced (cdecl); +} + + +/* Emit a series of calls to _Jv_RegisterClass for every class we emitted. + A series of calls is added to LIST_P. */ + +static void +emit_Jv_RegisterClass_calls (tree *list_p) +{ + tree klass, t, register_class_fn; + int i; + + t = build_function_type_list (void_type_node, class_ptr_type, NULL); + t = build_decl (input_location, + FUNCTION_DECL, get_identifier ("_Jv_RegisterClass"), t); + TREE_PUBLIC (t) = 1; + DECL_EXTERNAL (t) = 1; + register_class_fn = t; + + FOR_EACH_VEC_ELT (tree, registered_class, i, klass) + { + t = build_fold_addr_expr (klass); + t = build_call_expr (register_class_fn, 1, t); + append_to_statement_list (t, list_p); + } +} /* Emit something to register classes at start-up time. - The preferred mechanism is through the .jcr section, which contain + The default mechanism is to generate instances at run-time. + + An alternative mechanism is through the .jcr section, which contain a list of pointers to classes which get registered during constructor invocation time. @@ -2803,55 +2872,18 @@ emit_register_classes (tree *list_p) if (registered_class == NULL) return; + /* By default, generate instances of Class at runtime. */ if (flag_indirect_classes) - { - emit_indirect_register_classes (list_p); - return; - } - + emit_indirect_register_classes (list_p); /* TARGET_USE_JCR_SECTION defaults to 1 if SUPPORTS_WEAK and TARGET_ASM_NAMED_SECTION, else 0. Some targets meet those conditions but lack suitable crtbegin/end objects or linker support. These targets can override the default in tm.h to use the fallback mechanism. */ - if (TARGET_USE_JCR_SECTION) - { - tree klass, t; - int i; - -#ifdef JCR_SECTION_NAME - switch_to_section (get_section (JCR_SECTION_NAME, SECTION_WRITE, NULL)); -#else - /* A target has defined TARGET_USE_JCR_SECTION, - but doesn't have a JCR_SECTION_NAME. */ - gcc_unreachable (); -#endif - assemble_align (POINTER_SIZE); - - FOR_EACH_VEC_ELT (tree, registered_class, i, klass) - { - t = build_fold_addr_expr (klass); - output_constant (t, POINTER_SIZE / BITS_PER_UNIT, POINTER_SIZE); - } - } + else if (TARGET_USE_JCR_SECTION) + emit_register_classes_in_jcr_section (); + /* Use the fallback mechanism. */ else - { - tree klass, t, register_class_fn; - int i; - - t = build_function_type_list (void_type_node, class_ptr_type, NULL); - t = build_decl (input_location, - FUNCTION_DECL, get_identifier ("_Jv_RegisterClass"), t); - TREE_PUBLIC (t) = 1; - DECL_EXTERNAL (t) = 1; - register_class_fn = t; - - FOR_EACH_VEC_ELT (tree, registered_class, i, klass) - { - t = build_fold_addr_expr (klass); - t = build_call_expr (register_class_fn, 1, t); - append_to_statement_list (t, list_p); - } - } + emit_Jv_RegisterClass_calls (list_p); } /* Build a constructor for an entry in the symbol table. */ diff --git a/gcc/loop-init.c b/gcc/loop-init.c index b8d7b7ee7ce..03f8f610c97 100644 --- a/gcc/loop-init.c +++ b/gcc/loop-init.c @@ -158,15 +158,24 @@ loop_optimizer_finalize (void) static bool gate_handle_loop2 (void) { - return (optimize > 0 - && (flag_move_loop_invariants - || flag_unswitch_loops - || flag_peel_loops - || flag_unroll_loops + if (optimize > 0 + && (flag_move_loop_invariants + || flag_unswitch_loops + || flag_peel_loops + || flag_unroll_loops #ifdef HAVE_doloop_end - || (flag_branch_on_count_reg && HAVE_doloop_end) + || (flag_branch_on_count_reg && HAVE_doloop_end) #endif - )); + )) + return true; + else + { + /* No longer preserve loops, remove them now. */ + cfun->curr_properties &= ~PROP_loops; + if (current_loops) + loop_optimizer_finalize (); + return false; + } } struct rtl_opt_pass pass_loop2 = diff --git a/gcc/rtl.h b/gcc/rtl.h index bf1e26d66c5..30931b74df7 100644 --- a/gcc/rtl.h +++ b/gcc/rtl.h @@ -2373,7 +2373,6 @@ extern int rtx_to_tree_code (enum rtx_code); /* In cse.c */ extern int delete_trivially_dead_insns (rtx, int); -extern int cse_main (rtx, int); extern int exp_equiv_p (const_rtx, const_rtx, int, bool); extern unsigned hash_rtx (const_rtx x, enum machine_mode, int *, int *, bool); diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 954e8fb1b4b..c757d42d177 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,87 @@ +2012-04-03 Richard Guenther <rguenther@suse.de> + + PR tree-optimization/52808 + * gcc.dg/pr52808.c: New testcase. + +2012-04-03 Jakub Jelinek <jakub@redhat.com> + + PR tree-optimization/52835 + * gfortran.dg/pr52835.f90: New test. + +2012-04-03 Eric Botcazou <ebotcazou@adacore.com> + + * gnat.dg/specs/aggr5.ads: New test. + +2012-04-02 Richard Guenther <rguenther@suse.de> + + PR tree-optimization/52756 + * gcc.dg/torture/pr52756.c: New testcase. + +2012-04-02 Richard Guenther <rguenther@suse.de> + + PR middle-end/52803 + * gcc.dg/pr52803.c: New testcase. + +2012-04-02 Dodji Seketeli <dodji@redhat.com> + + PR c++/40942 + * g++.old-deja/g++.pt/spec40.C: Adjust to take the resolution of + DR 214 in account. + +2012-04-01 Paolo Carlini <paolo.carlini@oracle.com> + + PR c++/50043 + * g++.dg/cpp0x/noexcept17.C: New. + * g++.old-deja/g++.eh/cleanup1.C: Adjust. + * g++.dg/tree-ssa/ehcleanup-1.C: Likewise. + * g++.dg/cpp0x/noexcept01.C: Likewise. + * g++.dg/eh/init-temp1.C: Likewise. + * g++.dg/eh/ctor1.C: Likwise. + +2012-03-31 Eric Botcazou <ebotcazou@adacore.com> + + * gnat.dg/controlled6.adb: New test. + * gnat.dg/controlled6_pkg.ads: New helper. + * gnat.dg/controlled6_pkg-iterators.ad[sb]: Likewise. + +2012-03-30 Richard Henderson <rth@redhat.com> + + PR debug/52727 + * g++.dg/opt/pr52727.C: New testcase. + +2012-03-30 Richard Guenther <rguenther@suse.de> + + PR tree-optimization/52754 + * gcc.target/i386/pr52754.c: New testcase. + +2012-03-30 Richard Guenther <rguenther@suse.de> + + PR middle-end/52772 + * g++.dg/torture/pr52772.C: New testcase. + +2012-03-29 Paolo Carlini <paolo.carlini@oracle.com> + + PR c++/52718 + * g++.dg/warn/Wzero-as-null-pointer-constant-5.C: New. + +2012-03-29 Jason Merrill <jason@redhat.com> + + PR c++/52685 + * g++.dg/template/inherit8.C: New. + +2012-03-29 Jakub Jelinek <jakub@redhat.com> + + PR c++/52759 + * g++.dg/ext/weak4.C: New test. + + PR tree-optimization/52760 + * gcc.c-torture/execute/pr52760.c: New test. + +2012-03-29 Jason Merrill <jason@redhat.com> + + PR c++/52743 + * g++.dg/cpp0x/initlist-array3.C: New. + 2012-03-28 Jason Merrill <jason@redhat.com> PR c++/52746 diff --git a/gcc/testsuite/g++.dg/cpp0x/initlist-array3.C b/gcc/testsuite/g++.dg/cpp0x/initlist-array3.C new file mode 100644 index 00000000000..1a94f4ed55b --- /dev/null +++ b/gcc/testsuite/g++.dg/cpp0x/initlist-array3.C @@ -0,0 +1,10 @@ +// PR c++/52743 +// { dg-do compile { target c++11 } } + +void composite (int const (&) [2]); +void composite (int const (&) [3]); + +int main () +{ + composite({0,1}); // { dg-error "ambiguous" } +} diff --git a/gcc/testsuite/g++.dg/cpp0x/noexcept01.C b/gcc/testsuite/g++.dg/cpp0x/noexcept01.C index f314684eae8..b6be1ef7a3f 100644 --- a/gcc/testsuite/g++.dg/cpp0x/noexcept01.C +++ b/gcc/testsuite/g++.dg/cpp0x/noexcept01.C @@ -50,7 +50,7 @@ struct E ~E(); }; -SA (!noexcept (E())); +SA (noexcept (E())); struct F { @@ -74,7 +74,7 @@ void tf() } template void tf<int,true>(); -template void tf<E, false>(); +template void tf<E, true>(); // Make sure that noexcept uses the declared exception-specification, not // any knowledge we might have about whether or not the function really diff --git a/gcc/testsuite/g++.dg/cpp0x/noexcept17.C b/gcc/testsuite/g++.dg/cpp0x/noexcept17.C new file mode 100644 index 00000000000..82cd844c067 --- /dev/null +++ b/gcc/testsuite/g++.dg/cpp0x/noexcept17.C @@ -0,0 +1,54 @@ +// PR c++/50043 +// { dg-options -std=c++11 } + +struct True1 {}; +struct True2 { ~True2(); }; +struct True3 { ~True3(){ throw 0; } }; +struct False { ~False() noexcept(false); }; + +template <typename Base> +struct A : Base +{ +}; + +template <typename Member> +struct B +{ + Member mem; +}; + +template <typename Base, typename Member> +struct C : Base +{ + Member mem; +}; + +#define SA(X) static_assert(X, #X) + +SA( noexcept(True1())); +SA( noexcept(True2())); +SA( noexcept(True3())); +SA(!noexcept(False())); + +SA( noexcept(A<True1>())); +SA( noexcept(A<True2>())); +SA( noexcept(A<True3>())); +SA(!noexcept(A<False>())); + +SA( noexcept(B<True1>())); +SA( noexcept(B<True2>())); +SA( noexcept(B<True3>())); +SA(!noexcept(B<False>())); + +SA( noexcept(C<True1, True2>())); +SA( noexcept(C<True1, True3>())); +SA( noexcept(C<True2, True3>())); +SA( noexcept(C<True2, True1>())); +SA( noexcept(C<True3, True1>())); +SA( noexcept(C<True3, True2>())); +SA(!noexcept(C<False, True1>())); +SA(!noexcept(C<False, True2>())); +SA(!noexcept(C<False, True3>())); +SA(!noexcept(C<True1, False>())); +SA(!noexcept(C<True2, False>())); +SA(!noexcept(C<True3, False>())); diff --git a/gcc/testsuite/g++.dg/eh/ctor1.C b/gcc/testsuite/g++.dg/eh/ctor1.C index 43b735f0b00..b959d1c5620 100644 --- a/gcc/testsuite/g++.dg/eh/ctor1.C +++ b/gcc/testsuite/g++.dg/eh/ctor1.C @@ -5,6 +5,12 @@ // PR 411 +#ifdef __GXX_EXPERIMENTAL_CXX0X__ +#define NOEXCEPT_FALSE noexcept (false) +#else +#define NOEXCEPT_FALSE +#endif + bool was_f_in_Bar_destroyed=false; struct Foo @@ -17,7 +23,7 @@ struct Foo struct Bar { - ~Bar() + ~Bar() NOEXCEPT_FALSE { throw 1; } diff --git a/gcc/testsuite/g++.dg/eh/init-temp1.C b/gcc/testsuite/g++.dg/eh/init-temp1.C index 529014f497f..4996cea230f 100644 --- a/gcc/testsuite/g++.dg/eh/init-temp1.C +++ b/gcc/testsuite/g++.dg/eh/init-temp1.C @@ -1,6 +1,12 @@ // PR c++/15764 // { dg-do run } +#ifdef __GXX_EXPERIMENTAL_CXX0X__ +#define NOEXCEPT_FALSE noexcept (false) +#else +#define NOEXCEPT_FALSE +#endif + extern "C" void abort (); int thrown; @@ -8,7 +14,7 @@ int thrown; int as; struct a { a () { ++as; } - ~a () { --as; if (thrown++ == 0) throw 42; } + ~a () NOEXCEPT_FALSE { --as; if (thrown++ == 0) throw 42; } }; int f (a const&) { return 1; } diff --git a/gcc/testsuite/g++.dg/ext/weak4.C b/gcc/testsuite/g++.dg/ext/weak4.C new file mode 100644 index 00000000000..5b3cce05cd9 --- /dev/null +++ b/gcc/testsuite/g++.dg/ext/weak4.C @@ -0,0 +1,9 @@ +// PR c++/52759 +// { dg-do compile } +// { dg-require-weak "" } +// { dg-options "" } +#pragma weak foo +template <typename T> +struct A { }; +template <typename T> +void bar (A<T> &); diff --git a/gcc/testsuite/g++.dg/opt/pr52727.C b/gcc/testsuite/g++.dg/opt/pr52727.C new file mode 100644 index 00000000000..4dd38530a02 --- /dev/null +++ b/gcc/testsuite/g++.dg/opt/pr52727.C @@ -0,0 +1,45 @@ +// { dg-do compile } +// { dg-options "-g -Os" } + +int grow (int); +void fn (int); +struct A { int a1, a2; }; +template <typename T> +struct B +{ + A *b; + ~B () { b3 (b); } + void b1 (int); + void b2 (int); + void b3 (A *); +}; +struct C { int c1, c2, c3; bool c4; }; +int +bar (int x) +{ + int y = x / 6; + if (y > x / 2) + return y; + return 0; +} +void baz (double, double); +void +foo (const C *x, int y, int z) +{ + B<int> p; + double r = y / 2; + int w = bar (int (r)); + double s = y / 2 + 0.5; + double t = z / 2 + 0.5; + int u = x->c3; + int v = (x->c2 + u - 1 - x->c1) / u; + p.b2 ((2 * v > p.b->a1 || (2 * v < p.b->a2 && 2 * v < (p.b->a1 >> 1))) + ? grow (0) : p.b->a1); + for (int i = 0; i <= v; ++i) + { + double l = x->c4 ? 4.5 - i * 6.2 / v : (3.1 - i * 31 / v) / 6; + baz (s + (r - w) * l, t - (r - w) * l); + } +} + + diff --git a/gcc/testsuite/g++.dg/template/inherit8.C b/gcc/testsuite/g++.dg/template/inherit8.C new file mode 100644 index 00000000000..a9b2bdb5601 --- /dev/null +++ b/gcc/testsuite/g++.dg/template/inherit8.C @@ -0,0 +1,13 @@ +// PR c++/52685 + +template <typename T> +struct A +{ + template <typename U> + struct B : public A <B<U> > + { + struct C : public B<U> + { + }; + }; +}; diff --git a/gcc/testsuite/g++.dg/torture/pr52772.C b/gcc/testsuite/g++.dg/torture/pr52772.C new file mode 100644 index 00000000000..810e6579fba --- /dev/null +++ b/gcc/testsuite/g++.dg/torture/pr52772.C @@ -0,0 +1,85 @@ +// { dg-do compile } + +typedef __SIZE_TYPE__ size_t; + +class c1; + +class c2 { + public: c2() { }; + void *operator new(size_t size, const c1 & crc1); +}; + +class c3 { + public: c3() { _Obj = 0; } + ~c3() { if (_Obj) delete _Obj; } + void set(c2 *pObj); + protected: c2 *_Obj; +}; + +void c3::set(c2 *pObj) { _Obj = pObj; }; + +template<class TYPE> class tc1 : public c2 { + public: tc1(int n=0){}; + int get() const; + TYPE& operator[] (int id); + TYPE * _data; + int _size; +}; + +template<class TYPE> TYPE & tc1<TYPE>::operator[] (int id) { + return _data[id]; +} + +template<class TYPE> int tc1<TYPE>::get() const { + return _size; +} + +class c4 { + public: c4(); +}; + +class c5 : public c2 { + protected: c2 * _own; + public: c5(c2 *o) : _own(o) { } + c5(const c4 & box); + int add(const c4 & ext); +}; + +class c6 { + public: int get() const {}; +}; + +class c7 { + friend class c8; + int find(c6 * loop) const; +}; + +class c8 { + const c1 & _rc1; + int tria(c7 * face, c5 * vtree0 = 0); +}; + +int c8::tria(c7 * face, c5 * vtree0) { + c6 *sLData[64]; + tc1<c6*> loops(64); + while (loops.get() > 1) { + c6 *iloop = 0; + for (int j=1; j<loops.get(); j++) { + if (loops[j]->get() < 32) { + iloop = loops[j]; + } + } + face->find(iloop); + } + c4 box; + c3 ctree; + c5 *vtree = vtree0; + if (!vtree) { + vtree = new (_rc1) c5(box); + ctree.set(vtree); + for (int j=0; j<1; j++) { + c4 sVBBox; + vtree->add(sVBBox); + } + } +} diff --git a/gcc/testsuite/g++.dg/tree-ssa/ehcleanup-1.C b/gcc/testsuite/g++.dg/tree-ssa/ehcleanup-1.C index cc492a80975..0a29ce9cb4f 100644 --- a/gcc/testsuite/g++.dg/tree-ssa/ehcleanup-1.C +++ b/gcc/testsuite/g++.dg/tree-ssa/ehcleanup-1.C @@ -1,9 +1,16 @@ // { dg-options "-O2 -fdump-tree-ehcleanup1-details" } + +#ifdef __GXX_EXPERIMENTAL_CXX0X__ +#define NOEXCEPT_FALSE noexcept (false) +#else +#define NOEXCEPT_FALSE +#endif + extern void can_throw (); class a { public: - ~a () + ~a () NOEXCEPT_FALSE { if (0) can_throw (); diff --git a/gcc/testsuite/g++.dg/warn/Wzero-as-null-pointer-constant-5.C b/gcc/testsuite/g++.dg/warn/Wzero-as-null-pointer-constant-5.C new file mode 100644 index 00000000000..185d2b5c4ee --- /dev/null +++ b/gcc/testsuite/g++.dg/warn/Wzero-as-null-pointer-constant-5.C @@ -0,0 +1,20 @@ +// PR c++/52718 +// { dg-options "-Wzero-as-null-pointer-constant" } + +struct foo +{ + foo(void* a = 0) {}; // { dg-warning "zero as null pointer" } +}; + +void* fun(void* a = 0) {}; // { dg-warning "zero as null pointer" } + +struct bar: foo +{ + bar() {}; +}; + +struct baz +{ + baz(const foo& f1 = foo(), + void* f2 = fun()) {}; +}; diff --git a/gcc/testsuite/g++.old-deja/g++.eh/cleanup1.C b/gcc/testsuite/g++.old-deja/g++.eh/cleanup1.C index 16646438ed2..12f1ec7a081 100644 --- a/gcc/testsuite/g++.old-deja/g++.eh/cleanup1.C +++ b/gcc/testsuite/g++.old-deja/g++.eh/cleanup1.C @@ -2,6 +2,12 @@ // Bug: obj gets destroyed twice because the fixups for the return are // inside its cleanup region. +#ifdef __GXX_EXPERIMENTAL_CXX0X__ +#define NOEXCEPT_FALSE noexcept (false) +#else +#define NOEXCEPT_FALSE +#endif + extern "C" int printf (const char *, ...); int d; @@ -9,7 +15,7 @@ int d; struct myExc { }; struct myExcRaiser { - ~myExcRaiser() { throw myExc(); } + ~myExcRaiser() NOEXCEPT_FALSE { throw myExc(); } }; struct stackObj { diff --git a/gcc/testsuite/g++.old-deja/g++.pt/spec40.C b/gcc/testsuite/g++.old-deja/g++.pt/spec40.C index 70abb6fc50f..fc37f412b7e 100644 --- a/gcc/testsuite/g++.old-deja/g++.pt/spec40.C +++ b/gcc/testsuite/g++.old-deja/g++.pt/spec40.C @@ -1,14 +1,33 @@ -// { dg-do run } +// { dg-do compile } // Copyright (C) 2000 Free Software Foundation, Inc. // Contributed by Nathan Sidwell 12 Feb 2001 <nathan@codesourcery.com> -// More from bug 1617. We didn't resolve partial ordering properly. The -// std is rather vague about it anyway, DR 214 talks about this. +// More from bug 1617. The resolution of DR 214 implies that the below +// call to Foo is ambiguous. +// +// The type transformation (on the function parameter of Foo) allowed +// in the context of partial ordering of the Foo template overloads is +// the following ([temp.deduct.partial]/5): +// +// Before the partial ordering is done, certain transformations +// are performed on the types used for partial ordering: +// +// - If P is a reference type, P is replaced by the type +// referred to. +// +// - If A is a reference type, A is replaced by the type +// referred to. +// +// It follows that we are not allowed to apply array-to-pointer +// decay conversion to the type of the function parameter +// 'char const (&)[I]'. So the two Foo specializations should +// be considered unrelated. Thus the partial ordering of the two +// Foo specializations should fail. template <typename T> int Foo (T const *) {return 1;} template <unsigned I> int Foo (char const (&)[I]) {return 2;} int main () { - return Foo ("a") != 2; + return Foo ("a") != 2; // { dg-error "call of overloaded \[^\n\r\]* is ambiguous" } } diff --git a/gcc/testsuite/gcc.c-torture/execute/pr52760.c b/gcc/testsuite/gcc.c-torture/execute/pr52760.c new file mode 100644 index 00000000000..1413c5f275a --- /dev/null +++ b/gcc/testsuite/gcc.c-torture/execute/pr52760.c @@ -0,0 +1,27 @@ +/* PR tree-optimization/52760 */ + +struct T { unsigned short a, b, c, d; }; + +__attribute__((noinline, noclone)) void +foo (int x, struct T *y) +{ + int i; + + for (i = 0; i < x; i++) + { + y[i].a = ((0x00ff & y[i].a >> 8) | (0xff00 & y[i].a << 8)); + y[i].b = ((0x00ff & y[i].b >> 8) | (0xff00 & y[i].b << 8)); + y[i].c = ((0x00ff & y[i].c >> 8) | (0xff00 & y[i].c << 8)); + y[i].d = ((0x00ff & y[i].d >> 8) | (0xff00 & y[i].d << 8)); + } +} + +int +main () +{ + struct T t = { 0x0001, 0x0203, 0x0405, 0x0607 }; + foo (1, &t); + if (t.a != 0x0100 || t.b != 0x0302 || t.c != 0x0504 || t.d != 0x0706) + __builtin_abort (); + return 0; +} diff --git a/gcc/testsuite/gcc.dg/pr52803.c b/gcc/testsuite/gcc.dg/pr52803.c new file mode 100644 index 00000000000..6774b0c6d21 --- /dev/null +++ b/gcc/testsuite/gcc.dg/pr52803.c @@ -0,0 +1,4 @@ +/* { dg-do compile } */ +/* { dg-options "-O -fno-move-loop-invariants" } */ + +int main () { return 0; } diff --git a/gcc/testsuite/gcc.dg/pr52808.c b/gcc/testsuite/gcc.dg/pr52808.c new file mode 100644 index 00000000000..b731cb40133 --- /dev/null +++ b/gcc/testsuite/gcc.dg/pr52808.c @@ -0,0 +1,12 @@ +/* { dg-do compile } */ +/* { dg-options "-O -ftracer" } */ + +int **fn1 () __attribute__ ((__const__)); +int main () +{ + int i; + i = 0; + for (;; i++) + if (*fn1 ()[i] && !'a' <= 0 && i <= 'z' || *fn1 ()[0] && 'a' <= 'z') + return; +} diff --git a/gcc/testsuite/gcc.dg/torture/pr52756.c b/gcc/testsuite/gcc.dg/torture/pr52756.c new file mode 100644 index 00000000000..175b414e17d --- /dev/null +++ b/gcc/testsuite/gcc.dg/torture/pr52756.c @@ -0,0 +1,9 @@ +/* { dg-do compile } */ + +void Env_FetchObj0AttrOffset (unsigned int NumFields, int *Status) +{ + int Found = 0; + if (NumFields) + while ((*Status == 0) && NumFields-- > 0 && Found == 0) + Found = 1; +} diff --git a/gcc/testsuite/gcc.target/i386/pr52754.c b/gcc/testsuite/gcc.target/i386/pr52754.c new file mode 100644 index 00000000000..0f2dbff2dd7 --- /dev/null +++ b/gcc/testsuite/gcc.target/i386/pr52754.c @@ -0,0 +1,33 @@ +/* { dg-do run } */ +/* { dg-options "-O2 -fpredictive-commoning -msse2 -std=c99" } */ +/* { dg-require-effective-target sse2 } */ + +#include <x86intrin.h> + +#include "isa-check.h" +#include "sse-os-support.h" + +int main() +{ + const float mem[8] = { 0, 1, 2, 3, 4, 5, 6, 7 }; + + unsigned int indexes[8]; + for (unsigned int i = 0; i < 8; ++i) indexes[i] = i; + + check_isa (); + + if (!sse_os_support ()) + exit (0); + + __m128 x = _mm_setr_ps(0, 1, 2, 3); + for (unsigned int i = 0; i + 4 < 6; ++i) { + const unsigned int *ii = &indexes[i]; + const __m128 tmp = _mm_setr_ps(mem[ii[0]], mem[ii[1]], mem[ii[2]], mem[ii[3]]); + if (0xf != _mm_movemask_ps(_mm_cmpeq_ps(tmp, x))) { + __builtin_abort(); + } + x = _mm_add_ps(x, _mm_set1_ps(1)); + } + + return 0; +} diff --git a/gcc/testsuite/gfortran.dg/pr52835.f90 b/gcc/testsuite/gfortran.dg/pr52835.f90 new file mode 100644 index 00000000000..a72951ab6ee --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr52835.f90 @@ -0,0 +1,16 @@ +! PR tree-optimization/52835 +! { dg-do compile } +! { dg-options "-O3 -fdump-tree-optimized" } + +subroutine foo (x, y, z, n) + integer :: n, i + real :: x(n), y(n), z(n) + do i = 1, n + z(i) = 0.0 + y(i) = 0.0 + call bar (y(i), z(i), x(i)) + end do +end subroutine + +! { dg-final { scan-tree-dump "bar " "optimized" } } +! { dg-final { cleanup-tree-dump "optimized" } } diff --git a/gcc/testsuite/gnat.dg/controlled6.adb b/gcc/testsuite/gnat.dg/controlled6.adb new file mode 100644 index 00000000000..88640de7bea --- /dev/null +++ b/gcc/testsuite/gnat.dg/controlled6.adb @@ -0,0 +1,24 @@ +-- { dg-do compile } +-- { dg-options "-O -gnatn" } + +with Ada.Text_IO; use Ada.Text_IO; +with Controlled6_Pkg; +with Controlled6_Pkg.Iterators; + +procedure Controlled6 is + + type String_Access is access String; + + package My_Q is new Controlled6_Pkg (String_Access); + package My_Iterators is new My_Q.Iterators (0); + use My_Iterators; + + Iterator : Iterator_Type := Find; + +begin + loop + exit when Is_Null (Iterator); + Put (Current (Iterator).all & ' '); + Find_Next (Iterator); + end loop; +end; diff --git a/gcc/testsuite/gnat.dg/controlled6_pkg-iterators.adb b/gcc/testsuite/gnat.dg/controlled6_pkg-iterators.adb new file mode 100644 index 00000000000..201a75c94cc --- /dev/null +++ b/gcc/testsuite/gnat.dg/controlled6_pkg-iterators.adb @@ -0,0 +1,21 @@ +package body Controlled6_Pkg.Iterators is + + function Find return Iterator_Type is + Iterator : Iterator_Type; + begin + return Iterator; + end Find; + + function Current (Iterator : in Iterator_Type) return T is begin + return Iterator.Current.Item; + end Current; + + procedure Find_Next (Iterator : in out Iterator_Type) is begin + Iterator.Current := null; + end Find_Next; + + function Is_Null (Iterator : in Iterator_Type) return Boolean is begin + return Iterator.Current = null; + end Is_Null; + +end Controlled6_Pkg.Iterators; diff --git a/gcc/testsuite/gnat.dg/controlled6_pkg-iterators.ads b/gcc/testsuite/gnat.dg/controlled6_pkg-iterators.ads new file mode 100644 index 00000000000..89330f6a3ba --- /dev/null +++ b/gcc/testsuite/gnat.dg/controlled6_pkg-iterators.ads @@ -0,0 +1,22 @@ +with Ada.Finalization; + +generic + + I : Integer; + +package Controlled6_Pkg.Iterators is + + type Iterator_Type is new Ada.Finalization.Controlled with record + Current : Node_Access_Type; + end record; + + function Find return Iterator_Type; + + function Current (Iterator : in Iterator_Type) return T; + pragma Inline (Current); + + procedure Find_Next (Iterator : in out Iterator_Type); + + function Is_Null (Iterator : in Iterator_Type) return Boolean; + +end Controlled6_Pkg.Iterators; diff --git a/gcc/testsuite/gnat.dg/controlled6_pkg.ads b/gcc/testsuite/gnat.dg/controlled6_pkg.ads new file mode 100644 index 00000000000..2f1052be981 --- /dev/null +++ b/gcc/testsuite/gnat.dg/controlled6_pkg.ads @@ -0,0 +1,15 @@ +with Ada.Finalization; + +generic + + type T is private; + +package Controlled6_Pkg is + + type Node_Type is record + Item : T; + end record; + + type Node_Access_Type is access Node_Type; + +end Controlled6_Pkg; diff --git a/gcc/testsuite/gnat.dg/specs/aggr5.ads b/gcc/testsuite/gnat.dg/specs/aggr5.ads new file mode 100644 index 00000000000..ba1e695bca2 --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/aggr5.ads @@ -0,0 +1,19 @@ +-- { dg-do compile } + +pragma Restrictions (No_Elaboration_Code); + +package Aggr5 is + + type R is record + C : Character; + F : Float; + end record; + + for R use record + C at 0 range 0 .. 7; + F at 1 range 0 .. 31; + end record; + + My_R : R := (C => 'A', F => 1.0); + +end Aggr5; diff --git a/gcc/tracer.c b/gcc/tracer.c index 602e7580d99..8fb9817dbe9 100644 --- a/gcc/tracer.c +++ b/gcc/tracer.c @@ -59,7 +59,6 @@ static bool better_p (const_edge, const_edge); static edge find_best_successor (basic_block); static edge find_best_predecessor (basic_block); static int find_trace (basic_block, basic_block *); -static void tail_duplicate (void); /* Minimal outgoing edge probability considered for superblock formation. */ static int probability_cutoff; @@ -224,7 +223,7 @@ find_trace (basic_block bb, basic_block *trace) /* Look for basic blocks in frequency order, construct traces and tail duplicate if profitable. */ -static void +static bool tail_duplicate (void) { fibnode_t *blocks = XCNEWVEC (fibnode_t, last_basic_block); @@ -236,6 +235,7 @@ tail_duplicate (void) gcov_type cover_insns; int max_dup_insns; basic_block bb; + bool changed = false; /* Create an oversized sbitmap to reduce the chance that we need to resize it. */ @@ -332,6 +332,7 @@ tail_duplicate (void) bb2->index, copy->index, copy->frequency); bb2 = copy; + changed = true; } mark_bb_seen (bb2); bb = bb2; @@ -353,6 +354,8 @@ tail_duplicate (void) free (trace); free (counts); fibheap_delete (heap); + + return changed; } /* Main entry point to this file. */ @@ -360,6 +363,8 @@ tail_duplicate (void) static unsigned int tracer (void) { + bool changed; + gcc_assert (current_ir_type () == IR_GIMPLE); if (n_basic_blocks <= NUM_FIXED_BLOCKS + 1) @@ -370,15 +375,14 @@ tracer (void) dump_flow_info (dump_file, dump_flags); /* Trace formation is done on the fly inside tail_duplicate */ - tail_duplicate (); + changed = tail_duplicate (); + if (changed) + free_dominance_info (CDI_DOMINATORS); - /* FIXME: We really only need to do this when we know tail duplication - has altered the CFG. */ - free_dominance_info (CDI_DOMINATORS); if (dump_file) dump_flow_info (dump_file, dump_flags); - return 0; + return changed ? TODO_cleanup_cfg : 0; } static bool diff --git a/gcc/tree-affine.c b/gcc/tree-affine.c index 69cce2e7e61..7bb1645d425 100644 --- a/gcc/tree-affine.c +++ b/gcc/tree-affine.c @@ -812,7 +812,7 @@ aff_combination_constant_multiple_p (aff_tree *val, aff_tree *div, /* Prints the affine VAL to the FILE. */ -void +static void print_aff (FILE *file, aff_tree *val) { unsigned i; diff --git a/gcc/tree-affine.h b/gcc/tree-affine.h index 8cfbd691d9e..4d3a49df032 100644 --- a/gcc/tree-affine.h +++ b/gcc/tree-affine.h @@ -79,5 +79,4 @@ void free_affine_expand_cache (struct pointer_map_t **); bool aff_comb_cannot_overlap_p (aff_tree *, double_int, double_int); /* Debugging functions. */ -void print_aff (FILE *, aff_tree *); void debug_aff (aff_tree *); diff --git a/gcc/tree-cfg.c b/gcc/tree-cfg.c index eb7b62a72c5..1f59c03cfcd 100644 --- a/gcc/tree-cfg.c +++ b/gcc/tree-cfg.c @@ -2273,6 +2273,43 @@ gimple_cfg2vcg (FILE *file) Miscellaneous helpers ---------------------------------------------------------------------------*/ +/* Return true if T, a GIMPLE_CALL, can make an abnormal transfer of control + flow. Transfers of control flow associated with EH are excluded. */ + +static bool +call_can_make_abnormal_goto (gimple t) +{ + /* If the function has no non-local labels, then a call cannot make an + abnormal transfer of control. */ + if (!cfun->has_nonlocal_label) + return false; + + /* Likewise if the call has no side effects. */ + if (!gimple_has_side_effects (t)) + return false; + + /* Likewise if the called function is leaf. */ + if (gimple_call_flags (t) & ECF_LEAF) + return false; + + return true; +} + + +/* Return true if T can make an abnormal transfer of control flow. + Transfers of control flow associated with EH are excluded. */ + +bool +stmt_can_make_abnormal_goto (gimple t) +{ + if (computed_goto_p (t)) + return true; + if (is_gimple_call (t)) + return call_can_make_abnormal_goto (t); + return false; +} + + /* Return true if T represents a stmt that always transfers control. */ bool @@ -2306,10 +2343,8 @@ is_ctrl_altering_stmt (gimple t) { int flags = gimple_call_flags (t); - /* A non-pure/const call alters flow control if the current - function has nonlocal labels. */ - if (!(flags & (ECF_CONST | ECF_PURE | ECF_LEAF)) - && cfun->has_nonlocal_label) + /* A call alters control flow if it can make an abnormal goto. */ + if (call_can_make_abnormal_goto (t)) return true; /* A call also alters control flow if it does not return. */ @@ -2367,21 +2402,6 @@ simple_goto_p (gimple t) } -/* Return true if T can make an abnormal transfer of control flow. - Transfers of control flow associated with EH are excluded. */ - -bool -stmt_can_make_abnormal_goto (gimple t) -{ - if (computed_goto_p (t)) - return true; - if (is_gimple_call (t)) - return (gimple_has_side_effects (t) && cfun->has_nonlocal_label - && !(gimple_call_flags (t) & ECF_LEAF)); - return false; -} - - /* Return true if STMT should start a new basic block. PREV_STMT is the statement preceding STMT. It is used when STMT is a label or a case label. Labels should only start a new basic block if their diff --git a/gcc/tree-data-ref.c b/gcc/tree-data-ref.c index 9b3a10df3c7..6fb0d23f74e 100644 --- a/gcc/tree-data-ref.c +++ b/gcc/tree-data-ref.c @@ -140,7 +140,7 @@ int_divides_p (int a, int b) /* Dump into FILE all the data references from DATAREFS. */ -void +static void dump_data_references (FILE *file, VEC (data_reference_p, heap) *datarefs) { unsigned int i; @@ -158,27 +158,6 @@ debug_data_references (VEC (data_reference_p, heap) *datarefs) dump_data_references (stderr, datarefs); } -/* Dump to STDERR all the dependence relations from DDRS. */ - -DEBUG_FUNCTION void -debug_data_dependence_relations (VEC (ddr_p, heap) *ddrs) -{ - dump_data_dependence_relations (stderr, ddrs); -} - -/* Dump into FILE all the dependence relations from DDRS. */ - -void -dump_data_dependence_relations (FILE *file, - VEC (ddr_p, heap) *ddrs) -{ - unsigned int i; - struct data_dependence_relation *ddr; - - FOR_EACH_VEC_ELT (ddr_p, ddrs, i, ddr) - dump_data_dependence_relation (file, ddr); -} - /* Print to STDERR the data_reference DR. */ DEBUG_FUNCTION void @@ -253,7 +232,7 @@ dump_conflict_function (FILE *outf, conflict_function *cf) /* Dump function for a SUBSCRIPT structure. */ -void +static void dump_subscript (FILE *outf, struct subscript *subscript) { conflict_function *cf = SUB_CONFLICTS_IN_A (subscript); @@ -286,7 +265,7 @@ dump_subscript (FILE *outf, struct subscript *subscript) /* Print the classic direction vector DIRV to OUTF. */ -void +static void print_direction_vector (FILE *outf, lambda_vector dirv, int length) @@ -331,7 +310,7 @@ print_direction_vector (FILE *outf, /* Print a vector of direction vectors. */ -void +static void print_dir_vectors (FILE *outf, VEC (lambda_vector, heap) *dir_vects, int length) { @@ -356,9 +335,9 @@ print_lambda_vector (FILE * outfile, lambda_vector vector, int n) /* Print a vector of distance vectors. */ -void -print_dist_vectors (FILE *outf, VEC (lambda_vector, heap) *dist_vects, - int length) +static void +print_dist_vectors (FILE *outf, VEC (lambda_vector, heap) *dist_vects, + int length) { unsigned j; lambda_vector v; @@ -367,17 +346,9 @@ print_dist_vectors (FILE *outf, VEC (lambda_vector, heap) *dist_vects, print_lambda_vector (outf, v, length); } -/* Debug version. */ - -DEBUG_FUNCTION void -debug_data_dependence_relation (struct data_dependence_relation *ddr) -{ - dump_data_dependence_relation (stderr, ddr); -} - /* Dump function for a DATA_DEPENDENCE_RELATION structure. */ -void +static void dump_data_dependence_relation (FILE *outf, struct data_dependence_relation *ddr) { @@ -450,45 +421,33 @@ dump_data_dependence_relation (FILE *outf, fprintf (outf, ")\n"); } -/* Dump function for a DATA_DEPENDENCE_DIRECTION structure. */ +/* Debug version. */ -void -dump_data_dependence_direction (FILE *file, - enum data_dependence_direction dir) +DEBUG_FUNCTION void +debug_data_dependence_relation (struct data_dependence_relation *ddr) { - switch (dir) - { - case dir_positive: - fprintf (file, "+"); - break; - - case dir_negative: - fprintf (file, "-"); - break; - - case dir_equal: - fprintf (file, "="); - break; + dump_data_dependence_relation (stderr, ddr); +} - case dir_positive_or_negative: - fprintf (file, "+-"); - break; +/* Dump into FILE all the dependence relations from DDRS. */ - case dir_positive_or_equal: - fprintf (file, "+="); - break; +void +dump_data_dependence_relations (FILE *file, + VEC (ddr_p, heap) *ddrs) +{ + unsigned int i; + struct data_dependence_relation *ddr; - case dir_negative_or_equal: - fprintf (file, "-="); - break; + FOR_EACH_VEC_ELT (ddr_p, ddrs, i, ddr) + dump_data_dependence_relation (file, ddr); +} - case dir_star: - fprintf (file, "*"); - break; +/* Dump to STDERR all the dependence relations from DDRS. */ - default: - break; - } +DEBUG_FUNCTION void +debug_data_dependence_relations (VEC (ddr_p, heap) *ddrs) +{ + dump_data_dependence_relations (stderr, ddrs); } /* Dumps the distance and direction vectors in FILE. DDRS contains @@ -496,7 +455,7 @@ dump_data_dependence_direction (FILE *file, dependence vectors, or in other words the number of loops in the considered nest. */ -void +static void dump_dist_dir_vectors (FILE *file, VEC (ddr_p, heap) *ddrs) { unsigned int i, j; @@ -526,7 +485,7 @@ dump_dist_dir_vectors (FILE *file, VEC (ddr_p, heap) *ddrs) /* Dumps the data dependence relations DDRS in FILE. */ -void +static void dump_ddrs (FILE *file, VEC (ddr_p, heap) *ddrs) { unsigned int i; @@ -538,6 +497,12 @@ dump_ddrs (FILE *file, VEC (ddr_p, heap) *ddrs) fprintf (file, "\n\n"); } +DEBUG_FUNCTION void +debug_ddrs (VEC (ddr_p, heap) *ddrs) +{ + dump_ddrs (stderr, ddrs); +} + /* Helper function for split_constant_offset. Expresses OP0 CODE OP1 (the type of the result is TYPE) as VAR + OFF, where OFF is a nonzero constant of type ssizetype, and returns true. If we cannot do this @@ -4236,10 +4201,24 @@ compute_all_dependences (VEC (data_reference_p, heap) *datarefs, return true; } +/* Describes a location of a memory reference. */ + +typedef struct data_ref_loc_d +{ + /* Position of the memory reference. */ + tree *pos; + + /* True if the memory reference is read. */ + bool is_read; +} data_ref_loc; + +DEF_VEC_O (data_ref_loc); +DEF_VEC_ALLOC_O (data_ref_loc, heap); + /* Stores the locations of memory references in STMT to REFERENCES. Returns true if STMT clobbers memory, false otherwise. */ -bool +static bool get_references_in_stmt (gimple stmt, VEC (data_ref_loc, heap) **references) { bool clobbers_memory = false; @@ -4708,7 +4687,7 @@ free_data_refs (VEC (data_reference_p, heap) *datarefs) /* Dump vertex I in RDG to FILE. */ -void +static void dump_rdg_vertex (FILE *file, struct graph *rdg, int i) { struct vertex *v = &(rdg->vertices[i]); @@ -4744,7 +4723,8 @@ debug_rdg_vertex (struct graph *rdg, int i) /* Dump component C of RDG to FILE. If DUMPED is non-null, set the dumped vertices to that bitmap. */ -void dump_rdg_component (FILE *file, struct graph *rdg, int c, bitmap dumped) +static void +dump_rdg_component (FILE *file, struct graph *rdg, int c, bitmap dumped) { int i; @@ -5129,20 +5109,19 @@ build_rdg (struct loop *loop, VEC (data_reference_p, heap) **datarefs) { struct graph *rdg = NULL; - VEC (gimple, heap) *stmts = VEC_alloc (gimple, heap, 10); - - compute_data_dependences_for_loop (loop, false, loop_nest, datarefs, - dependence_relations); - if (known_dependences_p (*dependence_relations)) + if (compute_data_dependences_for_loop (loop, false, loop_nest, datarefs, + dependence_relations) + && known_dependences_p (*dependence_relations)) { + VEC (gimple, heap) *stmts = VEC_alloc (gimple, heap, 10); stmts_from_loop (loop, &stmts); rdg = build_empty_rdg (VEC_length (gimple, stmts)); create_rdg_vertices (rdg, stmts); create_rdg_edges (rdg, *dependence_relations); + VEC_free (gimple, heap, stmts); } - VEC_free (gimple, heap, stmts); return rdg; } @@ -5401,20 +5380,3 @@ remove_similar_memory_refs (VEC (gimple, heap) **stmts) htab_delete (seen); } -/* Returns the index of PARAMETER in the parameters vector of the - ACCESS_MATRIX. If PARAMETER does not exist return -1. */ - -int -access_matrix_get_index_for_parameter (tree parameter, - struct access_matrix *access_matrix) -{ - int i; - VEC (tree,heap) *lambda_parameters = AM_PARAMETERS (access_matrix); - tree lambda_parameter; - - FOR_EACH_VEC_ELT (tree, lambda_parameters, i, lambda_parameter) - if (lambda_parameter == parameter) - return i + AM_NB_INDUCTION_VARS (access_matrix); - - return -1; -} diff --git a/gcc/tree-data-ref.h b/gcc/tree-data-ref.h index d983c8cda45..41a20d74206 100644 --- a/gcc/tree-data-ref.h +++ b/gcc/tree-data-ref.h @@ -169,8 +169,6 @@ am_vector_index_for_loop (struct access_matrix *access_matrix, int loop_num) gcc_unreachable(); } -int access_matrix_get_index_for_parameter (tree, struct access_matrix *); - struct data_reference { /* A pointer to the statement that contains this DR. */ @@ -371,22 +369,6 @@ DEF_VEC_ALLOC_P(ddr_p,heap); #define DDR_REVERSED_P(DDR) DDR->reversed_p - -/* Describes a location of a memory reference. */ - -typedef struct data_ref_loc_d -{ - /* Position of the memory reference. */ - tree *pos; - - /* True if the memory reference is read. */ - bool is_read; -} data_ref_loc; - -DEF_VEC_O (data_ref_loc); -DEF_VEC_ALLOC_O (data_ref_loc, heap); - -bool get_references_in_stmt (gimple, VEC (data_ref_loc, heap) **); bool dr_analyze_innermost (struct data_reference *, struct loop *); extern bool compute_data_dependences_for_loop (struct loop *, bool, VEC (loop_p, heap) **, @@ -395,23 +377,13 @@ extern bool compute_data_dependences_for_loop (struct loop *, bool, extern bool compute_data_dependences_for_bb (basic_block, bool, VEC (data_reference_p, heap) **, VEC (ddr_p, heap) **); -extern void print_direction_vector (FILE *, lambda_vector, int); -extern void print_dir_vectors (FILE *, VEC (lambda_vector, heap) *, int); -extern void print_dist_vectors (FILE *, VEC (lambda_vector, heap) *, int); -extern void dump_subscript (FILE *, struct subscript *); -extern void dump_ddrs (FILE *, VEC (ddr_p, heap) *); -extern void dump_dist_dir_vectors (FILE *, VEC (ddr_p, heap) *); +extern void debug_ddrs (VEC (ddr_p, heap) *); extern void dump_data_reference (FILE *, struct data_reference *); extern void debug_data_reference (struct data_reference *); -extern void dump_data_references (FILE *, VEC (data_reference_p, heap) *); extern void debug_data_references (VEC (data_reference_p, heap) *); extern void debug_data_dependence_relation (struct data_dependence_relation *); -extern void dump_data_dependence_relation (FILE *, - struct data_dependence_relation *); extern void dump_data_dependence_relations (FILE *, VEC (ddr_p, heap) *); extern void debug_data_dependence_relations (VEC (ddr_p, heap) *); -extern void dump_data_dependence_direction (FILE *, - enum data_dependence_direction); extern void free_dependence_relation (struct data_dependence_relation *); extern void free_dependence_relations (VEC (ddr_p, heap) *); extern void free_data_ref (data_reference_p); @@ -567,9 +539,7 @@ typedef struct rdg_vertex #define RDG_MEM_WRITE_STMT(RDG, I) RDGV_HAS_MEM_WRITE (&(RDG->vertices[I])) #define RDG_MEM_READS_STMT(RDG, I) RDGV_HAS_MEM_READS (&(RDG->vertices[I])) -void dump_rdg_vertex (FILE *, struct graph *, int); void debug_rdg_vertex (struct graph *, int); -void dump_rdg_component (FILE *, struct graph *, int, bitmap); void debug_rdg_component (struct graph *, int); void dump_rdg (FILE *, struct graph *); void debug_rdg (struct graph *); diff --git a/gcc/tree-ssa-ccp.c b/gcc/tree-ssa-ccp.c index c28006a9132..4e86b8db0c3 100644 --- a/gcc/tree-ssa-ccp.c +++ b/gcc/tree-ssa-ccp.c @@ -1764,23 +1764,25 @@ gsi_prev_dom_bb_nondebug (gimple_stmt_iterator *i) } /* Find a BUILT_IN_STACK_SAVE dominating gsi_stmt (I), and insert - a clobber of VAR before each matching BUILT_IN_STACK_RESTORE. */ + a clobber of VAR before each matching BUILT_IN_STACK_RESTORE. + + It is possible that BUILT_IN_STACK_SAVE cannot be find in a dominator when a + previous pass (such as DOM) duplicated it along multiple paths to a BB. In + that case the function gives up without inserting the clobbers. */ static void insert_clobbers_for_var (gimple_stmt_iterator i, tree var) { - bool save_found; gimple stmt; tree saved_val; htab_t visited = NULL; - for (save_found = false; !gsi_end_p (i); gsi_prev_dom_bb_nondebug (&i)) + for (; !gsi_end_p (i); gsi_prev_dom_bb_nondebug (&i)) { stmt = gsi_stmt (i); if (!gimple_call_builtin_p (stmt, BUILT_IN_STACK_SAVE)) continue; - save_found = true; saved_val = gimple_call_lhs (stmt); if (saved_val == NULL_TREE) @@ -1792,7 +1794,6 @@ insert_clobbers_for_var (gimple_stmt_iterator i, tree var) if (visited != NULL) htab_delete (visited); - gcc_assert (save_found); } /* Detects a __builtin_alloca_with_align with constant size argument. Declares diff --git a/gcc/tree-ssa-forwprop.c b/gcc/tree-ssa-forwprop.c index 919779526d9..2b16222bbd5 100644 --- a/gcc/tree-ssa-forwprop.c +++ b/gcc/tree-ssa-forwprop.c @@ -905,6 +905,7 @@ forward_propagate_addr_expr_1 (tree name, tree def_rhs, that of the pointed-to type of the address we can put the dereferenced address on the LHS preserving the original alias-type. */ else if (gimple_assign_lhs (use_stmt) == lhs + && integer_zerop (TREE_OPERAND (lhs, 1)) && useless_type_conversion_p (TREE_TYPE (TREE_OPERAND (def_rhs, 0)), TREE_TYPE (gimple_assign_rhs1 (use_stmt)))) @@ -917,9 +918,8 @@ forward_propagate_addr_expr_1 (tree name, tree def_rhs, if (TREE_CODE (*def_rhs_basep) == MEM_REF) { new_base = TREE_OPERAND (*def_rhs_basep, 0); - new_offset - = int_const_binop (PLUS_EXPR, TREE_OPERAND (lhs, 1), - TREE_OPERAND (*def_rhs_basep, 1)); + new_offset = fold_convert (TREE_TYPE (TREE_OPERAND (lhs, 1)), + TREE_OPERAND (*def_rhs_basep, 1)); } else { @@ -989,6 +989,7 @@ forward_propagate_addr_expr_1 (tree name, tree def_rhs, that of the pointed-to type of the address we can put the dereferenced address on the RHS preserving the original alias-type. */ else if (gimple_assign_rhs1 (use_stmt) == rhs + && integer_zerop (TREE_OPERAND (rhs, 1)) && useless_type_conversion_p (TREE_TYPE (gimple_assign_lhs (use_stmt)), TREE_TYPE (TREE_OPERAND (def_rhs, 0)))) @@ -1001,9 +1002,8 @@ forward_propagate_addr_expr_1 (tree name, tree def_rhs, if (TREE_CODE (*def_rhs_basep) == MEM_REF) { new_base = TREE_OPERAND (*def_rhs_basep, 0); - new_offset - = int_const_binop (PLUS_EXPR, TREE_OPERAND (rhs, 1), - TREE_OPERAND (*def_rhs_basep, 1)); + new_offset = fold_convert (TREE_TYPE (TREE_OPERAND (rhs, 1)), + TREE_OPERAND (*def_rhs_basep, 1)); } else { diff --git a/gcc/tree-ssa-threadupdate.c b/gcc/tree-ssa-threadupdate.c index 4532886ca96..687eee0485a 100644 --- a/gcc/tree-ssa-threadupdate.c +++ b/gcc/tree-ssa-threadupdate.c @@ -826,6 +826,17 @@ determine_bb_domination_status (struct loop *loop, basic_block bb) return (bb_reachable ? DOMST_DOMINATING : DOMST_LOOP_BROKEN); } +/* Return true if BB is part of the new pre-header that is created + when threading the latch to DATA. */ + +static bool +def_split_header_continue_p (const_basic_block bb, const void *data) +{ + const_basic_block new_header = (const_basic_block) data; + return (bb->loop_father == new_header->loop_father + && bb != new_header); +} + /* Thread jumps through the header of LOOP. Returns true if cfg changes. If MAY_PEEL_LOOP_HEADERS is false, we avoid threading from entry edges to the inside of the loop. */ @@ -990,11 +1001,50 @@ thread_through_loop_header (struct loop *loop, bool may_peel_loop_headers) if (latch->aux) { - /* First handle the case latch edge is redirected. */ + basic_block *bblocks; + unsigned nblocks, i; + + /* First handle the case latch edge is redirected. We are copying + the loop header but not creating a multiple entry loop. Make the + cfg manipulation code aware of that fact. */ + set_loop_copy (loop, loop); loop->latch = thread_single_edge (latch); + set_loop_copy (loop, NULL); gcc_assert (single_succ (loop->latch) == tgt_bb); loop->header = tgt_bb; + /* Remove the new pre-header blocks from our loop. */ + bblocks = XCNEWVEC (basic_block, loop->num_nodes); + nblocks = dfs_enumerate_from (header, 0, def_split_header_continue_p, + bblocks, loop->num_nodes, tgt_bb); + for (i = 0; i < nblocks; i++) + { + remove_bb_from_loops (bblocks[i]); + add_bb_to_loop (bblocks[i], loop_outer (loop)); + } + free (bblocks); + + /* Cancel remaining threading requests that would make the + loop a multiple entry loop. */ + FOR_EACH_EDGE (e, ei, header->preds) + { + edge e2; + if (e->aux == NULL) + continue; + + if (THREAD_TARGET2 (e)) + e2 = THREAD_TARGET2 (e); + else + e2 = THREAD_TARGET (e); + + if (e->src->loop_father != e2->dest->loop_father + && e2->dest != loop->header) + { + free (e->aux); + e->aux = NULL; + } + } + /* Thread the remaining edges through the former header. */ thread_block (header, false); } diff --git a/gcc/tree-vect-slp.c b/gcc/tree-vect-slp.c index c142bbb0201..0ab6be0671a 100644 --- a/gcc/tree-vect-slp.c +++ b/gcc/tree-vect-slp.c @@ -2337,8 +2337,23 @@ vect_get_constant_vectors (tree op, slp_tree slp_node, op = gimple_call_arg (stmt, op_num); break; + case LSHIFT_EXPR: + case RSHIFT_EXPR: + case LROTATE_EXPR: + case RROTATE_EXPR: + op = gimple_op (stmt, op_num + 1); + /* Unlike the other binary operators, shifts/rotates have + the shift count being int, instead of the same type as + the lhs, so make sure the scalar is the right type if + we are dealing with vectors of + long long/long/short/char. */ + if (op_num == 1 && constant_p) + op = fold_convert (TREE_TYPE (vector_type), op); + break; + default: op = gimple_op (stmt, op_num + 1); + break; } } diff --git a/gcc/varasm.c b/gcc/varasm.c index 0c04de47974..34ed948cade 100644 --- a/gcc/varasm.c +++ b/gcc/varasm.c @@ -4420,6 +4420,7 @@ initializer_constant_valid_for_bitfield_p (tree value) } case INTEGER_CST: + case REAL_CST: return true; case VIEW_CONVERT_EXPR: @@ -5075,10 +5076,7 @@ output_constructor (tree exp, unsigned HOST_WIDE_INT size, /* The element in a union constructor specifies the proper field or index. */ - if ((TREE_CODE (local.type) == RECORD_TYPE - || TREE_CODE (local.type) == UNION_TYPE - || TREE_CODE (local.type) == QUAL_UNION_TYPE) - && ce->index != NULL_TREE) + if (RECORD_OR_UNION_TYPE_P (local.type) && ce->index != NULL_TREE) local.field = ce->index; else if (TREE_CODE (local.type) == ARRAY_TYPE) @@ -5110,9 +5108,18 @@ output_constructor (tree exp, unsigned HOST_WIDE_INT size, || !CONSTRUCTOR_BITFIELD_P (local.field))) output_constructor_regular_field (&local); - /* For a true bitfield or part of an outer one. */ + /* For a true bitfield or part of an outer one. Only INTEGER_CSTs are + supported for scalar fields, so we may need to convert first. */ else - output_constructor_bitfield (&local, outer); + { + if (TREE_CODE (local.val) == REAL_CST) + local.val + = fold_unary (VIEW_CONVERT_EXPR, + build_nonstandard_integer_type + (TYPE_PRECISION (TREE_TYPE (local.val)), 0), + local.val); + output_constructor_bitfield (&local, outer); + } } /* If we are not at toplevel, save the pending data for our caller. |