From patchwork Sat Jan 14 21:52:58 2012 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Paul Richard Thomas X-Patchwork-Id: 136114 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 5FEBBB6F9D for ; Sun, 15 Jan 2012 08:53:23 +1100 (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=1327182804; h=Comment: DomainKey-Signature:Received:Received:Received:Received: MIME-Version:Received:Received:Date:Message-ID:Subject:From:To: Content-Type:Mailing-List:Precedence:List-Id:List-Unsubscribe: List-Archive:List-Post:List-Help:Sender:Delivered-To; bh=Ntbkno5 ormyRx1TBHkyThVlfrPA=; b=kTRph8v6eiBqAFMY44xml2xVygMpnitqHznaRIh YgFay27Dv6qIjf6QIDkYViF1AmjRzTtjXcDIYJg8cA58fm/70beP4pqMy6hvoKP9 QHY1z6Ap7hAazVWMrIw0PLiEmaCUfnMPljtbzfk0gy8njktBzW8HPuPFuZxLec6m M8rc= 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:MIME-Version:Received:Received:Date:Message-ID:Subject:From:To:Content-Type:Mailing-List:Precedence:List-Id:List-Unsubscribe:List-Archive:List-Post:List-Help:Sender:Delivered-To; b=Z0JUcxDzRWs8hGJOZ0Brt1sDEgvRj/WUVavN/vf0cqAEqXrcfHX6s0BfWVEt2F N40hlTP92Dydw+079oZvQv15g4niD96SROOlNgrr+3RWa16DAv/0gaTVnz8cVpBS mh8+MpkKPoPnoetfeBHZBj7I4LRdxp1Ajbx4biMex5cDw=; Received: (qmail 25483 invoked by alias); 14 Jan 2012 21:53:16 -0000 Received: (qmail 25465 invoked by uid 22791); 14 Jan 2012 21:53:14 -0000 X-SWARE-Spam-Status: No, hits=-2.3 required=5.0 tests=AWL, BAYES_00, DKIM_SIGNED, DKIM_VALID, DKIM_VALID_AU, FREEMAIL_FROM, RCVD_IN_DNSWL_LOW X-Spam-Check-By: sourceware.org Received: from mail-ee0-f47.google.com (HELO mail-ee0-f47.google.com) (74.125.83.47) by sourceware.org (qpsmtpd/0.43rc1) with ESMTP; Sat, 14 Jan 2012 21:52:59 +0000 Received: by eekd17 with SMTP id d17so1321221eek.20 for ; Sat, 14 Jan 2012 13:52:58 -0800 (PST) MIME-Version: 1.0 Received: by 10.213.4.208 with SMTP id 16mr1804460ebs.29.1326577978184; Sat, 14 Jan 2012 13:52:58 -0800 (PST) Received: by 10.14.100.5 with HTTP; Sat, 14 Jan 2012 13:52:58 -0800 (PST) Date: Sat, 14 Jan 2012 22:52:58 +0100 Message-ID: Subject: [Patch, fortran] Fix temporary allocation for class assignment. From: Paul Richard Thomas To: Tobias Burnus , fortran@gcc.gnu.org, gcc-patches 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 Dear All, As previously advertised, the attached patch fixes the problem with using an index array in the final assignment in subroutine qsort in class_array_3.f03. The failure occurred because the temporary array was assigned zero size, since the declared type is abstract. More generally, even if the temporary is not zero size, the dynamic type will always be larger than the declared type. I have used what might appear to be a rather ad-hoc mechanism; set the element type to null in the call to gfc_trans_create_temp_array and pass the class reference indirectly through 'initial'. Since, for this application, we always want the initial value to be that of the left hand side of the assignment, all is well. I have reviewed all the other users of gfc_trans_create_temp_array and cannot see any issues at present. When F2008 intrinsic assignment of classes is introduced, some care will have to be taken in gfc_trans_assignment_1, between the call to gfc_conv_resolve_dependencies and that to gfc_conv_loop_setup, to ensure that the temporary, if it exists, is initialized correctly. Thus, all in all, I do not think that it is in fact ad-hoc and is rather easily extended to future needs. Please reassure me that class array constructors do not, cannot and will never occur! :-) When TRANSFER is implemented for class objects, there will likely be a similar issue with gfc_trans_create_temp_array. Bootstrapped and regtested on Fc9/x86_64 - OK for trunk? Cheers Paul 2012-01-14 Paul Thomas * trans-array.c (gfc_trans_create_temp_array): In the case of a class array temporary, detect a null 'eltype' on entry and use 'initial' to provde the class reference and so, through the vtable, the element size for the dynamic type. * trans-stmt.c (gfc_conv_elemental_dependencies): For class expressions, set 'eltype' to null and pass the values via the 'initial' expression. 2012-01-14 Paul Thomas * gfortran.dg/class_array_3.f03: Remove the explicit loop in subroutine 'qsort' and use index array to assign the result. Index: gcc/fortran/trans-array.c =================================================================== *** gcc/fortran/trans-array.c (revision 183162) --- gcc/fortran/trans-array.c (working copy) *************** gfc_trans_create_temp_array (stmtblock_t *** 990,998 **** --- 990,1012 ---- tree nelem; tree cond; tree or_expr; + tree class_expr = NULL_TREE; int n, dim, tmp_dim; int total_dim = 0; + /* This signals a class array for which we need the size of the + dynamic type. Generate an eltype and then the class expression. */ + if (eltype == NULL_TREE && initial) + { + if (POINTER_TYPE_P (TREE_TYPE (initial))) + class_expr = build_fold_indirect_ref_loc (input_location, initial); + eltype = TREE_TYPE (class_expr); + eltype = gfc_get_element_type (eltype); + /* Obtain the structure (class) expression. */ + class_expr = TREE_OPERAND (class_expr, 0); + gcc_assert (class_expr); + } + memset (from, 0, sizeof (from)); memset (to, 0, sizeof (to)); *************** gfc_trans_create_temp_array (stmtblock_t *** 1133,1148 **** /* Get the size of the array. */ if (size && !callee_alloc) { /* If or_expr is true, then the extent in at least one dimension is zero and the size is set to zero. */ size = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type, or_expr, gfc_index_zero_node, size); nelem = size; size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, ! size, ! fold_convert (gfc_array_index_type, ! TYPE_SIZE_UNIT (gfc_get_element_type (type)))); } else { --- 1147,1167 ---- /* Get the size of the array. */ if (size && !callee_alloc) { + tree elemsize; /* If or_expr is true, then the extent in at least one dimension is zero and the size is set to zero. */ size = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type, or_expr, gfc_index_zero_node, size); nelem = size; + if (class_expr == NULL_TREE) + elemsize = fold_convert (gfc_array_index_type, + TYPE_SIZE_UNIT (gfc_get_element_type (type))); + else + elemsize = gfc_vtable_size_get (class_expr); + size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, ! size, elemsize); } else { Index: gcc/fortran/trans-stmt.c =================================================================== *** gcc/fortran/trans-stmt.c (revision 183161) --- gcc/fortran/trans-stmt.c (working copy) *************** gfc_conv_elemental_dependencies (gfc_se *** 282,300 **** || (fsym->ts.type ==BT_DERIVED && fsym->attr.intent == INTENT_OUT)) initial = parmse.expr; else initial = NULL_TREE; ! /* Find the type of the temporary to create; we don't use the type ! of e itself as this breaks for subcomponent-references in e (where ! the type of e is that of the final reference, but parmse.expr's ! type corresponds to the full derived-type). */ ! /* TODO: Fix this somehow so we don't need a temporary of the whole ! array but instead only the components referenced. */ ! temptype = TREE_TYPE (parmse.expr); /* Pointer to descriptor. */ ! gcc_assert (TREE_CODE (temptype) == POINTER_TYPE); ! temptype = TREE_TYPE (temptype); ! temptype = gfc_get_element_type (temptype); /* Generate the temporary. Cleaning up the temporary should be the very last thing done, so we add the code to a new block and add it --- 282,312 ---- || (fsym->ts.type ==BT_DERIVED && fsym->attr.intent == INTENT_OUT)) initial = parmse.expr; + /* For class expressions, we always initialize with the copy of + the values. */ + else if (e->ts.type == BT_CLASS) + initial = parmse.expr; else initial = NULL_TREE; ! if (e->ts.type != BT_CLASS) ! { ! /* Find the type of the temporary to create; we don't use the type ! of e itself as this breaks for subcomponent-references in e ! (where the type of e is that of the final reference, but ! parmse.expr's type corresponds to the full derived-type). */ ! /* TODO: Fix this somehow so we don't need a temporary of the whole ! array but instead only the components referenced. */ ! temptype = TREE_TYPE (parmse.expr); /* Pointer to descriptor. */ ! gcc_assert (TREE_CODE (temptype) == POINTER_TYPE); ! temptype = TREE_TYPE (temptype); ! temptype = gfc_get_element_type (temptype); ! } ! ! else ! /* For class arrays signal that the size of the dynamic type has to ! be obtained from the vtable, using the 'initial' expression. */ ! temptype = NULL_TREE; /* Generate the temporary. Cleaning up the temporary should be the very last thing done, so we add the code to a new block and add it *************** gfc_conv_elemental_dependencies (gfc_se *** 312,320 **** /* Update other ss' delta. */ gfc_set_delta (loopse->loop); ! /* Copy the result back using unpack. */ ! tmp = build_call_expr_loc (input_location, ! gfor_fndecl_in_unpack, 2, parmse.expr, data); gfc_add_expr_to_block (&se->post, tmp); /* parmse.pre is already added above. */ --- 324,343 ---- /* Update other ss' delta. */ gfc_set_delta (loopse->loop); ! /* Copy the result back using unpack..... */ ! if (e->ts.type != BT_CLASS) ! tmp = build_call_expr_loc (input_location, ! gfor_fndecl_in_unpack, 2, parmse.expr, data); ! else ! { ! /* ... except for class results where the copy is ! unconditional. */ ! tmp = build_fold_indirect_ref_loc (input_location, parmse.expr); ! tmp = gfc_conv_descriptor_data_get (tmp); ! tmp = build_call_expr_loc (input_location, ! builtin_decl_explicit (BUILT_IN_MEMCPY), ! 3, tmp, data, size); ! } gfc_add_expr_to_block (&se->post, tmp); /* parmse.pre is already added above. */ Index: gcc/testsuite/gfortran.dg/class_array_3.f03 =================================================================== *** gcc/testsuite/gfortran.dg/class_array_3.f03 (revision 183161) --- gcc/testsuite/gfortran.dg/class_array_3.f03 (working copy) *************** contains *** 45,54 **** allocate (tmp(size (a, 1)), source = a) index_array = [(i, i = 1, size (a, 1))] call internal_qsort (tmp, index_array) ! Do not move class elements around until end ! do i = 1, size (a, 1) ! Since they can be of arbitrary size. ! a(i) = tmp(index_array(i)) ! Vector index array would be neater ! end do ! ! a = tmp(index_array) ! Like this - TODO: fixme end subroutine qsort recursive subroutine internal_qsort (x, iarray) --- 45,51 ---- allocate (tmp(size (a, 1)), source = a) index_array = [(i, i = 1, size (a, 1))] call internal_qsort (tmp, index_array) ! Do not move class elements around until end ! a = tmp(index_array) end subroutine qsort recursive subroutine internal_qsort (x, iarray)