From patchwork Thu Jan 4 20:32:06 2018 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Thomas Koenig X-Patchwork-Id: 855811 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-470175-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="uqlZZo5r"; 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 3zCKH21jNjz9s7c for ; Fri, 5 Jan 2018 07:32:28 +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=rhEo0xhKo544o0PwLPX9G5vDazv18M/5tZA4SKVx5AV6/WV+S3 jUq+Jnx6dchxsuL1tiiK2MBv5Lhrr1JF4eHjF+El8LcV70emYRMuxwvWX2f933vZ pkWR2hQ0rO/HjWFWbcLiaiPuvFbFrJIEcQmfC7M/VmzEZY8YYfDAcr9v8= 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=SJxsWeDLjuoRDwqrquDv8XuE4uY=; b=uqlZZo5r9I4aDCcuvnNx t1r8rfmQEly5vHfq3QOgkGv2ebWHk7r/YqSeXtOpdf7Kxa7Ydg6jhfqhYeKnhkEv 8lQC1SIRXguJXNigBpjrTIVL2/LG4m1MsYn1417d3vynhsoO2CtM/Cg3EBTu6gb3 IIhNbX59i7yd5NCsn45xPUI= Received: (qmail 85494 invoked by alias); 4 Jan 2018 20:32: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 85477 invoked by uid 89); 4 Jan 2018 20:32:15 -0000 Authentication-Results: sourceware.org; auth=none X-Virus-Found: No X-Spam-SWARE-Status: No, score=-11.5 required=5.0 tests=AWL, BAYES_00, 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=17567, ij, ppp, a0 X-Spam-User: qpsmtpd, 2 recipients X-HELO: cc-smtpout3.netcologne.de Received: from cc-smtpout3.netcologne.de (HELO cc-smtpout3.netcologne.de) (89.1.8.213) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with ESMTP; Thu, 04 Jan 2018 20:32:12 +0000 Received: from cc-smtpin2.netcologne.de (cc-smtpin2.netcologne.de [89.1.8.202]) by cc-smtpout3.netcologne.de (Postfix) with ESMTP id 4415612B06; Thu, 4 Jan 2018 21:32:10 +0100 (CET) Received: from localhost (localhost [127.0.0.1]) by cc-smtpin2.netcologne.de (Postfix) with ESMTP id 37D0311DD8; Thu, 4 Jan 2018 21:32:10 +0100 (CET) Received: from [78.35.145.170] (helo=cc-smtpin2.netcologne.de) by localhost with ESMTP (eXpurgate 4.1.9) (envelope-from ) id 5a4e8f4a-02b8-7f0000012729-7f000001807a-1 for ; Thu, 04 Jan 2018 21:32:10 +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-smtpin2.netcologne.de (Postfix) with ESMTPSA; Thu, 4 Jan 2018 21:32:08 +0100 (CET) To: "fortran@gcc.gnu.org" , gcc-patches From: Thomas Koenig Subject: [patch, fortran] Simplify eoshift Message-ID: <59c16b15-38bb-6180-e7c8-1db647afbde3@netcologne.de> Date: Thu, 4 Jan 2018 21:32:06 +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, here is a patch for simplifying eoshift. Along the way, I discovered two ICEs caused by wrong arguments to eoshift, which are now also caught by new checks and a corresponding test case. This already passed all of the *eoshift* tests and is regression-testing as I write this. OK if it passes? Regards Thomas 2018-01-04 Thomas Koenig PR fortran/83683 PR fortran/45689 * check.c (gfc_check_eoshift): Check for string length and for conformance of boundary. * intrinsic.c (add_functions): Add gfc_simplify_eoshift. * intrinsic.h: Add prototype for gfc_simplify_eoshift. * simplify.c (gfc_simplify_eoshift): New function. 2018-01-04 Thomas Koenig PR fortran/83683 PR fortran/45689 * gfortran.dg/eoshift_8.f90: New test. * gfortran.dg/simplify_eoshift_1.f90: New test. Index: check.c =================================================================== --- check.c (Revision 256171) +++ check.c (Arbeitskopie) @@ -2185,6 +2185,8 @@ bool gfc_check_eoshift (gfc_expr *array, gfc_expr *shift, gfc_expr *boundary, gfc_expr *dim) { + int d; + if (!array_check (array, 0)) return false; @@ -2197,6 +2199,13 @@ gfc_check_eoshift (gfc_expr *array, gfc_expr *shif if (!dim_rank_check (dim, array, false)) return false; + if (!dim) + d = 1; + else if (dim->expr_type == EXPR_CONSTANT) + gfc_extract_int (dim, &d); + else + d = -1; + if (array->rank == 1 || shift->rank == 0) { if (!scalar_check (shift, 1)) @@ -2204,14 +2213,6 @@ gfc_check_eoshift (gfc_expr *array, gfc_expr *shif } else if (shift->rank == array->rank - 1) { - int d; - if (!dim) - d = 1; - else if (dim->expr_type == EXPR_CONSTANT) - gfc_extract_int (dim, &d); - else - d = -1; - if (d > 0) { int i, j; @@ -2246,6 +2247,24 @@ gfc_check_eoshift (gfc_expr *array, gfc_expr *shif if (!same_type_check (array, 0, boundary, 2)) return false; + /* Reject unequal string lengths and emit a better error message than + gfc_check_same_strlen would. */ + if (array->ts.type == BT_CHARACTER) + { + ssize_t len_a, len_b; + + len_a = gfc_var_strlen(array); + len_b = gfc_var_strlen(boundary); + if (len_a != -1 && len_b != -1 && len_a != len_b) + { + gfc_error ("%qs must be of same type and kind as %qs at %L in %qs", + gfc_current_intrinsic_arg[2]->name, + gfc_current_intrinsic_arg[0]->name, + &boundary->where, gfc_current_intrinsic); + return false; + } + } + if (array->rank == 1 || boundary->rank == 0) { if (!scalar_check (boundary, 2)) @@ -2253,13 +2272,27 @@ gfc_check_eoshift (gfc_expr *array, gfc_expr *shif } else if (boundary->rank == array->rank - 1) { - if (!gfc_check_conformance (shift, boundary, - "arguments '%s' and '%s' for " - "intrinsic %s", - gfc_current_intrinsic_arg[1]->name, - gfc_current_intrinsic_arg[2]->name, - gfc_current_intrinsic)) - return false; + if (d > 0) + { + int i,j; + for (i = 0, j = 0; i < array->rank; i++) + { + if (i != d - 1) + { + if (!identical_dimen_shape (array, i, boundary, j)) + { + gfc_error ("%qs argument of %qs intrinsic at %L has " + "invalid shape in dimension %d (%ld/%ld)", + gfc_current_intrinsic_arg[2]->name, + gfc_current_intrinsic, &shift->where, i+1, + mpz_get_si (array->shape[i]), + mpz_get_si (boundary->shape[j])); + return false; + } + j += 1; + } + } + } } else { Index: intrinsic.c =================================================================== --- intrinsic.c (Revision 256088) +++ intrinsic.c (Arbeitskopie) @@ -1756,7 +1756,7 @@ add_functions (void) make_generic ("dshiftr", GFC_ISYM_DSHIFTR, GFC_STD_F2008); add_sym_4 ("eoshift", GFC_ISYM_EOSHIFT, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95, - gfc_check_eoshift, NULL, gfc_resolve_eoshift, + gfc_check_eoshift, gfc_simplify_eoshift, gfc_resolve_eoshift, ar, BT_REAL, dr, REQUIRED, sh, BT_INTEGER, ii, REQUIRED, bd, BT_REAL, dr, OPTIONAL, dm, BT_INTEGER, ii, OPTIONAL); Index: intrinsic.h =================================================================== --- intrinsic.h (Revision 256088) +++ intrinsic.h (Arbeitskopie) @@ -287,6 +287,7 @@ gfc_expr *gfc_simplify_dot_product (gfc_expr *, gf gfc_expr *gfc_simplify_dreal (gfc_expr *); gfc_expr *gfc_simplify_dshiftl (gfc_expr *, gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_dshiftr (gfc_expr *, gfc_expr *, gfc_expr *); +gfc_expr *gfc_simplify_eoshift (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_epsilon (gfc_expr *); gfc_expr *gfc_simplify_erf (gfc_expr *); gfc_expr *gfc_simplify_erfc (gfc_expr *); Index: simplify.c =================================================================== --- simplify.c (Revision 256088) +++ simplify.c (Arbeitskopie) @@ -2348,6 +2348,271 @@ gfc_simplify_dshiftl (gfc_expr *arg1, gfc_expr *ar gfc_expr * +gfc_simplify_eoshift (gfc_expr *array, gfc_expr *shift, gfc_expr *boundary, + gfc_expr *dim) +{ + bool temp_boundary; + gfc_expr *bnd; + gfc_expr *result; + int which; + gfc_expr **arrayvec, **resultvec; + gfc_expr **rptr, **sptr; + mpz_t size; + size_t arraysize, i; + gfc_constructor *array_ctor, *shift_ctor, *bnd_ctor; + ssize_t shift_val, len; + ssize_t count[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS], + sstride[GFC_MAX_DIMENSIONS], a_extent[GFC_MAX_DIMENSIONS], + a_stride[GFC_MAX_DIMENSIONS], ss_ex[GFC_MAX_DIMENSIONS]; + ssize_t rsoffset; + int d, n; + bool continue_loop; + gfc_expr **src, **dest; + size_t s_len; + + if (!is_constant_array_expr (array)) + return NULL; + + if (shift->rank > 0) + gfc_simplify_expr (shift, 1); + + if (!gfc_is_constant_expr (shift)) + return NULL; + + if (boundary) + { + if (boundary->rank > 0) + gfc_simplify_expr (boundary, 1); + + if (!gfc_is_constant_expr (boundary)) + return NULL; + } + + if (dim) + { + if (!gfc_is_constant_expr (dim)) + return NULL; + which = mpz_get_si (dim->value.integer) - 1; + } + else + which = 0; + + s_len = 0; + if (boundary == NULL) + { + temp_boundary = true; + switch (array->ts.type) + { + + case BT_INTEGER: + bnd = gfc_get_int_expr (array->ts.kind, NULL, 0); + break; + + case BT_LOGICAL: + bnd = gfc_get_logical_expr (array->ts.kind, NULL, 0); + break; + + case BT_REAL: + bnd = gfc_get_constant_expr (array->ts.type, array->ts.kind, &gfc_current_locus); + mpfr_set_ui (bnd->value.real, 0, GFC_RND_MODE); + break; + + case BT_COMPLEX: + bnd = gfc_get_constant_expr (array->ts.type, array->ts.kind, &gfc_current_locus); + mpc_set_ui (bnd->value.complex, 0, GFC_RND_MODE); + break; + + case BT_CHARACTER: + s_len = mpz_get_ui (array->ts.u.cl->length->value.integer); + bnd = gfc_get_character_expr (array->ts.kind, &gfc_current_locus, NULL, s_len); + break; + + default: + gcc_unreachable(); + + } + } + else + { + temp_boundary = false; + bnd = boundary; + } + + gfc_array_size (array, &size); + arraysize = mpz_get_ui (size); + mpz_clear (size); + + result = gfc_get_array_expr (array->ts.type, array->ts.kind, &array->where); + result->shape = gfc_copy_shape (array->shape, array->rank); + result->rank = array->rank; + result->ts = array->ts; + + if (arraysize == 0) + goto final; + + arrayvec = XCNEWVEC (gfc_expr *, arraysize); + array_ctor = gfc_constructor_first (array->value.constructor); + for (i = 0; i < arraysize; i++) + { + arrayvec[i] = array_ctor->expr; + array_ctor = gfc_constructor_next (array_ctor); + } + + resultvec = XCNEWVEC (gfc_expr *, arraysize); + + extent[0] = 1; + count[0] = 0; + + for (d=0; d < array->rank; d++) + { + a_extent[d] = mpz_get_si (array->shape[d]); + a_stride[d] = d == 0 ? 1 : a_stride[d-1] * a_extent[d-1]; + } + + if (shift->rank > 0) + { + shift_ctor = gfc_constructor_first (shift->value.constructor); + shift_val = 0; + } + else + { + shift_ctor = NULL; + shift_val = mpz_get_si (shift->value.integer); + } + + if (bnd->rank > 0) + bnd_ctor = gfc_constructor_first (bnd->value.constructor); + else + bnd_ctor = NULL; + + /* Shut up compiler */ + len = 1; + rsoffset = 1; + + n = 0; + for (d=0; d < array->rank; d++) + { + if (d == which) + { + rsoffset = a_stride[d]; + len = a_extent[d]; + } + else + { + count[n] = 0; + extent[n] = a_extent[d]; + sstride[n] = a_stride[d]; + ss_ex[n] = sstride[n] * extent[n]; + n++; + } + } + + continue_loop = true; + d = array->rank; + rptr = resultvec; + sptr = arrayvec; + + while (continue_loop) + { + ssize_t sh, delta; + + if (shift_ctor) + sh = mpz_get_si (shift_ctor->expr->value.integer); + else + sh = shift_val; + + if (( sh >= 0 ? sh : -sh ) > len) + { + delta = len; + sh = len; + } + else + delta = (sh >= 0) ? sh: -sh; + + if (sh > 0) + { + src = &sptr[delta * rsoffset]; + dest = rptr; + } + else + { + src = sptr; + dest = &rptr[delta * rsoffset]; + } + + for (n = 0; n < len - delta; n++) + { + *dest = *src; + dest += rsoffset; + src += rsoffset; + } + + if (sh < 0) + dest = rptr; + + n = delta; + + if (bnd_ctor) + { + while (n--) + { + *dest = gfc_copy_expr (bnd_ctor->expr); + dest += rsoffset; + } + } + else + { + while (n--) + { + *dest = gfc_copy_expr (bnd); + dest += rsoffset; + } + } + rptr += sstride[0]; + sptr += sstride[0]; + if (shift_ctor) + shift_ctor = gfc_constructor_next (shift_ctor); + + if (bnd_ctor) + bnd_ctor = gfc_constructor_next (bnd_ctor); + + count[0]++; + n = 0; + while (count[n] == extent[n]) + { + count[n] = 0; + rptr -= ss_ex[n]; + sptr -= ss_ex[n]; + n++; + if (n >= d - 1) + { + continue_loop = false; + break; + } + else + { + count[n]++; + rptr += sstride[n]; + sptr += sstride[n]; + } + } + } + + for (i = 0; i < arraysize; i++) + { + gfc_constructor_append_expr (&result->value.constructor, + gfc_copy_expr (resultvec[i]), + NULL); + } + + final: + if (temp_boundary) + gfc_free_expr (bnd); + + return result; +} + +gfc_expr * gfc_simplify_erf (gfc_expr *x) { gfc_expr *result;