From 3a65a8e95b2cf6c267daed30f355aed412d8d551 Mon Sep 17 00:00:00 2001 From: Mark Leair Date: Mon, 11 Jun 2018 14:59:38 -0700 Subject: [PATCH 1/6] For certain targets, defer the addition of underscores in symbol names to the llvm back-end. --- tools/flang1/flang1exe/semant.c | 30 +----------------------------- 1 file changed, 1 insertion(+), 29 deletions(-) diff --git a/tools/flang1/flang1exe/semant.c b/tools/flang1/flang1exe/semant.c index d1debe381cf..41e83264c3f 100644 --- a/tools/flang1/flang1exe/semant.c +++ b/tools/flang1/flang1exe/semant.c @@ -13058,26 +13058,12 @@ process_bind(int sptr) np = stb.n_base + CONVAL1G(bind_attr.altname); if (!*np) return; -#if defined(TARGET_OSX) - /* Win32 and OSX needs altname with underbar for bind only, to - match C routines. Do not depend on processing in - assem.c : we can not tell that this came specifically - from a bind statement - */ - w32_name = (char *)getitem(0, strlen(SYMNAME(bind_attr.altname)) + 1); - w32_name[0] = '_'; - strcpy(&(w32_name[1]), np); - - wsptr = getstring(w32_name, strlen(w32_name)); - ALTNAMEP(sptr, wsptr); -#else ALTNAMEP(sptr, bind_attr.altname); -#endif break; case DA_C: #if defined(TARGET_OSX) - /* add underscore to win32 common block names */ + /* add underscore to OSX common block names */ if (STYPEG(sptr) == ST_CMBLK) need_altname = 1; #endif @@ -13094,22 +13080,8 @@ process_bind(int sptr) } /* end for */ if ((need_altname) && ALTNAMEG(sptr) == 0) { -#if defined(TARGET_OSX) - - /* Win32 needs altname with underbar for bind only, to - match C routines. Do not depend on processing in - assem.c : we can not tell that this came specifically - from a bind statement - */ - w32_name = (char *)getitem(0, strlen(SYMNAME(sptr)) + 1); - w32_name[0] = '_'; - strcpy(&w32_name[1], SYMNAME(sptr)); - wsptr = getstring(w32_name, strlen(w32_name)); - ALTNAMEP(sptr, wsptr); -#else /* set default altname, so that no underbar gets added */ ALTNAMEP(sptr, getstring(SYMNAME(sptr), strlen(SYMNAME(sptr)))); -#endif } } /* process_bind */ From f30a111965d3d55ca3fbbbfcaf377f2b5a5021e4 Mon Sep 17 00:00:00 2001 From: Mark Leair Date: Mon, 11 Jun 2018 15:24:35 -0700 Subject: [PATCH 2/6] Fix infinite loop in the int128_count_leading_zeros() function of file int128.c. Some third party compilers would cause int128_count_leading_zeros() to loop forever when using __int128 and compiled with -O2. --- lib/scutil/int128.c | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/lib/scutil/int128.c b/lib/scutil/int128.c index 782d6454e5c..4e566614df2 100644 --- a/lib/scutil/int128.c +++ b/lib/scutil/int128.c @@ -1,5 +1,5 @@ /* - * Copyright (c) 2017, NVIDIA CORPORATION. All rights reserved. + * Copyright (c) 2016-2018, 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. @@ -85,11 +85,11 @@ int int128_count_leading_zeros(const int128_t *x) { int128_t v = *x; + int128_t mask = 1; + mask <<= 127; int j; - if (v == 0) - return 128; - for (j = 0; v > 0; ++j) { - v += v; + for(j = 0; j < 128 && 0 == (mask & v); j++) { + mask >>= 1; } return j; } From ae47162d60648c44568a788502df60f550150751 Mon Sep 17 00:00:00 2001 From: Mark Leair Date: Mon, 11 Jun 2018 15:39:59 -0700 Subject: [PATCH 3/6] add STG_RETURN, to return the most recent allocation --- miscutil.c --- sharedefs.h --- tools/flang1/utils/symtab/sharedefs.h | 8 ++++++++ tools/flang2/utils/symtab/sharedefs.h | 8 ++++++++ tools/shared/miscutil.c | 20 +++++++++++++++++++- tools/shared/sharedefs.h | 8 ++++++++ 4 files changed, 43 insertions(+), 1 deletion(-) diff --git a/tools/flang1/utils/symtab/sharedefs.h b/tools/flang1/utils/symtab/sharedefs.h index 410a21ec68a..759b28137f6 100644 --- a/tools/flang1/utils/symtab/sharedefs.h +++ b/tools/flang1/utils/symtab/sharedefs.h @@ -28,6 +28,7 @@ * i = STG_NEXT_SIZE(name, size) - return next available index, allocate size * i = STG_NEXT_FREELIST(name) - return index from free list * STG_NEED(name) - test avail vs size, realloc if needed + * STG_RETURN(name) - return lastest added element * STG_ADD_FREELIST(name, i) - add to free list * STG_ALLOC_SIDECAR(basename, name, datatype) * allocate name the same size as basename @@ -98,6 +99,8 @@ int stg_next(STG *stg, int n); /* allocate 'size' elements at stg_avail */ #define STG_NEXT_SIZE(name, size) stg_next((STG *)&name.stg_base, size) +/* + /* check that stg_avail does not overflow stg_size */ void stg_need(STG *stg); #define STG_NEED(name) stg_need((STG *)&name.stg_base) @@ -111,6 +114,11 @@ void stg_set_freelink(STG *stg, int offset); int stg_next_freelist(STG *stg); #define STG_NEXT_FREELIST(name) stg_next_freelist((STG *)&name.stg_base) +/* return latest added field */ +void stg_return(STG *stg); +#define STG_RETURN(name) \ + stg_return((STG *)&name.stg_base) + /* put this element on the free list */ void stg_add_freelist(STG *stg, int r); #define STG_ADD_FREELIST(name, index) \ diff --git a/tools/flang2/utils/symtab/sharedefs.h b/tools/flang2/utils/symtab/sharedefs.h index 410a21ec68a..759b28137f6 100644 --- a/tools/flang2/utils/symtab/sharedefs.h +++ b/tools/flang2/utils/symtab/sharedefs.h @@ -28,6 +28,7 @@ * i = STG_NEXT_SIZE(name, size) - return next available index, allocate size * i = STG_NEXT_FREELIST(name) - return index from free list * STG_NEED(name) - test avail vs size, realloc if needed + * STG_RETURN(name) - return lastest added element * STG_ADD_FREELIST(name, i) - add to free list * STG_ALLOC_SIDECAR(basename, name, datatype) * allocate name the same size as basename @@ -98,6 +99,8 @@ int stg_next(STG *stg, int n); /* allocate 'size' elements at stg_avail */ #define STG_NEXT_SIZE(name, size) stg_next((STG *)&name.stg_base, size) +/* + /* check that stg_avail does not overflow stg_size */ void stg_need(STG *stg); #define STG_NEED(name) stg_need((STG *)&name.stg_base) @@ -111,6 +114,11 @@ void stg_set_freelink(STG *stg, int offset); int stg_next_freelist(STG *stg); #define STG_NEXT_FREELIST(name) stg_next_freelist((STG *)&name.stg_base) +/* return latest added field */ +void stg_return(STG *stg); +#define STG_RETURN(name) \ + stg_return((STG *)&name.stg_base) + /* put this element on the free list */ void stg_add_freelist(STG *stg, int r); #define STG_ADD_FREELIST(name, index) \ diff --git a/tools/shared/miscutil.c b/tools/shared/miscutil.c index 5e08b4b8b52..cd2a8f0a3a8 100644 --- a/tools/shared/miscutil.c +++ b/tools/shared/miscutil.c @@ -347,7 +347,7 @@ int stg_next(STG *stg, int n) { STG *thisstg; - int r = stg->stg_avail; + unsigned int r = stg->stg_avail; if (n == 0) return 0; if (n < 0) { @@ -422,6 +422,24 @@ stg_next_freelist(STG *stg) return r; } /* stg_next_freelist */ +/* + * return latest entry (from stg_next) + */ +void +stg_return(STG *stg) +{ + STG *thisstg; + unsigned int r = stg->stg_avail - 1; + stg->stg_avail = r; + if (stg->stg_cleared > r) + stg->stg_cleared = r; + for (thisstg = (STG *)stg->stg_sidecar; thisstg; + thisstg = (STG *)thisstg->stg_sidecar) { + thisstg->stg_avail = stg->stg_avail; + thisstg->stg_cleared = stg->stg_cleared; + } +} /* stg_return */ + /* * add element to the free list * store the link to the next free element at 'word 0' diff --git a/tools/shared/sharedefs.h b/tools/shared/sharedefs.h index 410a21ec68a..759b28137f6 100644 --- a/tools/shared/sharedefs.h +++ b/tools/shared/sharedefs.h @@ -28,6 +28,7 @@ * i = STG_NEXT_SIZE(name, size) - return next available index, allocate size * i = STG_NEXT_FREELIST(name) - return index from free list * STG_NEED(name) - test avail vs size, realloc if needed + * STG_RETURN(name) - return lastest added element * STG_ADD_FREELIST(name, i) - add to free list * STG_ALLOC_SIDECAR(basename, name, datatype) * allocate name the same size as basename @@ -98,6 +99,8 @@ int stg_next(STG *stg, int n); /* allocate 'size' elements at stg_avail */ #define STG_NEXT_SIZE(name, size) stg_next((STG *)&name.stg_base, size) +/* + /* check that stg_avail does not overflow stg_size */ void stg_need(STG *stg); #define STG_NEED(name) stg_need((STG *)&name.stg_base) @@ -111,6 +114,11 @@ void stg_set_freelink(STG *stg, int offset); int stg_next_freelist(STG *stg); #define STG_NEXT_FREELIST(name) stg_next_freelist((STG *)&name.stg_base) +/* return latest added field */ +void stg_return(STG *stg); +#define STG_RETURN(name) \ + stg_return((STG *)&name.stg_base) + /* put this element on the free list */ void stg_add_freelist(STG *stg, int r); #define STG_ADD_FREELIST(name, index) \ From ce9ca5ae6da3e7b22fc2d81719d59fbec7f0a6e5 Mon Sep 17 00:00:00 2001 From: Mark Leair Date: Mon, 11 Jun 2018 15:58:33 -0700 Subject: [PATCH 4/6] Add get_cores prototype in x86id.h. --- runtime/libpgmath/lib/x86_64/x86id.h | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/runtime/libpgmath/lib/x86_64/x86id.h b/runtime/libpgmath/lib/x86_64/x86id.h index d21944de9b2..a8dee684b69 100644 --- a/runtime/libpgmath/lib/x86_64/x86id.h +++ b/runtime/libpgmath/lib/x86_64/x86id.h @@ -59,4 +59,8 @@ extern int X86IDFN(is_x86_64)(void); /* return 0 or 1 */ extern int X86IDFN(get_cachesize)(void); extern char *X86IDFN(get_processor_name)(void); +#if !defined(FOR_LIBPGC) +extern int get_cores(void); +#endif + #endif /* X86ID_H_ */ From 57eda030284bdfbfbe70de0bf1ac2e109da5727a Mon Sep 17 00:00:00 2001 From: Mark Leair Date: Mon, 11 Jun 2018 16:23:03 -0700 Subject: [PATCH 5/6] Fix a bug that caused unresolved type descriptor symbols. Do not create type descriptors for derived types inside interfaces. When derived types are defined inside interfaces, type descriptors are not needed because there is no executable code inside the interface. Futhermore, if we generate them, we might get multiple definitions of the same type descriptor because we mangle the name based on the scope of the interface; not on the scope of the host routine. To implement this solution, we add a symbol table flag called IS_INTERFACE to ST_ENTRY and ST_PROC that is set if the symbol is in an interface block. This is set in semant1. We then check this flag in lower_symbols() to determine if we need to lower a particular type descriptor. If the type_descriptor's scope is inside an interface, we do not lower it. By not lowering the type descriptor, its generation in the back-end does not occur. --- tools/flang1/flang1exe/lowersym.c | 16 +++++++++++++--- tools/flang1/flang1exe/semant.c | 2 +- tools/flang1/utils/symtab/symtab.n | 4 ++++ 3 files changed, 18 insertions(+), 4 deletions(-) diff --git a/tools/flang1/flang1exe/lowersym.c b/tools/flang1/flang1exe/lowersym.c index 93ebf83a6ca..f4047c01aa7 100644 --- a/tools/flang1/flang1exe/lowersym.c +++ b/tools/flang1/flang1exe/lowersym.c @@ -4677,9 +4677,19 @@ lower_symbols(void) } } } else if (!VISITG(sptr) && CLASSG(sptr) && DESCARRAYG(sptr) && - STYPEG(sptr) == ST_DESCRIPTOR /*&& FINALG(sptr)*/) { - if (PARENTG(sptr)) { - /* FS#21658: Only perform this if PARENT is set */ + STYPEG(sptr) == ST_DESCRIPTOR) { + SPTR scope = SCOPEG(sptr); + bool is_interface = ( (STYPEG(scope) == ST_PROC || + STYPEG(scope) == ST_ENTRY) && + IS_INTERFACEG(scope) ); + if (PARENTG(sptr) && !is_interface) { + /* Only perform this if PARENT is set. Also do not create type + * descriptors for derived types defined inside interfaces. When + * derived types are defined inside interfaces, type descriptors are + * not needed because there is no executable code inside an interface. + * Furthermore, if we generate them, we might get multiple definitions + * of the same type descriptor. + */ lower_put_datatype_stb(DTYPEG(sptr)); VISITP(sptr, 1); lower_symbol_stb(sptr); diff --git a/tools/flang1/flang1exe/semant.c b/tools/flang1/flang1exe/semant.c index 41e83264c3f..75764869049 100644 --- a/tools/flang1/flang1exe/semant.c +++ b/tools/flang1/flang1exe/semant.c @@ -2455,7 +2455,7 @@ semant1(int rednum, SST *top) */ INTERNALP(sptr, 0); } - + IS_INTERFACEP(sptr, sem.interface); break; /* ------------------------------------------------------------------ */ diff --git a/tools/flang1/utils/symtab/symtab.n b/tools/flang1/utils/symtab/symtab.n index ea0b9045b9f..1828197cfd8 100644 --- a/tools/flang1/utils/symtab/symtab.n +++ b/tools/flang1/utils/symtab/symtab.n @@ -1395,6 +1395,8 @@ name list group. .lp .ul Flags +.FL IS_INTERFACE f89 +Set if the entry symbol is in an interface block. .FL DCLD Set if currently processing a function subprogram and the data type of this entry has been explicitly declared. @@ -1560,6 +1562,8 @@ for this symbol. .lp .ul Flags +.FL IS_INTERFACE +Set if the procedure symbol is in an interface block. .FL IS_PROC_DUMMY f109 This flag is set if this ST_PROC is used as a procedure dummy argument. .FL CLASS f42 From dd29e164e6c4ceb692cb288d592f26d8c0b7960f Mon Sep 17 00:00:00 2001 From: Mark Leair Date: Mon, 11 Jun 2018 16:50:45 -0700 Subject: [PATCH 6/6] Fix a bug in structure constructors related to pointer components. In make_structkwd_str() of semutil2.c, assign value to ptr_sptr before using it. Follow the same pattern as in the is_empty_typedef() function. --- tools/flang1/flang1exe/semutil2.c | 16 +++++++++++++--- 1 file changed, 13 insertions(+), 3 deletions(-) diff --git a/tools/flang1/flang1exe/semutil2.c b/tools/flang1/flang1exe/semutil2.c index 5c9bbfc0088..bc5efea72c3 100644 --- a/tools/flang1/flang1exe/semutil2.c +++ b/tools/flang1/flang1exe/semutil2.c @@ -4979,8 +4979,10 @@ make_structkwd_str(DTYPE dtype, int *num_of_member, int *is_extend) NEW(kwd_str, char, size); *kwd_str = '\0'; member_sptr = DTY(dtype + 1); - + ptr_sptr = member_sptr; for (; member_sptr > NOSYM; member_sptr = SYMLKG(member_sptr)) { + if (POINTERG(member_sptr)) + ptr_sptr = member_sptr; if (is_tbp_or_final(member_sptr)) { possible_ext = 0; continue; /* skip tbp */ @@ -5196,9 +5198,8 @@ all_default_init(DTYPE dtype) thissptr = DTY(dtype + 1); for (mem = DTY(dtype + 1); mem > NOSYM; mem = SYMLKG(mem)) { - if (SCG(mem) == SC_BASED) { + if (POINTERG(mem)) thissptr = mem; - } myparent = PARENTG(thissptr); if (myparent && myparent == PARENTG(mem) && possible_ext && DTY(DTYPEG(mem)) == TY_DERIVED) { @@ -5279,6 +5280,7 @@ get_exttype_default(DTYPE dtype, int pos) if (pos >= DTC_DT_CNT) return pos; + ptr_sptr = member_sptr; for (; member_sptr > NOSYM; member_sptr = SYMLKG(member_sptr)) { if (no_data_components(DTYPEG(member_sptr))) { possible_ext = 0; @@ -5288,6 +5290,8 @@ get_exttype_default(DTYPE dtype, int pos) possible_ext = 0; continue; } + if (POINTERG(member_sptr)) + ptr_sptr = member_sptr; if (ptr_sptr && (member_sptr == MIDNUMG(ptr_sptr) || member_sptr == PTROFFG(ptr_sptr) || member_sptr == SDSCG(ptr_sptr) || @@ -5638,6 +5642,7 @@ get_exttype_struct_constructor(ACL *in_aclp, DTYPE dtype, ACL **prev_aclp) #endif member_sptr = DTY(dtype + 1); + ptr_sptr = member_sptr; if (member_sptr == 0) { error(155, 3, gbl.lineno, "Use of derived type name before definition:", SYMNAME(DTY(dtype + 3))); @@ -5654,6 +5659,8 @@ get_exttype_struct_constructor(ACL *in_aclp, DTYPE dtype, ACL **prev_aclp) continue; /* skip tbp */ } + if (POINTERG(member_sptr)) + ptr_sptr = member_sptr; if (ptr_sptr && (member_sptr == MIDNUMG(ptr_sptr) || member_sptr == PTROFFG(ptr_sptr) || member_sptr == SDSCG(ptr_sptr) || @@ -5775,6 +5782,7 @@ chk_struct_constructor(ACL *in_aclp) dtype = aclp->dtype; aclp = aclp->subc; /* go down to member list */ member_sptr = DTY(dtype + 1); + ptr_sptr = member_sptr; if (member_sptr == 0) { error(155, 3, gbl.lineno, "Use of derived type name before definition:", SYMNAME(DTY(dtype + 3))); @@ -5792,6 +5800,8 @@ chk_struct_constructor(ACL *in_aclp) cnt = 0; prev_aclp = NULL; for (; member_sptr != NOSYM; member_sptr = SYMLKG(member_sptr)) { + if (POINTERG(member_sptr)) + ptr_sptr = member_sptr; if (no_data_components(DTYPEG(member_sptr))) continue; if (is_tbp_or_final(member_sptr))