From patchwork Sat May 3 22:08:51 2014 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: Tobias Burnus X-Patchwork-Id: 345365 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]) (using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (No client certificate requested) by ozlabs.org (Postfix) with ESMTPS id 00C851400CF for ; Sun, 4 May 2014 08:09:11 +1000 (EST) DomainKey-Signature: a=rsa-sha1; c=nofws; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender :message-id:date:from:mime-version:to:subject:content-type; q= dns; s=default; b=FPGM6x7/U71fY/vxYWBkygiou2tjzoHjurdHxxjL7SaedZ BzHmrBPJB2kcTi5lE4EvYj8yVOanmjL8s2jFyhyBWnO1OPAqsiPUpu96W4u0XP75 2vsNfil4hsbVG1f42H1+fmab4jYKCTawa0wg3jPqCuOAvvFJhyZ9ANAAtRPEA= DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender :message-id:date:from:mime-version:to:subject:content-type; s= default; bh=SLXOk1QVUvtfzVwyrFJJRMtxPvM=; b=rLl8Q/sb/OqWwZfL9pqL 878f131VPO9CVOceJOr+1YKLmsiRm0LN7q/V9/1maxHI+WI8PurbzwxK8WeGXQlT LY3yLh7jvPhkz7DYf4659tNXRhc5xMtWqlYLRmN17451t9g4S4KZlBhCIP4buxN/ X58CtFey4AAWYay2YC3dl58= Received: (qmail 8679 invoked by alias); 3 May 2014 22:08:58 -0000 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 Received: (qmail 8659 invoked by uid 89); 3 May 2014 22:08:57 -0000 Authentication-Results: sourceware.org; auth=none X-Virus-Found: No X-Spam-SWARE-Status: No, score=1.1 required=5.0 tests=AWL, BAYES_50, KAM_STOCKGEN, RCVD_IN_DNSWL_NONE autolearn=no version=3.3.2 X-Spam-User: qpsmtpd, 2 recipients X-HELO: mx02.qsc.de Received: from mx02.qsc.de (HELO mx02.qsc.de) (213.148.130.14) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with (AES256-SHA encrypted) ESMTPS; Sat, 03 May 2014 22:08:55 +0000 Received: from tux.net-b.de (port-92-194-125-118.dynamic.qsc.de [92.194.125.118]) (using TLSv1 with cipher DHE-RSA-AES256-SHA (256/256 bits)) (No client certificate requested) by mx02.qsc.de (Postfix) with ESMTPSA id E108627678; Sun, 4 May 2014 00:08:51 +0200 (CEST) Message-ID: <536568F3.1060909@net-b.de> Date: Sun, 04 May 2014 00:08:51 +0200 From: Tobias Burnus User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:24.0) Gecko/20100101 Thunderbird/24.3.0 MIME-Version: 1.0 To: gcc-patches , gfortran Subject: [Fortran, Patch] Some prep patches for coarray communication This patch is a teaser: It adds some preparation for coarray communication to the trunk, but it doesn't yet added the library calls. (In particular, note the "0 &&" in the conditions, which add the intrinsics.) The idea is that coindexed variables are wrapped in the intrinsic function caf_get(expr) and assignments to coindexed variables are wrapped into the subroutine caf_send(LHS, RHS). Both intrinsic procedures are only internally reachable. The intrinsic procedures are then converted into library calls in trans-intrinsic.c. (See fortran-caf branch.) I am not yet submitting the the trans-intrinsic.c part as I still want to restructure the current version – and I am also unsure how exactly I should handle allocatable components of coarrays. But as this part should be ready, I thought that I already submit it, reducing the differences between the branch and the trunk. However, I can also hold off this patch until it is actually used. Build on x86-64-gnu-linux. OK for the trunk? Tobias 2014-05-04 Tobias Burnus * gfortran.h (gfc_isym_id): Add GFC_ISYM_CAF_GET and GFC_ISYM_CAF_SEND. * intrinsic.c (add_functions): Add only internally accessible caf_get and caf_send functions. * resolve.c (add_caf_get_intrinsic, remove_caf_get_intrinsic): New functions. (resolve_variable): Resolve expression rank and prepare for add_caf_get_intrinsic call. (gfc_resolve_expr): For variables, remove rank resolution. (resolve_ordinary_assign): Prepare call to GFC_ISYM_CAF_SEND. (resolve_code): Avoid call to GFC_ISYM_CAF_GET for the LHS of an assignment. diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c index 852ae92..4c2eaa5 100644 --- a/gcc/fortran/intrinsic.c +++ b/gcc/fortran/intrinsic.c @@ -2758,3 +2758,3 @@ add_functions (void) /* Obtain the stride for a given dimensions; to be used only internally. - "make_from_module" makes inaccessible for external users. */ + "make_from_module" makes it inaccessible for external users. */ add_sym_2 (GFC_PREFIX ("stride"), GFC_ISYM_STRIDE, CLASS_INQUIRY, ACTUAL_NO, @@ -2996,2 +2996,9 @@ add_functions (void) make_generic ("loc", GFC_ISYM_LOC, GFC_STD_GNU); + + /* The following function is internally used for coarray libray functions. + "make_from_module" makes it inaccessible for external users. */ + add_sym_1 (GFC_PREFIX ("caf_get"), GFC_ISYM_CAF_GET, CLASS_IMPURE, ACTUAL_NO, + BT_REAL, dr, GFC_STD_GNU, NULL, NULL, NULL, + x, BT_REAL, dr, REQUIRED); + make_from_module(); } @@ -3237,2 +3244,11 @@ add_subroutines (void) + /* The following subroutine is internally used for coarray libray functions. + "make_from_module" makes it inaccessible for external users. */ + add_sym_2s (GFC_PREFIX ("caf_send"), GFC_ISYM_CAF_SEND, CLASS_IMPURE, + BT_UNKNOWN, 0, GFC_STD_GNU, NULL, NULL, NULL, + "x", BT_REAL, dr, REQUIRED, INTENT_OUT, + "y", BT_REAL, dr, REQUIRED, INTENT_IN); + make_from_module(); + + /* More G77 compatibility garbage. */ diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 63be8af..d654d2b 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -318,6 +318,8 @@ enum gfc_isym_id GFC_ISYM_BLE, GFC_ISYM_BLT, GFC_ISYM_BTEST, + GFC_ISYM_CAF_GET, + GFC_ISYM_CAF_SEND, GFC_ISYM_CEILING, GFC_ISYM_CHAR, GFC_ISYM_CHDIR, diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 15c9463..241b85e 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -4726,14 +4726,58 @@ expression_rank (gfc_expr *e) e->rank = rank; done: expression_shape (e); } +static void +add_caf_get_intrinsic (gfc_expr *e) +{ + gfc_expr *wrapper, *tmp_expr; + gfc_ref *ref; + int n; + + for (ref = e->ref; ref; ref = ref->next) + if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0) + break; + if (ref == NULL) + return; + + for (n = ref->u.ar.dimen; n < ref->u.ar.dimen + ref->u.ar.codimen; n++) + if (ref->u.ar.dimen_type[n] != DIMEN_ELEMENT) + return; + + tmp_expr = XCNEW (gfc_expr); + *tmp_expr = *e; + wrapper = gfc_build_intrinsic_call (gfc_current_ns, GFC_ISYM_CAF_GET, + "caf_get", tmp_expr->where, 1, tmp_expr); + wrapper->ts = e->ts; + wrapper->rank = e->rank; + if (e->rank) + wrapper->shape = gfc_copy_shape (e->shape, e->rank); + *e = *wrapper; + free (wrapper); +} + + +static void +remove_caf_get_intrinsic (gfc_expr *e) +{ + gcc_assert (e->expr_type == EXPR_FUNCTION && e->value.function.isym + && e->value.function.isym->id == GFC_ISYM_CAF_GET); + gfc_expr *e2 = e->value.function.actual->expr; + e->value.function.actual->expr =NULL; + gfc_free_actual_arglist (e->value.function.actual); + gfc_free_shape (&e->shape, e->rank); + *e = *e2; + free (e2); +} + + /* Resolve a variable expression. */ static bool resolve_variable (gfc_expr *e) { gfc_symbol *sym; bool t; @@ -5005,14 +5049,20 @@ resolve_procedure: "subcomponent at %L", &e->where); t = false; break; } } } + if (t) + expression_rank (e); + + if (0 && t && gfc_option.coarray == GFC_FCOARRAY_LIB && gfc_is_coindexed (e)) + add_caf_get_intrinsic (e); + return t; } /* Checks to see that the correct symbol has been host associated. The only situation where this arises is that in which a twice contained function is parsed after the host association is made. @@ -6088,19 +6138,15 @@ gfc_resolve_expr (gfc_expr *e) case EXPR_FUNCTION: case EXPR_VARIABLE: if (check_host_association (e)) t = resolve_function (e); else - { - t = resolve_variable (e); - if (t) - expression_rank (e); - } + t = resolve_variable (e); if (e->ts.type == BT_CHARACTER && e->ts.u.cl == NULL && e->ref && e->ref->type != REF_SUBSTRING) gfc_resolve_substring_charlen (e); break; @@ -9210,23 +9256,44 @@ resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns) { gfc_error ("Nonallocatable variable must not be polymorphic in intrinsic " "assignment at %L - check that there is a matching specific " "subroutine for '=' operator", &lhs->where); return false; } + bool lhs_coindexed = gfc_is_coindexed (lhs); + /* F2008, Section 7.2.1.2. */ - if (gfc_is_coindexed (lhs) && gfc_has_ultimate_allocatable (lhs)) + if (lhs_coindexed && gfc_has_ultimate_allocatable (lhs)) { gfc_error ("Coindexed variable must not have an allocatable ultimate " "component in assignment at %L", &lhs->where); return false; } gfc_check_assign (lhs, rhs, 1); + + if (0 && lhs_coindexed && gfc_option.coarray == GFC_FCOARRAY_LIB) + { + code->op = EXEC_CALL; + gfc_get_sym_tree (GFC_PREFIX ("caf_send"), ns, &code->symtree, true); + code->resolved_sym = code->symtree->n.sym; + code->resolved_sym->attr.flavor = FL_PROCEDURE; + code->resolved_sym->attr.intrinsic = 1; + code->resolved_sym->attr.subroutine = 1; + code->resolved_isym = gfc_intrinsic_subroutine_by_id (GFC_ISYM_CAF_SEND); + gfc_commit_symbol (code->resolved_sym); + code->ext.actual = gfc_get_actual_arglist (); + code->ext.actual->expr = lhs; + code->ext.actual->next = gfc_get_actual_arglist (); + code->ext.actual->next->expr = rhs; + code->expr1 = NULL; + code->expr2 = NULL; + } + return false; } /* Add a component reference onto an expression. */ static void @@ -9841,28 +9908,33 @@ resolve_code (gfc_code *code, gfc_namespace *ns) case EXEC_END_PROCEDURE: break; case EXEC_ASSIGN: if (!t) break; + if (code->expr1->expr_type == EXPR_FUNCTION + && code->expr1->value.function.isym + && code->expr1->value.function.isym->id == GFC_ISYM_CAF_GET) + remove_caf_get_intrinsic (code->expr1); + if (!gfc_check_vardef_context (code->expr1, false, false, false, _("assignment"))) break; if (resolve_ordinary_assign (code, ns)) { if (code->op == EXEC_COMPCALL) goto compcall; else goto call; } /* F03 7.4.1.3 for non-allocatable, non-pointer components. */ - if (code->expr1->ts.type == BT_DERIVED + if (code->op != EXEC_CALL && code->expr1->ts.type == BT_DERIVED && code->expr1->ts.u.derived->attr.defined_assign_comp) generate_component_assignments (&code, ns); break; case EXEC_LABEL_ASSIGN: if (code->label1->defined == ST_LABEL_UNKNOWN)