re PR fortran/13465 (Data statement for large arrays compiles verrrry slllowwwly…

re PR fortran/13465 (Data statement for large arrays compiles verrrry slllowwwly and shows quadratic behaviour.)

        PR 13465
        * data.c (find_con_by_offset): Search ordered list; handle
        elements with repeat counts.
        (gfc_assign_data_value_range): New.
        * gfortran.h (struct gfc_data_value): Make repeat unsigned.
        (gfc_assign_data_value_range): Declare.
        * match.c (top_val_list): Extract repeat count into a temporary.
        * resolve.c (values): Make left unsigned.
        (next_data_value): Don't decrement left.
        (check_data_variable): Use gfc_assign_data_value_range.

From-SVN: r86443

gcc/fortran/ChangeLog

+2004-08-22  Richard Henderson  <rth@redhat.com>
+
+	PR 13465
+        * data.c (find_con_by_offset): Search ordered list; handle
+        elements with repeat counts.
+        (gfc_assign_data_value_range): New.
+        * gfortran.h (struct gfc_data_value): Make repeat unsigned.
+        (gfc_assign_data_value_range): Declare.
+        * match.c (top_val_list): Extract repeat count into a temporary.
+        * resolve.c (values): Make left unsigned.
+        (next_data_value): Don't decrement left.
+        (check_data_variable): Use gfc_assign_data_value_range.
+
 2004-08-22  Tobias Schlueter  <tobias.schlueter@physik.uni-muenchen.de>
 
 	* trans-const.c, trans-decl.c, trans-expr.c: Spelling fixes.

gcc/fortran/data.c

@@ -82,12 +82,40 @@ get_array_index (gfc_array_ref * ar, mpz_t * offset)
 static gfc_constructor *
 find_con_by_offset (mpz_t offset, gfc_constructor *con)
 {
+  mpz_t tmp;
+  gfc_constructor *ret = NULL;
+
+  mpz_init (tmp);
+
   for (; con; con = con->next)
     {
-      if (mpz_cmp (offset, con->n.offset) == 0)
-        return con;
+      int cmp = mpz_cmp (offset, con->n.offset);
+
+      /* We retain a sorted list, so if we're too large, we're done.  */
+      if (cmp < 0)
+	break;
+
+      /* Yaye for exact matches.  */
+      if (cmp == 0)
+	{
+          ret = con;
+	  break;
+	}
+
+      /* If the constructor element is a range, match any element.  */
+      if (mpz_cmp_ui (con->repeat, 1) > 0)
+	{
+	  mpz_add (tmp, con->n.offset, con->repeat);
+	  if (mpz_cmp (offset, tmp) < 0)
+	    {
+	      ret = con;
+	      break;
+	    }
+	}
     }
-  return NULL;
+
+  mpz_clear (tmp);
+  return ret;
 }
 
 
@@ -236,7 +264,7 @@ gfc_assign_data_value (gfc_expr * lvalue, gfc_expr * rvalue, mpz_t index)
 	  if (con == NULL)
 	    {
 	      /* Create a new constructor.  */
-	      con = gfc_get_constructor();
+	      con = gfc_get_constructor ();
 	      mpz_set (con->n.offset, offset);
 	      gfc_insert_constructor (expr, con);
 	    }
@@ -272,7 +300,6 @@ gfc_assign_data_value (gfc_expr * lvalue, gfc_expr * rvalue, mpz_t index)
 	  abort ();
 	}
 
-      
       if (init == NULL)
 	{
 	  /* Point the container at the new expression.  */
@@ -295,7 +322,6 @@ gfc_assign_data_value (gfc_expr * lvalue, gfc_expr * rvalue, mpz_t index)
       expr = gfc_copy_expr (rvalue);
       if (!gfc_compare_types (&lvalue->ts, &expr->ts))
 	gfc_convert_type (expr, &lvalue->ts, 0);
-
     }
 
   if (last_con == NULL)
@@ -304,6 +330,148 @@ gfc_assign_data_value (gfc_expr * lvalue, gfc_expr * rvalue, mpz_t index)
     last_con->expr = expr;
 }
 
+/* Similarly, but initialize REPEAT consectutive values in LVALUE the same
+   value in RVALUE.  For the nonce, LVALUE must refer to a full array, not
+   an array section.  */
+
+void
+gfc_assign_data_value_range (gfc_expr * lvalue, gfc_expr * rvalue,
+			     mpz_t index, mpz_t repeat)
+{
+  gfc_ref *ref;
+  gfc_expr *init, *expr;
+  gfc_constructor *con, *last_con;
+  gfc_symbol *symbol;
+  gfc_typespec *last_ts;
+  mpz_t offset;
+
+  symbol = lvalue->symtree->n.sym;
+  init = symbol->value;
+  last_ts = &symbol->ts;
+  last_con = NULL;
+  mpz_init_set_si (offset, 0);
+
+  /* Find/create the parent expressions for subobject references.  */
+  for (ref = lvalue->ref; ref; ref = ref->next)
+    {
+      /* Use the existing initializer expression if it exists.
+	 Otherwise create a new one.  */
+      if (init == NULL)
+	expr = gfc_get_expr ();
+      else
+	expr = init;
+
+      /* Find or create this element.  */
+      switch (ref->type)
+	{
+	case REF_ARRAY:
+	  if (init == NULL)
+	    {
+	      /* The element typespec will be the same as the array
+		 typespec.  */
+	      expr->ts = *last_ts;
+	      /* Setup the expression to hold the constructor.  */
+	      expr->expr_type = EXPR_ARRAY;
+	      expr->rank = ref->u.ar.as->rank;
+	    }
+	  else
+	    assert (expr->expr_type == EXPR_ARRAY);
+
+	  if (ref->u.ar.type == AR_ELEMENT)
+	    {
+	      get_array_index (&ref->u.ar, &offset);
+
+	      /* This had better not be the bottom of the reference.
+		 We can still get to a full array via a component.  */
+	      assert (ref->next != NULL);
+	    }
+	  else
+	    {
+	      mpz_set (offset, index);
+
+	      /* We're at a full array or an array section.  This means
+		 that we've better have found a full array, and that we're
+		 at the bottom of the reference.  */
+	      assert (ref->u.ar.type == AR_FULL);
+	      assert (ref->next == NULL);
+	    }
+
+	  /* Find the same element in the existing constructor.  */
+	  con = expr->value.constructor;
+	  con = find_con_by_offset (offset, con);
+
+	  /* Create a new constructor.  */
+	  if (con == NULL)
+	    {
+	      con = gfc_get_constructor ();
+	      mpz_set (con->n.offset, offset);
+	      if (ref->next == NULL)
+		mpz_set (con->repeat, repeat);
+	      gfc_insert_constructor (expr, con);
+	    }
+	  else
+	    assert (ref->next != NULL);
+	  break;
+
+	case REF_COMPONENT:
+	  if (init == NULL)
+	    {
+	      /* Setup the expression to hold the constructor.  */
+	      expr->expr_type = EXPR_STRUCTURE;
+	      expr->ts.type = BT_DERIVED;
+	      expr->ts.derived = ref->u.c.sym;
+	    }
+	  else
+	    assert (expr->expr_type == EXPR_STRUCTURE);
+	  last_ts = &ref->u.c.component->ts;
+
+	  /* Find the same element in the existing constructor.  */
+	  con = expr->value.constructor;
+	  con = find_con_by_component (ref->u.c.component, con);
+
+	  if (con == NULL)
+	    {
+	      /* Create a new constructor.  */
+	      con = gfc_get_constructor ();
+	      con->n.component = ref->u.c.component;
+	      con->next = expr->value.constructor;
+	      expr->value.constructor = con;
+	    }
+
+	  /* Since we're only intending to initialize arrays here,
+	     there better be an inner reference.  */
+	  assert (ref->next != NULL);
+	  break;
+
+	case REF_SUBSTRING:
+	default:
+	  abort ();
+	}
+
+      if (init == NULL)
+	{
+	  /* Point the container at the new expression.  */
+	  if (last_con == NULL)
+	    symbol->value = expr;
+	  else
+	    last_con->expr = expr;
+	}
+      init = con->expr;
+      last_con = con;
+    }
+
+  /* We should never be overwriting an existing initializer.  */
+  assert (!init);
+
+  expr = gfc_copy_expr (rvalue);
+  if (!gfc_compare_types (&lvalue->ts, &expr->ts))
+    gfc_convert_type (expr, &lvalue->ts, 0);
+
+  if (last_con == NULL)
+    symbol->value = expr;
+  else
+    last_con->expr = expr;
+}
 
 /* Modify the index of array section and re-calculate the array offset.  */
 

gcc/fortran/gfortran.h

@@ -1304,9 +1304,8 @@ gfc_data_variable;
 
 typedef struct gfc_data_value
 {
-  int repeat;
+  unsigned int repeat;
   gfc_expr *expr;
-
   struct gfc_data_value *next;
 }
 gfc_data_value;
@@ -1402,6 +1401,7 @@ extern iterator_stack *iter_stack;
 void gfc_formalize_init_value (gfc_symbol *);
 void gfc_get_section_index (gfc_array_ref *, mpz_t *, mpz_t *);
 void gfc_assign_data_value (gfc_expr *, gfc_expr *, mpz_t);
+void gfc_assign_data_value_range (gfc_expr *, gfc_expr *, mpz_t, mpz_t);
 void gfc_advance_section (mpz_t *, gfc_array_ref *, mpz_t *);
 
 /* scanner.c */

gcc/fortran/match.c

@@ -2894,13 +2894,15 @@ top_val_list (gfc_data * data)
 	}
       else
 	{
-	  msg = gfc_extract_int (expr, &tail->repeat);
+	  signed int tmp;
+	  msg = gfc_extract_int (expr, &tmp);
 	  gfc_free_expr (expr);
 	  if (msg != NULL)
 	    {
 	      gfc_error (msg);
 	      return MATCH_ERROR;
 	    }
+	  tail->repeat = tmp;
 
 	  m = match_data_constant (&tail->expr);
 	  if (m == MATCH_NO)

gcc/fortran/resolve.c

@@ -4037,7 +4037,7 @@ resolve_symbol (gfc_symbol * sym)
 static struct
 {
   gfc_data_value *vnode;
-  int left;
+  unsigned int left;
 }
 values;
 
@@ -4047,7 +4047,6 @@ values;
 static try
 next_data_value (void)
 {
-
   while (values.left == 0)
     {
       if (values.vnode->next == NULL)
@@ -4057,7 +4056,6 @@ next_data_value (void)
       values.left = values.vnode->repeat;
     }
 
-  values.left--;
   return SUCCESS;
 }
 
@@ -4086,7 +4084,10 @@ check_data_variable (gfc_data_variable * var, locus * where)
     gfc_internal_error ("check_data_variable(): Bad expression");
 
   if (e->rank == 0)
-    mpz_init_set_ui (size, 1);
+    {
+      mpz_init_set_ui (size, 1);
+      ref = NULL;
+    }
   else
     {
       ref = e->ref;
@@ -4145,19 +4146,54 @@ check_data_variable (gfc_data_variable * var, locus * where)
       if (t == FAILURE)
 	break;
 
+      /* If we have more than one element left in the repeat count,
+	 and we have more than one element left in the target variable,
+	 then create a range assignment.  */
+      /* ??? Only done for full arrays for now, since array sections
+	 seem tricky.  */
+      if (mark == AR_FULL && ref && ref->next == NULL
+	  && values.left > 1 && mpz_cmp_ui (size, 1) > 0)
+	{
+	  mpz_t range;
+
+	  if (mpz_cmp_ui (size, values.left) >= 0)
+	    {
+	      mpz_init_set_ui (range, values.left);
+	      mpz_sub_ui (size, size, values.left);
+	      values.left = 0;
+	    }
+	  else
+	    {
+	      mpz_init_set (range, size);
+	      values.left -= mpz_get_ui (size);
+	      mpz_set_ui (size, 0);
+	    }
+
+	  gfc_assign_data_value_range (var->expr, values.vnode->expr,
+				       offset, range);
+
+	  mpz_add (offset, offset, range);
+	  mpz_clear (range);
+	}
+
       /* Assign initial value to symbol.  */
-      gfc_assign_data_value (var->expr, values.vnode->expr, offset);
+      else
+	{
+	  values.left -= 1;
+	  mpz_sub_ui (size, size, 1);
 
-      if (mark == AR_FULL)
-        mpz_add_ui (offset, offset, 1);
+	  gfc_assign_data_value (var->expr, values.vnode->expr, offset);
 
-      /* Modify the array section indexes and recalculate the offset for
-         next element.  */
-      else if (mark == AR_SECTION)
-        gfc_advance_section (section_index, ar, &offset);
+	  if (mark == AR_FULL)
+	    mpz_add_ui (offset, offset, 1);
 
-      mpz_sub_ui (size, size, 1);
+	  /* Modify the array section indexes and recalculate the offset
+	     for next element.  */
+	  else if (mark == AR_SECTION)
+	    gfc_advance_section (section_index, ar, &offset);
+	}
     }
+
   if (mark == AR_SECTION)
     {
       for (i = 0; i < ar->dimen; i++)
@@ -4253,7 +4289,6 @@ traverse_data_var (gfc_data_variable * var, locus * where)
 static try
 resolve_data_variables (gfc_data_variable * d)
 {
-
   for (; d; d = d->next)
     {
       if (d->list == NULL)
@@ -4287,7 +4322,6 @@ resolve_data_variables (gfc_data_variable * d)
 static void
 resolve_data (gfc_data * d)
 {
-
   if (resolve_data_variables (d->var) == FAILURE)
     return;
 
@@ -4312,7 +4346,6 @@ resolve_data (gfc_data * d)
 int
 gfc_impure_variable (gfc_symbol * sym)
 {
-
   if (sym->attr.use_assoc || sym->attr.in_common)
     return 1;
 
@@ -4606,4 +4639,3 @@ gfc_resolve (gfc_namespace * ns)
 
   gfc_current_ns = old_ns;
 }
-