Skip to content
Permalink
Browse files

Merge pull request #841 from ThePortlandGroup/nv_stage

Pull 2019-11-26T15-28 Recent NVIDIA Changes
  • Loading branch information
sscalpone committed Nov 29, 2019
2 parents cbadb27 + 265c9c9 commit 619685549603ef0dd166614c17610dbb4908d010
@@ -396,6 +396,17 @@ I8(__alloc04)(__NELEM_T nelem, dtype kind, size_t len,
if (!ISPRESENT(errmsg))
errmsg = NULL;

if (*pointer && I8(__fort_allocated)(*pointer)
&& ISPRESENT(stat) && *stat == 2) {
int i;
char *mp;
MP_P_STDIO;
mp = "array already allocated";
for (i = 0; i < errlen; i++)
errmsg[i] = (*mp ? *mp++ : ' ');
MP_V_STDIO;
}

#if (defined(WIN64) || defined(WIN32))
#define ALN_LARGE
#else
@@ -912,7 +923,13 @@ ENTF90(ALLOC03_CHKA, alloc03_chka)(__INT_T *nelem, __INT_T *kind, __INT_T *len,
{

if (*pointer && I8(__fort_allocated)(*pointer)) {
__fort_abort("ALLOCATE: array already allocated");
if (ISPRESENT(stat)) {
*stat = 2;
} else {
__fort_abort("ALLOCATE: array already allocated");
}
} else if (ISPRESENT(stat) && *firsttime) {
*stat = 0;
}
ENTF90(ALLOC03,alloc03)(nelem, kind, len, stat, pointer, offset,
firsttime,CADR(errmsg), CLEN(errmsg));
@@ -937,7 +954,7 @@ ENTF90(ALLOC04A, alloc04a)(__NELEM_T *nelem, __INT_T *kind, __INT_T *len,
{
ALLHDR();

if (ISPRESENT(stat) && *firsttime)
if (ISPRESENT(stat) && *firsttime && *stat != 2)
*stat = 0;

if (!ISPRESENT(stat) && !*align) {
@@ -977,7 +994,13 @@ ENTF90(ALLOC04_CHKA, alloc04_chka)(__NELEM_T *nelem, __INT_T *kind,
{

if (*pointer && I8(__fort_allocated)(*pointer)) {
__fort_abort("ALLOCATE: array already allocated");
if (ISPRESENT(stat)) {
*stat = 2;
} else {
__fort_abort("ALLOCATE: array already allocated");
}
} else if (ISPRESENT(stat) && *firsttime) {
*stat = 0;
}
ENTF90(ALLOC04,alloc04)(nelem, kind, len, stat, pointer, offset, firsttime,
align, CADR(errmsg), CLEN(errmsg));
@@ -32,7 +32,7 @@ ENTFTN(TEMPLATE, template)(F90_Desc *dd, __INT_T *p_rank,

#include <string.h>
#include "fort_vars.h"
#if defined(TARGET_LINUX_X8664) || defined (TARGET_LINUX_POWER) || defined(TARGET_OSX_X8664)
#if defined(TARGET_LINUX_X8664) || defined (TARGET_LINUX_POWER) || defined(TARGET_OSX_X8664) || defined(TARGET_LINUX_ARM32) || defined(TARGET_LINUX_ARM64)
#include <unistd.h>
#include <sys/wait.h>
#endif
@@ -2849,7 +2849,7 @@ ENTF90(EXECCMDLINE, execcmdline)(DCHAR(command), __LOG_T *wait,

if (cmdstat)
store_int_kind(cmdstat, cmdstat_int_kind, 0);
#if defined(TARGET_LINUX_X8664) || defined(TARGET_OSX_X8664) || defined (TARGET_LINUX_POWER)
#if defined(TARGET_LINUX_X8664) || defined(TARGET_OSX_X8664) || defined(TARGET_LINUX_POWER) || defined(TARGET_LINUX_ARM32) || defined(TARGET_LINUX_ARM64)
pid_t pid, w;
int wstatus, ret;

@@ -36,6 +36,7 @@ static void sourced_alloc_and_assign_array(int extent, char *ab, char *bb, TYPE_
static void sourced_alloc_and_assign_array_from_scalar(int extent, char *ab, char *bb, TYPE_DESC *td);

static void get_source_and_dest_sizes(F90_Desc *ad, F90_Desc *bd, int *dest_sz, int *src_sz, int *dest_is_array, int *src_is_array, TYPE_DESC **tad, TYPE_DESC **tbd, __INT_T flag);
static int has_intrin_type(F90_Desc *dd);

#define ARG1_PTR 0x1
#define ARG1_ALLOC 0x2
@@ -1676,6 +1677,8 @@ static struct type_desc *I8(__f03_ty_to_id)[__NTYPES] = {
0,
0,
0,
0,
0,
0};

void ENTF90(SET_INTRIN_TYPE, set_intrin_type)(F90_Desc *dd, __INT_T intrin_type)
@@ -1829,6 +1832,31 @@ void ENTF90(POLY_ASN_DEST_INTRIN,
ENTF90(POLY_ASN, poly_asn)(ab, ad, bb, bd, flag);
}

/** \brief This routine checks whether a descriptor is associated with an
* intrinsic type.
*
* \param dd is the descriptor we are testing.
*
* \return 1 if \param dd is associated with an intinsinc type, else 0.
*/
static int has_intrin_type(F90_Desc *dd)
{
int i;
OBJECT_DESC *td = (OBJECT_DESC *)dd;
int is_intrin_type = 0;

if (td->type == NULL)
return 0;

for(i=0; i < __NTYPES; ++i) {
if (td->type == I8(__f03_ty_to_id)[i]) {
return 1;
}
}

return 0;
}

void ENTF90(INIT_UNL_POLY_DESC, init_unl_poly_desc)(F90_Desc *dd, F90_Desc *sd,
__INT_T kind)
{
@@ -1842,12 +1870,16 @@ void ENTF90(INIT_UNL_POLY_DESC, init_unl_poly_desc)(F90_Desc *dd, F90_Desc *sd,
}
dd->kind = kind;
} else {
dd->len = (sd && sd->tag == __DESC) ? sd->len : 0;
dd->tag = __DESC;
dd->len = (sd && (sd->tag == __DESC || sd->tag == __POLY)) ? sd->len : 0;
dd->tag = __POLY;
dd->rank = 0;
dd->lsize = 0;
dd->gsize = 0;
dd->kind = kind;
if (sd && (sd->tag == __DESC || sd->tag == __POLY ||
has_intrin_type(sd))) {
ENTF90(SET_TYPE, set_type)(dd, sd);
}
}
}

@@ -0,0 +1,35 @@
#
# Copyright (c) 2019, NVIDIA CORPORATION. All rights reserved.
#
# Licensed under the Apache License, Version 2.0 (the "License");
# you may not use this file except in compliance with the License.
# You may obtain a copy of the License at
#
# http://www.apache.org/licenses/LICENSE-2.0
#
# Unless required by applicable law or agreed to in writing, software
# distributed under the License is distributed on an "AS IS" BASIS,
# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
# See the License for the specific language governing permissions and
# limitations under the License.
#
#
########## Make rule for test pp73 ########


pp73: run


build: $(SRC)/pp73.f90
-$(RM) pp73.$(EXESUFFIX) core *.d *.mod FOR*.DAT FTN* ftn* fort.*
@echo ------------------------------------ building test $@
-$(FC) -c $(FFLAGS) $(LDFLAGS) $(SRC)/pp73.f90 -o pp73.$(OBJX)
-$(FC) $(FFLAGS) $(LDFLAGS) pp73.$(OBJX) $(LIBS) -o pp73.$(EXESUFFIX)


run:
@echo ------------------------------------ executing test pp73
pp73.$(EXESUFFIX)

verify: ;

@@ -0,0 +1,19 @@
#
# Copyright (c) 2017, NVIDIA CORPORATION. All rights reserved.
#
# Licensed under the Apache License, Version 2.0 (the "License");
# you may not use this file except in compliance with the License.
# You may obtain a copy of the License at
#
# http://www.apache.org/licenses/LICENSE-2.0
#
# Unless required by applicable law or agreed to in writing, software
# distributed under the License is distributed on an "AS IS" BASIS,
# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
# See the License for the specific language governing permissions and
# limitations under the License.

# Shared lit script for each tests. Run bash commands that run tests with make.

# RUN: KEEP_FILES=%keep FLAGS=%flags TEST_SRC=%s MAKE_FILE_DIR=%S/.. bash %S/runmake | tee %t
# RUN: cat %t | FileCheck %S/runmake
@@ -0,0 +1,32 @@
! Copyright (c) 2019, NVIDIA CORPORATION. All rights reserved.
!
! Licensed under the Apache License, Version 2.0 (the "License");
! you may not use this file except in compliance with the License.
! You may obtain a copy of the License at
!
! http://www.apache.org/licenses/LICENSE-2.0
!
! Unless required by applicable law or agreed to in writing, software
! distributed under the License is distributed on an "AS IS" BASIS,
! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
! See the License for the specific language governing permissions and
! limitations under the License.
!
!
! Tests subscripted pointer expressions that point to non-contiguous array
! sections.

program main
integer, pointer :: p1(:), p2(:)
integer, target :: a(20)
integer :: expect(8) = [3, 5, 7, 9, 11, 13, 15, 17]
integer :: j
a = [(j,j=1,20)]
p1 => a(::2)
p2(1:8) => p1(2:9)
if (all(p2 .eq. expect)) then
print *, 'PASS'
else
print *, 'FAIL'
endif
end program main
@@ -3429,6 +3429,10 @@ simply_contiguous(int arr_ast)
}
break;
case A_SUBSCR:
sptr = memsym_of_ast(arr_ast);
if (POINTERG(sptr)) {
return CONTIGATTRG(sptr);
}
return contiguous_array_section(arr_ast);
}

@@ -2050,6 +2050,10 @@ transform_call(int std, int ast)
handle_seq_section(entry, ele, i, std, &retval, &descr, 1,
inface_arg);
} else {
if (!DESCRG(sptr)) {
get_static_descriptor(sptr);
get_all_descriptors(sptr);
}
SPTR descr_sptr = DESCRG(sptr);
/* Set the INTERNREF flag of array descriptor to make sure host
subroutines' array descriptor is accessible for contained
@@ -11383,6 +11383,7 @@ semant1(int rednum, SST *top)
copy_sym_flags(sym, proc_interf_sptr);
HCCSYMP(sym, 1);
IS_PROC_PTR_IFACEP(sym, 1);
INTERFACEP(sym, 1);
}
proc_interf_sptr = sym;
}
@@ -1609,6 +1609,7 @@ int has_poly_mbr(int sptr, int flag);
void push_tbp_arg(ITEM *item);
ITEM *pop_tbp_arg(void);
void err307(char *, int, int);
void gen_init_unl_poly_desc(int dest_sdsc_ast, int src_sdsc_ast, int std);

/* xref.c */
void xrefinit(void);
@@ -61,7 +61,6 @@ static int gen_derived_arr_init(int arr_dtype, int strt_std, int end_std);
static int convert_to_block_forall(int old_forall_ast);

static int find_non_tbp(char *);
static void gen_init_unl_poly_desc(int dest_sdsc_ast, int src_sdsc_ast);
static int gen_sourced_allocation(int astdest, int astsrc);

static int construct_association(int lhs_sptr, SST *rhs, int stmt_dtype,
@@ -4230,7 +4229,7 @@ semant3(int rednum, SST *top)
? src_sdsc_ast
: mk_id(get_type_descr_arg(gbl.currsub, src));

gen_init_unl_poly_desc(dast, sast);
gen_init_unl_poly_desc(dast, sast, 0);
} else if (SDSCG(dest) && DTY(src_dtype) == TY_CHAR &&
is_unl_poly(dest)) {

@@ -6460,8 +6459,16 @@ convert_to_block_forall(int old_forall_ast)
return mk_stmt(A_ENDFORALL, 0);
}

static void
gen_init_unl_poly_desc(int dest_sdsc_ast, int src_sdsc_ast)
/** \brief Generate a call to init_unl_poly_desc which initializes a descriptor
* for an unlimited polymorphic object with another descriptor.
*
* \param dest_sdsc_ast is the AST of the destination's descriptor.
* \param src_sdsc_ast is the AST of the source descriptor.
* \param std is the statement descriptor to insert the call, or 0 to use
* the default statement descriptor.
*/
void
gen_init_unl_poly_desc(int dest_sdsc_ast, int src_sdsc_ast, int std)
{
int fsptr = sym_mkfunc_nodesc(mkRteRtnNm(RTE_init_unl_poly_desc), DT_NONE);
int argt = mk_argt(3);
@@ -6472,7 +6479,11 @@ gen_init_unl_poly_desc(int dest_sdsc_ast, int src_sdsc_ast)
val = mk_unop(OP_VAL, val, DT_INT);
ARGT_ARG(argt, 2) = val;
ast = mk_func_node(A_CALL, ast, 3, argt);
add_stmt(ast);
if (std == 0) {
add_stmt(ast);
} else {
add_stmt_after(ast, std);
}
}

static int
@@ -6801,7 +6812,7 @@ construct_association(int lhs_sptr, SST *rhs, int stmt_dtype, LOGICAL is_class)
assert(rhs_descriptor_ast > 0, "no rhs descr for unl poly lhs", lhs_sptr,
4);
#endif
gen_init_unl_poly_desc(mk_id(SDSCG(lhs_sptr)), rhs_descriptor_ast);
gen_init_unl_poly_desc(mk_id(SDSCG(lhs_sptr)), rhs_descriptor_ast, 0);
}
if (set_up_a_pointer) {
/* Construct association by means of a pointer to extant data, no
@@ -14100,8 +14100,7 @@ gen_set_type(int dest_ast, int src_ast, int std, LOGICAL insert_before,
arg0 = dest_ast;
} else if (A_TYPEG(src_ast) == A_MEM) {
sdsc = get_member_descriptor(sptr);
arg0 = mk_member(mk_id(sym_of_ast(A_PARENTG(dest_ast))), mk_id(sdsc),
A_DTYPEG(dest_ast));
arg0 = check_member(dest_ast, mk_id(sdsc));
} else {
sdsc = SDSCG(sptr);
if (sdsc == 0) {
@@ -14120,8 +14119,7 @@ gen_set_type(int dest_ast, int src_ast, int std, LOGICAL insert_before,
arg1 = src_ast;
} else if (A_TYPEG(src_ast) == A_MEM) {
sdsc = get_member_descriptor(sptr);
arg1 = mk_member(mk_id(sym_of_ast(A_PARENTG(src_ast))), mk_id(sdsc),
A_DTYPEG(src_ast));
arg1 = check_member(src_ast, mk_id(sdsc));
} else {
sdsc = SDSCG(sptr);
if (sdsc == 0) {
@@ -4305,6 +4305,11 @@ rewrite_allocatable_assignment(int astasgn, const int std,
ast = mk_set_type_call(dest_sdsc_ast, intrin_type, TRUE);
add_stmt_after(ast, std2); /* after call to poly_asn() */
}
} else if (is_unl_poly(sptrdest)) {
/* Need to initialize destination's unlimited polymorphic descriptor
* before calling poly_asn().
*/
gen_init_unl_poly_desc(dest_sdsc_ast, src_sdsc_ast, alloc_std);
}
ast_to_comment(astasgn);
return;
@@ -3867,6 +3867,8 @@ Don't allow statements between the DO loops of a cuf kernels do construct
reserved
.XB 0x80000:
reserved
.XB 0x100000:
reserved

.XF "138:"
vect prefetch limit

0 comments on commit 6196855

Please sign in to comment.
You can’t perform that action at this time.