From patchwork Thu Nov 3 13:16:48 2016 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Andre Vehreschild X-Patchwork-Id: 80652 Delivered-To: patch@linaro.org Received: by 10.140.97.247 with SMTP id m110csp629495qge; Thu, 3 Nov 2016 06:17:17 -0700 (PDT) X-Received: by 10.99.232.17 with SMTP id s17mr13867875pgh.127.1478179037515; Thu, 03 Nov 2016 06:17:17 -0700 (PDT) Return-Path: Received: from sourceware.org (server1.sourceware.org. [209.132.180.131]) by mx.google.com with ESMTPS id t90si9557887pfi.85.2016.11.03.06.17.17 for (version=TLS1_2 cipher=ECDHE-RSA-AES128-GCM-SHA256 bits=128/128); Thu, 03 Nov 2016 06:17:17 -0700 (PDT) Received-SPF: pass (google.com: domain of gcc-patches-return-440320-patch=linaro.org@gcc.gnu.org designates 209.132.180.131 as permitted sender) client-ip=209.132.180.131; Authentication-Results: mx.google.com; dkim=pass header.i=@gcc.gnu.org; spf=pass (google.com: domain of gcc-patches-return-440320-patch=linaro.org@gcc.gnu.org designates 209.132.180.131 as permitted sender) smtp.mailfrom=gcc-patches-return-440320-patch=linaro.org@gcc.gnu.org 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=Y+us6375w8F8Hu1ozbFMkAdJ7OO39IMaN+WCycFSSalCo9RkdKIrf pGysrdxY5AfgeZnhNrvXeq0o1vS7PJrP1V5D8JlcgBUtYWSp5cwrvsr3vnTnoTOC sO1UATg/Wbog3bP8arCvIOZ14Uar4hjusqMfB4qBtAAUH6RTJnMevk= 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=3/3KAcnXTCSWbPIqjWpvRepUvYU=; b=HZBG8hNQYdS1+HzffETZ B9I9hjXDt+zyOyNNQFWInMH7oeiUF66sB7Jt79ioDCY2o639JVMjX+jyESFjulm1 sNqA8RmYcvOeMRzxcXQp5UY1GvXScCgYpCaahZl25kXrA0CDIlu/zsr1yYO4Nqr6 fdelSxhVOAormM41jwnE7x8= Received: (qmail 45646 invoked by alias); 3 Nov 2016 13:16: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 45625 invoked by uid 89); 3 Nov 2016 13:16:57 -0000 Authentication-Results: sourceware.org; auth=none X-Virus-Found: No X-Spam-SWARE-Status: No, score=-2.0 required=5.0 tests=BAYES_00, FREEMAIL_FROM, KAM_STOCKGEN, RCVD_IN_DNSWL_LOW, RCVD_IN_SORBS_SPAM, SPF_PASS autolearn=ham version=3.3.2 spammy=MOLD, type's, proposes, 2105 X-Spam-User: qpsmtpd, 2 recipients X-HELO: mout.gmx.net Received: from mout.gmx.net (HELO mout.gmx.net) (212.227.17.21) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with ESMTP; Thu, 03 Nov 2016 13:16:55 +0000 Received: from vepi2 ([84.59.211.84]) by mail.gmx.com (mrgmx101) with ESMTPSA (Nemesis) id 0MJGFi-1bzWzz2SF8-002qcn; Thu, 03 Nov 2016 14:16:49 +0100 Date: Thu, 3 Nov 2016 14:16:48 +0100 From: Andre Vehreschild To: GCC-Patches-ML , GCC-Fortran-ML , Dominique Dhumieres Subject: [PATCH, Fortran, v1] Restructure initialization of allocatable components Message-ID: <20161103141648.1c8c87c3@vepi2> MIME-Version: 1.0 X-UI-Out-Filterresults: notjunk:1; V01:K0:bcxHKmip3yE=:H0EL54rK0y8SG0Yoq28js5 aGX/t9fO7+eOc8P5Nwvd6j4AtrXkBkW2eNYZl6ExALHaeHBzpZgB+AcxDph0tMOTSi7rnRNb2 dAmQ8zy8F7aW580kXC5rvMbBV0IMvdqs0m0CaRb1Q677b1trpSicMAnv1mpbWzHKEb4Ixwx1y Ra44KY2k0wosN/fpL09v53Jjdno+AX5hBoY80c2vAtyRYzui0O9BGntZMUBBdOTZJlJ/n+xyR rN/YwabtJtMjRXsh19SvzpMoJ95R923laadg0uEdFuTgosNMChIBdZhfqwDwDxnHyVmKVIFDi 30un3Df1aBlpEpLtzzG9F77GeSJKn7XYNkz3qnQmRhBoUlakECqNVc3N4dD/kOn8kItaTw1ID xT98ehmS6gOkVauYW7EBvmAsOMIzsfoP0/yAojZLev6wSYlbRN8ZwvTcfEgY88ALIItl7EaZq I5Fdo4/1Q/uEqUSafH5ISUe7X+zxS5QWDjuDpJPg5CDF0fS7LGlLHlfpCkNwfdVQul43Z4AHb Nxa0/l6rsPe41s2gJQVJozLZObjrnoI7+xlNC3SMQy9xW5OM7e9Tv5GvQh9EyLTb6OXP3tJiz q2/kpBsbmF0ey7WePyYgIkQdR2NAivsY3qwhgnZaE/drrtXYsnhlQ7jUbXdOnETN/zDSCvsDL Q3bchlan2gzMr1biSgk0W7nIVvFOlx7FUfusvvlb8AuvR2W4vDI+2VUBAizt3wXK5y0Trc27c hlNXJAPgCXUJQ3/Sf6zfExXwnZOnr/X4VQPTJ6tISDedg1xyGnnJanVG/4w= Hi all, the attached patch restructures gfortran's way of initializing components of derived types in ALLOCATE. The old way was to generate a new gfc_code-node and add it after the ALLOCATE node to initialize the the derived type on certain conditions (like initializer or allocatable components exist). This patch proposes to do the initialization as part of the ALLOCATE. This way it makes the ALLOCATE-statement more atomic in that the ALLOCATE does everything it is responsible for itself and does rely on other nodes adding to its responsibilities. The patch furthermore enables to use the knowledge we have in the allocate, i.e., a freshly allocated object can never have allocated allocatable components, so no need to check before resetting them. At the same time I remove some dead code from the resolve_alloc_expr and moved a loop invariant piece out of the loop iterating over all objects to allocate. This of course is only cosmetic. Of course did I not do this out of fun. I have a patch upcoming for allocatable components in coarrayed derived types. For this I needed to identify the initialization of the structure and to parameterize it further. This was hard when for the default initialization an additional code-node was created, but now that everything necessary for ALLOCATE is done in ALLOCATE parameterizing the initialization is way easier. The coarray patch is not yet perfect, but I thought to publish this part already to get your opinions. Bootstraps and regtests fine on x86_64-linux/F23. Ok for trunk? @Dominique: Would you give it a go on your open patch collection? Maybe it fixes one PR, but I am not very hopeful, because the patch is merely removing complexity instead of doing new things. Regards, Andre -- Andre Vehreschild * Email: vehre ad gmx dot de diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index bb183d4..0e94ae8 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -4131,6 +4131,26 @@ gfc_apply_init (gfc_typespec *ts, symbol_attribute *attr, gfc_expr *init) } +/* Check whether an expression is a structure constructor and whether it has + other values than NULL. */ + +bool +is_non_empty_structure_constructor (gfc_expr * e) +{ + if (e->expr_type != EXPR_STRUCTURE) + return false; + + gfc_constructor *cons = gfc_constructor_first (e->value.constructor); + while (cons) + { + if (!cons->expr || cons->expr->expr_type != EXPR_NULL) + return true; + cons = gfc_constructor_next (cons); + } + return false; +} + + /* Check for default initializer; sym->value is not enough as it is also set for EXPR_NULL of allocatables. */ @@ -4145,7 +4165,9 @@ gfc_has_default_initializer (gfc_symbol *der) { if (!c->attr.pointer && !c->attr.proc_pointer && !(c->attr.allocatable && der == c->ts.u.derived) - && gfc_has_default_initializer (c->ts.u.derived)) + && ((c->initializer + && is_non_empty_structure_constructor (c->initializer)) + || gfc_has_default_initializer (c->ts.u.derived))) return true; if (c->attr.pointer && c->initializer) return true; diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 14685d2..c341bbc 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -7046,35 +7046,6 @@ conformable_arrays (gfc_expr *e1, gfc_expr *e2) return true; } -static void -cond_init (gfc_code *code, gfc_expr *e, int pointer, gfc_expr *init_e) -{ - gfc_code *block; - gfc_expr *cond; - gfc_code *init_st; - gfc_expr *e_to_init = gfc_expr_to_initialize (e); - - cond = pointer - ? gfc_build_intrinsic_call (gfc_current_ns, GFC_ISYM_ASSOCIATED, - "associated", code->loc, 2, gfc_copy_expr (e_to_init), NULL) - : gfc_build_intrinsic_call (gfc_current_ns, GFC_ISYM_ALLOCATED, - "allocated", code->loc, 1, gfc_copy_expr (e_to_init)); - - init_st = gfc_get_code (EXEC_INIT_ASSIGN); - init_st->loc = code->loc; - init_st->expr1 = e_to_init; - init_st->expr2 = init_e; - - block = gfc_get_code (EXEC_IF); - block->loc = code->loc; - block->block = gfc_get_code (EXEC_IF); - block->block->loc = code->loc; - block->block->expr1 = cond; - block->block->next = init_st; - block->next = code->next; - - code->next = block; -} /* Resolve the expression in an ALLOCATE statement, doing the additional checks to see whether the expression is OK or not. The expression must @@ -7325,34 +7296,6 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code, bool *array_alloc_wo_spec) /* We have to zero initialize the integer variable. */ code->expr3 = gfc_get_int_expr (gfc_default_integer_kind, &e->where, 0); } - else if (!code->expr3) - { - /* Set up default initializer if needed. */ - gfc_typespec ts; - gfc_expr *init_e; - - if (gfc_bt_struct (code->ext.alloc.ts.type)) - ts = code->ext.alloc.ts; - else - ts = e->ts; - - if (ts.type == BT_CLASS) - ts = ts.u.derived->components->ts; - - if (gfc_bt_struct (ts.type) && (init_e = gfc_default_initializer (&ts))) - cond_init (code, e, pointer, init_e); - } - else if (code->expr3->mold && code->expr3->ts.type == BT_DERIVED) - { - /* Default initialization via MOLD (non-polymorphic). */ - gfc_expr *rhs = gfc_default_initializer (&code->expr3->ts); - if (rhs != NULL) - { - gfc_resolve_expr (rhs); - gfc_free_expr (code->expr3); - code->expr3 = rhs; - } - } if (e->ts.type == BT_CLASS && !unlimited && !UNLIMITED_POLY (code->expr3)) { @@ -7364,10 +7307,9 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code, bool *array_alloc_wo_spec) else if (code->ext.alloc.ts.type == BT_DERIVED) ts = code->ext.alloc.ts; + /* Finding the vtab also publishes the type's symbol. Therefore this + statement is necessary. */ gfc_find_derived_vtab (ts.u.derived); - - if (dimension) - e = gfc_expr_to_initialize (e); } else if (unlimited && !UNLIMITED_POLY (code->expr3)) { @@ -7381,10 +7323,9 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code, bool *array_alloc_wo_spec) gcc_assert (ts); + /* Finding the vtab also publishes the type's symbol. Therefore this + statement is necessary. */ gfc_find_vtab (ts); - - if (dimension) - e = gfc_expr_to_initialize (e); } if (dimension == 0 && codimension == 0) @@ -7688,6 +7629,22 @@ resolve_allocate_deallocate (gfc_code *code, const char *fcn) if (strcmp (fcn, "ALLOCATE") == 0) { bool arr_alloc_wo_spec = false; + + /* Resolving the expr3 in the loop over all objects to allocate would + execute loop invariant code for each loop item. Therefore do it just + once here. */ + if (code->expr3 && code->expr3->mold + && code->expr3->ts.type == BT_DERIVED) + { + /* Default initialization via MOLD (non-polymorphic). */ + gfc_expr *rhs = gfc_default_initializer (&code->expr3->ts); + if (rhs != NULL) + { + gfc_resolve_expr (rhs); + gfc_free_expr (code->expr3); + code->expr3 = rhs; + } + } for (a = code->ext.alloc.list; a; a = a->next) resolve_allocate_expr (a->expr, code, &arr_alloc_wo_spec); diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 74935b1..1708f7c 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -5623,14 +5623,6 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg, else gfc_add_expr_to_block (&se->pre, set_descriptor); - if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->attr.alloc_comp - && !coarray) - { - tmp = gfc_nullify_alloc_comp (expr->ts.u.derived, se->expr, - ref->u.ar.as->rank); - gfc_add_expr_to_block (&se->pre, tmp); - } - return true; } diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 7159b17..b5bcb22 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -10036,7 +10036,7 @@ gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, tree gfc_trans_init_assign (gfc_code * code) { - return gfc_trans_assignment (code->expr1, code->expr2, true, false); + return gfc_trans_assignment (code->expr1, code->expr2, true, false, true); } tree diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index c52066f..490b18d 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -5450,13 +5450,41 @@ gfc_trans_exit (gfc_code * code) } +/* Get the initializer expression for the code and expr of an allocate. + When no initializer is needed return NULL. */ + +static gfc_expr * +allocate_get_initializer (gfc_code * code, gfc_expr * expr) +{ + if (!gfc_bt_struct (expr->ts.type) && expr->ts.type != BT_CLASS) + return NULL; + + /* An explicit type was given in allocate ( T:: object). */ + if (code->ext.alloc.ts.type == BT_DERIVED + && (code->ext.alloc.ts.u.derived->attr.alloc_comp + || gfc_has_default_initializer (code->ext.alloc.ts.u.derived))) + return gfc_default_initializer (&code->ext.alloc.ts); + + if (gfc_bt_struct (expr->ts.type) + && (expr->ts.u.derived->attr.alloc_comp + || gfc_has_default_initializer (expr->ts.u.derived))) + return gfc_default_initializer (&expr->ts); + + if (expr->ts.type == BT_CLASS + && (CLASS_DATA (expr)->ts.u.derived->attr.alloc_comp + || gfc_has_default_initializer (CLASS_DATA (expr)->ts.u.derived))) + return gfc_default_initializer (&CLASS_DATA (expr)->ts); + + return NULL; +} + /* Translate the ALLOCATE statement. */ tree gfc_trans_allocate (gfc_code * code) { gfc_alloc *al; - gfc_expr *expr, *e3rhs = NULL; + gfc_expr *expr, *e3rhs = NULL, *init_expr; gfc_se se, se_sz; tree tmp; tree parm; @@ -6080,14 +6108,6 @@ gfc_trans_allocate (gfc_code * code) label_finish, expr, 0); else gfc_allocate_using_malloc (&se.pre, se.expr, memsz, stat); - - if (al->expr->ts.type == BT_DERIVED - && expr->ts.u.derived->attr.alloc_comp) - { - tmp = build_fold_indirect_ref_loc (input_location, se.expr); - tmp = gfc_nullify_alloc_comp (expr->ts.u.derived, tmp, 0); - gfc_add_expr_to_block (&se.pre, tmp); - } } else { @@ -6217,6 +6237,8 @@ gfc_trans_allocate (gfc_code * code) fold_convert (TREE_TYPE (al_len), integer_zero_node)); } + + init_expr = NULL; if (code->expr3 && !code->expr3->mold && e3_is != E3_MOLD) { /* Initialization via SOURCE block (or static default initializer). @@ -6246,6 +6268,23 @@ gfc_trans_allocate (gfc_code * code) gfc_free_statements (ini); gfc_add_expr_to_block (&block, tmp); } + else if ((init_expr = allocate_get_initializer (code, expr))) + { + /* Use class_init_assign to initialize expr. */ + gfc_code *ini; + int realloc_lhs = flag_realloc_lhs; + ini = gfc_get_code (EXEC_INIT_ASSIGN); + ini->expr1 = gfc_expr_to_initialize (expr); + ini->expr2 = init_expr; + flag_realloc_lhs = 0; + tmp= gfc_trans_init_assign (ini); + flag_realloc_lhs = realloc_lhs; + gfc_free_statements (ini); + /* Init_expr is freeed by above free_statements, just need to null + it here. */ + init_expr = NULL; + gfc_add_expr_to_block (&block, tmp); + } gfc_free_expr (expr); } // for-loop diff --git a/gcc/testsuite/gfortran.dg/allocate_with_source_14.f03 b/gcc/testsuite/gfortran.dg/allocate_with_source_14.f03 index 36c1245..fd2db74 100644 --- a/gcc/testsuite/gfortran.dg/allocate_with_source_14.f03 +++ b/gcc/testsuite/gfortran.dg/allocate_with_source_14.f03 @@ -210,5 +210,5 @@ program main call v%free() deallocate(av) end program -! { dg-final { scan-tree-dump-times "__builtin_malloc" 23 "original" } } +! { dg-final { scan-tree-dump-times "__builtin_malloc" 22 "original" } } ! { dg-final { scan-tree-dump-times "__builtin_free" 29 "original" } }