This is the mail archive of the fortran@gcc.gnu.org mailing list for the GNU Fortran project.


Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]
Other format: [Raw text]

Re: [Patch, fortran] PR51870 - [OOP] ICE with ALLOCATE and SOURCE-expr function returning BT_CLASS


Dear Tobias,

I have to stop for tonight.  The attached is where I got to:

> * It also fixed PR 48705. Your current patch fixes the reduced test case
> (comment 1) of that PR, but no longer the original version, which fails at
> the end of the program ("end program" line) at run time (SIGABRT). Valgrind
> shows:
> ?Invalid write of size 8
> ? ?at 0x4009B3: __generic_deferred_MOD___copy_generic_deferred_Vec (in
> /dev/shm/a.out)
>
> (I assume both programs have the same issue.)

I can confirm this - I believe that the type casting of the arguments
is to blame but I am not totally convinced yet.

>
> Thus, I would prefer if you could have a look at the latter PR.

Indeed, I did!
>
>
>> ?2012-01-22 ?Paul Thomas<pault@gcc.gnu.org>
>> ? ? ? ?PR fortran/51870
>
>
> Could you also add PR fortran/51943 and PR 51946? (I think those are
> effectively the same examples. Also the full example
> ssdSource/chapter08/puppeteer_f2003 works for me.)

Verified - so I have included them in the ChangeLog entries.
>
>
> + ? ? ? ? /* This is the safest way of converting to a compatible
> + ? ? ? ? ? ?type for use in the allocation. ?*/
> + ? ? ? ? tmp = TYPE_SIZE_UNIT (TREE_TYPE (gfc_index_zero_node));
> + ? ? ? ? memsz = fold_convert (TREE_TYPE (tmp), memsz);

memsz = fold_convert (gfc_charlen_type_node, memsz);  works fine.


>
> ? for (al = code->ext.alloc.list; al != NULL; al = al->next)
> ? ? {
> ...
> + ? ? ? ? class_expr = build_fold_indirect_ref_loc (input_location,
> + ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? ? se_sz.expr);
> + ? ? ? ? class_expr = gfc_evaluate_now (class_expr, &se.pre);
>
> I have the feeling that you evaluate the function multiple times. Actually,
> for*

fixed.


>
> Thus, one evaluates the function 4 times instead of only once. Additionally,
> MOLD= does not invoke the default initializer (as expected for MOLD=) but
> memcopy (as expected for SOURCE=).

fixed - although multiple entries in the allocate list, with MOLD,
brings back the fold_convert problem.  The code for applying the
default initializer with MOLD has been very much simplified, as you
can see.



> And a last issue: If one changes in
> ? type(show_producer), allocatable :: executive_producer
> the TYPE to CLASS one gets still an ICE in conv_function_val.

I have yet to turn to this.

Cheers

Paul
Index: gcc/fortran/trans-array.c
===================================================================
*** gcc/fortran/trans-array.c	(revision 183364)
--- gcc/fortran/trans-array.c	(working copy)
*************** static tree
*** 4719,4725 ****
  gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
  		     gfc_expr ** lower, gfc_expr ** upper, stmtblock_t * pblock,
  		     stmtblock_t * descriptor_block, tree * overflow,
! 		     gfc_expr *expr3)
  {
    tree type;
    tree tmp;
--- 4719,4725 ----
  gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
  		     gfc_expr ** lower, gfc_expr ** upper, stmtblock_t * pblock,
  		     stmtblock_t * descriptor_block, tree * overflow,
! 		     tree expr3_elem_size, tree *nelems, gfc_expr *expr3)
  {
    tree type;
    tree tmp;
*************** gfc_array_init_size (tree descriptor, in
*** 4876,4882 ****
    /* The stride is the number of elements in the array, so multiply by the
       size of an element to get the total size.  Obviously, if there ia a
       SOURCE expression (expr3) we must use its element size.  */
!   if (expr3 != NULL)
      {
        if (expr3->ts.type == BT_CLASS)
  	{
--- 4876,4884 ----
    /* The stride is the number of elements in the array, so multiply by the
       size of an element to get the total size.  Obviously, if there ia a
       SOURCE expression (expr3) we must use its element size.  */
!   if (expr3_elem_size != NULL_TREE)
!     tmp = expr3_elem_size;
!   else if (expr3 != NULL)
      {
        if (expr3->ts.type == BT_CLASS)
  	{
*************** gfc_array_init_size (tree descriptor, in
*** 4904,4909 ****
--- 4906,4912 ----
    if (rank == 0)
      return element_size;
  
+   *nelems = gfc_evaluate_now (stride, pblock);
    stride = fold_convert (size_type_node, stride);
  
    /* First check for overflow. Since an array of type character can
*************** gfc_array_init_size (tree descriptor, in
*** 4962,4968 ****
  
  bool
  gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
! 		    tree errlen, tree label_finish, gfc_expr *expr3)
  {
    tree tmp;
    tree pointer;
--- 4965,4972 ----
  
  bool
  gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
! 		    tree errlen, tree label_finish, tree expr3_elem_size,
! 		    tree *nelems, gfc_expr *expr3)
  {
    tree tmp;
    tree pointer;
*************** gfc_array_allocate (gfc_se * se, gfc_exp
*** 5047,5053 ****
    size = gfc_array_init_size (se->expr, ref->u.ar.as->rank,
  			      ref->u.ar.as->corank, &offset, lower, upper,
  			      &se->pre, &set_descriptor_block, &overflow,
! 			      expr3);
  
    if (dimension)
      {
--- 5051,5057 ----
    size = gfc_array_init_size (se->expr, ref->u.ar.as->rank,
  			      ref->u.ar.as->corank, &offset, lower, upper,
  			      &se->pre, &set_descriptor_block, &overflow,
! 			      expr3_elem_size, nelems, expr3);
  
    if (dimension)
      {
*************** gfc_array_allocate (gfc_se * se, gfc_exp
*** 5078,5083 ****
--- 5082,5090 ----
    gfc_start_block (&elseblock);
  
    /* Allocate memory to store the data.  */
+   if (POINTER_TYPE_P (TREE_TYPE (se->expr)))
+     se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
+ 
    pointer = gfc_conv_descriptor_data_get (se->expr);
    STRIP_NOPS (pointer);
  
*************** gfc_array_allocate (gfc_se * se, gfc_exp
*** 5104,5110 ****
  
    gfc_add_expr_to_block (&se->pre, tmp);
  
!   if (expr->ts.type == BT_CLASS && expr3)
      {
        tmp = build_int_cst (unsigned_char_type_node, 0);
        /* With class objects, it is best to play safe and null the 
--- 5111,5118 ----
  
    gfc_add_expr_to_block (&se->pre, tmp);
  
!   if (expr->ts.type == BT_CLASS
! 	&& (expr3_elem_size != NULL_TREE || expr3))
      {
        tmp = build_int_cst (unsigned_char_type_node, 0);
        /* With class objects, it is best to play safe and null the 
Index: gcc/fortran/trans-expr.c
===================================================================
*** gcc/fortran/trans-expr.c	(revision 183364)
--- gcc/fortran/trans-expr.c	(working copy)
*************** gfc_conv_derived_to_class (gfc_se *parms
*** 215,221 ****
     OOP-TODO: This could be improved by adding code that branched on
     the dynamic type being the same as the declared type. In this case
     the original class expression can be passed directly.  */ 
! static void
  gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e,
  			 gfc_typespec class_ts, bool elemental)
  {
--- 215,221 ----
     OOP-TODO: This could be improved by adding code that branched on
     the dynamic type being the same as the declared type. In this case
     the original class expression can be passed directly.  */ 
! void
  gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e,
  			 gfc_typespec class_ts, bool elemental)
  {
*************** gfc_conv_class_to_class (gfc_se *parmse,
*** 303,308 ****
--- 303,411 ----
  }
  
  
+ /* Given a class array declaration and an index, returns the address
+    of the referenced element.  */
+ 
+ tree
+ gfc_get_class_array_ref (tree index, tree class_decl)
+ {
+   tree data = gfc_class_data_get (class_decl);
+   tree size = gfc_vtable_size_get (class_decl);
+   tree offset = fold_build2_loc (input_location, MULT_EXPR,
+ 				 gfc_array_index_type,
+ 				 index, size);
+   tree ptr;
+   data = gfc_conv_descriptor_data_get (data);
+   ptr = fold_convert (pvoid_type_node, data);
+   ptr = fold_build_pointer_plus_loc (input_location, ptr, offset);
+   return fold_convert (TREE_TYPE (data), ptr);
+ }
+ 
+ 
+ /* Copies one class expression to another, assuming that if either
+    'to' or 'from' are arrays they are packed.  Should 'from' be
+    NULL_TREE, the inialization expression for 'to' is used, assuming
+    that the _vptr is set.  */
+ 
+ tree
+ gfc_copy_class_to_class (tree from, tree to, tree nelems)
+ {
+   tree fcn;
+   tree fcn_type;
+   tree from_data;
+   tree to_data;
+   tree to_ref;
+   tree from_ref;
+   VEC(tree,gc) *args;
+   tree tmp;
+   tree index;
+   stmtblock_t loopbody;
+   stmtblock_t body;
+   gfc_loopinfo loop;
+ 
+   args = NULL;
+ 
+   if (from != NULL_TREE)
+     fcn = gfc_vtable_copy_get (from);
+   else
+     fcn = gfc_vtable_copy_get (to);
+ 
+   fcn_type = TREE_TYPE (TREE_TYPE (fcn));
+ 
+   if (from != NULL_TREE)
+     from_data = gfc_class_data_get (from);
+   else
+     from_data = gfc_vtable_def_init_get (to);
+ 
+   to_data = gfc_class_data_get (to);
+ 
+   if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (to_data)))
+     {
+       gfc_init_block (&body);
+       tmp = fold_build2_loc (input_location, MINUS_EXPR,
+ 			     gfc_array_index_type, nelems,
+ 			     gfc_index_one_node);
+       nelems = gfc_evaluate_now (tmp, &body);
+       index = gfc_create_var (gfc_array_index_type, "S");
+ 
+       if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from_data)))
+ 	{
+ 	  from_ref = gfc_get_class_array_ref (index, from);
+ 	  VEC_safe_push (tree, gc, args, from_ref);
+ 	}
+       else
+         VEC_safe_push (tree, gc, args, from_data);
+ 
+       to_ref = gfc_get_class_array_ref (index, to);
+       VEC_safe_push (tree, gc, args, to_ref);
+ 
+       tmp = build_call_vec (fcn_type, fcn, args);
+ 
+       /* Build the body of the loop.  */
+       gfc_init_block (&loopbody);
+       gfc_add_expr_to_block (&loopbody, tmp);
+ 
+       /* Build the loop and return.  */
+       gfc_init_loopinfo (&loop);
+       loop.dimen = 1;
+       loop.from[0] = gfc_index_zero_node;
+       loop.loopvar[0] = index;
+       loop.to[0] = nelems;
+       gfc_trans_scalarizing_loops (&loop, &loopbody);
+       gfc_add_block_to_block (&body, &loop.pre);
+       tmp = gfc_finish_block (&body);
+     }
+   else
+     {
+       gcc_assert (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (from_data)));
+       VEC_safe_push (tree, gc, args, from_data);
+       VEC_safe_push (tree, gc, args, to_data);
+       tmp = build_call_vec (fcn_type, fcn, args);
+     }
+ 
+   return tmp;
+ }
+ 
  static tree
  gfc_trans_class_array_init_assign (gfc_expr *rhs, gfc_expr *lhs, gfc_expr *obj)
  {
Index: gcc/fortran/trans-array.h
===================================================================
*** gcc/fortran/trans-array.h	(revision 183364)
--- gcc/fortran/trans-array.h	(working copy)
*************** tree gfc_array_deallocate (tree, tree, t
*** 25,31 ****
  /* Generate code to initialize and allocate an array.  Statements are added to
     se, which should contain an expression for the array descriptor.  */
  bool gfc_array_allocate (gfc_se *, gfc_expr *, tree, tree, tree, tree,
! 			 gfc_expr *);
  
  /* Allow the bounds of a loop to be set from a callee's array spec.  */
  void gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping *,
--- 25,31 ----
  /* Generate code to initialize and allocate an array.  Statements are added to
     se, which should contain an expression for the array descriptor.  */
  bool gfc_array_allocate (gfc_se *, gfc_expr *, tree, tree, tree, tree,
! 			 tree, tree *, gfc_expr *);
  
  /* Allow the bounds of a loop to be set from a callee's array spec.  */
  void gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping *,
Index: gcc/fortran/trans-stmt.c
===================================================================
*** gcc/fortran/trans-stmt.c	(revision 183364)
--- gcc/fortran/trans-stmt.c	(working copy)
*************** gfc_trans_allocate (gfc_code * code)
*** 4740,4745 ****
--- 4740,4747 ----
    stmtblock_t post;
    gfc_expr *sz;
    gfc_se se_sz;
+   tree class_expr;
+   tree nelems;
  
    if (!code->ext.alloc.list)
      return NULL_TREE;
*************** gfc_trans_allocate (gfc_code * code)
*** 4793,4806 ****
        se.want_pointer = 1;
        se.descriptor_only = 1;
        gfc_conv_expr (&se, expr);
  
        if (!gfc_array_allocate (&se, expr, stat, errmsg, errlen, label_finish,
! 			       code->expr3))
  	{
  	  /* A scalar or derived type.  */
  
  	  /* Determine allocate size.  */
! 	  if (al->expr->ts.type == BT_CLASS && code->expr3)
  	    {
  	      if (code->expr3->ts.type == BT_CLASS)
  		{
--- 4795,4834 ----
        se.want_pointer = 1;
        se.descriptor_only = 1;
        gfc_conv_expr (&se, expr);
+       class_expr = NULL_TREE;
  
+       /* Evaluate expr3 just once if not a variable.  */
+       if (al == code->ext.alloc.list
+ 	    && al->expr->ts.type == BT_CLASS
+ 	    && code->expr3
+ 	    && code->expr3->ts.type == BT_CLASS
+ 	    && code->expr3->expr_type != EXPR_VARIABLE)
+ 	{
+ 	  gfc_init_se (&se_sz, NULL);
+ 	  gfc_conv_expr_reference (&se_sz, code->expr3);
+ 	  gfc_conv_class_to_class (&se_sz, code->expr3,
+ 				   code->expr3->ts, false);
+ 	  gfc_add_block_to_block (&se.pre, &se_sz.pre);
+ 	  gfc_add_block_to_block (&se.post, &se_sz.post);
+ 	  class_expr = build_fold_indirect_ref_loc (input_location,
+ 						    se_sz.expr);
+ 	  class_expr = gfc_evaluate_now (class_expr, &se.pre);
+ 	  memsz = gfc_vtable_size_get (class_expr);
+ 	  memsz = fold_convert (gfc_charlen_type_node, memsz);
+ 	}
+       else
+ 	memsz = NULL_TREE;
+ 
+       nelems = NULL_TREE;
        if (!gfc_array_allocate (&se, expr, stat, errmsg, errlen, label_finish,
! 			       memsz, &nelems, code->expr3))
  	{
  	  /* A scalar or derived type.  */
  
  	  /* Determine allocate size.  */
! 	  if (al->expr->ts.type == BT_CLASS
! 		&& code->expr3
! 		&& memsz == NULL_TREE)
  	    {
  	      if (code->expr3->ts.type == BT_CLASS)
  		{
*************** gfc_trans_allocate (gfc_code * code)
*** 4956,4968 ****
        e = gfc_copy_expr (al->expr);
        if (e->ts.type == BT_CLASS)
  	{
! 	  gfc_expr *lhs,*rhs;
  	  gfc_se lse;
  
  	  lhs = gfc_expr_to_initialize (e);
  	  gfc_add_vptr_component (lhs);
! 	  rhs = NULL;
! 	  if (code->expr3 && code->expr3->ts.type == BT_CLASS)
  	    {
  	      /* Polymorphic SOURCE: VPTR must be determined at run time.  */
  	      rhs = gfc_copy_expr (code->expr3);
--- 4984,5006 ----
        e = gfc_copy_expr (al->expr);
        if (e->ts.type == BT_CLASS)
  	{
! 	  gfc_expr *lhs, *rhs;
  	  gfc_se lse;
  
  	  lhs = gfc_expr_to_initialize (e);
  	  gfc_add_vptr_component (lhs);
! 
! 	  if (class_expr != NULL_TREE)
! 	    {
! 	      /* Polymorphic SOURCE: VPTR must be determined at run time.  */
! 	      gfc_init_se (&lse, NULL);
! 	      lse.want_pointer = 1;
! 	      gfc_conv_expr (&lse, lhs);
! 	      tmp = gfc_class_vptr_get (class_expr);
! 	      gfc_add_modify (&block, lse.expr,
! 			fold_convert (TREE_TYPE (lse.expr), tmp));
! 	    }
! 	  else if (code->expr3 && code->expr3->ts.type == BT_CLASS)
  	    {
  	      /* Polymorphic SOURCE: VPTR must be determined at run time.  */
  	      rhs = gfc_copy_expr (code->expr3);
*************** gfc_trans_allocate (gfc_code * code)
*** 5011,5017 ****
  	  /* Initialization via SOURCE block
  	     (or static default initializer).  */
  	  gfc_expr *rhs = gfc_copy_expr (code->expr3);
! 	  if (al->expr->ts.type == BT_CLASS)
  	    {
  	      gfc_actual_arglist *actual;
  	      gfc_expr *ppc;
--- 5049,5062 ----
  	  /* Initialization via SOURCE block
  	     (or static default initializer).  */
  	  gfc_expr *rhs = gfc_copy_expr (code->expr3);
! 	  if (class_expr != NULL_TREE)
! 	    {
! 	      tree to;
! 	      to = TREE_OPERAND (se.expr, 0);
! 
! 	      tmp = gfc_copy_class_to_class (class_expr, to, nelems);
! 	    }
! 	  else if (al->expr->ts.type == BT_CLASS)
  	    {
  	      gfc_actual_arglist *actual;
  	      gfc_expr *ppc;
*************** gfc_trans_allocate (gfc_code * code)
*** 5098,5122 ****
  	  gfc_free_expr (rhs);
  	  gfc_add_expr_to_block (&block, tmp);
  	}
!       else if (code->expr3 && code->expr3->mold
  	    && code->expr3->ts.type == BT_CLASS)
  	{
! 	  /* Default-initialization via MOLD (polymorphic).  */
! 	  gfc_expr *rhs = gfc_copy_expr (code->expr3);
! 	  gfc_se dst,src;
! 	  gfc_add_vptr_component (rhs);
! 	  gfc_add_def_init_component (rhs);
! 	  gfc_init_se (&dst, NULL);
! 	  gfc_init_se (&src, NULL);
! 	  gfc_conv_expr (&dst, expr);
! 	  gfc_conv_expr (&src, rhs);
! 	  gfc_add_block_to_block (&block, &src.pre);
! 	  tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz);
  	  gfc_add_expr_to_block (&block, tmp);
- 	  gfc_free_expr (rhs);
  	}
  
!       gfc_free_expr (expr);
      }
  
    /* STAT.  */
--- 5143,5160 ----
  	  gfc_free_expr (rhs);
  	  gfc_add_expr_to_block (&block, tmp);
  	}
!      else if (code->expr3 && code->expr3->mold
  	    && code->expr3->ts.type == BT_CLASS)
  	{
! 	  /* Since the _vptr has already been assigned to the allocate
! 	     object, we can use gfc_copy_class_to_class in its
! 	     initialization mode.  */
! 	  tmp = TREE_OPERAND (se.expr, 0);
! 	  tmp = gfc_copy_class_to_class (NULL_TREE, tmp, nelems);
  	  gfc_add_expr_to_block (&block, tmp);
  	}
  
!        gfc_free_expr (expr);
      }
  
    /* STAT.  */
Index: gcc/fortran/trans.h
===================================================================
*** gcc/fortran/trans.h	(revision 183364)
--- gcc/fortran/trans.h	(working copy)
*************** tree gfc_vtable_size_get (tree);
*** 346,351 ****
--- 346,354 ----
  tree gfc_vtable_extends_get (tree);
  tree gfc_vtable_def_init_get (tree);
  tree gfc_vtable_copy_get (tree);
+ tree gfc_get_class_array_ref (tree, tree);
+ tree gfc_copy_class_to_class (tree, tree, tree);
+ void gfc_conv_class_to_class (gfc_se *, gfc_expr *, gfc_typespec, bool);
  
  /* Initialize an init/cleanup block.  */
  void gfc_start_wrapped_block (gfc_wrapped_block* block, tree code);

Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]