From patchwork Tue Jun 11 12:56:35 2024 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Andre Vehreschild X-Patchwork-Id: 1946336 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@legolas.ozlabs.org Authentication-Results: legolas.ozlabs.org; dkim=pass (2048-bit key; secure) header.d=gmx.de header.i=vehre@gmx.de header.a=rsa-sha256 header.s=s31663417 header.b=XM/A68y6; dkim-atps=neutral Authentication-Results: legolas.ozlabs.org; spf=pass (sender SPF authorized) smtp.mailfrom=gcc.gnu.org (client-ip=2620:52:3:1:0:246e:9693:128c; helo=server2.sourceware.org; envelope-from=gcc-patches-bounces+incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=patchwork.ozlabs.org) Received: from server2.sourceware.org (server2.sourceware.org [IPv6:2620:52:3:1:0:246e:9693:128c]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits) key-exchange X25519 server-signature ECDSA (secp384r1) server-digest SHA384) (No client certificate requested) by legolas.ozlabs.org (Postfix) with ESMTPS id 4Vz80Z3stTz1ydW for ; Tue, 11 Jun 2024 23:00:14 +1000 (AEST) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id D0987385E45B for ; Tue, 11 Jun 2024 13:00:12 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from mout.gmx.net (mout.gmx.net [212.227.15.18]) by sourceware.org (Postfix) with ESMTPS id 1E24E3857340; Tue, 11 Jun 2024 12:57:05 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org 1E24E3857340 Authentication-Results: sourceware.org; dmarc=pass (p=quarantine dis=none) header.from=gmx.de Authentication-Results: sourceware.org; spf=pass smtp.mailfrom=gmx.de ARC-Filter: OpenARC Filter v1.0.0 sourceware.org 1E24E3857340 Authentication-Results: server2.sourceware.org; arc=none smtp.remote-ip=212.227.15.18 ARC-Seal: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1718110628; cv=none; b=a8mLsGEiVScs/sBqijFsHNqmpUFnUENVyZXKaenQltl662mLwkNQyiNTPCKtAdSCwt8jKYeUnCawSzWWGwyRPCBzoYWVa+XApuCiyG3q35jcSOXdLDakLdGAgzrMQ64bdQdViYuOmMP8LiBtwG1/aN3dwfhH9OfuydARHsCEuhQ= ARC-Message-Signature: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1718110628; c=relaxed/simple; bh=ISPspmMHohxDkZ6XmDBhDIylprzPM1k247t99ollMeA=; h=DKIM-Signature:Date:From:To:Subject:Message-ID:MIME-Version; b=PioUbLCv/1u+rLCt86DvbZKc8Gg48B5/GauQu3+pLrVbuKAvg8vGg0SENrKnFCx6LtZIyB6FKI4D4EF5AlgMg09CWkdLMRq1iB7qjYo/t9yfwSTBFMM5KbeddwefnXQ55mjedGQz5FYRhQ79giQ47WbCSlJd3Mpu1nVU2FPp1c4= ARC-Authentication-Results: i=1; server2.sourceware.org DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gmx.de; s=s31663417; t=1718110624; x=1718715424; i=vehre@gmx.de; bh=oiiujjLj5ygXoPzszK9VnuIXyPcYSArLN+bec4b/kbE=; h=X-UI-Sender-Class:Date:From:To:Subject:Message-ID:MIME-Version: Content-Type:cc:content-transfer-encoding:content-type:date:from: message-id:mime-version:reply-to:subject:to; b=XM/A68y6wszj6ZtRhUZqWsZJozkurCDXGcuqa7Ghue+RQxGruMbd49ZMU1g/sshq VO44t2vHBO0/G8hLa9n20PK5XNJ34DcJHA5+P+4U1hQ5OiQyABX4T2ddQAqAlmTVg QvxlO0aHxtDNjtuYzn0k8YwejKMmjnKAz8ecEOTN8SpKnBn6CAbdSwySd1Xx1TP3S n03ZDnq53ciPItax7QpcCOXeodEzZdFNbFBtnU3cqyrWmE2UdIdIqxzPfR0ZiioKv 1FUwr/Zh0Q5nXo/aWBovSHVnzQUoN7exr+ImEqr1sKnr8Kd1sF/DM3TfD6kc6R7fB MTDOIaTPNiK2qV48lg== X-UI-Sender-Class: 724b4f7f-cbec-4199-ad4e-598c01a50d3a Received: from vepi2 ([62.155.205.192]) by mail.gmx.net (mrgmx005 [212.227.17.190]) with ESMTPSA (Nemesis) id 1My32L-1scp1c3YEB-011F1M; Tue, 11 Jun 2024 14:57:03 +0200 Date: Tue, 11 Jun 2024 14:56:35 +0200 From: Andre Vehreschild To: GCC-Patches-ML , GCC-Fortran-ML Subject: [Patch, Fortran] 3/3 RFC: Introduce gfc_class_set_vptr. Message-ID: <20240611145635.4fe0aa25@vepi2> X-Mailer: Claws Mail 4.2.0 (GTK 3.24.41; x86_64-redhat-linux-gnu) MIME-Version: 1.0 X-Provags-ID: V03:K1:g8SOxUbmKIPUdmyZI82e00obE818/pcdx8qGDNgDwosnrg+/QUe RUdhyPX8SytAERLBRxmAwkW0/BGKtA3OMpTw3ahVQof4VOTOnEtDWXBnwjr6BwaPHtyV0q4 Mh2NqKyXypHC+wJxWdVz2ynCIL94zzBmJB5f2hDbiBiBr+AkkC94QyrEES8IW1bD1fVdldY 4Zlh0UUdFeq4tb5Ghzd+Q== UI-OutboundReport: notjunk:1;M01:P0:Ri66bFfAFvo=;LDQK2uLYC2MTXAVjYNf5lzlfUxi 0OnILvPB8/3HHlyoQB7OozGf4p8oFUJJrTsu8MpXSfS29/7ekBBJ1xu5Ed0IR2R3jwV7TBpGi BT3Tvhcpx4+8whJqDxff//LiFkDrIWjmX69f69kZyYuzBOh9jcHXTd1Mvf3O85wHtWbaisn8I V7Rz266kmLz03sS6/v8ZmmNXi7kVm9tiKPMgaISrxGZVgllfQOAbuq9Pdu61bAAU6N3JD5GUj MCiwblXXYd7SXtI7caGsCTREUdVFASTr5Wua3uCfgN9/YYDqygbJ0PCPZktjlVMAH8CWM+/+h 9+wUldsr4i3uEUCQesBpdRPyn3tFiHLzf2D6mcpWuvEFyK2us9h7IekWQpWHzQ5wQ3Oit8RuV wAXH2v+nSwf0MxKocq7TImKiCjXbp56AOcGaP/ypgBWn6D/9+OgKLk3u/7okpQQb45ceF5PmD aLIu97IS2J7uKJjtwc2apEDIYZdzowT5oId7HDrL9SBYiuF1beQ+HeUgHGYxN8AeGk2gHH5sy 30EMYmDPZubQiziy+TFY4BcDvbsp7HBuuxfUn1wMGsqPNZv/CipMX19NpSlHvfRXWHeZwbJHw JSwLEkaTB8BeV/PZ4jsdiF4dk+VpX0WNDT92smDjZarTK6hOLaeMV7VcAV89N6Zxi8O46nX8n zLTQFxX9TS6H6jxVAxxmGkXKXTTelnuI+75taKp5dI44VYEREw3coY7xQrjzYawH8tZPZd2EM Jabd3Q2qbQyyqHeWy1NcM1IIkdI+NQ73nk+RMWn0FWwBLsHkA9fpu1jigef0iZT6zvRviSi8a T+r2HhlwBpoWPITCGTf9LISMl6EznmgmSmRvRWKW/yh3c= X-Spam-Status: No, score=-10.6 required=5.0 tests=BAYES_00, DKIM_SIGNED, DKIM_VALID, DKIM_VALID_AU, DKIM_VALID_EF, FREEMAIL_FROM, GIT_PATCH_0, RCVD_IN_DNSWL_LOW, SPF_HELO_NONE, SPF_PASS, TXREP, T_SCC_BODY_TEXT_LINE autolearn=ham autolearn_force=no version=3.4.6 X-Spam-Checker-Version: SpamAssassin 3.4.6 (2021-04-09) on server2.sourceware.org X-BeenThere: gcc-patches@gcc.gnu.org X-Mailman-Version: 2.1.30 Precedence: list List-Id: Gcc-patches mailing list List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: gcc-patches-bounces+incoming=patchwork.ozlabs.org@gcc.gnu.org Hi all, although this mail has a patch attached, it is rather a request for comment. The attached patch introduces `gfc_class_set_vptr()` for consistently assigning the _vptr of a class data type. I figured that gfortran does these assignments in various locations and does them differently everywhere without any obvious needs. During working on this I got the impression that it could be worth to add a general class assignment function and this could be the first step to it. The final goal is to reduce the complexity of assigning to class data types and to prevent forgetting the corner cases. What do you think? On x86_66 Fedora 39 this regtests fine. Regards, Andre --- Andre Vehreschild * Email: vehre ad gmx dot de From 9847eaa6aa96eead01ab26800812bc5aeb6443d2 Mon Sep 17 00:00:00 2001 From: Andre Vehreschild Date: Tue, 11 Jun 2024 12:52:26 +0200 Subject: [PATCH 3/3] Add gfc_class_set_vptr. First step to adding a general assign all class type's data members routine. Having a general routine prevents forgetting to tackle the edge cases, e.g. setting _len. gcc/fortran/ChangeLog: * trans-expr.cc (gfc_class_set_vptr): Add setting of _vptr member. * trans-intrinsic.cc (conv_intrinsic_move_alloc): First use of gfc_class_set_vptr and refactor very similar code. * trans.h (gfc_class_set_vptr): Declare the new function. gcc/testsuite/ChangeLog: * gfortran.dg/unlimited_polymorphic_11.f90: Remove unnecessary casts in gd-final expression. --- gcc/fortran/trans-expr.cc | 44 ++++ gcc/fortran/trans-intrinsic.cc | 203 +++++------------- gcc/fortran/trans.h | 2 + .../gfortran.dg/unlimited_polymorphic_11.f90 | 2 +- 4 files changed, 106 insertions(+), 145 deletions(-) diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc index 454b87581f5..0796fb75505 100644 --- a/gcc/fortran/trans-expr.cc +++ b/gcc/fortran/trans-expr.cc @@ -598,6 +598,50 @@ gfc_reset_vptr (stmtblock_t *block, gfc_expr *e, tree class_container, } } +void +gfc_class_set_vptr (stmtblock_t *block, tree to, tree from) +{ + tree tmp, vptr_ref; + // gcc_assert (POINTER_TYPE_P (TREE_TYPE (to)) + // && GFC_CLASS_TYPE_P (TREE_TYPE (TREE_TYPE (to)))); + vptr_ref = gfc_get_vptr_from_expr (to); + if (POINTER_TYPE_P (TREE_TYPE (from)) + && GFC_CLASS_TYPE_P (TREE_TYPE (TREE_TYPE (from)))) + { + gfc_add_modify (block, vptr_ref, + fold_convert (TREE_TYPE (vptr_ref), + gfc_get_vptr_from_expr (from))); + } + else if (VAR_P (from) + && strncmp (IDENTIFIER_POINTER (DECL_NAME (from)), "__vtab", 6) == 0) + { + gfc_add_modify (block, vptr_ref, + gfc_build_addr_expr (TREE_TYPE (vptr_ref), from)); + } + else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (from))) + && GFC_CLASS_TYPE_P ( + TREE_TYPE (TREE_OPERAND (TREE_OPERAND (from, 0), 0)))) + { + gfc_add_modify (block, vptr_ref, + fold_convert (TREE_TYPE (vptr_ref), + gfc_get_vptr_from_expr (TREE_OPERAND ( + TREE_OPERAND (from, 0), 0)))); + } + else + { + tree vtab; + gfc_symbol *type; + tmp = TREE_TYPE (from); + if (POINTER_TYPE_P (tmp)) + tmp = TREE_TYPE (tmp); + gfc_find_symbol (IDENTIFIER_POINTER (TYPE_NAME (tmp)), gfc_current_ns, 1, + &type); + vtab = gfc_find_derived_vtab (type)->backend_decl; + gcc_assert (vtab); + gfc_add_modify (block, vptr_ref, + gfc_build_addr_expr (TREE_TYPE (vptr_ref), vtab)); + } +} /* Reset the len for unlimited polymorphic objects. */ diff --git a/gcc/fortran/trans-intrinsic.cc b/gcc/fortran/trans-intrinsic.cc index ac7fcd250d3..5ea10e84060 100644 --- a/gcc/fortran/trans-intrinsic.cc +++ b/gcc/fortran/trans-intrinsic.cc @@ -12667,10 +12667,9 @@ conv_intrinsic_move_alloc (gfc_code *code) { stmtblock_t block; gfc_expr *from_expr, *to_expr; - gfc_expr *to_expr2, *from_expr2 = NULL; gfc_se from_se, to_se; - tree tmp; - bool coarray; + tree tmp, to_tree, from_tree; + bool coarray, from_is_class, from_is_scalar; gfc_start_block (&block); @@ -12680,178 +12679,94 @@ conv_intrinsic_move_alloc (gfc_code *code) gfc_init_se (&from_se, NULL); gfc_init_se (&to_se, NULL); - gcc_assert (from_expr->ts.type != BT_CLASS - || to_expr->ts.type == BT_CLASS); + gcc_assert (from_expr->ts.type != BT_CLASS || to_expr->ts.type == BT_CLASS); coarray = gfc_get_corank (from_expr) != 0; - if (from_expr->rank == 0 && !coarray) + from_is_class = from_expr->ts.type == BT_CLASS; + from_is_scalar = from_expr->rank == 0 && !coarray; + if (to_expr->ts.type == BT_CLASS || from_is_scalar) { - if (from_expr->ts.type != BT_CLASS) - from_expr2 = from_expr; + from_se.want_pointer = 1; + if (from_is_scalar) + gfc_conv_expr (&from_se, from_expr); else - { - from_expr2 = gfc_copy_expr (from_expr); - gfc_add_data_component (from_expr2); - } - - if (to_expr->ts.type != BT_CLASS) - to_expr2 = to_expr; + gfc_conv_expr_descriptor (&from_se, from_expr); + if (from_is_class) + from_tree = gfc_class_data_get (from_se.expr); else { - to_expr2 = gfc_copy_expr (to_expr); - gfc_add_data_component (to_expr2); + gfc_symbol *vtab; + from_tree = from_se.expr; + + vtab = gfc_find_vtab (&from_expr->ts); + gcc_assert (vtab); + from_se.expr = gfc_get_symbol_decl (vtab); } + gfc_add_block_to_block (&block, &from_se.pre); - from_se.want_pointer = 1; to_se.want_pointer = 1; - gfc_conv_expr (&from_se, from_expr2); - gfc_conv_expr (&to_se, to_expr2); - gfc_add_block_to_block (&block, &from_se.pre); + if (to_expr->rank == 0) + gfc_conv_expr (&to_se, to_expr); + else + gfc_conv_expr_descriptor (&to_se, to_expr); + if (to_expr->ts.type == BT_CLASS) + to_tree = gfc_class_data_get (to_se.expr); + else + to_tree = to_se.expr; gfc_add_block_to_block (&block, &to_se.pre); /* Deallocate "to". */ - tmp = gfc_deallocate_scalar_with_status (to_se.expr, NULL_TREE, NULL_TREE, - true, to_expr, to_expr->ts); - gfc_add_expr_to_block (&block, tmp); + if (to_expr->rank == 0) + { + tmp + = gfc_deallocate_scalar_with_status (to_tree, NULL_TREE, NULL_TREE, + true, to_expr, to_expr->ts); + gfc_add_expr_to_block (&block, tmp); + } - /* Assign (_data) pointers. */ - gfc_add_modify_loc (input_location, &block, to_se.expr, - fold_convert (TREE_TYPE (to_se.expr), from_se.expr)); + if (from_is_scalar) + { + /* Assign (_data) pointers. */ + gfc_add_modify_loc (input_location, &block, to_tree, + fold_convert (TREE_TYPE (to_tree), from_tree)); - /* Set "from" to NULL. */ - gfc_add_modify_loc (input_location, &block, from_se.expr, - fold_convert (TREE_TYPE (from_se.expr), null_pointer_node)); + /* Set "from" to NULL. */ + gfc_add_modify_loc (input_location, &block, from_tree, + fold_convert (TREE_TYPE (from_tree), + null_pointer_node)); - gfc_add_block_to_block (&block, &from_se.post); + gfc_add_block_to_block (&block, &from_se.post); + } gfc_add_block_to_block (&block, &to_se.post); /* Set _vptr. */ if (to_expr->ts.type == BT_CLASS) { - gfc_symbol *vtab; - - gfc_free_expr (to_expr2); - gfc_init_se (&to_se, NULL); - to_se.want_pointer = 1; - gfc_add_vptr_component (to_expr); - gfc_conv_expr (&to_se, to_expr); - - if (from_expr->ts.type == BT_CLASS) - { - if (UNLIMITED_POLY (from_expr)) - vtab = NULL; - else - { - vtab = gfc_find_derived_vtab (from_expr->ts.u.derived); - gcc_assert (vtab); - } - - gfc_free_expr (from_expr2); - gfc_init_se (&from_se, NULL); - from_se.want_pointer = 1; - gfc_add_vptr_component (from_expr); - gfc_conv_expr (&from_se, from_expr); - gfc_add_modify_loc (input_location, &block, to_se.expr, - fold_convert (TREE_TYPE (to_se.expr), - from_se.expr)); - - /* Reset _vptr component to declared type. */ - if (vtab == NULL) - /* Unlimited polymorphic. */ - gfc_add_modify_loc (input_location, &block, from_se.expr, - fold_convert (TREE_TYPE (from_se.expr), - null_pointer_node)); - else - { - tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab)); - gfc_add_modify_loc (input_location, &block, from_se.expr, - fold_convert (TREE_TYPE (from_se.expr), tmp)); - } - } - else - { - vtab = gfc_find_vtab (&from_expr->ts); - gcc_assert (vtab); - tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab)); - gfc_add_modify_loc (input_location, &block, to_se.expr, - fold_convert (TREE_TYPE (to_se.expr), tmp)); - } - } - - if (to_expr->ts.type == BT_CHARACTER && to_expr->ts.deferred) - { - gfc_add_modify_loc (input_location, &block, to_se.string_length, - fold_convert (TREE_TYPE (to_se.string_length), - from_se.string_length)); - if (from_expr->ts.deferred) - gfc_add_modify_loc (input_location, &block, from_se.string_length, - build_int_cst (TREE_TYPE (from_se.string_length), 0)); + gfc_class_set_vptr (&block, to_se.expr, from_se.expr); + if (from_is_class) + gfc_reset_vptr (&block, from_expr); } - return gfc_finish_block (&block); - } - - /* Update _vptr component. */ - if (to_expr->ts.type == BT_CLASS) - { - gfc_symbol *vtab; - - to_se.want_pointer = 1; - to_expr2 = gfc_copy_expr (to_expr); - gfc_add_vptr_component (to_expr2); - gfc_conv_expr (&to_se, to_expr2); - - if (from_expr->ts.type == BT_CLASS) + if (from_is_scalar) { - if (UNLIMITED_POLY (from_expr)) - vtab = NULL; - else + if (to_expr->ts.type == BT_CHARACTER && to_expr->ts.deferred) { - vtab = gfc_find_derived_vtab (from_expr->ts.u.derived); - gcc_assert (vtab); + gfc_add_modify_loc (input_location, &block, to_se.string_length, + fold_convert (TREE_TYPE (to_se.string_length), + from_se.string_length)); + if (from_expr->ts.deferred) + gfc_add_modify_loc ( + input_location, &block, from_se.string_length, + build_int_cst (TREE_TYPE (from_se.string_length), 0)); } - from_se.want_pointer = 1; - from_expr2 = gfc_copy_expr (from_expr); - gfc_add_vptr_component (from_expr2); - gfc_conv_expr (&from_se, from_expr2); - gfc_add_modify_loc (input_location, &block, to_se.expr, - fold_convert (TREE_TYPE (to_se.expr), - from_se.expr)); - - /* Reset _vptr component to declared type. */ - if (vtab == NULL) - /* Unlimited polymorphic. */ - gfc_add_modify_loc (input_location, &block, from_se.expr, - fold_convert (TREE_TYPE (from_se.expr), - null_pointer_node)); - else - { - tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab)); - gfc_add_modify_loc (input_location, &block, from_se.expr, - fold_convert (TREE_TYPE (from_se.expr), tmp)); - } - } - else - { - vtab = gfc_find_vtab (&from_expr->ts); - gcc_assert (vtab); - tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab)); - gfc_add_modify_loc (input_location, &block, to_se.expr, - fold_convert (TREE_TYPE (to_se.expr), tmp)); + return gfc_finish_block (&block); } - gfc_free_expr (to_expr2); gfc_init_se (&to_se, NULL); - - if (from_expr->ts.type == BT_CLASS) - { - gfc_free_expr (from_expr2); - gfc_init_se (&from_se, NULL); - } + gfc_init_se (&from_se, NULL); } - /* Deallocate "to". */ if (from_expr->rank == 0) { diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index 5e064af5ccb..1d3ad187113 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -454,6 +454,8 @@ tree gfc_vptr_deallocate_get (tree); void gfc_reset_vptr (stmtblock_t *, gfc_expr *, tree = NULL_TREE, gfc_symbol * = nullptr); +void +gfc_class_set_vptr (stmtblock_t *, tree, tree); void gfc_reset_len (stmtblock_t *, gfc_expr *); tree gfc_get_class_from_gfc_expr (gfc_expr *); tree gfc_get_class_from_expr (tree); diff --git a/gcc/testsuite/gfortran.dg/unlimited_polymorphic_11.f90 b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_11.f90 index bbd3d067f3f..653992f40eb 100644 --- a/gcc/testsuite/gfortran.dg/unlimited_polymorphic_11.f90 +++ b/gcc/testsuite/gfortran.dg/unlimited_polymorphic_11.f90 @@ -10,4 +10,4 @@ call move_alloc(a,c) end -! { dg-final { scan-tree-dump "\\(struct __vtype__STAR \\*\\) c._vptr = \\(struct __vtype__STAR \\*\\) a._vptr;" "original" } } +! { dg-final { scan-tree-dump "c._vptr = a._vptr;" "original" } } -- 2.45.1