From patchwork Thu Jun 28 07:34:39 2012 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Tobias Burnus X-Patchwork-Id: 167810 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Received: from sourceware.org (server1.sourceware.org [209.132.180.131]) by ozlabs.org (Postfix) with SMTP id 174D9B7006 for ; Thu, 28 Jun 2012 17:35:13 +1000 (EST) Comment: DKIM? See http://www.dkim.org DKIM-Signature: v=1; a=rsa-sha1; c=relaxed/relaxed; d=gcc.gnu.org; s=default; x=1341473714; h=Comment: DomainKey-Signature:Received:Received:Received:Received: Message-ID:Date:From:User-Agent:MIME-Version:To:Subject: Content-Type:Mailing-List:Precedence:List-Id:List-Unsubscribe: List-Archive:List-Post:List-Help:Sender:Delivered-To; bh=eko0tYC DcPeu74sZzlUm2aTvb9k=; b=o6QHtF//D24NEJTkorvYxh6D6Wu1tE2/tJH/ogq Mx0lRWSnPfy/nu7lO5E/6d/RvjclsVStHkzZfbYHwSGBrifVEn93vEwb18k6TLOs EO/emYWuwRQv5Lif/50jnIUMYegPXjjwA9zGKcXnp15vr4GWxJVI/WdDH3u7aVdX NwW4= Comment: DomainKeys? See http://antispam.yahoo.com/domainkeys DomainKey-Signature: a=rsa-sha1; q=dns; c=nofws; s=default; d=gcc.gnu.org; h=Received:Received:X-SWARE-Spam-Status:X-Spam-Check-By:Received:Received:Message-ID:Date:From:User-Agent:MIME-Version:To:Subject:Content-Type:Mailing-List:Precedence:List-Id:List-Unsubscribe:List-Archive:List-Post:List-Help:Sender:Delivered-To; b=HtBu1/DQlyfVQMNaAeIaSokJzN7V9ZAFr56rjeRXLkWXyNOCBrmdbWtOuon408 tdF+EDfGUm6uB/XYMaZQQZB++ev8SAJKE6HooflpYiIAGCEpycSTDqICHFQfN42K UHA2g5sYfer5hIEPafAozcFzthaO/llPg8wC/aUfnPDQU=; Received: (qmail 18673 invoked by alias); 28 Jun 2012 07:35:07 -0000 Received: (qmail 18643 invoked by uid 22791); 28 Jun 2012 07:35:04 -0000 X-SWARE-Spam-Status: No, hits=-1.8 required=5.0 tests=AWL, BAYES_00, RCVD_IN_DNSWL_NONE, RCVD_IN_HOSTKARMA_NO, TW_FP, TW_TM X-Spam-Check-By: sourceware.org Received: from mx02.qsc.de (HELO mx02.qsc.de) (213.148.130.14) by sourceware.org (qpsmtpd/0.43rc1) with ESMTP; Thu, 28 Jun 2012 07:34:50 +0000 Received: from [192.168.178.22] (port-92-204-53-225.dynamic.qsc.de [92.204.53.225]) by mx02.qsc.de (Postfix) with ESMTP id E6D3C277E6; Thu, 28 Jun 2012 09:34:42 +0200 (CEST) Message-ID: <4FEC090F.4090507@net-b.de> Date: Thu, 28 Jun 2012 09:34:39 +0200 From: Tobias Burnus User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:13.0) Gecko/20120614 Thunderbird/13.0.1 MIME-Version: 1.0 To: gcc patches , gfortran Subject: [Patch, Fortran] Handle C_F_POINTER with a noncontiguous SHAPE= 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 This patch generates inline code for C_F_POINTER with an array argument. One reason is that GCC didn't handle SHAPE= arguments which were noncontiguous. However, the real motivation is the fortran-dev branch with the new array-descriptor: C_F_POINTER needs then to set the stride multiplier, but as it doesn't know the size of a single element, one had either to pass the value or handle it partially in the front end. Hence, doing it all in the front-end was simpler. The C_F_Pointer issue is the main cause for failing test cases on the branch, though several other issues remain. Build and regtested on x86-64-linux- OK for the trunk? * * * If you wonder why I had some problems before: http://gcc.gnu.org/ml/fortran/2012-04/msg00115.html The reason is that I called pushlevel() twice for "body": + gfc_start_block (&body); + gfc_start_scalarized_body (&loop, &body); I removed the first one - and now it works. (Well, there were also some other issues in the patch, which are now fixed.) Tobias PS: After committal, I will update the patch for the branch; let's see how many failures will remain on the branch. PPS: The offset handling in gfortran is really complicated. I wonder whether we have to (or at least should) change it for the new array descriptor. 2012-06-27 Tobias Burnus * trans-expr.c (conv_isocbinding_procedure): Generate c_f_pointer code inline. 2012-06-27 Tobias Burnus * gfortran.dg/c_f_pointer_shape_tests_5.f90: New. * gfortran.dg/c_f_pointer_tests_3.f90: Update scan-tree-dump-times pattern. diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 7d1a6d4..9ebde9d 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -3307,14 +3351,17 @@ conv_isocbinding_procedure (gfc_se * se, gfc_symbol * sym, return 1; } - else if ((sym->intmod_sym_id == ISOCBINDING_F_POINTER - && arg->next->expr->rank == 0) + else if (sym->intmod_sym_id == ISOCBINDING_F_POINTER || sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER) { - /* Convert c_f_pointer if fptr is a scalar - and convert c_f_procpointer. */ + /* Convert c_f_pointer and c_f_procpointer. */ gfc_se cptrse; gfc_se fptrse; + gfc_se shapese; + gfc_ss *ss, *shape_ss; + tree desc, dim, tmp, stride, offset; + stmtblock_t body, block, ifblock; + gfc_loopinfo loop; gfc_init_se (&cptrse, NULL); gfc_conv_expr (&cptrse, arg->expr); @@ -3322,25 +3369,113 @@ conv_isocbinding_procedure (gfc_se * se, gfc_symbol * sym, gfc_add_block_to_block (&se->post, &cptrse.post); gfc_init_se (&fptrse, NULL); - if (sym->intmod_sym_id == ISOCBINDING_F_POINTER - || gfc_is_proc_ptr_comp (arg->next->expr, NULL)) - fptrse.want_pointer = 1; + if (arg->next->expr->rank == 0) + { + if (sym->intmod_sym_id == ISOCBINDING_F_POINTER + || gfc_is_proc_ptr_comp (arg->next->expr, NULL)) + fptrse.want_pointer = 1; + + gfc_conv_expr (&fptrse, arg->next->expr); + gfc_add_block_to_block (&se->pre, &fptrse.pre); + gfc_add_block_to_block (&se->post, &fptrse.post); + if (arg->next->expr->symtree->n.sym->attr.proc_pointer + && arg->next->expr->symtree->n.sym->attr.dummy) + fptrse.expr = build_fold_indirect_ref_loc (input_location, + fptrse.expr); + se->expr = fold_build2_loc (input_location, MODIFY_EXPR, + TREE_TYPE (fptrse.expr), + fptrse.expr, + fold_convert (TREE_TYPE (fptrse.expr), + cptrse.expr)); + return 1; + } - gfc_conv_expr (&fptrse, arg->next->expr); - gfc_add_block_to_block (&se->pre, &fptrse.pre); - gfc_add_block_to_block (&se->post, &fptrse.post); - - if (arg->next->expr->symtree->n.sym->attr.proc_pointer - && arg->next->expr->symtree->n.sym->attr.dummy) - fptrse.expr = build_fold_indirect_ref_loc (input_location, - fptrse.expr); - - se->expr = fold_build2_loc (input_location, MODIFY_EXPR, - TREE_TYPE (fptrse.expr), - fptrse.expr, - fold_convert (TREE_TYPE (fptrse.expr), - cptrse.expr)); + gfc_start_block (&block); + + /* Get the descriptor of the Fortran pointer. */ + ss = gfc_walk_expr (arg->next->expr); + gcc_assert (ss != gfc_ss_terminator); + fptrse.descriptor_only = 1; + gfc_conv_expr_descriptor (&fptrse, arg->next->expr, ss); + gfc_add_block_to_block (&block, &fptrse.pre); + desc = fptrse.expr; + + /* Set data value, dtype, and offset. */ + tmp = GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc)); + gfc_conv_descriptor_data_set (&block, desc, + fold_convert (tmp, cptrse.expr)); + gfc_add_modify (&block, gfc_conv_descriptor_dtype (desc), + gfc_get_dtype (TREE_TYPE (desc))); + + /* Start scalarization of the bounds, using the shape argument. */ + + shape_ss = gfc_walk_expr (arg->next->next->expr); + gcc_assert (shape_ss != gfc_ss_terminator); + gfc_init_se (&shapese, NULL); + + gfc_init_loopinfo (&loop); + gfc_add_ss_to_loop (&loop, shape_ss); + gfc_conv_ss_startstride (&loop); + gfc_conv_loop_setup (&loop, &arg->next->expr->where); + gfc_mark_ss_chain_used (shape_ss, 1); + + gfc_copy_loopinfo_to_se (&shapese, &loop); + shapese.ss = shape_ss; + + stride = gfc_create_var (gfc_array_index_type, "stride"); + offset = gfc_create_var (gfc_array_index_type, "offset"); + gfc_add_modify (&block, stride, gfc_index_one_node); + gfc_add_modify (&block, offset, gfc_index_one_node); + + /* Loop body. */ + gfc_start_scalarized_body (&loop, &body); + + dim = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, + loop.loopvar[0], loop.from[0]); + + /* Set bounds and stride. */ + gfc_conv_descriptor_lbound_set (&body, desc, dim, gfc_index_one_node); + gfc_conv_descriptor_stride_set (&body, desc, dim, stride); + + gfc_conv_expr (&shapese, arg->next->next->expr); + gfc_add_block_to_block (&body, &shapese.pre); + gfc_conv_descriptor_ubound_set (&body, desc, dim, shapese.expr); + gfc_add_block_to_block (&body, &shapese.post); + + /* Calculate offset. */ + gfc_init_block (&ifblock); + gfc_add_modify (&ifblock, offset, + fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, offset, stride)); + tmp = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, + loop.loopvar[0],loop.from[0]); + tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, tmp, + gfc_finish_block (&ifblock), + build_empty_stmt (input_location)); + gfc_add_expr_to_block (&body, tmp); + + /* Update stride. */ + gfc_add_modify (&body, stride, + fold_build2_loc (input_location, MULT_EXPR, + gfc_array_index_type, stride, + fold_convert (gfc_array_index_type, + shapese.expr))); + /* Finish scalarization loop. */ + gfc_trans_scalarizing_loops (&loop, &body); + gfc_add_block_to_block (&block, &loop.pre); + gfc_add_block_to_block (&block, &loop.post); + gfc_add_block_to_block (&block, &fptrse.post); + gfc_cleanup_loop (&loop); + gfc_free_ss (ss); + + gfc_add_modify (&block, offset, + fold_build2_loc (input_location, MULT_EXPR, + gfc_array_index_type, offset, + build_int_cst (gfc_array_index_type, + -1))); + gfc_conv_descriptor_offset_set (&block, desc, offset); + se->expr = gfc_finish_block (&block); return 1; } else if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED) diff --git a/gcc/testsuite/gfortran.dg/c_f_pointer_tests_3.f90 b/gcc/testsuite/gfortran.dg/c_f_pointer_tests_3.f90 index f7d6fa7..29072b8 100644 --- a/gcc/testsuite/gfortran.dg/c_f_pointer_tests_3.f90 +++ b/gcc/testsuite/gfortran.dg/c_f_pointer_tests_3.f90 @@ -21,14 +21,21 @@ program test call c_f_procpointer(cfunptr, fprocptr) end program test -! Make sure there is only a single function call: -! { dg-final { scan-tree-dump-times "c_f" 1 "original" } } -! { dg-final { scan-tree-dump-times "c_f_pointer" 1 "original" } } -! { dg-final { scan-tree-dump-times "c_f_pointer_i4" 1 "original" } } +! Make sure there is no function call: +! { dg-final { scan-tree-dump-times "c_f" 0 "original" } } +! { dg-final { scan-tree-dump-times "c_f_pointer" 0 "original" } } +! { dg-final { scan-tree-dump-times "c_f_pointer_i4" 0 "original" } } ! ! Check scalar c_f_pointer ! { dg-final { scan-tree-dump-times " fptr = .integer.kind=4. .. cptr" 1 "original" } } ! +! Array c_f_pointer: +! +! { dg-final { scan-tree-dump-times " fptr_array.data = cptr;" 1 "original" } } +! { dg-final { scan-tree-dump-times " fptr_array.dim\\\[S..\\\].lbound = 1;" 1 "original" } } +! { dg-final { scan-tree-dump-times " fptr_array.dim\\\[S..\\\].ubound = " 1 "original" } } +! { dg-final { scan-tree-dump-times " fptr_array.dim\\\[S..\\\].stride = " 1 "original" } } +! ! Check c_f_procpointer ! { dg-final { scan-tree-dump-times " fprocptr = .integer.kind=4. .\\*<.*>. ... cfunptr;" 1 "original" } } ! --- /dev/null 2012-06-26 07:11:42.215802679 +0200 +++ gcc/gcc/testsuite/gfortran.dg/c_f_pointer_shape_tests_5.f90 2012-06-28 08:29:40.000000000 +0200 @@ -0,0 +1,27 @@ +! { dg-do run } +! +! Check that C_F_Pointer works with a noncontiguous SHAPE argument +! +use iso_c_binding +type(c_ptr) :: x +integer, target :: array(3) +integer, pointer :: ptr(:,:) +integer, pointer :: ptr2(:,:,:) +integer :: myshape(5) + +array = [22,33,44] +x = c_loc(array) +myshape = [1,2,3,4,1] + +call c_f_pointer(x, ptr, shape=myshape(1:4:2)) +if (any (lbound(ptr) /= [ 1, 1])) call abort () +if (any (ubound(ptr) /= [ 1, 3])) call abort () +if (any (shape(ptr) /= [ 1, 3])) call abort () +if (any (ptr(1,:) /= array)) call abort() + +call c_f_pointer(x, ptr2, shape=myshape([1,3,1])) +if (any (lbound(ptr2) /= [ 1, 1, 1])) call abort () +if (any (ubound(ptr2) /= [ 1, 3, 1])) call abort () +if (any (shape(ptr2) /= [ 1, 3, 1])) call abort () +if (any (ptr2(1,:,1) /= array)) call abort() +end