From patchwork Wed Nov 8 16:58:10 2023 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: Tobias Burnus X-Patchwork-Id: 163109 Return-Path: Delivered-To: ouuuleilei@gmail.com Received: by 2002:a59:aa0b:0:b0:403:3b70:6f57 with SMTP id k11csp1049027vqo; Wed, 8 Nov 2023 08:59:01 -0800 (PST) X-Google-Smtp-Source: AGHT+IGa+2DAyLpZekhI4/qG0ktsINedcWnbCND9WDn/qPhnaIjvjHJKyXKVippLPL+XkLkMHrbH X-Received: by 2002:ad4:5967:0:b0:66d:949d:717e with SMTP id eq7-20020ad45967000000b0066d949d717emr2536645qvb.42.1699462740623; Wed, 08 Nov 2023 08:59:00 -0800 (PST) ARC-Seal: i=2; a=rsa-sha256; t=1699462740; cv=pass; d=google.com; s=arc-20160816; b=icDKUa12vlcTzFvOAnqMk6h8g9v43zfONF1JplxOyvGJze7K5+1rHobB64eWpf/sN2 sQHMWmK6S3iJNDvd5FVml50ELjpZd0lMWDs1agr0U1fAn49ONDgdEvH2igm+4Hi2siKP KmN5Dx/XGgC3xzblcsQ8obUp1LJMdeRZwtb6mLrsAhKGDJlXF1xM8eh1UTFlvGq/k/1A hQZCXOvkmZzIYZpmz5e5Kfxs5vHYE5hyckE/Y7oqVPYq6oRdmWGzuHFxmi7YKQkxn3qM Dnzo0fl6SvlZx8w37Wm8nOQrFaOyYUXuwjJJGXL/S2FHaGQQRDzMLz+JmanO7ANFGIpy +edQ== ARC-Message-Signature: i=2; a=rsa-sha256; c=relaxed/relaxed; d=google.com; s=arc-20160816; h=errors-to:list-subscribe:list-help:list-post:list-archive :list-unsubscribe:list-id:precedence:subject:from:to :content-language:user-agent:mime-version:date:message-id :ironport-sdr:arc-filter:dmarc-filter:delivered-to; bh=nKkOoZp3LB2Zsv5HMsWs16nu8X/tgOg3/UVLTKWJs0Q=; fh=uWhqZ0eEFBTfpXrFd/v68TtrkiZwZw75pk/+qd9bJz4=; b=ZoQLAuAo2l0uM7iFDgUe0sDKZfAGYjZaA+/uhYK4DeEcoczRucVH3WTDSndDdh0fvd WX5bXjBCQzA/oQA3O1EpfMBkf8QoSMTP+2kmsdzgl7nCtr64rGk2+TouJ3vL9nxNR6aI KZjZuek2c+MGoqpLYc1EZ3Cl4HI8xv6ZMzpSI5ljcXKIWmNMBH0cxNCdg2ndd8GRJTvT npkDCb4ZOXXQzx5TJMIpvDQW1kHbX8u0hNB+tMcxyUdQfbcgGDTYpofxQZ7hMjNpNqV7 yjvY7HIcGMhoEH5UXawfUfqp9GsyAuGtVGLhNTf0eZyf5w3BtdFhVZ6B+q36a7Wgxv0J nQrQ== ARC-Authentication-Results: i=2; mx.google.com; arc=pass (i=1); spf=pass (google.com: domain of gcc-patches-bounces+ouuuleilei=gmail.com@gcc.gnu.org designates 8.43.85.97 as permitted sender) smtp.mailfrom="gcc-patches-bounces+ouuuleilei=gmail.com@gcc.gnu.org" Received: from server2.sourceware.org (server2.sourceware.org. [8.43.85.97]) by mx.google.com with ESMTPS id pm15-20020ad446cf000000b0065b176ed459si1538795qvb.154.2023.11.08.08.59.00 for (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Wed, 08 Nov 2023 08:59:00 -0800 (PST) Received-SPF: pass (google.com: domain of gcc-patches-bounces+ouuuleilei=gmail.com@gcc.gnu.org designates 8.43.85.97 as permitted sender) client-ip=8.43.85.97; Authentication-Results: mx.google.com; arc=pass (i=1); spf=pass (google.com: domain of gcc-patches-bounces+ouuuleilei=gmail.com@gcc.gnu.org designates 8.43.85.97 as permitted sender) smtp.mailfrom="gcc-patches-bounces+ouuuleilei=gmail.com@gcc.gnu.org" Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 5F3603857BA4 for ; Wed, 8 Nov 2023 16:59:00 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from esa1.mentor.iphmx.com (esa1.mentor.iphmx.com [68.232.129.153]) by sourceware.org (Postfix) with ESMTPS id 20CBB3857711; Wed, 8 Nov 2023 16:58:18 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org 20CBB3857711 Authentication-Results: sourceware.org; dmarc=none (p=none dis=none) header.from=codesourcery.com Authentication-Results: sourceware.org; spf=pass smtp.mailfrom=mentor.com ARC-Filter: OpenARC Filter v1.0.0 sourceware.org 20CBB3857711 Authentication-Results: server2.sourceware.org; arc=none smtp.remote-ip=68.232.129.153 ARC-Seal: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1699462705; cv=none; b=H3LsZ1wSQSGqy6R3ceE9IWmqcQzNgkBkNdNG0oNZeQPE7fOSVVCO1ZPA9/lSRjxYzprrSJl1qcmxVoJOR5QIC7OKeFPtElrVL/Ev2PVkUp7MNusoJOL6sbczVshQfdCn5/ZIyLqwg5mYjiz8bdsi4T+LoIMeYLnH2n3lEZX/KUo= ARC-Message-Signature: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1699462705; c=relaxed/simple; bh=tGjvs0L64ZuKqxBBskcI8jyXLzznUxughUI+VwCTVZg=; h=Message-ID:Date:MIME-Version:To:From:Subject; b=bIU+2IdL7UpYWRwrH1XWjpVoep26YdkviEi4BBze2HjcLIYIhMcTTJLWc4fPJwRi3mTsF0u1Cz7L8vhWH1G0SSZ6icTz7kUB/19eCOc5GBMwOkPS+nZu1EfPLmz5NXoDRfVYfez6OO24LR1VykEI/QoPPd9cnPoHD5A86xUhKlU= ARC-Authentication-Results: i=1; server2.sourceware.org X-CSE-ConnectionGUID: unnh8TD7TB6vqZe8HV85fw== X-CSE-MsgGUID: 5s3+2yvDToOR2yjq7AKPxw== X-IronPort-AV: E=Sophos;i="6.03,286,1694764800"; d="diff'?scan'208";a="25177108" Received: from orw-gwy-02-in.mentorg.com ([192.94.38.167]) by esa1.mentor.iphmx.com with ESMTP; 08 Nov 2023 08:58:16 -0800 IronPort-SDR: 6JysW7LKU3gnqrapGugb+HI7L0bX+cRd98UuXjYf8hHi/XAvPQ0UbRrYmLio+PRsunH7H/0yF5 8XLsk7R2BqIDhM3tjoJWAlBi34bK+8WQdw+GnpfDPZhleuWv5Mfi4dd967TtF7vgYJO1vgW2T1 /qgPKN9VqwxymUMtss/iqqbD3TQIvnpbJnUROR4tSkXa+BrF7YMZ9MPLY472AgFK5Km8iWEAHR F/u+Eoh7arV9vkNYIJvXC19snVPKcG7IccMTTtfyBd4q/8tzOBR9md/leL/7aFCRjfq9ZLPW9Y Sqs= Message-ID: <60940754-edc6-4110-b7ba-5bed2133bbb6@codesourcery.com> Date: Wed, 8 Nov 2023 17:58:10 +0100 MIME-Version: 1.0 User-Agent: Mozilla Thunderbird Content-Language: en-US To: gcc-patches , fortran , Jakub Jelinek From: Tobias Burnus Subject: [patch] OpenMP/Fortran: Implement omp allocators/allocate for ptr/allocatables X-Originating-IP: [137.202.0.90] X-ClientProxiedBy: svr-ies-mbx-14.mgc.mentorg.com (139.181.222.14) To svr-ies-mbx-12.mgc.mentorg.com (139.181.222.12) X-Spam-Status: No, score=-10.6 required=5.0 tests=BAYES_00, GIT_PATCH_0, HEADER_FROM_DIFFERENT_DOMAINS, KAM_DMARC_STATUS, KAM_SHORT, SPF_HELO_PASS, SPF_PASS, TXREP, T_SCC_BODY_TEXT_LINE, URIBL_BLACK 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+ouuuleilei=gmail.com@gcc.gnu.org X-getmail-retrieved-from-mailbox: INBOX X-GMAIL-THRID: 1782015842598389693 X-GMAIL-MSGID: 1782015842598389693 Hi all, Comment to reviewers: * Fortran: Except for ensuring that the version field in array descriptors is always set to the default (zero), the generated code should only be affected when -fopenmp-allocators is set, even though several files are touched. * Middle-end: BUILT_IN_GOMP_REALLOC has been added - otherwise untouched. * Otherwise, smaller libgomp changes, conditions to (de)allocation code in fortran/trans*.cc and and some checking updates (mostly openmp.cc) * * * GCC supports OpenMP's allocators, which work typically as: my_c_ptr = omp_alloc (byte_size, my_allocator) ... call omp_free (my_c_ptr, omp_null_allocator) where (if called as such) the runtime has to find the used allocator in order to handle the 'free' (and likewise: omp_realloc) correctly. libgomp implements this by allocating a bit more bytes - and using the first bytes to store the handle for the allocator such that 'my_c_ptr minus size of handle' will be the address. See also OpenMP spec and: https://gcc.gnu.org/onlinedocs/libgomp/OMP_005fALLOCATOR.html https://gcc.gnu.org/onlinedocs/libgomp/Memory-Management-Routines.html https://gcc.gnu.org/onlinedocs/libgomp/Memory-allocation.html and https://gcc.gnu.org/wiki/cauldron2023 (OpenMP BoF; video recordings not yet available, slide is) FOR FORTRAN, OpenMP permits to allocate ALLOCATABLES and POINTERS also as follows: !$omp allocators allocate(allocator(my_alloc), align(128) : A) allocate(A(10), B) A = [1,2,3] ! reallocate with same allocator call intent_out_function(B) ! Has to use proper deallocator deallocate(A) ! Likewise. ! end of scope deallocation: Likewise. (Side remark: In 5.{1,2}, '!$omp allocate(A,B) allocator(my_alloc) align(123)' is the syntax to use - which has nearly the same effect, except that for non-specified variables, 'omp allocators' uses the normal Fortran allocation while for a 'omp allocate' without a variable list uses that OpenMP allocator for nonlisted variables.) * * * The problem is really that 'malloc'ed memory has to be freed/realloced by 'free' and 'realloc' while 'omp_alloc'ed memory has to be by handled by 'omp_free' and 'omp_realloc' - getting this wrong will nearly always crash the program- I assume that the propagation depth is rather slow, i.e. most likely all deallocation will happen in the file as the allocation, but that's not guaranteed and I bet that a few "leaks" to other files are likely in every other software package. * * * ASSUMPTIONS for the attached implementation: * Most OpenMP code will not use '!$omp allocators' (Note: Using the API routines or 'allocate' clauses on block-associated directives (like: omp parallel firstprivate(a) allocate(allocator(my_alloc) :a)') or 'omp allocate' for stack variables are separate and pose no problems.) * The (de,re)allocation will not happen in a hot code * And, if used, the number of scalar variables of this kind will be small SOLUTION as implemented: * All code that uses 'omp allocator' and all code that might deallocate such memory must be compiled by a special flag: -fopenmp-allocators This solves the issues: - Always having an overhead even if -fopenmp code does not need it - Permitting (de,re)allocation of such a variable from code which is not compiled with -fopenmp While -fopenmp-allocators could be auto-enabled when 'omp allocators' shows up in a file, I decided to require it explicitly by the user in order to highlight that other files might require the same flag as thy might do (de,re)allocation on such memory. * For ARRAYS, we fortunately can encode it in the descriptor. I (mis)use the version field for this: version = 0 means standard Fortran way while version = 1 means using omp_alloc and friends. * For SCALARS, there is no way to store this. As (see assumptions) this is neither in a hot path nor are there very many variables, we simply keep track of such variables in a separate way. (O (log2 N)) in libgomp - by keekping track of the pointer address in libgomp. Disclaimer: * I am not 100% sure that I have caught all corner cases for deallocation/reallocation; however, it should covers most. * One area that is probably not fully covered is BIND(C). A Fortran actual to a BIND(C) intent(out) should work (dealloced on the caller side), once converted to a CFI descriptor, all deallocations will likely fail, be it a later intrinsic-assignment realloc, cfi_deallocate or 'deallocate' after conversion to Fortran. This can be fixed but requires (a) adding the how-allocated to the CFI descriptor but not as version (as that is user visible) and (b) handling it in CFI_deallocate. The latter will add a dependency on 'omp_free', which somehow has to be resolved. (Like weak symbols, which is likely not supported on all platforms.) Thus, as very special case, it has been left out - but it could be added. If a user code hits it, it should cause a reproducible crash (using free for omp_alloc'ed memory; libc's free should be able to detect this and abort loudly). * * * I think the patch is mostly self describing, however, two remarks: * I had to move the 'gfc_conv_descriptor_data_get' before calling 'gfc_deallocate_with_status' as it would otherwise use the GOMP_is_alloc routine instead of the 'version == 1' check. gfc_deallocate_with_status already added the gfc_conv_descriptor_data_get (except for some coarrays - thus, it was updated to add them there). * In principle, OpenMP supports component references in list items. That's currently not implemented but could be added. This mainly needs some to detect whether the expression in the list item is the same as in the ALLOCATE statement and what the spec actually wants to see as list item. '!$omp allocate' w/o list items is not handled. Still, there are some ways to already allocate DT components, which is handled. Comments, suggestions, remarks? Tobias PS: On the OG13 branch and planned for upstreaming is also the support for pseudo-unified-shared memory; there are some similarities like having an OpenMP allocator, but also several differences; to be disentangled once the upstreaming is done. ----------------- Siemens Electronic Design Automation GmbH; Anschrift: Arnulfstraße 201, 80634 München; Gesellschaft mit beschränkter Haftung; Geschäftsführer: Thomas Heurung, Frank Thürauf; Sitz der Gesellschaft: München; Registergericht München, HRB 106955 OpenMP/Fortran: Implement omp allocators/allocate for ptr/allocatables This commit adds -fopenmp-allocators which enables support for 'omp allocators' and 'omp allocate' that are associated with a Fortran allocate-stmt. If such a construct is encountered, an error is shown, unless the -fopenmp-allocators flag is present. With -fopenmp -fopenmp-allocators, those constructs get turned into GOMP_alloc allocations, while -fopenmp-allocators (also without -fopenmp) ensures deallocation and reallocation (via intrinsic assignments) are properly directed to GOMP_free/omp_realloc - while normal Fortran allocations are processed by free/realloc. In order to distinguish a 'malloc'ed from a 'GOMP_alloc'ed memory, the version field of the Fortran array discriptor is (mis)used: 0 indicates the normal Fortran allocation while 1 denotes GOMP_alloc. For scalars, there is record keeping in libgomp: GOMP_add_alloc(ptr) will add the pointer address to a splay_tree while GOMP_is_alloc(ptr) will return true it was previously added but also removes it from the list. Besides Fortran FE work, BUILT_IN_GOMP_REALLOC is no part of omp-builtins.def and libgomp gains the mentioned two new function. gcc/ChangeLog: * builtin-types.def (BT_FN_PTR_PTR_SIZE_PTRMODE_PTRMODE): New. * omp-builtins.def (BUILT_IN_GOMP_REALLOC): New. * builtins.cc (builtin_fnspec): Handle it. * gimple-ssa-warn-access.cc (fndecl_alloc_p, matching_alloc_calls_p): Likewise. * gimple.cc (nonfreeing_call_p): Likewise. * predict.cc (expr_expected_value_1): Likewise. * tree-ssa-ccp.cc (evaluate_stmt): Likewise. * tree.cc (fndecl_dealloc_argno): Likewise. gcc/fortran/ChangeLog: * dump-parse-tree.cc (show_omp_node): Handle EXEC_OMP_ALLOCATE and EXEC_OMP_ALLOCATORS. * f95-lang.cc (ATTR_ALLOC_WARN_UNUSED_RESULT_SIZE_2_NOTHROW_LIST): Add 'ECF_LEAF | ECF_MALLOC' to existing 'ECF_NOTHROW'. (ATTR_ALLOC_WARN_UNUSED_RESULT_SIZE_2_NOTHROW_LEAF_LIST): Define. * gfortran.h (gfc_omp_clauses): Add contained_in_target_construct. * invoke.texi (-fopenacc, -fopenmp): Update based on C version. (-fopenmp-simd): New, based on C version. (-fopenmp-allocators): New. * lang.opt (fopenmp-allocators): Add. * openmp.cc (resolve_omp_clauses): For allocators/allocate directive, add target and no dynamic_allocators diagnostic and more invalid diagnostic. * parse.cc (decode_omp_directive): Set contains_teams_construct. * trans-array.h (gfc_array_allocate): Update prototype. (gfc_conv_descriptor_version): New prototype. * trans-decl.cc (gfc_init_default_dt): Fix comment. * trans-array.cc (gfc_conv_descriptor_version): New. (gfc_array_allocate): Support GOMP_alloc allocation. (gfc_alloc_allocatable_for_assignment, structure_alloc_comps): Handle GOMP_free/omp_realloc as needed. * trans-expr.cc (gfc_conv_procedure_call): Likewise. (alloc_scalar_allocatable_for_assignment): Likewise. * trans-intrinsic.cc (conv_intrinsic_move_alloc): * trans-openmp.cc (gfc_trans_omp_allocators, gfc_trans_omp_directive): Handle allocators/allocate directive. (gfc_omp_call_add_alloc, gfc_omp_call_is_alloc): New. * trans-stmt.h (gfc_trans_allocate): Update prototype. * trans-stmt.cc (gfc_trans_allocate): Support GOMP_alloc. * trans-types.cc (gfc_get_dtype_rank_type): Set version field. * trans.cc (gfc_allocate_using_malloc, gfc_allocate_allocatable): Update to handle GOMP_alloc. (gfc_deallocate_with_status, gfc_deallocate_scalar_with_status): Handle GOMP_free. (trans_code): Update call. * trans.h (gfc_allocate_allocatable, gfc_allocate_using_malloc): Update prototype. (gfc_omp_call_add_alloc, gfc_omp_call_is_alloc): New prototype. * types.def (BT_FN_PTR_PTR_SIZE_PTRMODE_PTRMODE): New. libgomp/ChangeLog: * allocator.c (struct fort_alloc_splay_tree_key_s, fort_alloc_splay_compare, GOMP_add_alloc, GOMP_is_alloc): New. * libgomp.h: Define splay_tree_static for 'reverse' splay tree. * libgomp.map (GOMP_5.1.2): New; add GOMP_add_alloc and GOMP_is_alloc; move GOMP_target_map_indirect_ptr from ... (GOMP_5.1.1): ... here. * libgomp.texi (Impl. Status, Memory management): Update for allocators/allocate directives. * splay-tree.c: Handle splay_tree_static define to declare all functions as static. (splay_tree_lookup_node): New. * splay-tree.h: Handle splay_tree_decl_only define. (splay_tree_lookup_node): New prototype. * target.c: Define splay_tree_static for 'reverse'. * testsuite/libgomp.fortran/allocators-1.f90: New test. * testsuite/libgomp.fortran/allocators-2.f90: New test. * testsuite/libgomp.fortran/allocators-3.f90: New test. * testsuite/libgomp.fortran/allocators-4.f90: New test. * testsuite/libgomp.fortran/allocators-5.f90: New test. gcc/testsuite/ChangeLog: * gfortran.dg/gomp/allocate-14.f90: Add coarray and not-listed tests. * gfortran.dg/gomp/allocate-5.f90: Remove sorry dg-message. * gfortran.dg/bind_c_array_params_2.f90: Update expected dump for dtype '.version=0'. * gfortran.dg/gomp/allocate-16.f90: New test. * gfortran.dg/gomp/allocators-3.f90: New test. * gfortran.dg/gomp/allocators-4.f90: New test. gcc/builtin-types.def | 2 + gcc/builtins.cc | 1 + gcc/fortran/dump-parse-tree.cc | 2 + gcc/fortran/f95-lang.cc | 4 +- gcc/fortran/gfortran.h | 1 + gcc/fortran/invoke.texi | 79 ++++++++--- gcc/fortran/lang.opt | 4 + gcc/fortran/openmp.cc | 120 ++++++++++++++-- gcc/fortran/parse.cc | 7 +- gcc/fortran/trans-array.cc | 152 +++++++++++++++++---- gcc/fortran/trans-array.h | 4 +- gcc/fortran/trans-decl.cc | 2 +- gcc/fortran/trans-expr.cc | 24 +++- gcc/fortran/trans-intrinsic.cc | 5 +- gcc/fortran/trans-openmp.cc | 61 ++++++++- gcc/fortran/trans-stmt.cc | 92 ++++++++++++- gcc/fortran/trans-stmt.h | 2 +- gcc/fortran/trans-types.cc | 4 + gcc/fortran/trans.cc | 85 +++++++++--- gcc/fortran/trans.h | 10 +- gcc/fortran/types.def | 2 + gcc/gimple-ssa-warn-access.cc | 18 ++- gcc/gimple.cc | 2 + gcc/omp-builtins.def | 3 + gcc/predict.cc | 1 + .../gfortran.dg/bind_c_array_params_2.f90 | 2 +- gcc/testsuite/gfortran.dg/gomp/allocate-14.f90 | 41 ++++++ gcc/testsuite/gfortran.dg/gomp/allocate-16.f90 | 10 ++ gcc/testsuite/gfortran.dg/gomp/allocate-5.f90 | 17 +-- gcc/testsuite/gfortran.dg/gomp/allocators-3.f90 | 36 +++++ gcc/testsuite/gfortran.dg/gomp/allocators-4.f90 | 9 ++ gcc/tree-ssa-ccp.cc | 1 + gcc/tree.cc | 2 + libgomp/allocator.c | 63 +++++++++ libgomp/libgomp.h | 1 + libgomp/libgomp.map | 8 +- libgomp/libgomp.texi | 16 ++- libgomp/splay-tree.c | 40 +++++- libgomp/splay-tree.h | 17 +++ libgomp/target.c | 1 + libgomp/testsuite/libgomp.fortran/allocators-1.f90 | 68 +++++++++ libgomp/testsuite/libgomp.fortran/allocators-2.f90 | 101 ++++++++++++++ libgomp/testsuite/libgomp.fortran/allocators-3.f90 | 25 ++++ libgomp/testsuite/libgomp.fortran/allocators-4.f90 | 57 ++++++++ libgomp/testsuite/libgomp.fortran/allocators-5.f90 | 27 ++++ 45 files changed, 1113 insertions(+), 116 deletions(-) diff --git a/gcc/builtin-types.def b/gcc/builtin-types.def index 43381bc8949..183ef62bad2 100644 --- a/gcc/builtin-types.def +++ b/gcc/builtin-types.def @@ -840,6 +840,8 @@ DEF_FUNCTION_TYPE_4 (BT_FN_PTR_PTR_CONST_PTR_SIZE_SIZE, BT_PTR, BT_PTR, BT_CONST_PTR, BT_SIZE, BT_SIZE) DEF_FUNCTION_TYPE_4 (BT_FN_PTR_PTR_INT_SIZE_SIZE, BT_PTR, BT_PTR, BT_INT, BT_SIZE, BT_SIZE) +DEF_FUNCTION_TYPE_4 (BT_FN_PTR_PTR_SIZE_PTRMODE_PTRMODE, + BT_PTR, BT_PTR, BT_SIZE, BT_PTRMODE, BT_PTRMODE) DEF_FUNCTION_TYPE_4 (BT_FN_UINT_UINT_UINT_UINT_UINT, BT_UINT, BT_UINT, BT_UINT, BT_UINT, BT_UINT) DEF_FUNCTION_TYPE_4 (BT_FN_UINT_UINT_UINT_UINT_UINTPTR, diff --git a/gcc/builtins.cc b/gcc/builtins.cc index cb90bd03b3e..4f2597eaae6 100644 --- a/gcc/builtins.cc +++ b/gcc/builtins.cc @@ -11739,6 +11739,7 @@ builtin_fnspec (tree callee) return ".cO "; /* Realloc serves both as allocation point and deallocation point. */ case BUILT_IN_REALLOC: + case BUILT_IN_GOMP_REALLOC: return ".Cw "; case BUILT_IN_GAMMA_R: case BUILT_IN_GAMMAF_R: diff --git a/gcc/fortran/dump-parse-tree.cc b/gcc/fortran/dump-parse-tree.cc index cc4846e5d74..ecf71036444 100644 --- a/gcc/fortran/dump-parse-tree.cc +++ b/gcc/fortran/dump-parse-tree.cc @@ -2241,6 +2241,8 @@ show_omp_node (int level, gfc_code *c) case EXEC_OACC_CACHE: case EXEC_OACC_ENTER_DATA: case EXEC_OACC_EXIT_DATA: + case EXEC_OMP_ALLOCATE: + case EXEC_OMP_ALLOCATORS: case EXEC_OMP_ASSUME: case EXEC_OMP_CANCEL: case EXEC_OMP_CANCELLATION_POINT: diff --git a/gcc/fortran/f95-lang.cc b/gcc/fortran/f95-lang.cc index 350e6e379eb..dfff9445e64 100644 --- a/gcc/fortran/f95-lang.cc +++ b/gcc/fortran/f95-lang.cc @@ -556,7 +556,9 @@ gfc_builtin_function (tree decl) #define ATTR_NOTHROW_LIST (ECF_NOTHROW) #define ATTR_CONST_NOTHROW_LIST (ECF_NOTHROW | ECF_CONST) #define ATTR_ALLOC_WARN_UNUSED_RESULT_SIZE_2_NOTHROW_LIST \ - (ECF_NOTHROW) + (ECF_NOTHROW | ECF_LEAF | ECF_MALLOC) +#define ATTR_ALLOC_WARN_UNUSED_RESULT_SIZE_2_NOTHROW_LEAF_LIST \ + (ECF_NOTHROW | ECF_LEAF) #define ATTR_COLD_NORETURN_NOTHROW_LEAF_LIST \ (ECF_COLD | ECF_NORETURN | \ ECF_NOTHROW | ECF_LEAF) diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index aa3f6cb70b4..38043a91b70 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -1579,6 +1579,7 @@ typedef struct gfc_omp_clauses unsigned grainsize_strict:1, num_tasks_strict:1, compare:1, weak:1; unsigned non_rectangular:1, order_concurrent:1; unsigned contains_teams_construct:1, target_first_st_is_teams:1; + unsigned contained_in_target_construct:1; ENUM_BITFIELD (gfc_omp_sched_kind) sched_kind:3; ENUM_BITFIELD (gfc_omp_device_type) device_type:2; ENUM_BITFIELD (gfc_omp_memorder) memorder:3; diff --git a/gcc/fortran/invoke.texi b/gcc/fortran/invoke.texi index 10387e39501..041173507cd 100644 --- a/gcc/fortran/invoke.texi +++ b/gcc/fortran/invoke.texi @@ -126,8 +126,9 @@ by type. Explanations are in the following sections. -ffree-form -ffree-line-length-@var{n} -ffree-line-length-none -fimplicit-none -finteger-4-integer-8 -fmax-identifier-length -fmodule-private -ffixed-form -fno-range-check -fopenacc -fopenmp --freal-4-real-10 -freal-4-real-16 -freal-4-real-8 -freal-8-real-10 --freal-8-real-16 -freal-8-real-4 -std=@var{std} -ftest-forall-temp +-fopenmp-allocators -fopenmp-simd -freal-4-real-10 -freal-4-real-16 +-freal-4-real-8 -freal-8-real-10 -freal-8-real-16 -freal-8-real-4 +-std=@var{std} -ftest-forall-temp } @item Preprocessing Options @@ -410,26 +411,64 @@ Specify that no implicit typing is allowed, unless overridden by explicit Enable the Cray pointer extension, which provides C-like pointer functionality. -@opindex @code{fopenacc} -@cindex OpenACC + +@opindex fopenacc +@cindex OpenACC accelerator programming @item -fopenacc -Enable the OpenACC extensions. This includes OpenACC @code{!$acc} -directives in free form and @code{c$acc}, @code{*$acc} and -@code{!$acc} directives in fixed form, @code{!$} conditional -compilation sentinels in free form and @code{c$}, @code{*$} and -@code{!$} sentinels in fixed form, and when linking arranges for the -OpenACC runtime library to be linked in. - -@opindex @code{fopenmp} -@cindex OpenMP +Enable handling of OpenACC directives @samp{!$acc} in free-form Fortran and +@samp{!$acc}, @samp{c$acc} and @samp{*$acc} in fixed-form Fortran. When +@option{-fopenacc} is specified, the compiler generates accelerated code +according to the OpenACC Application Programming Interface v2.6 +@w{@uref{https://www.openacc.org}}. This option implies @option{-pthread}, +and thus is only supported on targets that have support for @option{-pthread}. +The option @option{-fopenacc} implies @option{-frecursive}. + +@opindex fopenmp +@cindex OpenMP parallel @item -fopenmp -Enable the OpenMP extensions. This includes OpenMP @code{!$omp} directives -in free form -and @code{c$omp}, @code{*$omp} and @code{!$omp} directives in fixed form, -@code{!$} conditional compilation sentinels in free form -and @code{c$}, @code{*$} and @code{!$} sentinels in fixed form, -and when linking arranges for the OpenMP runtime library to be linked -in. The option @option{-fopenmp} implies @option{-frecursive}. +Enable handling of OpenMP directives @samp{!$omp} in Fortran. It +additionally enables the conditional compilation sentinel @samp{!$} in +Fortran. In fixed source form Fortran, the sentinels can also start with +@samp{c} or @samp{*}. When @option{-fopenmp} is specified, the +compiler generates parallel code according to the OpenMP Application +Program Interface v4.5 @w{@uref{https://www.openmp.org}}. This option +implies @option{-pthread}, and thus is only supported on targets that +have support for @option{-pthread}. @option{-fopenmp} implies +@option{-fopenmp-simd} and @option{-frecursive}. + +@opindex fopenmp-allocators +@cindex OpenMP Allocators +@item -fopenmp-allocators +Enables handling of allocation, reallocation and deallocation of Fortran +allocatable and pointer variables that are allocated using the +@samp{!$omp allocators} and @samp{!$omp allocate} constructs. Files +containing either directive have to be compiled with this option in addition +to @option{-fopenmp}. Additionally, all files that might deallocate or +reallocate a variable that has been allocated with an OpenMP allocator +have to be compiled with this option. This includes intrinsic assignment +to allocatable variables when reallocation may occur and deallocation +due to either of the following: end of scope, explicit deallocation, +@samp{intent(out)}, deallocation of allocatable components etc. +Files not changing the allocation status or only for components of +a derived type that have not been allocated using those two directives +do not need to be compiled with this option. Nor do files that handle +such variables after they have been deallocated or allocated by the +normal Fortran allocator. + +@opindex fopenmp-simd +@cindex OpenMP SIMD +@cindex SIMD +@item -fopenmp-simd +Enable handling of OpenMP's @code{simd}, @code{declare simd}, +@code{declare reduction}, @code{assume}, @code{ordered}, @code{scan} +and @code{loop} directive, and of combined or composite directives with +@code{simd} as constituent with @code{!$omp} in Fortran. It additionally +enables the conditional compilation sentinel @samp{!$} in Fortran. In +fixed source form Fortran, the sentinels can also start with @samp{c} or +@samp{*}. Other OpenMP directives are ignored. Unless @option{-fopenmp} +is additionally specified, the @code{loop} region binds to the current task +region, independent of the specified @code{bind} clause. + @opindex @code{frange-check} @item -fno-range-check diff --git a/gcc/fortran/lang.opt b/gcc/fortran/lang.opt index 7236351a93c..4c8748bc412 100644 --- a/gcc/fortran/lang.opt +++ b/gcc/fortran/lang.opt @@ -712,6 +712,10 @@ fopenmp-simd Fortran ; Documented in C +fopenmp-allocators +Fortran Var(flag_openmp_allocators) +Handle OpenMP allocators for allocatables and pointers. + fpack-derived Fortran Var(flag_pack_derived) Try to lay out derived types as compactly as possible. diff --git a/gcc/fortran/openmp.cc b/gcc/fortran/openmp.cc index 2e2e23d567b..bba17acd3dc 100644 --- a/gcc/fortran/openmp.cc +++ b/gcc/fortran/openmp.cc @@ -7410,6 +7410,9 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses, if (omp_clauses == NULL) return; + if (ns == NULL) + ns = gfc_current_ns; + if (omp_clauses->orderedc && omp_clauses->orderedc < omp_clauses->collapse) gfc_error ("ORDERED clause parameter is less than COLLAPSE at %L", &code->loc); @@ -7643,23 +7646,22 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses, && n->sym->result == n->sym && n->sym->attr.function) { - if (gfc_current_ns->proc_name == n->sym - || (gfc_current_ns->parent - && gfc_current_ns->parent->proc_name == n->sym)) + if (ns->proc_name == n->sym + || (ns->parent && ns->parent->proc_name == n->sym)) continue; - if (gfc_current_ns->proc_name->attr.entry_master) + if (ns->proc_name->attr.entry_master) { - gfc_entry_list *el = gfc_current_ns->entries; + gfc_entry_list *el = ns->entries; for (; el; el = el->next) if (el->sym == n->sym) break; if (el) continue; } - if (gfc_current_ns->parent - && gfc_current_ns->parent->proc_name->attr.entry_master) + if (ns->parent + && ns->parent->proc_name->attr.entry_master) { - gfc_entry_list *el = gfc_current_ns->parent->entries; + gfc_entry_list *el = ns->parent->entries; for (; el; el = el->next) if (el->sym == n->sym) break; @@ -7959,24 +7961,120 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses, && code->block->next->op == EXEC_ALLOCATE) { gfc_alloc *a; + gfc_omp_namelist *n_null = NULL; + bool missing_allocator = false; + gfc_symbol *missing_allocator_sym = NULL; for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next) { + if (n->u2.allocator == NULL) + { + if (!missing_allocator_sym) + missing_allocator_sym = n->sym; + missing_allocator = true; + } if (n->sym == NULL) - continue; + { + n_null = n; + continue; + } if (n->sym->attr.codimension) gfc_error ("Unexpected coarray %qs in % at %L", n->sym->name, &n->where); for (a = code->block->next->ext.alloc.list; a; a = a->next) if (a->expr->expr_type == EXPR_VARIABLE && a->expr->symtree->n.sym == n->sym) - break; + { + gfc_ref *ref; + for (ref = a->expr->ref; ref; ref = ref->next) + if (ref->type == REF_COMPONENT) + break; + if (ref == NULL) + break; + } if (a == NULL) gfc_error ("%qs specified in % at %L but not " "in the associated ALLOCATE statement", n->sym->name, &n->where); } - } + /* If there is an ALLOCATE directive without list argument, a + namelist with its allocator/align clauses and n->sym = NULL is + created during parsing; here, we add all not otherwise specified + items from the Fortran allocate to that list. + For an ALLOCATORS directive, not listed items use the normal + Fortran way. + The behavior of an ALLOCATE directive that does not list all + arguments but there is no directive without list argument is not + well specified. Thus, we reject such code below. In OpenMP 5.2 + the executable ALLOCATE directive is deprecated and in 6.0 + deleted such that no spec clarification is to be expected. */ + for (a = code->block->next->ext.alloc.list; a; a = a->next) + if (a->expr->expr_type == EXPR_VARIABLE) + { + for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next) + if (a->expr->symtree->n.sym == n->sym) + { + gfc_ref *ref; + for (ref = a->expr->ref; ref; ref = ref->next) + if (ref->type == REF_COMPONENT) + break; + if (ref == NULL) + break; + } + if (n == NULL && n_null == NULL) + { + /* OK for ALLOCATORS but for ALLOCATE: Unspecified whether + that should use the default allocator of OpenMP or the + Fortran allocator. Thus, just reject it. */ + if (code->op == EXEC_OMP_ALLOCATE) + gfc_error ("%qs listed in % statement at %L " + "but it is neither explicitly in listed in " + "the % directive nor exists" + " a directive without argument list", + a->expr->symtree->n.sym->name, + &a->expr->where); + break; + } + if (n == NULL) + { + if (a->expr->symtree->n.sym->attr.codimension) + gfc_error ("Unexpected coarray %qs in % at " + "%L, implicitly listed in %" + " at %L", a->expr->symtree->n.sym->name, + &a->expr->where, &n_null->where); + break; + } + } + gfc_namespace *prog_unit = ns; + while (prog_unit->parent) + prog_unit = prog_unit->parent; + gfc_namespace *fn_ns = ns; + while (fn_ns) + { + if (ns->proc_name + && (ns->proc_name->attr.subroutine + || ns->proc_name->attr.function)) + break; + fn_ns = fn_ns->parent; + } + if (missing_allocator + && !(prog_unit->omp_requires & OMP_REQ_DYNAMIC_ALLOCATORS) + && ((fn_ns && fn_ns->proc_name->attr.omp_declare_target) + || omp_clauses->contained_in_target_construct)) + { + if (code->op == EXEC_OMP_ALLOCATORS) + gfc_error ("ALLOCATORS directive at %L inside a target region " + "must specify an ALLOCATOR modifier for %qs", + &code->loc, missing_allocator_sym->name); + else if (missing_allocator_sym) + gfc_error ("ALLOCATE directive at %L inside a target region " + "must specify an ALLOCATOR clause for %qs", + &code->loc, missing_allocator_sym->name); + else + gfc_error ("ALLOCATE directive at %L inside a target region " + "must specify an ALLOCATOR clause", &code->loc); + } + } } /* OpenACC reductions. */ diff --git a/gcc/fortran/parse.cc b/gcc/fortran/parse.cc index abd3a424f38..c0eb0575a90 100644 --- a/gcc/fortran/parse.cc +++ b/gcc/fortran/parse.cc @@ -1364,6 +1364,8 @@ decode_omp_directive (void) prog_unit->omp_target_seen = true; break; } + case ST_OMP_ALLOCATE_EXEC: + case ST_OMP_ALLOCATORS: case ST_OMP_TEAMS: case ST_OMP_TEAMS_DISTRIBUTE: case ST_OMP_TEAMS_DISTRIBUTE_SIMD: @@ -1386,7 +1388,10 @@ decode_omp_directive (void) case EXEC_OMP_TARGET_PARALLEL_DO_SIMD: case EXEC_OMP_TARGET_PARALLEL_LOOP: case EXEC_OMP_TARGET_SIMD: - stk->tail->ext.omp_clauses->contains_teams_construct = 1; + if (ret == ST_OMP_ALLOCATE_EXEC || ret == ST_OMP_ALLOCATORS) + new_st.ext.omp_clauses->contained_in_target_construct = 1; + else + stk->tail->ext.omp_clauses->contains_teams_construct = 1; break; default: break; diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc index bbb81f40aa9..f23325dc4e1 100644 --- a/gcc/fortran/trans-array.cc +++ b/gcc/fortran/trans-array.cc @@ -363,6 +363,21 @@ gfc_conv_descriptor_rank (tree desc) } +tree +gfc_conv_descriptor_version (tree desc) +{ + tree tmp; + tree dtype; + + dtype = gfc_conv_descriptor_dtype (desc); + tmp = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (dtype)), GFC_DTYPE_VERSION); + gcc_assert (tmp != NULL_TREE + && TREE_TYPE (tmp) == integer_type_node); + return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp), + dtype, tmp, NULL_TREE); +} + + /* Return the element length from the descriptor dtype field. */ tree @@ -6196,7 +6211,7 @@ bool gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg, tree errlen, tree label_finish, tree expr3_elem_size, tree *nelems, gfc_expr *expr3, tree e3_arr_desc, - bool e3_has_nodescriptor) + bool e3_has_nodescriptor, gfc_omp_namelist *omp_alloc) { tree tmp; tree pointer; @@ -6218,6 +6233,7 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg, gfc_ref *ref, *prev_ref = NULL, *coref; bool allocatable, coarray, dimension, alloc_w_e3_arr_spec = false, non_ulimate_coarray_ptr_comp; + tree omp_cond = NULL_TREE, omp_alt_alloc = NULL_TREE; ref = expr->ref; @@ -6368,7 +6384,11 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg, token = gfc_build_addr_expr (NULL_TREE, token); } else - pointer = gfc_conv_descriptor_data_get (se->expr); + { + pointer = gfc_conv_descriptor_data_get (se->expr); + if (omp_alloc) + omp_cond = boolean_true_node; + } STRIP_NOPS (pointer); if (allocatable) @@ -6384,18 +6404,66 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg, gfc_start_block (&elseblock); + tree succ_add_expr = NULL_TREE; + if (omp_cond) + { + tree align, alloc, sz; + gfc_se se2; + if (omp_alloc->u2.allocator) + { + gfc_init_se (&se2, NULL); + gfc_conv_expr (&se2, omp_alloc->u2.allocator); + gfc_add_block_to_block (&elseblock, &se2.pre); + alloc = gfc_evaluate_now (se2.expr, &elseblock); + gfc_add_block_to_block (&elseblock, &se2.post); + } + else + alloc = build_zero_cst (ptr_type_node); + tmp = TREE_TYPE (TREE_TYPE (pointer)); + if (tmp == void_type_node) + tmp = gfc_typenode_for_spec (&expr->ts, 0); + if (omp_alloc->u.align) + { + gfc_init_se (&se2, NULL); + gfc_conv_expr (&se2, omp_alloc->u.align); + gcc_assert (CONSTANT_CLASS_P (se2.expr) + && se2.pre.head == NULL + && se2.post.head == NULL); + align = build_int_cst (size_type_node, + MAX (tree_to_uhwi (se2.expr), + TYPE_ALIGN_UNIT (tmp))); + } + else + align = build_int_cst (size_type_node, TYPE_ALIGN_UNIT (tmp)); + sz = fold_build2_loc (input_location, MAX_EXPR, size_type_node, + fold_convert (size_type_node, size), + build_int_cst (size_type_node, 1)); + omp_alt_alloc = builtin_decl_explicit (BUILT_IN_GOMP_ALLOC); + DECL_ATTRIBUTES (omp_alt_alloc) + = tree_cons (get_identifier ("omp allocator"), + build_tree_list (NULL_TREE, alloc), + DECL_ATTRIBUTES (omp_alt_alloc)); + omp_alt_alloc = build_call_expr (omp_alt_alloc, 3, align, sz, alloc); + succ_add_expr = fold_build2_loc (input_location, MODIFY_EXPR, + void_type_node, + gfc_conv_descriptor_version (se->expr), + build_int_cst (integer_type_node, 1)); + } + /* The allocatable variant takes the old pointer as first argument. */ if (allocatable) gfc_allocate_allocatable (&elseblock, pointer, size, token, status, errmsg, errlen, label_finish, expr, - coref != NULL ? coref->u.ar.as->corank : 0); + coref != NULL ? coref->u.ar.as->corank : 0, + omp_cond, omp_alt_alloc, succ_add_expr); else if (non_ulimate_coarray_ptr_comp && token) /* The token is set only for GFC_FCOARRAY_LIB mode. */ gfc_allocate_using_caf_lib (&elseblock, pointer, size, token, status, errmsg, errlen, GFC_CAF_COARRAY_ALLOC_ALLOCATE_ONLY); else - gfc_allocate_using_malloc (&elseblock, pointer, size, status); + gfc_allocate_using_malloc (&elseblock, pointer, size, status, + omp_cond, omp_alt_alloc, succ_add_expr); if (dimension) { @@ -9603,11 +9671,6 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, tree dest, else if (attr->dimension && !attr->proc_pointer) caf_token = gfc_conv_descriptor_token (comp); } - if (attr->dimension && !attr->codimension && !attr->proc_pointer) - /* When this is an array but not in conjunction with a coarray - then add the data-ref. For coarray'ed arrays the data-ref - is added by deallocate_with_status. */ - comp = gfc_conv_descriptor_data_get (comp); tmp = gfc_deallocate_with_status (comp, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, true, @@ -10292,29 +10355,50 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, tree dest, gfc_add_expr_to_block (&fnblock, tmp); } - if (c->attr.pdt_array) + if (c->attr.pdt_array || c->attr.pdt_string) { - tmp = gfc_conv_descriptor_data_get (comp); + tmp = comp; + if (c->attr.pdt_array) + tmp = gfc_conv_descriptor_data_get (comp); null_cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, tmp, build_int_cst (TREE_TYPE (tmp), 0)); - tmp = gfc_call_free (tmp); - tmp = build3_v (COND_EXPR, null_cond, tmp, - build_empty_stmt (input_location)); - gfc_add_expr_to_block (&fnblock, tmp); - gfc_conv_descriptor_data_set (&fnblock, comp, null_pointer_node); - } - else if (c->attr.pdt_string) - { - null_cond = fold_build2_loc (input_location, NE_EXPR, - logical_type_node, comp, - build_int_cst (TREE_TYPE (comp), 0)); - tmp = gfc_call_free (comp); + if (flag_openmp_allocators) + { + tree cd, t; + if (c->attr.pdt_array) + cd = fold_build2_loc (input_location, EQ_EXPR, + boolean_type_node, + gfc_conv_descriptor_version (comp), + build_int_cst (integer_type_node, 1)); + else + cd = gfc_omp_call_is_alloc (tmp); + t = builtin_decl_explicit (BUILT_IN_GOMP_FREE); + t = build_call_expr_loc (input_location, t, 1, tmp); + + stmtblock_t tblock; + gfc_init_block (&tblock); + gfc_add_expr_to_block (&tblock, t); + if (c->attr.pdt_array) + gfc_add_modify (&tblock, gfc_conv_descriptor_version (comp), + build_zero_cst (integer_type_node)); + tmp = build3_loc (input_location, COND_EXPR, void_type_node, + cd, gfc_finish_block (&tblock), + gfc_call_free (tmp)); + } + else + tmp = gfc_call_free (tmp); tmp = build3_v (COND_EXPR, null_cond, tmp, build_empty_stmt (input_location)); gfc_add_expr_to_block (&fnblock, tmp); - tmp = fold_convert (TREE_TYPE (comp), null_pointer_node); - gfc_add_modify (&fnblock, comp, tmp); + + if (c->attr.pdt_array) + gfc_conv_descriptor_data_set (&fnblock, comp, null_pointer_node); + else + { + tmp = fold_convert (TREE_TYPE (comp), null_pointer_node); + gfc_add_modify (&fnblock, comp, tmp); + } } break; @@ -11248,8 +11332,22 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop, builtin_decl_explicit (BUILT_IN_REALLOC), 2, fold_convert (pvoid_type_node, array1), size2); - gfc_conv_descriptor_data_set (&realloc_block, - desc, tmp); + if (flag_openmp_allocators) + { + tree cond, omp_tmp; + cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, + gfc_conv_descriptor_version (desc), + build_int_cst (integer_type_node, 1)); + omp_tmp = builtin_decl_explicit (BUILT_IN_GOMP_REALLOC); + omp_tmp = build_call_expr_loc (input_location, omp_tmp, 4, + fold_convert (pvoid_type_node, array1), size2, + build_zero_cst (ptr_type_node), + build_zero_cst (ptr_type_node)); + tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), cond, + omp_tmp, tmp); + } + + gfc_conv_descriptor_data_set (&realloc_block, desc, tmp); } else { diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h index 5408755138e..6cdcc9a3e75 100644 --- a/gcc/fortran/trans-array.h +++ b/gcc/fortran/trans-array.h @@ -21,7 +21,8 @@ along with GCC; see the file COPYING3. If not see /* Generate code to initialize and allocate an array. Statements are added to se, which should contain an expression for the array descriptor. */ bool gfc_array_allocate (gfc_se *, gfc_expr *, tree, tree, tree, tree, - tree, tree *, gfc_expr *, tree, bool); + tree, tree *, gfc_expr *, tree, bool, + gfc_omp_namelist *); /* Allow the bounds of a loop to be set from a callee's array spec. */ void gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping *, @@ -177,6 +178,7 @@ tree gfc_conv_descriptor_span_get (tree); tree gfc_conv_descriptor_dtype (tree); tree gfc_conv_descriptor_rank (tree); tree gfc_conv_descriptor_elem_len (tree); +tree gfc_conv_descriptor_version (tree); tree gfc_conv_descriptor_attribute (tree); tree gfc_conv_descriptor_type (tree); tree gfc_get_descriptor_dimension (tree); diff --git a/gcc/fortran/trans-decl.cc b/gcc/fortran/trans-decl.cc index b86cfec7d49..cf848406a05 100644 --- a/gcc/fortran/trans-decl.cc +++ b/gcc/fortran/trans-decl.cc @@ -4350,7 +4350,7 @@ gfc_init_default_dt (gfc_symbol * sym, stmtblock_t * block, bool dealloc) /* Initialize INTENT(OUT) derived type dummies. As well as giving - them their default initializer, if they do not have allocatable + them their default initializer, if they have allocatable components, they have their allocatable components deallocated. */ static void diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc index 50c4604a025..9ba8d164519 100644 --- a/gcc/fortran/trans-expr.cc +++ b/gcc/fortran/trans-expr.cc @@ -7150,8 +7150,6 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, if (TREE_TYPE(tmp) != pvoid_type_node) tmp = build_fold_indirect_ref_loc (input_location, parmse.expr); - if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp))) - tmp = gfc_conv_descriptor_data_get (tmp); tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, true, e, @@ -11701,8 +11699,30 @@ alloc_scalar_allocatable_for_assignment (stmtblock_t *block, builtin_decl_explicit (BUILT_IN_REALLOC), 2, fold_convert (pvoid_type_node, lse.expr), size_in_bytes); + tree omp_cond = NULL_TREE; + if (flag_openmp_allocators) + { + tree omp_tmp; + omp_cond = gfc_omp_call_is_alloc (lse.expr); + omp_cond = gfc_evaluate_now (omp_cond, block); + + omp_tmp = builtin_decl_explicit (BUILT_IN_GOMP_REALLOC); + omp_tmp = build_call_expr_loc (input_location, omp_tmp, 4, + fold_convert (pvoid_type_node, + lse.expr), size_in_bytes, + build_zero_cst (ptr_type_node), + build_zero_cst (ptr_type_node)); + tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), + omp_cond, omp_tmp, tmp); + } tmp = fold_convert (TREE_TYPE (lse.expr), tmp); gfc_add_modify (block, lse.expr, tmp); + if (omp_cond) + gfc_add_expr_to_block (block, + build3_loc (input_location, COND_EXPR, + void_type_node, omp_cond, + gfc_omp_call_add_alloc (lse.expr), + build_empty_stmt (input_location))); tmp = build1_v (LABEL_EXPR, jump_label2); gfc_add_expr_to_block (block, tmp); diff --git a/gcc/fortran/trans-intrinsic.cc b/gcc/fortran/trans-intrinsic.cc index 289309190a5..05e111c0fcc 100644 --- a/gcc/fortran/trans-intrinsic.cc +++ b/gcc/fortran/trans-intrinsic.cc @@ -12819,9 +12819,8 @@ conv_intrinsic_move_alloc (gfc_code *code) gfc_add_expr_to_block (&block, tmp); } - tmp = gfc_conv_descriptor_data_get (to_se.expr); - tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE, NULL_TREE, - NULL_TREE, true, to_expr, + tmp = gfc_deallocate_with_status (to_se.expr, NULL_TREE, NULL_TREE, + NULL_TREE, NULL_TREE, true, to_expr, GFC_CAF_COARRAY_NOCOARRAY); gfc_add_expr_to_block (&block, tmp); } diff --git a/gcc/fortran/trans-openmp.cc b/gcc/fortran/trans-openmp.cc index 82bbc41b388..9e166c94f8e 100644 --- a/gcc/fortran/trans-openmp.cc +++ b/gcc/fortran/trans-openmp.cc @@ -4841,6 +4841,30 @@ gfc_trans_oacc_wait_directive (gfc_code *code) static tree gfc_trans_omp_sections (gfc_code *, gfc_omp_clauses *); static tree gfc_trans_omp_workshare (gfc_code *, gfc_omp_clauses *); +static tree +gfc_trans_omp_allocators (gfc_code *code) +{ + static bool warned = false; + gfc_omp_namelist *omp_allocate + = code->ext.omp_clauses->lists[OMP_LIST_ALLOCATE]; + if (!flag_openmp_allocators && !warned) + { + omp_allocate = NULL; + gfc_error ("% at %L requires %<-fopenmp-allocators%>", + code->op == EXEC_OMP_ALLOCATE ? "ALLOCATE" : "ALLOCATORS", + &code->loc); + warning (0, "All files that might deallocate such a variable must be " + "compiled with %<-fopenmp-allocators%>"); + inform (UNKNOWN_LOCATION, + "This includes explicit DEALLOCATE, reallocation on intrinsic " + "assignment, INTENT(OUT) for allocatable dummy arguments, and " + "reallocation of allocatable components allocated with an " + "OpenMP allocator"); + warned = true; + } + return gfc_trans_allocate (code->block->next, omp_allocate); +} + static tree gfc_trans_omp_assume (gfc_code *code) { @@ -7992,9 +8016,7 @@ gfc_trans_omp_directive (gfc_code *code) { case EXEC_OMP_ALLOCATE: case EXEC_OMP_ALLOCATORS: - sorry ("% not yet supported", - code->op == EXEC_OMP_ALLOCATE ? "ALLOCATE" : "ALLOCATORS"); - return NULL_TREE; + return gfc_trans_omp_allocators (code); case EXEC_OMP_ASSUME: return gfc_trans_omp_assume (code); case EXEC_OMP_ATOMIC: @@ -8329,3 +8351,36 @@ gfc_trans_omp_declare_variant (gfc_namespace *ns) } } } + +/* Add ptr for tracking as being allocated by GOMP_alloc. */ + +tree +gfc_omp_call_add_alloc (tree ptr) +{ + static tree fn = NULL_TREE; + if (fn == NULL_TREE) + { + fn = build_function_type_list (void_type_node, ptr_type_node, NULL_TREE); + fn = build_fn_decl ("GOMP_add_alloc", fn); +/* FIXME: attributes. */ + } + return build_call_expr_loc (input_location, fn, 1, ptr); +} + +/* Generated function returns true when it was tracked via GOMP_add_alloc and + removes it from the tracking. As called just before GOMP_free or omp_realloc + the pointer is or might become invalid, thus, it is always removed. */ + +tree +gfc_omp_call_is_alloc (tree ptr) +{ + static tree fn = NULL_TREE; + if (fn == NULL_TREE) + { + fn = build_function_type_list (boolean_type_node, ptr_type_node, + NULL_TREE); + fn = build_fn_decl ("GOMP_is_alloc", fn); +/* FIXME: attributes. */ + } + return build_call_expr_loc (input_location, fn, 1, ptr); +} diff --git a/gcc/fortran/trans-stmt.cc b/gcc/fortran/trans-stmt.cc index 50b71e67234..5530e893a62 100644 --- a/gcc/fortran/trans-stmt.cc +++ b/gcc/fortran/trans-stmt.cc @@ -6228,7 +6228,7 @@ allocate_get_initializer (gfc_code * code, gfc_expr * expr) /* Translate the ALLOCATE statement. */ tree -gfc_trans_allocate (gfc_code * code) +gfc_trans_allocate (gfc_code * code, gfc_omp_namelist *omp_allocate) { gfc_alloc *al; gfc_expr *expr, *e3rhs = NULL, *init_expr; @@ -6790,11 +6790,38 @@ gfc_trans_allocate (gfc_code * code) else tmp = expr3_esize; + gfc_omp_namelist *omp_alloc_item = NULL; + if (omp_allocate) + { + gfc_omp_namelist *n = NULL; + gfc_omp_namelist *n_null = NULL; + for (n = omp_allocate; n; n = n->next) + { + if (n->sym == NULL) + { + n_null = n; + continue; + } + if (expr->expr_type == EXPR_VARIABLE + && expr->symtree->n.sym == n->sym) + { + gfc_ref *ref; + for (ref = expr->ref; ref; ref = ref->next) + if (ref->type == REF_COMPONENT) + break; + if (ref == NULL) + break; + } + } + omp_alloc_item = n ? n : n_null; + + } + if (!gfc_array_allocate (&se, expr, stat, errmsg, errlen, label_finish, tmp, &nelems, e3rhs ? e3rhs : code->expr3, e3_is == E3_DESC ? expr3 : NULL_TREE, - e3_has_nodescriptor)) + e3_has_nodescriptor, omp_alloc_item)) { /* A scalar or derived type. First compute the size to allocate. @@ -6874,10 +6901,59 @@ gfc_trans_allocate (gfc_code * code) /* Handle size computation of the type declared to alloc. */ memsz = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (se.expr))); + bool use_coarray_alloc + = (flag_coarray == GFC_FCOARRAY_LIB + && (caf_attr = gfc_caf_attr (expr, true, &caf_refs_comp)) + .codimension); + tree omp_cond = NULL_TREE; + tree omp_alt_alloc = NULL_TREE; + tree succ_add_expr = NULL_TREE; + if (!use_coarray_alloc && omp_alloc_item) + { + tree align, alloc, sz; + gfc_se se2; + + omp_cond = boolean_true_node; + if (omp_alloc_item->u2.allocator) + { + gfc_init_se (&se2, NULL); + gfc_conv_expr (&se2, omp_alloc_item->u2.allocator); + gfc_add_block_to_block (&se.pre, &se2.pre); + alloc = gfc_evaluate_now (se2.expr, &se.pre); + gfc_add_block_to_block (&se.pre, &se2.post); + } + else + alloc = build_zero_cst (ptr_type_node); + tmp = TREE_TYPE (TREE_TYPE (se.expr)); + if (tmp == void_type_node) + tmp = gfc_typenode_for_spec (&expr->ts, 0); + if (omp_alloc_item->u.align) + { + gfc_init_se (&se2, NULL); + gfc_conv_expr (&se2, omp_alloc_item->u.align); + gcc_assert (CONSTANT_CLASS_P (se2.expr) + && se2.pre.head == NULL + && se2.post.head == NULL); + align = build_int_cst (size_type_node, + MAX (tree_to_uhwi (se2.expr), + TYPE_ALIGN_UNIT (tmp))); + } + else + align = build_int_cst (size_type_node, TYPE_ALIGN_UNIT (tmp)); + sz = fold_build2_loc (input_location, MAX_EXPR, size_type_node, + fold_convert (size_type_node, memsz), + build_int_cst (size_type_node, 1)); + omp_alt_alloc = builtin_decl_explicit (BUILT_IN_GOMP_ALLOC); + DECL_ATTRIBUTES (omp_alt_alloc) + = tree_cons (get_identifier ("omp allocator"), + build_tree_list (NULL_TREE, alloc), + DECL_ATTRIBUTES (omp_alt_alloc)); + omp_alt_alloc = build_call_expr (omp_alt_alloc, 3, align, sz, alloc); + succ_add_expr = gfc_omp_call_add_alloc (se.expr); + } + /* Store the caf-attributes for latter use. */ - if (flag_coarray == GFC_FCOARRAY_LIB - && (caf_attr = gfc_caf_attr (expr, true, &caf_refs_comp)) - .codimension) + if (use_coarray_alloc) { /* Scalar allocatable components in coarray'ed derived types make it here and are treated now. */ @@ -6904,9 +6980,11 @@ gfc_trans_allocate (gfc_code * code) else if (gfc_expr_attr (expr).allocatable) gfc_allocate_allocatable (&se.pre, se.expr, memsz, NULL_TREE, stat, errmsg, errlen, - label_finish, expr, 0); + label_finish, expr, 0, + omp_cond, omp_alt_alloc, succ_add_expr); else - gfc_allocate_using_malloc (&se.pre, se.expr, memsz, stat); + gfc_allocate_using_malloc (&se.pre, se.expr, memsz, stat, + omp_cond, omp_alt_alloc, succ_add_expr); } else { diff --git a/gcc/fortran/trans-stmt.h b/gcc/fortran/trans-stmt.h index 101a0540ef4..270ebcf9915 100644 --- a/gcc/fortran/trans-stmt.h +++ b/gcc/fortran/trans-stmt.h @@ -64,7 +64,7 @@ tree gfc_trans_change_team (gfc_code *); tree gfc_trans_end_team (gfc_code *); tree gfc_trans_sync_team (gfc_code *); tree gfc_trans_where (gfc_code *); -tree gfc_trans_allocate (gfc_code *); +tree gfc_trans_allocate (gfc_code *, gfc_omp_namelist *); tree gfc_trans_deallocate (gfc_code *); /* trans-openmp.cc */ diff --git a/gcc/fortran/trans-types.cc b/gcc/fortran/trans-types.cc index 084b8c3ae2c..ffb37f2a1c6 100644 --- a/gcc/fortran/trans-types.cc +++ b/gcc/fortran/trans-types.cc @@ -1601,6 +1601,10 @@ gfc_get_dtype_rank_type (int rank, tree etype) GFC_DTYPE_ELEM_LEN); CONSTRUCTOR_APPEND_ELT (v, field, fold_convert (TREE_TYPE (field), size)); + field = gfc_advance_chain (TYPE_FIELDS (dtype_type_node), + GFC_DTYPE_VERSION); + CONSTRUCTOR_APPEND_ELT (v, field, + build_zero_cst (TREE_TYPE (field))); field = gfc_advance_chain (TYPE_FIELDS (dtype_type_node), GFC_DTYPE_RANK); diff --git a/gcc/fortran/trans.cc b/gcc/fortran/trans.cc index e2e1b694012..961b0b5a573 100644 --- a/gcc/fortran/trans.cc +++ b/gcc/fortran/trans.cc @@ -796,7 +796,10 @@ gfc_call_malloc (stmtblock_t * block, tree type, tree size) if (stat requested) stat = 0; + // if cond == NULL_NULL: newmem = malloc (MAX (size, 1)); + // otherwise: + newmem = ? : malloc (MAX (size, 1)) if (newmem == NULL) { if (stat) @@ -808,7 +811,8 @@ gfc_call_malloc (stmtblock_t * block, tree type, tree size) } */ void gfc_allocate_using_malloc (stmtblock_t * block, tree pointer, - tree size, tree status) + tree size, tree status, tree cond, tree alt_alloc, + tree extra_success_expr) { tree tmp, error_cond; stmtblock_t on_error; @@ -822,13 +826,18 @@ gfc_allocate_using_malloc (stmtblock_t * block, tree pointer, /* The allocation itself. */ size = fold_convert (size_type_node, size); - gfc_add_modify (block, pointer, - fold_convert (TREE_TYPE (pointer), - build_call_expr_loc (input_location, - builtin_decl_explicit (BUILT_IN_MALLOC), 1, - fold_build2_loc (input_location, - MAX_EXPR, size_type_node, size, - build_int_cst (size_type_node, 1))))); + tmp = fold_build2_loc (input_location, MAX_EXPR, size_type_node, + size, build_int_cst (size_type_node, 1)); + + tmp = build_call_expr_loc (input_location, + builtin_decl_explicit (BUILT_IN_MALLOC), 1, tmp); + if (cond == boolean_true_node) + tmp = alt_alloc; + else if (cond) + tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), cond, + alt_alloc, tmp); + + gfc_add_modify (block, pointer, fold_convert (TREE_TYPE (pointer), tmp)); /* What to do in case of error. */ gfc_start_block (&on_error); @@ -852,7 +861,9 @@ gfc_allocate_using_malloc (stmtblock_t * block, tree pointer, tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, gfc_unlikely (error_cond, PRED_FORTRAN_FAIL_ALLOC), gfc_finish_block (&on_error), - build_empty_stmt (input_location)); + extra_success_expr + ? extra_success_expr + : build_empty_stmt (input_location)); gfc_add_expr_to_block (block, tmp); } @@ -938,7 +949,8 @@ gfc_allocate_using_caf_lib (stmtblock_t * block, tree pointer, tree size, void gfc_allocate_allocatable (stmtblock_t * block, tree mem, tree size, tree token, tree status, tree errmsg, tree errlen, - tree label_finish, gfc_expr* expr, int corank) + tree label_finish, gfc_expr* expr, int corank, + tree cond, tree alt_alloc, tree extra_success_expr) { stmtblock_t alloc_block; tree tmp, null_mem, alloc, error; @@ -963,7 +975,7 @@ gfc_allocate_allocatable (stmtblock_t * block, tree mem, tree size, if (flag_coarray == GFC_FCOARRAY_LIB && (corank > 0 || caf_attr.codimension)) { - tree cond, sub_caf_tree; + tree cond2, sub_caf_tree; gfc_se se; bool compute_special_caf_types_size = false; @@ -1027,16 +1039,17 @@ gfc_allocate_allocatable (stmtblock_t * block, tree mem, tree size, { TREE_USED (label_finish) = 1; tmp = build1_v (GOTO_EXPR, label_finish); - cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, - status, build_zero_cst (TREE_TYPE (status))); + cond2 = fold_build2_loc (input_location, NE_EXPR, logical_type_node, + status, build_zero_cst (TREE_TYPE (status))); tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, - gfc_unlikely (cond, PRED_FORTRAN_FAIL_ALLOC), + gfc_unlikely (cond2, PRED_FORTRAN_FAIL_ALLOC), tmp, build_empty_stmt (input_location)); gfc_add_expr_to_block (&alloc_block, tmp); } } else - gfc_allocate_using_malloc (&alloc_block, mem, size, status); + gfc_allocate_using_malloc (&alloc_block, mem, size, status, + cond, alt_alloc, extra_success_expr); alloc = gfc_finish_block (&alloc_block); @@ -1781,6 +1794,7 @@ gfc_deallocate_with_status (tree pointer, tree status, tree errmsg, tree cond, tmp, error; tree status_type = NULL_TREE; tree token = NULL_TREE; + tree descr = NULL_TREE; gfc_coarray_deregtype caf_dereg_type = GFC_CAF_COARRAY_DEREGISTER; if (coarray_dealloc_mode >= GFC_CAF_COARRAY_ANALYZE) @@ -1788,7 +1802,11 @@ gfc_deallocate_with_status (tree pointer, tree status, tree errmsg, if (flag_coarray == GFC_FCOARRAY_LIB) { if (caf_token) - token = caf_token; + { + token = caf_token; + if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (pointer))) + pointer = gfc_conv_descriptor_data_get (pointer); + } else { tree caf_type, caf_decl = pointer; @@ -1824,7 +1842,10 @@ gfc_deallocate_with_status (tree pointer, tree status, tree errmsg, pointer = gfc_conv_descriptor_data_get (pointer); } else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (pointer))) - pointer = gfc_conv_descriptor_data_get (pointer); + { + descr = pointer; + pointer = gfc_conv_descriptor_data_get (pointer); + } cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, pointer, build_int_cst (TREE_TYPE (pointer), 0)); @@ -1876,9 +1897,27 @@ gfc_deallocate_with_status (tree pointer, tree status, tree errmsg, tmp = build_call_expr_loc (input_location, builtin_decl_explicit (BUILT_IN_FREE), 1, fold_convert (pvoid_type_node, pointer)); + if (flag_openmp_allocators && coarray_dealloc_mode < GFC_CAF_COARRAY_ANALYZE) + { + tree cond, omp_tmp; + if (descr) + cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, + gfc_conv_descriptor_version (descr), + build_int_cst (integer_type_node, 1)); + else + cond = gfc_omp_call_is_alloc (pointer); + omp_tmp = builtin_decl_explicit (BUILT_IN_GOMP_FREE); + omp_tmp = build_call_expr_loc (input_location, omp_tmp, 2, pointer, + build_zero_cst (ptr_type_node)); + tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), cond, + omp_tmp, tmp); + } gfc_add_expr_to_block (&non_null, tmp); gfc_add_modify (&non_null, pointer, build_int_cst (TREE_TYPE (pointer), 0)); + if (flag_openmp_allocators && descr) + gfc_add_modify (&non_null, gfc_conv_descriptor_version (descr), + build_zero_cst (integer_type_node)); if (status != NULL_TREE && !integer_zerop (status)) { @@ -2050,6 +2089,16 @@ gfc_deallocate_scalar_with_status (tree pointer, tree status, tree label_finish, tmp = build_call_expr_loc (input_location, builtin_decl_explicit (BUILT_IN_FREE), 1, fold_convert (pvoid_type_node, pointer)); + if (flag_openmp_allocators) + { + tree cond, omp_tmp; + cond = gfc_omp_call_is_alloc (pointer); + omp_tmp = builtin_decl_explicit (BUILT_IN_GOMP_FREE); + omp_tmp = build_call_expr_loc (input_location, omp_tmp, 2, pointer, + build_zero_cst (ptr_type_node)); + tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), cond, + omp_tmp, tmp); + } gfc_add_expr_to_block (&non_null, tmp); if (status != NULL_TREE && !integer_zerop (status)) @@ -2483,7 +2532,7 @@ trans_code (gfc_code * code, tree cond) break; case EXEC_ALLOCATE: - res = gfc_trans_allocate (code); + res = gfc_trans_allocate (code, NULL); break; case EXEC_DEALLOCATE: diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index 109d7647235..8bac342fdab 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -764,10 +764,14 @@ void gfc_allocate_using_caf_lib (stmtblock_t *, tree, tree, tree, tree, tree, /* Allocate memory for allocatable variables, with optional status variable. */ void gfc_allocate_allocatable (stmtblock_t*, tree, tree, tree, tree, - tree, tree, tree, gfc_expr*, int); + tree, tree, tree, gfc_expr*, int, + tree = NULL_TREE, tree = NULL_TREE, + tree = NULL_TREE); /* Allocate memory, with optional status variable. */ -void gfc_allocate_using_malloc (stmtblock_t *, tree, tree, tree); +void gfc_allocate_using_malloc (stmtblock_t *, tree, tree, tree, + tree = NULL_TREE, tree = NULL_TREE, + tree = NULL_TREE); /* Generate code to deallocate an array. */ tree gfc_deallocate_with_status (tree, tree, tree, tree, tree, bool, @@ -817,6 +821,8 @@ struct array_descr_info; bool gfc_get_array_descr_info (const_tree, struct array_descr_info *); /* In trans-openmp.cc */ +tree gfc_omp_call_add_alloc (tree); +tree gfc_omp_call_is_alloc (tree); bool gfc_omp_is_allocatable_or_ptr (const_tree); tree gfc_omp_check_optional_argument (tree, bool); tree gfc_omp_array_data (tree, bool); diff --git a/gcc/fortran/types.def b/gcc/fortran/types.def index 7a465c89c5f..5462381cdd4 100644 --- a/gcc/fortran/types.def +++ b/gcc/fortran/types.def @@ -155,6 +155,8 @@ DEF_FUNCTION_TYPE_3 (BT_FN_UINT_UINT_PTR_PTR, BT_UINT, BT_UINT, BT_PTR, BT_PTR) DEF_FUNCTION_TYPE_3 (BT_FN_PTR_SIZE_SIZE_PTRMODE, BT_PTR, BT_SIZE, BT_SIZE, BT_PTRMODE) +DEF_FUNCTION_TYPE_4 (BT_FN_PTR_PTR_SIZE_PTRMODE_PTRMODE, + BT_PTR, BT_PTR, BT_SIZE, BT_PTRMODE, BT_PTRMODE) DEF_FUNCTION_TYPE_4 (BT_FN_VOID_OMPFN_PTR_UINT_UINT, BT_VOID, BT_PTR_FN_VOID_PTR, BT_PTR, BT_UINT, BT_UINT) DEF_FUNCTION_TYPE_4 (BT_FN_UINT_OMPFN_PTR_UINT_UINT, diff --git a/gcc/gimple-ssa-warn-access.cc b/gcc/gimple-ssa-warn-access.cc index 8b734295f09..4916ee27ae0 100644 --- a/gcc/gimple-ssa-warn-access.cc +++ b/gcc/gimple-ssa-warn-access.cc @@ -1574,6 +1574,7 @@ fndecl_alloc_p (tree fndecl, bool all_alloc) case BUILT_IN_ALIGNED_ALLOC: case BUILT_IN_CALLOC: case BUILT_IN_GOMP_ALLOC: + case BUILT_IN_GOMP_REALLOC: case BUILT_IN_MALLOC: case BUILT_IN_REALLOC: case BUILT_IN_STRDUP: @@ -1801,9 +1802,20 @@ matching_alloc_calls_p (tree alloc_decl, tree dealloc_decl) case BUILT_IN_ALLOCA_WITH_ALIGN: return false; + case BUILT_IN_GOMP_ALLOC: + case BUILT_IN_GOMP_REALLOC: + if (DECL_IS_OPERATOR_DELETE_P (dealloc_decl)) + return false; + + if (fndecl_built_in_p (dealloc_decl, BUILT_IN_GOMP_FREE, + BUILT_IN_GOMP_REALLOC)) + return true; + + alloc_dealloc_kind = alloc_kind_t::builtin; + break; + case BUILT_IN_ALIGNED_ALLOC: case BUILT_IN_CALLOC: - case BUILT_IN_GOMP_ALLOC: case BUILT_IN_MALLOC: case BUILT_IN_REALLOC: case BUILT_IN_STRDUP: @@ -1829,7 +1841,8 @@ matching_alloc_calls_p (tree alloc_decl, tree dealloc_decl) if (fndecl_built_in_p (dealloc_decl, BUILT_IN_NORMAL)) { built_in_function dealloc_code = DECL_FUNCTION_CODE (dealloc_decl); - if (dealloc_code == BUILT_IN_REALLOC) + if (dealloc_code == BUILT_IN_REALLOC + || dealloc_code == BUILT_IN_GOMP_REALLOC) realloc_kind = alloc_kind_t::builtin; for (tree amats = DECL_ATTRIBUTES (alloc_decl); @@ -1882,6 +1895,7 @@ matching_alloc_calls_p (tree alloc_decl, tree dealloc_decl) case BUILT_IN_ALIGNED_ALLOC: case BUILT_IN_CALLOC: case BUILT_IN_GOMP_ALLOC: + case BUILT_IN_GOMP_REALLOC: case BUILT_IN_MALLOC: case BUILT_IN_REALLOC: case BUILT_IN_STRDUP: diff --git a/gcc/gimple.cc b/gcc/gimple.cc index 7924d900b35..67f3fb2dabf 100644 --- a/gcc/gimple.cc +++ b/gcc/gimple.cc @@ -2988,6 +2988,8 @@ nonfreeing_call_p (gimple *call) case BUILT_IN_TM_FREE: case BUILT_IN_REALLOC: case BUILT_IN_STACK_RESTORE: + case BUILT_IN_GOMP_FREE: + case BUILT_IN_GOMP_REALLOC: return false; default: return true; diff --git a/gcc/omp-builtins.def b/gcc/omp-builtins.def index ed78d49d205..7b6b1dca3e3 100644 --- a/gcc/omp-builtins.def +++ b/gcc/omp-builtins.def @@ -467,6 +467,9 @@ DEF_GOMP_BUILTIN (BUILT_IN_GOMP_WORKSHARE_TASK_REDUCTION_UNREGISTER, DEF_GOMP_BUILTIN (BUILT_IN_GOMP_ALLOC, "GOMP_alloc", BT_FN_PTR_SIZE_SIZE_PTRMODE, ATTR_ALLOC_WARN_UNUSED_RESULT_SIZE_2_NOTHROW_LIST) +DEF_GOMP_BUILTIN (BUILT_IN_GOMP_REALLOC, + "omp_realloc", BT_FN_PTR_PTR_SIZE_PTRMODE_PTRMODE, + ATTR_ALLOC_WARN_UNUSED_RESULT_SIZE_2_NOTHROW_LEAF_LIST) DEF_GOMP_BUILTIN (BUILT_IN_GOMP_FREE, "GOMP_free", BT_FN_VOID_PTR_PTRMODE, ATTR_NOTHROW_LEAF_LIST) DEF_GOMP_BUILTIN (BUILT_IN_GOMP_WARNING, "GOMP_warning", diff --git a/gcc/predict.cc b/gcc/predict.cc index 396746cbfd1..2e9b7dd07a7 100644 --- a/gcc/predict.cc +++ b/gcc/predict.cc @@ -2566,6 +2566,7 @@ expr_expected_value_1 (tree type, tree op0, enum tree_code code, *predictor = PRED_COMPARE_AND_SWAP; return boolean_true_node; case BUILT_IN_REALLOC: + case BUILT_IN_GOMP_REALLOC: if (predictor) *predictor = PRED_MALLOC_NONNULL; /* FIXME: This is wrong and we need to convert the logic diff --git a/gcc/testsuite/gfortran.dg/bind_c_array_params_2.f90 b/gcc/testsuite/gfortran.dg/bind_c_array_params_2.f90 index 04faa433435..0825efc7a2f 100644 --- a/gcc/testsuite/gfortran.dg/bind_c_array_params_2.f90 +++ b/gcc/testsuite/gfortran.dg/bind_c_array_params_2.f90 @@ -25,7 +25,7 @@ end ! { dg-final { scan-tree-dump "parm...span = 4;" "original" } } -! { dg-final { scan-tree-dump "parm...dtype = {.elem_len=4, .rank=2, .type=1};" "original" } } +! { dg-final { scan-tree-dump "parm...dtype = {.elem_len=4, .version=0, .rank=2, .type=1};" "original" } } ! { dg-final { scan-tree-dump "parm...dim\\\[0\\\].lbound = 1;" "original" } } ! { dg-final { scan-tree-dump "parm...dim\\\[0\\\].ubound = 4;" "original" } } ! { dg-final { scan-tree-dump "parm...dim\\\[0\\\].stride = 1;" "original" } } diff --git a/gcc/testsuite/gfortran.dg/gomp/allocate-14.f90 b/gcc/testsuite/gfortran.dg/gomp/allocate-14.f90 index 8ff9c252e49..4fed19249a3 100644 --- a/gcc/testsuite/gfortran.dg/gomp/allocate-14.f90 +++ b/gcc/testsuite/gfortran.dg/gomp/allocate-14.f90 @@ -93,3 +93,44 @@ subroutine c_and_func_ptrs !$omp allocate(cfunptr) ! OK? A normal derived-type var? !$omp allocate(p) ! { dg-error "Argument 'p' at .1. to declarative !.OMP ALLOCATE directive must be a variable" } end + + +subroutine coarray_2 + use m + implicit none + integer :: x + integer, allocatable :: a, b, c[:], d + x = 5 ! executable stmt + !$omp allocate(a,b) align(16) + !$omp allocate ! { dg-error "Unexpected coarray 'c' in 'allocate' at .1., implicitly listed in '!.OMP ALLOCATE' at .2." } + !$omp allocate(d) align(32) + allocate(a,b,c[*],d) ! { dg-error "Unexpected coarray 'c' in 'allocate' at .1., implicitly listed in '!.OMP ALLOCATE' at .2." } +end + + +subroutine coarray_3 + use m + implicit none + integer :: x + integer, allocatable :: a, b, c[:], d + x = 5 ! executable stmt + !$omp allocators allocate(align(16): a,b) allocate(align(32) : d) + allocate(a,b,c[*],d) ! OK - Fortran allocator used for 'C' +end + + +subroutine unclear + use m + implicit none + integer :: x + integer, allocatable :: a, b, c[:], d + + ! OpenMP is unclear which allocator is used for 'C' - the fortran one or the OpenMP one. + ! GCC therefore rejects it. + + x = 5 ! executable stmt + + !$omp allocate(a,b) align(16) + !$omp allocate(d) align(32) + allocate(a,b,c[*],d) ! { dg-error "'c' listed in 'allocate' statement at .1. but it is neither explicitly in listed in the '!.OMP ALLOCATE' directive nor exists a directive without argument list" } +end diff --git a/gcc/testsuite/gfortran.dg/gomp/allocate-16.f90 b/gcc/testsuite/gfortran.dg/gomp/allocate-16.f90 new file mode 100644 index 00000000000..6c203e02d57 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/allocate-16.f90 @@ -0,0 +1,10 @@ +integer, pointer :: ptr + +!$omp flush +!$omp allocate(ptr) +allocate(ptr) +end + +! { dg-error "'!.OMP ALLOCATE' at .1. requires '-fopenmp-allocators'" "" { target *-*-* } 4 } +! { dg-warning "All files that might deallocate such a variable must be compiled with '-fopenmp-allocators'" "" { target *-*-* } 4 } +! { dg-note "This includes explicit DEALLOCATE, reallocation on intrinsic assignment, INTENT\\(OUT\\) for allocatable dummy arguments, and reallocation of allocatable components allocated with an OpenMP allocator" "" { target *-*-* } 0 } diff --git a/gcc/testsuite/gfortran.dg/gomp/allocate-5.f90 b/gcc/testsuite/gfortran.dg/gomp/allocate-5.f90 index bf9c781dcc5..28369ae876b 100644 --- a/gcc/testsuite/gfortran.dg/gomp/allocate-5.f90 +++ b/gcc/testsuite/gfortran.dg/gomp/allocate-5.f90 @@ -1,3 +1,4 @@ +! { dg-additional-options "-fopenmp-allocators" } module my_omp_lib use iso_c_binding, only: c_intptr_t !use omp_lib @@ -45,15 +46,15 @@ subroutine two(c,x2,y2) class(t), pointer :: y2(:) !$omp flush ! some executable statement - !$omp allocate(a) ! { dg-message "not yet supported" } - allocate(a,b(4),c(3,4)) - deallocate(a,b,c) + !$omp allocate(a) + allocate(a) + deallocate(a) - !$omp allocate(x1,y1,x2,y2) ! { dg-message "not yet supported" } + !$omp allocate(x1,y1,x2,y2) allocate(x1,y1,x2(5),y2(5)) deallocate(x1,y1,x2,y2) - !$omp allocate(b,a) align ( 128 ) ! { dg-message "not yet supported" } + !$omp allocate(b,a) align ( 128 ) !$omp allocate align ( 64 ) allocate(a,b(4),c(3,4)) deallocate(a,b,c) @@ -66,7 +67,7 @@ subroutine three(c) integer, allocatable :: a, b(:), c(:,:) call foo() ! executable stmt - !$omp allocate allocator( omp_large_cap_mem_alloc ) , align(64) ! { dg-message "not yet supported" } + !$omp allocate allocator( omp_large_cap_mem_alloc ) , align(64) !$omp allocate(b) allocator( omp_high_bw_mem_alloc ) !$omp allocate(c) allocator( omp_high_bw_mem_alloc ) allocate(a,b(4),c(3,4)) @@ -74,7 +75,7 @@ subroutine three(c) block q = 5 ! executable stmt - !$omp allocate(a) align(64) ! { dg-message "not yet supported" } + !$omp allocate(a) align(64) !$omp allocate(b) allocator( omp_high_bw_mem_alloc ), align(32) !$omp allocate(c) allocator( omp_thread_mem_alloc ) allocate(a,b(4),c(3,4)) @@ -84,7 +85,7 @@ subroutine three(c) contains subroutine inner call foo() ! executable stmt - !$omp allocate(a) align(64) ! { dg-message "not yet supported" } + !$omp allocate(a) align(64) !$omp allocate(b) allocator( omp_high_bw_mem_alloc ), align(32) !$omp allocate(c) allocator( omp_thread_mem_alloc ) allocate(a,b(4),c(3,4)) diff --git a/gcc/testsuite/gfortran.dg/gomp/allocators-3.f90 b/gcc/testsuite/gfortran.dg/gomp/allocators-3.f90 new file mode 100644 index 00000000000..d0e31ee8727 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/allocators-3.f90 @@ -0,0 +1,36 @@ +subroutine f + integer, allocatable :: A1, A2, B(:), C + !$omp declare target + + !$omp allocators ! OK + allocate(A1) + + !$omp allocators allocate(align(8) : a2) ! { dg-error "ALLOCATORS directive at .1. inside a target region must specify an ALLOCATOR modifier for 'a2'" } + allocate(A2) + + !$omp allocate ! { dg-error "ALLOCATE directive at .1. inside a target region must specify an ALLOCATOR clause" } + allocate(B(5)) + + !$omp allocate(c) ! { dg-error "ALLOCATE directive at .1. inside a target region must specify an ALLOCATOR clause for 'c'" } + allocate(C) +end + +subroutine g + integer, allocatable :: A1, A2, B(:), C + + !$omp target + !$omp single + !$omp allocators ! OK + allocate(A1) + + !$omp allocators allocate(align(8) : a2) ! { dg-error "ALLOCATORS directive at .1. inside a target region must specify an ALLOCATOR modifier for 'a2'" } + allocate(A2) + + !$omp allocate ! { dg-error "ALLOCATE directive at .1. inside a target region must specify an ALLOCATOR clause" } + allocate(B(5)) + + !$omp allocate(c) ! { dg-error "ALLOCATE directive at .1. inside a target region must specify an ALLOCATOR clause for 'c'" } + allocate(C) + !$omp end single + !$omp end target +end diff --git a/gcc/testsuite/gfortran.dg/gomp/allocators-4.f90 b/gcc/testsuite/gfortran.dg/gomp/allocators-4.f90 new file mode 100644 index 00000000000..55ae48d61f2 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/allocators-4.f90 @@ -0,0 +1,9 @@ +integer, pointer :: ptr + +!$omp allocators allocate(ptr) +allocate(ptr) +end + +! { dg-error "'!.OMP ALLOCATORS' at .1. requires '-fopenmp-allocators'" "" { target *-*-* } 3 } +! { dg-warning "All files that might deallocate such a variable must be compiled with '-fopenmp-allocators'" "" { target *-*-* } 3 } +! { dg-note "This includes explicit DEALLOCATE, reallocation on intrinsic assignment, INTENT\\(OUT\\) for allocatable dummy arguments, and reallocation of allocatable components allocated with an OpenMP allocator" "" { target *-*-* } 0 } diff --git a/gcc/tree-ssa-ccp.cc b/gcc/tree-ssa-ccp.cc index 1a555ae6826..907fb3f6fdd 100644 --- a/gcc/tree-ssa-ccp.cc +++ b/gcc/tree-ssa-ccp.cc @@ -2346,6 +2346,7 @@ evaluate_stmt (gimple *stmt) { case BUILT_IN_MALLOC: case BUILT_IN_REALLOC: + case BUILT_IN_GOMP_REALLOC: case BUILT_IN_CALLOC: case BUILT_IN_STRDUP: case BUILT_IN_STRNDUP: diff --git a/gcc/tree.cc b/gcc/tree.cc index 33ea1d2e2d0..669256494bf 100644 --- a/gcc/tree.cc +++ b/gcc/tree.cc @@ -15002,6 +15002,8 @@ fndecl_dealloc_argno (tree fndecl) { case BUILT_IN_FREE: case BUILT_IN_REALLOC: + case BUILT_IN_GOMP_FREE: + case BUILT_IN_GOMP_REALLOC: return 0; default: break; diff --git a/libgomp/allocator.c b/libgomp/allocator.c index b4e50e2ad72..76ee93231fc 100644 --- a/libgomp/allocator.c +++ b/libgomp/allocator.c @@ -35,6 +35,69 @@ #include #endif +/* Keeping track whether a Fortran scalar allocatable/pointer has been + allocated via 'omp allocators'/'omp allocate'. */ + +struct fort_alloc_splay_tree_key_s { + void *ptr; +}; + +typedef struct fort_alloc_splay_tree_node_s *fort_alloc_splay_tree_node; +typedef struct fort_alloc_splay_tree_s *fort_alloc_splay_tree; +typedef struct fort_alloc_splay_tree_key_s *fort_alloc_splay_tree_key; + +static inline int +fort_alloc_splay_compare (fort_alloc_splay_tree_key x, fort_alloc_splay_tree_key y) +{ + if (x->ptr < y->ptr) + return -1; + if (x->ptr > y->ptr) + return 1; + return 0; +} +#define splay_tree_prefix fort_alloc +#define splay_tree_static +#include "splay-tree.h" + +#define splay_tree_prefix fort_alloc +#define splay_tree_static +#define splay_tree_c +#include "splay-tree.h" + +static struct fort_alloc_splay_tree_s fort_alloc_scalars; + +/* Add pointer as being alloced by GOMP_alloc. */ +void +GOMP_add_alloc (void *ptr) +{ + if (ptr == NULL) + return; + fort_alloc_splay_tree_node item; + item = gomp_malloc (sizeof (struct splay_tree_node_s)); + item->key.ptr = ptr; + item->left = NULL; + item->right = NULL; + fort_alloc_splay_tree_insert (&fort_alloc_scalars, item); +} + +/* Remove pointer, either called by FREE or by REALLOC, + either of them can change the allocation status. */ +bool +GOMP_is_alloc (void *ptr) +{ + struct fort_alloc_splay_tree_key_s needle; + fort_alloc_splay_tree_node n; + needle.ptr = ptr; + n = fort_alloc_splay_tree_lookup_node (&fort_alloc_scalars, &needle); + if (n) + { + fort_alloc_splay_tree_remove (&fort_alloc_scalars, &n->key); + free (n); + } + return n != NULL; +} + + #define omp_max_predefined_alloc omp_thread_mem_alloc enum gomp_numa_memkind_kind diff --git a/libgomp/libgomp.h b/libgomp/libgomp.h index 15a767cf317..9a111636607 100644 --- a/libgomp/libgomp.h +++ b/libgomp/libgomp.h @@ -1272,6 +1272,7 @@ reverse_splay_compare (reverse_splay_tree_key x, reverse_splay_tree_key y) } #define splay_tree_prefix reverse +#define splay_tree_static #include "splay-tree.h" /* Indirect target function splay-tree handling. */ diff --git a/libgomp/libgomp.map b/libgomp/libgomp.map index 90c401453b2..65901dff235 100644 --- a/libgomp/libgomp.map +++ b/libgomp/libgomp.map @@ -419,9 +419,15 @@ GOMP_5.1 { GOMP_5.1.1 { global: GOMP_taskwait_depend_nowait; - GOMP_target_map_indirect_ptr; } GOMP_5.1; +GOMP_5.1.2 { + global: + GOMP_add_alloc; + GOMP_is_alloc; + GOMP_target_map_indirect_ptr; +} GOMP_5.1.1; + OACC_2.0 { global: acc_get_num_devices; diff --git a/libgomp/libgomp.texi b/libgomp/libgomp.texi index 9cb893e7719..5fdc3b2a52f 100644 --- a/libgomp/libgomp.texi +++ b/libgomp/libgomp.texi @@ -232,7 +232,9 @@ The OpenMP 4.5 specification is fully supported. @item Predefined memory spaces, memory allocators, allocator traits @tab Y @tab See also @ref{Memory allocation} @item Memory management routines @tab Y @tab -@item @code{allocate} directive @tab P @tab Only C and Fortran, only stack variables +@item @code{allocate} directive @tab P + @tab Only C for stack/automatic and Fortran for stack/automatic + and allocatable/pointer variables @item @code{allocate} clause @tab P @tab Initial support @item @code{use_device_addr} clause on @code{target data} @tab Y @tab @item @code{ancestor} modifier on @code{device} clause @tab Y @tab @@ -304,7 +306,7 @@ The OpenMP 4.5 specification is fully supported. @item @code{strict} modifier in the @code{grainsize} and @code{num_tasks} clauses of the @code{taskloop} construct @tab Y @tab @item @code{align} clause in @code{allocate} directive @tab P - @tab Only C and Fortran (and only stack variables) + @tab Only C and Fortran (and not for static variables) @item @code{align} modifier in @code{allocate} clause @tab Y @tab @item @code{thread_limit} clause to @code{target} construct @tab Y @tab @item @code{has_device_addr} clause to @code{target} construct @tab Y @tab @@ -402,7 +404,7 @@ to address of matching mapped list item per 5.1, Sect. 2.21.7.2 @tab N @tab @item Deprecation of @code{to} clause on declare target directive @tab N @tab @item Extended list of directives permitted in Fortran pure procedures @tab Y @tab -@item New @code{allocators} directive for Fortran @tab N @tab +@item New @code{allocators} directive for Fortran @tab Y @tab @item Deprecation of @code{allocate} directive for Fortran allocatables/pointers @tab N @tab @item Optional paired @code{end} directive with @code{dispatch} @tab N @tab @@ -5657,8 +5659,12 @@ The description below applies to: @option{-fstack-arrays}].) @item Using the @code{allocate} directive for variable in static memory is currently not supported (compile time error). -@item Using the @code{allocators} directive for Fortran pointers and - allocatables is currently not supported (compile time error). +@item In Fortran, the @code{allocators} directive and the executable + @code{allocate} directive for Fortran pointers and allocatables is + supported, but requires that files containing those directives has to be + compiled with @option{-fopenmp-allocators}. Additionally, all files that + might explicitly or implicitly deallocate memory allocated that way must + also be compiled with that option. @end itemize For the available predefined allocators and, as applicable, their associated diff --git a/libgomp/splay-tree.c b/libgomp/splay-tree.c index 02695d4b2bd..9e076f55180 100644 --- a/libgomp/splay-tree.c +++ b/libgomp/splay-tree.c @@ -131,7 +131,11 @@ splay_tree_splay (splay_tree sp, splay_tree_key key) /* Insert a new NODE into SP. The NODE shouldn't exist in the tree. */ +#ifdef splay_tree_static +__attribute__((unused)) static void +#else attribute_hidden void +#endif splay_tree_insert (splay_tree sp, splay_tree_node node) { int comparison = 0; @@ -167,7 +171,11 @@ splay_tree_insert (splay_tree sp, splay_tree_node node) /* Remove node with KEY from SP. It is not an error if it did not exist. */ +#ifdef splay_tree_static +__attribute__((unused)) static void +#else attribute_hidden void +#endif splay_tree_remove (splay_tree sp, splay_tree_key key) { splay_tree_splay (sp, key); @@ -202,7 +210,28 @@ splay_tree_remove (splay_tree sp, splay_tree_key key) /* Lookup KEY in SP, returning NODE if present, and NULL otherwise. */ +#ifdef splay_tree_static +__attribute__((unused)) static splay_tree_node +#else +attribute_hidden splay_tree_node +#endif +splay_tree_lookup_node (splay_tree sp, splay_tree_key key) +{ + splay_tree_splay (sp, key); + + if (sp->root && splay_compare (&sp->root->key, key) == 0) + return sp->root; + else + return NULL; +} + +/* Likewise but return the key. */ + +#ifdef splay_tree_static +__attribute__((unused)) static splay_tree_key +#else attribute_hidden splay_tree_key +#endif splay_tree_lookup (splay_tree sp, splay_tree_key key) { splay_tree_splay (sp, key); @@ -231,7 +260,11 @@ splay_tree_foreach_internal (splay_tree_node node, splay_tree_callback func, /* Run FUNC on each of the nodes in SP. */ +#ifdef splay_tree_static +__attribute__((unused)) static void +#else attribute_hidden void +#endif splay_tree_foreach (splay_tree sp, splay_tree_callback func, void *data) { splay_tree_foreach_internal (sp->root, func, data); @@ -253,8 +286,13 @@ splay_tree_foreach_internal_lazy (splay_tree_node node, return splay_tree_foreach_internal_lazy (node->right, func, data); } +#ifdef splay_tree_static +__attribute__((unused)) static void +#else attribute_hidden void -splay_tree_foreach_lazy (splay_tree sp, splay_tree_callback_stop func, void *data) +#endif +splay_tree_foreach_lazy (splay_tree sp, splay_tree_callback_stop func, + void *data) { splay_tree_foreach_internal_lazy (sp->root, func, data); } diff --git a/libgomp/splay-tree.h b/libgomp/splay-tree.h index 978f1e49800..04ff94739b0 100644 --- a/libgomp/splay-tree.h +++ b/libgomp/splay-tree.h @@ -35,6 +35,8 @@ typedef struct splay_tree_key_s *splay_tree_key; define splay_tree_key_s structure, and define splay_compare inline function. + Define splay_tree_static to mark all functions as static. + Alternatively, they can define splay_tree_prefix macro before including this header and then all the above types, the splay_compare function and the splay_tree_{lookup,insert_remove} @@ -72,6 +74,8 @@ typedef struct splay_tree_key_s *splay_tree_key; splay_tree_name (splay_tree_prefix, splay_compare) # define splay_tree_lookup \ splay_tree_name (splay_tree_prefix, splay_tree_lookup) +# define splay_tree_lookup_node \ + splay_tree_name (splay_tree_prefix, splay_tree_lookup_node) # define splay_tree_insert \ splay_tree_name (splay_tree_prefix, splay_tree_insert) # define splay_tree_remove \ @@ -105,11 +109,19 @@ struct splay_tree_s { typedef void (*splay_tree_callback) (splay_tree_key, void *); typedef int (*splay_tree_callback_stop) (splay_tree_key, void *); +#ifndef splay_tree_static extern splay_tree_key splay_tree_lookup (splay_tree, splay_tree_key); +extern splay_tree_node splay_tree_lookup_node (splay_tree, splay_tree_key); extern void splay_tree_insert (splay_tree, splay_tree_node); extern void splay_tree_remove (splay_tree, splay_tree_key); extern void splay_tree_foreach (splay_tree, splay_tree_callback, void *); extern void splay_tree_foreach_lazy (splay_tree, splay_tree_callback_stop, void *); +#endif + +#ifdef splay_tree_static_unused_attr +# undef splay_tree_static_unused_attr +#endif + #else /* splay_tree_c */ # ifdef splay_tree_prefix # include "splay-tree.c" @@ -117,6 +129,10 @@ extern void splay_tree_foreach_lazy (splay_tree, splay_tree_callback_stop, void # undef splay_tree_c #endif /* #ifndef splay_tree_c */ +#ifdef splay_tree_static +# undef splay_tree_static +#endif + #ifdef splay_tree_prefix # undef splay_tree_name_1 # undef splay_tree_name @@ -128,6 +144,7 @@ extern void splay_tree_foreach_lazy (splay_tree, splay_tree_callback_stop, void # undef splay_tree_key # undef splay_compare # undef splay_tree_lookup +# undef splay_tree_lookup_node # undef splay_tree_insert # undef splay_tree_remove # undef splay_tree_foreach diff --git a/libgomp/target.c b/libgomp/target.c index f30c20255d3..0637d34f125 100644 --- a/libgomp/target.c +++ b/libgomp/target.c @@ -47,6 +47,7 @@ /* Define another splay tree instantiation - for reverse offload. */ #define splay_tree_prefix reverse +#define splay_tree_static #define splay_tree_c #include "splay-tree.h" diff --git a/libgomp/testsuite/libgomp.fortran/allocators-1.f90 b/libgomp/testsuite/libgomp.fortran/allocators-1.f90 new file mode 100644 index 00000000000..935a37cd959 --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/allocators-1.f90 @@ -0,0 +1,68 @@ +! { dg-additional-options "-fopenmp-allocators -fdump-tree-original" } +module m + use omp_lib + use iso_c_binding, only: c_intptr_t + implicit none (type,external) + integer(omp_allocator_handle_kind) :: handle + integer(c_intptr_t) :: iptr +end module m + +subroutine scalar + use m + implicit none (type,external) + integer :: i + integer, allocatable :: SSS + i = 5 ! required executive statement before 'omp allocators' + !$omp allocate allocator(handle) + allocate(SSS) + if (mod (loc (sss), 64) /= 0) stop 1 + deallocate(SSS) + allocate(SSS) +end +! { dg-final { scan-tree-dump-times "sss = \\(integer\\(kind=4\\) \\*\\) __builtin_GOMP_alloc \\(4, 4, D\\.\[0-9\]+\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "GOMP_add_alloc \\(sss\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "if \\(GOMP_is_alloc \\(sss\\)\\)" 2 "original" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_free \\(sss, 0B\\);" 2 "original" } } + +subroutine array + use m + implicit none (type,external) + integer :: i + integer, allocatable :: A(:) + i = 5 ! required executive statement before 'omp allocators' + !$omp allocate allocator(handle) align(512) + allocate(A(5)) + if (mod (loc (A), 512) /= 0) stop 2 + A=[1] + if (mod (loc (A), 64) /= 0) stop 3 + deallocate(A) + A=[1] + deallocate(A) + call omp_set_default_allocator (handle) + !$omp allocate + allocate(A(7)) + if (mod (loc (A), 64) /= 0) stop 4 +end +! { dg-final { scan-tree-dump-times "a.dtype = {.elem_len=4, .version=0, .rank=1, .type=1};" 5 "original" } } +! { dg-final { scan-tree-dump-times "\\.elem_len=4" 5 "original" } } +! { dg-final { scan-tree-dump-times "a.data = \\(void \\* restrict\\) __builtin_GOMP_alloc \\(512, 20, D\\.\[0-9\]+\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "a.data = \\(void \\* restrict\\) __builtin_GOMP_alloc \\(4, 28, 0B\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "a.dtype.version = 1;" 2 "original" } } +! { dg-final { scan-tree-dump-times "a.data = \\(void \\* restrict\\) \\(a.dtype.version == 1 \\? __builtin_omp_realloc \\(\\(void \\*\\) a.data, 4, 0B, 0B\\) : __builtin_realloc \\(\\(void \\*\\) a.data, 4\\)\\);" 2 "original" } } +! { dg-final { scan-tree-dump-times "if \\(a.dtype.version == 1\\)" 3 "original" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_free \\(\\(integer\\(kind=4\\)\\\[0:\\\] \\* restrict\\) a.data, 0B\\);" 3 "original" } } +! { dg-final { scan-tree-dump-times "a.dtype.version = 0;" 3 "original" } } + +program main + use m + implicit none (type,external) + external :: scalar, array + type (omp_alloctrait), parameter :: traits(*) & + = [omp_alloctrait(omp_atk_sync_hint, omp_atv_contended), & + omp_alloctrait(omp_atk_alignment, 64)] + handle = omp_init_allocator (omp_high_bw_mem_alloc, size(traits), traits) + call scalar + call array + call omp_destroy_allocator (handle) +end + diff --git a/libgomp/testsuite/libgomp.fortran/allocators-2.f90 b/libgomp/testsuite/libgomp.fortran/allocators-2.f90 new file mode 100644 index 00000000000..c42fbd31e3e --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/allocators-2.f90 @@ -0,0 +1,101 @@ +! { dg-additional-options "-fopenmp-allocators" } +module m + implicit none (type, external) + type t + integer, allocatable :: Acomp, Bcomp(:) + end type t + +contains + +subroutine intent_out(aa, bb, cc, dd, ee, ff) + integer, allocatable,intent(out) :: aa, bb(:) + type(t), intent(out) :: cc, dd(4) + type(t), allocatable, intent(out) :: ee, ff(:) +end + +subroutine q(qa, qb, qc, qd, qe, qf) + integer, allocatable :: qa, qb(:) + type(t) :: qc, qd(4) + type(t), allocatable :: qe, qf(:) + call intent_out (qa, qb, qc, qd, qe, qf) +end subroutine q + +subroutine r + integer, allocatable :: r1, r2(:) + type(t) :: r3, r4(4) + type(t), allocatable :: r5, r6(:) + + call q(r1,r2,r3,r4,r5,r6) + + allocate(r1,r2(3)) + allocate(r5,r6(4)) + allocate(r3%Acomp, r3%Bcomp(2)) + allocate(r4(2)%Acomp, r4(2)%Bcomp(2)) + allocate(r5%Acomp, r5%Bcomp(2)) + allocate(r6(3)%Acomp, r6(3)%Bcomp(2)) + !$omp allocate align(128) + allocate(r4(3)%Acomp, r4(3)%Bcomp(2), & + r6(1)%Acomp, r6(1)%Bcomp(2)) + if (mod (loc (r4(3)%Acomp), 128) /= 0) stop 1 + if (mod (loc (r4(3)%Bcomp), 128) /= 0) stop 2 + if (mod (loc (r6(1)%Acomp), 128) /= 0) stop 3 + if (mod (loc (r6(1)%Bcomp), 128) /= 0) stop 3 + call q(r1,r2,r3,r4,r5,r6) + + !$omp allocate align(64) + allocate(r1,r2(3)) + if (mod (loc (r1), 64) /= 0) stop 1 + if (mod (loc (r2), 64) /= 0) stop 1 + !$omp allocate align(64) + allocate(r5,r6(4)) + if (mod (loc (r5), 64) /= 0) stop 1 + if (mod (loc (r6), 64) /= 0) stop 1 + !$omp allocate align(64) + allocate(r3%Acomp, r3%Bcomp(2)) + if (mod (loc (r3%Acomp), 64) /= 0) stop 1 + if (mod (loc (r3%Bcomp), 64) /= 0) stop 1 + !$omp allocate align(64) + allocate(r4(2)%Acomp, r4(2)%Bcomp(2)) + if (mod (loc (r4(2)%Acomp), 64) /= 0) stop 1 + if (mod (loc (r4(2)%Bcomp), 64) /= 0) stop 1 + !$omp allocate align(64) + allocate(r5%Acomp, r5%Bcomp(2)) + if (mod (loc (r5%Acomp), 64) /= 0) stop 1 + if (mod (loc (r5%Bcomp), 64) /= 0) stop 1 + !$omp allocate align(64) + allocate(r6(3)%Acomp, r6(3)%Bcomp(2)) + if (mod (loc (r6(3)%Acomp), 64) /= 0) stop 1 + if (mod (loc (r6(3)%Bcomp), 64) /= 0) stop 1 + !$omp allocate align(128) + allocate(r4(3)%Acomp, r4(3)%Bcomp(2), & + r6(1)%Acomp, r6(1)%Bcomp(2)) + if (mod (loc (r4(3)%Acomp), 128) /= 0) stop 1 + if (mod (loc (r4(3)%Bcomp), 128) /= 0) stop 2 + if (mod (loc (r6(1)%Acomp), 128) /= 0) stop 3 + if (mod (loc (r6(1)%Bcomp), 128) /= 0) stop 3 + call q(r1,r2,r3,r4,r5,r6) +end subroutine r +end + +subroutine s + use m, only : t + implicit none (type, external) + type(t) :: xx + integer :: i, iiiiii + i = 4 + !$omp allocate + allocate(xx%Acomp, xx%Bcomp(4)) + deallocate(xx%Acomp, xx%Bcomp) + + !$omp allocate + allocate(xx%Acomp, xx%Bcomp(4)) + xx = t(1, [1,2]) +end + +program main + use m, only: r + implicit none (type, external) + external s + call s + call r +end diff --git a/libgomp/testsuite/libgomp.fortran/allocators-3.f90 b/libgomp/testsuite/libgomp.fortran/allocators-3.f90 new file mode 100644 index 00000000000..2e05939a8b6 --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/allocators-3.f90 @@ -0,0 +1,25 @@ +! { dg-additional-options "-fdump-tree-original -fopenmp-allocators" } + +subroutine s + character(:), allocatable :: s1,s2 + + !$omp allocators allocate(s1) + allocate(character(len=3) :: s1) + + !$omp allocators allocate(s2) + allocate(character(len=5) :: s2) + + s2(1:5) = "12" + s1 = trim(s2) +end +! { dg-final { scan-tree-dump-times "s1 = \\(character\\(kind=1\\)\\\[1:.s1\\\] \\*\\) __builtin_GOMP_alloc \\(1, 3, 0B\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "s2 = \\(character\\(kind=1\\)\\\[1:.s2\\\] \\*\\) __builtin_GOMP_alloc \\(1, 5, 0B\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "s1 = \\(character\\(kind=1\\)\\\[1:.s1\\\] \\*\\) \\(D\\.\[0-9\]+ \\? __builtin_omp_realloc \\(\\(void \\*\\) s1, MAX_EXPR <\\(sizetype\\) len.1, 1>, 0B, 0B\\) : __builtin_realloc \\(\\(void \\*\\) s1, MAX_EXPR <\\(sizetype\\) len.1, 1>\\)\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "GOMP_add_alloc \\(s1\\);" 2 "original" } } +! { dg-final { scan-tree-dump-times "OMP_add_alloc \\(s2\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "if \\(GOMP_is_alloc \\(s2\\)\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_free \\(s2, 0B\\);" 1 "original" } } + + +call s +end diff --git a/libgomp/testsuite/libgomp.fortran/allocators-4.f90 b/libgomp/testsuite/libgomp.fortran/allocators-4.f90 new file mode 100644 index 00000000000..12689ea41ac --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/allocators-4.f90 @@ -0,0 +1,57 @@ +! { dg-additional-options "-fopenmp-allocators" } +module m +implicit none +type t + integer, allocatable :: Acomp, Bcomp(:) + class(*), allocatable :: Ccomp, Dcomp(:) +end type t +contains + +subroutine intout(c,d,e,f) +implicit none +class(t), intent(out) :: c,d(4) +class(t), allocatable, intent(out) :: e,f(:) +end + +subroutine q(c,d,e,f) +implicit none +class(t) :: c,d(4) +class(t), allocatable :: e,f(:) +call intout(c,d,e,f) +end subroutine q + +subroutine s +implicit none +type(t) :: xx +class(t), allocatable :: yy +integer :: i, iiiiii +i = 4 +!$omp allocate +allocate(xx%Acomp, xx%Bcomp(4)) +deallocate(xx%Acomp, xx%Bcomp) + +!$omp allocate +allocate(integer :: xx%Ccomp, xx%Dcomp(4)) +deallocate(xx%Ccomp, xx%Dcomp) + +!$omp allocators allocate(yy) +allocate(t :: yy) + +!$omp allocate +allocate(real :: xx%Ccomp, xx%Dcomp(4)) +deallocate(xx%Ccomp, xx%Dcomp) + +!$omp allocate +allocate(xx%Acomp, xx%Bcomp(4)) +!$omp allocate +allocate(logical :: xx%Ccomp, xx%Dcomp(4)) + +iiiiii = 555 +xx = t(1, [1,2]) +end + +end module + +use m +call s +end diff --git a/libgomp/testsuite/libgomp.fortran/allocators-5.f90 b/libgomp/testsuite/libgomp.fortran/allocators-5.f90 new file mode 100644 index 00000000000..87088630197 --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/allocators-5.f90 @@ -0,0 +1,27 @@ +! { dg-additional-options "-fopenmp-allocators" } +module m +contains +subroutine s(a,b,c,d) +integer, allocatable :: A, B +integer, allocatable :: C(:), D(:) + +!$omp allocators allocate(A,B) +allocate(A,B) +call move_alloc(A,B) + +!$omp allocators allocate(C,D) +allocate(C(5),D(5)) +call move_alloc(C,D) +end + +subroutine q() +integer, allocatable :: A, B +integer, allocatable :: C(:), D(:) + +call s(a,b,c,d) +end +end + +use m +call q +end