From patchwork Mon Jun 6 21:40:15 2011 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Tobias Burnus X-Patchwork-Id: 99047 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Received: from sourceware.org (server1.sourceware.org [209.132.180.131]) by ozlabs.org (Postfix) with SMTP id 8D79EB6FB3 for ; Tue, 7 Jun 2011 07:40:47 +1000 (EST) Received: (qmail 16033 invoked by alias); 6 Jun 2011 21:40:45 -0000 Received: (qmail 16018 invoked by uid 22791); 6 Jun 2011 21:40:41 -0000 X-SWARE-Spam-Status: No, hits=-0.4 required=5.0 tests=AWL, BAYES_50, RCVD_IN_DNSWL_NONE X-Spam-Check-By: sourceware.org Received: from mx02.qsc.de (HELO mx02.qsc.de) (213.148.130.14) by sourceware.org (qpsmtpd/0.43rc1) with ESMTP; Mon, 06 Jun 2011 21:40:17 +0000 Received: from [192.168.178.22] (port-92-204-18-93.dynamic.qsc.de [92.204.18.93]) by mx02.qsc.de (Postfix) with ESMTP id 2E4181E6B9; Mon, 6 Jun 2011 23:40:15 +0200 (CEST) Message-ID: <4DED493E.5030705@net-b.de> Date: Mon, 06 Jun 2011 23:40:15 +0200 From: Tobias Burnus User-Agent: Mozilla/5.0 (X11; U; Linux x86_64; de; rv:1.9.2.17) Gecko/20110414 SUSE/3.1.10 Thunderbird/3.1.10 MIME-Version: 1.0 To: gcc patches , gfortran Subject: [Patch, Fortran] (Coarray) Add parse support for LOCK/UNLOCK (part 1 of 2) Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Unsubscribe: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Delivered-To: mailing list gcc-patches@gcc.gnu.org This patch adds incomplete parsing support for the LOCK and UNLOCK statement. Missing part 2 is the addition of the LOCK_TYPE of the ISO_FORTRAN_ENV. Build and tested on x86-64-linux. OK for the trunk? Tobias b/gcc/fortran/dump-parse-tree.c | 27 +++ b/gcc/fortran/frontend-passes.c | 1 b/gcc/fortran/gfortran.h | 5 b/gcc/fortran/match.c | 202 ++++++++++++++++++++++- b/gcc/fortran/match.h | 2 b/gcc/fortran/parse.c | 14 + b/gcc/fortran/resolve.c | 39 ++++ b/gcc/fortran/st.c | 2 2011-06-06 Tobias Burnus PR fortran/18918 * gfortran.h (gfc_statement): Add ST_LOCK and ST_UNLOCK. (gfc_exec_op): Add EXEC_LOCK and EXEC_UNLOCK. (gfc_code): Add expr4. * match.h (gfc_match_lock, gfc_match_unlock): New prototypes. * match.c (gfc_match_lock, gfc_match_unlock, lock_unlock_statement): New functions. (sync_statement): Bug fix, avoiding double freeing. (gfc_match_if): Handle LOCK/UNLOCK statement. * parse.c (decode_statement, next_statement, gfc_ascii_statement): Ditto. * st.c (gfc_free_statement): Handle LOCK and UNLOCK. * resolve.c (resolve_lock_unlock): New function. (resolve_code): Call it. * dump-parse-tree.c (show_code_node): Handle LOCK/UNLOCK. * frontend-passes.c (gfc_code_walker): Optimize gfc_code's expr4. 2011-06-06 Tobias Burnus PR fortran/18918 * gfortran.dg/coarray_lock_1.f90: New. * gfortran.dg/coarray_lock_2.f90: New. diff --git a/gcc/fortran/dump-parse-tree.c b/gcc/fortran/dump-parse-tree.c index c807062..87b8b68 100644 --- a/gcc/fortran/dump-parse-tree.c +++ b/gcc/fortran/dump-parse-tree.c @@ -1396,6 +1396,33 @@ show_code_node (int level, gfc_code *c) } break; + case EXEC_LOCK: + case EXEC_UNLOCK: + if (c->op == EXEC_LOCK) + fputs ("LOCK ", dumpfile); + else + fputs ("UNLOCK ", dumpfile); + + fputs ("lock-variable=", dumpfile); + if (c->expr1 != NULL) + show_expr (c->expr1); + if (c->expr4 != NULL) + { + fputs (" acquired_lock=", dumpfile); + show_expr (c->expr4); + } + if (c->expr2 != NULL) + { + fputs (" stat=", dumpfile); + show_expr (c->expr2); + } + if (c->expr3 != NULL) + { + fputs (" errmsg=", dumpfile); + show_expr (c->expr3); + } + break; + case EXEC_ARITHMETIC_IF: fputs ("IF ", dumpfile); show_expr (c->expr1); diff --git a/gcc/fortran/frontend-passes.c b/gcc/fortran/frontend-passes.c index 0137a9d..f100e1f 100644 --- a/gcc/fortran/frontend-passes.c +++ b/gcc/fortran/frontend-passes.c @@ -1190,6 +1190,7 @@ gfc_code_walker (gfc_code **c, walk_code_fn_t codefn, walk_expr_fn_t exprfn, WALK_SUBEXPR (co->expr1); WALK_SUBEXPR (co->expr2); WALK_SUBEXPR (co->expr3); + WALK_SUBEXPR (co->expr4); for (b = co->block; b; b = b->block) { WALK_SUBEXPR (b->expr1); diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index ff82424..f23fbbd 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -208,7 +208,7 @@ typedef enum ST_OMP_PARALLEL_WORKSHARE, ST_OMP_SECTIONS, ST_OMP_SECTION, ST_OMP_SINGLE, ST_OMP_THREADPRIVATE, ST_OMP_WORKSHARE, ST_OMP_TASK, ST_OMP_END_TASK, ST_OMP_TASKWAIT, ST_PROCEDURE, ST_GENERIC, ST_CRITICAL, ST_END_CRITICAL, - ST_GET_FCN_CHARACTERISTICS, ST_NONE + ST_GET_FCN_CHARACTERISTICS, ST_LOCK, ST_UNLOCK, ST_NONE } gfc_statement; @@ -2056,6 +2056,7 @@ typedef enum EXEC_OPEN, EXEC_CLOSE, EXEC_WAIT, EXEC_READ, EXEC_WRITE, EXEC_IOLENGTH, EXEC_TRANSFER, EXEC_DT_END, EXEC_BACKSPACE, EXEC_ENDFILE, EXEC_INQUIRE, EXEC_REWIND, EXEC_FLUSH, + EXEC_LOCK, EXEC_UNLOCK, EXEC_OMP_CRITICAL, EXEC_OMP_DO, EXEC_OMP_FLUSH, EXEC_OMP_MASTER, EXEC_OMP_ORDERED, EXEC_OMP_PARALLEL, EXEC_OMP_PARALLEL_DO, EXEC_OMP_PARALLEL_SECTIONS, EXEC_OMP_PARALLEL_WORKSHARE, @@ -2074,7 +2075,7 @@ typedef struct gfc_code gfc_st_label *here, *label1, *label2, *label3; gfc_symtree *symtree; - gfc_expr *expr1, *expr2, *expr3; + gfc_expr *expr1, *expr2, *expr3, *expr4; /* A name isn't sufficient to identify a subroutine, we need the actual symbol for the interface definition. const char *sub_name; */ diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c index f275239..11dee41 100644 --- a/gcc/fortran/match.c +++ b/gcc/fortran/match.c @@ -1561,6 +1561,7 @@ gfc_match_if (gfc_statement *if_type) match ("go to", gfc_match_goto, ST_GOTO) match ("if", match_arithmetic_if, ST_ARITHMETIC_IF) match ("inquire", gfc_match_inquire, ST_INQUIRE) + match ("lock", gfc_match_lock, ST_LOCK) match ("nullify", gfc_match_nullify, ST_NULLIFY) match ("open", gfc_match_open, ST_OPEN) match ("pause", gfc_match_pause, ST_NONE) @@ -1573,6 +1574,7 @@ gfc_match_if (gfc_statement *if_type) match ("sync all", gfc_match_sync_all, ST_SYNC_CALL); match ("sync images", gfc_match_sync_images, ST_SYNC_IMAGES); match ("sync memory", gfc_match_sync_memory, ST_SYNC_MEMORY); + match ("unlock", gfc_match_unlock, ST_UNLOCK) match ("where", match_simple_where, ST_WHERE) match ("write", gfc_match_write, ST_WRITE) @@ -2305,6 +2307,190 @@ gfc_match_error_stop (void) } +/* Match LOCK/UNLOCK statement. Syntax: + LOCK ( lock-variable [ , lock-stat-list ] ) + UNLOCK ( lock-variable [ , sync-stat-list ] ) + where lock-stat is ACQUIRED_LOCK or sync-stat + and sync-stat is STAT= or ERRMSG=. */ + +static match +lock_unlock_statement (gfc_statement st) +{ + match m; + gfc_expr *tmp, *lockvar, *acq_lock, *stat, *errmsg; + bool saw_acq_lock, saw_stat, saw_errmsg; + + tmp = lockvar = acq_lock = stat = errmsg = NULL; + saw_acq_lock = saw_stat = saw_errmsg = false; + + if (gfc_pure (NULL)) + { + gfc_error ("Image control statement SYNC at %C in PURE procedure"); + return MATCH_ERROR; + } + + if (gfc_implicit_pure (NULL)) + gfc_current_ns->proc_name->attr.implicit_pure = 0; + + if (gfc_option.coarray == GFC_FCOARRAY_NONE) + { + gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable"); + return MATCH_ERROR; + } + + if (gfc_find_state (COMP_CRITICAL) == SUCCESS) + { + gfc_error ("Image control statement SYNC at %C in CRITICAL block"); + return MATCH_ERROR; + } + + if (gfc_match_char ('(') != MATCH_YES) + goto syntax; + + if (gfc_match ("%e", &lockvar) != MATCH_YES) + goto syntax; + m = gfc_match_char (','); + if (m == MATCH_ERROR) + goto syntax; + if (m == MATCH_NO) + { + m = gfc_match_char (')'); + if (m == MATCH_YES) + goto done; + goto syntax; + } + + for (;;) + { + m = gfc_match (" stat = %v", &tmp); + if (m == MATCH_ERROR) + goto syntax; + if (m == MATCH_YES) + { + if (saw_stat) + { + gfc_error ("Redundant STAT tag found at %L ", &tmp->where); + goto cleanup; + } + stat = tmp; + saw_stat = true; + + m = gfc_match_char (','); + if (m == MATCH_YES) + continue; + + tmp = NULL; + break; + } + + m = gfc_match (" errmsg = %v", &tmp); + if (m == MATCH_ERROR) + goto syntax; + if (m == MATCH_YES) + { + if (saw_errmsg) + { + gfc_error ("Redundant ERRMSG tag found at %L ", &tmp->where); + goto cleanup; + } + errmsg = tmp; + saw_errmsg = true; + + m = gfc_match_char (','); + if (m == MATCH_YES) + continue; + + tmp = NULL; + break; + } + + m = gfc_match (" acquired_lock = %v", &tmp); + if (m == MATCH_ERROR || st == ST_UNLOCK) + goto syntax; + if (m == MATCH_YES) + { + if (saw_acq_lock) + { + gfc_error ("Redundant ACQUIRED_LOCK tag found at %L ", + &tmp->where); + goto cleanup; + } + acq_lock = tmp; + saw_acq_lock = true; + + m = gfc_match_char (','); + if (m == MATCH_YES) + continue; + + tmp = NULL; + break; + } + + break; + } + + if (m == MATCH_ERROR) + goto syntax; + + if (gfc_match (" )%t") != MATCH_YES) + goto syntax; + +done: + switch (st) + { + case ST_LOCK: + new_st.op = EXEC_LOCK; + break; + case ST_UNLOCK: + new_st.op = EXEC_UNLOCK; + break; + default: + gcc_unreachable (); + } + + new_st.expr1 = lockvar; + new_st.expr2 = stat; + new_st.expr3 = errmsg; + new_st.expr4 = acq_lock; + + return MATCH_YES; + +syntax: + gfc_syntax_error (st); + +cleanup: + gfc_free_expr (tmp); + gfc_free_expr (lockvar); + gfc_free_expr (acq_lock); + gfc_free_expr (stat); + gfc_free_expr (errmsg); + + return MATCH_ERROR; +} + + +match +gfc_match_lock (void) +{ + if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: LOCK statement at %C") + == FAILURE) + return MATCH_ERROR; + + return lock_unlock_statement (ST_LOCK); +} + + +match +gfc_match_unlock (void) +{ + if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: UNLOCK statement at %C") + == FAILURE) + return MATCH_ERROR; + + return lock_unlock_statement (ST_UNLOCK); +} + + /* Match SYNC ALL/IMAGES/MEMORY statement. Syntax: SYNC ALL [(sync-stat-list)] SYNC MEMORY [(sync-stat-list)] @@ -2345,7 +2531,7 @@ sync_statement (gfc_statement st) gfc_error ("Image control statement SYNC at %C in CRITICAL block"); return MATCH_ERROR; } - + if (gfc_match_eos () == MATCH_YES) { if (st == ST_SYNC_IMAGES) @@ -2396,6 +2582,9 @@ sync_statement (gfc_statement st) if (gfc_match_char (',') == MATCH_YES) continue; + + tmp = NULL; + break; } m = gfc_match (" errmsg = %v", &tmp); @@ -2413,16 +2602,17 @@ sync_statement (gfc_statement st) if (gfc_match_char (',') == MATCH_YES) continue; - } - gfc_gobble_whitespace (); + tmp = NULL; + break; + } - if (gfc_peek_char () == ')') break; - - goto syntax; } + if (m == MATCH_ERROR) + goto syntax; + if (gfc_match (" )%t") != MATCH_YES) goto syntax; diff --git a/gcc/fortran/match.h b/gcc/fortran/match.h index 69f1d9e..5a40d7a 100644 --- a/gcc/fortran/match.h +++ b/gcc/fortran/match.h @@ -74,6 +74,7 @@ match gfc_match_associate (void); match gfc_match_do (void); match gfc_match_cycle (void); match gfc_match_exit (void); +match gfc_match_lock (void); match gfc_match_pause (void); match gfc_match_stop (void); match gfc_match_error_stop (void); @@ -83,6 +84,7 @@ match gfc_match_goto (void); match gfc_match_sync_all (void); match gfc_match_sync_images (void); match gfc_match_sync_memory (void); +match gfc_match_unlock (void); match gfc_match_allocate (void); match gfc_match_nullify (void); diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c index a47b457..6013931 100644 --- a/gcc/fortran/parse.c +++ b/gcc/fortran/parse.c @@ -398,6 +398,10 @@ decode_statement (void) match ("intrinsic", gfc_match_intrinsic, ST_ATTR_DECL); break; + case 'l': + match ("lock", gfc_match_lock, ST_LOCK); + break; + case 'm': match ("module% procedure", gfc_match_modproc, ST_MODULE_PROC); match ("module", gfc_match_module, ST_MODULE); @@ -449,6 +453,7 @@ decode_statement (void) break; case 'u': + match ("unlock", gfc_match_unlock, ST_UNLOCK); match ("use", gfc_match_use, ST_USE); break; @@ -953,7 +958,8 @@ next_statement (void) case ST_ASSIGNMENT: case ST_ARITHMETIC_IF: case ST_WHERE: case ST_FORALL: \ case ST_LABEL_ASSIGNMENT: case ST_FLUSH: case ST_OMP_FLUSH: \ case ST_OMP_BARRIER: case ST_OMP_TASKWAIT: case ST_ERROR_STOP: \ - case ST_SYNC_ALL: case ST_SYNC_IMAGES: case ST_SYNC_MEMORY + case ST_SYNC_ALL: case ST_SYNC_IMAGES: case ST_SYNC_MEMORY: \ + case ST_LOCK: case ST_UNLOCK /* Statements that mark other executable statements. */ @@ -1334,6 +1340,9 @@ gfc_ascii_statement (gfc_statement st) case ST_INTERFACE: p = "INTERFACE"; break; + case ST_LOCK: + p = "LOCK"; + break; case ST_PARAMETER: p = "PARAMETER"; break; @@ -1394,6 +1403,9 @@ gfc_ascii_statement (gfc_statement st) case ST_TYPE: p = "TYPE"; break; + case ST_UNLOCK: + p = "UNLOCK"; + break; case ST_USE: p = "USE"; break; diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 6ca98f2..b2c3189 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -8199,6 +8199,40 @@ find_reachable_labels (gfc_code *block) static void +resolve_lock_unlock (gfc_code *code) +{ + /* FIXME: Add more lock-variable checks. For now, always reject it. + Note that ISO_FORTRAN_ENV's LOCK_TYPE is not yet available. */ + /* if (code->expr2->ts.type != BT_DERIVED + || code->expr2->rank != 0 + || code->expr2->expr_type != EXPR_VARIABLE) */ + gfc_error ("Lock variable at %L must be a scalar of type LOCK_TYPE", + &code->expr1->where); + + /* Check STAT. */ + if (code->expr2 + && (code->expr2->ts.type != BT_INTEGER || code->expr2->rank != 0 + || code->expr2->expr_type != EXPR_VARIABLE)) + gfc_error ("STAT= argument at %L must be a scalar INTEGER variable", + &code->expr2->where); + + /* Check ERRMSG. */ + if (code->expr3 + && (code->expr3->ts.type != BT_CHARACTER || code->expr3->rank != 0 + || code->expr3->expr_type != EXPR_VARIABLE)) + gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable", + &code->expr3->where); + + /* Check ACQUIRED_LOCK. */ + if (code->expr4 + && (code->expr4->ts.type != BT_LOGICAL || code->expr4->rank != 0 + || code->expr4->expr_type != EXPR_VARIABLE)) + gfc_error ("ACQUIRED_LOCK= argument at %L must be a scalar LOGICAL " + "variable", &code->expr4->where); +} + + +static void resolve_sync (gfc_code *code) { /* Check imageset. The * case matches expr1 == NULL. */ @@ -9065,6 +9099,11 @@ resolve_code (gfc_code *code, gfc_namespace *ns) resolve_sync (code); break; + case EXEC_LOCK: + case EXEC_UNLOCK: + resolve_lock_unlock (code); + break; + case EXEC_ENTRY: /* Keep track of which entry we are up to. */ current_entry_id = code->ext.entry->id; diff --git a/gcc/fortran/st.c b/gcc/fortran/st.c index 6f8a234..cedb97c 100644 --- a/gcc/fortran/st.c +++ b/gcc/fortran/st.c @@ -113,6 +113,8 @@ gfc_free_statement (gfc_code *p) case EXEC_SYNC_ALL: case EXEC_SYNC_IMAGES: case EXEC_SYNC_MEMORY: + case EXEC_LOCK: + case EXEC_UNLOCK: break; case EXEC_BLOCK: --- /dev/null 2011-06-06 07:23:08.586867510 +0200 +++ gcc/gcc/testsuite/gfortran.dg/coarray_lock_1.f90 2011-06-06 23:24:56.000000000 +0200 @@ -0,0 +1,15 @@ +! { dg-do compile } +! { dg-options "-fcoarray=single -std=f2008" } +! +! LOCK/UNLOCK intrinsics +! +! PR fortran/18918 +! +integer :: a[*] +integer :: s +character(len=3) :: c +logical :: bool + +LOCK (a, stat=s, acquired_lock=bool, errmsg=c) ! { dg-error "must be a scalar of type LOCK_TYPE" } +UNLOCK (a, stat=s, errmsg=c) ! { dg-error "must be a scalar of type LOCK_TYPE" } +end --- /dev/null 2011-06-06 07:23:08.586867510 +0200 +++ gcc/gcc/testsuite/gfortran.dg/coarray_lock_2.f90 2011-06-06 23:24:33.000000000 +0200 @@ -0,0 +1,15 @@ +! { dg-do compile } +! { dg-options "-fcoarray=single -std=f2003" } +! +! LOCK/UNLOCK intrinsics +! +! PR fortran/18918 +! +integer :: a[*] ! { dg-error "Fortran 2008: Coarray declaration" } +integer :: s +character(len=3) :: c +logical :: bool + +LOCK (a, stat=s, acquired_lock=bool, errmsg=c) ! { dg-error "Fortran 2008: LOCK statement" } +UNLOCK (a, stat=s, errmsg=c) ! { dg-error "Fortran 2008: UNLOCK statement" } +end