#include "trans-stmt.h"
#include "gomp-constants.h"
#include "gimplify.h"
+#include "context.h"
#include "omp-general.h"
+#include "omp-offload.h"
#include "attr-fnspec.h"
#include "tree-iterator.h"
#include "dependency.h"
}
-static tree
-add_attributes_to_decl (symbol_attribute sym_attr, tree list)
+static void
+add_attributes_to_decl (tree *decl_p, const gfc_symbol *sym)
{
unsigned id;
- tree attr;
+ tree list = NULL_TREE;
+ symbol_attribute sym_attr = sym->attr;
for (id = 0; id < EXT_ATTR_NUM; id++)
if (sym_attr.ext_attr & (1 << id) && ext_attr_list[id].middle_end_name)
{
- attr = build_tree_list (
- get_identifier (ext_attr_list[id].middle_end_name),
- NULL_TREE);
- list = chainon (list, attr);
+ tree ident = get_identifier (ext_attr_list[id].middle_end_name);
+ list = tree_cons (ident, NULL_TREE, list);
}
tree clauses = NULL_TREE;
clauses = c;
}
+ bool has_declare = true;
if (sym_attr.omp_declare_target_link
|| sym_attr.oacc_declare_link)
list = tree_cons (get_identifier ("omp declare target link"),
|| sym_attr.oacc_declare_device_resident)
list = tree_cons (get_identifier ("omp declare target"),
clauses, list);
+ else
+ has_declare = false;
if (sym_attr.omp_declare_target_indirect)
list = tree_cons (get_identifier ("omp declare target indirect"),
clauses, list);
- return list;
+ decl_attributes (decl_p, list, 0);
+
+ if (has_declare
+ && VAR_P (*decl_p)
+ && sym->ns->proc_name->attr.flavor != FL_MODULE)
+ {
+ has_declare = false;
+ for (gfc_namespace* ns = sym->ns->contained; ns; ns = ns->sibling)
+ if (ns->proc_name->attr.omp_declare_target)
+ {
+ has_declare = true;
+ break;
+ }
+ }
+
+ if (has_declare && VAR_P (*decl_p) && has_declare)
+ {
+ /* Add to offload_vars; get_create does so for omp_declare_target,
+ omp_declare_target_link requires manual work. */
+ gcc_assert (symtab_node::get (*decl_p) == 0);
+ symtab_node *node = symtab_node::get_create (*decl_p);
+ if (node != NULL && sym_attr.omp_declare_target_link)
+ {
+ node->offloadable = 1;
+ if (ENABLE_OFFLOADING)
+ {
+ g->have_offload = true;
+ if (is_a <varpool_node *> (node))
+ vec_safe_push (offload_vars, *decl_p);
+ }
+ }
+ }
}
{
tree decl;
tree length = NULL_TREE;
- tree attributes;
int byref;
bool intrinsic_array_parameter = false;
bool fun_or_res;
decl = build_decl (gfc_get_location (&sym->declared_at),
VAR_DECL, gfc_sym_identifier (sym), gfc_sym_type (sym));
- /* Add attributes to variables. Functions are handled elsewhere. */
- attributes = add_attributes_to_decl (sym->attr, NULL_TREE);
- decl_attributes (&decl, attributes, 0);
- if (sym->ts.deferred && VAR_P (length))
- decl_attributes (&length, attributes, 0);
-
/* Symbols from modules should have their assembler names mangled.
This is done here rather than in gfc_finish_var_decl because it
is different for string length variables. */
TREE_READONLY (decl) = 1;
}
+ /* Add attributes to variables. Functions are handled elsewhere. */
+ add_attributes_to_decl (&decl, sym);
+
+ if (sym->ts.deferred && VAR_P (length))
+ decl_attributes (&length, DECL_ATTRIBUTES (decl), 0);
+
return decl;
}
get_proc_pointer_decl (gfc_symbol *sym)
{
tree decl;
- tree attributes;
if (sym->module || sym->fn_result_spec)
{
&& (TREE_STATIC (decl) || DECL_EXTERNAL (decl)))
set_decl_tls_model (decl, decl_default_tls_model (decl));
- attributes = add_attributes_to_decl (sym->attr, NULL_TREE);
- decl_attributes (&decl, attributes, 0);
+ add_attributes_to_decl (&decl, sym);
return decl;
}
{
tree type;
tree fndecl;
- tree attributes;
gfc_expr e;
gfc_intrinsic_sym *isym;
gfc_expr argexpr;
DECL_EXTERNAL (fndecl) = 1;
TREE_PUBLIC (fndecl) = 1;
- attributes = add_attributes_to_decl (sym->attr, NULL_TREE);
- decl_attributes (&fndecl, attributes, 0);
+ add_attributes_to_decl (&fndecl, sym);
gfc_set_decl_assembler_name (fndecl, mangled_name);
static void
build_function_decl (gfc_symbol * sym, bool global)
{
- tree fndecl, type, attributes;
+ tree fndecl, type;
symbol_attribute attr;
tree result_decl;
gfc_formal_arglist *f;
if (sym->attr.referenced || sym->attr.entry_master)
TREE_USED (fndecl) = 1;
- attributes = add_attributes_to_decl (attr, NULL_TREE);
- decl_attributes (&fndecl, attributes, 0);
+ add_attributes_to_decl (&fndecl, sym);
/* Figure out the return type of the declared function, and build a
RESULT_DECL for it. If this is a subroutine with alternate
returns, build a RESULT_DECL for it. */
result_decl = NULL_TREE;
/* TODO: Shouldn't this just be TREE_TYPE (TREE_TYPE (fndecl)). */
- if (attr.function)
+ if (sym->attr.function)
{
if (gfc_return_by_reference (sym))
type = void_type_node;
/* Set attributes for PURE functions. A call to a PURE function in the
Fortran 95 sense is both pure and without side effects in the C
sense. */
- if (attr.pure || attr.implicit_pure)
+ if (sym->attr.pure || sym->attr.implicit_pure)
{
/* TODO: check if a pure SUBROUTINE has no INTENT(OUT) arguments
including an alternate return. In that case it can also be
--- /dev/null
+! { dg-additional-options "-Wall" }
+! PR fortran/115559
+
+module m
+ integer :: A
+ !$omp declare target link(A)
+end module m
+
+subroutine f
+ implicit none (type, external)
+ integer, save :: x, y ! { dg-warning "Unused variable 'y' declared" }
+ !$omp declare target link(x, y)
+
+ ! note: y is not 'link' as gfortran doesn't regard it as used
+ x = 6
+ call ii
+
+contains
+ subroutine k
+ !$omp declare target
+ use m
+ A = 5
+ end
+ subroutine ii
+ integer :: res
+ !$omp target map(x) map(from: res)
+ call k()
+ call ll()
+ res = get()
+ !$omp end target
+ ! print *, res
+ if (res /= 6 + 7 + 5) &
+ stop 1
+ end
+ subroutine ll
+ !$omp declare target
+ x = x + 7
+ end
+ integer function get()
+ use m
+ !$omp declare target
+ get = x + A
+ end
+end
+
+
+subroutine sub
+ implicit none (type, external)
+ integer, save :: arr(100), arr2(1:4)
+ !$omp declare target link(arr,arr2)
+
+ call mapit
+ call device1
+ call re_mapit
+ call device2
+contains
+ subroutine mapit
+ integer :: i
+ arr = [(i, i=1,100)]
+ !$omp target enter data map(to:arr(10:50)) map(alloc: arr2(1:4))
+ end subroutine
+ subroutine re_mapit
+ integer :: i
+ !$omp target exit data map(from:arr(10:50)) map(delete: arr2)
+
+ if (any (arr(1:9) /= [(i, i=1,9)])) stop 2
+ if (any (arr(10:50) /= [(3-10*i, i=10,50)])) stop 3
+ if (any (arr(51:100) /= [(i, i=51,100)])) stop 4
+ end subroutine
+
+ subroutine device1
+ integer :: res
+ !$omp target map(from:res)
+ res = run_device1()
+ !$omp end target
+ print *, res
+ ! FIXME: arr2 not link mapped -> PR115637
+ ! if (res /= -11436) stop 5
+ if (res /= -11546) stop 5 ! FIXME
+ end
+ integer function run_device1()
+ !$omp declare target
+ integer :: i
+ run_device1 = -99
+ ! FIXME: arr2 not link mapped -> PR115637
+ ! arr2 = [11,22,33,44]
+ if (any (arr(10:50) /= [(i, i=10,50)])) then
+ run_device1 = arr(11)
+ return
+ end if
+ ! FIXME: -> PR115637
+ ! run_device1 = sum(arr(10:13) + arr2)
+ run_device1 = sum(arr(10:13) ) ! FIXME
+ do i = 10, 50
+ arr(i) = 3 - 10 * arr(i)
+ end do
+ run_device1 = run_device1 + sum(arr(15:50))
+ end
+ subroutine device2
+ end
+ integer function run_device2()
+ !$omp declare target
+ run_device2 = -99
+ end
+end
+
+
+use m
+implicit none (type, external)
+external f
+external sub
+
+!$omp target enter data map(alloc: A)
+call f()
+call sub
+end
projects / thirdparty / gcc.git / commitdiff
