diff mbox

[Fortran] Handle C_F_POINTER with a noncontiguous SHAPE=

Message ID 4FFF42A7.7000805@net-b.de
State New
Headers show

Commit Message

Tobias Burnus July 12, 2012, 9:33 p.m. UTC 
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.
diff mbox

Patch

2012-07-12  Tobias Burnus  <burnus@net-b.de>

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

2012-07-12  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..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