patch for FORALL resolution
Canqun Yang <canqun-/[email protected]> Mon, 12 May 2003 22:34:26 +0800 (CST)
| Newsgroups | gmane.comp.compilers.g95 |
|---|---|
| Message-ID | <[email protected]> |
--0-1490740966-1052750066=:23256
Content-Type: text/plain; charset=gb2312
Content-Transfer-Encoding: 8bit
Content-Id:
Content-Disposition: inline
Hi, Paul, Steven
This patch enhanced the resolution for FORALL.
Would you please check it?
I hope the patch can be applied, because it took
Lifang Zeng much time on it, and to maintain the patch
is really a burden.
Canqun Yang.
_________________________________________________________
Do You Yahoo!?
Ïà¼û²»ÈçÁÄÌì!²»³öÃÅÒ»ÑùÃæ¶ÔÃ棡ÍøÂçÉãÏñÍ·¶Ô¶ÔÅÉËÍÖÐ~¸Ï¿ìÓÃÄãµÄÑÅ»¢µçÓÊÕʺŲÎÓë°É¡¡
http://cn.rd.yahoo.com/mail_cn/tag/?http://cn.messenger.yahoo.com/
--0-1490740966-1052750066=:23256
Content-Type: text/plain; name="forall_resolve_patch.txt"
Content-Description: forall_resolve_patch.txt
Content-Disposition: inline; filename="forall_resolve_patch.txt"
*** resolve.c 2003-05-12 19:56:00.000000000 +0800
--- resolve.c 2003-05-12 21:54:29.000000000 +0800
***************
*** 22,28 ****
#include "config.h"
#include "g95.h"
#include "arith.h" /* For g95_compare_expr(). */
!
#include <string.h>
/* Stack to push the current if we descend into a block during
--- 22,28 ----
#include "config.h"
#include "g95.h"
#include "arith.h" /* For g95_compare_expr(). */
! #include <assert.h>
#include <string.h>
/* Stack to push the current if we descend into a block during
***************
*** 2955,2961 ****
/* Check shape consistent for WHERE assignment target. */
if (e && resolve_where_shape (cnext->expr, e) == FAILURE)
g95_error ("WHERE assignment target at %L has "
! "inconsistent shape", &cnext->expr->where);
break;
/* WHERE or WHERE construct is part of a where-body-construct */
--- 2955,2961 ----
/* Check shape consistent for WHERE assignment target. */
if (e && resolve_where_shape (cnext->expr, e) == FAILURE)
g95_error ("WHERE assignment target at %L has "
! "inconsistent shape", &cnext->expr->where);
break;
/* WHERE or WHERE construct is part of a where-body-construct */
***************
*** 2976,2981 ****
--- 2976,3316 ----
}
+ /* Check whether the forall index appear in the expression or not. */
+
+ static try
+ g95_find_forall_index (g95_expr *expr, g95_symbol *symbol)
+ {
+ g95_array_ref ar;
+ g95_actual_arglist *args;
+ int i;
+
+ switch (expr->expr_type)
+ {
+ case EXPR_VARIABLE:
+ assert (expr->symtree->n.sym);
+
+ /* A scalar assignment */
+ if (!expr->ref)
+ {
+ if (expr->symtree->n.sym == symbol)
+ return 1;
+ }
+ else
+ {
+ g95_ref *tmp;
+
+ /* the expr is array ref, substring or struct component. */
+ tmp = expr->ref;
+ while (tmp != NULL)
+ {
+ switch (tmp->type)
+ {
+ case REF_ARRAY:
+ /* Check if the symbol appears in the array subscript. */
+ ar = tmp->u.ar;
+ for (i = 0; i < G95_MAX_DIMENSIONS; i++)
+ {
+ if (ar.start[i])
+ {
+ if (g95_find_forall_index (ar.start[i], symbol))
+ return 1;
+ }
+ }
+ for (i = 0; i < G95_MAX_DIMENSIONS; i++)
+ {
+ if (ar.end[i])
+ {
+ if (g95_find_forall_index (ar.end[i], symbol))
+ return 1;
+ }
+ }
+ for (i = 0; i < G95_MAX_DIMENSIONS; i++)
+ {
+ if (ar.stride[i])
+ {
+ if (g95_find_forall_index (ar.stride[i], symbol))
+ return 1;
+ }
+ }
+ break;
+
+ case REF_SUBSTRING:
+ if (expr->symtree->n.sym == symbol)
+ return 1;
+
+ /* Check if the symbol appears in the substring section. */
+ if (g95_find_forall_index (expr->ref->u.ss.start, symbol))
+ return 1;
+ if (g95_find_forall_index (expr->ref->u.ss.end, symbol))
+ return 1;
+ break;
+
+ /* If the ref is REF_COMPONENT,just Jumping over it and
+ going to the next. */
+ case REF_COMPONENT:
+ break;
+
+ default:
+ g95_error("expresion reference type error at %L",
+ &expr->where);
+ }
+ tmp = tmp->next;
+ }
+ }
+ break;
+
+ /* If the expression is a function call, then check if the symbol
+ appears in the actual arglist of the function. */
+ case EXPR_FUNCTION:
+ for (args = expr->value.function.actual; args; args = args->next)
+ {
+ if (g95_find_forall_index(args->expr,symbol))
+ return 1;
+ }
+ break;
+
+ /* It seems not to happen? */
+ case EXPR_SUBSTRING:
+ if (expr->ref)
+ {
+ assert(expr->ref->type == REF_SUBSTRING);
+ if (g95_find_forall_index (expr->ref->u.ss.start, symbol))
+ return 1;
+ if (g95_find_forall_index (expr->ref->u.ss.end, symbol))
+ return 1;
+ }
+ break;
+
+ /* It seems not to happen? */
+ case EXPR_STRUCTURE:
+ case EXPR_ARRAY:
+ g95_error ("Not supported statement while finding forall index in "
+ "expression");
+ break;
+
+ default:
+ break;
+ }
+
+ /* Find the forall index in the first operand. */
+ if(expr->op1)
+ {
+ if (g95_find_forall_index (expr->op1, symbol))
+ return 1;
+ }
+
+ /* Find the forall index in the second operand. */
+ if(expr->op2)
+ {
+ if (g95_find_forall_index (expr->op2, symbol))
+ return 1;
+ }
+
+ return 0;
+ }
+
+
+ /* Resolve assignment in forall construct */
+
+ static void
+ g95_resolve_assign_in_forall (g95_code *code, int nvar, g95_expr **var_expr)
+ {
+ int n;
+
+ /* Nvar is the number of FORALL index variables.
+ Var_expr records the FORALL index variables. */
+ for (n = 0; n < nvar; n++)
+ {
+ g95_symbol *forall_index;
+
+ forall_index = var_expr[n]->symtree->n.sym;
+
+ /* Check whether the lhs of the assignment is one of the FORALL
+ index variable. */
+ if ((code->expr->expr_type == EXPR_VARIABLE)
+ && (code->expr->symtree->n.sym == forall_index))
+ g95_error ("Assignment to a FORALL index variable "
+ "at %L", &code->expr->where);
+ else
+ {
+ /* If one of the FORALL index variables doesn't appear in the
+ lhs of the assignment, then there will be a many-to-one
+ assignment. */
+ if ( ! g95_find_forall_index (code->expr, forall_index))
+ g95_error ("The FORALL with index '%s' cause more "
+ "than one assignment to this object at %L",
+ var_expr[n]->symtree->name, &code->expr->where);
+ }
+ }
+ }
+
+
+ /* Resolve where statement in forall construct */
+
+ static void
+ g95_resolve_where_code_in_forall (g95_code *code, int nvar, g95_expr **var_expr){
+ g95_code *cblock;
+ g95_code *cnext;
+
+ cblock = code->block;
+ while (cblock)
+ {
+ /* the assignment statement of a WHERE statement, or the first
+ statement in where-body-construct of a WHERE construct */
+ cnext = cblock->next;
+ while (cnext)
+ {
+ switch (cnext->op)
+ {
+ /* WHERE assignment statement */
+ case EXEC_ASSIGN:
+ g95_resolve_assign_in_forall (cnext, nvar, var_expr);
+ break;
+
+ /* WHERE or WHERE construct is part of a where-body-construct */
+ case EXEC_WHERE:
+ g95_resolve_where_code_in_forall (cnext, nvar, var_expr);
+ break;
+
+ default:
+ g95_error ("Unsupported statement inside WHERE at %L",
+ &cnext->loc);
+ break;
+ }
+ /* the next statement within the same where-body-construct */
+ cnext = cnext->next;
+ }
+ /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */
+ cblock = cblock->block;
+ }
+ }
+
+
+ /* Traverse the FORALL body to check whether the following errors exist:
+ 1. For assignment, check if a many-to-one assignment happens.
+ 2. For where statement, check the where body to see if there is any
+ many-to-one assignment. */
+
+ static void
+ g95_resolve_forall_body (g95_code *code, int nvar, g95_expr **var_expr)
+ {
+ g95_code *c;
+
+ c = code->block->next;
+
+ while (c)
+ {
+ switch (c->op)
+ {
+ case EXEC_ASSIGN:
+ case EXEC_POINTER_ASSIGN:
+ g95_resolve_assign_in_forall (c, nvar, var_expr);
+ break;
+
+ /* Because the resolve_blocks() will handle the nested FORALL,
+ there is no need to handle it here. */
+ case EXEC_FORALL:
+ break;
+
+ case EXEC_WHERE:
+ g95_resolve_where_code_in_forall(c, nvar, var_expr);
+ break;
+
+ default:
+ break;
+ }
+
+ /* The next statement in the FORALL body. */
+ c = c->next;
+ }
+ }
+
+
+ /* Given a forall construct, first resolve the forall iterator, then call
+ g95_resolve_forall_body to resolve the forall body. */
+
+ static void resolve_blocks (g95_code *, g95_namespace *);
+ static void
+ g95_resolve_forall (g95_code *code, g95_namespace *ns, int forall_save)
+ {
+ static g95_expr **var_expr;
+ static int total_var = 0;
+ static int nvar = 0;
+ g95_forall_iterator *fa;
+ g95_symbol *forall_index;
+ g95_code *next;
+ int i;
+
+ /* Resolve FORALL construct */
+ if (forall_save == 0)
+ {
+ /* Count the total number of FORALL index in the nested FORALL
+ construct in order to allocate the VAR_EXPR with proper size. */
+ next = code;
+ while ((next != NULL) && (next->op == EXEC_FORALL))
+ {
+ for (fa = next->ext.forall_iterator; fa; fa = fa->next)
+ total_var ++;
+ next = next->block->next;
+ }
+
+ /* allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
+ var_expr = (g95_expr **) g95_getmem (total_var * sizeof (g95_expr *));
+ }
+
+ /* The information about forall iterator, including forall index start,end
+ and stride. The FORALL index can not appear in start, end or stride. */
+ for (fa = code->ext.forall_iterator; fa; fa = fa->next)
+ {
+ /* Check if any outer FORALL index name is the same as the current
+ one */
+ for (i = 0; i < nvar; i++)
+ {
+ if (fa->var->symtree->n.sym == var_expr[i]->symtree->n.sym)
+ {
+ g95_error ("An outer FORALL construct already has an index "
+ "with this name %L", &fa->var->where);
+ }
+ }
+
+ /* Record the current FORALL index. */
+ var_expr[nvar] = g95_copy_expr (fa->var);
+
+ forall_index = fa->var->symtree->n.sym;
+
+ /* Check if the FORALL index appears in start,end or stride. */
+ if (g95_find_forall_index (fa->start, forall_index))
+ g95_error ("A FORALL index must not appear in a limit or stride "
+ "expression in the same FORALL at %L", &fa->start->where);
+
+ if (g95_find_forall_index (fa->end, forall_index))
+ g95_error ("A FORALL index must not appear in a limit or stride "
+ "expression in the same FORALL at %L", &fa->end->where);
+
+ if (g95_find_forall_index (fa->stride, forall_index))
+ g95_error ("A FORALL index must not appear in a limit or stride "
+ "expression in the same FORALL at %L", &fa->stride->where);
+ nvar++;
+ }
+
+ /* Resolve the forall body. */
+ g95_resolve_forall_body (code, nvar, var_expr);
+
+ resolve_blocks (code->block, ns);
+
+ /* Clear the global var NVAR and VAR_EXPR after resolving a nested
+ FORALL construct. It must be here after resolve_blocks(), because
+ resolve_blocks() will handle the inner FORALL and modify NVAR and
+ VAR_EXPR. */
+ for (i = 0; i < total_var; i++)
+ g95_free_expr (var_expr[i]);
+
+ total_var = 0;
+ nvar = 0;
+ }
+
+
/* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL and DO code
nodes. */
***************
*** 3050,3058 ****
{
forall_save = forall_flag;
forall_flag = 1;
! }
!
! resolve_blocks (code->block, ns);
if (code->op == EXEC_FORALL)
forall_flag = forall_save;
--- 3385,3394 ----
{
forall_save = forall_flag;
forall_flag = 1;
! g95_resolve_forall (code, ns, forall_save);
! }
! else
! resolve_blocks (code->block, ns);
if (code->op == EXEC_FORALL)
forall_flag = forall_save;
*** ChangeLog 2003-05-12 21:58:28.000000000 +0800
--- ChangeLog 2003-05-12 21:53:57.000000000 +0800
***************
*** 1,3 ****
--- 1,11 ----
+ 2003-05-12 Lifang Zeng <[email protected]>
+ *resolve.c (g95_resolve_forall): Resolve FORALL construct.
+ (g95_resolve_where_code_in_forall): New function
+ (g95_resolve_assign_in_forall): New function
+ (g95_resolve_forall_body): New function
+ (g95_find_forall_index): New function
+ (resolve_code): Modified
+
2003-05-11 Paul Brook <[email protected]>
* arith.c (g95_integer_index_kind): New variable.
--0-1490740966-1052750066=:23256
Content-Type: text/plain; name="forall_resolve.txt"
Content-Description: forall_resolve.txt
Content-Disposition: inline; filename="forall_resolve.txt"
! Test FORALL resolution
program forall_resolve
integer a(4)
forall (i=1:4)
a = i
end forall
end
subroutine forall_resolve_2
integer a(4,6), n1, n2
do i=1,4
a(i,1) = -1
a(i,2) = 0
a(i,3) = 1
a(i,4) = 2
a(i,5) = -2
a(i,6) = -1
enddo
n1 = 4
n2 = 6
forall (i=1:n1, a(1,i).GT.0)
forall (j=i:n2, a(i,j).GT.0)
forall (j=i:n2)
a(i,:) = i+j
end forall
end forall
end forall
end
subroutine forall_resolve_3
integer a(10,10),k,j,b(10)
type people
integer a(10,10)
character*10 name
end type
type (people) me(10)
forall (i=1:i)
forall (j=i:10)
me(i)%a(i,b(i)) = 2
me(j)%name = "zlf"
i = 1
j = 1
where (a.GT.0)
me(i)%name = "xmq"
elsewhere
me(j)%name = "xxx"
end where
end forall
end forall
end
subroutine forall_resolve_3
integer a(10,10),i,j
forall (i=1:10)
forall (j=i:10)
a(:,j) = i+j
end forall
end forall
end
subroutine forall_resolve_5
integer, parameter :: N = 10 ! say...
integer, parameter :: M = 2*N
integer :: i1,i2,i3,i4,i5,i6,i7,i8,i9,i10,i11,i12,i13,i14
real, dimension(M,M,M,M,M,M,M) :: A, B
forall (i1=1:N2, i2=1:N, i3=1:N, i4=1:N, i5=1:N, i6=1:N, i7=1:N,&
i8=1:N2, i9=1:N, i10=1:N, i11=1:N, i12=1:N, i13=1:N, i14=1:N)&
a(i1,i2,i3,i4,i5,i6,i7) = b(i8,i9,i10,i11,i12,i13,i14)
forall (i1=1:N2, i2=1:N, i3=1:N, i4=1:N, i5=1:N, i6=1:N, i7=1:N,&
i8=1:N2, i9=1:N, i10=1:N, i11=1:N, i12=1:N, i13=1:N, i14=1:N)&
a(i1+i2,i3+i4,i5+i6,i7+i8,i9,i11+i12,i13) = 2
end
--0-1490740966-1052750066=:23256--
-------------------------------------------------------
Enterprise Linux Forum Conference & Expo, June 4-6, 2003, Santa Clara
The only event dedicated to issues related to Linux enterprise solutions
www.enterpriselinuxforum.com