===================================================================
@@ -5582,6 +5582,9 @@ gfc_is_simply_contiguous (gfc_expr *expr, bool str
gfc_ref *ref, *part_ref = NULL;
gfc_symbol *sym;
+ if (expr->expr_type == EXPR_ARRAY)
+ return true;
+
if (expr->expr_type == EXPR_FUNCTION)
{
if (expr->value.function.esym)
===================================================================
@@ -7755,6 +7755,23 @@ array_parameter_size (tree desc, gfc_expr *expr, t
*size, fold_convert (gfc_array_index_type, elem));
}
+/* Helper function - return true if the argument is a pointer. */
+
+static bool
+is_pointer (gfc_expr *e)
+{
+ gfc_symbol *sym;
+
+ if (e->expr_type != EXPR_VARIABLE || e->symtree == NULL)
+ return false;
+
+ sym = e->symtree->n.sym;
+ if (sym == NULL)
+ return false;
+
+ return sym->attr.pointer || sym->attr.proc_pointer;
+}
+
/* Convert an array for passing as an actual parameter. */
void
@@ -8006,6 +8023,19 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr *
"Creating array temporary at %L", &expr->where);
}
+ /* When optmizing, we can use gfc_conv_subref_array_arg for
+ making the packing and unpacking operation visible to the
+ optimizers. */
+
+ if (g77 && optimize && !optimize_size && expr->expr_type == EXPR_VARIABLE
+ && !is_pointer (expr))
+ {
+ gfc_conv_subref_array_arg (se, expr, g77,
+ fsym ? fsym->attr.intent : INTENT_INOUT,
+ false, fsym, proc_name, sym);
+ return;
+ }
+
ptr = build_call_expr_loc (input_location,
gfor_fndecl_in_pack, 1, desc);
===================================================================
@@ -4536,7 +4536,9 @@ gfc_apply_interface_mapping (gfc_interface_mapping
after the function call. */
void
gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, int g77,
- sym_intent intent, bool formal_ptr)
+ sym_intent intent, bool formal_ptr,
+ const gfc_symbol *fsym, const char *proc_name,
+ gfc_symbol *sym)
{
gfc_se lse;
gfc_se rse;
@@ -4553,7 +4555,25 @@ gfc_conv_subref_array_arg (gfc_se * parmse, gfc_ex
stmtblock_t body;
int n;
int dimen;
+ tree parmse_expr;
+ if (gfc_option.rtcheck & GFC_RTCHECK_ARRAY_TEMPS)
+ {
+ /* We will create a temporary array, so let us warn. */
+ char * msg;
+
+ if (fsym && proc_name)
+ msg = xasprintf ("An array temporary was created for argument "
+ "'%s' of procedure '%s'", fsym->name, proc_name);
+ else
+ msg = xasprintf ("An array temporary was created");
+
+ tmp = build_int_cst (logical_type_node, 1);
+ gfc_trans_runtime_check (false, true, tmp, &parmse->pre,
+ &expr->where, msg);
+ free (msg);
+ }
+
gfc_init_se (&lse, NULL);
gfc_init_se (&rse, NULL);
@@ -4803,10 +4823,25 @@ class_array_fcn:
/* We want either the address for the data or the address of the descriptor,
depending on the mode of passing array arguments. */
if (g77)
- parmse->expr = gfc_conv_descriptor_data_get (parmse->expr);
+ parmse_expr = gfc_conv_descriptor_data_get (parmse->expr);
else
- parmse->expr = gfc_build_addr_expr (NULL_TREE, parmse->expr);
+ parmse_expr = gfc_build_addr_expr (NULL_TREE, parmse->expr);
+ /* Wrap in "if (present(x))" if needed. */
+
+ if (fsym && fsym->attr.optional && sym && sym->attr.optional)
+ {
+ tree present;
+ tree type;
+
+ present = gfc_conv_expr_present (sym);
+ type = TREE_TYPE (parmse_expr);
+ tmp = fold_build3_loc (input_location, COND_EXPR, type, present,
+ parmse_expr, build_int_cst (type, 0));
+ parmse_expr = tmp;
+ }
+
+ parmse->expr = parmse_expr;
return;
}
===================================================================
@@ -529,7 +529,10 @@ int gfc_is_intrinsic_libcall (gfc_expr *);
int gfc_conv_procedure_call (gfc_se *, gfc_symbol *, gfc_actual_arglist *,
gfc_expr *, vec<tree, va_gc> *);
-void gfc_conv_subref_array_arg (gfc_se *, gfc_expr *, int, sym_intent, bool);
+void gfc_conv_subref_array_arg (gfc_se *, gfc_expr *, int, sym_intent, bool,
+ const gfc_symbol *fsym = NULL,
+ const char *proc_name = NULL,
+ gfc_symbol *sym = NULL);
/* Generate code for a scalar assignment. */
tree gfc_trans_scalar_assign (gfc_se *, gfc_se *, gfc_typespec, bool, bool,
===================================================================
@@ -1,5 +1,5 @@
! { dg-do compile }
-! { dg-options "-fdump-tree-original" }
+! { dg-options "-O0 -fdump-tree-original" }
!
! Test the fix for PR66082. The original problem was with the first
! call foo_1d.
===================================================================
@@ -1,5 +1,5 @@
-! { dg-do run }
-! { dg-options "-fdump-tree-original" }
+! { dg-do compile }
+! { dg-options "-O0 -fdump-tree-original" }
!
! PR fortran/48820
!
===================================================================
@@ -1,5 +1,5 @@
! { dg-do compile }
-! { dg-options "-fdump-tree-original" }
+! { dg-options "-O0 -fdump-tree-original" }
!
! PR fortran/56907
!
===================================================================
@@ -1,5 +1,5 @@
! { dg-do compile }
-! { dg-options "-fdump-tree-original" }
+! { dg-options "-O0 -fdump-tree-original" }
!
! PR fortran/40632
!
===================================================================
@@ -1,5 +1,5 @@
! { dg-do compile }
-! { dg-options "-fdump-tree-original" }
+! { dg-options "-O0 -fdump-tree-original" }
!
! Test the fix for PR43173, where unnecessary calls to internal_pack/unpack
! were being produced below. These references are contiguous and so do not
===================================================================
@@ -1,5 +1,5 @@
! { dg-do compile }
-! { dg-options "-fdump-tree-original" }
+! { dg-options "-O0 -fdump-tree-original" }
!
! Test the fix for PR43243, where unnecessary calls to internal_pack/unpack
! were being produced below. These references are contiguous and so do not
===================================================================
@@ -1,5 +1,5 @@
! { dg-do compile }
-! { dg-additional-options "-fdump-tree-original" }
+! { dg-additional-options "-O0 -fdump-tree-original" }
! PR 59345 - pack/unpack was not needed here.
SUBROUTINE S1(A)
REAL :: A(3)
===================================================================
@@ -1,5 +1,5 @@
! { dg-do compile }
-! { dg-additional-options "-fdump-tree-original" }
+! { dg-additional-options "-O0 -fdump-tree-original" }
! PR 59345 - pack/unpack was not needed here.
! Original test case by Joost VandeVondele
SUBROUTINE S1(A)
===================================================================
@@ -1,5 +1,5 @@
! { dg-do compile }
-! { dg-additional-options "-fdump-tree-original" }
+! { dg-additional-options "-O0 -fdump-tree-original" }
! PR 57992 - this was packed/unpacked unnecessarily.
! Original case by Tobias Burnus.
subroutine test
===================================================================
@@ -1,5 +1,4 @@
! { dg-do run }
-! { dg-options "-fdump-tree-original" }
!
! PR fortran/36132
!
@@ -25,6 +24,3 @@ END MODULE M1
USE M1
CALL S2()
END
-
-! { dg-final { scan-tree-dump-times "a != 0B \\? \\\(.*\\\) _gfortran_internal_pack" 1 "original" } }
-! { dg-final { scan-tree-dump-times "if \\(a != 0B &&" 1 "original" } }
===================================================================
@@ -1,5 +1,5 @@
! { dg-do compile }
-! { dg-options "-fdump-tree-original" }
+! { dg-options "-O0 -fdump-tree-original" }
!
! PR fortran/36909
!
===================================================================
@@ -1,5 +1,5 @@
-! { dg-do run }
-! { dg-options "-fdump-tree-original" }
+! { dg-do compile }
+! { dg-options "-O0 -fdump-tree-original" }
!
! Test the fix for PR41113 and PR41117, in which unnecessary calls
! to internal_pack and internal_unpack were being generated.
===================================================================
@@ -1,5 +1,5 @@
! { dg-do compile }
-! { dg-options "-fdump-tree-original" }
+! { dg-options "-O0 -fdump-tree-original" }
!
! During the discussion of the fix for PR43072, in which unnecessary
! calls to internal PACK/UNPACK were being generated, the following,
===================================================================
@@ -46,14 +46,3 @@ contains
end subroutine scalar2
end program test
-
-! { dg-final { scan-tree-dump-times "scalar2 \\(slr1" 1 "original" } }
-
-! { dg-final { scan-tree-dump-times "= es1 != 0B" 1 "original" } }
-! { dg-final { scan-tree-dump-times "assumed_shape2 \\(es1" 0 "original" } }
-! { dg-final { scan-tree-dump-times "explicit_shape2 \\(es1" 1 "original" } }
-
-! { dg-final { scan-tree-dump-times "= as1 != 0B" 2 "original" } }
-! { dg-final { scan-tree-dump-times "assumed_shape2 \\(as1" 0 "original" } }
-! { dg-final { scan-tree-dump-times "explicit_shape2 \\(as1" 0 "original" } }
-
===================================================================
@@ -1,5 +1,5 @@
-! { dg-do run }
-! { dg-options "-fdump-tree-original" }
+! { dg-do compile }
+! { dg-options "-O0 -fdump-tree-original" }
!
! PR fortran/39505
!
===================================================================
@@ -1,5 +1,5 @@
-! { dg-do run }
-! { dg-options "-fdump-tree-original" }
+! { dg-do compile }
+! { dg-options "-O0 -fdump-tree-original" }
!
! PR fortran/49074
! ICE on defined assignment with class arrays.
===================================================================
@@ -1,5 +1,4 @@
! { dg-do run }
-! { dg-options "-fdump-tree-original" }
!
! PR fortran/56136
! ICE on defined assignment with class arrays.
@@ -37,6 +36,3 @@
IF (ANY(A(2::2)%I /= (/ ((50+2*I, I=1,SIZE(A)/4), J=1,2) /))) STOP 3
END PROGRAM
-! { dg-final { scan-tree-dump-times "_gfortran_internal_pack" 1 "original" } }
-! { dg-final { scan-tree-dump-times "_gfortran_internal_unpack" 1 "original" } }
-
Hello world, the attached patch moves the packing / unpacking of arrays to the front end when optimizing, but not for size. Rationale: internal_pack and internal_unpack are opaque to the compiler. This can lead to a lot of information loss for inlining and inter- procedural optimization, and in extreme cases can lead to huge slowdowns. I don't want to do this for -Os or for -O0. -Os because I want to avoid size increases, and -O0 for several reasons: The current method works well, if there should turn out to be a bug still hiding in this code I want to at least have "works with -O0" in the bug report, and finally I did not want to rewrite all test cases. Because run test cases cycle through a lot of optimization options, I had to split some of them up - test the pattern matches with -O0, test for run time correctness under all the options. I have regression-tested this. I would, however, prefer if some people could run this patch against their non-testsuite code and report any problems that this may introduce. So, if you can spare the time and the cycles, that would be great. The nice thing about this kind of patch is that, if this does not work for a certain condition, it is usually straightforward to check for the condition and then simply not do the optimization. So, comments? Bug reports? OK for trunk if nobody has come up with a bug in the next few days? Regards Thomas 2019-01-22 Thomas Koenig <tkoenig@gcc.gnu.org> PR fortran/88821 * expr.c (gfc_is_simply_contiguous): Return true for an EXPR_ARRAY. * trans-array.c (is_pointer): New function. (gfc_conv_array_parameter): Call gfc_conv_subref_array_arg when not optimizing and not optimizing for size if the formal arg is passed by reference. * trans-expr.c (gfc_conv_subref_array_arg): Add arguments fsym, proc_name and sym. Add run-time warning for temporary array creation. Wrap argument if passing on an optional argument to an optional argument. * trans.h (gfc_conv_subref_array_arg): Add optional arguments fsym, proc_name and sym to prototype. 2019-01-22 Thomas Koenig <tkoenig@gcc.gnu.org> PR fortran/88821 * gfortran.dg/alloc_comp_auto_array_3.f90: Add -O0 to dg-options to make sure the test for internal_pack is retained. * gfortran.dg/assumed_type_2.f90: Split compile and run time tests into this and * gfortran.dg/assumed_type_2a.f90: New file. * gfortran.dg/c_loc_test_22.f90: Likewise. * gfortran.dg/contiguous_3.f90: Likewise. * gfortran.dg/internal_pack_11.f90: Likewise. * gfortran.dg/internal_pack_12.f90: Likewise. * gfortran.dg/internal_pack_16.f90: Likewise. * gfortran.dg/internal_pack_17.f90: Likewise. * gfortran.dg/internal_pack_18.f90: Likewise. * gfortran.dg/internal_pack_4.f90: Likewise. * gfortran.dg/internal_pack_5.f90: Add -O0 to dg-options to make sure the test for internal_pack is retained. * gfortran.dg/internal_pack_6.f90: Split compile and run time tests into this and * gfortran.dg/internal_pack_6a.f90: New file. * gfortran.dg/internal_pack_8.f90: Likewise. * gfortran.dg/missing_optional_dummy_6: Split compile and run time tests into this and * gfortran.dg/missing_optional_dummy_6a.f90: New file. * gfortran.dg/no_arg_check_2.f90: Split compile and run time tests into this and * gfortran.dg/no_arg_check_2a.f90: New file. * gfortran.dg/typebound_assignment_5.f90: Split compile and run time tests into this and * gfortran.dg/typebound_assignment_5a.f90: New file. * gfortran.dg/typebound_assignment_6.f90: Split compile and run time tests into this and * gfortran.dg/typebound_assignment_6a.f90: New file. * gfortran.dg/internal_pack_19.f90: New file. * gfortran.dg/internal_pack_20.f90: New file. ! { dg-do compile } ! { dg-options "-O0 -fdump-tree-original" } ! ! PR fortran/56136 ! ICE on defined assignment with class arrays. ! ! Original testcase by Alipasha <alipash.celeris@gmail.com> MODULE A_TEST_M TYPE :: A_TYPE INTEGER :: I CONTAINS GENERIC :: ASSIGNMENT (=) => ASGN_A PROCEDURE, PRIVATE :: ASGN_A END TYPE CONTAINS ELEMENTAL SUBROUTINE ASGN_A (A, B) CLASS (A_TYPE), INTENT (INOUT) :: A CLASS (A_TYPE), INTENT (IN) :: B A%I = B%I END SUBROUTINE END MODULE A_TEST_M PROGRAM ASGN_REALLOC_TEST USE A_TEST_M TYPE (A_TYPE), ALLOCATABLE :: A(:) INTEGER :: I, J ALLOCATE (A(100)) A = (/ (A_TYPE(I), I=1,SIZE(A)) /) A(1:50) = A(51:100) IF (ANY(A%I /= (/ ((50+I, I=1,SIZE(A)/2), J=1,2) /))) STOP 1 A(::2) = A(1:50) ! pack/unpack IF (ANY(A( ::2)%I /= (/ (50+I, I=1,SIZE(A)/2) /))) STOP 2 IF (ANY(A(2::2)%I /= (/ ((50+2*I, I=1,SIZE(A)/4), J=1,2) /))) STOP 3 END PROGRAM ! { dg-final { scan-tree-dump-times "_gfortran_internal_pack" 1 "original" } } ! { dg-final { scan-tree-dump-times "_gfortran_internal_unpack" 1 "original" } } ! { dg-do run } ! ! PR fortran/49074 ! ICE on defined assignment with class arrays. module foo type bar integer :: i contains generic :: assignment (=) => assgn_bar procedure, private :: assgn_bar end type bar contains elemental subroutine assgn_bar (a, b) class (bar), intent (inout) :: a class (bar), intent (in) :: b select type (b) type is (bar) a%i = b%i end select return end subroutine assgn_bar end module foo program main use foo type (bar), allocatable :: foobar(:) allocate (foobar(2)) foobar = [bar(1), bar(2)] if (any(foobar%i /= [1, 2])) STOP 1 end program