From patchwork Thu Jul 21 13:31:02 2016 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Andre Vehreschild X-Patchwork-Id: 651186 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 3rwF6p3Qhqz9sBR for ; Thu, 21 Jul 2016 23:31:29 +1000 (AEST) Authentication-Results: ozlabs.org; dkim=pass (1024-bit key; unprotected) header.d=gcc.gnu.org header.i=@gcc.gnu.org header.b=t4lp2oKk; dkim-atps=neutral DomainKey-Signature: a=rsa-sha1; c=nofws; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender:date :from:to:subject:message-id:mime-version:content-type; q=dns; s= default; b=hNC8XmuxXeUX+MW17itAT7zhGgvfpxsLaV3h67dGMP935Mhkq0nXM fUum2fmGC3AYvxOSYuWuMm3AV7BZu6zKsjflUjIiFuSOPDgmwUZEKUQvku+1G1Mq SjE1bW+ez8Vdw47BlT/WpbcAdIBx5DxSsUKWOurbjFwkFKWnIvSjwA= 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:date :from:to:subject:message-id:mime-version:content-type; s= default; bh=2w+3hQE4N8t9q/ClvSNF8Bz8jt4=; b=t4lp2oKkS4Rdd/aJRYD2 IJbEi0SX4XUS8Lj1b6g3RpeAjjA9l7fMnzoWOs/ILn0hx8kCKmMFOY3QCjZF15HQ RYcA0D2S7SFep+/njUltEPhR3REjKBzJnIxbVS7CVn13NLXOezr8l5JOUQ1pWmEj Po7QnmWJzXBXAOY8QzROEx8= Received: (qmail 120730 invoked by alias); 21 Jul 2016 13:31:16 -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 120685 invoked by uid 89); 21 Jul 2016 13:31:12 -0000 Authentication-Results: sourceware.org; auth=none X-Virus-Found: No X-Spam-SWARE-Status: No, score=-2.3 required=5.0 tests=AWL, BAYES_00, FREEMAIL_FROM, RCVD_IN_DNSWL_LOW, SPF_PASS autolearn=ham version=3.3.2 spammy=3287, 328, 7, resides, TOKEN X-Spam-User: qpsmtpd, 2 recipients X-HELO: mout.gmx.net Received: from mout.gmx.net (HELO mout.gmx.net) (212.227.17.20) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with ESMTP; Thu, 21 Jul 2016 13:31:10 +0000 Received: from vepi2 ([92.209.45.60]) by mail.gmx.com (mrgmx101) with ESMTPSA (Nemesis) id 0M4jbN-1b7bJa3dgj-00yxT6; Thu, 21 Jul 2016 15:31:04 +0200 Date: Thu, 21 Jul 2016 15:31:02 +0200 From: Andre Vehreschild To: GCC-Fortran-ML , GCC-Patches-ML Subject: [Fortran, patch, v1] Add STAT= support to caf_single get()/send() Message-ID: <20160721153102.585a4e8d@vepi2> MIME-Version: 1.0 X-UI-Out-Filterresults: notjunk:1; V01:K0:uibATRcwifI=:jakx6mQe6fHB7zJw/T6Cnu 80F5auC/c14mMczj/5ExnalTYfnq0K7ix56hmRAxtt+4aw+Bx7b12Jk2dateCrALdl8f7Yn5r /RuKlhhs+6mX+bQUr5UT86iHXil7BkdhRdh16dNV9V3UZsMdv2IP3qZXDkabkdZkYglUJdmTj peEBlvJ0wWI/NEtHgHlUWhIHabLBHdq8ZkC1CK9uDpSBOv/d4WIRg7MJqPu7EeeRs97ltVwmj fWb+4EYDus+Gu7uejjfWTPEkVOhjBbNtpJKn2ZrcJXP9poqzY9Wbqu7dMxD9HvRzlLdz10cU8 arPSzG39eW8TItvRpXRzVXqA2r1dVtPOILO8+WDxHpHGFEhSUBY9G2/G37m7F5IIQrnIBgims w9m4aXqEO2jM4ajJlU254O5hcEaj46xJ3zv1cCAj2MCDokvv+q2zquR1/T9DYmx87RCufsZqw o+Z58yAJ3+50tl34ZVOBgm8up3/0pCIVhkRJ7CNFY8A9H0smOXhldWKFooZ3lVgPLPYI+5ccn e8gESj/KuOFKL7apPu2lT3dMsnvjLZuqIjwI5xM8ZQDj0/WZRlnY8CTlqlccCx7ozSYLL3B11 VVJhohqA1pxG3JF6emwymgpOugPMyANa5uCotuASOTWxwfxN2fAcAJ4g9QiM8D2fUSnSyDP8N TkMXLs5+AeqDLFn07BKLsLN+IWCdvbwkOdWc50IxloFrzbgCrGvXsweOTnZV/9ZCOkjavQUn6 /A8XuEZJGZ19mxcrhoMoragDeqOxk7I2qfy4eirocscsm0yvj6EYBy8VJlI= Hi all, the attached patch adds support for a stat parameter to caf_single's caf_get() and caf_send() routines and adds a testcase. Unfortunately is there not much that can go wrong in a caf_single's get/send, so the test resides to check whether stat is reset correctly. Bootstraps and regtests ok on x86_64-linux/F23. Ok for trunk? Regards, Andre diff --git a/gcc/testsuite/gfortran.dg/coarray_stat_2.f90 b/gcc/testsuite/gfortran.dg/coarray_stat_2.f90 new file mode 100644 index 0000000..3bbd3fc --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray_stat_2.f90 @@ -0,0 +1,23 @@ +! { dg-do run } +! { dg-options "-fcoarray=lib -lcaf_single" } +! +! Support for stat= in caf reference +! +program whitespace + implicit none + + integer :: me[*],tmp,stat + + me = this_image() + stat = 0 + + sync all(stat = stat) + + if(stat /= 0) write(*,*) 'failure during sync' + + stat = 42 + + tmp = me[num_images(),stat = stat] + if(stat /= 0) call abort() + +end program whitespace diff --git a/libgfortran/caf/libcaf.h b/libgfortran/caf/libcaf.h index 01a33f9..863b5b4 100644 --- a/libgfortran/caf/libcaf.h +++ b/libgfortran/caf/libcaf.h @@ -121,9 +121,11 @@ void _gfortran_caf_co_reduce (gfc_descriptor_t *, void* (*) (void *, void*), int, int, int *, char *, int, int); void _gfortran_caf_get (caf_token_t, size_t, int, gfc_descriptor_t *, - caf_vector_t *, gfc_descriptor_t *, int, int, bool); + caf_vector_t *, gfc_descriptor_t *, int, int, bool, + int *); void _gfortran_caf_send (caf_token_t, size_t, int, gfc_descriptor_t *, - caf_vector_t *, gfc_descriptor_t *, int, int, bool); + caf_vector_t *, gfc_descriptor_t *, int, int, bool, + int *); void _gfortran_caf_sendget (caf_token_t, size_t, int, gfc_descriptor_t *, caf_vector_t *, caf_token_t, size_t, int, gfc_descriptor_t *, caf_vector_t *, int, int, bool); diff --git a/libgfortran/caf/single.c b/libgfortran/caf/single.c index f726537..21916d3 100644 --- a/libgfortran/caf/single.c +++ b/libgfortran/caf/single.c @@ -328,7 +328,7 @@ assign_char1_from_char4 (size_t dst_size, size_t src_size, unsigned char *dst, static void convert_type (void *dst, int dst_type, int dst_kind, void *src, int src_type, - int src_kind) + int src_kind, int *stat) { #ifdef HAVE_GFC_INTEGER_16 typedef __int128 int128t; @@ -581,7 +581,10 @@ convert_type (void *dst, int dst_type, int dst_kind, void *src, int src_type, error: fprintf (stderr, "libcaf_single RUNTIME ERROR: Cannot convert type %d kind " "%d to type %d kind %d\n", src_type, src_kind, dst_type, dst_kind); - abort(); + if (stat) + *stat = 1; + else + abort (); } @@ -591,7 +594,7 @@ _gfortran_caf_get (caf_token_t token, size_t offset, gfc_descriptor_t *src, caf_vector_t *src_vector __attribute__ ((unused)), gfc_descriptor_t *dest, int src_kind, int dst_kind, - bool may_require_tmp) + bool may_require_tmp, int *stat) { /* FIXME: Handle vector subscripts. */ size_t i, k, size; @@ -600,6 +603,9 @@ _gfortran_caf_get (caf_token_t token, size_t offset, size_t src_size = GFC_DESCRIPTOR_SIZE (src); size_t dst_size = GFC_DESCRIPTOR_SIZE (dest); + if (stat) + *stat = 0; + if (rank == 0) { void *sr = (void *) ((char *) TOKEN (token) + offset); @@ -626,7 +632,7 @@ _gfortran_caf_get (caf_token_t token, size_t offset, sr); else convert_type (GFC_DESCRIPTOR_DATA (dest), GFC_DESCRIPTOR_TYPE (dest), - dst_kind, sr, GFC_DESCRIPTOR_TYPE (src), src_kind); + dst_kind, sr, GFC_DESCRIPTOR_TYPE (src), src_kind, stat); return; } @@ -710,7 +716,7 @@ _gfortran_caf_get (caf_token_t token, size_t offset, assign_char4_from_char1 (dst_size, src_size, dst, sr); else convert_type (dst, GFC_DESCRIPTOR_TYPE (dest), dst_kind, - sr, GFC_DESCRIPTOR_TYPE (src), src_kind); + sr, GFC_DESCRIPTOR_TYPE (src), src_kind, stat); array_offset_sr += src_size; } @@ -770,7 +776,7 @@ _gfortran_caf_get (caf_token_t token, size_t offset, assign_char4_from_char1 (dst_size, src_size, dst, sr); else convert_type (dst, GFC_DESCRIPTOR_TYPE (dest), dst_kind, - sr, GFC_DESCRIPTOR_TYPE (src), src_kind); + sr, GFC_DESCRIPTOR_TYPE (src), src_kind, stat); } } @@ -781,7 +787,7 @@ _gfortran_caf_send (caf_token_t token, size_t offset, gfc_descriptor_t *dest, caf_vector_t *dst_vector __attribute__ ((unused)), gfc_descriptor_t *src, int dst_kind, int src_kind, - bool may_require_tmp) + bool may_require_tmp, int *stat) { /* FIXME: Handle vector subscripts. */ size_t i, k, size; @@ -790,6 +796,9 @@ _gfortran_caf_send (caf_token_t token, size_t offset, size_t src_size = GFC_DESCRIPTOR_SIZE (src); size_t dst_size = GFC_DESCRIPTOR_SIZE (dest); + if (stat) + *stat = 0; + if (rank == 0) { void *dst = (void *) ((char *) TOKEN (token) + offset); @@ -816,7 +825,7 @@ _gfortran_caf_send (caf_token_t token, size_t offset, else convert_type (dst, GFC_DESCRIPTOR_TYPE (dest), dst_kind, GFC_DESCRIPTOR_DATA (src), GFC_DESCRIPTOR_TYPE (src), - src_kind); + src_kind, stat); return; } @@ -909,7 +918,7 @@ _gfortran_caf_send (caf_token_t token, size_t offset, assign_char4_from_char1 (dst_size, src_size, dst, sr); else convert_type (dst, GFC_DESCRIPTOR_TYPE (dest), dst_kind, - sr, GFC_DESCRIPTOR_TYPE (src), src_kind); + sr, GFC_DESCRIPTOR_TYPE (src), src_kind, stat); if (GFC_DESCRIPTOR_RANK (src)) array_offset_sr += src_size; } @@ -976,7 +985,7 @@ _gfortran_caf_send (caf_token_t token, size_t offset, assign_char4_from_char1 (dst_size, src_size, dst, sr); else convert_type (dst, GFC_DESCRIPTOR_TYPE (dest), dst_kind, - sr, GFC_DESCRIPTOR_TYPE (src), src_kind); + sr, GFC_DESCRIPTOR_TYPE (src), src_kind, stat); } } @@ -997,7 +1006,7 @@ _gfortran_caf_sendget (caf_token_t dst_token, size_t dst_offset, void *src_base = GFC_DESCRIPTOR_DATA (src); GFC_DESCRIPTOR_DATA (src) = (void *) ((char *) TOKEN (src_token) + src_offset); _gfortran_caf_send (dst_token, dst_offset, dst_image_index, dest, dst_vector, - src, dst_kind, src_kind, may_require_tmp); + src, dst_kind, src_kind, may_require_tmp, NULL); GFC_DESCRIPTOR_DATA (src) = src_base; }