From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: (qmail 21088 invoked by alias); 20 Jun 2011 21:13:41 -0000 Received: (qmail 21069 invoked by uid 22791); 20 Jun 2011 21:13:38 -0000 X-SWARE-Spam-Status: No, hits=-1.7 required=5.0 tests=AWL,BAYES_00,RCVD_IN_DNSWL_NONE,TW_RK X-Spam-Check-By: sourceware.org Received: from mx01.qsc.de (HELO mx01.qsc.de) (213.148.129.14) by sourceware.org (qpsmtpd/0.43rc1) with ESMTP; Mon, 20 Jun 2011 21:13:22 +0000 Received: from [192.168.178.22] (port-92-204-88-186.dynamic.qsc.de [92.204.88.186]) by mx01.qsc.de (Postfix) with ESMTP id CEF673CECA; Mon, 20 Jun 2011 23:13:19 +0200 (CEST) Message-ID: <4DFFB7EF.10000@net-b.de> Date: Mon, 20 Jun 2011 22:10:00 -0000 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: Paul Richard Thomas CC: gcc patches , gfortran Subject: Re: [Patch, Fortran] (coarray) Add LOCK_TYPE References: <4DF9A24E.1040800@net-b.de> <4DFF5D18.3030205@net-b.de> In-Reply-To: Content-Type: multipart/mixed; boundary="------------090200050509060909070804" Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org X-SW-Source: 2011-06/txt/msg01535.txt.bz2 This is a multi-part message in MIME format. --------------090200050509060909070804 Content-Type: text/plain; charset=ISO-8859-1; format=flowed Content-Transfer-Encoding: 7bit Content-length: 2579 Dear Paul, Paul Richard Thomas wrote: > I have checked out the code for any obvious style or other minor > errors and all looks well. However, I had a look at 8.5.6 "LOCK and > UNLOCK statements" in the standard and can only confess to feeling > very stupid tonight because I could not make head nor tail of the > example. Thus, I can offer no judgement on the functionality of your > patch. Well, for a single image - and more the current patch does not support - it is very simple: LOCK and UNLOCK do not do anything. If there is a STAT=, it is set to 0 and if there is a LOCK_ACQUIRED= it is set to true. But in general, a LOCK/UNLOCK pair allows to create a critical section, where only one process at a time processes a certain block. Mostly one image (process) can hold a lock at any given time. The simplest case for LOCK is a CRITICAL block where only one process (image) at a time can execute code in the block. However, LOCK allows more: * With LOCK_ACQUIRED, it allows to perform some alternative action when it cannot get the lock (otherwise, LOCK waits until it can obtain the lock) * As the example in the standard shows: One can use one lock (variable) to lock different section of the code. In the example (Example 8.45): Each image (process) has a work queue. This queue is filled (remotely) by its neighbour, i.e. "this_image()-1", which is possible as the work queue is a coarray. In the first block, each process checks whether there is a new item in its own ("this_image()") workqueue - in the second block, it adds a new item to the neighbouring queue. While an item is being added or removed from the queue, no parallel access should be happen - thus the access is guarded via a lock. The lock is also a coarray, thus, there are num_image() locks. In the example "work_queue" is the local arrays and thus semantically identical to "work_queue[this_image()]" while "work_queue[me+1]" refers to the remote coarray on image "me+1". > OK for trunk Thanks for the review! And good that you asked about the trans part. There was actually a bug in it: + if (stat != NULL_TREE) + gfc_add_modify (&se.pre, lock_acquired, + build_int_cst (TREE_TYPE (lock_acquired), 0)); The check in "if" should be "lock_acquired" not "stat". Corrected in the committed version (Rev. 175228). I have now also added a run-test (cf. attachment) to make sure that it actually works. > PS Please give me a co-array tutorial sometime! I will, though I think for the real fun, one needs to have a working mult-image support. Tobias --------------090200050509060909070804 Content-Type: text/plain; name="lock_1.f90" Content-Transfer-Encoding: 7bit Content-Disposition: attachment; filename="lock_1.f90" Content-length: 476 ! { dg-do run } ! ! LOCK/UNLOCK check ! ! PR fortran/18918 ! use iso_fortran_env implicit none type(lock_type) :: lock[*] integer :: stat logical :: acquired LOCK(lock) UNLOCK(lock) stat = 99 LOCK(lock, stat=stat) if (stat /= 0) call abort() stat = 99 UNLOCK(lock, stat=stat) if (stat /= 0) call abort() if (this_image() == 1) then acquired = .false. LOCK (lock[this_image()], acquired_lock=acquired) if (.not. acquired) call abort() UNLOCK (lock[1]) end if end --------------090200050509060909070804 Content-Type: text/x-patch; name="lock-changes.diff" Content-Transfer-Encoding: 7bit Content-Disposition: attachment; filename="lock-changes.diff" Content-length: 9242 Index: trans-stmt.c =================================================================== --- trans-stmt.c (Revision 175227) +++ trans-stmt.c (Arbeitskopie) @@ -653,6 +653,48 @@ gfc_trans_stop (gfc_code *code, bool error_stop) tree +gfc_trans_lock_unlock (gfc_code *code, gfc_exec_op type ATTRIBUTE_UNUSED) +{ + gfc_se se, argse; + tree stat = NULL_TREE, lock_acquired = NULL_TREE; + + /* Short cut: For single images without STAT= or LOCK_ACQUIRED + return early. (ERRMSG= is always untouched for -fcoarray=single.) */ + if (!code->expr2 && !code->expr4 && gfc_option.coarray != GFC_FCOARRAY_LIB) + return NULL_TREE; + + gfc_init_se (&se, NULL); + gfc_start_block (&se.pre); + + if (code->expr2) + { + gcc_assert (code->expr2->expr_type == EXPR_VARIABLE); + gfc_init_se (&argse, NULL); + gfc_conv_expr_val (&argse, code->expr2); + stat = argse.expr; + } + + if (code->expr4) + { + gcc_assert (code->expr4->expr_type == EXPR_VARIABLE); + gfc_init_se (&argse, NULL); + gfc_conv_expr_val (&argse, code->expr4); + lock_acquired = argse.expr; + } + + if (stat != NULL_TREE) + gfc_add_modify (&se.pre, stat, build_int_cst (TREE_TYPE (stat), 0)); + + if (lock_acquired != NULL_TREE) + gfc_add_modify (&se.pre, lock_acquired, + fold_convert (TREE_TYPE (lock_acquired), + boolean_true_node)); + + return gfc_finish_block (&se.pre); +} + + +tree gfc_trans_sync (gfc_code *code, gfc_exec_op type) { gfc_se se, argse; Index: resolve.c =================================================================== --- resolve.c (Revision 175227) +++ resolve.c (Arbeitskopie) @@ -6235,7 +6235,7 @@ gfc_resolve_iterator (gfc_iterator *iter, bool rea == FAILURE) return FAILURE; - if (gfc_check_vardef_context (iter->var, false, _("iterator variable")) + if (gfc_check_vardef_context (iter->var, false, false, _("iterator variable")) == FAILURE) return FAILURE; @@ -6502,9 +6502,11 @@ resolve_deallocate_expr (gfc_expr *e) } if (pointer - && gfc_check_vardef_context (e, true, _("DEALLOCATE object")) == FAILURE) + && gfc_check_vardef_context (e, true, true, _("DEALLOCATE object")) + == FAILURE) return FAILURE; - if (gfc_check_vardef_context (e, false, _("DEALLOCATE object")) == FAILURE) + if (gfc_check_vardef_context (e, false, true, _("DEALLOCATE object")) + == FAILURE) return FAILURE; return SUCCESS; @@ -6796,6 +6798,21 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code &e->where, &code->expr3->where); goto failure; } + + /* Check F2008, C642. */ + if (code->expr3->ts.type == BT_DERIVED + && ((codimension && gfc_expr_attr (code->expr3).lock_comp) + || (code->expr3->ts.u.derived->from_intmod + == INTMOD_ISO_FORTRAN_ENV + && code->expr3->ts.u.derived->intmod_sym_id + == ISOFORTRAN_LOCK_TYPE))) + { + gfc_error ("The source-expr at %L shall neither be of type " + "LOCK_TYPE nor have a LOCK_TYPE component if " + "allocate-object at %L is a coarray", + &code->expr3->where, &e->where); + goto failure; + } } /* Check F08:C629. */ @@ -6814,9 +6831,9 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code e2 = remove_last_array_ref (e); t = SUCCESS; if (t == SUCCESS && pointer) - t = gfc_check_vardef_context (e2, true, _("ALLOCATE object")); + t = gfc_check_vardef_context (e2, true, true, _("ALLOCATE object")); if (t == SUCCESS) - t = gfc_check_vardef_context (e2, false, _("ALLOCATE object")); + t = gfc_check_vardef_context (e2, false, true, _("ALLOCATE object")); gfc_free_expr (e2); if (t == FAILURE) goto failure; @@ -6992,7 +7009,7 @@ resolve_allocate_deallocate (gfc_code *code, const /* Check the stat variable. */ if (stat) { - gfc_check_vardef_context (stat, false, _("STAT variable")); + gfc_check_vardef_context (stat, false, false, _("STAT variable")); if ((stat->ts.type != BT_INTEGER && !(stat->ref && (stat->ref->type == REF_ARRAY @@ -7035,7 +7052,7 @@ resolve_allocate_deallocate (gfc_code *code, const gfc_warning ("ERRMSG at %L is useless without a STAT tag", &errmsg->where); - gfc_check_vardef_context (errmsg, false, _("ERRMSG variable")); + gfc_check_vardef_context (errmsg, false, false, _("ERRMSG variable")); if ((errmsg->ts.type != BT_CHARACTER && !(errmsg->ref @@ -8100,7 +8117,8 @@ resolve_transfer (gfc_code *code) code->ext.dt may be NULL if the TRANSFER is related to an INQUIRE statement -- but in this case, we are not reading, either. */ if (code->ext.dt && code->ext.dt->dt_io_kind->value.iokind == M_READ - && gfc_check_vardef_context (exp, false, _("item in READ")) == FAILURE) + && gfc_check_vardef_context (exp, false, false, _("item in READ")) + == FAILURE) return; sym = exp->symtree->n.sym; @@ -8201,13 +8219,15 @@ 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); + if (code->expr1->ts.type != BT_DERIVED + || code->expr1->expr_type != EXPR_VARIABLE + || code->expr1->ts.u.derived->from_intmod != INTMOD_ISO_FORTRAN_ENV + || code->expr1->ts.u.derived->intmod_sym_id != ISOFORTRAN_LOCK_TYPE + || code->expr1->rank != 0 + || !(gfc_expr_attr (code->expr1).codimension + || gfc_is_coindexed (code->expr1))) + gfc_error ("Lock variable at %L must be a scalar coarray of type " + "LOCK_TYPE", &code->expr1->where); /* Check STAT. */ if (code->expr2 @@ -8216,6 +8236,11 @@ resolve_lock_unlock (gfc_code *code) gfc_error ("STAT= argument at %L must be a scalar INTEGER variable", &code->expr2->where); + if (code->expr2 + && gfc_check_vardef_context (code->expr2, false, false, + _("STAT variable")) == FAILURE) + return; + /* Check ERRMSG. */ if (code->expr3 && (code->expr3->ts.type != BT_CHARACTER || code->expr3->rank != 0 @@ -8223,12 +8248,22 @@ resolve_lock_unlock (gfc_code *code) gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable", &code->expr3->where); + if (code->expr3 + && gfc_check_vardef_context (code->expr3, false, false, + _("ERRMSG variable")) == FAILURE) + return; + /* 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); + + if (code->expr4 + && gfc_check_vardef_context (code->expr4, false, false, + _("ACQUIRED_LOCK variable")) == FAILURE) + return; } @@ -9143,8 +9178,8 @@ resolve_code (gfc_code *code, gfc_namespace *ns) if (t == FAILURE) break; - if (gfc_check_vardef_context (code->expr1, false, _("assignment")) - == FAILURE) + if (gfc_check_vardef_context (code->expr1, false, false, + _("assignment")) == FAILURE) break; if (resolve_ordinary_assign (code, ns)) @@ -9182,9 +9217,11 @@ resolve_code (gfc_code *code, gfc_namespace *ns) array ref may be present on the LHS and fool gfc_expr_attr used in gfc_check_vardef_context. Remove it. */ e = remove_last_array_ref (code->expr1); - t = gfc_check_vardef_context (e, true, _("pointer assignment")); + t = gfc_check_vardef_context (e, true, false, + _("pointer assignment")); if (t == SUCCESS) - t = gfc_check_vardef_context (e, false, _("pointer assignment")); + t = gfc_check_vardef_context (e, false, false, + _("pointer assignment")); gfc_free_expr (e); if (t == FAILURE) break; @@ -12340,6 +12377,17 @@ resolve_symbol (gfc_symbol *sym) sym->ts.u.derived->name) == FAILURE) return; + /* F2008, C1302. */ + if (sym->ts.type == BT_DERIVED + && sym->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV + && sym->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE + && !sym->attr.codimension) + { + gfc_error ("Variable '%s' at %L of type LOCK_TYPE must be a coarray", + sym->name, &sym->declared_at); + return; + } + /* An assumed-size array with INTENT(OUT) shall not be of a type for which default initialization is defined (5.1.2.4.4). */ if (sym->ts.type == BT_DERIVED @@ -12360,6 +12408,12 @@ resolve_symbol (gfc_symbol *sym) } } + /* F2008, C542. */ + if (sym->ts.type == BT_DERIVED && sym->attr.dummy + && sym->attr.intent == INTENT_OUT && sym->attr.lock_comp) + gfc_error ("Dummy argument '%s' at %L of LOCK_TYPE shall not be " + "INTENT(OUT)", sym->name, &sym->declared_at); + /* F2008, C526. */ if (((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp) || sym->attr.codimension) --------------090200050509060909070804--