[gfortran] Builtin functions allocate their results (compiler part)

[Victor Leikehman <lei at haifasphere dot co dot il>]

I am working on the change that allows builtin functions
to create the return value in case that the caller does not know
the shape of the result, as proposed by Paul Brook a while ago.

This is the patch to the compiler that accompanies the change
to the library (http://gcc.gnu.org/ml/gcc-patches/2004-08/msg00227.html).

As posted, these two patches pass the existing regression test suite,
and also facerec spec benchmark, which does not work otherwise.
The third part of this change will include the new testcases.

2004-08-04  Victor Leikehman  <lei@il.ibm.com>

	* trans-array.c (gfc_trans_allocate_array_storage,
	gfc_trans_allocate_temp_array, gfc_add_loop_ss_code,
	gfc_conv_loop_setup, gfc_conv_expr_descriptor):
	For functions, if the shape of the result is not known
	in compile-time, generate an empty array descriptor for
	the result and let the callee to allocate the memory.

-- 
  Victor Leikehman
  IBM Research Labs in Haifa, Israel

Index: trans-array.c
===================================================================
RCS file: /cvsroot/gcc/gcc/gcc/fortran/trans-array.c,v
retrieving revision 1.11
diff -c -p -r1.11 trans-array.c
*** trans-array.c	15 Jul 2004 14:53:28 -0000	1.11
--- trans-array.c	4 Aug 2004 12:16:13 -0000
*************** gfc_trans_allocate_array_storage (gfc_lo
*** 450,456 ****
  
    desc = info->descriptor;
    data = gfc_conv_descriptor_data (desc);
!   onstack = gfc_can_put_var_on_stack (size);
    if (onstack)
      {
        /* Make a temporary variable to hold the data.  */
--- 450,456 ----
  
    desc = info->descriptor;
    data = gfc_conv_descriptor_data (desc);
!   onstack = (size == NULL_TREE) ? 0 : gfc_can_put_var_on_stack (size);
    if (onstack)
      {
        /* Make a temporary variable to hold the data.  */
*************** gfc_trans_allocate_array_storage (gfc_lo
*** 465,470 ****
--- 465,477 ----
        info->offset = gfc_index_zero_node;
  
      }
+   else if (size == 0)
+     {
+       gfc_add_modify_expr (&loop->pre, data, convert (TREE_TYPE (data), 
+                                                       gfc_index_zero_node));
+       info->data = data;
+       info->offset = gfc_index_zero_node;
+     }
    else
      {
        /* Allocate memory to hold the data.  */
*************** gfc_trans_allocate_temp_array (gfc_loopi
*** 526,532 ****
  	assert (integer_zerop (loop->from[n]));
        else
  	{
! 	  loop->to[n] = fold (build (MINUS_EXPR, gfc_array_index_type,
  				     loop->to[n], loop->from[n]));
  	  loop->from[n] = gfc_index_zero_node;
  	}
--- 533,540 ----
  	assert (integer_zerop (loop->from[n]));
        else
  	{
!           if (loop->to[n])
!               loop->to[n] = fold (build (MINUS_EXPR, gfc_array_index_type,
  				     loop->to[n], loop->from[n]));
  	  loop->from[n] = gfc_index_zero_node;
  	}
*************** gfc_trans_allocate_temp_array (gfc_loopi
*** 566,571 ****
--- 574,589 ----
  
    for (n = 0; n < info->dimen; n++)
      {
+       if (loop->to[n] == NULL_TREE)
+         {
+           tmp = build (MINUS_EXPR, gfc_array_index_type,
+                        gfc_conv_descriptor_ubound (desc, gfc_rank_cst[n]),
+                        gfc_conv_descriptor_lbound (desc, gfc_rank_cst[n]));
+           loop->to[n] = tmp;
+           size = 0;
+           continue;
+         }
+         
        /* Store the stride and bound components in the descriptor.  */
        tmp = gfc_conv_descriptor_stride (desc, gfc_rank_cst[n]);
        gfc_add_modify_expr (&loop->pre, tmp, size);
*************** gfc_trans_allocate_temp_array (gfc_loopi
*** 589,595 ****
  
    /* Get the size of the array.  */
    nelem = size;
!   size = fold (build (MULT_EXPR, gfc_array_index_type, size,
  		      TYPE_SIZE_UNIT (gfc_get_element_type (type))));
  
    gfc_trans_allocate_array_storage (loop, info, size, nelem);
--- 607,614 ----
  
    /* Get the size of the array.  */
    nelem = size;
!   if (size)
!     size = fold (build (MULT_EXPR, gfc_array_index_type, size,
  		      TYPE_SIZE_UNIT (gfc_get_element_type (type))));
  
    gfc_trans_allocate_array_storage (loop, info, size, nelem);
*************** gfc_add_loop_ss_code (gfc_loopinfo * loo
*** 1065,1070 ****
--- 1084,1093 ----
  	  gfc_trans_array_constructor (loop, ss);
  	  break;
  
+         case GFC_SS_TEMP:
+           /* Do nothing, but prevent defaulting to abort() */
+           break;
+ 
  	default:
  	  abort ();
  	}
*************** gfc_conv_loop_setup (gfc_loopinfo * loop
*** 2256,2261 ****
--- 2279,2290 ----
  	      continue;
  	    }
  
+           if (ss->type == GFC_SS_FUNCTION)
+             {
+               loopspec[n] = ss;
+               continue;
+             }
+ 
  	  /* We don't know how to handle functions yet.
  	     This may not be possible in all cases.  */
  	  if (ss->type != GFC_SS_SECTION)
*************** gfc_conv_loop_setup (gfc_loopinfo * loop
*** 2333,2338 ****
--- 2362,2371 ----
  							  &loop->pre);
  	      break;
  
+             case GFC_SS_FUNCTION:
+               assert (loop->to[n] == NULL_TREE); /* to be allocated by the callee */
+               break;
+ 
  	    default:
  	      abort ();
  	    }
*************** gfc_conv_loop_setup (gfc_loopinfo * loop
*** 2359,2364 ****
--- 2392,2400 ----
  	}
      }
  
+   /* Add all the scalar code that can be taken out of the loops.  */
+   gfc_add_loop_ss_code (loop, loop->ss, false);
+ 
    /* If we want a temporary then create it.  */
    if (loop->temp_ss != NULL)
      {
*************** gfc_conv_loop_setup (gfc_loopinfo * loop
*** 2373,2381 ****
  				     tmp, len);
      }
  
-   /* Add all the scalar code that can be taken out of the loops.  */
-   gfc_add_loop_ss_code (loop, loop->ss, false);
- 
    for (n = 0; n < loop->temp_dim; n++)
      loopspec[loop->order[n]] = NULL;
  
--- 2409,2414 ----
*************** gfc_conv_expr_descriptor (gfc_se * se, g
*** 3364,3369 ****
--- 3397,3421 ----
  	  return;
  	}
      }
+   /* Pass return values from function calls without a temporary */
+   else if (expr->expr_type == EXPR_FUNCTION)
+     {
+       secss = ss;
+       while (secss != gfc_ss_terminator && secss->type != GFC_SS_FUNCTION)
+       	secss = secss->next;
+       
+       if (secss == gfc_ss_terminator)
+         {
+           need_tmp = 1;
+           secss = NULL;
+           info = NULL;
+         }
+       else
+         {
+           need_tmp = 0;
+           info = &secss->data.info;
+         }
+     }
    else
      {
        need_tmp = 1;
*************** gfc_conv_expr_descriptor (gfc_se * se, g
*** 3503,3508 ****
--- 3555,3576 ----
        else
  	base = NULL_TREE;
  
+       if (info->ref == 0)
+         {
+           for (n = 0; n < info->dimen; n++)
+             {
+               gfc_add_modify_expr (&loop.pre, 
+                                    gfc_conv_descriptor_lbound (parm, gfc_rank_cst[n]),
+                                    gfc_conv_descriptor_lbound (desc, gfc_rank_cst[n]));
+               gfc_add_modify_expr (&loop.pre, 
+                                    gfc_conv_descriptor_ubound (parm, gfc_rank_cst[n]),
+                                    gfc_conv_descriptor_ubound (desc, gfc_rank_cst[n]));
+               gfc_add_modify_expr (&loop.pre, 
+                                    gfc_conv_descriptor_stride (parm, gfc_rank_cst[n]),
+                                    gfc_conv_descriptor_stride (desc, gfc_rank_cst[n]));
+             }
+         }
+       else
        for (n = 0; n < info->ref->u.ar.dimen; n++)
  	{
  	  stride = gfc_conv_array_stride (desc, n);