[RFC, fortran]: Updated TRANSFER patch, now with a proper target-memory implementation.

[Brooks Moses <brooks dot moses at codesourcery dot com>]

This is the revised version of the TRANSFER patch, which should handle 
everything with the proper target-side memory representation.  It 
depends on the four prerequisite patches that I just posted, but once 
those exist, the remaining changes are quite straightforward.  The size 
of an expression in target memory is calculated using the same code that 
the fold-const functions use, and so it should work without making any 
assumptions about equality kinds and byte sizes.

I have revised the interfaces to gfc_target_interpret_expr somewhat. 
Now, it expects all of the information about the type and type 
parameters for the result to be set in the result variable when it is 
passed in, rather than having things like the array length and character 
length passed in explicitly.  Thus, gfc_simplify_transfer sets up the 
value.character.length element of the result (if it's a character 
variable), and creates its shape[] array (if it's an array), prior to 
passing it to gfc_target_interpret_expr.  Similarly, interpret_derived 
is responsible for setting up the shape array for array components. 
Also, the size of the buffer is now explicitly tracked, and errors are 
thrown (by the native_encode_expr and native_interpret_expr functions) 
if anything overruns.

I've tested this in a fairly basic way on i686-pc-linux-gnu; it does 
compile, and fixes all of the PRs listed in the ChangeLog.  :)

So, the remaining work for this is creating testcases for all sorts of 
TRANSFER constant-folding, doing any last debugging that those expose, 
and putting a few more comments in the target-memory.* files.  (Also, 
there are a few debugging outputs scattered in the code for verifying 
that it works right, which will be deleted before the final submission; 
those are marked with "TODO: Remove before flight" comments.)  Any other 
comments/suggestions?

Thanks muchly to Paul Thomas for his help with this!

---------------------------------------------------------------------
2007-04-06  Brooks Moses  <brooks.moses@codesourcery.com>

	PR fortran/18769
	PR fortran/30881
	PR fortran/31194
	PR fortran/31216
	PR fortran/31427
	simplify.c (gfc_simplify_transfer): Implement constant-
	folding for TRANSFER intrinsic.
	target-memory.c: New file.
	target-memory.h: New file.
	Make-lang.in: Add dependencies on new target-memory.* files.

---------------------------------------------------------------------

- Brooks
Index: simplify.c
===================================================================
--- simplify.c	(revision 123513)
+++ simplify.c	(working copy)
@@ -26,6 +26,7 @@
 #include "gfortran.h"
 #include "arith.h"
 #include "intrinsic.h"
+#include "target-memory.h"
 
 gfc_expr gfc_bad_expr;
 
@@ -3795,12 +3796,85 @@
 gfc_expr *
 gfc_simplify_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size)
 {
-  /* Reference mold and size to suppress warning.  */
-  if (gfc_init_expr && (mold || size))
-    gfc_error ("TRANSFER intrinsic not implemented for initialization at %L",
-	       &source->where);
+  gfc_expr *result;
+  gfc_expr *mold_element;
+  size_t source_size;
+  size_t result_size;
+  size_t result_elt_size;
+  size_t buffer_size;
+  mpz_t tmp;
+  unsigned char *buffer;
 
-  return NULL;
+  if (!gfc_is_constant_expr (source)
+	|| !gfc_is_constant_expr (size))
+    return NULL;
+
+  /* Calculate the size of the source.  */
+  if (source->expr_type == EXPR_ARRAY
+      && gfc_array_size (source, &tmp) == FAILURE)
+    gfc_internal_error ("Failure getting length of a constant array.");
+
+  source_size = gfc_target_expr_size (source);
+
+  /* Create an empty new expression with the appropriate characteristics.  */
+  result = gfc_constant_result (mold->ts.type, mold->ts.kind,
+				&source->where);
+  result->ts = mold->ts;
+
+  mold_element = mold->expr_type == EXPR_ARRAY
+		 ? mold->value.constructor->expr
+		 : mold;
+
+  /* Set result character length, if needed.  Note that this needs to be
+     set even for array expressions, in order to pass this information into 
+     gfc_target_interpret_expr.  */
+  if (result->ts.type == BT_CHARACTER)
+    result->value.character.length = mold_element->value.character.length;
+  
+  /* Set the number of elements in the result, and determine its size.  */
+  result_elt_size = gfc_target_expr_size (mold_element);
+  if (mold->expr_type == EXPR_ARRAY || size != NULL)
+    {
+      int result_length;
+
+      result->expr_type = EXPR_ARRAY;
+      result->rank = 1;
+
+      if (size)
+	result_length = (size_t)mpz_get_ui (size->value.integer);
+      else
+	{
+	  result_length = source_size / result_elt_size;
+	  if (result_length * result_elt_size < source_size)
+	    result_length += 1;
+	}
+
+      result->shape = gfc_get_shape (1);
+      mpz_init_set_ui (result->shape[0], result_length);
+
+      result_size = result_length * result_elt_size;
+    }
+  else
+    {
+      result->rank = 0;
+      result_size = result_elt_size;
+    }
+
+  /* TODO: Remove before flight.  */
+  gfc_warning_now ("Source size: %d, Result size: %d", source_size, result_size);
+
+  /* Allocate the buffer to store the binary version of the source.  */
+  buffer_size = source_size > result_size ? source_size : result_size;
+  buffer = gfc_getmem (buffer_size);
+
+  /* Now write source to the buffer.  */
+  gfc_target_encode_expr (source, buffer, buffer_size);
+
+  /* And read the buffer back into the new expression.  */
+  gfc_target_interpret_expr (buffer, buffer_size, result);
+
+  gfc_free (buffer);
+  return result;
 }
 
 
Index: target-memory.c
===================================================================
--- target-memory.c	(revision 0)
+++ target-memory.c	(revision 0)
@@ -0,0 +1,455 @@
+/* Simulate storage of variables into target memory.
+   Copyright (C) 2007
+   Free Software Foundation, Inc.
+   Contributed by Paul Thomas and Brooks Moses
+
+This file is part of GCC.
+
+GCC is free software; you can redistribute it and/or modify it under
+the terms of the GNU General Public License as published by the Free
+Software Foundation; either version 2, or (at your option) any later
+version.
+
+GCC is distributed in the hope that it will be useful, but WITHOUT ANY
+WARRANTY; without even the implied warranty of MERCHANTABILITY or
+FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
+for more details.
+
+You should have received a copy of the GNU General Public License
+along with GCC; see the file COPYING.  If not, write to the Free
+Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
+02110-1301, USA.  */
+
+#include "config.h"
+#include "system.h"
+#include "flags.h"
+#include "machmode.h"
+#include "tree.h"
+#include "gfortran.h"
+#include "arith.h"
+#include "trans.h"
+#include "trans-const.h"
+#include "trans-types.h"
+#include "target-memory.h"
+
+/* ---------------------------------------------------------------  */
+/* Calculate the size of an expression.  */
+
+static size_t
+size_array (gfc_expr *e)
+{
+  mpz_t array_size;
+  size_t elt_size = gfc_target_expr_size (e->value.constructor->expr);
+
+  gfc_array_size (e, &array_size);
+  return (size_t)mpz_get_ui (array_size) * elt_size;
+}
+
+static size_t
+size_integer (int kind)
+{
+  return GET_MODE_SIZE (TYPE_MODE (gfc_get_int_type (kind)));;
+}
+
+
+static size_t
+size_float (int kind)
+{
+  return GET_MODE_SIZE (TYPE_MODE (gfc_get_real_type (kind)));;
+}
+
+
+static size_t
+size_complex (int kind)
+{
+  return kind * size_float (kind);
+}
+
+
+static size_t
+size_logical (int kind)
+{
+  return GET_MODE_SIZE (TYPE_MODE (gfc_get_logical_type (kind)));;
+}
+
+
+static size_t
+size_character (int length)
+{
+  return length;
+}
+
+
+size_t
+gfc_target_expr_size (gfc_expr *e)
+{
+  gfc_constructor *ctr;
+  size_t expr_size = 0;
+
+  gcc_assert (e != NULL);
+
+  if (e->expr_type == EXPR_ARRAY)
+    return size_array (e);
+
+  switch (e->ts.type)
+    {
+    case BT_INTEGER:
+      return size_integer (e->ts.kind);
+    case BT_REAL:
+      return size_float (e->ts.kind);
+    case BT_COMPLEX:
+      return size_complex (e->ts.kind);
+    case BT_LOGICAL:
+      return size_logical (e->ts.kind);
+    case BT_CHARACTER:
+      return size_character (e->value.character.length);
+    case BT_DERIVED:
+      ctr = e->value.constructor;
+      for (;ctr; ctr = ctr->next)
+	{
+	  gcc_assert (ctr->expr != NULL);
+	  expr_size += gfc_target_expr_size (ctr->expr);
+	}
+      return expr_size;
+    default:
+      gfc_internal_error ("Invalid expression in gfc_target_expr_size.");
+      return 0;
+    }
+}
+
+
+/* The encode_* functions export a value into a buffer, and 
+   return the number of bytes of the buffer that have been
+   used.  */
+
+static int
+encode_array (gfc_expr *expr, unsigned char *buffer, size_t buffer_size)
+{
+  mpz_t array_size;
+  int i;
+  int ptr = 0;
+
+  gfc_array_size (expr, &array_size);
+  for (i = 0; i < (int)mpz_get_ui (array_size); i++)
+    {
+      ptr += gfc_target_encode_expr (gfc_get_array_element (expr, i),
+				     &buffer[ptr], buffer_size - ptr);
+    }
+
+  mpz_clear (array_size);
+  return ptr;
+}
+
+
+static int
+encode_integer (int kind, mpz_t integer, unsigned char *buffer,
+		size_t buffer_size)
+{
+  return native_encode_expr (gfc_conv_mpz_to_tree (integer, kind),
+			     buffer, buffer_size);
+}
+
+
+static int
+encode_float (int kind, mpfr_t real, unsigned char *buffer, size_t buffer_size)
+{
+  return native_encode_expr (gfc_conv_mpfr_to_tree (real, kind), buffer,
+			     buffer_size);
+}
+
+
+static int
+encode_complex (int kind, mpfr_t real, mpfr_t imaginary, unsigned char *buffer,
+		size_t buffer_size)
+{
+  int size;
+  size = encode_float (kind, real, &buffer[0], buffer_size);
+  size += encode_float (kind, imaginary, &buffer[size], buffer_size - size);
+  return size;
+}
+
+
+static int
+encode_logical (int kind, int logical, unsigned char *buffer, size_t buffer_size)
+{
+  return native_encode_expr (build_int_cst (gfc_get_logical_type (kind),
+					    logical),
+			     buffer, buffer_size);
+}
+
+
+static int
+encode_character (int length, char *string, unsigned char *buffer,
+		  size_t buffer_size)
+{
+  gcc_assert (buffer_size >= size_character (length));
+  memcpy (buffer, string, length);
+  return length;
+}
+
+
+static int
+encode_derived (gfc_expr *source, unsigned char *buffer, size_t buffer_size)
+{
+  gfc_constructor *ctr;
+  int ptr = 0;
+
+  ctr = source->value.constructor;
+  for (;ctr; ctr = ctr->next)
+    {
+      gcc_assert (ctr->expr != NULL);
+      ptr += gfc_target_encode_expr (ctr->expr, &buffer[ptr],
+				     buffer_size - ptr);
+    }
+  return ptr;
+}
+
+
+/* Write a constant expression in binary form to a buffer.  */
+int
+gfc_target_encode_expr (gfc_expr *source, unsigned char *buffer,
+			size_t buffer_size)
+{
+  if (source == NULL)
+    return 0;
+
+  if (source->expr_type == EXPR_ARRAY)
+    return encode_array (source, buffer, buffer_size);
+
+  gcc_assert (source->expr_type == EXPR_CONSTANT
+	      || source->expr_type == EXPR_STRUCTURE);
+
+  switch (source->ts.type)
+    {
+    case BT_INTEGER:
+      return encode_integer (source->ts.kind, source->value.integer, buffer,
+			     buffer_size);
+    case BT_REAL:
+      return encode_float (source->ts.kind, source->value.real, buffer,
+			   buffer_size);
+    case BT_COMPLEX:
+      return encode_complex (source->ts.kind, source->value.complex.r,
+			     source->value.complex.i, buffer, buffer_size);
+    case BT_LOGICAL:
+      return encode_logical (source->ts.kind, source->value.logical, buffer,
+			     buffer_size);
+    case BT_CHARACTER:
+      return encode_character (source->value.character.length, 
+			       source->value.character.string, buffer,
+			       buffer_size);
+    case BT_DERIVED:
+      return encode_derived (source, buffer, buffer_size);
+    default:
+      gfc_internal_error ("Invalid expression in gfc_target_encode_expr.");
+      return 0;
+    }
+}
+
+
+static int
+interpret_array (unsigned char *buffer, size_t buffer_size, gfc_expr *result)
+{
+  int array_size = 1;
+  int i;
+  int ptr = 0;
+  gfc_constructor *head = NULL, *tail = NULL;
+
+  /* Calculate array size from its shape and rank.  */
+  if (result->rank == 0 || result->shape == NULL)
+    gfc_error ("failure to obtain array size at %L", &result->where);
+
+  for (i = 0; i < result->rank; i++)
+    array_size *= (int)mpz_get_ui (result->shape[i]);
+
+  /* Iterate over array elements, producing constructors.  */
+  for (i = 0; i < array_size; i++)
+    {
+      if (head == NULL)
+	head = tail = gfc_get_constructor ();
+      else
+	{
+	  tail->next = gfc_get_constructor ();
+	  tail = tail->next;
+	}
+
+      tail->where = result->where;
+      tail->expr = gfc_constant_result (result->ts.type,
+					  result->ts.kind, &result->where);
+      tail->expr->ts = result->ts;
+
+      if (tail->expr->ts.type == BT_CHARACTER)
+	tail->expr->value.character.length = result->value.character.length;
+
+      ptr += gfc_target_interpret_expr (&buffer[ptr], buffer_size - ptr,
+					tail->expr);
+    }
+  result->value.constructor = head;
+
+  return ptr;
+}
+
+
+static int
+interpret_integer (int kind, unsigned char *buffer, size_t buffer_size,
+		   mpz_t integer)
+{
+  mpz_init (integer);
+  gfc_conv_tree_to_mpz (integer,
+			native_interpret_expr (gfc_get_int_type (kind),
+					       buffer, buffer_size));
+
+  /* TODO: Remove before flight.  */
+  mpz_out_str (stderr, 10, integer);
+  fprintf (stderr, "\n");
+  
+  return size_integer (kind);
+}
+
+
+static int
+interpret_float (int kind, unsigned char *buffer, size_t buffer_size,
+		 mpfr_t real)
+{
+  mpfr_init (real);
+  gfc_conv_tree_to_mpfr (real,
+			 native_interpret_expr (gfc_get_real_type (kind),
+						buffer, buffer_size));
+
+  return size_float (kind);
+}
+
+
+static int
+interpret_complex (int kind, unsigned char *buffer, size_t buffer_size,
+		   mpfr_t real, mpfr_t imaginary)
+{
+  int size;
+  size = interpret_float (kind, &buffer[0], buffer_size, real);
+  size += interpret_float (kind, &buffer[size], buffer_size - size, imaginary);
+  return size;
+}
+
+
+static int
+interpret_logical (int kind, unsigned char *buffer, size_t buffer_size,
+		   int *logical)
+{
+  tree t = native_interpret_expr (gfc_get_logical_type (kind), buffer,
+				  buffer_size);
+  *logical = double_int_zero_p (tree_to_double_int (t))
+	     ? 0 : 1;
+  return size_logical (kind);
+}
+
+
+static int
+interpret_character (unsigned char *buffer, size_t buffer_size, gfc_expr *result)
+{
+  if (result->ts.cl && result->ts.cl->length)
+    result->value.character.length =
+      (int)mpz_get_ui (result->ts.cl->length->value.integer);
+
+  gcc_assert (buffer_size >= size_character (result->value.character.length));
+  result->value.character.string =
+    gfc_getmem (result->value.character.length + 1);
+  memcpy (result->value.character.string, buffer,
+	  result->value.character.length);
+  result->value.character.string [result->value.character.length] = '\0';
+
+  /* TODO: Remove before flight.  */
+  fprintf (stderr, "len:%d; '%s'\n", result->value.character.length, result->value.character.string);
+
+  return result->value.character.length;
+}
+
+
+static int
+interpret_derived (unsigned char *buffer, size_t buffer_size, gfc_expr *result)
+{
+  gfc_component *cmp;
+  gfc_constructor *head = NULL, *tail = NULL;
+  int ptr = 0;
+
+  /* The attributes of the derived type need to be bolted to the floor.  */
+  result->expr_type = EXPR_STRUCTURE;
+
+  cmp = result->ts.derived->components;
+
+  /* Run through the derived type components.  */
+  for (;cmp; cmp = cmp->next)
+    {
+      if (head == NULL)
+	head = tail = gfc_get_constructor ();
+      else
+	{
+	  tail->next = gfc_get_constructor ();
+	  tail = tail->next;
+	}
+
+      /* The constructor points to the component.  */
+      tail->n.component = cmp;
+
+      tail->expr = gfc_constant_result (cmp->ts.type, cmp->ts.kind,
+					&result->where);
+      tail->expr->ts = cmp->ts;
+
+      /* Copy shape, if needed.  */
+      if (cmp->as && cmp->as->rank)
+	{
+	  int n;
+
+	  tail->expr->expr_type = EXPR_ARRAY;
+	  tail->expr->rank = cmp->as->rank;
+
+	  tail->expr->shape = gfc_get_shape (tail->expr->rank);
+	  for (n = 0; n < tail->expr->rank; n++)
+	     {
+	       mpz_init_set_ui (tail->expr->shape[n], 1);
+	       mpz_add (tail->expr->shape[n], tail->expr->shape[n],
+			cmp->as->upper[n]->value.integer);
+	       mpz_sub (tail->expr->shape[n], tail->expr->shape[n],
+			cmp->as->lower[n]->value.integer);
+	     }
+	}
+
+      ptr += gfc_target_interpret_expr (&buffer[ptr], buffer_size - ptr,
+					  tail->expr);
+
+      result->value.constructor = head;
+    }
+  return ptr;
+}
+
+
+/* Read a binary buffer to a constant expression.  */
+int
+gfc_target_interpret_expr (unsigned char *buffer, size_t buffer_size,
+			   gfc_expr *result)
+{
+  if (result->expr_type == EXPR_ARRAY)
+    return interpret_array (buffer, buffer_size, result);
+
+  switch (result->ts.type)
+    {
+    case BT_INTEGER:
+      return interpret_integer (result->ts.kind, buffer, buffer_size,
+				result->value.integer);
+    case BT_REAL:
+      return interpret_float (result->ts.kind, buffer, buffer_size,
+			      result->value.real);
+    case BT_COMPLEX:
+      return interpret_complex (result->ts.kind, buffer, buffer_size,
+				result->value.complex.r,
+				result->value.complex.i);
+    case BT_LOGICAL:
+      return interpret_logical (result->ts.kind, buffer, buffer_size,
+				&result->value.logical);
+    case BT_CHARACTER:
+      return interpret_character (buffer, buffer_size, result);
+    case BT_DERIVED:
+      return interpret_derived (buffer, buffer_size, result);
+    default:
+      gfc_internal_error ("Invalid expression in gfc_target_interpret_expr.");
+    }
+  return 0;
+}
Index: target-memory.h
===================================================================
--- target-memory.h	(revision 0)
+++ target-memory.h	(revision 0)
@@ -0,0 +1,37 @@
+/* Simulate storage of variables into target memory, header.
+   Copyright (C) 2007
+   Free Software Foundation, Inc.
+   Contributed by Paul Thomas and Brooks Moses
+
+This file is part of GCC.
+
+GCC is free software; you can redistribute it and/or modify it under
+the terms of the GNU General Public License as published by the Free
+Software Foundation; either version 2, or (at your option) any later
+version.
+
+GCC is distributed in the hope that it will be useful, but WITHOUT ANY
+WARRANTY; without even the implied warranty of MERCHANTABILITY or
+FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
+for more details.
+
+You should have received a copy of the GNU General Public License
+along with GCC; see the file COPYING.  If not, write to the Free
+Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
+02110-1301, USA.  */
+
+#ifndef GFC_TARGET_MEMORY_H
+#define GFC_TARGET_MEMORY_H
+
+#include "gfortran.h"
+
+/* Return the size of an expression in its target representation.  */
+size_t gfc_target_expr_size (gfc_expr *);
+
+/* Write a constant expression in binary form to a target buffer.  */
+int gfc_target_encode_expr (gfc_expr *, unsigned char *, size_t);
+
+/* Read a target buffer into a constant expression.  */
+int gfc_target_interpret_expr (unsigned char *, size_t, gfc_expr *);
+
+#endif /* GFC_TARGET_MEMORY_H  */
Index: Make-lang.in
===================================================================
--- Make-lang.in	(revision 123513)
+++ Make-lang.in	(working copy)
@@ -66,7 +66,7 @@
     fortran/match.o fortran/matchexp.o fortran/misc.o fortran/module.o \
     fortran/openmp.o fortran/options.o fortran/parse.o fortran/primary.o \
     fortran/resolve.o fortran/scanner.o fortran/simplify.o fortran/st.o \
-    fortran/symbol.o
+    fortran/symbol.o fortran/target-memory.o
 
 F95_OBJS = $(F95_PARSER_OBJS) \
     fortran/convert.o fortran/dependency.o fortran/f95-lang.o \
@@ -297,7 +297,7 @@
 # TODO: Add dependencies on the backend/tree header files
 
 $(F95_PARSER_OBJS): fortran/gfortran.h fortran/intrinsic.h fortran/match.h \
-		fortran/parse.h \
+		fortran/parse.h fortran/arith.h fortran/target-memory.h \
 		$(CONFIG_H) $(SYSTEM_H) $(TM_H) $(TM_P_H) coretypes.h \
 		$(RTL_H) $(TREE_H) $(TREE_DUMP_H) $(GGC_H) $(EXPR_H) \
 		$(FLAGS_H) output.h $(DIAGNOSTIC_H) errors.h $(FUNCTION_H)