Hi Mikael, dear all,
Mikael Morin wrote:
PPS: The offset handling in gfortran is really complicated. I wonder
whether we have to (or at least should) change it for the new array
descriptor.
I don't know exactly what you mean by "really complicated". There are
not many simple things in gfortran ;-).
;-)
And I don't know what you mean by "change it". Generally I'm in favour
of changing as few things as possible, or at least changing them
incrementally, but there could well exist some cases where changing
everything together is just simpler.
Well, one has to check the TS29113, but my impression is that it doesn't
contain that field. That does not imply that we have to get rid of
"offset". But if we don't one has to make sure that it will also work
correctly with descriptors passed to and from C, which might get
difficult. Thus, if needed, I'd prefer to really use only the semantics
and fields of the C descriptor of TS29113.
You initialize offset to 1... [...] ...and then update it in the loop
with an if condition to skip the first iteration. Wouldn't it be
better to initialize to 0, and update without condition?
Well spotted! I had that much trouble at some point that I simply copied
the algorithm from the library, which has that condition. Performance
and code wise, getting rid of conditionals is highly useful. Thanks!
Could/Should we use a NEGATE_EXPR instead of a multiplication by -1?
It probably doesn't matter that much, but given that a sign flip is
cheap, I assume the compiler internally handles it that way. That change
probably saves some time for optimization, an int cst tree declaration,
and makes the code shorter.
Thanks for your helpful comments!
Tobias
PS: I have committed the attached patch as Rev. 189442.
2012-07-12 Tobias Burnus <bur...@net-b.de>
* trans-expr.c (conv_isocbinding_procedure): Generate c_f_pointer code
inline.
2012-07-12 Tobias Burnus <bur...@net-b.de>
* gfortran.dg/c_f_pointer_shape_tests_5.f90: New.
* gfortran.dg/c_f_pointer_tests_3.f90: Update
scan-tree-dump-times pattern.
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 7d1a6d4..34e0f69 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -3307,14 +3307,17 @@ conv_isocbinding_procedure (gfc_se * se, gfc_symbol * sym,
return 1;
}
- else if ((sym->intmod_sym_id == ISOCBINDING_F_POINTER
- && arg->next->expr->rank == 0)
+ else if (sym->intmod_sym_id == ISOCBINDING_F_POINTER
|| sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER)
{
- /* Convert c_f_pointer if fptr is a scalar
- and convert c_f_procpointer. */
+ /* Convert c_f_pointer and c_f_procpointer. */
gfc_se cptrse;
gfc_se fptrse;
+ gfc_se shapese;
+ gfc_ss *ss, *shape_ss;
+ tree desc, dim, tmp, stride, offset;
+ stmtblock_t body, block;
+ gfc_loopinfo loop;
gfc_init_se (&cptrse, NULL);
gfc_conv_expr (&cptrse, arg->expr);
@@ -3322,25 +3325,103 @@ conv_isocbinding_procedure (gfc_se * se, gfc_symbol * sym,
gfc_add_block_to_block (&se->post, &cptrse.post);
gfc_init_se (&fptrse, NULL);
- if (sym->intmod_sym_id == ISOCBINDING_F_POINTER
- || gfc_is_proc_ptr_comp (arg->next->expr, NULL))
- fptrse.want_pointer = 1;
+ if (arg->next->expr->rank == 0)
+ {
+ if (sym->intmod_sym_id == ISOCBINDING_F_POINTER
+ || gfc_is_proc_ptr_comp (arg->next->expr, NULL))
+ fptrse.want_pointer = 1;
+
+ gfc_conv_expr (&fptrse, arg->next->expr);
+ gfc_add_block_to_block (&se->pre, &fptrse.pre);
+ gfc_add_block_to_block (&se->post, &fptrse.post);
+ if (arg->next->expr->symtree->n.sym->attr.proc_pointer
+ && arg->next->expr->symtree->n.sym->attr.dummy)
+ fptrse.expr = build_fold_indirect_ref_loc (input_location,
+ fptrse.expr);
+ se->expr = fold_build2_loc (input_location, MODIFY_EXPR,
+ TREE_TYPE (fptrse.expr),
+ fptrse.expr,
+ fold_convert (TREE_TYPE (fptrse.expr),
+ cptrse.expr));
+ return 1;
+ }
- gfc_conv_expr (&fptrse, arg->next->expr);
- gfc_add_block_to_block (&se->pre, &fptrse.pre);
- gfc_add_block_to_block (&se->post, &fptrse.post);
-
- if (arg->next->expr->symtree->n.sym->attr.proc_pointer
- && arg->next->expr->symtree->n.sym->attr.dummy)
- fptrse.expr = build_fold_indirect_ref_loc (input_location,
- fptrse.expr);
-
- se->expr = fold_build2_loc (input_location, MODIFY_EXPR,
- TREE_TYPE (fptrse.expr),
- fptrse.expr,
- fold_convert (TREE_TYPE (fptrse.expr),
- cptrse.expr));
+ gfc_start_block (&block);
+
+ /* Get the descriptor of the Fortran pointer. */
+ ss = gfc_walk_expr (arg->next->expr);
+ gcc_assert (ss != gfc_ss_terminator);
+ fptrse.descriptor_only = 1;
+ gfc_conv_expr_descriptor (&fptrse, arg->next->expr, ss);
+ gfc_add_block_to_block (&block, &fptrse.pre);
+ desc = fptrse.expr;
+
+ /* Set data value, dtype, and offset. */
+ tmp = GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc));
+ gfc_conv_descriptor_data_set (&block, desc,
+ fold_convert (tmp, cptrse.expr));
+ gfc_add_modify (&block, gfc_conv_descriptor_dtype (desc),
+ gfc_get_dtype (TREE_TYPE (desc)));
+
+ /* Start scalarization of the bounds, using the shape argument. */
+
+ shape_ss = gfc_walk_expr (arg->next->next->expr);
+ gcc_assert (shape_ss != gfc_ss_terminator);
+ gfc_init_se (&shapese, NULL);
+
+ gfc_init_loopinfo (&loop);
+ gfc_add_ss_to_loop (&loop, shape_ss);
+ gfc_conv_ss_startstride (&loop);
+ gfc_conv_loop_setup (&loop, &arg->next->expr->where);
+ gfc_mark_ss_chain_used (shape_ss, 1);
+
+ gfc_copy_loopinfo_to_se (&shapese, &loop);
+ shapese.ss = shape_ss;
+
+ stride = gfc_create_var (gfc_array_index_type, "stride");
+ offset = gfc_create_var (gfc_array_index_type, "offset");
+ gfc_add_modify (&block, stride, gfc_index_one_node);
+ gfc_add_modify (&block, offset, gfc_index_zero_node);
+
+ /* Loop body. */
+ gfc_start_scalarized_body (&loop, &body);
+
+ dim = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+ loop.loopvar[0], loop.from[0]);
+
+ /* Set bounds and stride. */
+ gfc_conv_descriptor_lbound_set (&body, desc, dim, gfc_index_one_node);
+ gfc_conv_descriptor_stride_set (&body, desc, dim, stride);
+
+ gfc_conv_expr (&shapese, arg->next->next->expr);
+ gfc_add_block_to_block (&body, &shapese.pre);
+ gfc_conv_descriptor_ubound_set (&body, desc, dim, shapese.expr);
+ gfc_add_block_to_block (&body, &shapese.post);
+
+ /* Calculate offset. */
+ gfc_add_modify (&body, offset,
+ fold_build2_loc (input_location, PLUS_EXPR,
+ gfc_array_index_type, offset, stride));
+ /* Update stride. */
+ gfc_add_modify (&body, stride,
+ fold_build2_loc (input_location, MULT_EXPR,
+ gfc_array_index_type, stride,
+ fold_convert (gfc_array_index_type,
+ shapese.expr)));
+ /* Finish scalarization loop. */
+ gfc_trans_scalarizing_loops (&loop, &body);
+ gfc_add_block_to_block (&block, &loop.pre);
+ gfc_add_block_to_block (&block, &loop.post);
+ gfc_add_block_to_block (&block, &fptrse.post);
+ gfc_cleanup_loop (&loop);
+ gfc_free_ss (ss);
+
+ gfc_add_modify (&block, offset,
+ fold_build1_loc (input_location, NEGATE_EXPR,
+ gfc_array_index_type, offset));
+ gfc_conv_descriptor_offset_set (&block, desc, offset);
+ se->expr = gfc_finish_block (&block);
return 1;
}
else if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
diff --git a/gcc/testsuite/gfortran.dg/c_f_pointer_tests_3.f90 b/gcc/testsuite/gfortran.dg/c_f_pointer_tests_3.f90
index f7d6fa7..29072b8 100644
--- a/gcc/testsuite/gfortran.dg/c_f_pointer_tests_3.f90
+++ b/gcc/testsuite/gfortran.dg/c_f_pointer_tests_3.f90
@@ -21,14 +21,21 @@ program test
call c_f_procpointer(cfunptr, fprocptr)
end program test
-! Make sure there is only a single function call:
-! { dg-final { scan-tree-dump-times "c_f" 1 "original" } }
-! { dg-final { scan-tree-dump-times "c_f_pointer" 1 "original" } }
-! { dg-final { scan-tree-dump-times "c_f_pointer_i4" 1 "original" } }
+! Make sure there is no function call:
+! { dg-final { scan-tree-dump-times "c_f" 0 "original" } }
+! { dg-final { scan-tree-dump-times "c_f_pointer" 0 "original" } }
+! { dg-final { scan-tree-dump-times "c_f_pointer_i4" 0 "original" } }
!
! Check scalar c_f_pointer
! { dg-final { scan-tree-dump-times " fptr = .integer.kind=4. .. cptr" 1 "original" } }
!
+! Array c_f_pointer:
+!
+! { dg-final { scan-tree-dump-times " fptr_array.data = cptr;" 1 "original" } }
+! { dg-final { scan-tree-dump-times " fptr_array.dim\\\[S..\\\].lbound = 1;" 1 "original" } }
+! { dg-final { scan-tree-dump-times " fptr_array.dim\\\[S..\\\].ubound = " 1 "original" } }
+! { dg-final { scan-tree-dump-times " fptr_array.dim\\\[S..\\\].stride = " 1 "original" } }
+!
! Check c_f_procpointer
! { dg-final { scan-tree-dump-times " fprocptr = .integer.kind=4. .\\*<.*>. ... cfunptr;" 1 "original" } }
!
--- /dev/null 2012-06-26 07:11:42.215802679 +0200
+++ gcc/gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_5.f90 2012-06-28 08:29:40.000000000 +0200
@@ -0,0 +1,27 @@
+! { dg-do run }
+!
+! Check that C_F_Pointer works with a noncontiguous SHAPE argument
+!
+use iso_c_binding
+type(c_ptr) :: x
+integer, target :: array(3)
+integer, pointer :: ptr(:,:)
+integer, pointer :: ptr2(:,:,:)
+integer :: myshape(5)
+
+array = [22,33,44]
+x = c_loc(array)
+myshape = [1,2,3,4,1]
+
+call c_f_pointer(x, ptr, shape=myshape(1:4:2))
+if (any (lbound(ptr) /= [ 1, 1])) call abort ()
+if (any (ubound(ptr) /= [ 1, 3])) call abort ()
+if (any (shape(ptr) /= [ 1, 3])) call abort ()
+if (any (ptr(1,:) /= array)) call abort()
+
+call c_f_pointer(x, ptr2, shape=myshape([1,3,1]))
+if (any (lbound(ptr2) /= [ 1, 1, 1])) call abort ()
+if (any (ubound(ptr2) /= [ 1, 3, 1])) call abort ()
+if (any (shape(ptr2) /= [ 1, 3, 1])) call abort ()
+if (any (ptr2(1,:,1) /= array)) call abort()
+end