From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: from smtp.smtpout.orange.fr (smtp-14.smtpout.orange.fr [80.12.242.14]) by sourceware.org (Postfix) with ESMTPS id E1AC73858412 for ; Thu, 13 Jul 2023 08:52:44 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org E1AC73858412 Authentication-Results: sourceware.org; dmarc=none (p=none dis=none) header.from=gcc.gnu.org Authentication-Results: sourceware.org; spf=fail smtp.mailfrom=gcc.gnu.org Received: from cyrano.home ([86.215.161.51]) by smtp.orange.fr with ESMTPA id Js3wqzoJKtImzJs43q0yVQ; Thu, 13 Jul 2023 10:52:43 +0200 DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=wanadoo.fr; s=t20230301; t=1689238363; bh=tRHq5Jsff0GvwwRL9hVrthjZtLxWWndbU9ZVtN0i8ZQ=; h=From:To:Subject:Date:In-Reply-To:References; b=caV12rcvbgubrGlt0WX6RZipoxMIN2leYWeO9xY1HTQ/ri6sL4DndmG9UYZRvSIrJ I+hFeTQWBOWWEK2uUEYFWq8vpJn0lmC8kkdJ6yLUW/9M5OA9q8+wp9vv9Vr3eNNn4/ EDfkRjPmY11Y6GeRAnP+OIms3C8D5ZdDqOsP5dtuogdS0G5I1eVwZbQR5ezQ7qL/M+ 5dCc5Tq0h6TNSK34IVwP1l+FWTWXqah80OTJMcCFrndOGkla+de1Hs0lohmwkFsKQ7 M5uJ8SdR8sni8lDFhcCBpMLiAhdfUGnvu1a0VcMT1QC3Cy8buOK6u0RhRNuRQi+QGW /xHYlKZ/MugOw== X-ME-Helo: cyrano.home X-ME-Auth: bW9yaW4tbWlrYWVsQG9yYW5nZS5mcg== X-ME-Date: Thu, 13 Jul 2023 10:52:43 +0200 X-ME-IP: 86.215.161.51 From: Mikael Morin To: fortran@gcc.gnu.org, gcc-patches@gcc.gnu.org Subject: [PATCH 03/14] fortran: Outline data reference descriptor evaluation Date: Thu, 13 Jul 2023 10:52:25 +0200 Message-Id: <20230713085236.330222-4-mikael@gcc.gnu.org> X-Mailer: git-send-email 2.40.1 In-Reply-To: <20230713085236.330222-1-mikael@gcc.gnu.org> References: <20230713085236.330222-1-mikael@gcc.gnu.org> MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Spam-Status: No, score=-11.1 required=5.0 tests=BAYES_00,DKIM_SIGNED,DKIM_VALID,FORGED_SPF_HELO,GIT_PATCH_0,JMQ_SPF_NEUTRAL,RCVD_IN_DNSWL_NONE,RCVD_IN_MSPIKE_H3,RCVD_IN_MSPIKE_WL,SPF_HELO_PASS,SPF_NEUTRAL,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 List-Id: gcc/fortran/ChangeLog: * trans.cc (get_var_descr): New function. (gfc_build_final_call): Outline the data reference descriptor evaluation code to get_var_descr. --- gcc/fortran/trans.cc | 149 ++++++++++++++++++++++++------------------- 1 file changed, 83 insertions(+), 66 deletions(-) diff --git a/gcc/fortran/trans.cc b/gcc/fortran/trans.cc index 1e4779f94af..9807b7eb9d9 100644 --- a/gcc/fortran/trans.cc +++ b/gcc/fortran/trans.cc @@ -1124,6 +1124,83 @@ get_elem_size (gfc_se *se, gfc_typespec *ts, gfc_expr *class_size) } +/* Generate the data reference (array) descriptor corresponding to the + expression passed as argument in VAR. Use type in TS to pilot code + generation. */ + +static void +get_var_descr (gfc_se *se, gfc_typespec *ts, gfc_expr *var) +{ + gfc_se tmp_se; + symbol_attribute attr; + + gcc_assert (var); + + gfc_init_se (&tmp_se, NULL); + + if (ts->type == BT_DERIVED) + { + tmp_se.want_pointer = 1; + if (var->rank) + { + tmp_se.descriptor_only = 1; + gfc_conv_expr_descriptor (&tmp_se, var); + } + else + { + gfc_conv_expr (&tmp_se, var); +// gcc_assert (se.pre.head == NULL_TREE && se.post.head == NULL_TREE); + + /* No copy back needed, hence set attr's allocatable/pointer + to zero. */ + gfc_clear_attr (&attr); + tmp_se.expr = gfc_conv_scalar_to_descriptor (&tmp_se, tmp_se.expr, + attr); + gcc_assert (tmp_se.post.head == NULL_TREE); + } + } + else + { + gfc_expr *array_expr; + + array_expr = gfc_copy_expr (var); + + tmp_se.want_pointer = 1; + if (array_expr->rank) + { + gfc_add_class_array_ref (array_expr); + tmp_se.descriptor_only = 1; + gfc_conv_expr_descriptor (&tmp_se, array_expr); + } + else + { + gfc_add_data_component (array_expr); + gfc_conv_expr (&tmp_se, array_expr); + gcc_assert (tmp_se.post.head == NULL_TREE); + + if (!gfc_is_coarray (array_expr)) + { + /* No copy back needed, hence set attr's allocatable/pointer + to zero. */ + gfc_clear_attr (&attr); + tmp_se.expr = gfc_conv_scalar_to_descriptor (&tmp_se, tmp_se.expr, + attr); + } + gcc_assert (tmp_se.post.head == NULL_TREE); + } + gfc_free_expr (array_expr); + } + + if (!POINTER_TYPE_P (TREE_TYPE (tmp_se.expr))) + tmp_se.expr = gfc_build_addr_expr (NULL, tmp_se.expr); + + gfc_add_block_to_block (&se->pre, &tmp_se.pre); + gfc_add_block_to_block (&se->post, &tmp_se.post); + se->expr = tmp_se.expr; +} + + + /* Build a call to a FINAL procedure, which finalizes "var". */ static tree @@ -1131,10 +1208,8 @@ gfc_build_final_call (gfc_typespec ts, gfc_expr *final_wrapper, gfc_expr *var, bool fini_coarray, gfc_expr *class_size) { stmtblock_t block; - gfc_se final_se, size_se; - gfc_se se; + gfc_se final_se, size_se, desc_se; tree final_fndecl, array, size, tmp; - symbol_attribute attr; gcc_assert (var); @@ -1150,74 +1225,16 @@ gfc_build_final_call (gfc_typespec ts, gfc_expr *final_wrapper, gfc_expr *var, gfc_add_block_to_block (&block, &size_se.pre); size = size_se.expr; - if (ts.type == BT_DERIVED) - { - gfc_init_se (&se, NULL); - se.want_pointer = 1; - if (var->rank) - { - se.descriptor_only = 1; - gfc_conv_expr_descriptor (&se, var); - array = se.expr; - } - else - { - gfc_conv_expr (&se, var); -// gcc_assert (se.pre.head == NULL_TREE && se.post.head == NULL_TREE); - array = se.expr; + gfc_init_se (&desc_se, NULL); + get_var_descr (&desc_se, &ts, var); + gfc_add_block_to_block (&block, &desc_se.pre); + array = desc_se.expr; - /* No copy back needed, hence set attr's allocatable/pointer - to zero. */ - gfc_clear_attr (&attr); - gfc_init_se (&se, NULL); - array = gfc_conv_scalar_to_descriptor (&se, array, attr); - gcc_assert (se.post.head == NULL_TREE); - } - } - else - { - gfc_expr *array_expr; - - array_expr = gfc_copy_expr (var); - gfc_init_se (&se, NULL); - se.want_pointer = 1; - if (array_expr->rank) - { - gfc_add_class_array_ref (array_expr); - se.descriptor_only = 1; - gfc_conv_expr_descriptor (&se, array_expr); - array = se.expr; - } - else - { - gfc_add_data_component (array_expr); - gfc_conv_expr (&se, array_expr); - gfc_add_block_to_block (&block, &se.pre); - gcc_assert (se.post.head == NULL_TREE); - array = se.expr; - - if (!gfc_is_coarray (array_expr)) - { - /* No copy back needed, hence set attr's allocatable/pointer - to zero. */ - gfc_clear_attr (&attr); - gfc_init_se (&se, NULL); - array = gfc_conv_scalar_to_descriptor (&se, array, attr); - } - gcc_assert (se.post.head == NULL_TREE); - } - gfc_free_expr (array_expr); - } - - if (!POINTER_TYPE_P (TREE_TYPE (array))) - array = gfc_build_addr_expr (NULL, array); - - gfc_add_block_to_block (&block, &se.pre); tmp = build_call_expr_loc (input_location, final_fndecl, 3, array, size, fini_coarray ? boolean_true_node : boolean_false_node); - gfc_add_block_to_block (&block, &se.post); + gfc_add_block_to_block (&block, &desc_se.post); gfc_add_expr_to_block (&block, tmp); return gfc_finish_block (&block); } -- 2.40.1