From patchwork Fri Nov 20 20:09:47 2015 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: Steve Kargl X-Patchwork-Id: 547035 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 DFB8214030F for ; Sat, 21 Nov 2015 07:10:05 +1100 (AEDT) Authentication-Results: ozlabs.org; dkim=pass (1024-bit key; unprotected) header.d=gcc.gnu.org header.i=@gcc.gnu.org header.b=CGr1Y0/T; 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:references:mime-version:content-type :content-transfer-encoding:in-reply-to; q=dns; s=default; b=E2YO fu6LXaBmSvwvTxaOtBA9cY1NOwiXw0cGwevC89Yu7pk777QraEyL4LBP+tJd+E3Z be7zpHoxo1/UPZANV7xtW7h8fwTuuPj32Jg/iY1WsjX0yMmKwU+8A5V4b0/9NJLP doIh1KaWh8eYuLN0Oo7mcKmZ2HiVd1zWKAK6UR4= 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:references:mime-version:content-type :content-transfer-encoding:in-reply-to; s=default; bh=rEz69o0iD4 bwNXHs/BbAr1FbpXY=; b=CGr1Y0/T7yPv8lQIH/MkcuF5Qb6hrjAwd0IqmhaAMe 4gBsGKuLSbt19zefopkQrv4ahhJbNe8h5jS6vFhVC0KKguJu9yNJsYzbEn+0adD5 H/WHL9X0w9UzcTEx9bUVgo+WXu5F+iHUmpJlCPxcDEDJGYT18aKuW33n+wQET4+x U= Received: (qmail 10224 invoked by alias); 20 Nov 2015 20:09:53 -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 10207 invoked by uid 89); 20 Nov 2015 20:09:53 -0000 Authentication-Results: sourceware.org; auth=none X-Virus-Found: No X-Spam-SWARE-Status: No, score=0.1 required=5.0 tests=AWL, BAYES_50, KAM_ASCII_DIVIDERS, KAM_LAZY_DOMAIN_SECURITY, RP_MATCHES_RCVD autolearn=no version=3.3.2 X-Spam-User: qpsmtpd, 2 recipients X-HELO: troutmask.apl.washington.edu Received: from troutmask.apl.washington.edu (HELO troutmask.apl.washington.edu) (128.95.76.21) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with (AES256-GCM-SHA384 encrypted) ESMTPS; Fri, 20 Nov 2015 20:09:51 +0000 Received: from troutmask.apl.washington.edu (localhost [127.0.0.1]) by troutmask.apl.washington.edu (8.15.2/8.15.2) with ESMTPS id tAKK9nCC061360 (version=TLSv1.2 cipher=DHE-RSA-AES256-GCM-SHA384 bits=256 verify=NO); Fri, 20 Nov 2015 12:09:49 -0800 (PST) (envelope-from sgk@troutmask.apl.washington.edu) Received: (from sgk@localhost) by troutmask.apl.washington.edu (8.15.2/8.15.2/Submit) id tAKK9lt0061359; Fri, 20 Nov 2015 12:09:47 -0800 (PST) (envelope-from sgk) Date: Fri, 20 Nov 2015 12:09:47 -0800 From: Steve Kargl To: fortran@gcc.gnu.org, gcc-patches@gcc.gnu.org Subject: Re: [PATCH] (Partial) Implementation of simplificaiton of CSHIFT Message-ID: <20151120200947.GA61350@troutmask.apl.washington.edu> References: <20151120005836.GA53763@troutmask.apl.washington.edu> MIME-Version: 1.0 Content-Disposition: inline In-Reply-To: <20151120005836.GA53763@troutmask.apl.washington.edu> User-Agent: Mutt/1.5.24 (2015-08-30) On Thu, Nov 19, 2015 at 04:58:36PM -0800, Steve Kargl wrote: > > 2015-11-19 Steven G. Kargl > > * intrinsic.h: Prototype for gfc_simplify_cshift > * intrinsic.c (add_functions): Use gfc_simplify_cshift. > * simplify.c (gfc_simplify_cshift): Implement simplification of CSHIFT. > (gfc_simplify_spread): Remove a FIXME and add error condition. > > 2015-11-19 Steven G. Kargl > > * gfortran.dg/simplify_cshift_1.f90: New test. > I've attached an updated patch. The changes consists of 1) better/more comments 2) re-organize code to reduce copying of the array. 3) add optimization for a left/right shift that returns the original array. 4) Don't leak memory. Index: gcc/fortran/intrinsic.c =================================================================== --- gcc/fortran/intrinsic.c (revision 230585) +++ gcc/fortran/intrinsic.c (working copy) @@ -1659,9 +1659,11 @@ add_functions (void) make_generic ("count", GFC_ISYM_COUNT, GFC_STD_F95); - add_sym_3 ("cshift", GFC_ISYM_CSHIFT, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95, - gfc_check_cshift, NULL, gfc_resolve_cshift, - ar, BT_REAL, dr, REQUIRED, sh, BT_INTEGER, di, REQUIRED, + add_sym_3 ("cshift", GFC_ISYM_CSHIFT, CLASS_TRANSFORMATIONAL, ACTUAL_NO, + BT_REAL, dr, GFC_STD_F95, + gfc_check_cshift, gfc_simplify_cshift, gfc_resolve_cshift, + ar, BT_REAL, dr, REQUIRED, + sh, BT_INTEGER, di, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL); make_generic ("cshift", GFC_ISYM_CSHIFT, GFC_STD_F95); Index: gcc/fortran/intrinsic.h =================================================================== --- gcc/fortran/intrinsic.h (revision 230585) +++ gcc/fortran/intrinsic.h (working copy) @@ -271,6 +271,7 @@ gfc_expr *gfc_simplify_conjg (gfc_expr * gfc_expr *gfc_simplify_cos (gfc_expr *); gfc_expr *gfc_simplify_cosh (gfc_expr *); gfc_expr *gfc_simplify_count (gfc_expr *, gfc_expr *, gfc_expr *); +gfc_expr *gfc_simplify_cshift (gfc_expr *, gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_dcmplx (gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_dble (gfc_expr *); gfc_expr *gfc_simplify_digits (gfc_expr *); Index: gcc/fortran/simplify.c =================================================================== --- gcc/fortran/simplify.c (revision 230585) +++ gcc/fortran/simplify.c (working copy) @@ -1789,6 +1789,99 @@ gfc_simplify_count (gfc_expr *mask, gfc_ gfc_expr * +gfc_simplify_cshift (gfc_expr *array, gfc_expr *shift, gfc_expr *dim) +{ + int dm; + gfc_expr *a; + + /* DIM is only useful for rank > 1, but deal with it here as one can + set DIM = 1 for rank = 1. */ + if (dim) + { + if (!gfc_is_constant_expr (dim)) + return NULL; + dm = mpz_get_si (dim->value.integer); + } + else + dm = 1; + + /* Copy array into 'a', simplify it, and then test for a constant array. + Unexpected expr_type cause an ICE. */ + switch (array->expr_type) + { + case EXPR_VARIABLE: + case EXPR_ARRAY: + a = gfc_copy_expr (array); + gfc_simplify_expr (a, 0); + if (!is_constant_array_expr (a)) + { + gfc_free_expr (a); + return NULL; + } + break; + default: + gcc_unreachable (); + } + + if (a->rank == 1) + { + gfc_constructor *ca, *cr; + gfc_expr *result; + mpz_t size; + int i, j, shft, sz; + + if (!gfc_is_constant_expr (shift)) + { + gfc_free_expr (a); + return NULL; + } + + shft = mpz_get_si (shift->value.integer); + + /* Case (i): If ARRAY has rank one, element i of the result is + ARRAY (1 + MODULO (i + SHIFT ­ 1, SIZE (ARRAY))). */ + + mpz_init (size); + gfc_array_size (a, &size); + sz = mpz_get_si (size); + mpz_clear (size); + + /* Special case: rank 1 array with no shift or a complete shift to + the original order! */ + if (shft == 0 || shft == sz || shft == 1 - sz) + return a; + + /* Adjust shft to deal with right or left shifts. */ + shft = shft < 0 ? 1 - shft : shft; + + result = gfc_copy_expr (a); + cr = gfc_constructor_first (result->value.constructor); + for (i = 0; i < sz; i++, cr = gfc_constructor_next (cr)) + { + j = (i + shft) % sz; + ca = gfc_constructor_first (a->value.constructor); + while (j-- > 0) + ca = gfc_constructor_next (ca); + cr->expr = gfc_copy_expr (ca->expr); + } + + gfc_free_expr (a); + return result; + } + else + { + /* FIXME: Deal with rank > 1 arrays. For now, don't leak memory + and exit with an error message. */ + gfc_free_expr (a); + gfc_error ("Simplification of CSHIFT with an array with rank > 1 " + "no yet support"); + } + + return NULL; +} + + +gfc_expr * gfc_simplify_dcmplx (gfc_expr *x, gfc_expr *y) { return simplify_cmplx ("DCMPLX", x, y, gfc_default_double_kind); @@ -6089,10 +6182,11 @@ gfc_simplify_spread (gfc_expr *source, g } } else - /* FIXME: Returning here avoids a regression in array_simplify_1.f90. - Replace NULL with gcc_unreachable() after implementing - gfc_simplify_cshift(). */ - return NULL; + { + gfc_error ("Simplification of SPREAD at %L not yet implemented", + &source->where); + return &gfc_bad_expr; + } if (source->ts.type == BT_CHARACTER) result->ts.u.cl = source->ts.u.cl; Index: gcc/testsuite/gfortran.dg/simplify_cshift_1.f90 =================================================================== --- gcc/testsuite/gfortran.dg/simplify_cshift_1.f90 (nonexistent) +++ gcc/testsuite/gfortran.dg/simplify_cshift_1.f90 (working copy) @@ -0,0 +1,46 @@ +! { dg-do run } +program foo + + implicit none + + type t + integer i + end type t + + type(t), parameter :: d(5) = [t(1), t(2), t(3), t(4), t(5)] + type(t) e(5), q(5) + + integer, parameter :: a(5) = [1, 2, 3, 4, 5] + integer i, b(5), c(5), v(5) + + c = [1, 2, 3, 4, 5] + + b = cshift(a, -2) + v = cshift(c, -2) + if (any(b /= v)) call abort + + b = cshift(a, 2) + v = cshift(c, 2) + if (any(b /= v)) call abort + + ! Special cases shift = 0, size(a), 1-size(a) + b = cshift([1, 2, 3, 4, 5], 0) + if (any(b /= a)) call abort + b = cshift([1, 2, 3, 4, 5], size(a)) + if (any(b /= a)) call abort + b = cshift([1, 2, 3, 4, 5], 1-size(a)) + if (any(b /= a)) call abort + + ! simplification of array arg. + b = cshift(2 * a, 0) + if (any(b /= 2 * a)) call abort + + ! An array of derived types workd too. + e = [t(1), t(2), t(3), t(4), t(5)] + e = cshift(e, 3) + q = cshift(d, 3) + do i = 1, 5 + if (e(i)%i /= q(i)%i) call abort + end do + +end program foo