Patchwork [Fortran] Handle C_F_POINTER with a noncontiguous SHAPE=

login
register
mail settings
Submitter Tobias Burnus
Date June 28, 2012, 7:34 a.m.
Message ID <4FEC090F.4090507@net-b.de>
Download mbox | patch
Permalink /patch/167810/
State New
Headers show

Comments

Tobias Burnus - June 28, 2012, 7:34 a.m.
This patch generates inline code for C_F_POINTER with an array argument. 
One reason is that GCC didn't handle SHAPE= arguments which were 
noncontiguous.

However, the real motivation is the fortran-dev branch with the new 
array-descriptor: C_F_POINTER needs then to set the stride multiplier, 
but as it doesn't know the size of a single element, one had either to 
pass the value or handle it partially in the front end. Hence, doing it 
all in the front-end was simpler. The C_F_Pointer issue is the main 
cause for failing test cases on the branch, though several other issues 
remain.

Build and regtested on x86-64-linux-
OK for the trunk?

* * *

If you wonder why I had some problems before: 
http://gcc.gnu.org/ml/fortran/2012-04/msg00115.html

The reason is that I called pushlevel() twice for "body":

+      gfc_start_block (&body);
+      gfc_start_scalarized_body (&loop, &body);


I removed the first one - and now it works. (Well, there were also some 
other issues in the patch, which are now fixed.)

Tobias

PS: After committal, I will update the patch for the branch; let's see 
how many failures will remain on the branch.

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.
Tobias Burnus - July 12, 2012, 10:10 a.m.
*ping*

On 06/28/2012 09:34 AM, Tobias Burnus wrote:
> This patch generates inline code for C_F_POINTER with an array 
> argument. One reason is that GCC didn't handle SHAPE= arguments which 
> were noncontiguous.

Actually, I just messed up my test case and didn't properly read the 
libgfortran/intrinsics/iso_c_binding.c file. The current library version 
does support noncontiguous shapes. However, for other reasons - such as 
the one below - I still would like to commit the patch; and for review 
purpose I also would like to include it now and not together with the 
branch.

> However, the real motivation is the fortran-dev branch with the new 
> array-descriptor: C_F_POINTER needs then to set the stride multiplier, 
> but as it doesn't know the size of a single element, one had either to 
> pass the value or handle it partially in the front end. Hence, doing 
> it all in the front-end was simpler. The C_F_Pointer issue is the main 
> cause for failing test cases on the branch, though several other 
> issues remain.
>
> Build and regtested on x86-64-linux-
> OK for the trunk?
>
> * * *
>
> If you wonder why I had some problems before: 
> http://gcc.gnu.org/ml/fortran/2012-04/msg00115.html
>
> The reason is that I called pushlevel() twice for "body":
>
> +      gfc_start_block (&body);
> +      gfc_start_scalarized_body (&loop, &body);
>
>
> I removed the first one - and now it works. (Well, there were also 
> some other issues in the patch, which are now fixed.)
>
> Tobias
>
> PS: After committal, I will update the patch for the branch; let's see 
> how many failures will remain on the branch.
>
> 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.
Mikael Morin - July 12, 2012, 6:40 p.m.
On 28/06/2012 09:34, Tobias Burnus wrote:
> This patch generates inline code for C_F_POINTER with an array argument.
> One reason is that GCC didn't handle SHAPE= arguments which were
> noncontiguous.
> 
> However, the real motivation is the fortran-dev branch with the new
> array-descriptor: C_F_POINTER needs then to set the stride multiplier,
> but as it doesn't know the size of a single element, one had either to
> pass the value or handle it partially in the front end. Hence, doing it
> all in the front-end was simpler. The C_F_Pointer issue is the main
> cause for failing test cases on the branch, though several other issues
> remain.
> 
> Build and regtested on x86-64-linux-
> OK for the trunk?
> 

Two comments about your patch below.


> 
> 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.



> +
> +      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_one_node);
> +
You initialize offset to 1...

[...]

> +
> +      /* Calculate offset. */
> +      gfc_init_block (&ifblock);
> +      gfc_add_modify (&ifblock, offset,
> +		      fold_build2_loc (input_location, PLUS_EXPR,
> +				       gfc_array_index_type, offset, stride));
> +      tmp = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
> +			     loop.loopvar[0],loop.from[0]);
> +      tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, tmp,
> +			     gfc_finish_block (&ifblock),
> +			     build_empty_stmt (input_location));
> +      gfc_add_expr_to_block (&body, tmp);
> +
...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?


[...]


> +
> +      gfc_add_modify (&block, offset, 
> +		      fold_build2_loc (input_location, MULT_EXPR,
> +				       gfc_array_index_type, offset,
> +				       build_int_cst (gfc_array_index_type,
> +						      -1)));

Could/Should we use a NEGATE_EXPR instead of a multiplication by -1?


Patch pre-approved with the two nits above fixed.  Thanks.

Mikael

Patch

2012-06-27  Tobias Burnus  <burnus@net-b.de>

	* trans-expr.c (conv_isocbinding_procedure): Generate c_f_pointer code
	inline.

2012-06-27  Tobias Burnus  <burnus@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..9ebde9d 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -3307,14 +3351,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, ifblock;
+      gfc_loopinfo loop;
 
       gfc_init_se (&cptrse, NULL);
       gfc_conv_expr (&cptrse, arg->expr);
@@ -3322,25 +3369,113 @@  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_one_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_init_block (&ifblock);
+      gfc_add_modify (&ifblock, offset,
+		      fold_build2_loc (input_location, PLUS_EXPR,
+				       gfc_array_index_type, offset, stride));
+      tmp = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
+			     loop.loopvar[0],loop.from[0]);
+      tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, tmp,
+			     gfc_finish_block (&ifblock),
+			     build_empty_stmt (input_location));
+      gfc_add_expr_to_block (&body, tmp);
+
+      /* 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_build2_loc (input_location, MULT_EXPR,
+				       gfc_array_index_type, offset,
+				       build_int_cst (gfc_array_index_type,
+						      -1)));
+      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