From patchwork Sun Dec 31 14:48:13 2017 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Thomas Koenig X-Patchwork-Id: 854221 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Authentication-Results: ozlabs.org; spf=pass (mailfrom) smtp.mailfrom=gcc.gnu.org (client-ip=209.132.180.131; helo=sourceware.org; envelope-from=gcc-patches-return-469924-incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=) Authentication-Results: ozlabs.org; dkim=pass (1024-bit key; unprotected) header.d=gcc.gnu.org header.i=@gcc.gnu.org header.b="LHKllYZ4"; dkim-atps=neutral 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 3z8jrP3FZlz9s7n for ; Mon, 1 Jan 2018 01:48:50 +1100 (AEDT) DomainKey-Signature: a=rsa-sha1; c=nofws; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender:to :from:subject:message-id:date:mime-version:content-type; q=dns; s=default; b=qy9m3m/KR4vy6n+jwmfqwGf/hm4BQdgzHRcnkjp4h7sB/JuGL6 95QbKrZ4TM5DjEADUOceYFjxbQuqDF+CIgLoVnRFKZDh3G2JEMmQn+t+jzb2SqD/ NDzQFxYKaCxL8aocsQoVZlmV7+BR+CCi11KRHmcA1G+6fVZ6EPGT/9BAA= 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:to :from:subject:message-id:date:mime-version:content-type; s= default; bh=mAQ9EIY/uU1/augputeCOmsufHU=; b=LHKllYZ4Zh49TW4eqGDQ a6e5NQqiTKIc5xNRy9QwRU4upgplsUnF33U8p0lASclRb2hDl5Ggmk0zLCYHY1+m EQ4ae90+xGRleb2d58OAO/R/Upr8zgjzn3K5IZ1lmjasg6yH7R94aw102J7rdTig dnTiCVis1EirAGoG/7tWVGA= Received: (qmail 37179 invoked by alias); 31 Dec 2017 14:48:36 -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 37152 invoked by uid 89); 31 Dec 2017 14:48:35 -0000 Authentication-Results: sourceware.org; auth=none X-Virus-Found: No X-Spam-SWARE-Status: No, score=-15.4 required=5.0 tests=AWL, BAYES_00, GIT_PATCH_1, GIT_PATCH_2, GIT_PATCH_3, KAM_ASCII_DIVIDERS, RCVD_IN_DNSWL_LOW, SPF_PASS, T_RP_MATCHES_RCVD autolearn=ham version=3.3.2 spammy=n1, 2307, ranks, MASK X-Spam-User: qpsmtpd, 2 recipients X-HELO: cc-smtpout2.netcologne.de Received: from cc-smtpout2.netcologne.de (HELO cc-smtpout2.netcologne.de) (89.1.8.212) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with ESMTP; Sun, 31 Dec 2017 14:48:24 +0000 Received: from cc-smtpin3.netcologne.de (cc-smtpin3.netcologne.de [89.1.8.203]) by cc-smtpout2.netcologne.de (Postfix) with ESMTP id 0608A12929; Sun, 31 Dec 2017 15:48:17 +0100 (CET) Received: from localhost (localhost [127.0.0.1]) by cc-smtpin3.netcologne.de (Postfix) with ESMTP id EDDAB11D7B; Sun, 31 Dec 2017 15:48:16 +0100 (CET) Received: from [78.35.145.170] (helo=cc-smtpin3.netcologne.de) by localhost with ESMTP (eXpurgate 4.1.9) (envelope-from ) id 5a48f8b0-02b7-7f0000012729-7f000001a8b8-1 for ; Sun, 31 Dec 2017 15:48:16 +0100 Received: from [192.168.178.20] (xdsl-78-35-145-170.netcologne.de [78.35.145.170]) (using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (No client certificate requested) by cc-smtpin3.netcologne.de (Postfix) with ESMTPSA; Sun, 31 Dec 2017 15:48:15 +0100 (CET) To: "fortran@gcc.gnu.org" , gcc-patches From: Thomas Koenig Subject: [patch, fortran] Implement simplification of minloc and maxloc Message-ID: Date: Sun, 31 Dec 2017 15:48:13 +0100 User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:52.0) Gecko/20100101 Thunderbird/52.5.0 MIME-Version: 1.0 Hello world, the attached patch implements the simplification for minloc and maxloc. I had considered using the existing simplify_transformation_to_array and simplify_transformation_to_scalar functions, but it turned out that the special casing required for minloc/maxloc was just too complex, so I wrote new functions (mostly copying the old ones). This closes a significant hole in F2003 - with this implemented, only finalization is left as only partially implemented. Regression-tested. OK for trunk? Regards Thomas 2017-12-31 Thomas Koenig PR fortran/45689 * intrinsic.c (add_function): Add gfc_simplify_maxloc and gfc_simplify_minloc to maxloc and minloc, respectively. * intrinsic.h: Add prototypes for gfc_simplify_minloc and gfc_simplify_maxloc. * simplify.c (min_max_chose): Adjust prototype. Modify function to have a return value which indicates if the extremum was found. (...): Fix typo in comment. (simplify_minmaxloc_to_scalar): New function. (simplify_minmaxloc_nodim): New function. (new_array): New function. (simplify_minmaxloc_to_array): New function. (gfc_simplify_minmaxloc): New function. (simplify_minloc): New function. (simplify_maxloc): New function. 2017-12-31 Thomas Koenig PR fortran/45689 * gfortran.dg/minloc_4.f90: New test case. * gfortran.dg/maxloc_4.f90: New test case. Index: intrinsic.c =================================================================== --- intrinsic.c (Revision 255788) +++ intrinsic.c (Arbeitskopie) @@ -2458,7 +2458,7 @@ add_functions (void) make_generic ("maxexponent", GFC_ISYM_MAXEXPONENT, GFC_STD_F95); add_sym_4ml ("maxloc", GFC_ISYM_MAXLOC, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95, - gfc_check_minloc_maxloc, NULL, gfc_resolve_maxloc, + gfc_check_minloc_maxloc, gfc_simplify_maxloc, gfc_resolve_maxloc, ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL, msk, BT_LOGICAL, dl, OPTIONAL, kind, BT_INTEGER, di, OPTIONAL); @@ -2534,7 +2534,7 @@ add_functions (void) make_generic ("minexponent", GFC_ISYM_MINEXPONENT, GFC_STD_F95); add_sym_4ml ("minloc", GFC_ISYM_MINLOC, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95, - gfc_check_minloc_maxloc, NULL, gfc_resolve_minloc, + gfc_check_minloc_maxloc, gfc_simplify_minloc, gfc_resolve_minloc, ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL, msk, BT_LOGICAL, dl, OPTIONAL, kind, BT_INTEGER, di, OPTIONAL); Index: intrinsic.h =================================================================== --- intrinsic.h (Revision 255788) +++ intrinsic.h (Arbeitskopie) @@ -347,8 +347,10 @@ gfc_expr *gfc_simplify_maskr (gfc_expr *, gfc_expr gfc_expr *gfc_simplify_merge (gfc_expr *, gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_merge_bits (gfc_expr *, gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_min (gfc_expr *); +gfc_expr *gfc_simplify_minloc (gfc_expr*, gfc_expr *, gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_minval (gfc_expr *, gfc_expr*, gfc_expr*); gfc_expr *gfc_simplify_max (gfc_expr *); +gfc_expr *gfc_simplify_maxloc (gfc_expr*, gfc_expr *, gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_maxval (gfc_expr *, gfc_expr*, gfc_expr*); gfc_expr *gfc_simplify_maxexponent (gfc_expr *); gfc_expr *gfc_simplify_minexponent (gfc_expr *); Index: simplify.c =================================================================== --- simplify.c (Revision 255788) +++ simplify.c (Arbeitskopie) @@ -31,7 +31,7 @@ along with GCC; see the file COPYING3. If not see /* Prototypes. */ -static void min_max_choose (gfc_expr *, gfc_expr *, int); +static int min_max_choose (gfc_expr *, gfc_expr *, int); gfc_expr gfc_bad_expr; @@ -230,7 +230,7 @@ convert_boz (gfc_expr *x, int kind) } -/* Test that the expression is an constant array, simplifying if +/* Test that the expression is a constant array, simplifying if we are dealing with a parameter array. */ static bool @@ -4414,25 +4414,34 @@ gfc_simplify_merge_bits (gfc_expr *i, gfc_expr *j, /* Selects between current value and extremum for simplify_min_max and simplify_minval_maxval. */ -static void +static int min_max_choose (gfc_expr *arg, gfc_expr *extremum, int sign) { + int ret; + switch (arg->ts.type) { case BT_INTEGER: - if (mpz_cmp (arg->value.integer, - extremum->value.integer) * sign > 0) - mpz_set (extremum->value.integer, arg->value.integer); + ret = mpz_cmp (arg->value.integer, + extremum->value.integer) * sign; + if (ret > 0) + mpz_set (extremum->value.integer, arg->value.integer); break; case BT_REAL: - /* We need to use mpfr_min and mpfr_max to treat NaN properly. */ - if (sign > 0) - mpfr_max (extremum->value.real, extremum->value.real, - arg->value.real, GFC_RND_MODE); + if (mpfr_nan_p (extremum->value.real)) + { + ret = 1; + mpfr_set (extremum->value.real, arg->value.real, GFC_RND_MODE); + } + else if (mpfr_nan_p (arg->value.real)) + ret = -1; else - mpfr_min (extremum->value.real, extremum->value.real, - arg->value.real, GFC_RND_MODE); + { + ret = mpfr_cmp (arg->value.real, extremum->value.real) * sign; + if (ret > 0) + mpfr_set (extremum->value.real, arg->value.real, GFC_RND_MODE); + } break; case BT_CHARACTER: @@ -4451,8 +4460,8 @@ min_max_choose (gfc_expr *arg, gfc_expr *extremum, LENGTH(extremum) = LENGTH(arg); free (tmp); } - - if (gfc_compare_string (arg, extremum) * sign > 0) + ret = gfc_compare_string (arg, extremum) * sign; + if (ret > 0) { free (STRING(extremum)); STRING(extremum) = gfc_get_wide_string (LENGTH(extremum) + 1); @@ -4469,6 +4478,7 @@ min_max_choose (gfc_expr *arg, gfc_expr *extremum, default: gfc_internal_error ("simplify_min_max(): Bad type in arglist"); } + return ret; } @@ -4581,7 +4591,385 @@ gfc_simplify_maxval (gfc_expr *array, gfc_expr* di } +/* Transform minloc or maxloc of an array, according to MASK, + to the scalar result. This code is mostly identical to + simplify_transformation_to_scalar. */ + +static gfc_expr * +simplify_minmaxloc_to_scalar (gfc_expr *result, gfc_expr *array, gfc_expr *mask, + gfc_expr *extremum, int sign) +{ + gfc_expr *a, *m; + gfc_constructor *array_ctor, *mask_ctor; + mpz_t count; + + mpz_set_si (result->value.integer, 0); + + + /* Shortcut for constant .FALSE. MASK. */ + if (mask + && mask->expr_type == EXPR_CONSTANT + && !mask->value.logical) + return result; + + array_ctor = gfc_constructor_first (array->value.constructor); + if (mask && mask->expr_type == EXPR_ARRAY) + mask_ctor = gfc_constructor_first (mask->value.constructor); + else + mask_ctor = NULL; + + mpz_init_set_si (count, 0); + while (array_ctor) + { + mpz_add_ui (count, count, 1); + a = array_ctor->expr; + array_ctor = gfc_constructor_next (array_ctor); + /* A constant MASK equals .TRUE. here and can be ignored. */ + if (mask_ctor) + { + m = mask_ctor->expr; + mask_ctor = gfc_constructor_next (mask_ctor); + if (!m->value.logical) + continue; + } + if (min_max_choose (a, extremum, sign) > 0) + mpz_set (result->value.integer, count); + } + mpz_clear (count); + gfc_free_expr (extremum); + return result; +} + +/* Simplify minloc / maxloc in the absence of a dim argument. */ + +static gfc_expr * +simplify_minmaxloc_nodim (gfc_expr *result, gfc_expr *extremum, + gfc_expr *array, gfc_expr *mask, int sign) +{ + ssize_t res[GFC_MAX_DIMENSIONS]; + int i, n; + gfc_constructor *result_ctor, *array_ctor, *mask_ctor; + ssize_t count[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS], + sstride[GFC_MAX_DIMENSIONS]; + gfc_expr *a, *m; + bool continue_loop; + bool ma; + + for (i = 0; irank; i++) + res[i] = -1; + + /* Shortcut for constant .FALSE. MASK. */ + if (mask + && mask->expr_type == EXPR_CONSTANT + && !mask->value.logical) + goto finish; + + for (i = 0; i < array->rank; i++) + { + count[i] = 0; + sstride[i] = (i == 0) ? 1 : sstride[i-1] * mpz_get_si (array->shape[i-1]); + extent[i] = mpz_get_si (array->shape[i]); + if (extent[i] <= 0) + goto finish; + } + + continue_loop = true; + array_ctor = gfc_constructor_first (array->value.constructor); + if (mask && mask->rank > 0) + mask_ctor = gfc_constructor_first (mask->value.constructor); + else + mask_ctor = NULL; + + /* Loop over the array elements (and mask), keeping track of + the indices to return. */ + while (continue_loop) + { + do + { + a = array_ctor->expr; + if (mask_ctor) + { + m = mask_ctor->expr; + ma = m->value.logical; + mask_ctor = gfc_constructor_next (mask_ctor); + } + else + ma = true; + + if (ma && min_max_choose (a, extremum, sign) > 0) + { + for (i = 0; irank; i++) + res[i] = count[i]; + } + array_ctor = gfc_constructor_next (array_ctor); + count[0] ++; + } while (count[0] != extent[0]); + n = 0; + do + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + n++; + if (n >= array->rank) + { + continue_loop = false; + break; + } + else + count[n] ++; + } while (count[n] == extent[n]); + } + + finish: + gfc_free_expr (extremum); + result_ctor = gfc_constructor_first (result->value.constructor); + for (i = 0; irank; i++) + { + gfc_expr *r_expr; + r_expr = result_ctor->expr; + mpz_set_si (r_expr->value.integer, res[i] + 1); + result_ctor = gfc_constructor_next (result_ctor); + } + return result; +} + +/* Helper function for gfc_simplify_minmaxloc - build an arry + expression with n elements. */ + +static gfc_expr * +new_array (bt type, int kind, int n, locus *where) +{ + gfc_expr *result; + int i; + + result = gfc_get_array_expr (type, kind, where); + result->rank = 1; + result->shape = gfc_get_shape(1); + mpz_init_set_si (result->shape[0], n); + for (i = 0; i < n; i++) + { + gfc_constructor_append_expr (&result->value.constructor, + gfc_get_constant_expr (type, kind, where), + NULL); + } + + return result; +} + +/* Simplify minloc and maxloc. This code is mostly identical to + simplify_transformation_to_array. */ + +static gfc_expr * +simplify_minmaxloc_to_array (gfc_expr *result, gfc_expr *array, + gfc_expr *dim, gfc_expr *mask, + gfc_expr *extremum, int sign) +{ + mpz_t size; + int done, i, n, arraysize, resultsize, dim_index, dim_extent, dim_stride; + gfc_expr **arrayvec, **resultvec, **base, **src, **dest; + gfc_constructor *array_ctor, *mask_ctor, *result_ctor; + + int count[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS], + sstride[GFC_MAX_DIMENSIONS], dstride[GFC_MAX_DIMENSIONS], + tmpstride[GFC_MAX_DIMENSIONS]; + + /* Shortcut for constant .FALSE. MASK. */ + if (mask + && mask->expr_type == EXPR_CONSTANT + && !mask->value.logical) + return result; + + /* Build an indexed table for array element expressions to minimize + linked-list traversal. Masked elements are set to NULL. */ + gfc_array_size (array, &size); + arraysize = mpz_get_ui (size); + mpz_clear (size); + + arrayvec = XCNEWVEC (gfc_expr*, arraysize); + + array_ctor = gfc_constructor_first (array->value.constructor); + mask_ctor = NULL; + if (mask && mask->expr_type == EXPR_ARRAY) + mask_ctor = gfc_constructor_first (mask->value.constructor); + + for (i = 0; i < arraysize; ++i) + { + arrayvec[i] = array_ctor->expr; + array_ctor = gfc_constructor_next (array_ctor); + + if (mask_ctor) + { + if (!mask_ctor->expr->value.logical) + arrayvec[i] = NULL; + + mask_ctor = gfc_constructor_next (mask_ctor); + } + } + + /* Same for the result expression. */ + gfc_array_size (result, &size); + resultsize = mpz_get_ui (size); + mpz_clear (size); + + resultvec = XCNEWVEC (gfc_expr*, resultsize); + result_ctor = gfc_constructor_first (result->value.constructor); + for (i = 0; i < resultsize; ++i) + { + resultvec[i] = result_ctor->expr; + result_ctor = gfc_constructor_next (result_ctor); + } + + gfc_extract_int (dim, &dim_index); + dim_index -= 1; /* zero-base index */ + dim_extent = 0; + dim_stride = 0; + + for (i = 0, n = 0; i < array->rank; ++i) + { + count[i] = 0; + tmpstride[i] = (i == 0) ? 1 : tmpstride[i-1] * mpz_get_si (array->shape[i-1]); + if (i == dim_index) + { + dim_extent = mpz_get_si (array->shape[i]); + dim_stride = tmpstride[i]; + continue; + } + + extent[n] = mpz_get_si (array->shape[i]); + sstride[n] = tmpstride[i]; + dstride[n] = (n == 0) ? 1 : dstride[n-1] * extent[n-1]; + n += 1; + } + + done = false; + base = arrayvec; + dest = resultvec; + while (!done) + { + gfc_expr *ex; + ex = gfc_copy_expr (extremum); + for (src = base, n = 0; n < dim_extent; src += dim_stride, ++n) + { + if (*src && min_max_choose (*src, ex, sign) > 0) + mpz_set_si ((*dest)->value.integer, n + 1); + } + + count[0]++; + base += sstride[0]; + dest += dstride[0]; + gfc_free_expr (ex); + + n = 0; + while (!done && count[n] == extent[n]) + { + count[n] = 0; + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + + n++; + if (n < result->rank) + { + /* If the nested loop is unrolled GFC_MAX_DIMENSIONS + times, we'd warn for the last iteration, because the + array index will have already been incremented to the + array sizes, and we can't tell that this must make + the test against result->rank false, because ranks + must not exceed GFC_MAX_DIMENSIONS. */ + GCC_DIAGNOSTIC_PUSH_IGNORED (-Warray-bounds) + count[n]++; + base += sstride[n]; + dest += dstride[n]; + GCC_DIAGNOSTIC_POP + } + else + done = true; + } + } + + /* Place updated expression in result constructor. */ + result_ctor = gfc_constructor_first (result->value.constructor); + for (i = 0; i < resultsize; ++i) + { + result_ctor->expr = resultvec[i]; + result_ctor = gfc_constructor_next (result_ctor); + } + + free (arrayvec); + free (resultvec); + free (extremum); + return result; +} + +/* Simplify minloc and maxloc for constant arrays. */ + gfc_expr * +gfc_simplify_minmaxloc (gfc_expr *array, gfc_expr *dim, gfc_expr *mask, + gfc_expr *kind, int sign) +{ + gfc_expr *result; + gfc_expr *extremum; + int ikind; + int init_val; + + if (!is_constant_array_expr (array) + || !gfc_is_constant_expr (dim)) + return NULL; + + if (mask + && !is_constant_array_expr (mask) + && mask->expr_type != EXPR_CONSTANT) + return NULL; + + if (kind) + { + if (gfc_extract_int (kind, &ikind, -1)) + return NULL; + } + else + ikind = gfc_default_integer_kind; + + if (sign < 0) + init_val = INT_MAX; + else if (sign > 0) + init_val = INT_MIN; + else + gcc_unreachable(); + + extremum = gfc_get_constant_expr (array->ts.type, array->ts.kind, &array->where); + init_result_expr (extremum, init_val, array); + + if (dim) + { + result = transformational_result (array, dim, BT_INTEGER, + ikind, &array->where); + init_result_expr (result, 0, array); + + if (array->rank == 1) + return simplify_minmaxloc_to_scalar (result, array, mask, extremum, sign); + else + return simplify_minmaxloc_to_array (result, array, dim, mask, extremum, sign); + } + else + { + result = new_array (BT_INTEGER, ikind, array->rank, &array->where); + return simplify_minmaxloc_nodim (result, extremum, array, mask, sign); + } +} + +gfc_expr * +gfc_simplify_minloc (gfc_expr *array, gfc_expr *dim, gfc_expr *mask, gfc_expr *kind) +{ + return gfc_simplify_minmaxloc (array, dim, mask, kind, -1); +} + +gfc_expr * +gfc_simplify_maxloc (gfc_expr *array, gfc_expr *dim, gfc_expr *mask, gfc_expr *kind) +{ + return gfc_simplify_minmaxloc (array, dim, mask, kind, 1); +} + +gfc_expr * gfc_simplify_maxexponent (gfc_expr *x) { int i = gfc_validate_kind (BT_REAL, x->ts.kind, false);