[Patch, Fortran] Allocate + CAF library

[Patch, Fortran] Allocate + CAF library

[Daniel Carrera]

[-- Attachment #1: Type: text/plain, Size: 528 bytes --]

Hello,

This is my largest patch so far and the first that I'll commit myself. 
This patch improves support for the ALLOCATE statement when using the 
coarray library. Specifically, it adds support for the stat= and errmsg= 
attributes:

ALLOCATE( x(n)[*] , stat=i , errmsg=str )

These attributes are now written by the CAF library. This patch also 
involves a good amount of code cleanup.

ChangeLog is attached.

As soon as I get the go-ahead, I'll commit this patch.


Cheers,
Daniel.
-- 
I'm not overweight, I'm undertall.

[-- Attachment #2: allocate.diff --]
[-- Type: text/x-patch, Size: 21693 bytes --]

Index: gcc/fortran/trans-array.c
===================================================================
--- gcc/fortran/trans-array.c	(revision 176148)
+++ gcc/fortran/trans-array.c	(working copy)
@@ -4366,7 +4366,8 @@ gfc_array_init_size (tree descriptor, in
 /*GCC ARRAYS*/
 
 bool
-gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree pstat)
+gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
+		    tree errlen)
 {
   tree tmp;
   tree pointer;
@@ -4460,22 +4461,15 @@ gfc_array_allocate (gfc_se * se, gfc_exp
   error = build_call_expr_loc (input_location,
   			   gfor_fndecl_runtime_error, 1, msg);
 
-  if (pstat != NULL_TREE && !integer_zerop (pstat))
+  if (status != NULL_TREE)
     {
-      /* Set the status variable if it's present.  */
+      tree status_type = TREE_TYPE (status);
       stmtblock_t set_status_block;
-      tree status_type = pstat ? TREE_TYPE (TREE_TYPE (pstat)) : NULL_TREE;
 
       gfc_start_block (&set_status_block);
-      gfc_add_modify (&set_status_block,
-  		      fold_build1_loc (input_location, INDIRECT_REF,
-  				       status_type, pstat),
-  			   build_int_cst (status_type, LIBERROR_ALLOCATION));
-
-      tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
-  			     pstat, build_int_cst (TREE_TYPE (pstat), 0));
-      error = fold_build3_loc (input_location, COND_EXPR, void_type_node, tmp,
-  			       error, gfc_finish_block (&set_status_block));
+      gfc_add_modify (&set_status_block, status,
+		      build_int_cst (status_type, LIBERROR_ALLOCATION));
+      error = gfc_finish_block (&set_status_block);
     }
 
   gfc_start_block (&elseblock);
@@ -4484,14 +4478,15 @@ gfc_array_allocate (gfc_se * se, gfc_exp
   pointer = gfc_conv_descriptor_data_get (se->expr);
   STRIP_NOPS (pointer);
 
-  /* The allocate_array variants take the old pointer as first argument.  */
+  /* The allocatable variant takes the old pointer as first argument.  */
   if (allocatable)
-    tmp = gfc_allocate_allocatable_with_status (&elseblock,
-						pointer, size, pstat, expr);
+    tmp = gfc_allocate_allocatable (&elseblock, pointer, size,
+				    status, errmsg, errlen, expr);
   else
-    tmp = gfc_allocate_with_status (&elseblock, size, pstat, false);
-  tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, pointer,
-			 tmp);
+    tmp = gfc_allocate_using_malloc (&elseblock, size, status);
+
+  tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
+			 pointer, tmp);
 
   gfc_add_expr_to_block (&elseblock, tmp);
 
Index: gcc/fortran/trans-array.h
===================================================================
--- gcc/fortran/trans-array.h	(revision 176148)
+++ gcc/fortran/trans-array.h	(working copy)
@@ -24,7 +24,7 @@ tree gfc_array_deallocate (tree, tree, g
 
 /* Generate code to initialize an 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);
+bool gfc_array_allocate (gfc_se *, gfc_expr *, tree, tree, tree);
 
 /* 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-openmp.c
===================================================================
--- gcc/fortran/trans-openmp.c	(revision 176148)
+++ gcc/fortran/trans-openmp.c	(working copy)
@@ -188,9 +188,9 @@ gfc_omp_clause_default_ctor (tree clause
   size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
 			  size, esize);
   size = gfc_evaluate_now (fold_convert (size_type_node, size), &cond_block);
-  ptr = gfc_allocate_allocatable_with_status (&cond_block,
-					      build_int_cst (pvoid_type_node, 0),
-					      size, NULL, NULL);
+  ptr = gfc_allocate_allocatable (&cond_block,
+			  build_int_cst (pvoid_type_node, 0),
+			  size, NULL_TREE, NULL_TREE, NULL_TREE, NULL);
   gfc_conv_descriptor_data_set (&cond_block, decl, ptr);
   then_b = gfc_finish_block (&cond_block);
 
@@ -241,9 +241,9 @@ gfc_omp_clause_copy_ctor (tree clause, t
   size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
 			  size, esize);
   size = gfc_evaluate_now (fold_convert (size_type_node, size), &block);
-  ptr = gfc_allocate_allocatable_with_status (&block,
-					      build_int_cst (pvoid_type_node, 0),
-					      size, NULL, NULL);
+  ptr = gfc_allocate_allocatable (&block,
+			  build_int_cst (pvoid_type_node, 0),
+			  size, NULL_TREE, NULL_TREE, NULL_TREE, NULL);
   gfc_conv_descriptor_data_set (&block, dest, ptr);
   call = build_call_expr_loc (input_location,
 			  built_in_decls[BUILT_IN_MEMCPY], 3, ptr,
@@ -663,9 +663,9 @@ gfc_trans_omp_array_reduction (tree c, g
       size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
 			      size, esize);
       size = gfc_evaluate_now (fold_convert (size_type_node, size), &block);
-      ptr = gfc_allocate_allocatable_with_status (&block,
-						  build_int_cst (pvoid_type_node, 0),
-						  size, NULL, NULL);
+      ptr = gfc_allocate_allocatable (&block,
+			      build_int_cst (pvoid_type_node, 0),
+			      size, NULL_TREE, NULL_TREE, NULL_TREE, NULL);
       gfc_conv_descriptor_data_set (&block, decl, ptr);
       gfc_add_expr_to_block (&block, gfc_trans_assignment (e1, e2, false,
 			     false));
Index: gcc/fortran/trans-stmt.c
===================================================================
--- gcc/fortran/trans-stmt.c	(revision 176148)
+++ gcc/fortran/trans-stmt.c	(working copy)
@@ -4686,8 +4686,10 @@ gfc_trans_allocate (gfc_code * code)
   tree tmp;
   tree parm;
   tree stat;
-  tree pstat;
-  tree error_label;
+  tree errmsg;
+  tree errlen;
+  tree label_errmsg;
+  tree label_finish;
   tree memsz;
   tree expr3;
   tree slen3;
@@ -4699,7 +4701,8 @@ gfc_trans_allocate (gfc_code * code)
   if (!code->ext.alloc.list)
     return NULL_TREE;
 
-  pstat = stat = error_label = tmp = memsz = NULL_TREE;
+  stat = tmp = memsz = NULL_TREE;
+  label_errmsg = label_finish = errmsg = errlen = NULL_TREE;
 
   gfc_init_block (&block);
   gfc_init_block (&post);
@@ -4707,13 +4710,27 @@ gfc_trans_allocate (gfc_code * code)
   /* Either STAT= and/or ERRMSG is present.  */
   if (code->expr1 || code->expr2)
     {
+      /* STAT=  */
       tree gfc_int4_type_node = gfc_get_int_type (4);
-
       stat = gfc_create_var (gfc_int4_type_node, "stat");
-      pstat = gfc_build_addr_expr (NULL_TREE, stat);
 
-      error_label = gfc_build_label_decl (NULL_TREE);
-      TREE_USED (error_label) = 1;
+      /* ERRMSG=  */
+      errmsg = null_pointer_node;
+      errlen = build_int_cst (gfc_charlen_type_node, 0);
+      if (code->expr2)
+	{
+	  gfc_init_se (&se, NULL);
+	  gfc_conv_expr_lhs (&se, code->expr2);
+
+	  errlen = gfc_get_expr_charlen (code->expr2);
+	  errmsg = gfc_build_addr_expr (pchar_type_node, se.expr);
+	}
+
+      /* GOTO destinations.  */
+      label_errmsg = gfc_build_label_decl (NULL_TREE);
+      label_finish = gfc_build_label_decl (NULL_TREE);
+      TREE_USED (label_errmsg) = 1;
+      TREE_USED (label_finish) = 1;
     }
 
   expr3 = NULL_TREE;
@@ -4732,7 +4749,7 @@ gfc_trans_allocate (gfc_code * code)
       se.descriptor_only = 1;
       gfc_conv_expr (&se, expr);
 
-      if (!gfc_array_allocate (&se, expr, pstat))
+      if (!gfc_array_allocate (&se, expr, stat, errmsg, errlen))
 	{
 	  /* A scalar or derived type.  */
 
@@ -4847,10 +4864,10 @@ gfc_trans_allocate (gfc_code * code)
 
 	  /* Allocate - for non-pointers with re-alloc checking.  */
 	  if (gfc_expr_attr (expr).allocatable)
-	    tmp = gfc_allocate_allocatable_with_status (&se.pre, se.expr, memsz,
-							pstat, expr);
+	    tmp = gfc_allocate_allocatable (&se.pre, se.expr, memsz,
+					    stat, errmsg, errlen, expr);
 	  else
-	    tmp = gfc_allocate_with_status (&se.pre, memsz, pstat, false);
+	    tmp = gfc_allocate_using_malloc (&se.pre, memsz, stat);
 
 	  tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
 				 se.expr,
@@ -4859,7 +4876,13 @@ gfc_trans_allocate (gfc_code * code)
 
 	  if (code->expr1 || code->expr2)
 	    {
-	      tmp = build1_v (GOTO_EXPR, error_label);
+	      /* The coarray library already sets the errmsg.  */
+	      if (gfc_option.coarray == GFC_FCOARRAY_LIB
+		  && gfc_expr_attr (expr).codimension)
+		tmp = build1_v (GOTO_EXPR, label_finish);
+	      else
+		tmp = build1_v (GOTO_EXPR, label_errmsg);
+
 	      parm = fold_build2_loc (input_location, NE_EXPR,
 				      boolean_type_node, stat,
 				      build_int_cst (TREE_TYPE (stat), 0));
@@ -5005,16 +5028,11 @@ gfc_trans_allocate (gfc_code * code)
 
     }
 
-  /* STAT block.  */
-  if (code->expr1)
+  /* STAT or ERRMSG.  */
+  if (code->expr1 || code->expr2)
     {
-      tmp = build1_v (LABEL_EXPR, error_label);
+      tmp = build1_v (LABEL_EXPR, label_errmsg);
       gfc_add_expr_to_block (&block, tmp);
-
-      gfc_init_se (&se, NULL);
-      gfc_conv_expr_lhs (&se, code->expr1);
-      tmp = convert (TREE_TYPE (se.expr), stat);
-      gfc_add_modify (&block, se.expr, tmp);
     }
 
   /* ERRMSG block.  */
@@ -5022,7 +5040,7 @@ gfc_trans_allocate (gfc_code * code)
     {
       /* A better error message may be possible, but not required.  */
       const char *msg = "Attempt to allocate an allocated object";
-      tree errmsg, slen, dlen;
+      tree slen, dlen;
 
       gfc_init_se (&se, NULL);
       gfc_conv_expr_lhs (&se, code->expr2);
@@ -5050,6 +5068,22 @@ gfc_trans_allocate (gfc_code * code)
       gfc_add_expr_to_block (&block, tmp);
     }
 
+  /* STAT or ERRMSG.  */
+  if (code->expr1 || code->expr2)
+    {
+      tmp = build1_v (LABEL_EXPR, label_finish);
+      gfc_add_expr_to_block (&block, tmp);
+    }
+
+  /* STAT block.  */
+  if (code->expr1)
+    {
+      gfc_init_se (&se, NULL);
+      gfc_conv_expr_lhs (&se, code->expr1);
+      tmp = convert (TREE_TYPE (se.expr), stat);
+      gfc_add_modify (&block, se.expr, tmp);
+    }
+
   gfc_add_block_to_block (&block, &se.post);
   gfc_add_block_to_block (&block, &post);
 
Index: gcc/fortran/trans.c
===================================================================
--- gcc/fortran/trans.c	(revision 176148)
+++ gcc/fortran/trans.c	(working copy)
@@ -567,12 +567,12 @@ gfc_call_malloc (stmtblock_t * block, tr
    This function follows the following pseudo-code:
 
     void *
-    allocate (size_t size, integer_type* stat)
+    allocate (size_t size, integer_type stat)
     {
       void *newmem;
     
-      if (stat)
-	*stat = 0;
+      if (stat requested)
+	stat = 0;
 
       newmem = malloc (MAX (size, 1));
       if (newmem == NULL)
@@ -585,12 +585,11 @@ gfc_call_malloc (stmtblock_t * block, tr
       return newmem;
     }  */
 tree
-gfc_allocate_with_status (stmtblock_t * block, tree size, tree status,
-			  bool coarray_lib)
+gfc_allocate_using_malloc (stmtblock_t * block, tree size, tree status)
 {
   stmtblock_t alloc_block;
-  tree res, tmp, msg, cond;
-  tree status_type = status ? TREE_TYPE (TREE_TYPE (status)) : NULL_TREE;
+  tree res, tmp, on_error;
+  tree status_type = status ? TREE_TYPE (status) : NULL_TREE;
 
   /* Evaluate size only once, and make sure it has the right type.  */
   size = gfc_evaluate_now (size, block);
@@ -601,74 +600,37 @@ gfc_allocate_with_status (stmtblock_t * 
   res = gfc_create_var (prvoid_type_node, NULL);
 
   /* Set the optional status variable to zero.  */
-  if (status != NULL_TREE && !integer_zerop (status))
-    {
-      tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type,
-			     fold_build1_loc (input_location, INDIRECT_REF,
-					      status_type, status),
-			     build_int_cst (status_type, 0));
-      tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
-			     fold_build2_loc (input_location, NE_EXPR,
-					boolean_type_node, status,
-					build_int_cst (TREE_TYPE (status), 0)),
-			     tmp, build_empty_stmt (input_location));
-      gfc_add_expr_to_block (block, tmp);
-    }
+  if (status != NULL_TREE)
+      gfc_add_expr_to_block (block,
+	     fold_build2_loc (input_location, MODIFY_EXPR, status_type,
+			      status, build_int_cst (status_type, 0)));
 
   /* The allocation itself.  */
   gfc_start_block (&alloc_block);
-  if (coarray_lib)
-    {
-      gfc_add_modify (&alloc_block, res,
-	      fold_convert (prvoid_type_node,
-		    build_call_expr_loc (input_location,
-			 gfor_fndecl_caf_register, 6,
-			 fold_build2_loc (input_location,
-				  MAX_EXPR, size_type_node, size,
-				  build_int_cst (size_type_node, 1)),
-			 build_int_cst (integer_type_node,
-					GFC_CAF_COARRAY_ALLOC),
-			 null_pointer_node,  /* token  */
-			 null_pointer_node,  /* stat  */
-			 null_pointer_node,  /* errmsg, errmsg_len  */
-			 build_int_cst (integer_type_node, 0))));
-    }
+  gfc_add_modify (&alloc_block, res,
+	  fold_convert (prvoid_type_node,
+		build_call_expr_loc (input_location,
+			     built_in_decls[BUILT_IN_MALLOC], 1,
+			     fold_build2_loc (input_location,
+				      MAX_EXPR, size_type_node, size,
+				      build_int_cst (size_type_node, 1)))));
+
+  /* What to do in case of error.  */
+  if (status != NULL_TREE)
+    on_error = fold_build2_loc (input_location, MODIFY_EXPR, status_type,
+			status, build_int_cst (status_type, LIBERROR_ALLOCATION));
   else
-    {
-      gfc_add_modify (&alloc_block, res,
-	      fold_convert (prvoid_type_node,
-		    build_call_expr_loc (input_location,
-			 built_in_decls[BUILT_IN_MALLOC], 1,
-			 fold_build2_loc (input_location,
-				  MAX_EXPR, size_type_node, size,
-				  build_int_cst (size_type_node, 1)))));
-    }
-
-  msg = gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const
-			     ("Allocation would exceed memory limit"));
-  tmp = build_call_expr_loc (input_location,
-			 gfor_fndecl_os_error, 1, msg);
-
-  if (status != NULL_TREE && !integer_zerop (status))
-    {
-      /* Set the status variable if it's present.  */
-      tree tmp2;
-
-      cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
-			      status, build_int_cst (TREE_TYPE (status), 0));
-      tmp2 = fold_build2_loc (input_location, MODIFY_EXPR, status_type,
-			      fold_build1_loc (input_location, INDIRECT_REF,
-					       status_type, status),
-			      build_int_cst (status_type, LIBERROR_ALLOCATION));
-      tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
-			     tmp, tmp2);
-    }
+    on_error = build_call_expr_loc (input_location, gfor_fndecl_os_error, 1,
+		    gfc_build_addr_expr (pchar_type_node,
+				 gfc_build_localized_cstring_const
+				 ("Allocation would exceed memory limit")));
 
   tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
 			 fold_build2_loc (input_location, EQ_EXPR,
 					  boolean_type_node, res,
 					  build_int_cst (prvoid_type_node, 0)),
-			 tmp, build_empty_stmt (input_location));
+			 on_error, build_empty_stmt (input_location));
+
   gfc_add_expr_to_block (&alloc_block, tmp);
   gfc_add_expr_to_block (block, gfc_finish_block (&alloc_block));
 
@@ -676,6 +638,76 @@ gfc_allocate_with_status (stmtblock_t * 
 }
 
 
+/* Allocate memory, using an optional status argument.
+ 
+   This function follows the following pseudo-code:
+
+    void *
+    allocate (size_t size, integer_type stat)
+    {
+      void *newmem;
+    
+      if (stat requested)
+	stat = 0;
+
+      newmem = _caf_register ( size, regtype, NULL, &stat, NULL, NULL);
+      if (newmem == NULL)
+      {
+        if (!stat requested)
+	  runtime_error ("Allocation would exceed memory limit");
+      }
+      return newmem;
+    }  */
+tree
+gfc_allocate_using_lib (stmtblock_t * block, tree size, tree status,
+			tree errmsg, tree errlen)
+{
+  tree res, pstat;
+  tree status_type = status ? TREE_TYPE (status) : NULL_TREE;
+
+  /* Evaluate size only once, and make sure it has the right type.  */
+  size = gfc_evaluate_now (size, block);
+  if (TREE_TYPE (size) != TREE_TYPE (size_type_node))
+    size = fold_convert (size_type_node, size);
+
+  /* Create a variable to hold the result.  */
+  res = gfc_create_var (prvoid_type_node, NULL);
+
+  /* Set the optional status variable to zero.  */
+  if (status != NULL_TREE)
+      gfc_add_expr_to_block (block,
+	     fold_build2_loc (input_location, MODIFY_EXPR, status_type,
+			      status, build_int_cst (status_type, 0)));
+
+  /* The allocation itself.  */
+  if (status == NULL_TREE)
+    pstat  = null_pointer_node;
+  else
+    pstat  = gfc_build_addr_expr (NULL_TREE, status);
+
+  if (errmsg == NULL_TREE)
+    {
+      gcc_assert(errlen == NULL_TREE);
+      errmsg = null_pointer_node;
+      errlen = build_int_cst (integer_type_node, 0);
+    }
+
+  gfc_add_modify (block, res,
+	  fold_convert (prvoid_type_node,
+		build_call_expr_loc (input_location,
+		     gfor_fndecl_caf_register, 6,
+		     fold_build2_loc (input_location,
+			      MAX_EXPR, size_type_node, size,
+			      build_int_cst (size_type_node, 1)),
+		     build_int_cst (integer_type_node,
+			    GFC_CAF_COARRAY_ALLOC),
+		     null_pointer_node,  /* token  */
+		     pstat, errmsg, errlen)));
+
+  return res;
+}
+
+
 /* Generate code for an ALLOCATE statement when the argument is an
    allocatable variable.  If the variable is currently allocated, it is an
    error to allocate it again.
@@ -683,7 +715,7 @@ gfc_allocate_with_status (stmtblock_t * 
    This function follows the following pseudo-code:
   
     void *
-    allocate_allocatable (void *mem, size_t size, integer_type *stat)
+    allocate_allocatable (void *mem, size_t size, integer_type stat)
     {
       if (mem == NULL)
 	return allocate (size, stat);
@@ -693,7 +725,7 @@ gfc_allocate_with_status (stmtblock_t * 
 	{
 	  free (mem);
 	  mem = allocate (size, stat);
-	  *stat = LIBERROR_ALLOCATION;
+	  stat = LIBERROR_ALLOCATION;
 	  return mem;
 	}
 	else
@@ -704,8 +736,8 @@ gfc_allocate_with_status (stmtblock_t * 
     expr must be set to the original expression being allocated for its locus
     and variable name in case a runtime error has to be printed.  */
 tree
-gfc_allocate_allocatable_with_status (stmtblock_t * block, tree mem, tree size,
-				      tree status, gfc_expr* expr)
+gfc_allocate_allocatable (stmtblock_t * block, tree mem, tree size, tree status,
+			  tree errmsg, tree errlen, gfc_expr* expr)
 {
   stmtblock_t alloc_block;
   tree res, tmp, null_mem, alloc, error;
@@ -720,11 +752,16 @@ gfc_allocate_allocatable_with_status (st
 					    boolean_type_node, mem,
 					    build_int_cst (type, 0)));
 
-  /* If mem is NULL, we call gfc_allocate_with_status.  */
+  /* If mem is NULL, we call gfc_allocate_using_malloc or
+     gfc_allocate_using_lib.  */
   gfc_start_block (&alloc_block);
-  tmp = gfc_allocate_with_status (&alloc_block, size, status,
-				  gfc_option.coarray == GFC_FCOARRAY_LIB
-				  && gfc_expr_attr (expr).codimension);
+
+  if (gfc_option.coarray == GFC_FCOARRAY_LIB
+      && gfc_expr_attr (expr).codimension)
+    tmp = gfc_allocate_using_lib (&alloc_block, size, status,
+				  errmsg, errlen);
+  else
+    tmp = gfc_allocate_using_malloc (&alloc_block, size, status);
 
   gfc_add_modify (&alloc_block, res, fold_convert (type, tmp));
   alloc = gfc_finish_block (&alloc_block);
@@ -749,9 +786,9 @@ gfc_allocate_allocatable_with_status (st
 				     "Attempting to allocate already allocated"
 				     " variable");
 
-  if (status != NULL_TREE && !integer_zerop (status))
+  if (status != NULL_TREE)
     {
-      tree status_type = TREE_TYPE (TREE_TYPE (status));
+      tree status_type = TREE_TYPE (status);
       stmtblock_t set_status_block;
 
       gfc_start_block (&set_status_block);
@@ -760,18 +797,12 @@ gfc_allocate_allocatable_with_status (st
 			     fold_convert (pvoid_type_node, mem));
       gfc_add_expr_to_block (&set_status_block, tmp);
 
-      tmp = gfc_allocate_with_status (&set_status_block, size, status, false);
+      tmp = gfc_allocate_using_malloc (&set_status_block, size, status);
       gfc_add_modify (&set_status_block, res, fold_convert (type, tmp));
 
-      gfc_add_modify (&set_status_block,
-			   fold_build1_loc (input_location, INDIRECT_REF,
-					    status_type, status),
-			   build_int_cst (status_type, LIBERROR_ALLOCATION));
-
-      tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
-			     status, build_int_cst (status_type, 0));
-      error = fold_build3_loc (input_location, COND_EXPR, void_type_node, tmp,
-			       error, gfc_finish_block (&set_status_block));
+      gfc_add_modify (&set_status_block, status,
+		      build_int_cst (status_type, LIBERROR_ALLOCATION));
+      error = gfc_finish_block (&set_status_block);
     }
 
   tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, null_mem,
Index: gcc/fortran/trans.h
===================================================================
--- gcc/fortran/trans.h	(revision 176148)
+++ gcc/fortran/trans.h	(working copy)
@@ -541,11 +541,12 @@ tree gfc_call_malloc (stmtblock_t *, tre
 tree gfc_build_memcpy_call (tree, tree, tree);
 
 /* Allocate memory for allocatable variables, with optional status variable.  */
-tree gfc_allocate_allocatable_with_status (stmtblock_t*,
-					   tree, tree, tree, gfc_expr*);
+tree gfc_allocate_allocatable (stmtblock_t*, tree, tree,
+			       tree, tree, tree, gfc_expr*);
 
 /* Allocate memory, with optional status variable.  */
-tree gfc_allocate_with_status (stmtblock_t *, tree, tree, bool);
+tree gfc_allocate_using_malloc (stmtblock_t *, tree, tree);
+tree gfc_allocate_using_lib (stmtblock_t *, tree, tree, tree, tree);
 
 /* Generate code to deallocate an array.  */
 tree gfc_deallocate_with_status (tree, tree, bool, gfc_expr*);

[-- Attachment #3: ChangeLog --]
[-- Type: text/plain, Size: 1050 bytes --]

2011-07-11  Daniel Carrera  <dcarrera@gmail.com>

	* trans.c (gfc_allocate_with_status): Split into two functions
	gfc_allocate_using_malloc ad gfc_allocate_usig_lib.
	(gfc_allocate_using_malloc): The status parameter is now the
	actual status rather than a pointer. Code cleanup.
	(gfc_allocate_using_lib): Ditto. Add new parametrs errmsg and
	errlen. Pass these to the coarray lib.
	* trans-openmp.c (gfc_omp_clause_default_ctor): Update calls to
	gfc_allocate_allocatable.
	(gfc_omp_clause_copy_ctor): Ditto.
	(gfc_trans_omp_array_reduction): Ditto.
	* trans-stmt.c (gfc_trans_allocate): Ditto. Update call to
	gfc_allocate_using_malloc. Pass stat rather than pstat to the
	allocate fuctions. If using coarray lib, pass errmsg and errlen
	to the allocate functions.
	* trans-array.c (gfc_array_allocate): Add new parameters errmsg
	and errlen. Replace parameter pstat by status. Code cleanup. Update
	calls to gfc_allocate_allocatable and gfc_allocate_using_malloc.
	* trans-array.h (gfc_array_allocate): Update signature of
	gfc_array_allocate.

Re: [Patch, Fortran] Allocate + CAF library

[Daniel Carrera]

*ping* ?

On 07/11/2011 08:16 PM, Daniel Carrera wrote:
> Hello,
>
> This is my largest patch so far and the first that I'll commit myself.
> This patch improves support for the ALLOCATE statement when using the
> coarray library. Specifically, it adds support for the stat= and errmsg=
> attributes:
>
> ALLOCATE( x(n)[*] , stat=i , errmsg=str )
>
> These attributes are now written by the CAF library. This patch also
> involves a good amount of code cleanup.
>
> ChangeLog is attached.
>
> As soon as I get the go-ahead, I'll commit this patch.
>
>
> Cheers,
> Daniel.


-- 
I'm not overweight, I'm undertall.

Re: [Patch, Fortran] Allocate + CAF library

[Tobias Burnus]

On 07/11/2011 08:16 PM, Daniel Carrera wrote:
> This patch improves support for the ALLOCATE statement when using the 
> coarray library. Specifically, it adds support for the stat= and 
> errmsg= attributes:

Thanks for the patch - and sorry for the slow review.

Some comments below.

> Index: gcc/fortran/trans-stmt.c
> ===================================================================
> +      /* ERRMSG=  */
> +      errmsg = null_pointer_node;
> +      errlen = build_int_cst (gfc_charlen_type_node, 0);
> +      if (code->expr2)
> +	{
> [...]
> +	  errlen = gfc_get_expr_charlen (code->expr2);
> +	  errmsg = gfc_build_addr_expr (pchar_type_node, se.expr);
> +	}

While build_int_cst is not terribly expensive, it also does not come for 
free (cf. tree.c); thus, please move the code from before the "if" into 
an "else".

> +      /* GOTO destinations.  */
> +      label_errmsg = gfc_build_label_decl (NULL_TREE);
> +      label_finish = gfc_build_label_decl (NULL_TREE);

There seems to be a goto missing. For

   integer, allocatable :: AA, BB[:], CC
   integer :: stat
   allocate(CC, AA, stat=stat)

one gets (-fdump-tree-original):

         cc = D.1563;  /* end of allocation of "CC".  */
         if (stat.0 != 0) goto L.1;

         if ((logical(kind=4)) __builtin_expect (aa != 0B, 0))
           ....
         else
            /* Allocate "AA".  */

If you try
         allocate(BB[*], AA, stat=stat)
instead you do not get the "if (stat.0 != 0) goto L.1;"

Or in English: Assuming one has stat=variable: If you do not have 
coarrays, as soon as one allocation fails, one jumps at the end of the 
block and the "stat" variable contains a nonzero value.
If the coarray allocation fails, one continues with other allocations 
and thus may end up with "stat == 0" although (at least) one (coarray) 
allocation has failed.


> +  if (status != NULL_TREE)
> +      gfc_add_expr_to_block (block,
> +	     fold_build2_loc (input_location, MODIFY_EXPR, status_type,
> +			      status, build_int_cst (status_type, 0)));

Indent is wrong (should be two spaces, is more as a left over from 
removing the { ... }).

> +   This function follows the following pseudo-code:
> [...]
> +      newmem = _caf_register ( size, regtype, NULL,&stat, NULL, NULL);
> +      if (newmem == NULL)
> +      {
> +        if (!stat requested)
> +	  runtime_error ("Allocation would exceed memory limit");
> +      }
> +      return newmem;

The "if (newmem == NULL) part is not present in the patch - an error is 
already printed in _caf_register and thus the check has been removed. 
However, the comment has not been updated.
Additionally, you could replace the last two NULLs by errmsg/errmsg_len.

> +gfc_allocate_using_lib (stmtblock_t * block, tree size, tree status,
> +			tree errmsg, tree errlen)
> [...]
>
> +  /* Set the optional status variable to zero.  */
> +  if (status != NULL_TREE)
> +      gfc_add_expr_to_block (block,
> +	     fold_build2_loc (input_location, MODIFY_EXPR, status_type,
> +			      status, build_int_cst (status_type, 0)));
> [...]
> +  gfc_add_modify (block, res,
> +	  fold_convert (prvoid_type_node,
> +		build_call_expr_loc (input_location,
> +		     gfor_fndecl_caf_register, 6,

The "stat" variable is already set in the registering function - no need 
to set it to zero before the call.

Tobias

Re: [Patch, Fortran] Allocate + CAF library

[Daniel Carrera]

On 07/15/2011 10:03 AM, Tobias Burnus wrote:
>> + /* ERRMSG= */
>> + errmsg = null_pointer_node;
>> + errlen = build_int_cst (gfc_charlen_type_node, 0);
>> + if (code->expr2)
>> + {
>> [...]
>> + errlen = gfc_get_expr_charlen (code->expr2);
>> + errmsg = gfc_build_addr_expr (pchar_type_node, se.expr);
>> + }
>
> While build_int_cst is not terribly expensive, it also does not come for
> free (cf. tree.c); thus, please move the code from before the "if" into
> an "else".

Ok. Fixed.


>> + /* GOTO destinations. */
>> + label_errmsg = gfc_build_label_decl (NULL_TREE);
>> + label_finish = gfc_build_label_decl (NULL_TREE);
>
> There seems to be a goto missing. For
>
> integer, allocatable :: AA, BB[:], CC
> integer :: stat
> allocate(CC, AA, stat=stat)
>
> one gets (-fdump-tree-original):
>
> cc = D.1563; /* end of allocation of "CC". */
> if (stat.0 != 0) goto L.1;
>
> if ((logical(kind=4)) __builtin_expect (aa != 0B, 0))
> ....
> else
> /* Allocate "AA". */
>
> If you try
> allocate(BB[*], AA, stat=stat)
> instead you do not get the "if (stat.0 != 0) goto L.1;"
>
> Or in English: Assuming one has stat=variable: If you do not have
> coarrays, as soon as one allocation fails, one jumps at the end of the
> block and the "stat" variable contains a nonzero value.
> If the coarray allocation fails, one continues with other allocations
> and thus may end up with "stat == 0" although (at least) one (coarray)
> allocation has failed.


This is strange. The problem is definitely in the following if branch in 
gfc_trans_array:

   if (code->expr1 || code->expr2)
     {
       /* The coarray library already sets the errmsg.  */
       if (gfc_option.coarray == GFC_FCOARRAY_LIB
	  && gfc_expr_attr (expr).codimension)
	tmp = build1_v (GOTO_EXPR, label_finish);
       else
	tmp = build1_v (GOTO_EXPR, label_errmsg);
     ...
     }


You see what I'm trying to do here. If the current expression is a 
coarray and we are using the coarray lib, the library has already set 
the errmsg and we do not want to set it again. That's why there are two 
goto destinations. Schematically, it's like this:

label_errmsg:
     if (stat != 0) *errmsg = "Compiler's default message.";

label_finish:
     if (stat != 0) ... write user's stat variable ...;


I other words, the code example that you posted should have two 
different GOTO targets. If you are using MPI then BB should be pointing 
at label_finish and AA should be pointing at label_errmsg. And if you 
are not using MPI, then both should be pointing at label_errmsg.


I'll need some time to think about why this is not working the way I expect.


>> + if (status != NULL_TREE)
>> + gfc_add_expr_to_block (block,
>> + fold_build2_loc (input_location, MODIFY_EXPR, status_type,
>> + status, build_int_cst (status_type, 0)));
>
> Indent is wrong (should be two spaces, is more as a left over from
> removing the { ... }).

Fixed.


>> + This function follows the following pseudo-code:
>> [...]
>> + newmem = _caf_register ( size, regtype, NULL,&stat, NULL, NULL);
>> + if (newmem == NULL)
>> + {
>> + if (!stat requested)
>> + runtime_error ("Allocation would exceed memory limit");
>> + }
>> + return newmem;
>
> The "if (newmem == NULL) part is not present in the patch - an error is
> already printed in _caf_register and thus the check has been removed.
> However, the comment has not been updated.
> Additionally, you could replace the last two NULLs by errmsg/errmsg_len.

Fixed.


>> +gfc_allocate_using_lib (stmtblock_t * block, tree size, tree status,
>> + tree errmsg, tree errlen)
>> [...]
>>
>> + /* Set the optional status variable to zero. */
>> + if (status != NULL_TREE)
>> + gfc_add_expr_to_block (block,
>> + fold_build2_loc (input_location, MODIFY_EXPR, status_type,
>> + status, build_int_cst (status_type, 0)));
>> [...]
>> + gfc_add_modify (block, res,
>> + fold_convert (prvoid_type_node,
>> + build_call_expr_loc (input_location,
>> + gfor_fndecl_caf_register, 6,
>
> The "stat" variable is already set in the registering function - no need
> to set it to zero before the call.

Fixed.  I tried to clean up the residual code inherited from 
allocate_with_status but I missed that part.


Anyway, I'll go think about the GOTOs and figure out what went wrong 
there...

Cheers,
Daniel.
-- 
I'm not overweight, I'm undertall.

Re: [Patch, Fortran] Allocate + CAF library

[Tobias Burnus]

On 07/15/2011 12:58 PM, Daniel Carrera wrote:
>>> + label_errmsg = gfc_build_label_decl (NULL_TREE);
>>> + label_finish = gfc_build_label_decl (NULL_TREE);
>>
>> There seems to be a goto missing.
>
> This is strange. The problem is definitely in the following if branch 
> in gfc_trans_array:
>
>   if (code->expr1 || code->expr2)
>     {

Side remark: One actually only needs to take care whether there is a 
STAT=. If there is only an ERRMSG=, the code is unreachable as without 
STAT= one gets a run-time error, when an error occurs - and if no error 
occurs, ERRMSG= is not modified. Thus, one could reduce the code size by 
checking only for code->expr1.


>       /* The coarray library already sets the errmsg.  */
>       if (gfc_option.coarray == GFC_FCOARRAY_LIB
> && gfc_expr_attr (expr).codimension)
>     tmp = build1_v (GOTO_EXPR, label_finish);
>       else
>     tmp = build1_v (GOTO_EXPR, label_errmsg);

OK, I understand now why. It is a bit convoluted - and it is due to an 
existing bug in GCC. All (allocatable) coarrays - including 
(allocatable) scalar coarrays are arrays - and arrays are handled in 
gfc_array_allocate.
The code to jump over the next items to the final or error label is only 
checked in the "!gfc_array_allocate" loop.

Thus:
- The code for jumping to the label needs to be either in an "else" 
branch or moved out of "if" branch.
- In the "if" branch, you can remove all coarray additions - and add a 
gcc_assert() to make sure that indeed no coarray enters there.

Seemingly, the "if (stat !=0) goto ..."  for arrays never worked - not 
in GCC 4.1, 4.3, 4.4, 4.6 nor in 4.7.

Tobias

PS: Another bug I found when looking at this patch is PR 49775, it is 
related to the code, but an independent issue. I think it will probably 
better to place it into a different patch. I was wondering whether you 
could/would/want to do it after this patch; it should be straight forward.

Re: [Patch, Fortran] Allocate + CAF library

[Daniel Carrera]

On 07/15/2011 02:16 PM, Tobias Burnus wrote:
>> if (code->expr1 || code->expr2)
>> {
>
> Side remark: One actually only needs to take care whether there is a
> STAT=. If there is only an ERRMSG=, the code is unreachable as without
> STAT= one gets a run-time error, when an error occurs - and if no error
> occurs, ERRMSG= is not modified. Thus, one could reduce the code size by
> checking only for code->expr1.

Ok.


>> /* The coarray library already sets the errmsg. */
>> if (gfc_option.coarray == GFC_FCOARRAY_LIB
>> && gfc_expr_attr (expr).codimension)
>> tmp = build1_v (GOTO_EXPR, label_finish);
>> else
>> tmp = build1_v (GOTO_EXPR, label_errmsg);
>
> OK, I understand now why. It is a bit convoluted - and it is due to an
> existing bug in GCC. All (allocatable) coarrays - including
> (allocatable) scalar coarrays are arrays - and arrays are handled in
> gfc_array_allocate.
> The code to jump over the next items to the final or error label is only
> checked in the "!gfc_array_allocate" loop.
>
> Thus:
> - The code for jumping to the label needs to be either in an "else"
> branch or moved out of "if" branch.
> - In the "if" branch, you can remove all coarray additions - and add a
> gcc_assert() to make sure that indeed no coarray enters there.

There are two if-branches and I'm not sure which one you are talking 
about. But let me tell you what I think we should do and you can tell me 
if we are on the same page:

I think we should move the entire "if (code->expr1 ...)" block outside 
the "if (!gfc_array_allocate)" block. In other words, I propose this:


if (!gfc_array_allocate (&se, expr, stat, errmsg, errlen))
   {
     ... allocate scalar ...
   }
if (code->expr1)
   {
     /* The coarray library already sets the errmsg.  */
     if (gfc_option.coarray == GFC_FCOARRAY_LIB
		  && gfc_expr_attr (expr).codimension)
       tmp = build1_v (GOTO_EXPR, label_finish);
     else
       tmp = build1_v (GOTO_EXPR, label_errmsg);
     ...
   }


My thinking is that this error checking applies equally whether the we 
use gfc_array_allocate or not. If we call gfc_array_allocate we still 
have stat, we still have errmsg, and we still may or may not call the 
coarray library. And I see nothing inside gfc_array_allocate that covers 
stat= and errmsg=.

What do you think?


> Seemingly, the "if (stat !=0) goto ..." for arrays never worked - not in
> GCC 4.1, 4.3, 4.4, 4.6 nor in 4.7.

That would make sense if arrays always went into gfc_array_allocate. In 
that case, I think that my proposed change above would fix the problem.


> PS: Another bug I found when looking at this patch is PR 49775, it is
> related to the code, but an independent issue. I think it will probably
> better to place it into a different patch. I was wondering whether you
> could/would/want to do it after this patch; it should be straight forward.

Yes, I'd like to do that next. It's very much related to what I've been 
doing lately. I think I even remember noticing that the code deallocated 
the previous array and was wondering why it did that.

Cheers,
Daniel.
-- 
I'm not overweight, I'm undertall.

Re: [Patch, Fortran] Allocate + CAF library

[Tobias Burnus]

Daniel Carrera wrote:
> I propose this:
>
>
> if (!gfc_array_allocate (&se, expr, stat, errmsg, errlen))
>   {
>     ... allocate scalar ...
>   }
> if (code->expr1)
>   {
>     /* The coarray library already sets the errmsg.  */
>     if (gfc_option.coarray == GFC_FCOARRAY_LIB
> && gfc_expr_attr (expr).codimension)
>       tmp = build1_v (GOTO_EXPR, label_finish);
>     else
>       tmp = build1_v (GOTO_EXPR, label_errmsg);
>     ...
>   }

Yes, that was what I was thinking of. I hadn't checked whether one could 
use exactly the same code or needed a slightly different version, but it 
seems as if one can do just as you have written.

[Other PR]
> I think I even remember noticing that the code deallocated the 
> previous array and was wondering why it did that.

I think I saw the code also before in some dump, wondered about it, but 
not enough to check the standard, which explicitly prohibits the 
(de/re)allocation. (It does so in F2003 and F2008, I have not checked 
the wording in F90/F95. Maybe the status back then was "undefined"?)

Tobias