RFC: gfc_simplify_transfer implementation.

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

The attached patch is a first pass at an implementation for 
gfc_simplify_transfer, based on an initial version by Paul Thomas that 
I've been working on.

The basic organization is that gfc_simplify_transfer sets up a buffer to 
simulate a bit of memory on the target, and calls functions in the new 
target-memory.c file to write data to this buffer and read back from it.

At this point, I believe that the implementation in 
gfc_simplify_transfer is in a reasonable approximation of its final 
state, and the target-memory.h interfaces are also reasonably final.

Meanwhile, the target-memory.c functions are in a sort of preliminary 
state which assumes that the host and target have the same memory 
representations, and thus don't work correctly on cross-compilers. They 
are, however, written in a way that should make it relatively easy to 
improve them and include proper target representations.  And they do 
function properly for a native compiler.

(Also, note that this version has a couple of extra things that write 
output to standard error or throw "warnings", which I've been using for 
debugging.  I've also attached a file that I've been using for testing; 
currently, it seems to all work correctly.)

I think the best plan is to do a little more polishing work on this as 
it stands, and then commit it to mainline on the grounds that it's at 
least a distinct improvement over the current form, even if it's wrong 
for cross-compilers.  I will then work on implementing the "right" sort 
of memory transfer functions that don't piggyback off the host's memory 
representation.

Thoughts/comments?

Thanks,
- Brooks


---------------------------------------------------------------
2007-03-27  Brooks Moses  <brooks.moses@codesourcery.com>
	    Paul Thomas  <pault@gcc.gnu.org>

	* simplify.c: Add #include of target-memory.h.
	(gfc_simplify_transfer): Add implementation.
	* target-memory.c: New file.
	* target-memory.h: New file.
	* Make-lang.in: Add dependencies on target-memory.*

---------------------------------------------------------------
Index: simplify.c
===================================================================
--- simplify.c	(revision 123170)
+++ 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;
 
@@ -3742,12 +3743,75 @@
 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;
+  size_t source_size;
+  size_t result_size;
+  size_t result_elt_size;
+  size_t buffer_size;
+  mpz_t tmp;
+  char *buffer;
+  int result_length;
 
-  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);
+
+  /* Set up an empty new expression for the result.  */
+  result = gfc_constant_result (mold->ts.type, mold->ts.kind,
+				&source->where);
+  result->ts = mold->ts;
+  if (result->ts.type == BT_CHARACTER)
+    result->value.character.length = (mold->expr_type == EXPR_ARRAY)
+				     ? mold->value.constructor->expr->value.character.length
+				     : mold->value.character.length;
+
+  /* Determine the number of elements in the result, and its size.  */
+  result_elt_size = mold->expr_type == EXPR_ARRAY
+		    ? gfc_target_expr_size (mold->value.constructor->expr)
+		    : gfc_target_expr_size (mold);
+
+  if (mold->expr_type == EXPR_ARRAY || size != NULL)
+    {
+      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_size = result_length * result_elt_size;
+
+      result->shape = gfc_get_shape(1);
+      mpz_init_set_ui (result->shape[0], result_length);
+    }
+  else
+    {
+      result->rank = 0;
+      result_size = result_elt_size;
+    }
+
+  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);
+  memset (buffer, '\0', buffer_size);
+
+  /* Write the source to the buffer, and read it back into the result.  */
+  gfc_target_export_expr (source, buffer);
+  gfc_target_import_expr (buffer, result);
+
+  gfc_free (buffer);
+  return result;
 }
 
 
Index: Make-lang.in
===================================================================
--- Make-lang.in	(revision 123251)
+++ 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) 
Index: target-memory.c
===================================================================
--- target-memory.c	(revision 0)
+++ target-memory.c	(revision 0)
@@ -0,0 +1,459 @@
+/* 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 "gfortran.h"
+#include "arith.h"
+#include "target-memory.h"
+
+/* The size_* functions return the size of a constant expression.  */
+
+static size_t
+size_array (gfc_expr *e)
+{
+  size_t size;
+  mpz_t array_size;
+  size_t elt_size = gfc_target_expr_size (e->value.constructor->expr);
+
+  gfc_array_size (e, &array_size);
+  size = (size_t)mpz_get_ui (array_size) * elt_size;
+  mpz_clear (array_size);
+  return size;
+}
+
+static size_t
+size_integer (int kind)
+{
+  return kind;
+}
+
+
+static size_t
+size_float (int kind)
+{
+  return kind;
+}
+
+
+static size_t
+size_complex (int kind)
+{
+  return kind * 2;
+}
+
+
+static size_t
+size_logical (void)
+{
+  int logical;
+  return sizeof (logical);
+}
+
+
+static size_t
+size_character (int length)
+{
+  return length;
+}
+
+
+static size_t
+size_derived (gfc_expr *e)
+{
+  gfc_constructor *ctr;
+  size_t expr_size = 0;
+
+  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;
+}
+
+
+size_t
+gfc_target_expr_size (gfc_expr *e)
+{
+  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 ();
+    case BT_CHARACTER:
+      return size_character (e->value.character.length);
+    case BT_DERIVED:
+      return size_derived (e);
+    default:
+      gfc_error ("BAD STUFF in expr_size");
+      return 0;
+    }
+}
+
+
+/* The export_* functions export a value into a buffer, and 
+   return the number of bytes of the buffer that have been
+   used.  */
+
+static int
+export_array (gfc_expr *expr, char *buffer)
+{
+  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_export_expr (gfc_get_array_element (expr, i),
+				     &buffer[ptr]);
+    }
+  return ptr;
+}
+
+
+static int
+export_integer (int kind, mpz_t integer, void *buffer)
+{
+  size_t count;
+  if (kind == sizeof (char))
+    {
+      char *buf = buffer;
+      mpz_export (buffer, &count, 1, kind, 0, 0, integer);
+      if (mpz_sgn (integer) < 0)
+	*buf = -*buf;
+    }
+  else if (kind == sizeof (short))
+    {
+      short *buf = (short *)buffer;
+      mpz_export (buffer, &count, 1, kind, 0, 0, integer);
+      if (mpz_sgn (integer) < 0)
+	*buf = -*buf;
+    }
+  else if (kind == sizeof (int))
+    {
+      int *buf = (int *)buffer;
+      mpz_export (buffer, &count, 1, kind, 0, 0, integer);
+      if (mpz_sgn (integer) < 0)
+	*buf = -*buf;
+    }
+  else if (kind == sizeof (long))
+    {
+      long *buf = (long *)buffer;
+      mpz_export (buffer, &count, 1, kind, 0, 0, integer);
+      if (mpz_sgn (integer) < 0)
+	*buf = -*buf;
+    }
+  else if (kind == sizeof (long long))
+    {
+      long long *buf = (long long *)buffer;
+      mpz_export (buffer, &count, 1, kind, 0, 0, integer);
+      if (mpz_sgn (integer) < 0)
+	*buf = -*buf;
+    }
+  return kind;
+}
+
+
+static int
+export_float (int kind, mpfr_t real, char *buffer)
+{
+  if (kind == sizeof (long double))
+    {
+      long double val = mpfr_get_ld (real, GFC_RND_MODE);
+      memcpy (&buffer[0], &val, sizeof (long double));
+    }
+  else
+    {
+      double val = mpfr_get_d (real, GFC_RND_MODE);
+      if (kind == sizeof (float))
+	{
+	  float fval = (float)val;
+	  memcpy (&buffer[0], &fval, sizeof (float));
+	}
+      else
+	memcpy (&buffer[0], &val, sizeof (double));
+    }
+  return kind;
+}
+
+
+static int
+export_complex (int kind, mpfr_t real, mpfr_t imaginary, char *buffer)
+{
+  int size;
+  size = export_float (kind, real, &buffer[0]);
+  size += export_float (kind, imaginary, &buffer[size]);
+  return size;
+}
+
+
+static int
+export_logical (int logical, char *buffer)
+{
+  memcpy (buffer, &logical, sizeof (logical));
+  return sizeof (logical);
+}
+
+
+static int
+export_character (int length, char *string, char *buffer)
+{
+  memcpy (buffer, string, length);
+  return length;
+}
+
+
+static int
+export_derived (gfc_expr *source, char *buffer)
+{
+  gfc_constructor *ctr;
+  int ptr = 0;
+
+  ctr = source->value.constructor;
+  for (;ctr; ctr = ctr->next)
+    {
+      gcc_assert (ctr->expr != NULL);
+      ptr += gfc_target_export_expr (ctr->expr, &buffer[ptr]);
+    }
+  return ptr;
+}
+
+
+int
+gfc_target_export_expr (gfc_expr *source, char *buffer)
+{
+  if (source->expr_type == EXPR_ARRAY)
+    return export_array (source, buffer);
+
+  gcc_assert (source->expr_type == EXPR_CONSTANT || source->expr_type == EXPR_STRUCTURE);
+
+  switch (source->ts.type)
+    {
+    case BT_INTEGER:
+      return export_integer (source->ts.kind, source->value.integer, buffer);
+    case BT_REAL:
+      return export_float (source->ts.kind, source->value.real, buffer);
+    case BT_COMPLEX:
+      return export_complex (source->ts.kind, source->value.complex.r,
+			     source->value.complex.i, buffer);
+    case BT_LOGICAL:
+      return export_logical (source->value.logical, buffer);
+    case BT_CHARACTER:
+      return export_character (source->value.character.length, 
+			       source->value.character.string, buffer);
+    case BT_DERIVED:
+      return export_derived (source, buffer);
+    default:
+      gfc_internal_error ("BAD STUFF in export");
+      return 0;
+    }
+}
+
+
+/* The import_* functions import a value from a buffer, and 
+   return the number of bytes of the buffer that have been
+   read.  */
+
+static int
+import_array (char *buffer, gfc_expr *result)
+{
+  int i;
+  int ptr = 0;
+  gfc_constructor *head = NULL, *tail = NULL;
+
+  result->expr_type = EXPR_ARRAY;
+
+  /* TODO: Do we need a shape here?  */
+
+  for (i = 0; i < (int)mpz_get_ui (result->shape[0]); 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_import_expr (&buffer[ptr], tail->expr);
+    }
+  result->value.constructor = head;
+  return ptr;
+}
+
+
+static int
+import_integer (int kind, char *buffer, mpz_t integer)
+{
+  mpz_import (integer, 1, 1, kind,
+	      0, 0, (void*)buffer);
+
+  mpz_out_str (stderr, 10, integer);
+  fprintf (stderr, "\n");
+  
+  return kind;
+}
+
+
+static int
+import_float (int kind, char *buffer, mpfr_t real)
+{
+  mpfr_init (real);
+  if (kind == sizeof (long double))
+    mpfr_set_ld (real, *(long double*)buffer, GFC_RND_MODE);
+  else
+    {
+      if (kind == sizeof (float))
+	mpfr_set_d (real, (double)(*(float*)buffer), GFC_RND_MODE);
+      else
+	mpfr_set_d (real, *(double*)buffer, GFC_RND_MODE);
+    }
+  return kind;
+}
+
+
+static int
+import_complex (int kind, char *buffer, mpfr_t real, mpfr_t imaginary)
+{
+  int size;
+  size = import_float (kind, &buffer[0], real);
+  size += import_float (kind, &buffer[size], imaginary);
+  return size;
+}
+
+
+static int
+import_logical (char *buffer, int logical)
+{
+  memcpy (&logical, buffer, sizeof (logical));
+  return sizeof (logical);
+}
+
+
+static int
+import_character (char *buffer, 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);
+
+  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';
+
+  fprintf (stderr, "len:%d; '%s'\n", result->value.character.length, result->value.character.string);
+
+  return result->value.character.length;
+}
+
+
+static int
+import_derived (char *buffer, 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;
+
+      if (cmp->as && cmp->as->rank)
+        {
+	  tail->expr->rank = cmp->as->rank;
+	  tail->expr->shape = gfc_get_shape(1);
+          spec_size (cmp->as, &tail->expr->shape[0]);
+	  ptr += import_array (buffer, tail->expr);
+	}
+      else
+	ptr += gfc_target_import_expr (&buffer[ptr], tail->expr);
+
+      result->value.constructor = head;
+    }
+  return ptr;
+}
+
+
+int
+gfc_target_import_expr (char *buffer, gfc_expr *result)
+{
+  if (result->rank > 0)
+    return import_array (buffer, result);
+
+  switch (result->ts.type)
+    {
+    case BT_INTEGER:
+      return import_integer (result->ts.kind, buffer, result->value.integer);
+    case BT_REAL:
+      return import_float (result->ts.kind, buffer, result->value.real);
+    case BT_COMPLEX:
+      return import_complex (result->ts.kind, buffer, result->value.complex.r,
+			     result->value.complex.i);
+    case BT_LOGICAL:
+      return import_logical (buffer, result->value.logical);
+    case BT_CHARACTER:
+      return import_character (buffer, result);
+    case BT_DERIVED:
+      return import_derived (buffer, result);
+    default:
+      gfc_internal_error ("BAD STUFF in import");
+      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_export_expr (gfc_expr *, char *);
+
+/* Read a target buffer into a constant expression.  */
+int gfc_target_import_expr (char *, gfc_expr *);
+
+#endif /* GFC_TARGET_MEMORY_H  */

type dt1
  integer x
  integer y
  integer z
end type

type dt2
  integer x(3)
end type

integer, parameter :: i1(3) = transfer( dt1(1, 2, 3), (/ 3 /))
type(dt1), parameter :: d1 = transfer( (/ 3, 3 /), dt1(1, 2, 3))

integer, parameter :: i2(3) = transfer( dt2( (/1, 2, 3/) ), (/ 3 /))
type(dt2), parameter :: d2 = transfer( (/ 3, 3 /), dt2( (/1, 2, 3/) ))

character(4), parameter :: zero = char(0) // char(0) // char(0) // char(0)
character(4), parameter :: sixtyfive = "A" // char(0) // char(0) // char(0)
character(4), parameter :: twofiveseven = char(1) // char(1) // char(0) // char(0)

type dt3
  character(4) x
  character(4) y
  character(4) z
end type

type dt4
  character(4) x(3)
end type

type(dt3), parameter :: dt3_0 = dt3( zero, sixtyfive, twofiveseven )
type(dt4), parameter :: dt4_0 = dt4( (/ zero, sixtyfive, twofiveseven /) )


integer, parameter :: i3(3) = transfer( dt3_0, (/ 3 /))
type(dt3), parameter :: d3 = transfer( (/ 65, 66 /), dt3_0 )

integer, parameter :: i4(3) = transfer( dt4_0, (/ 3 /))
type(dt4), parameter :: d4 = transfer( (/ 65, 66 /), dt4_0 )

write (*,*) i1
write (*,*) d1
write (*,*) i2
write (*,*) d2
write (*,*) i3
write (*,*) d3
write (*,*) i4
write (*,*) d4

end