* [Patches, Fortran] ALLOCATE & CAF library.
@ 2011-07-21 11:30 Daniel Carrera
2011-07-21 12:49 ` Daniel Carrera
2011-07-21 14:50 ` Tobias Burnus
0 siblings, 2 replies; 11+ messages in thread
From: Daniel Carrera @ 2011-07-21 11:30 UTC (permalink / raw)
To: gcc patches, gfortran
[-- Attachment #1: Type: text/plain, Size: 2854 bytes --]
Hello all,
After some delay due to other work, I'd like to submit an updated
version of my patch. This patch allows the ALLOCATE statement to
correctly support the stat= and errmsg= attributes.
The patch (allocate.diff) was produced by Mercurial but it has a diff
style that should be very similar to the SVN style.
This patch now fixes an existing bug in GFortran whereby the ALLOCATE
statement only gets error checking if you are allocating a scalar. The
reason is that gfc_trans_allocate looks like this:
if (!gfc_array_allocate (&se, expr, stat, errmsg, errlen))
{
... allocatable scalars are handled here ...
if (code->expr1 || code->expr2)
{
... if stat != 0 goto label ...
}
}
The solution of course is to move the error checking outside (with
appropriate changes), and that's the only thing that makes this patch
different form my previous version:
if (!gfc_array_allocate (&se, expr, stat, errmsg, errlen))
{
... allocatable scalars are handled here ...
}
if (code->expr1 || code->expr2)
{
... if stat != 0 goto label ...
}
The patch compiles and passes all tests. I verified that the tree is
correct using a sample code that was known not to work correctly before:
integer, allocatable :: AA, BB[:], CC
integer :: stat
allocate(CC, BB, stat=stat)
With current trunk, if you compile this with -fdump-tree-original you see:
cc = D.1563;
if (stat.0 != 0) goto L.1;
...
{
...
bb.data = D.1564;
}
... if-block missing ...
So the "if (stat.0 != 0)" appears for the allocatable scalar but not for
the allocatable scalar coarray. I have confirmed that this now works
correctly. In fact, attached you'll find two dump trees that show the
main four scenarios:
1) -fcoaray=single versus -fcoarray=lib
2) Allocatable scalar and a coarray (treated as an array).
In both cases the program is:
program test
integer, allocatable :: AA, BB[:], CC
integer :: stat
allocate(CC, BB[*], stat=stat)
end program
Scanning the dump tree you'll immediately see that the "goto" is there
in all four cases. And if you are attentive you'll notice that one three
cases have one goto:
if (stat.0 != 0) goto L.1;
but in the case of a coarray compiled with -fcoarray=lib the goto
destination changes:
if (stat.0 != 0) goto L.2;
Though not shown in these attachments, if the user included errmsg= in
the allocate statemet, then errmsg is set between L.1 and L.2:
L.1:;
... set errmsg here ...
L.2:;
stat = stat.0;
If we have a coarray and -fcoarray=lib, then the library is in charge of
setting errmsg and the compiler shouldn't do it again.
All in all, I feel positive about this patch. Please take a look and let
me know if I missed anything. If I get a yay, I'll commit this to trunk.
Cheers,
Daniel.
--
I'm not overweight, I'm undertall.
[-- Attachment #2: allocate.diff --]
[-- Type: text/x-patch, Size: 18167 bytes --]
Index: gcc/fortran/trans-array.c
===================================================================
--- gcc/fortran/trans-array.c (revision 176528)
+++ gcc/fortran/trans-array.c (working copy)
@@ -4384,3 +4384,4 @@ gfc_array_init_size (tree descriptor, in
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)
{
@@ -4479,18 +4480,11 @@ gfc_array_allocate (gfc_se * se, gfc_exp
- if (pstat != NULL_TREE && !integer_zerop (pstat))
- {
- /* Set the status variable if it's present. */
+ if (status != NULL_TREE)
+ {
+ 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);
}
@@ -4503,10 +4497,11 @@ gfc_array_allocate (gfc_se * se, gfc_exp
- /* 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);
Index: gcc/fortran/trans-array.h
===================================================================
--- gcc/fortran/trans-array.h (revision 176528)
+++ gcc/fortran/trans-array.h (working copy)
@@ -26,3 +26,3 @@ tree gfc_array_deallocate (tree, tree, g
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);
Index: gcc/fortran/trans-openmp.c
===================================================================
--- gcc/fortran/trans-openmp.c (revision 176528)
+++ gcc/fortran/trans-openmp.c (working copy)
@@ -190,5 +190,5 @@ gfc_omp_clause_default_ctor (tree clause
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);
@@ -243,5 +243,5 @@ gfc_omp_clause_copy_ctor (tree clause, t
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);
@@ -665,5 +665,5 @@ gfc_trans_omp_array_reduction (tree c, g
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);
Index: gcc/fortran/trans-stmt.c
===================================================================
--- gcc/fortran/trans-stmt.c (revision 176528)
+++ gcc/fortran/trans-stmt.c (working copy)
@@ -4688,4 +4688,6 @@ gfc_trans_allocate (gfc_code * code)
tree stat;
- tree pstat;
- tree error_label;
+ tree errmsg;
+ tree errlen;
+ tree label_errmsg;
+ tree label_finish;
tree memsz;
@@ -4701,3 +4703,4 @@ gfc_trans_allocate (gfc_code * code)
- pstat = stat = error_label = tmp = memsz = NULL_TREE;
+ stat = tmp = memsz = NULL_TREE;
+ label_errmsg = label_finish = errmsg = errlen = NULL_TREE;
@@ -4709,9 +4712,23 @@ gfc_trans_allocate (gfc_code * code)
{
+ /* 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;
}
@@ -4734,3 +4751,3 @@ gfc_trans_allocate (gfc_code * code)
- if (!gfc_array_allocate (&se, expr, pstat))
+ if (!gfc_array_allocate (&se, expr, stat, errmsg, errlen))
{
@@ -4849,6 +4866,6 @@ gfc_trans_allocate (gfc_code * code)
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);
@@ -4861,3 +4878,9 @@ gfc_trans_allocate (gfc_code * code)
{
- 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,
@@ -5007,12 +5030,7 @@ 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);
}
@@ -5024,3 +5042,3 @@ gfc_trans_allocate (gfc_code * code)
const char *msg = "Attempt to allocate an allocated object";
- tree errmsg, slen, dlen;
+ tree slen, dlen;
@@ -5052,2 +5070,18 @@ gfc_trans_allocate (gfc_code * code)
+ /* 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);
Index: gcc/fortran/trans.c
===================================================================
--- gcc/fortran/trans.c (revision 176528)
+++ gcc/fortran/trans.c (working copy)
@@ -567,3 +567,3 @@ gfc_call_malloc (stmtblock_t * block, tr
void *
- allocate (size_t size, integer_type* stat)
+ allocate (size_t size, integer_type stat)
{
@@ -571,4 +571,4 @@ gfc_call_malloc (stmtblock_t * block, tr
- if (stat)
- *stat = 0;
+ if (stat requested)
+ stat = 0;
@@ -585,8 +585,7 @@ gfc_call_malloc (stmtblock_t * block, tr
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;
@@ -601,15 +600,6 @@ gfc_allocate_with_status (stmtblock_t *
/* 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)));
@@ -617,48 +607,19 @@ gfc_allocate_with_status (stmtblock_t *
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")));
@@ -668,3 +629,4 @@ gfc_allocate_with_status (stmtblock_t *
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);
@@ -676,2 +638,72 @@ 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
@@ -683,3 +715,3 @@ gfc_allocate_with_status (stmtblock_t *
void *
- allocate_allocatable (void *mem, size_t size, integer_type *stat)
+ allocate_allocatable (void *mem, size_t size, integer_type stat)
{
@@ -693,3 +725,3 @@ gfc_allocate_with_status (stmtblock_t *
mem = allocate (size, stat);
- *stat = LIBERROR_ALLOCATION;
+ stat = LIBERROR_ALLOCATION;
return mem;
@@ -704,4 +736,4 @@ gfc_allocate_with_status (stmtblock_t *
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)
{
@@ -720,7 +752,12 @@ gfc_allocate_allocatable_with_status (st
- /* 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);
@@ -749,5 +786,5 @@ gfc_allocate_allocatable_with_status (st
- 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;
@@ -760,14 +797,8 @@ gfc_allocate_allocatable_with_status (st
- 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);
}
Index: gcc/fortran/trans.h
===================================================================
--- gcc/fortran/trans.h (revision 176528)
+++ gcc/fortran/trans.h (working copy)
@@ -543,7 +543,8 @@ tree gfc_build_memcpy_call (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);
[-- Attachment #3: dump-tree-lib.original --]
[-- Type: text/plain, Size: 2676 bytes --]
test ()
{
struct array1_integer(kind=4) bb;
integer(kind=4) * cc;
integer(kind=4) stat;
try
{
bb.data = 0B;
cc = 0B;
{
integer(kind=4) * D.1534;
integer(kind=4) stat.0;
if ((logical(kind=4)) __builtin_expect (cc != 0B, 0))
{
{
void * restrict D.1536;
__builtin_free ((void *) cc);
stat.0 = 0;
D.1536 = (void * restrict) __builtin_malloc (4);
if (D.1536 == 0B)
{
stat.0 = 5014;
}
D.1534 = (integer(kind=4) *) D.1536;
stat.0 = 5014;
}
}
else
{
{
void * restrict D.1535;
stat.0 = 0;
D.1535 = (void * restrict) __builtin_malloc (4);
if (D.1535 == 0B)
{
stat.0 = 5014;
}
D.1534 = (integer(kind=4) *) D.1535;
}
}
cc = D.1534;
if (stat.0 != 0) goto L.1;
bb.dtype = 264;
bb.dim[0].lbound = 1;
{
void * restrict D.1537;
if ((logical(kind=4)) __builtin_expect (bb.data != 0B, 0))
{
{
void * restrict D.1539;
__builtin_free ((void *) bb.data);
stat.0 = 0;
D.1539 = (void * restrict) __builtin_malloc (4);
if (D.1539 == 0B)
{
stat.0 = 5014;
}
D.1537 = D.1539;
stat.0 = 5014;
}
}
else
{
{
void * restrict D.1538;
stat.0 = 0;
D.1538 = (void * restrict) _gfortran_caf_register (4, 1, 0B, &stat.0, 0B, 0);
D.1537 = D.1538;
}
}
bb.data = D.1537;
}
if (stat.0 != 0) goto L.2;
L.1:;
L.2:;
stat = stat.0;
}
}
finally
{
if (cc != 0B)
{
__builtin_free ((void *) cc);
}
if (bb.data != 0B)
{
__builtin_free ((void *) bb.data);
}
bb.data = 0B;
}
}
main (integer(kind=4) argc, character(kind=1) * * argv)
{
static integer(kind=4) options.1[8] = {68, 1023, 0, 0, 1, 1, 0, 1};
_gfortran_caf_init (&argc, &argv, &_gfortran_caf_this_image, &_gfortran_caf_num_images);
_gfortran_set_args (argc, argv);
_gfortran_set_options (8, &options.1[0]);
test ();
__sync_synchronize ();
_gfortran_caf_finalize ();
return 0;
}
[-- Attachment #4: dump-tree-single.original --]
[-- Type: text/plain, Size: 2611 bytes --]
test ()
{
struct array1_integer(kind=4) bb;
integer(kind=4) * cc;
integer(kind=4) stat;
try
{
bb.data = 0B;
cc = 0B;
{
integer(kind=4) * D.1523;
integer(kind=4) stat.0;
if ((logical(kind=4)) __builtin_expect (cc != 0B, 0))
{
{
void * restrict D.1525;
__builtin_free ((void *) cc);
stat.0 = 0;
D.1525 = (void * restrict) __builtin_malloc (4);
if (D.1525 == 0B)
{
stat.0 = 5014;
}
D.1523 = (integer(kind=4) *) D.1525;
stat.0 = 5014;
}
}
else
{
{
void * restrict D.1524;
stat.0 = 0;
D.1524 = (void * restrict) __builtin_malloc (4);
if (D.1524 == 0B)
{
stat.0 = 5014;
}
D.1523 = (integer(kind=4) *) D.1524;
}
}
cc = D.1523;
if (stat.0 != 0) goto L.1;
bb.dtype = 264;
bb.dim[0].lbound = 1;
{
void * restrict D.1526;
if ((logical(kind=4)) __builtin_expect (bb.data != 0B, 0))
{
{
void * restrict D.1528;
__builtin_free ((void *) bb.data);
stat.0 = 0;
D.1528 = (void * restrict) __builtin_malloc (4);
if (D.1528 == 0B)
{
stat.0 = 5014;
}
D.1526 = D.1528;
stat.0 = 5014;
}
}
else
{
{
void * restrict D.1527;
stat.0 = 0;
D.1527 = (void * restrict) __builtin_malloc (4);
if (D.1527 == 0B)
{
stat.0 = 5014;
}
D.1526 = D.1527;
}
}
bb.data = D.1526;
}
if (stat.0 != 0) goto L.1;
L.1:;
L.2:;
stat = stat.0;
}
}
finally
{
if (cc != 0B)
{
__builtin_free ((void *) cc);
}
if (bb.data != 0B)
{
__builtin_free ((void *) bb.data);
}
bb.data = 0B;
}
}
main (integer(kind=4) argc, character(kind=1) * * argv)
{
static integer(kind=4) options.1[8] = {68, 1023, 0, 0, 1, 1, 0, 1};
_gfortran_set_args (argc, argv);
_gfortran_set_options (8, &options.1[0]);
test ();
return 0;
}
^ permalink raw reply [flat|nested] 11+ messages in thread
* Re: [Patches, Fortran] ALLOCATE & CAF library.
2011-07-21 11:30 [Patches, Fortran] ALLOCATE & CAF library Daniel Carrera
@ 2011-07-21 12:49 ` Daniel Carrera
2011-07-21 14:50 ` Tobias Burnus
1 sibling, 0 replies; 11+ messages in thread
From: Daniel Carrera @ 2011-07-21 12:49 UTC (permalink / raw)
To: gcc patches, gfortran
[-- Attachment #1: Type: text/plain, Size: 93 bytes --]
I forgot to include an updated ChangeLog (attached).
--
I'm not overweight, I'm undertall.
[-- Attachment #2: ChangeLog --]
[-- Type: text/plain, Size: 1176 bytes --]
2011-07-21 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. Move error checking outside the if (!gfc_array_allocate)
block so that it also affects trees produced by gfc_array_allocate.
* 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.
^ permalink raw reply [flat|nested] 11+ messages in thread
* Re: [Patches, Fortran] ALLOCATE & CAF library.
2011-07-21 11:30 [Patches, Fortran] ALLOCATE & CAF library Daniel Carrera
2011-07-21 12:49 ` Daniel Carrera
@ 2011-07-21 14:50 ` Tobias Burnus
2011-07-21 15:34 ` Daniel Carrera
1 sibling, 1 reply; 11+ messages in thread
From: Tobias Burnus @ 2011-07-21 14:50 UTC (permalink / raw)
To: Daniel Carrera; +Cc: gcc patches, gfortran
On 07/21/2011 01:09 PM, Daniel Carrera wrote:
> This patch now fixes an existing bug in GFortran whereby the ALLOCATE
> statement only gets error checking if you are allocating a scalar.
Somehow that does not seem to work. I just tried a vanilla trunk with
just your patch applied. For the following, I do not get a single
"goto". That's different to your dumps, where you get two (though, in
your case, you had a scalar and a scalar coarray).
integer, allocatable :: A(:), B[:]
integer :: stat
character(len=33) :: str
allocate(A(1), B[*], stat=stat)!, errmsg=str)
end
Thus, I wonder whether you have send the correct patch, if not, the
question is really why we see those large differences.
That also fits with the code:
- if (!gfc_array_allocate (&se, expr, pstat))
+ if (!gfc_array_allocate (&se, expr, stat, errmsg, errlen))
{
...
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);
...
}
Where the code is still in the scalar-allocation loop.
* * *
To the patch itself:
/* Either STAT= and/or ERRMSG is present. */
if (code->expr1 || code->expr2)
> @@ -4709,9 +4712,23 @@ gfc_trans_allocate (gfc_code * code)
> {
> + /* STAT= */
> tree gfc_int4_type_node = gfc_get_int_type (4)
Can you change the "if ()" into "if(code->expr1)", i.e. only checking
whether STAT= is present? There is no point of generating code for
ERRMSG= if STAT= is not present.
Assuming you had: ALLOCATE(A, ERRMSG=str).
a) Everything goes fine. Result: "str" remains unmodified.
b) There is an error: As there is no STAT=, a run-time error is
generated and there is no process left, which an make use of the error
string.
Thus, using "if (code->expr1)" is sufficient.
> + /* 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);
> + }
As said in previous review: Use:
else
{
errmsg = null_pointer_node;
errlen = build_int_cst (gfc_charlen_type_node, 0);
}
That avoids evaluating uselessly build_int_cst, which is cheap but
changing the code comes for free.
> - /* STAT block. */
> - if (code->expr1)
> + /* STAT or ERRMSG. */
> + if (code->expr1 || code->expr2)
I believe here applies the same: The code will be unreachable if there
is no STAT=.
> + /* STAT or ERRMSG. */
> + if (code->expr1 || code->expr2)
Ditto.
Tobias
^ permalink raw reply [flat|nested] 11+ messages in thread
* Re: [Patches, Fortran] ALLOCATE & CAF library.
2011-07-21 14:50 ` Tobias Burnus
@ 2011-07-21 15:34 ` Daniel Carrera
2011-07-21 15:47 ` Tobias Burnus
0 siblings, 1 reply; 11+ messages in thread
From: Daniel Carrera @ 2011-07-21 15:34 UTC (permalink / raw)
To: Tobias Burnus; +Cc: gcc patches, gfortran
[-- Attachment #1: Type: text/plain, Size: 3877 bytes --]
On 07/21/2011 04:19 PM, Tobias Burnus wrote:
> On 07/21/2011 01:09 PM, Daniel Carrera wrote:
>> This patch now fixes an existing bug in GFortran whereby the ALLOCATE
>> statement only gets error checking if you are allocating a scalar.
>
> Somehow that does not seem to work. I just tried a vanilla trunk with
> just your patch applied. For the following, I do not get a single
> "goto". That's different to your dumps, where you get two (though, in
> your case, you had a scalar and a scalar coarray).
>
> integer, allocatable :: A(:), B[:]
> integer :: stat
> character(len=33) :: str
> allocate(A(1), B[*], stat=stat)!, errmsg=str)
> end
>
> Thus, I wonder whether you have send the correct patch, if not, the
> question is really why we see those large differences.
From what you posted, it looks like I sent the wrong patch. I generated
the patch again with a different name just to make sure I'm not mixing
it up (attached).
I tried you code sample and for me it works perfectly:
daniel ~/GCC % cat test2.f90
program test
integer, allocatable :: A(:), B[:]
integer :: stat
character(len=33) :: str
allocate(A(1), B[*], stat=stat)
end program
daniel ~/GCC % mpif90 -fcoarray=lib
-fdump-tree-original test2.f90 mpi.o
The result is attached. You'll find that the gotos are there, just as
they should be:
a.data = 0B;
b.data = 0B;
{
....
if ((logical(kind=4)) __builtin_expect (overflow.1 != 0, 0))
{
stat.0 = 5014;
}
else
{
{
...
a.data = D.1539;
}
}
a.offset = -1;
if (stat.0 != 0) goto L.1;
...
}
b.data = D.1542;
}
if (stat.0 != 0) goto L.2;
L.1:;
L.2:;
stat = stat.0;
> That also fits with the code:
> - if (!gfc_array_allocate (&se, expr, pstat))
> + if (!gfc_array_allocate (&se, expr, stat, errmsg, errlen))
> {
> ...
> 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);
> ...
> }
>
> Where the code is still in the scalar-allocation loop.
That's clearly I wrong... I guess I did send the wrong patch.
> Can you change the "if ()" into "if(code->expr1)", i.e. only checking
> whether STAT= is present? There is no point of generating code for
> ERRMSG= if STAT= is not present.
Ok. The attached patch includes that change (technically I haven't
tested it, but I'll test before committing).
>> + /* 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);
>> + }
>
> As said in previous review: Use:
> else
> {
>
> errmsg = null_pointer_node;
> errlen = build_int_cst (gfc_charlen_type_node, 0);
>
> }
>
>
> That avoids evaluating uselessly build_int_cst, which is cheap but
> changing the code comes for free.
Fixed. Included in the attached patch. Will test before committing.
>> - /* STAT block. */
>> - if (code->expr1)
>> + /* STAT or ERRMSG. */
>> + if (code->expr1 || code->expr2)
>
> I believe here applies the same: The code will be unreachable if there
> is no STAT=.
>
>> + /* STAT or ERRMSG. */
>> + if (code->expr1 || code->expr2)
> Ditto.
Fixed. I also changed the comments to remind ourselves later why we
don't check for ERRMSG.
Cheers,
Daniel.
--
I'm not overweight, I'm undertall.
[-- Attachment #2: test2.f90.003t.original --]
[-- Type: text/plain, Size: 3461 bytes --]
test ()
{
struct array1_integer(kind=4) a;
struct array1_integer(kind=4) b;
integer(kind=4) stat;
try
{
a.data = 0B;
b.data = 0B;
{
integer(kind=4) overflow.1;
integer(kind=4) D.1537;
integer(kind=4) D.1536;
integer(kind=4) stat.0;
a.dtype = 265;
a.dim[0].lbound = 1;
a.dim[0].ubound = 1;
a.dim[0].stride = 1;
D.1536 = (logical(kind=4)) 0 ? 0 : (logical(kind=4)) 0 ? 1 : 0;
D.1537 = ((logical(kind=4)) 0 ? 0 : (logical(kind=4)) 0 ? 1 : 0) + D.1536;
overflow.1 = D.1537;
if ((logical(kind=4)) __builtin_expect (overflow.1 != 0, 0))
{
stat.0 = 5014;
}
else
{
{
void * restrict D.1539;
if ((logical(kind=4)) __builtin_expect (a.data != 0B, 0))
{
{
void * restrict D.1541;
__builtin_free ((void *) a.data);
stat.0 = 0;
D.1541 = (void * restrict) __builtin_malloc (4);
if (D.1541 == 0B)
{
stat.0 = 5014;
}
D.1539 = D.1541;
stat.0 = 5014;
}
}
else
{
{
void * restrict D.1540;
stat.0 = 0;
D.1540 = (void * restrict) __builtin_malloc (4);
if (D.1540 == 0B)
{
stat.0 = 5014;
}
D.1539 = D.1540;
}
}
a.data = D.1539;
}
}
a.offset = -1;
if (stat.0 != 0) goto L.1;
b.dtype = 264;
b.dim[0].lbound = 1;
{
void * restrict D.1542;
if ((logical(kind=4)) __builtin_expect (b.data != 0B, 0))
{
{
void * restrict D.1544;
__builtin_free ((void *) b.data);
stat.0 = 0;
D.1544 = (void * restrict) __builtin_malloc (4);
if (D.1544 == 0B)
{
stat.0 = 5014;
}
D.1542 = D.1544;
stat.0 = 5014;
}
}
else
{
{
void * restrict D.1543;
stat.0 = 0;
D.1543 = (void * restrict) _gfortran_caf_register (4, 1, 0B, &stat.0, 0B, 0);
D.1542 = D.1543;
}
}
b.data = D.1542;
}
if (stat.0 != 0) goto L.2;
L.1:;
L.2:;
stat = stat.0;
}
}
finally
{
if (b.data != 0B)
{
__builtin_free ((void *) b.data);
}
b.data = 0B;
if (a.data != 0B)
{
__builtin_free ((void *) a.data);
}
a.data = 0B;
}
}
main (integer(kind=4) argc, character(kind=1) * * argv)
{
static integer(kind=4) options.2[8] = {68, 1023, 0, 0, 1, 1, 0, 1};
_gfortran_caf_init (&argc, &argv, &_gfortran_caf_this_image, &_gfortran_caf_num_images);
_gfortran_set_args (argc, argv);
_gfortran_set_options (8, &options.2[0]);
test ();
__sync_synchronize ();
_gfortran_caf_finalize ();
return 0;
}
[-- Attachment #3: again-allocate.diff --]
[-- Type: text/x-patch, Size: 18167 bytes --]
Index: gcc/fortran/trans-array.c
===================================================================
--- gcc/fortran/trans-array.c (revision 176528)
+++ gcc/fortran/trans-array.c (working copy)
@@ -4384,3 +4384,4 @@ gfc_array_init_size (tree descriptor, in
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)
{
@@ -4479,18 +4480,11 @@ gfc_array_allocate (gfc_se * se, gfc_exp
- if (pstat != NULL_TREE && !integer_zerop (pstat))
- {
- /* Set the status variable if it's present. */
+ if (status != NULL_TREE)
+ {
+ 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);
}
@@ -4503,10 +4497,11 @@ gfc_array_allocate (gfc_se * se, gfc_exp
- /* 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);
Index: gcc/fortran/trans-array.h
===================================================================
--- gcc/fortran/trans-array.h (revision 176528)
+++ gcc/fortran/trans-array.h (working copy)
@@ -26,3 +26,3 @@ tree gfc_array_deallocate (tree, tree, g
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);
Index: gcc/fortran/trans-openmp.c
===================================================================
--- gcc/fortran/trans-openmp.c (revision 176528)
+++ gcc/fortran/trans-openmp.c (working copy)
@@ -190,5 +190,5 @@ gfc_omp_clause_default_ctor (tree clause
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);
@@ -243,5 +243,5 @@ gfc_omp_clause_copy_ctor (tree clause, t
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);
@@ -665,5 +665,5 @@ gfc_trans_omp_array_reduction (tree c, g
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);
Index: gcc/fortran/trans-stmt.c
===================================================================
--- gcc/fortran/trans-stmt.c (revision 176528)
+++ gcc/fortran/trans-stmt.c (working copy)
@@ -4688,4 +4688,6 @@ gfc_trans_allocate (gfc_code * code)
tree stat;
- tree pstat;
- tree error_label;
+ tree errmsg;
+ tree errlen;
+ tree label_errmsg;
+ tree label_finish;
tree memsz;
@@ -4701,3 +4703,4 @@ gfc_trans_allocate (gfc_code * code)
- pstat = stat = error_label = tmp = memsz = NULL_TREE;
+ stat = tmp = memsz = NULL_TREE;
+ label_errmsg = label_finish = errmsg = errlen = NULL_TREE;
@@ -4709,9 +4712,23 @@ gfc_trans_allocate (gfc_code * code)
{
+ /* 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;
}
@@ -4734,3 +4751,3 @@ gfc_trans_allocate (gfc_code * code)
- if (!gfc_array_allocate (&se, expr, pstat))
+ if (!gfc_array_allocate (&se, expr, stat, errmsg, errlen))
{
@@ -4849,6 +4866,6 @@ gfc_trans_allocate (gfc_code * code)
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);
@@ -4861,3 +4878,9 @@ gfc_trans_allocate (gfc_code * code)
{
- 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,
@@ -5007,12 +5030,7 @@ 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);
}
@@ -5024,3 +5042,3 @@ gfc_trans_allocate (gfc_code * code)
const char *msg = "Attempt to allocate an allocated object";
- tree errmsg, slen, dlen;
+ tree slen, dlen;
@@ -5052,2 +5070,18 @@ gfc_trans_allocate (gfc_code * code)
+ /* 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);
Index: gcc/fortran/trans.c
===================================================================
--- gcc/fortran/trans.c (revision 176528)
+++ gcc/fortran/trans.c (working copy)
@@ -567,3 +567,3 @@ gfc_call_malloc (stmtblock_t * block, tr
void *
- allocate (size_t size, integer_type* stat)
+ allocate (size_t size, integer_type stat)
{
@@ -571,4 +571,4 @@ gfc_call_malloc (stmtblock_t * block, tr
- if (stat)
- *stat = 0;
+ if (stat requested)
+ stat = 0;
@@ -585,8 +585,7 @@ gfc_call_malloc (stmtblock_t * block, tr
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;
@@ -601,15 +600,6 @@ gfc_allocate_with_status (stmtblock_t *
/* 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)));
@@ -617,48 +607,19 @@ gfc_allocate_with_status (stmtblock_t *
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")));
@@ -668,3 +629,4 @@ gfc_allocate_with_status (stmtblock_t *
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);
@@ -676,2 +638,72 @@ 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
@@ -683,3 +715,3 @@ gfc_allocate_with_status (stmtblock_t *
void *
- allocate_allocatable (void *mem, size_t size, integer_type *stat)
+ allocate_allocatable (void *mem, size_t size, integer_type stat)
{
@@ -693,3 +725,3 @@ gfc_allocate_with_status (stmtblock_t *
mem = allocate (size, stat);
- *stat = LIBERROR_ALLOCATION;
+ stat = LIBERROR_ALLOCATION;
return mem;
@@ -704,4 +736,4 @@ gfc_allocate_with_status (stmtblock_t *
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)
{
@@ -720,7 +752,12 @@ gfc_allocate_allocatable_with_status (st
- /* 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);
@@ -749,5 +786,5 @@ gfc_allocate_allocatable_with_status (st
- 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;
@@ -760,14 +797,8 @@ gfc_allocate_allocatable_with_status (st
- 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);
}
Index: gcc/fortran/trans.h
===================================================================
--- gcc/fortran/trans.h (revision 176528)
+++ gcc/fortran/trans.h (working copy)
@@ -543,7 +543,8 @@ tree gfc_build_memcpy_call (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);
^ permalink raw reply [flat|nested] 11+ messages in thread
* Re: [Patches, Fortran] ALLOCATE & CAF library.
2011-07-21 15:34 ` Daniel Carrera
@ 2011-07-21 15:47 ` Tobias Burnus
2011-07-21 16:16 ` Daniel Carrera
0 siblings, 1 reply; 11+ messages in thread
From: Tobias Burnus @ 2011-07-21 15:47 UTC (permalink / raw)
To: Daniel Carrera; +Cc: gcc patches, gfortran
On 07/21/2011 05:20 PM, Daniel Carrera wrote:
> From what you posted, it looks like I sent the wrong patch. I
> generated the patch again with a different name just to make sure I'm
> not mixing it up (attached).
The patch is identical to the previous one. I wonder what goes wrong,
but it applies cleanly to the trunk and indeed looks as if the goto is
in the wrong part. I only see GOTO_EXPR at:
+ if (!gfc_array_allocate (&se, expr, stat, errmsg, errlen))
{
...
@@ -4861,3 +4878,9 @@ gfc_trans_allocate (gfc_code * code)
...
+ 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);
And also the indention indicates that it is still in the
"!gfc_array_allocate" branch.
> Ok. The attached patch includes that change (technically I haven't
> tested it, but I'll test before committing).
I think something goes seriously wrong with diffing: As the patch is
identically, it is not included.
I do not know mercury, but "git" distinguishes between a modification
which is just in the directory and can be shown with "git diff" - and
one which has been staged with "git add" and shown with "git diff
--cached". (And those patches committed locally via "git commit".)
I wouldn't be surprised if mercury does something similar.
Tobias
^ permalink raw reply [flat|nested] 11+ messages in thread
* Re: [Patches, Fortran] ALLOCATE & CAF library.
2011-07-21 15:47 ` Tobias Burnus
@ 2011-07-21 16:16 ` Daniel Carrera
2011-07-21 17:10 ` Tobias Burnus
0 siblings, 1 reply; 11+ messages in thread
From: Daniel Carrera @ 2011-07-21 16:16 UTC (permalink / raw)
To: Tobias Burnus; +Cc: gcc patches, gfortran
[-- Attachment #1: Type: text/plain, Size: 1230 bytes --]
On 07/21/2011 05:36 PM, Tobias Burnus wrote:
> The patch is identical to the previous one. I wonder what goes wrong,
...
I was using Mercurial wrong. I've been experimenting with using
Mercurial to work with GCC and was doing the diff wrong. The attached
file should be correct (fingers crossed).
> I think something goes seriously wrong with diffing: As the patch is
> identically, it is not included.
>
> I do not know mercury, but "git" distinguishes between a modification
> which is just in the directory and can be shown with "git diff" - and
> one which has been staged with "git add" and shown with "git diff
> --cached". (And those patches committed locally via "git commit".)
>
> I wouldn't be surprised if mercury does something similar.
Sort of.
I'm using the Mercurial-SVN bridge. I thought "hg diff --svn" was just
to get SVN-like formatting, but what it really does is it compares your
most recently saved changes against the SVN parent. That's actually very
useful, but I didn't know I had to save before doing the diff. So I kept
making a diff against the work I saved on Sunday. Now that I saved, "hg
diff --svn" seems to do the right thing.
Cheers,
Daniel.
--
I'm not overweight, I'm undertall.
[-- Attachment #2: allocate.diff --]
[-- Type: text/x-patch, Size: 19283 bytes --]
Index: gcc/fortran/trans-array.c
===================================================================
--- gcc/fortran/trans-array.c (revision 176528)
+++ gcc/fortran/trans-array.c (working copy)
@@ -4384,3 +4384,4 @@ gfc_array_init_size (tree descriptor, in
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)
{
@@ -4479,18 +4480,11 @@ gfc_array_allocate (gfc_se * se, gfc_exp
- if (pstat != NULL_TREE && !integer_zerop (pstat))
- {
- /* Set the status variable if it's present. */
+ if (status != NULL_TREE)
+ {
+ 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);
}
@@ -4503,10 +4497,11 @@ gfc_array_allocate (gfc_se * se, gfc_exp
- /* 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);
Index: gcc/fortran/trans-array.h
===================================================================
--- gcc/fortran/trans-array.h (revision 176528)
+++ gcc/fortran/trans-array.h (working copy)
@@ -26,3 +26,3 @@ tree gfc_array_deallocate (tree, tree, g
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);
Index: gcc/fortran/trans-openmp.c
===================================================================
--- gcc/fortran/trans-openmp.c (revision 176528)
+++ gcc/fortran/trans-openmp.c (working copy)
@@ -190,5 +190,5 @@ gfc_omp_clause_default_ctor (tree clause
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);
@@ -243,5 +243,5 @@ gfc_omp_clause_copy_ctor (tree clause, t
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);
@@ -665,5 +665,5 @@ gfc_trans_omp_array_reduction (tree c, g
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);
Index: gcc/fortran/trans-stmt.c
===================================================================
--- gcc/fortran/trans-stmt.c (revision 176528)
+++ gcc/fortran/trans-stmt.c (working copy)
@@ -4688,4 +4688,6 @@ gfc_trans_allocate (gfc_code * code)
tree stat;
- tree pstat;
- tree error_label;
+ tree errmsg;
+ tree errlen;
+ tree label_errmsg;
+ tree label_finish;
tree memsz;
@@ -4701,3 +4703,4 @@ gfc_trans_allocate (gfc_code * code)
- pstat = stat = error_label = tmp = memsz = NULL_TREE;
+ stat = tmp = memsz = NULL_TREE;
+ label_errmsg = label_finish = errmsg = errlen = NULL_TREE;
@@ -4706,12 +4709,29 @@ gfc_trans_allocate (gfc_code * code)
- /* Either STAT= and/or ERRMSG is present. */
- if (code->expr1 || code->expr2)
+ /* STAT= (and maybe ERRMSG=) is present. */
+ if (code->expr1)
{
+ /* 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= only makes sense with STAT= . */
+ 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);
+ }
+ else
+ {
+ errmsg = null_pointer_node;
+ errlen = build_int_cst (gfc_charlen_type_node, 0);
+ }
+
+ /* 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;
}
@@ -4734,3 +4754,3 @@ gfc_trans_allocate (gfc_code * code)
- if (!gfc_array_allocate (&se, expr, pstat))
+ if (!gfc_array_allocate (&se, expr, stat, errmsg, errlen))
{
@@ -4849,6 +4869,6 @@ gfc_trans_allocate (gfc_code * code)
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);
@@ -4859,14 +4879,2 @@ gfc_trans_allocate (gfc_code * code)
- if (code->expr1 || code->expr2)
- {
- tmp = build1_v (GOTO_EXPR, error_label);
- parm = fold_build2_loc (input_location, NE_EXPR,
- boolean_type_node, stat,
- build_int_cst (TREE_TYPE (stat), 0));
- tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
- parm, tmp,
- build_empty_stmt (input_location));
- gfc_add_expr_to_block (&se.pre, tmp);
- }
-
if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->attr.alloc_comp)
@@ -4881,2 +4889,21 @@ gfc_trans_allocate (gfc_code * code)
+ /* Error checking -- Note: ERRMS only makes sense with STAT. */
+ 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);
+
+ parm = fold_build2_loc (input_location, NE_EXPR,
+ boolean_type_node, stat,
+ build_int_cst (TREE_TYPE (stat), 0));
+ tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
+ parm, tmp,
+ build_empty_stmt (input_location));
+ gfc_add_expr_to_block (&block, tmp);
+ }
+
if (code->expr3 && !code->expr3->mold)
@@ -5007,12 +5034,7 @@ gfc_trans_allocate (gfc_code * code)
- /* STAT block. */
+ /* STAT (ERRMSG only makes sense with STAT). */
if (code->expr1)
{
- 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);
}
@@ -5024,3 +5046,3 @@ gfc_trans_allocate (gfc_code * code)
const char *msg = "Attempt to allocate an allocated object";
- tree errmsg, slen, dlen;
+ tree slen, dlen;
@@ -5052,2 +5074,18 @@ gfc_trans_allocate (gfc_code * code)
+ /* STAT (ERRMSG only makes sense with STAT). */
+ if (code->expr1)
+ {
+ 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);
Index: gcc/fortran/trans.c
===================================================================
--- gcc/fortran/trans.c (revision 176528)
+++ gcc/fortran/trans.c (working copy)
@@ -567,3 +567,3 @@ gfc_call_malloc (stmtblock_t * block, tr
void *
- allocate (size_t size, integer_type* stat)
+ allocate (size_t size, integer_type stat)
{
@@ -571,4 +571,4 @@ gfc_call_malloc (stmtblock_t * block, tr
- if (stat)
- *stat = 0;
+ if (stat requested)
+ stat = 0;
@@ -585,8 +585,7 @@ gfc_call_malloc (stmtblock_t * block, tr
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;
@@ -601,15 +600,6 @@ gfc_allocate_with_status (stmtblock_t *
/* 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)));
@@ -617,48 +607,19 @@ gfc_allocate_with_status (stmtblock_t *
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")));
@@ -668,3 +629,4 @@ gfc_allocate_with_status (stmtblock_t *
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);
@@ -676,2 +638,72 @@ 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
@@ -683,3 +715,3 @@ gfc_allocate_with_status (stmtblock_t *
void *
- allocate_allocatable (void *mem, size_t size, integer_type *stat)
+ allocate_allocatable (void *mem, size_t size, integer_type stat)
{
@@ -693,3 +725,3 @@ gfc_allocate_with_status (stmtblock_t *
mem = allocate (size, stat);
- *stat = LIBERROR_ALLOCATION;
+ stat = LIBERROR_ALLOCATION;
return mem;
@@ -704,4 +736,4 @@ gfc_allocate_with_status (stmtblock_t *
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)
{
@@ -720,7 +752,12 @@ gfc_allocate_allocatable_with_status (st
- /* 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);
@@ -749,5 +786,5 @@ gfc_allocate_allocatable_with_status (st
- 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;
@@ -760,14 +797,8 @@ gfc_allocate_allocatable_with_status (st
- 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);
}
Index: gcc/fortran/trans.h
===================================================================
--- gcc/fortran/trans.h (revision 176528)
+++ gcc/fortran/trans.h (working copy)
@@ -543,7 +543,8 @@ tree gfc_build_memcpy_call (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);
^ permalink raw reply [flat|nested] 11+ messages in thread
* Re: [Patches, Fortran] ALLOCATE & CAF library.
2011-07-21 16:16 ` Daniel Carrera
@ 2011-07-21 17:10 ` Tobias Burnus
2011-07-21 17:13 ` Daniel Carrera
0 siblings, 1 reply; 11+ messages in thread
From: Tobias Burnus @ 2011-07-21 17:10 UTC (permalink / raw)
To: Daniel Carrera; +Cc: gcc patches, gfortran
On 07/21/2011 06:01 PM, Daniel Carrera wrote:
> I was using Mercurial wrong. I've been experimenting with using
> Mercurial to work with GCC and was doing the diff wrong. The attached
> file should be correct (fingers crossed).
Looks better :-)
The patch is OK after regtesting and fixing the following nits.
Changelog from http://gcc.gnu.org/ml/fortran/2011-07/txt00008.txt:
> * trans.c (gfc_allocate_with_status): Split into two functions
> gfc_allocate_using_malloc ad gfc_allocate_usig_lib.
Typo: "and" and "gfc_allocate_using_lib" (usig->using).
> @@ -4881,2 +4889,21 @@ gfc_trans_allocate (gfc_code * code)
>
> + /* Error checking -- Note: ERRMS only makes sense with STAT. */
Typo: ERRMSG.
> @@ -676,2 +638,72 @@ 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;
No need to set "stat = 0". caf_registering always sets stat (if present).
> + newmem = _caf_register ( size, regtype, NULL,&stat, NULL, NULL);
> + if (newmem == NULL)
> + {
> + if (!stat requested)
> + runtime_error ("Allocation would exceed memory limit");
> + }
Remove the if block - it's not in the actual code and the library
function already aborts.
> + 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)));
As written above - just for the actual code.
Tobias
^ permalink raw reply [flat|nested] 11+ messages in thread
* Re: [Patches, Fortran] ALLOCATE & CAF library.
2011-07-21 17:10 ` Tobias Burnus
@ 2011-07-21 17:13 ` Daniel Carrera
2011-07-21 17:39 ` Tobias Burnus
0 siblings, 1 reply; 11+ messages in thread
From: Daniel Carrera @ 2011-07-21 17:13 UTC (permalink / raw)
To: Tobias Burnus; +Cc: gcc patches, gfortran
[-- Attachment #1: Type: text/plain, Size: 2516 bytes --]
Ok. Updated patch and updated ChangeLog attached. Compiles fine and I'm
about to start running the test suite again.
Cheers,
Daniel.
On 07/21/2011 06:37 PM, Tobias Burnus wrote:
> On 07/21/2011 06:01 PM, Daniel Carrera wrote:
>> I was using Mercurial wrong. I've been experimenting with using
>> Mercurial to work with GCC and was doing the diff wrong. The attached
>> file should be correct (fingers crossed).
>
> Looks better :-)
>
> The patch is OK after regtesting and fixing the following nits.
>
> Changelog from http://gcc.gnu.org/ml/fortran/2011-07/txt00008.txt:
>> * trans.c (gfc_allocate_with_status): Split into two functions
>> gfc_allocate_using_malloc ad gfc_allocate_usig_lib.
>
> Typo: "and" and "gfc_allocate_using_lib" (usig->using).
>
>> @@ -4881,2 +4889,21 @@ gfc_trans_allocate (gfc_code * code)
>>
>> + /* Error checking -- Note: ERRMS only makes sense with STAT. */
>
> Typo: ERRMSG.
>
>> @@ -676,2 +638,72 @@ 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;
>
> No need to set "stat = 0". caf_registering always sets stat (if present).
>
>> + newmem = _caf_register ( size, regtype, NULL,&stat, NULL, NULL);
>> + if (newmem == NULL)
>> + {
>> + if (!stat requested)
>> + runtime_error ("Allocation would exceed memory limit");
>> + }
>
> Remove the if block - it's not in the actual code and the library
> function already aborts.
>
>> + 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)));
>
> As written above - just for the actual code.
>
>
> Tobias
--
I'm not overweight, I'm undertall.
[-- Attachment #2: allocate.diff --]
[-- Type: text/x-patch, Size: 18871 bytes --]
Index: gcc/fortran/trans-array.c
===================================================================
--- gcc/fortran/trans-array.c (revision 176528)
+++ gcc/fortran/trans-array.c (working copy)
@@ -4384,3 +4384,4 @@ gfc_array_init_size (tree descriptor, in
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)
{
@@ -4479,18 +4480,11 @@ gfc_array_allocate (gfc_se * se, gfc_exp
- if (pstat != NULL_TREE && !integer_zerop (pstat))
- {
- /* Set the status variable if it's present. */
+ if (status != NULL_TREE)
+ {
+ 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);
}
@@ -4503,10 +4497,11 @@ gfc_array_allocate (gfc_se * se, gfc_exp
- /* 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);
Index: gcc/fortran/trans-array.h
===================================================================
--- gcc/fortran/trans-array.h (revision 176528)
+++ gcc/fortran/trans-array.h (working copy)
@@ -26,3 +26,3 @@ tree gfc_array_deallocate (tree, tree, g
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);
Index: gcc/fortran/trans-openmp.c
===================================================================
--- gcc/fortran/trans-openmp.c (revision 176528)
+++ gcc/fortran/trans-openmp.c (working copy)
@@ -190,5 +190,5 @@ gfc_omp_clause_default_ctor (tree clause
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);
@@ -243,5 +243,5 @@ gfc_omp_clause_copy_ctor (tree clause, t
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);
@@ -665,5 +665,5 @@ gfc_trans_omp_array_reduction (tree c, g
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);
Index: gcc/fortran/trans-stmt.c
===================================================================
--- gcc/fortran/trans-stmt.c (revision 176528)
+++ gcc/fortran/trans-stmt.c (working copy)
@@ -4688,4 +4688,6 @@ gfc_trans_allocate (gfc_code * code)
tree stat;
- tree pstat;
- tree error_label;
+ tree errmsg;
+ tree errlen;
+ tree label_errmsg;
+ tree label_finish;
tree memsz;
@@ -4701,3 +4703,4 @@ gfc_trans_allocate (gfc_code * code)
- pstat = stat = error_label = tmp = memsz = NULL_TREE;
+ stat = tmp = memsz = NULL_TREE;
+ label_errmsg = label_finish = errmsg = errlen = NULL_TREE;
@@ -4706,12 +4709,29 @@ gfc_trans_allocate (gfc_code * code)
- /* Either STAT= and/or ERRMSG is present. */
- if (code->expr1 || code->expr2)
+ /* STAT= (and maybe ERRMSG=) is present. */
+ if (code->expr1)
{
+ /* 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= only makes sense with STAT=. */
+ 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);
+ }
+ else
+ {
+ errmsg = null_pointer_node;
+ errlen = build_int_cst (gfc_charlen_type_node, 0);
+ }
+
+ /* 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;
}
@@ -4734,3 +4754,3 @@ gfc_trans_allocate (gfc_code * code)
- if (!gfc_array_allocate (&se, expr, pstat))
+ if (!gfc_array_allocate (&se, expr, stat, errmsg, errlen))
{
@@ -4849,6 +4869,6 @@ gfc_trans_allocate (gfc_code * code)
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);
@@ -4859,14 +4879,2 @@ gfc_trans_allocate (gfc_code * code)
- if (code->expr1 || code->expr2)
- {
- tmp = build1_v (GOTO_EXPR, error_label);
- parm = fold_build2_loc (input_location, NE_EXPR,
- boolean_type_node, stat,
- build_int_cst (TREE_TYPE (stat), 0));
- tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
- parm, tmp,
- build_empty_stmt (input_location));
- gfc_add_expr_to_block (&se.pre, tmp);
- }
-
if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->attr.alloc_comp)
@@ -4881,2 +4889,21 @@ gfc_trans_allocate (gfc_code * code)
+ /* Error checking -- Note: ERRMSG only makes sense with STAT. */
+ 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);
+
+ parm = fold_build2_loc (input_location, NE_EXPR,
+ boolean_type_node, stat,
+ build_int_cst (TREE_TYPE (stat), 0));
+ tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
+ parm, tmp,
+ build_empty_stmt (input_location));
+ gfc_add_expr_to_block (&block, tmp);
+ }
+
if (code->expr3 && !code->expr3->mold)
@@ -5007,12 +5034,7 @@ gfc_trans_allocate (gfc_code * code)
- /* STAT block. */
+ /* STAT (ERRMSG only makes sense with STAT). */
if (code->expr1)
{
- 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);
}
@@ -5024,3 +5046,3 @@ gfc_trans_allocate (gfc_code * code)
const char *msg = "Attempt to allocate an allocated object";
- tree errmsg, slen, dlen;
+ tree slen, dlen;
@@ -5052,2 +5074,18 @@ gfc_trans_allocate (gfc_code * code)
+ /* STAT (ERRMSG only makes sense with STAT). */
+ if (code->expr1)
+ {
+ 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);
Index: gcc/fortran/trans.c
===================================================================
--- gcc/fortran/trans.c (revision 176528)
+++ gcc/fortran/trans.c (working copy)
@@ -567,3 +567,3 @@ gfc_call_malloc (stmtblock_t * block, tr
void *
- allocate (size_t size, integer_type* stat)
+ allocate (size_t size, integer_type stat)
{
@@ -571,4 +571,4 @@ gfc_call_malloc (stmtblock_t * block, tr
- if (stat)
- *stat = 0;
+ if (stat requested)
+ stat = 0;
@@ -585,8 +585,7 @@ gfc_call_malloc (stmtblock_t * block, tr
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;
@@ -601,15 +600,6 @@ gfc_allocate_with_status (stmtblock_t *
/* 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)));
@@ -617,48 +607,19 @@ gfc_allocate_with_status (stmtblock_t *
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")));
@@ -668,3 +629,4 @@ gfc_allocate_with_status (stmtblock_t *
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);
@@ -676,2 +638,58 @@ 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;
+
+ newmem = _caf_register ( size, regtype, NULL, &stat, NULL, NULL);
+ 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);
+
+ /* 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
@@ -683,3 +701,3 @@ gfc_allocate_with_status (stmtblock_t *
void *
- allocate_allocatable (void *mem, size_t size, integer_type *stat)
+ allocate_allocatable (void *mem, size_t size, integer_type stat)
{
@@ -693,3 +711,3 @@ gfc_allocate_with_status (stmtblock_t *
mem = allocate (size, stat);
- *stat = LIBERROR_ALLOCATION;
+ stat = LIBERROR_ALLOCATION;
return mem;
@@ -704,4 +722,4 @@ gfc_allocate_with_status (stmtblock_t *
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)
{
@@ -720,7 +738,12 @@ gfc_allocate_allocatable_with_status (st
- /* 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);
@@ -749,5 +772,5 @@ gfc_allocate_allocatable_with_status (st
- 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;
@@ -760,14 +783,8 @@ gfc_allocate_allocatable_with_status (st
- 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);
}
Index: gcc/fortran/trans.h
===================================================================
--- gcc/fortran/trans.h (revision 176528)
+++ gcc/fortran/trans.h (working copy)
@@ -543,7 +543,8 @@ tree gfc_build_memcpy_call (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);
[-- Attachment #3: ChangeLog --]
[-- Type: text/plain, Size: 1177 bytes --]
2011-07-21 Daniel Carrera <dcarrera@gmail.com>
* trans.c (gfc_allocate_with_status): Split into two functions
gfc_allocate_using_malloc and 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. Move error checking outside the if (!gfc_array_allocate)
block so that it also affects trees produced by gfc_array_allocate.
* 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.
^ permalink raw reply [flat|nested] 11+ messages in thread
* Re: [Patches, Fortran] ALLOCATE & CAF library.
2011-07-21 17:13 ` Daniel Carrera
@ 2011-07-21 17:39 ` Tobias Burnus
2011-07-21 19:35 ` Daniel Carrera
0 siblings, 1 reply; 11+ messages in thread
From: Tobias Burnus @ 2011-07-21 17:39 UTC (permalink / raw)
To: Daniel Carrera; +Cc: gcc patches, gfortran
On 07/21/2011 06:46 PM, Daniel Carrera wrote:
> Ok. Updated patch and updated ChangeLog attached. Compiles fine and
> I'm about to start running the test suite again.
Doesn't compile here:
gcc/fortran/trans.c: In function 'tree_node*
gfc_allocate_using_lib(stmtblock_t*, tree, tree, tree, tree)':
gcc/fortran/trans.c:656:8: error: unused variable 'status_type'
[-Werror=unused-variable]
Please fix before committal.
Thanks,
Tobias
^ permalink raw reply [flat|nested] 11+ messages in thread
* Re: [Patches, Fortran] ALLOCATE & CAF library.
2011-07-21 17:39 ` Tobias Burnus
@ 2011-07-21 19:35 ` Daniel Carrera
2011-07-21 21:30 ` Tobias Burnus
0 siblings, 1 reply; 11+ messages in thread
From: Daniel Carrera @ 2011-07-21 19:35 UTC (permalink / raw)
To: Tobias Burnus; +Cc: gcc patches, gfortran
[-- Attachment #1: Type: text/plain, Size: 757 bytes --]
On 07/21/2011 07:22 PM, Tobias Burnus wrote:
> On 07/21/2011 06:46 PM, Daniel Carrera wrote:
>> Ok. Updated patch and updated ChangeLog attached. Compiles fine and
>> I'm about to start running the test suite again.
>
> Doesn't compile here:
>
> gcc/fortran/trans.c: In function 'tree_node*
> gfc_allocate_using_lib(stmtblock_t*, tree, tree, tree, tree)':
> gcc/fortran/trans.c:656:8: error: unused variable 'status_type'
> [-Werror=unused-variable]
>
> Please fix before committal.
Hmm... I really wish that my Makefile was as picky as yours. But last
time I tried to change my configure flag everything went crazy.
The attached file contains the fix. I won't commit until I get a "ok"
from you.
Cheers,
Daniel.
--
I'm not overweight, I'm undertall.
[-- Attachment #2: allocate.diff --]
[-- Type: text/x-patch, Size: 18808 bytes --]
Index: gcc/fortran/trans-array.c
===================================================================
--- gcc/fortran/trans-array.c (revision 176528)
+++ gcc/fortran/trans-array.c (working copy)
@@ -4384,3 +4384,4 @@ gfc_array_init_size (tree descriptor, in
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)
{
@@ -4479,18 +4480,11 @@ gfc_array_allocate (gfc_se * se, gfc_exp
- if (pstat != NULL_TREE && !integer_zerop (pstat))
- {
- /* Set the status variable if it's present. */
+ if (status != NULL_TREE)
+ {
+ 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);
}
@@ -4503,10 +4497,11 @@ gfc_array_allocate (gfc_se * se, gfc_exp
- /* 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);
Index: gcc/fortran/trans-array.h
===================================================================
--- gcc/fortran/trans-array.h (revision 176528)
+++ gcc/fortran/trans-array.h (working copy)
@@ -26,3 +26,3 @@ tree gfc_array_deallocate (tree, tree, g
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);
Index: gcc/fortran/trans-openmp.c
===================================================================
--- gcc/fortran/trans-openmp.c (revision 176528)
+++ gcc/fortran/trans-openmp.c (working copy)
@@ -190,5 +190,5 @@ gfc_omp_clause_default_ctor (tree clause
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);
@@ -243,5 +243,5 @@ gfc_omp_clause_copy_ctor (tree clause, t
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);
@@ -665,5 +665,5 @@ gfc_trans_omp_array_reduction (tree c, g
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);
Index: gcc/fortran/trans-stmt.c
===================================================================
--- gcc/fortran/trans-stmt.c (revision 176528)
+++ gcc/fortran/trans-stmt.c (working copy)
@@ -4688,4 +4688,6 @@ gfc_trans_allocate (gfc_code * code)
tree stat;
- tree pstat;
- tree error_label;
+ tree errmsg;
+ tree errlen;
+ tree label_errmsg;
+ tree label_finish;
tree memsz;
@@ -4701,3 +4703,4 @@ gfc_trans_allocate (gfc_code * code)
- pstat = stat = error_label = tmp = memsz = NULL_TREE;
+ stat = tmp = memsz = NULL_TREE;
+ label_errmsg = label_finish = errmsg = errlen = NULL_TREE;
@@ -4706,12 +4709,29 @@ gfc_trans_allocate (gfc_code * code)
- /* Either STAT= and/or ERRMSG is present. */
- if (code->expr1 || code->expr2)
+ /* STAT= (and maybe ERRMSG=) is present. */
+ if (code->expr1)
{
+ /* 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= only makes sense with STAT=. */
+ 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);
+ }
+ else
+ {
+ errmsg = null_pointer_node;
+ errlen = build_int_cst (gfc_charlen_type_node, 0);
+ }
+
+ /* 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;
}
@@ -4734,3 +4754,3 @@ gfc_trans_allocate (gfc_code * code)
- if (!gfc_array_allocate (&se, expr, pstat))
+ if (!gfc_array_allocate (&se, expr, stat, errmsg, errlen))
{
@@ -4849,6 +4869,6 @@ gfc_trans_allocate (gfc_code * code)
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);
@@ -4859,14 +4879,2 @@ gfc_trans_allocate (gfc_code * code)
- if (code->expr1 || code->expr2)
- {
- tmp = build1_v (GOTO_EXPR, error_label);
- parm = fold_build2_loc (input_location, NE_EXPR,
- boolean_type_node, stat,
- build_int_cst (TREE_TYPE (stat), 0));
- tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
- parm, tmp,
- build_empty_stmt (input_location));
- gfc_add_expr_to_block (&se.pre, tmp);
- }
-
if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->attr.alloc_comp)
@@ -4881,2 +4889,21 @@ gfc_trans_allocate (gfc_code * code)
+ /* Error checking -- Note: ERRMSG only makes sense with STAT. */
+ 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);
+
+ parm = fold_build2_loc (input_location, NE_EXPR,
+ boolean_type_node, stat,
+ build_int_cst (TREE_TYPE (stat), 0));
+ tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
+ parm, tmp,
+ build_empty_stmt (input_location));
+ gfc_add_expr_to_block (&block, tmp);
+ }
+
if (code->expr3 && !code->expr3->mold)
@@ -5007,12 +5034,7 @@ gfc_trans_allocate (gfc_code * code)
- /* STAT block. */
+ /* STAT (ERRMSG only makes sense with STAT). */
if (code->expr1)
{
- 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);
}
@@ -5024,3 +5046,3 @@ gfc_trans_allocate (gfc_code * code)
const char *msg = "Attempt to allocate an allocated object";
- tree errmsg, slen, dlen;
+ tree slen, dlen;
@@ -5052,2 +5074,18 @@ gfc_trans_allocate (gfc_code * code)
+ /* STAT (ERRMSG only makes sense with STAT). */
+ if (code->expr1)
+ {
+ 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);
Index: gcc/fortran/trans.c
===================================================================
--- gcc/fortran/trans.c (revision 176528)
+++ gcc/fortran/trans.c (working copy)
@@ -567,3 +567,3 @@ gfc_call_malloc (stmtblock_t * block, tr
void *
- allocate (size_t size, integer_type* stat)
+ allocate (size_t size, integer_type stat)
{
@@ -571,4 +571,4 @@ gfc_call_malloc (stmtblock_t * block, tr
- if (stat)
- *stat = 0;
+ if (stat requested)
+ stat = 0;
@@ -585,8 +585,7 @@ gfc_call_malloc (stmtblock_t * block, tr
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;
@@ -601,15 +600,6 @@ gfc_allocate_with_status (stmtblock_t *
/* 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)));
@@ -617,48 +607,19 @@ gfc_allocate_with_status (stmtblock_t *
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")));
@@ -668,3 +629,4 @@ gfc_allocate_with_status (stmtblock_t *
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);
@@ -676,2 +638,57 @@ 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;
+
+ newmem = _caf_register ( size, regtype, NULL, &stat, NULL, NULL);
+ return newmem;
+ } */
+tree
+gfc_allocate_using_lib (stmtblock_t * block, tree size, tree status,
+ tree errmsg, tree errlen)
+{
+ tree res, pstat;
+
+ /* 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);
+
+ /* 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
@@ -683,3 +700,3 @@ gfc_allocate_with_status (stmtblock_t *
void *
- allocate_allocatable (void *mem, size_t size, integer_type *stat)
+ allocate_allocatable (void *mem, size_t size, integer_type stat)
{
@@ -693,3 +710,3 @@ gfc_allocate_with_status (stmtblock_t *
mem = allocate (size, stat);
- *stat = LIBERROR_ALLOCATION;
+ stat = LIBERROR_ALLOCATION;
return mem;
@@ -704,4 +721,4 @@ gfc_allocate_with_status (stmtblock_t *
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)
{
@@ -720,7 +737,12 @@ gfc_allocate_allocatable_with_status (st
- /* 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);
@@ -749,5 +771,5 @@ gfc_allocate_allocatable_with_status (st
- 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;
@@ -760,14 +782,8 @@ gfc_allocate_allocatable_with_status (st
- 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);
}
Index: gcc/fortran/trans.h
===================================================================
--- gcc/fortran/trans.h (revision 176528)
+++ gcc/fortran/trans.h (working copy)
@@ -543,7 +543,8 @@ tree gfc_build_memcpy_call (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);
^ permalink raw reply [flat|nested] 11+ messages in thread
* Re: [Patches, Fortran] ALLOCATE & CAF library.
2011-07-21 19:35 ` Daniel Carrera
@ 2011-07-21 21:30 ` Tobias Burnus
0 siblings, 0 replies; 11+ messages in thread
From: Tobias Burnus @ 2011-07-21 21:30 UTC (permalink / raw)
To: Daniel Carrera; +Cc: gcc patches, gfortran
Daniel Carrera wrote:
> On 07/21/2011 07:22 PM, Tobias Burnus wrote:
>> Doesn't compile here:
>> gcc/fortran/trans.c:656:8: error: unused variable 'status_type'
>> [-Werror=unused-variable]
> Hmm... I really wish that my Makefile was as picky as yours. But last
> time I tried to change my configure flag everything went crazy.
>
> The attached file contains the fix. I won't commit until I get a "ok"
> from you.
Compiled and regtested successfully.
Tobias
^ permalink raw reply [flat|nested] 11+ messages in thread
end of thread, other threads:[~2011-07-21 21:04 UTC | newest]
Thread overview: 11+ messages (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2011-07-21 11:30 [Patches, Fortran] ALLOCATE & CAF library Daniel Carrera
2011-07-21 12:49 ` Daniel Carrera
2011-07-21 14:50 ` Tobias Burnus
2011-07-21 15:34 ` Daniel Carrera
2011-07-21 15:47 ` Tobias Burnus
2011-07-21 16:16 ` Daniel Carrera
2011-07-21 17:10 ` Tobias Burnus
2011-07-21 17:13 ` Daniel Carrera
2011-07-21 17:39 ` Tobias Burnus
2011-07-21 19:35 ` Daniel Carrera
2011-07-21 21:30 ` Tobias Burnus
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).