/* * Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions. * See https://llvm.org/LICENSE.txt for license information. * SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception * */ /* * Modifications Copyright (c) 2019 Advanced Micro Devices, Inc. All rights reserved. * Notified per clause 4(b) of the license. * * Changes to support AMDGPU OpenMP offloading * Support for parity intrinsic. * Month of Modification: July 2019 * * Support for Bit transformational intrinsic iany, iall, iparity. * Month of Modification: July 2019 * Last modified: Jun 2020 */ /** \brief Fortran transformation module */ #include "gbldefs.h" #include "global.h" #include "error.h" #include "comm.h" #include "symtab.h" #include "symutl.h" #include "dtypeutl.h" #include "soc.h" #include "semant.h" #include "ast.h" #include "transfrm.h" #include "gramtk.h" #include "extern.h" #include "hpfutl.h" #include "dinit.h" #include "ccffinfo.h" #include "optimize.h" #include "rte.h" #include "rtlRtns.h" static void rewrite_into_forall(void); static void rewrite_block_where(void); static void rewrite_block_forall(void); static void find_allocatable_assignment(void); static void rewrite_allocatable_assignment(int, int, bool, bool); static void handle_allocatable_members(int, int, int, bool); static void trans_get_descrs(void); static int trans_getidx(void); static void trans_clridx(void); static void trans_freeidx(void); static int collapse_assignment(int, int); static int build_sdsc_node(int); static int inline_spread_shifts(int, int, int); static int copy_forall(int); static void clear_dist_align(void); static void transform_init(void); static void declare_local_mode(void); static void init_finfo(void); static void distribute_fval(void); static int get_newdist_with_newproc(int dist); static void set_initial_s1(void); static LOGICAL contains_non0_scope(int astSrc); static LOGICAL is_non0_scope(int sptr); static void gen_allocated_check(int, int, int, bool, bool, bool); static int subscript_allocmem(int aref, int asd); static int normalize_subscripts(int oldasd, int oldshape, int newshape); static int gen_dos_over_shape(int shape, int std); static void gen_do_ends(int docnt, int std); static LOGICAL all_stride_one_shape(int shape); static int mk_bounds_shape(int shape); #if DEBUG extern void dbg_print_stmts(FILE *); #endif static bool chk_assumed_subscr(int a); static int mk_ptr_subscr(int subAst, int std); static int get_sdsc_ast(SPTR sptrsrc, int astsrc); static int build_poly_func_node(int dest, int src, int intrin_type); static int mk_poly_test(int dest, int src, int optype, int intrin_type); static int count_allocatable_members(int ast); void rewrite_asts_collapse_loop(struct collapse_loop); FINFO_TBL finfot; static int init_idx[MAXSUBS + MAXSUBS]; static int num_init_idx; struct pure_gbl pure_gbl; extern int pghpf_type_sptr; int pghpf_local_mode_sptr = 0; #ifdef OMP_OFFLOAD_LLVM // AOCC BEGIN /* maximum number of AST statement clones */ #define MAX_CLONES 1000 static void rewrite_omp_targetdata_construct() { int std = 0; int ast = 0, ifast = 0, new_if = 0, new_end = 0, ast_type = 0; int begin_std = 0, target_ast = 0; ast_visit(1,1); for (std = STD_NEXT(0); std > 0; std = STD_NEXT(std)) { ast = STD_AST(std); // Search for targetdata. if (A_TYPEG(ast) != A_MP_TARGETDATA) { continue; } begin_std = std; ast = STD_AST(std); target_ast = ast; ifast = A_IFPARG(target_ast); if (!ifast) continue; // Create new if-then-endif structure. new_if = mk_stmt(A_IFTHEN, 0); new_end = mk_stmt(A_ENDIF, 0); // Copy the condition from the TARGETDATA statement. A_IFEXPRP(new_if, ifast); // Place if-then before the targetdata add_stmt_before(new_if, begin_std); A_IFPARP(ast, 0); // Next statements should be list of A_MP_MAP and one A_MP_EMAP std = STD_NEXT(std); assert(std > 0, "", ast, 4); ast = STD_AST(std); while (A_TYPEG(ast) != A_MP_EMAP) { assert(A_TYPEG(ast) == A_MP_MAP, "", ast, 4); std = STD_NEXT(std); assert(std > 0, "", ast, 4); ast = STD_AST(std); } assert(A_TYPEG(ast) == A_MP_EMAP, "", ast, 4); // Insert else-then {cloned nodes} statements after // A_MP_EMAP add_stmt_after(new_end, std); std = STD_NEXT(std); assert(std > 0, "", ast, 4); ast = STD_AST(std); // Search for endtargetdata node and insert the // same if-then-endif condition around it as well. while (A_TYPEG(ast) != A_MP_ENDTARGETDATA) { std = STD_NEXT(std); assert(std > 0, "", ast, 4); ast = STD_AST(std); } assert(A_TYPEG(ast) == A_MP_ENDTARGETDATA, "", ast, 4); // Clone the if and end statements. new_if = ast_rewrite(new_if); new_end = ast_rewrite(new_end); add_stmt_before(new_if, std); add_stmt_after(new_end, std); } ast_unvisit(); // Handle targetenterdata and targetexitdata. ast_visit(1,1); for (std = STD_NEXT(0); std > 0; std = STD_NEXT(std)) { ast = STD_AST(std); // Search for targetdata. ast_type = A_TYPEG(ast); if (ast_type != A_MP_TARGETENTERDATA && ast_type != A_MP_TARGETEXITDATA) { continue; } begin_std = std; ast = STD_AST(std); target_ast = ast; ifast = A_IFPARG(target_ast); if (!ifast) continue; // Create new if-then-endif structure. new_if = mk_stmt(A_IFTHEN, 0); new_end = mk_stmt(A_ENDIF, 0); // Copy the condition from the TARGET(ENTER|EXIT)DATA statement. A_IFEXPRP(new_if, ifast); // Place if-then before the targetdata add_stmt_before(new_if, begin_std); A_IFPARP(ast, 0); // Next statements should be list of A_MP_MAP and one A_MP_EMAP std = STD_NEXT(std); assert(std > 0, "", ast, 4); ast = STD_AST(std); while (A_TYPEG(ast) != A_MP_EMAP) { assert(A_TYPEG(ast) == A_MP_MAP, "", ast, 4); std = STD_NEXT(std); assert(std > 0, "", ast, 4); ast = STD_AST(std); } assert(A_TYPEG(ast) == A_MP_EMAP, "", ast, 4); // Insert else-then {cloned nodes} statements after // A_MP_EMAP add_stmt_after(new_end, std); } ast_unvisit(); } static void rewrite_omp_target_construct() { int std = 0; int ast = 0, ifast = 0, new_if = 0, new_end = 0, new_else = 0; int cloned_stmts[MAX_CLONES]; int begin_std = 0, target_ast = 0; int curr = 0; int new_stmt = 0; int found_inner_scope = 0; ast_visit(1,1); for (std = STD_NEXT(0); std > 0; std = STD_NEXT(std)) { ast = STD_AST(std); // Search for BMPSCOPE. if (A_TYPEG(ast) != A_MP_BMPSCOPE) { continue; } begin_std = std; // Next AST Statement should be Target std = STD_NEXT(std); assert(std > 0, "", ast, 4); ast = STD_AST(std); if (A_TYPEG(ast) != A_MP_TARGET) { continue; } target_ast = ast; ifast = A_IFPARG(target_ast); if (!ifast) { continue; } // Create new if-then-else structure. new_if = mk_stmt(A_IFTHEN, 0); new_else = mk_stmt(A_ELSE, 0); new_end = mk_stmt(A_ENDIF, 0); // Copy the condition from the TARGET statement. A_IFEXPRP(new_if, ifast); // Place if-then before the A_MP_BMPSCOPE. add_stmt_before(new_if, begin_std); A_IFPARP(ast, 0); // Next statement could be an assignment to a private variable // when in_reduction is used // or local variable when in_reduction is used std = STD_NEXT(std); assert(std > 0, "", ast, 4); ast = STD_AST(std); while (A_TYPEG(ast) == A_ASN) { assert(SCG(A_SPTRG(A_DESTG(ast))) == SC_PRIVATE || SCG(A_SPTRG(A_DESTG(ast))) == SC_LOCAL , "", ast, 4); std = STD_NEXT(std); assert(std > 0, "", ast, 4); ast = STD_AST(std); } // Next statements should be list of A_MP_MAP and one A_MP_EMAP while (A_TYPEG(ast) != A_MP_EMAP) { assert(A_TYPEG(ast) == A_MP_MAP, "", ast, 4); std = STD_NEXT(std); assert(std > 0, "", ast, 4); ast = STD_AST(std); } assert(A_TYPEG(ast) == A_MP_EMAP, "", ast, 4); std = STD_NEXT(std); ast = STD_AST(std); int outer_scope = 1; int team_scope = 0; while (std > 0) { ast = STD_AST(std); if (A_TYPEG(ast) == A_MP_ENDTARGET) break; if (A_TYPEG(ast) == A_MP_TEAMS) team_scope = 1; if (A_TYPEG(ast) == A_MP_BMPSCOPE) { if (outer_scope || !team_scope) { new_stmt = STD_AST(clone_bmpscope_std(begin_std)); } else { new_stmt = STD_AST(clone_bmpscope_std(std)); } int stblk_ast = A_STBLKG(new_stmt); int uplevel_sptr = PARUPLEVELG(A_SPTRG(stblk_ast)); int uplevel_sptr2 = PARUPLEVELG(A_STBLKG(ast)); if (!outer_scope) { llmp_uplevel_set_parent(uplevel_sptr, uplevel_sptr-2); } outer_scope = 0; } else { new_stmt = ast_rewrite(ast); } A_DESTP(new_stmt, A_DESTG(ast)); A_SRCP(new_stmt, A_SRCG(ast)); assert(curr < MAX_CLONES, "rewrite_omp_target_construct: Too many AST " "statements to clone",ast,4); cloned_stmts[curr++] = new_stmt; std = STD_NEXT(std); } assert(A_TYPEG(ast) == A_MP_ENDTARGET, "", ast, 4); // Match for A_EMPSCOPE. std = STD_NEXT(std); assert(std > 0, "", ast, 4); ast = STD_AST(std); assert(A_TYPEG(ast) == A_MP_EMPSCOPE, "", ast, 4); // Insert else-then {cloned nodes} statements after // A_MP_EMPSCOPE. add_stmt_after(new_end, std); // Insert the cloned statements in the // else part. while (curr > 0) { int cloned_ast = cloned_stmts[--curr]; add_stmt_after(cloned_ast,std); } add_stmt_after(new_else, std); // Move to next node. std = STD_NEXT(std); } ast_unvisit(); } void rewrite_omp_map_array_section() { int std = 0, bmpstd; int ast = 0, lop; int ast2 = 0, shape, src; int tmp, newast, asn; ast_visit(1,1); for(std = STD_NEXT(0); std > 0; std = STD_NEXT(std)) { ast = STD_AST(std); if(ast == 0) continue; if(A_TYPEG(ast) == A_MP_BMPSCOPE) bmpstd = std; if(A_TYPEG(ast) != A_MP_MAP) continue; lop = A_LOPG(ast); if(A_TYPEG(lop) != A_SUBSCR || !A_SHAPEG(lop)) continue; transform_map_array_section(lop, bmpstd, &ast2); shape = A_SHAPEG(lop); // compute the size of the array if(SHD_UPB(shape, 0)){ src = mk_binop(OP_ADD, mk_binop(OP_SUB, SHD_UPB(shape,0), SHD_LWB(shape,0), astb.bnd.dtype), SHD_STRIDE(shape,0), astb.bnd.dtype); tmp = getcctmp('z', src, ST_VAR, DT_INT8); newast = mk_id(tmp); asn = mk_assn_stmt(newast, src, DT_INT8); add_stmt_before(asn, bmpstd); A_ROPP(ast, newast); } if(ast2) A_LOPP(ast, ast2); } ast_unvisit(); } #endif // AOCC END void transform(void) { pghpf_type_sptr = 0; pghpf_local_mode_sptr = 0; if (gbl.rutype != RU_BDATA) { transform_init(); set_initial_s1(); /* create descriptors */ trans_get_descrs(); // AOCC BEGIN #ifdef OMP_OFFLOAD_LLVM if (flg.omptarget) { /* Handle if-clause in OpenMP statements. */ rewrite_omp_target_construct(); rewrite_omp_targetdata_construct(); #if DEBUG if (DBGBIT(50, 4)) { fprintf(gbl.dbgfil, "After rewrite_omp_target_construct\n"); dstda(); } #endif /* Handle sections for assumed array in map clause */ rewrite_omp_map_array_section(); #if DEBUG if(DBGBIT(50, 4)) { fprintf(gbl.dbgfil, "After rewrite_omp_map_array_section\n"); dstda(); } #endif } #endif // AOCC END /* turn block wheres into single wheres */ #if DEBUG if (DBGBIT(50, 4)) { fprintf(gbl.dbgfil, "Before rewrite_block_where\n"); dstda(); } #endif rewrite_block_where(); #if DEBUG if (DBGBIT(50, 4)) { fprintf(gbl.dbgfil, "After rewrite_block_where\n"); dstda(); } #endif /* turn block foralls into single foralls */ rewrite_block_forall(); #if DEBUG if (DBGBIT(50, 4)) { fprintf(gbl.dbgfil, "After rewrite_block_forall\n"); dstda(); } #endif /* transformational intrinsics */ /* rewrite_forall_intrinsic();*/ rewrite_forall_pure(); if (flg.opt >= 2 && XBIT(53, 2)) { points_to(); } #if DEBUG if (DBGBIT(50, 4)) { fprintf(gbl.dbgfil, "After rewrite_forall_pure\n"); dstdpa(); } #endif /* Rewrite arguments to subroutines and uses of array-valued * functions */ rewrite_calls(); #if DEBUG if (DBGBIT(50, 4)) { fprintf(gbl.dbgfil, "After rewrite_calls\n"); dstda(); } #endif find_allocatable_assignment(); #if DEBUG if (DBGBIT(50, 4)) { fprintf(gbl.dbgfil, "After find_allocatable_assignment\n"); dstda(); } #endif /* Transform array assignments, etc. into forall */ rewrite_into_forall(); #if DEBUG if (DBGBIT(50, 4)) { fprintf(gbl.dbgfil, "After rewrite_into_forall\n"); dstda(); } #endif /* This routine rewrites those foralls * 1. forall with shape suc as A(i,:) * 2. forall with dependency, * 3. forall with distributed indirection array at rhs. */ rewrite_forall(); #if DEBUG if (DBGBIT(50, 4)) { fprintf(gbl.dbgfil, "After rewrite_forall\n"); dstda(); } #endif #if DEBUG if (DBGBIT(50, 2)) { fprintf(gbl.dbgfil, "Statements after transform pass\n"); dbg_print_stmts(gbl.dbgfil); } #endif if (flg.opt >= 2 && XBIT(53, 2)) { f90_fini_pointsto(); } trans_freeidx(); if (sem.p_dealloc != 0) { interr("items were added to sem.p_dealloc but not freed", 0, ERR_Severe); } } } void reset_init_idx(void) { int i; for (i = 0; i < MAXSUBS + MAXSUBS; i++) { init_idx[i] = 0; } } static void transform_init(void) { int i; init_finfo(); pure_gbl.local_mode = 0; pghpf_type_sptr = 0; pghpf_local_mode_sptr = 0; init_region(); if (gbl.rutype != RU_BDATA) { for (i = 0; i < MAXSUBS + MAXSUBS; i++) { init_idx[i] = 0; } num_init_idx = 0; } } /* * set SDSDNS1 for descriptors of user array pointers or array-member pointers * for allocatables, assumed-shape, fixed-shape arrays, the associated * descriptors will always have a linear stride in the 1st dimension of one. * Also, set SDSCCONTIG for descriptors of user arrays with ALLOCATABLE * attribute, assumed-shape dummies, or fixed-shape arrays. */ static void set_initial_s1(void) { int sptr, sdsc, dtype, eldtype; for (sptr = stb.firstusym; sptr < stb.stg_avail; ++sptr) { switch (STYPEG(sptr)) { case ST_ARRAY: case ST_DESCRIPTOR: case ST_VAR: case ST_IDENT: case ST_STRUCT: case ST_MEMBER: if (IGNOREG(sptr)) break; dtype = DTYPEG(sptr); if (dtype && DTY(dtype) == TY_ARRAY) { sdsc = SDSCG(sptr); if (sdsc != 0 && STYPEG(sdsc) != ST_PARAM) { /* an array with a section descriptor */ if (!POINTERG(sptr)) { if ((SCG(sptr) == SC_DUMMY || SCG(sdsc) == SC_DUMMY) && ASSUMSHPG(sptr)) { if (!XBIT(54, 2) && !(XBIT(58, 0x400000) && TARGETG(sptr))) { /* don't set S1 for assumed-shape if -x 54 2 */ /* don't set S1 for assumed-shape if -x 58 0x400000 && target */ SDSCS1P(sdsc, 1); } } else { SDSCS1P(sdsc, 1); } } else { /* set SDSCS1 for section descriptor if stride-1 */ long s1; s1 = 0; if (s1) { SDSCS1P(sdsc, 1); SDSCCONTIGP(sdsc, 1); BYTELENP(sdsc, s1); } } if ((ALLOCATTRG(sptr) || (ASSUMSHPG(sptr) && !XBIT(54, 2) && !(XBIT(58, 0x400000) && TARGETG(sptr)))) && !ASSUMLENG(sptr) && !ADJLENG(sptr) && !(DDTG(DTYPEG(sptr)) == DT_DEFERCHAR || DDTG(DTYPEG(sptr)) == DT_DEFERNCHAR)) { SDSCCONTIGP(sdsc, 1); eldtype = DTY(dtype + 1); BYTELENP(sdsc, size_of(eldtype)); } } if (SCG(sptr) == SC_DUMMY) { sdsc = NEWDSCG(sptr); if (sdsc != 0 && STYPEG(sdsc) != ST_PARAM) { if (!POINTERG(sptr) && !(XBIT(54, 2) && ASSUMSHPG(sptr)) && !(XBIT(58, 0x400000) && TARGETG(sptr) && ASSUMSHPG(sptr))) { /* set SDSCS1 for section descriptor */ /* don't set S1 for assumed-shape if -x 54 2 */ /* don't set S1 for assumed-shape if -x 58 0x400000 && target */ SDSCS1P(sdsc, 1); } if ((ALLOCATTRG(sptr) || (ASSUMSHPG(sptr) && !XBIT(54, 2) && !(XBIT(58, 0x400000) && TARGETG(sptr)))) && !ASSUMLENG(sptr) && !ADJLENG(sptr) && !(DDTG(DTYPEG(sptr)) == DT_DEFERCHAR || DDTG(DTYPEG(sptr)) == DT_DEFERNCHAR)) { SDSCCONTIGP(sdsc, 1); eldtype = DTY(dtype + 1); BYTELENP(sdsc, size_of(eldtype)); } } } } break; default:; } } } /* set_initial_s1 */ int get_init_idx(int i, int dtype) { if (init_idx[i] == 0 || SCG(init_idx[i]) != symutl.sc || DTYPEG(init_idx[i]) != dtype) { char ci[2], cj[2]; ci[0] = 'i'; ci[1] = '\0'; cj[0] = 'a' + num_init_idx; cj[1] = '\0'; init_idx[i] = sym_get_scalar(ci, cj, dtype); ++num_init_idx; if (num_init_idx >= 26) num_init_idx = 0; } return init_idx[i]; } /* get_init_idx */ /* forall table */ static void init_finfo(void) { finfot.size = 240; NEW(finfot.base, FINFO, finfot.size); finfot.avl = 1; } static int mk_finfo(void) { int nd; nd = finfot.avl++; /* finfot.avl += sizeof(FINFO); */ NEED(finfot.avl, finfot.base, FINFO, finfot.size, finfot.size + 240); if (finfot.base == NULL) errfatal(7); return nd; } int get_finfo(int forall, int a) { int i; for (i = A_STARTG(forall); i > (int)(A_STARTG(forall) - A_NCOUNTG(forall)); i--) if (a == FINFO_AST(i)) return i; return 0; } #define TRANS_AREA 10 static void clear_dist_align(void) { int sptr; int stype; for (sptr = stb.firstusym; sptr < stb.stg_avail; sptr++) { stype = STYPEG(sptr); if (stype == ST_ARRAY) { if (!ASSUMSHPG(sptr)) SEQP(sptr, 1); } } } static struct { int sptr; } wherestuff; static void nice_mask(int ast, LOGICAL *nice) { switch (A_TYPEG(ast)) { case A_BINOP: if (A_OPTYPEG(ast) == OP_XTOX) /* real ** real */ *nice = FALSE; break; case A_SUBSCR: case A_ID: case A_PAREN: case A_CONV: case A_CNST: case A_CMPLXC: case A_UNOP: case A_TRIPLE: break; default: *nice = FALSE; break; } } static LOGICAL nice_where_mask(int ast) { LOGICAL nice; nice = TRUE; ast_visit(1, 1); ast_traverse(ast, NULL, nice_mask, &nice); ast_unvisit(); return nice; } static void srch_sym(int ast, LOGICAL *has_sym) { if (A_TYPEG(ast) == A_ID && wherestuff.sptr == A_SPTRG(ast)) *has_sym = TRUE; } static LOGICAL mask_on_lhs(int mask, int lhs) { int sptr, stype; LOGICAL has_sym; /* find the LHS symbol */ if (A_TYPEG(lhs) == A_SUBSCR) lhs = A_LOPG(lhs); if (A_TYPEG(lhs) != A_ID) return TRUE; sptr = A_SPTRG(lhs); stype = STYPEG(sptr); assert(stype == ST_ARRAY, "mask_on_lhs: sptr not array", sptr, 4); wherestuff.sptr = sptr; has_sym = FALSE; ast_visit(1, 1); ast_traverse(mask, NULL, srch_sym, &has_sym); ast_unvisit(); return has_sym; } static void rewrite_where_expr(int where_std, int endwhere_std) { int ast, std; int astnew, stdnew; /* rewrite the where expression if it has transformationals, etc. */ ast = STD_AST(where_std); /* If the expression requires a temporary as part of its * evaluation, must make sure that the temp is freed after * the WHERE, if it is a block where. An ugly way to * do this is to create a temp statement then move stuff * that gets added after it. */ astnew = mk_stmt(A_CONTINUE, 0); stdnew = add_stmt_before(astnew, where_std); arg_gbl.std = stdnew; /* A_IFEXPRP(ast, rewrite_sub_ast(A_IFEXPRG(ast)));*/ /* all the stuff from between stdnew and where_std needs * to be moved after the ENDWHERE */ if (STD_NEXT(stdnew) != where_std) { /* link the chain in after endwhere_std */ STD_PREV(STD_NEXT(endwhere_std)) = STD_PREV(where_std); STD_NEXT(STD_PREV(where_std)) = STD_NEXT(endwhere_std); STD_NEXT(endwhere_std) = STD_NEXT(stdnew); STD_PREV(STD_NEXT(endwhere_std)) = endwhere_std; /* remove the chain after stdnew */ STD_NEXT(stdnew) = where_std; STD_PREV(where_std) = stdnew; } /* unlink the dummy statement */ STD_NEXT(STD_PREV(stdnew)) = STD_NEXT(stdnew); STD_PREV(STD_NEXT(stdnew)) = STD_PREV(stdnew); arg_gbl.std = where_std; } typedef struct wherestackentry { int where, elsewhere, forall; } wherestackentry; struct wherestack { wherestackentry *base; int size, topwhere, topforall; } wherestack = {(wherestackentry *)0, 0, 0, 0}; /* * allocate the wherestack; also, initialize it at entry zero * with zero where/elsewhere statements */ static void init_where(void) { int top; wherestack.size = 5; NEW(wherestack.base, wherestackentry, wherestack.size); top = wherestack.topwhere = wherestack.topforall = 0; wherestack.base[top].where = 0; wherestack.base[top].elsewhere = 0; wherestack.base[top].forall = 0; } /* init_where */ static void push_where(int where_std) { int top; ++wherestack.topwhere; NEED(wherestack.topwhere + 1, wherestack.base, wherestackentry, wherestack.size, 2 * wherestack.size); top = wherestack.topwhere; wherestack.base[top].where = where_std; wherestack.base[top].elsewhere = 0; } /* push_where */ static void push_elsewhere(int elsewhere_std) { int top; top = wherestack.topwhere; if (top == 0) interr("rewrite_block_forall: elsewhere with no where", elsewhere_std, 3); if (wherestack.base[top].elsewhere != 0) interr("rewrite_block_forall: two elsewheres", elsewhere_std, 3); wherestack.base[top].elsewhere = elsewhere_std; } /* push_elsewhere */ static void pop_where(int *where, int *elsewhere) { int top; top = wherestack.topwhere; if (top <= 0) { *where = 0; *elsewhere = 0; } else { *where = wherestack.base[top].where; *elsewhere = wherestack.base[top].elsewhere; --wherestack.topwhere; } } /* pop_where */ static void push_forall(int forall_std) { int top; ++wherestack.topforall; NEED(wherestack.topforall + 1, wherestack.base, wherestackentry, wherestack.size, 2 * wherestack.size); top = wherestack.topforall; wherestack.base[top].forall = forall_std; } /* push_forall */ static void pop_forall(int *forall_std) { int top; top = wherestack.topforall; if (top <= 0) { *forall_std = 0; } else { *forall_std = wherestack.base[top].forall; --wherestack.topforall; } } /* pop_forall */ static void add_wheresym(ITEM **wheresymlist, int wheresym) { ITEM *itemp = (ITEM *)getitem(TRANS_AREA, sizeof(ITEM)); itemp->next = *wheresymlist; itemp->t.sptr = wheresym; *wheresymlist = itemp; } static LOGICAL in_wheresymlist(ITEM *list, int sptr) { ITEM *itemp; for (itemp = list; itemp != ITEM_END; itemp = itemp->next) { if (itemp->t.sptr == sptr) { return TRUE; } } return FALSE; } /* move few STD nodes ahead of distributed do loop. * update the upper bound of distributed loop as that of parallel loop. */ void rewrite_asts_collapse_loop(struct collapse_loop collapse_loop) { if ((collapse_loop.distributed_loop != 0) && (collapse_loop.instruction_range_start != 0) && (collapse_loop.instruction_range_end != 0) && (collapse_loop.parallel_loop != 0)) { // move range of STD nodes ahead of distributed do loop move_range_before(collapse_loop.instruction_range_start, collapse_loop.instruction_range_end, collapse_loop.distributed_loop); /* add an assignment statement to assign a new value to the upper bound of * distributed loop which is same as that of parallel loop. * add this newly created assignment statement just before the distributed * loop. */ int collapse_assn_ast = mk_assn_stmt(A_M2G(STD_AST(collapse_loop.distributed_loop)), A_DESTG(STD_AST(collapse_loop.instruction_range_end)), DT_INT); (void)add_stmt_before(collapse_assn_ast, collapse_loop.distributed_loop); /* set the lower bound of both distributed and parallel loop to 1 and * add this assignement statement just before distributed loop. */ collapse_assn_ast = mk_assn_stmt(A_M1G(STD_AST(collapse_loop.distributed_loop)), astb.i1, DT_INT); (void)add_stmt_before(collapse_assn_ast, collapse_loop.distributed_loop); /* update the lower bound, upper bound and stride of parallel loop as that * of distributed loop. This makes it possible to pass the proper bounds to * the second runtime kmpc call corresponding to the parallel loop. * Here the bounds returned as reference by the first kmpc call * corresponding to distributed loop are used during second kmpc call. */ A_M1P(STD_AST(collapse_loop.parallel_loop), A_M1G(STD_AST(collapse_loop.distributed_loop))); A_M2P(STD_AST(collapse_loop.parallel_loop), A_M2G(STD_AST(collapse_loop.distributed_loop))); A_M3P(STD_AST(collapse_loop.parallel_loop), A_M3G(STD_AST(collapse_loop.distributed_loop))); } } /* * Transform block WHERE statements to single-statement wheres */ static void rewrite_block_where(void) { int std, stdnext, std1; int shape; int ast, ast1, ast2, lhs, nestedwhere; int where_load; int list; int wheresym; int sptr_lhs; int subscr[MAXSUBS]; int where_std, elsewhere_std, endwhere_std; int outer_where_std, outer_endwhere_std; LOGICAL nice_where; int shape1; int parallel_depth; int task_depth; ITEM *wheresymlist = ITEM_END; init_where(); /* Transform block wheres */ where_std = elsewhere_std = 0; parallel_depth = 0; task_depth = 0; for (std = STD_NEXT(0); std != 0; std = stdnext) { stdnext = STD_NEXT(std); gbl.lineno = STD_LINENO(std); ast = STD_AST(std); switch (A_TYPEG(ast)) { case A_MP_PARALLEL: ++parallel_depth; /*symutl.sc = SC_PRIVATE;*/ set_descriptor_sc(SC_PRIVATE); break; case A_MP_ENDPARALLEL: --parallel_depth; if (parallel_depth == 0 && task_depth == 0) { /*symutl.sc = SC_LOCAL;*/ set_descriptor_sc(SC_LOCAL); } break; case A_MP_TASK: case A_MP_TASKLOOP: ++task_depth; set_descriptor_sc(SC_PRIVATE); break; case A_MP_ENDTASK: case A_MP_ETASKLOOP: --task_depth; if (parallel_depth == 0 && task_depth == 0) { set_descriptor_sc(SC_LOCAL); } break; case A_FORALL: if (A_IFSTMTG(ast) == 0) { int astli, li; push_forall(std); /* mark the forall indices */ astli = A_LISTG(ast); for (li = astli; li != 0; li = ASTLI_NEXT(li)) { int sptr = ASTLI_SPTR(li); #if DEBUG if (FORALLNDXG(sptr)) { interr("rewrite_block_where: nested foralls with same index", std, 4); } #endif FORALLNDXP(sptr, 1); } } break; case A_ENDFORALL: { int forall_std, forall_ast, astli, li; pop_forall(&forall_std); forall_ast = STD_AST(forall_std); #if DEBUG if (A_TYPEG(forall_ast) != A_FORALL) { interr("rewrite_block_where: problem with endforall nesting", std, 4); } #endif /* now unmark the forall indices */ astli = A_LISTG(forall_ast); for (li = astli; li != 0; li = ASTLI_NEXT(li)) { int sptr = ASTLI_SPTR(li); #if DEBUG if (!FORALLNDXG(sptr)) { interr("rewrite_block_where: forall index flag improperly reset", std, 4); } #endif FORALLNDXP(sptr, 0); } } break; case A_WHERE: if (!A_IFSTMTG(ast)) { if (wherestack.topwhere == 0) { int std1, ast1, ast2, wherenest; /* this is the outermost WHERE, find outermost ENDWHERE */ outer_where_std = std; outer_endwhere_std = 0; wherenest = 1; for (std1 = STD_NEXT(std); std1 > 0 && wherenest > 0; std1 = STD_NEXT(std1)) { ast1 = STD_AST(std1); switch (A_TYPEG(ast1)) { case A_WHERE: if (A_IFSTMTG(ast1) == 0) { ++wherenest; } else { /* Single-statement WHERE from nested where * Rewrite to regular nested WHERE */ ast2 = mk_stmt(A_ENDWHERE, 0); add_stmt_after(ast2, std1); ast2 = A_IFSTMTG(ast1); ast2 = mk_assn_stmt(A_DESTG(ast2), A_SRCG(ast2), A_DTYPEG(ast2)); add_stmt_after(ast2, std1); ast2 = mk_stmt(A_WHERE, 0); A_IFEXPRP(ast2, A_IFEXPRG(ast1)); add_stmt_after(ast2, std1); ast_to_comment(STD_AST(std1)); } break; case A_ENDWHERE: --wherenest; if (wherenest == 0) outer_endwhere_std = std1; break; } } if (outer_endwhere_std == 0) interr("rewrite_block_where: no outer endwhere", std, 4); } push_where(std); } break; case A_ELSEWHERE: assert(wherestack.topwhere > 0, "rewrite_block_where: ELSEWHERE with no WHERE", 0, 4); push_elsewhere(std); break; case A_ENDWHERE: /* end of block where. Try to optimize mask creation. If the * mask expression is 'nice', and no variable in the mask * expr is modified in the WHERE, then just use the expression * and its negation. Otherwise create a temp and use that. * * Use-def would be nice here, we'll hack it for now. */ pop_where(&where_std, &elsewhere_std); endwhere_std = std; /* find lhs */ lhs = 0; for (std1 = where_std; std1 != endwhere_std; std1 = STD_NEXT(std1)) { if (std1 == where_std || std1 == elsewhere_std) continue; ast = STD_AST(std1); /* might be a call or an allocate here, * front end rewrites array-valued * functions. */ switch (A_TYPEG(ast)) { case A_CALL: case A_ALLOC: case A_CONTINUE: case A_COMMENT: case A_COMSTR: case A_DO: case A_ENDDO: continue; case A_WHERE: /* could be single-statement WHERE from nested where */ ast = A_IFSTMTG(ast); break; case A_ASN: break; default: error(510, 4, STD_LINENO(where_std), CNULL, CNULL); } /* assignment node, look at lhs */ lhs = A_DESTG(ast); if (HCCSYMG(memsym_of_ast(lhs))) { /* assignments to compiler generated symbols to not need * to be conformable */ continue; } shape = A_SHAPEG(lhs); if (shape == 0) continue; shape1 = A_SHAPEG(A_IFEXPRG(STD_AST(where_std))); if (!conform_shape(shape, shape1)) error(511, 3, STD_LINENO(std), CNULL, CNULL); break; } if (!A_SHAPEG(A_IFEXPRG(STD_AST(where_std)))) error(512, 4, STD_LINENO(where_std), CNULL, CNULL); rewrite_where_expr(where_std, endwhere_std); if (wherestack.topwhere > 0) { /* nested WHEREs always get temporary */ nice_where = FALSE; } else { nice_where = nice_where_mask(A_IFEXPRG(STD_AST(where_std))); } where_load = A_IFEXPRG(STD_AST(where_std)); for (std1 = where_std; nice_where && std1 != endwhere_std; std1 = STD_NEXT(std1)) { if (std1 == where_std || std1 == elsewhere_std) continue; ast = STD_AST(std1); /* might be a call or an allocate here, * front end rewrites array-valued * functions. */ switch (A_TYPEG(ast)) { case A_CALL: case A_ALLOC: case A_CONTINUE: case A_COMMENT: case A_COMSTR: case A_DO: case A_ENDDO: continue; case A_WHERE: /* could be single-statement WHERE from nested where */ ast = A_IFSTMTG(ast); break; case A_ASN: break; default: interr("rewrite_block_where: non assignment in WHERE", std1, 4); } /* assignment node, look at lhs */ lhs = A_DESTG(ast); shape = A_SHAPEG(lhs); if (shape == 0) continue; /* this is an array assignment */ if (mask_on_lhs(where_load, lhs)) nice_where = FALSE; } if (!nice_where && lhs) { ast = STD_AST(where_std); shape = A_SHAPEG(A_IFEXPRG(ast)); assert(shape != 0, "rewrite_block_where: bad where", std, 4); /* get a temp */ assert(A_SHAPEG(lhs), "rewrite_block_where: no shape in WHERE", 0, 4); ast1 = lhs; if (ast1 == 0) ast1 = search_conform_array(A_IFEXPRG(ast), FALSE); if (ast1 == 0) ast1 = search_conform_array(A_IFEXPRG(ast), TRUE); assert(ast1 != 0, "rewrite_block_where: can't find array", 0, 4); wheresym = mk_assign_sptr(ast1, "ww", subscr, DT_LOG, &where_load); add_wheresym(&wheresymlist, wheresym); } for (std1 = where_std; std1 != endwhere_std; std1 = STD_NEXT(std1)) { if (std1 == where_std) continue; if (std1 == elsewhere_std) { if (nice_where) where_load = mk_unop(OP_LNOT, where_load, A_DTYPEG(where_load)); continue; } ast = STD_AST(std1); nestedwhere = 0; switch (A_TYPEG(ast)) { case A_CALL: case A_ALLOC: case A_CONTINUE: case A_COMMENT: case A_COMSTR: case A_DO: case A_ENDDO: continue; case A_WHERE: /* could be single-statement WHERE from nested where */ nestedwhere = A_IFEXPRG(ast); ast = A_IFSTMTG(ast); break; case A_ASN: break; default: interr("rewrite_block_where: non assignment in WHERE", std1, 4); } /* assignment node, look at lhs */ lhs = A_DESTG(ast); sptr_lhs = memsym_of_ast(lhs); if (A_SHAPEG(A_DESTG(ast)) == 0 || (HCCSYMG(sptr_lhs) && !in_wheresymlist(wheresymlist, sptr_lhs))) continue; /* this is an array assignment */ /* make it a where */ ast1 = mk_stmt(A_WHERE, 0); A_IFSTMTP(ast1, ast); if (nestedwhere) { /* make .AND. of condition; use SCAND as noncommutative AND */ A_IFEXPRP(ast1, nestedwhere); nestedwhere = mk_binop(OP_SCAND, where_load, nestedwhere, A_DTYPEG(where_load)); } else { A_IFEXPRP(ast1, where_load); } A_STDP(ast1, std1); STD_AST(std1) = ast1; } if (!nice_where && lhs) { /* make "wheresym = expr" */ ast = STD_AST(where_std); ast2 = mk_stmt(A_ASN, DTYPEG(wheresym)); A_DESTP(ast2, where_load); A_SRCP(ast2, A_IFEXPRG(ast)); add_stmt_after(ast2, where_std); /* Insert the allocate statement */ mk_mem_allocate(mk_id(wheresym), subscr, outer_where_std, 0); add_stmt_before(mk_assn_stmt(where_load, astb.i0, DT_LOG), outer_where_std); if (elsewhere_std) { /* generate "where_sym = .not. where_sym" */ ast2 = mk_unop(OP_LNOT, where_load, A_DTYPEG(where_load)); ast1 = mk_stmt(A_ASN, DTYPEG(wheresym)); A_DESTP(ast1, where_load); A_SRCP(ast1, ast2); add_stmt_after(ast1, elsewhere_std); } /* insert deallocate statement */ mk_mem_deallocate(mk_id(wheresym), outer_endwhere_std); } if (where_std) ast_to_comment(STD_AST(where_std)); if (elsewhere_std) ast_to_comment(STD_AST(elsewhere_std)); if (endwhere_std) ast_to_comment(STD_AST(endwhere_std)); break; default: break; } } FREE(wherestack.base); } static int ForallList; /* This is the callback function for contains_forall_index(). */ static LOGICAL _contains_forall_index(int ast, LOGICAL *flag) { if (ast && A_TYPEG(ast) == A_ID) { int list; for (list = ForallList; list; list = ASTLI_NEXT(list)) { if (A_SPTRG(ast) == ASTLI_SPTR(list)) { *flag = TRUE; return TRUE; } } } return FALSE; } /* _contains_forall_index */ /* Return TRUE if any index in the forall_list occurs somewhere within ast. * Modified from 'ast.c:contains_ast' */ static LOGICAL contains_forall_index(int ast, int forall_list) { LOGICAL result = FALSE; if (!ast) return FALSE; ForallList = forall_list; ast_visit(1, 1); ast_traverse(ast, _contains_forall_index, NULL, &result); ast_unvisit(); return result; } /* contains_forall_index */ static void rewrite_block_forall(void) { int std, stdnext, std1; int ast, ast1, ast2; int list, stmt; int expr, expr1, where_expr; int subscr[MAXSUBS]; int forallb_std, endforall_std; int stack[MAXSUBS], top; int newforall; int forallb; /* * Transform block FORALL constructs to single-statement FORALLs */ /* Transform block FORALLs */ forallb_std = endforall_std = 0; top = 0; for (std = STD_NEXT(0); std != 0; std = stdnext) { stdnext = STD_NEXT(std); gbl.lineno = STD_LINENO(std); ast = STD_AST(std); if (A_TYPEG(ast) == A_FORALL && !A_IFSTMTG(ast)) { forallb_std = std; stack[top] = forallb_std; top++; assert(top <= MAXSUBS && top >= 0, "rewrite_block_forall: FORALL with no ENDFORALL", 0, 4); } else if (A_TYPEG(ast) == A_ENDFORALL) { endforall_std = std; top--; forallb_std = stack[top]; assert(forallb_std, "rewrite_block_forall: FORALL with no ENDFORALL", 0, 4); for (std1 = forallb_std; std1 != endforall_std; std1 = STD_NEXT(std1)) { gbl.lineno = STD_LINENO(std1); if (std1 == forallb_std) { forallb = STD_AST(forallb_std); continue; } ast = STD_AST(std1); /* might be a call or an allocate here, * front end rewrites array-valued * functions. */ if (A_TYPEG(ast) == A_CALL) { if (!contains_forall_index(ast, A_LISTG(forallb))) continue; } if (A_TYPEG(ast) == A_ALLOC || A_TYPEG(ast) == A_CONTINUE || A_TYPEG(ast) == A_COMMENT || A_TYPEG(ast) == A_COMSTR || A_TYPEG(ast) == A_DO || A_TYPEG(ast) == A_ENDDO) //AOCC continue; /* or it may be like, z_b_0 = 1 */ if (A_TYPEG(ast) == A_ASN && A_TYPEG(A_DESTG(ast)) == A_ID) continue; switch (A_TYPEG(ast)) { case A_CALL: case A_ASN: case A_ICALL: expr = A_IFEXPRG(forallb); list = A_LISTG(forallb); stmt = ast; break; case A_WHERE: expr = A_IFEXPRG(forallb); where_expr = A_IFEXPRG(ast); if (expr) expr = mk_binop(OP_LAND, expr, where_expr, DT_LOG); else expr = where_expr; list = A_LISTG(forallb); stmt = A_IFSTMTG(ast); break; case A_FORALL: list = concatenate_list(A_LISTG(forallb), A_LISTG(ast)); expr = A_IFEXPRG(forallb); expr1 = A_IFEXPRG(ast); if (expr && expr1) expr = mk_binop(OP_LAND, expr, expr1, DT_LOG); else if (expr1) expr = expr1; stmt = A_IFSTMTG(ast); break; default: interr("rewrite_block_forall: illegal statement in FORALL", ast, 3); } assert(stmt && list, "rewrite_block_forall: someting is wrong", ast, 4); newforall = mk_stmt(A_FORALL, 0); A_IFSTMTP(newforall, stmt); A_IFEXPRP(newforall, expr); A_LISTP(newforall, list); A_SRCP(newforall, A_SRCG(forallb)); add_stmt_before(newforall, std1); ast_to_comment(STD_AST(std1)); } ast_to_comment(STD_AST(forallb_std)); ast_to_comment(STD_AST(endforall_std)); } } } static void check_subprogram(int std, int ast, int callast) { int lop = A_LOPG(callast); int sptr = memsym_of_ast(lop); if (SEQUENTG(sptr)) { /* TPR 1786 */ /* go through the arguments; * if any are array-valued, make forall */ int shape, shapearg, i, cnt, argt, arg; shape = 0; cnt = A_ARGCNTG(callast); argt = A_ARGSG(callast); for (i = 0; i < cnt; ++i) { arg = ARGT_ARG(argt, i); if (arg > 0) { shape = A_SHAPEG(arg); shapearg = arg; if (shape) break; } } if (shape) { /* i is the argument with the shape */ int ast1; ast1 = make_forall(shape, shapearg, 0, 0); for (i = 0; i < cnt; ++i) { arg = ARGT_ARG(argt, i); if (arg > 0) { arg = normalize_forall(ast1, arg, 0); ARGT_ARG(argt, i) = arg; } } A_IFSTMTP(ast1, ast); A_IFEXPRP(ast1, 0); A_STDP(ast1, std); STD_AST(std) = ast1; } } } /* check_subprogram */ /* This routine is to find an array from expr which has constant bounds. * We currently allow simple expression with rhs rank 1. */ static LOGICAL find_const_bound_rhs(int expr, int *rhs, int* shape) { int i, nargs, argt; int asd; int ndim; int list; LOGICAL find1, find2; if (expr == 0) return FALSE; switch (A_TYPEG(expr)) { case A_BINOP: find1 = find_const_bound_rhs(A_LOPG(expr), rhs, shape); if (find1) return TRUE; return find_const_bound_rhs(A_ROPG(expr), rhs, shape); case A_UNOP: return find_const_bound_rhs(A_LOPG(expr), rhs, shape); case A_CONV: return find_const_bound_rhs(A_LOPG(expr), rhs, shape); case A_PAREN: return find_const_bound_rhs(A_LOPG(expr), rhs, shape); case A_ID: if (DTY(A_DTYPEG(expr)) == TY_ARRAY) { int shd = A_SHAPEG(expr); if (shd) { int ii, arr_lb, arr_ub, arr_st; int nd = SHD_NDIM(shd); if (nd > 1) return FALSE; for (ii = 0; ii < nd; ++ii) { arr_lb = SHD_LWB(shd, ii); arr_ub = SHD_UPB(shd, ii); arr_st = SHD_STRIDE(shd, ii); if (A_TYPEG(arr_ub) != A_CNST) return FALSE; if (A_TYPEG(arr_lb) != A_CNST) return FALSE; if (arr_st != 0 && arr_st != astb.bnd.one) return FALSE; } *rhs = expr; *shape = shd; return TRUE; } } return FALSE; case A_SUBSCR: if (vector_member(expr)) { if (A_TYPEG(expr) == A_MEM) { int sptr = A_SPTRG(A_MEMG(expr)); if (DTY(DTYPEG(sptr)) == TY_ARRAY) { return FALSE; } return FALSE; } if (A_TYPEG(expr) == A_SUBSCR) { int asd, i, n; asd = A_ASDG(expr); n = ASD_NDIM(asd); if (n > 1) return FALSE; for (i = 0; i < n; ++i) { int ss = ASD_SUBS(asd, i); if (A_SHAPEG(ss) > 0) { return FALSE; } if (A_TYPEG(ss) == A_TRIPLE) { /* Ignore non-stride 1 for now */ /* check if triplet value is the same as array bounds */ int dtype, lop; int lwb = A_LBDG(ss); int upb = A_UPBDG(ss); int st = A_STRIDEG(ss); if (st == 0) st = astb.bnd.one; if ( st != astb.bnd.one) return FALSE; lop = A_LOPG(expr); /* allow simple expression for now */ if (A_TYPEG(lop) == A_ID && A_SHAPEG(lop)) { int ii, arr_lb, arr_ub, arr_st; int shd = A_SHAPEG(lop); int nd = SHD_NDIM(shd); if (nd > 1) return FALSE; for (ii = 0; ii < nd; ++ii) { arr_lb = SHD_LWB(shd, ii); arr_ub = SHD_UPB(shd, ii); arr_st = SHD_STRIDE(shd, ii); if (A_TYPEG(arr_ub) != A_CNST) return FALSE; if (A_TYPEG(arr_lb) != A_CNST) return FALSE; if (arr_lb != lwb || arr_ub != upb || arr_st != st) { return FALSE; } } *rhs = expr; *shape = A_SHAPEG(lop); return TRUE; } } } } } else if (A_TYPEG(A_LOPG(expr)) == A_MEM) { return find_const_bound_rhs(A_PARENTG(expr), rhs, shape); } return FALSE; case A_MEM: case A_TRIPLE: case A_SUBSTR: case A_INTR: case A_FUNC: case A_CNST: case A_CMPLXC: default: return FALSE; } } /* check if this current shape has constant bounds */ static LOGICAL constant_shape(int shape) { int ii, lb, ub, st; int nd = SHD_NDIM(shape); for (ii = 0; ii < nd; ++ii) { ub = SHD_UPB(shape, ii); lb = SHD_LWB(shape, ii); if (A_TYPEG(ub) != A_CNST) return FALSE; if (A_TYPEG(lb) != A_CNST) return FALSE; } return TRUE; } static void rewrite_into_forall(void) { int std, stdnext; int shape; int ast, ast1, ast2, lhs, rhs; int where_load; int list; int wheresym; int sptr; int shape1, shape2; int parallel_depth; int task_depth; int copy_ast = 0, dealloc_ast = 0; /* * Transform WHERE statements to foralls, and transform block-forall * statements to single-statement foralls. * * Block-foralls can be left alone when back end is prepared to handle * them. * * Subset HPF doesn't allow block foralls. * * IF statements are transformed to IF-THEN-ENDIF statements so that * communication calls can be inserted without trouble. * * Some call statements are inspected and elementalized if they * have array arguments (specifically, F90 IO routines). */ parallel_depth = 0; task_depth = 0; for (std = STD_NEXT(0); std; std = stdnext) { stdnext = STD_NEXT(std); gbl.lineno = STD_LINENO(std); ast = STD_AST(std); switch (A_TYPEG(ast)) { case A_WHERE: if (A_IFSTMTG(ast)) { if (!A_SHAPEG(A_IFEXPRG(ast))) error(512, 4, STD_LINENO(std), CNULL, CNULL); shape1 = A_SHAPEG(A_IFEXPRG(ast)); shape2 = A_SHAPEG(A_DESTG(A_IFSTMTG(ast))); if (!conform_shape(shape1, shape2)) error(511, 3, STD_LINENO(std), CNULL, CNULL); /* single-stmt where */ /* create forall stmt */ /* forall is normalized with respect to the LHS expression */ ast1 = make_forall(A_SHAPEG(A_DESTG(A_IFSTMTG(ast))), A_DESTG(A_IFSTMTG(ast)), A_IFEXPRG(ast), 0); /* flag to show that it is made from arrray assignment */ A_ARRASNP(ast1, 1); ast2 = normalize_forall(ast1, A_IFSTMTG(ast), 0); /* replace this ast with forall */ A_IFSTMTP(ast1, ast2); A_STDP(ast1, std); STD_AST(std) = ast1; } else { interr("rewrite_info_forall: WHERE construct", std, 4); } break; case A_ELSEWHERE: case A_ENDWHERE: interr("rewrite_info_forall: WHERE construct", std, 4); break; case A_MP_ATOMICUPDATE: lhs = A_LOPG(ast); rhs = A_ROPG(ast); shape = A_SHAPEG(lhs); if (shape) { ast1 = make_forall(shape, lhs, 0, 0); ast2 = normalize_forall(ast1, ast, 0); A_IFSTMTP(ast1, ast2); A_IFEXPRP(ast1, 0); A_STDP(ast1, std); STD_AST(std) = ast1; /* flag to show that it is made from array assignment */ A_ARRASNP(ast1, 1); STD_ZTRIP(std) = 1; } break; case A_ASN: /* assignment node, look at lhs */ lhs = A_DESTG(ast); rhs = A_SRCG(ast); /* if it is string, don't touch it */ if (A_TYPEG(lhs) == A_SUBSTR && A_TYPEG(A_LOPG(lhs)) == A_SUBSCR) lhs = A_LOPG(lhs); shape = A_SHAPEG(lhs); if (shape) { /* * check if array assignment can be collapsed into a single * memset/move */ ast1 = collapse_assignment(ast, std); if (ast1) { std = add_stmt_after(ast1, std); ast_to_comment(ast); } else { /* this is an array assignment; need to create a forall */ int newrhs, newshape; if (flg.opt >= 2 && !XBIT(58,0x1000000) && !constant_shape(shape) && find_const_bound_rhs(rhs, &newrhs, &newshape)) { ast1 = make_forall(newshape, newrhs, 0, 0); A_CONSTBNDP(ast1, 1); } else { ast1 = make_forall(shape, lhs, 0, 0); } ast2 = normalize_forall(ast1, ast, 0); A_IFSTMTP(ast1, ast2); A_IFEXPRP(ast1, 0); A_STDP(ast1, std); STD_AST(std) = ast1; /* flag to show that it is made from array assignment */ A_ARRASNP(ast1, 1); STD_ZTRIP(std) = 1; } } else { if (A_TYPEG(rhs) == A_FUNC) { check_subprogram(std, ast, rhs); } } break; case A_CALL: check_subprogram(std, ast, ast); break; case A_MP_PARALLEL: ++parallel_depth; /*symutl.sc = SC_PRIVATE;*/ set_descriptor_sc(SC_PRIVATE); break; case A_MP_ENDPARALLEL: --parallel_depth; if (parallel_depth == 0 && task_depth == 0) { /*symutl.sc = SC_LOCAL;*/ set_descriptor_sc(SC_LOCAL); } break; case A_MP_TASK: case A_MP_TASKLOOP: ++task_depth; set_descriptor_sc(SC_PRIVATE); break; case A_MP_ENDTASK: case A_MP_ETASKLOOP: --task_depth; if (parallel_depth == 0 && task_depth == 0) { set_descriptor_sc(SC_LOCAL); } break; default: break; } } } static int search_arr(int ast) { int ast1; if (A_TYPEG(ast) == A_SUBSCR) ast = A_LOPG(ast); /* assert(A_TYPEG(ast) == A_ID, "search_arr: not ID", ast, 4); */ assert(DTY(A_DTYPEG(ast)) == TY_ARRAY, "search_arr: not TY_ARRAY", ast, 4); return ast; } /* Convert ast from an index with oldlb and oldstride to one with * newlb and newstride. I.e. * (ast - oldlb) / oldstride * newstride + newlb */ static int normalize_subscript(int ast, int oldlb, int oldstride, int newlb, int newstride) { if (oldstride == 0) oldstride = astb.bnd.one; if (newstride == 0) newstride = astb.bnd.one; if (oldstride == newstride) { if (oldlb != newlb) { ast = mk_binop(OP_SUB, ast, oldlb, astb.bnd.dtype); ast = mk_binop(OP_ADD, ast, newlb, astb.bnd.dtype); } } else { if (oldstride == mk_isz_cval(-1, astb.bnd.dtype)) { ast = mk_binop(OP_SUB, oldlb, ast, astb.bnd.dtype); } else { ast = mk_binop(OP_SUB, ast, oldlb, astb.bnd.dtype); ast = mk_binop(OP_DIV, ast, oldstride, astb.bnd.dtype); } ast = mk_binop(OP_MUL, ast, newstride, astb.bnd.dtype); ast = mk_binop(OP_ADD, ast, newlb, astb.bnd.dtype); } return ast; } /** \brief Return TRUE if memast is an A_MEM for an array, or memast is an A_SUBSCR whose parent is an A_MEM and which has triplet subscripts */ LOGICAL vector_member(int memast) { if (A_TYPEG(memast) == A_MEM) { int sptr = A_SPTRG(A_MEMG(memast)); if (DTY(DTYPEG(sptr)) == TY_ARRAY) return TRUE; return FALSE; } if (A_TYPEG(memast) == A_SUBSCR) { int asd, i, n; asd = A_ASDG(memast); n = ASD_NDIM(asd); for (i = 0; i < n; ++i) { int ss = ASD_SUBS(asd, i); if (A_SHAPEG(ss) > 0) return TRUE; if (A_TYPEG(ss) == A_TRIPLE) return TRUE; } } return FALSE; } /* vector_member */ static int normalize_forall_array(int forall_ast, int arr_ast, int inlist) { int i, j, triple; int list; int shape, vectmem; int ast; int ast1; int asd; int subs[MAXSUBS]; int numdim; int l; int lwb, stride; LOGICAL flag; /* arr_ast is an array subscript or a whole array reference. * Normalize the indices into arr_ast */ shape = A_SHAPEG(arr_ast); assert(shape != 0, "normalize_forall_array: 0 shape", arr_ast, 4); if (A_TYPEG(arr_ast) == A_ID || A_TYPEG(arr_ast) == A_MEM) { asd = 0; numdim = SHD_NDIM(shape); } else if (A_TYPEG(arr_ast) == A_SUBSCR) { asd = A_ASDG(arr_ast); numdim = ASD_NDIM(asd); j = SHD_NDIM(shape); } else { interr("normalize_forall_array:bad ast type", arr_ast, 3); } if (numdim < 1 || numdim > MAXSUBS) { interr("normalize_forall_array:bad numdim", shape, 3); numdim = 0; } /* do this call now, instead of later, because arr_ast may * be changed in place */ vectmem = vector_member(arr_ast); if (inlist != 0) { /* this is a vector subscript. Use the ast list that was passed in */ list = inlist; } else { list = A_LISTG(forall_ast); } for (i = numdim - 1; i >= 0; i--) { flag = FALSE; if (asd) { if (A_TYPEG(ASD_SUBS(asd, i)) == A_TRIPLE) { assert(j > 0, "normalize_forall_array: SHD/ASD mismatch", forall_ast, 4); --j; lwb = SHD_LWB(shape, j); stride = SHD_STRIDE(shape, j); flag = TRUE; } else if (A_SHAPEG(ASD_SUBS(asd, i))) { /* vector subscript */ lwb = normalize_forall(forall_ast, ASD_SUBS(asd, i), list); flag = FALSE; list = ASTLI_NEXT(list); --j; } else { /* scalar subscript */ lwb = ASD_SUBS(asd, i); flag = FALSE; } } else { lwb = check_member(arr_ast, SHD_LWB(shape, i)); stride = check_member(arr_ast, SHD_STRIDE(shape, i)); flag = TRUE; } if (flag) { int sptr = ASTLI_SPTR(list); assert(list != 0, "normalize_forall_array: non-conformable", arr_ast, 4); triple = ASTLI_TRIPLE(list); if (sptr == 0) { subs[i] = triple; } else { subs[i] = normalize_subscript(mk_id(sptr), A_LBDG(triple), A_STRIDEG(triple), lwb, stride); } list = ASTLI_NEXT(list); } else { subs[i] = lwb; } } ast = search_arr(arr_ast); if (vectmem) { /* This is a%b(:), where a and b are both arrays. We want * a%b(i) */ ast = mk_subscr(ast, subs, numdim, DDTG(A_DTYPEG(arr_ast))); } else if (A_TYPEG(ast) == A_MEM) { /* This is a%b(i), where a and b are both arrays. We want * a(j)%b(i) */ int ast1; int subs1[MAXSUBS]; int n1; ast1 = mk_subscr(A_PARENTG(ast), subs, numdim, DDTG(A_DTYPEG(A_PARENTG(ast)))); ast = mk_member(ast1, A_MEMG(ast), DDTG(A_DTYPEG(A_MEMG(ast)))); if (A_TYPEG(arr_ast) == A_SUBSCR) { asd = A_ASDG(arr_ast); n1 = ASD_NDIM(asd); for (i = 0; i < n1; ++i) subs1[i] = ASD_SUBS(asd, i); ast = mk_subscr(ast, subs1, n1, DDTG(A_DTYPEG(A_MEMG(ast)))); } else ast = mk_subscr(ast, subs, numdim, DDTG(A_DTYPEG(arr_ast))); } else ast = mk_subscr(ast, subs, numdim, DDTG(A_DTYPEG(arr_ast))); return ast; } static int normalize_id(int forall_ast, int asgn_ast, int inlist) { int org_shape, newast, nd, nc; org_shape = A_SHAPEG(asgn_ast); newast = normalize_forall_array(forall_ast, asgn_ast, inlist); /* A_SECSHPP(newast, org_shape); */ /* keep original shape */ /* put info into FINFO table */ nd = mk_finfo(); FINFO_AST(nd) = newast; FINFO_SHAPE(nd) = org_shape; FINFO_TYPE(nd) = 0; A_STARTP(forall_ast, nd); nc = A_NCOUNTG(forall_ast) + 1; A_NCOUNTP(forall_ast, nc); return newast; } /* normalize_id */ int normalize_forall(int forall_ast, int asgn_ast, int inlist) { /* forall_ast represents a forall statement with one or more indices. * asgn_ast represents an array assignment with or without triple * expressions. Create a new ast, replacing the triples or whole-array * dimensions of the asgn_ast with indices representing the same * sections, expressed as functions of the forall_ast index variables */ int ast, ast1, ast2; int dtype; int argt, nargs, i; int newast, org_shape; int nd, nc; int shape; if (asgn_ast == 0) return 0; switch (A_TYPEG(asgn_ast)) { case A_ASN: ast1 = normalize_forall(forall_ast, A_DESTG(asgn_ast), inlist); ast2 = normalize_forall(forall_ast, A_SRCG(asgn_ast), inlist); ast = mk_stmt(A_ASN, A_DTYPEG(ast1)); A_DESTP(ast, ast1); A_SRCP(ast, ast2); return ast; case A_MP_ATOMICUPDATE: ast1 = normalize_forall(forall_ast, A_LOPG(asgn_ast), inlist); ast2 = normalize_forall(forall_ast, A_ROPG(asgn_ast), inlist); ast = mk_stmt(A_MP_ATOMICUPDATE, A_DTYPEG(ast1)); A_LOPP(ast, ast1); A_ROPP(ast, ast2); A_OPTYPEP(ast, A_OPTYPEG(asgn_ast)); A_MEM_ORDERP(ast, A_MEM_ORDERG(asgn_ast)); return ast; case A_BINOP: ast1 = normalize_forall(forall_ast, A_LOPG(asgn_ast), inlist); ast2 = normalize_forall(forall_ast, A_ROPG(asgn_ast), inlist); dtype = A_DTYPEG(asgn_ast); if (DTY(dtype) == TY_ARRAY) dtype = DTY(dtype + 1); return mk_binop(A_OPTYPEG(asgn_ast), ast1, ast2, dtype); case A_UNOP: ast1 = normalize_forall(forall_ast, A_LOPG(asgn_ast), inlist); dtype = A_DTYPEG(asgn_ast); if (DTY(dtype) == TY_ARRAY) dtype = DTY(dtype + 1); return mk_unop(A_OPTYPEG(asgn_ast), ast1, dtype); case A_CONV: ast1 = normalize_forall(forall_ast, A_LOPG(asgn_ast), inlist); dtype = A_DTYPEG(asgn_ast); if (DTY(dtype) == TY_ARRAY) dtype = DTY(dtype + 1); if (is_iso_cptr(dtype) && A_OPTYPEG(A_LOPG(asgn_ast))) { A_DTYPEP(ast1, DT_PTR); dtype = DT_PTR; } return mk_convert(ast1, dtype); case A_CMPLXC: case A_CNST: return asgn_ast; case A_SUBSTR: ast = normalize_forall(forall_ast, A_LOPG(asgn_ast), inlist); return mk_substr(ast, A_LEFTG(asgn_ast), A_RIGHTG(asgn_ast), A_DTYPEG(asgn_ast)); case A_PAREN: ast = normalize_forall(forall_ast, A_LOPG(asgn_ast), inlist); return mk_paren(ast, A_DTYPEG(ast)); case A_INTR: return inline_spread_shifts(asgn_ast, forall_ast, inlist); case A_FUNC: shape = A_SHAPEG(asgn_ast); if (shape) { argt = A_ARGSG(asgn_ast); nargs = A_ARGCNTG(asgn_ast); for (i = 0; i < nargs; ++i) { ARGT_ARG(argt, i) = normalize_forall(forall_ast, ARGT_ARG(argt, i), inlist); } dtype = A_DTYPEG(asgn_ast); if (DTY(dtype) == TY_ARRAY && elemental_func_call(asgn_ast)) { A_DTYPEP(asgn_ast, DTY(dtype + 1)); A_SHAPEP(asgn_ast, 0); } } return asgn_ast; case A_SUBSCR: /* does this subscript have any triplet entries */ if (vector_member(asgn_ast)) { asgn_ast = normalize_id(forall_ast, asgn_ast, inlist); } if (A_TYPEG(A_LOPG(asgn_ast)) == A_MEM) { /* the parent might have an array index */ int asd, i, n, subs[MAXSUBS], dtype; asd = A_ASDG(asgn_ast); ast = normalize_forall(forall_ast, A_PARENTG(A_LOPG(asgn_ast)), inlist); if (ast != A_PARENTG(A_LOPG(asgn_ast))) { dtype = A_DTYPEG(A_MEMG(A_LOPG(asgn_ast))); ast = mk_member(ast, A_MEMG(A_LOPG(asgn_ast)), dtype); if (DTY(dtype) == TY_ARRAY) dtype = DTY(dtype + 1); /* add the member subscripts */ n = ASD_NDIM(asd); for (i = 0; i < n; ++i) { subs[i] = ASD_SUBS(asd, i); } asgn_ast = mk_subscr(ast, subs, n, dtype); } } return asgn_ast; case A_MEM: if (vector_member(asgn_ast)) { return normalize_id(forall_ast, asgn_ast, inlist); } else { /* the parent might have an array index */ ast = normalize_forall(forall_ast, A_PARENTG(asgn_ast), inlist); /* member should be a scalar here */ return mk_member(ast, A_MEMG(asgn_ast), A_DTYPEG(A_MEMG(asgn_ast))); } case A_ID: if (DTY(A_DTYPEG(asgn_ast)) == TY_ARRAY) { return normalize_id(forall_ast, asgn_ast, inlist); } return asgn_ast; default: interr("normalize_forall: bad opc", asgn_ast, 3); return asgn_ast; } } static LOGICAL is_reshape(int ast) { /* Is the input ast the source array section of a RESHAPE operation? */ if (A_TYPEG(ast) == A_SUBSCR && A_TYPEG(A_LOPG(ast)) == A_ID && A_SPTRG(A_LOPG(ast)) && strncmp(SYMNAME(A_SPTRG(A_LOPG(ast))), "reshap", 6) == 0) return TRUE; return FALSE; } /* * check if array assignment can be collapsed into a single memset/move */ static int collapse_assignment(int asn, int std) { int lhs, rhs; int rhs_allocatable; int shape; int ast; int cnst; int dtype; int dest; int src; int ndim; int i; int func; int sz; int szdtype; int one; int is_zero; int use_numelm; char *nm; FtnRtlEnum rtlRtn; int rhs_isptr, lhs_isptr; // AOCC Begin // for device offload do not transform array assignments to runtime library if (flg.omptarget) return 0; // AOCC End if (flg.opt < 2) return 0; if (XBIT(8, 0x8000000)) return 0; rhs_isptr = 0; lhs_isptr = 0; lhs = A_DESTG(asn); shape = A_SHAPEG(lhs); ndim = SHD_NDIM(shape); if (XBIT(34, 0x200) && ndim > 2) { /* * assume -Mconcur is better than collapsing an assignment of 3D * or greater array. For a >= 3D array: * + the backend replaces the innermost loop with an idiom, and * the idiom is now part of the next loop; * + autopar does not parallelize the loop containing the idiom; * + autopar parallelizes the outer (originally the 3rd) loop. */ return 0; } /* * look at the rhs of the assignment; for now, limit it to a * constant, scalar, array, contiguous array section of a basic * numeric type. */ rhs_allocatable = 0; src = 0; rhs = A_SRCG(asn); dtype = A_DTYPEG(rhs); switch (A_TYPEG(rhs)) { case A_CONV: src = 0; break; case A_ID: /* can only be rank 1 if assumed-shape */ src = A_SPTRG(rhs); if (SCG(src) == SC_DUMMY && ASSUMSHPG(src) && ndim > 1 && !CONTIGATTRG(src)) return 0; goto rhs_chk; case A_MEM: /* member must be array instead of some parent */ src = A_SPTRG(A_MEMG(rhs)); if (DTY(DTYPEG(src)) != TY_ARRAY) return 0; rhs_chk: if (POINTERG(src)) { rhs_isptr = 1; } if (ALLOCATTRG(src)) { rhs_allocatable = 1; } break; case A_SUBSCR: if (!contiguous_section(rhs)) return 0; src = find_array(rhs, NULL); if (STYPEG(src) != ST_MEMBER && SCG(src) == SC_DUMMY && ASSUMSHPG(src) && ndim > 1) return 0; if (POINTERG(src)) { rhs_isptr = 1; } rhs = first_element(rhs); break; default: return 0; } if (!src) { /* WANT scalar rhs */ rhs = A_LOPG(rhs); /* check for scalar to a array conversion */ if (DTY(A_DTYPEG(rhs)) == TY_ARRAY) return 0; } dtype = DDTG(dtype); if (!DT_ISNUMERIC(dtype) && !DT_ISLOG(dtype)) return 0; cnst = 0; if (A_TYPEG(rhs) == A_CNST) /* scalar constant */ cnst = A_SPTRG(A_ALIASG(rhs)); /* look at the lhs of the assignment */ use_numelm = 1; if (A_TYPEG(lhs) == A_ID) { /* can only be rank 1 if assumed-shape */ dest = A_SPTRG(lhs); if (SCG(dest) == SC_DUMMY && ASSUMSHPG(dest)) { use_numelm = 0; /* the entire (type is A_ID) lhs array is referenced: take advantage of the convention that the passed in array is always contiguous and allow the collapse to proceed, (only if the rhs is a reshape array section for now) */ if (!TARGETG(dest) && is_reshape(rhs)) { /* proceed with other checks */ } else { if (ndim > 1 && !CONTIGATTRG(dest)) return 0; } } } else if (A_TYPEG(lhs) == A_MEM) { dest = A_SPTRG(A_MEMG(lhs)); /* member must be array instead of some parent */ if (DTY(DTYPEG(dest)) != TY_ARRAY) return 0; } else { use_numelm = 0; /* section??? */ return 0; } if (POINTERG(dest)) { use_numelm = 0; lhs_isptr = 1; } if ((ADD_NUMELM(DTYPEG(dest))) == 0) { use_numelm = 0; } if (ndim <= 1 && !DT_ISCMPLX(dtype) && !ASSUMSHPG(dest)) return 0; if (ALLOCATTRG(dest)) { if (src && rhs_allocatable && XBIT(54, 0x1)) /* allocatable <- allocatable & f2003 semantics */ return 0; use_numelm = 0; } else if (ALLOCG(dest)) use_numelm = 0; /*********************************************************** * scn (03 Oct 2014): -0.0 is not considered to be 0.0 here ***********************************************************/ is_zero = 0; if (cnst) { switch (dtype) { case DT_CMPLX8: if (CONVAL1G(cnst) == 0 && CONVAL2G(cnst) == 0) is_zero = 1; break; case DT_CMPLX16: if (CONVAL1G(cnst) == stb.dbl0 && CONVAL2G(cnst) == stb.dbl0) is_zero = 1; break; // AOCC begin case DT_CMPLX32: if (CONVAL1G(cnst) == stb.quad0 && CONVAL2G(cnst) == stb.quad0) is_zero = 1; break; // AOCC end case DT_BINT: case DT_SINT: case DT_INT4: case DT_BLOG: case DT_SLOG: case DT_LOG4: if (CONVAL2G(cnst) == 0) is_zero = 1; break; case DT_LOG8: if (CONVAL1G(cnst) == 0 && CONVAL2G(cnst) == 0) is_zero = 1; break; default: if (cnst == stb.i0 || cnst == stb.k0 || cnst == stb.flt0 || cnst == stb.dbl0 || cnst == stb.quad0) is_zero = 1; break; } } szdtype = DT_INT8; sz = one = astb.k1; if (lhs_isptr || rhs_isptr) { if (lhs_isptr && rhs_isptr) { /* could have an overlap */ /*** do work in progress ***/ return 0; } if (lhs_isptr && !CONTIGATTRG(dest)) return 0; if (rhs_isptr && !CONTIGATTRG(src)) return 0; /* For now, we disable this optimization if XBIT(4, 0x800000) is set or we have an expression such as WXI(N)%CR */ if (XBIT(4, 0x800000) || (A_TYPEG(lhs) == A_MEM && A_TYPEG(A_PARENTG(lhs)) == A_SUBSCR)) return 0; } if (use_numelm) { #if DEBUG if (ADD_NUMELM(DTYPEG(dest)) == 0) error(0, 2, gbl.lineno, "ADD_NUMELM(DTYPEG(dest) is 0 ", CNULL); #endif sz = convert_int(ADD_NUMELM(DTYPEG(dest)), szdtype); } else { /* compute size from shape descriptor */ for (i = ndim - 1; i >= 0; i--) { int lwb, upb, aa; lwb = check_member(lhs, SHD_LWB(shape, i)); lwb = convert_int(lwb, szdtype); upb = check_member(lhs, SHD_UPB(shape, i)); upb = convert_int(upb, szdtype); aa = mk_binop(OP_SUB, upb, lwb, szdtype); aa = mk_binop(OP_ADD, aa, one, szdtype); sz = mk_binop(OP_MUL, sz, aa, szdtype); } } if (is_zero) { if (DT_ISCMPLX(dtype)) { switch (size_of(dtype)) { case 8: rtlRtn = RTE_mzeroz8; break; case 16: rtlRtn = RTE_mzeroz16; break; case 32: rtlRtn = RTE_mzeroz32; break; } } else { switch (size_of(dtype)) { case 1: rtlRtn = RTE_mzero1; break; case 2: rtlRtn = RTE_mzero2; break; case 4: rtlRtn = RTE_mzero4; break; case 8: rtlRtn = RTE_mzero8; break; case 16: rtlRtn = RTE_mzeroz8; break; } } nm = mkRteRtnNm(rtlRtn); func = sym_mkfunc_nodesc(nm, DT_INT); ast = begin_call(A_CALL, func, 2); add_arg(lhs); /*add_arg(sz);*/ add_arg(mk_unop(OP_VAL, sz, szdtype)); ccff_info(MSGOPT, "OPT008", gbl.findex, gbl.lineno, "Memory zero idiom, array assignment replaced by call to %mzero", "mzero=%s", nm, NULL); } else if (src) { if (DT_ISCMPLX(dtype)) { switch (size_of(dtype)) { case 8: rtlRtn = RTE_mcopyz8; break; case 16: rtlRtn = RTE_mcopyz16; break; case 32: rtlRtn = RTE_mcopyz32; break; } } else { switch (size_of(dtype)) { case 1: rtlRtn = RTE_mcopy1; break; case 2: rtlRtn = RTE_mcopy2; break; case 4: rtlRtn = RTE_mcopy4; break; case 8: rtlRtn = RTE_mcopy8; break; case 16: rtlRtn = RTE_mcopyz8; break; } } nm = mkRteRtnNm(rtlRtn); func = sym_mkfunc_nodesc(nm, DT_INT); ast = begin_call(A_CALL, func, 3); add_arg(lhs); add_arg(rhs); /*add_arg(sz);*/ add_arg(mk_unop(OP_VAL, sz, szdtype)); ccff_info(MSGOPT, "OPT006", gbl.findex, gbl.lineno, "Memory copy idiom, array assignment replaced by call to %mcopy", "mcopy=%s", nm, NULL); } else { if (DT_ISCMPLX(dtype)) { switch (size_of(dtype)) { case 8: rtlRtn = RTE_msetz8; break; case 16: rtlRtn = RTE_msetz16; break; case 32: rtlRtn = RTE_msetz32; break; } } else { switch (size_of(dtype)) { case 1: rtlRtn = RTE_mset1; break; case 2: rtlRtn = RTE_mset2; break; case 4: rtlRtn = RTE_mset4; break; case 8: rtlRtn = RTE_mset8; break; case 16: rtlRtn = RTE_msetz8; break; } } nm = mkRteRtnNm(rtlRtn); func = sym_mkfunc_nodesc(nm, DT_INT); ast = begin_call(A_CALL, func, 3); add_arg(lhs); add_arg(rhs); /*add_arg(sz);*/ add_arg(mk_unop(OP_VAL, sz, szdtype)); ccff_info(MSGOPT, "OPT007", gbl.findex, gbl.lineno, "Memory set idiom, array assignment replaced by call to %mset", "mset=%s", nm, NULL); } /*dbg_print_ast(ast, STDERR);*/ return ast; } static int inline_spread_shifts(int asgn_ast, int forall_ast, int inlist) { int argt, nargs; int list, listp, astli; int newlist; int count, nidx; int subs[MAXSUBS]; int ndim; int dim, cdim, shd; int srcarray, maskarray; int newforall; int i, j; int asd; int retval, newast; int shift, cshift; int nd; int func_ast; int dtype; int boundary; assert(A_TYPEG(asgn_ast) == A_INTR, "inline_spread_shifts: wrong ast type", asgn_ast, 3); if (INKINDG(A_SPTRG(A_LOPG(asgn_ast))) == IK_INQUIRY) return asgn_ast; argt = A_ARGSG(asgn_ast); nargs = A_ARGCNTG(asgn_ast); switch (A_OPTYPEG(asgn_ast)) { case I_SPREAD: /* spread(source, dim, ncopies) */ srcarray = ARGT_ARG(argt, 0); dim = ARGT_ARG(argt, 1); if (!A_SHAPEG(srcarray)) dim = astb.i1; if (A_TYPEG(dim) != A_CNST) goto ret_norm; cdim = get_int_cval(A_SPTRG(dim)); newforall = copy_forall(forall_ast); list = A_LISTG(newforall); nidx = 1; for (listp = list; listp != 0; listp = ASTLI_NEXT(listp)) nidx++; count = 1; astli = 0; for (listp = list; listp != 0; listp = ASTLI_NEXT(listp)) { if (count == nidx - cdim) astli = listp; count++; } assert(astli, "normalize_forall: something is wrong", astli, 3); list = delete_astli(list, astli); A_LISTP(newforall, list); newast = normalize_forall(newforall, srcarray, inlist); return newast; case I_TRANSPOSE: /* transpose(matrix) */ srcarray = ARGT_ARG(argt, 0); /* transpose the forall index */ newforall = copy_forall(forall_ast); list = A_LISTG(newforall); count = 0; for (listp = list; listp != 0; listp = ASTLI_NEXT(listp)) { subs[count] = listp; count++; assert(count <= MAXSUBS, "inline_spread_shifts: wrong forall", newforall, 4); } /* only transpose the first two indices; * if there are more than two, we assume (hopefully) that * the others come from the indices added to handle * componentized array members of derived types */ start_astli(); if (count < 2) { listp = subs[0]; newlist = add_astli(); ASTLI_SPTR(newlist) = ASTLI_SPTR(listp); ASTLI_TRIPLE(newlist) = ASTLI_TRIPLE(listp); } else { /* switch 1 and 0 */ for (i = 1; i >= 0; --i) { listp = subs[i]; newlist = add_astli(); ASTLI_SPTR(newlist) = ASTLI_SPTR(listp); ASTLI_TRIPLE(newlist) = ASTLI_TRIPLE(listp); } /* append 2 until the end */ for (i = 2; i < count; ++i) { listp = subs[i]; newlist = add_astli(); ASTLI_SPTR(newlist) = ASTLI_SPTR(listp); ASTLI_TRIPLE(newlist) = ASTLI_TRIPLE(listp); } } list = ASTLI_HEAD; A_LISTP(newforall, list); newast = normalize_forall(newforall, srcarray, inlist); return newast; case I_CSHIFT: /* cshift(array, shift, [dim]) */ case I_EOSHIFT: /* eoshift(array, shift, [boundary, dim]); */ if (A_OPTYPEG(asgn_ast) == I_CSHIFT) dim = ARGT_ARG(argt, 2); else dim = ARGT_ARG(argt, 3); srcarray = ARGT_ARG(argt, 0); shift = ARGT_ARG(argt, 1); if (A_OPTYPEG(asgn_ast) == I_EOSHIFT) { boundary = ARGT_ARG(argt, 2); if (!boundary) ARGT_ARG(argt, 2) = astb.ptr0; } if (dim == 0) dim = mk_cval(1, DT_INT); assert(A_TYPEG(shift) == A_CNST, "inline_spread_shifts: shift must be constant", 3, shift); assert(A_TYPEG(dim) == A_CNST, "inline_spread_shifts: dim must be constant", 3, dim); cdim = get_int_cval(A_SPTRG(dim)); cshift = get_int_cval(A_SPTRG(shift)); if (cshift <= 0) shift = mk_cval(-1 * cshift, DT_INT); retval = normalize_forall(forall_ast, srcarray, inlist); asd = A_ASDG(retval); ndim = ASD_NDIM(asd); list = A_LISTG(forall_ast); count = 0; for (i = 0; i < ndim; i++) { subs[i] = ASD_SUBS(asd, i); nidx = 0; astli = 0; search_forall_idx(ASD_SUBS(asd, i), list, &astli, &nidx); if (astli) count++; if (count == cdim) { if (cshift > 0) subs[i] = mk_binop(OP_ADD, ASD_SUBS(asd, i), shift, astb.bnd.dtype); else subs[i] = mk_binop(OP_SUB, ASD_SUBS(asd, i), shift, astb.bnd.dtype); count = 99; } } dtype = A_DTYPEG(retval); retval = mk_subscr(A_LOPG(retval), subs, ndim, dtype); ARGT_ARG(argt, 0) = retval; func_ast = asgn_ast; retval = mk_func_node(A_TYPEG(func_ast), A_LOPG(func_ast), A_ARGCNTG(func_ast), argt); A_DTYPEP(retval, dtype); A_SHAPEP(retval, 0); A_OPTYPEP(retval, A_OPTYPEG(func_ast)); return retval; case I_SUM: /* sum(a+b,dim=1) */ case I_PRODUCT: case I_MAXVAL: case I_MINVAL: case I_PARITY: // AOCC case I_IPARITY: // AOCC case I_IALL: // AOCC case I_IANY: // AOCC case I_ALL: case I_ANY: case I_COUNT: srcarray = ARGT_ARG(argt, 0); maskarray = ARGT_ARG(argt, 2); dim = ARGT_ARG(argt, 1); cdim = 0; if (dim) { cdim = get_int_cval(A_SPTRG(dim)); } assert(cdim, "inline_spread_shifts: reduction intrinsic without dimension", 3, dim); shd = A_SHAPEG(srcarray); assert(shd, "inline_spread_shifts: reduction intrinsic without shape", 3, shd); list = A_LISTG(forall_ast); nidx = 1; for (listp = list; listp != 0; listp = ASTLI_NEXT(listp)) ++nidx; start_astli(); listp = list; while (nidx) { if (nidx == cdim) { astli = add_astli(); ASTLI_SPTR(astli) = 0; ASTLI_TRIPLE(astli) = mk_triple(SHD_LWB(shd, cdim - 1), SHD_UPB(shd, cdim - 1), SHD_STRIDE(shd, cdim - 1)); } else { astli = add_astli(); ASTLI_SPTR(astli) = ASTLI_SPTR(listp); ASTLI_TRIPLE(astli) = ASTLI_TRIPLE(listp); listp = ASTLI_NEXT(listp); } --nidx; } newforall = mk_stmt(A_FORALL, 0); A_LISTP(newforall, ASTLI_HEAD); srcarray = normalize_forall(newforall, srcarray, inlist); ARGT_ARG(argt, 0) = srcarray; if (maskarray) { maskarray = normalize_forall(newforall, maskarray, inlist); ARGT_ARG(argt, 2) = maskarray; } ARGT_ARG(argt, 1) = 0; return asgn_ast; default: dtype = A_DTYPEG(asgn_ast); A_DTYPEP(asgn_ast, DDTG(dtype)); A_SHAPEP(asgn_ast, 0); goto ret_norm; } ret_norm: for (i = 0; i < nargs; ++i) { ARGT_ARG(argt, i) = normalize_forall(forall_ast, ARGT_ARG(argt, i), inlist); } return asgn_ast; } static int copy_forall(int forall) { int newforall; assert(A_TYPEG(forall) == A_FORALL, "copy_forall:must be FORALL", forall, 3); newforall = mk_stmt(A_FORALL, 0); A_IFSTMTP(newforall, A_IFSTMTG(forall)); A_IFEXPRP(newforall, A_IFEXPRG(forall)); A_LISTP(newforall, A_LISTG(forall)); return newforall; } int make_forall(int shape, int astmem, int mask_ast, int lc) { int i, j, l; int numdim; int sym; int list; int triple, triple1; int ast, ast1; int asd, lwb, upb, stride; int dtype; int nd; int dscast; /* Using the array section in shape, create a forall statement that * will index it, with the mask_ast as the mask */ numdim = SHD_NDIM(shape); if (numdim < 1 || numdim > MAXSUBS) { interr("make_forall:bad numdim", shape, 3); numdim = 0; } start_astli(); #ifdef DSCASTG switch (A_TYPEG(astmem)) { case A_ID: case A_LABEL: case A_ENTRY: case A_SUBSCR: case A_SUBSTR: case A_MEM: dscast = sym_of_ast(astmem); dscast = (STYPEG(dscast) == ST_VAR || STYPEG(dscast) == ST_ARRAY) ? DSCASTG(dscast) : 0; break; default: dscast = 0; } #endif for (i = numdim - 1; i >= 0; i--) { /* make each forall index */ #ifdef DSCASTG lwb = check_member((dscast) ? dscast : astmem, SHD_LWB(shape, i)); upb = check_member((dscast) ? dscast : astmem, SHD_UPB(shape, i)); stride = check_member((dscast) ? dscast : astmem, SHD_STRIDE(shape, i)); #else lwb = check_member(astmem, SHD_LWB(shape, i)); upb = check_member(astmem, SHD_UPB(shape, i)); stride = check_member(astmem, SHD_STRIDE(shape, i)); #endif if (A_DTYPEG(lwb) == DT_INT8 || A_DTYPEG(upb) == DT_INT8 || A_DTYPEG(stride) == DT_INT8) dtype = DT_INT8; else dtype = astb.bnd.dtype; /* add the triple */ /* sym = trans_getidx();*/ sym = get_init_idx((numdim - 1) - i + lc, dtype); if (flg.smp && SCG(sym) == SC_PRIVATE) { /* TASKP(sym, 1) if descriptor is TASKP * We need this because in host * routine where we allocate and copy firstprivate for task * which is done in the host and we need a flag to indicate * that this is TASKP variable even though it is SC_PRIVATE. * iliutil then we ignore the fact that it is private when * it is in host routine. */ } list = add_astli(); triple = mk_triple(lwb, upb, stride); ASTLI_SPTR(list) = sym; ASTLI_TRIPLE(list) = triple; } ast = mk_stmt(A_FORALL, 0); A_LISTP(ast, ASTLI_HEAD); /* now make the mask expression, if any */ if (mask_ast) { ast1 = normalize_forall(ast, mask_ast, 0); A_IFEXPRP(ast, ast1); } else A_IFEXPRP(ast, 0); trans_clridx(); return ast; } void init_tbl(void) { tbl.size = 200; NEW(tbl.base, TABLE, tbl.size); tbl.avl = 0; } void free_tbl(void) { FREE(tbl.base); } int get_tbl(void) { int nd; nd = tbl.avl++; NEED(tbl.avl, tbl.base, TABLE, tbl.size, tbl.size + 100); if (nd > SPTR_MAX || tbl.base == NULL) errfatal(7); return nd; } #if DEBUG int *badpointer1 = (int *)0; long *badpointer2 = (long *)1; long badnumerator = 99; long baddenominator = 0; #endif void trans_process_align(void) { int sptr; clear_dist_align(); #if DEBUG /* convenient place for a segfault */ if (XBIT(4, 0x2000)) { if (!XBIT(4, 0x1000) || gbl.func_count > 2) { /* store to null pointer */ *badpointer1 = 99; } } if (XBIT(4, 0x4000)) { if (!XBIT(4, 0x1000) || gbl.func_count > 2) { /* divide by zero */ badnumerator = badnumerator / baddenominator; } } if (XBIT(4, 0x8000)) { if (!XBIT(4, 0x1000) || gbl.func_count > 2) { /* infinite loop */ while (badnumerator) { badnumerator = (badnumerator < 1) | 3; } } } #endif } static void trans_get_descrs(void) { int sptr, stype; for (sptr = stb.firstusym; sptr < stb.stg_avail; sptr++) { stype = STYPEG(sptr); /* if (stype == ST_ARRAY && SCG(sptr) == SC_NONE) NODESCP(sptr, 1); */ /* unused DYNAMIC should be SC_LOCAL */ if (is_array_type(sptr) && !NODESCG(sptr) && !IGNOREG(sptr)) { if (!is_bad_dtype(DTYPEG(sptr))) trans_mkdescr(sptr); } } } /* ------------- Utilities ------------ */ /* need to try to reuse indices */ static struct idxlist { int idx; int free; struct idxlist *next; } * idxlist; static int trans_getidx(void) { struct idxlist *p; for (p = idxlist; p != 0; p = p->next) if (p->free) { p->free = 0; return p->idx; } p = (struct idxlist *)getitem(TRANS_AREA, sizeof(struct idxlist)); p->idx = sym_get_scalar("i", 0, DT_INT); p->free = 0; p->next = idxlist; idxlist = p; return p->idx; } static void trans_clridx(void) { struct idxlist *p; for (p = idxlist; p != 0; p = p->next) p->free = 1; } static void trans_freeidx(void) { idxlist = 0; freearea(TRANS_AREA); } LOGICAL is_bad_dtype(int dtype) { if ((DTYG(dtype) != TY_NCHAR) && (DTYG(dtype) != TY_STRUCT) && (DTYG(dtype) != TY_UNION)) return FALSE; return TRUE; } LOGICAL is_array_type(int sptr) { int stype; LOGICAL result; result = FALSE; stype = STYPEG(sptr); if ((stype == ST_ARRAY || stype == ST_MEMBER) && DTY(DTYPEG(sptr)) == TY_ARRAY && !DESCARRAYG(sptr)) result = TRUE; return result; } static int find_allocate(int findstd, int findast) { int std, ast; for (std = STD_PREV(findstd); std; std = STD_PREV(std)) { ast = STD_AST(std); if (A_TYPEG(ast) == A_ALLOC && A_TKNG(ast) == TK_ALLOCATE) { if (contains_ast(ast, findast)) { return std; } } else if (A_TYPEG(ast) != A_ASN) { break; } } return 0; } /* find_allocate */ static int find_deallocate(int findstd, int findast) { int std, ast; for (std = STD_NEXT(findstd); std; std = STD_NEXT(std)) { ast = STD_AST(std); if (A_TYPEG(ast) == A_ALLOC && A_TKNG(ast) == TK_DEALLOCATE) { if (contains_ast(ast, findast)) { return std; } } } return 0; } /* find_deallocate */ /* the function of this routine is to use lhs for user-defined * array returning function, * allocate (tmp) * call user_func(tmp, ..) * lhs = tmp + .. * deallocate(tmp) * transformed if lhs can be useable * call user_func(lhs, ...) * lhs = lhs + ... * * lhs is useable * 1-lhs is not common * 2-lhs is not appear multiply times * 3-result is not arg of another function on rhs * (currently, this is checked with contain_calls(rhs) * which is very conservative) */ static LOGICAL use_lhs_for_user_func(int std) { int std1; int ast; int sptr, lhs_sptr; int entry, fval; int nargs, argt; int ele, a, asd, ndim, i; int asn, lhs, src; int asn_std, alloc_std, dealloc_std; ast = STD_AST(std); if (A_TYPEG(ast) != A_CALL) return FALSE; entry = A_SPTRG(A_LOPG(ast)); if (!FVALG(entry)) return FALSE; if (PUREG(entry)) return FALSE; if (RECURG(entry)) return FALSE; /* if we are calling an internal function, the internal * function might modify the LHS variable directly */ if (gbl.internal == 1 && INTERNALG(entry)) return FALSE; fval = FVALG(entry); if (POINTERG(fval)) return FALSE; nargs = A_ARGCNTG(ast); argt = A_ARGSG(ast); ele = ARGT_ARG(argt, 0); assert(A_TYPEG(ele) == A_ID, "use_lhs_for_user_func: fval not ID", ele, 4); sptr = A_SPTRG(ele); /* find where ele is used */ asn_std = 0; for (std1 = STD_NEXT(std); std1; std1 = STD_NEXT(std1)) { if (asn_std) break; ast = STD_AST(std1); if (!contains_ast(ast, ele)) continue; if (A_TYPEG(ast) != A_ASN) return FALSE; asn_std = std1; } if (!asn_std) return FALSE; assert(asn_std, "use_lhs_for_user_func: can not find asn", ele, 4); alloc_std = dealloc_std = 0; if ((!POINTERG(fval) && !ALLOCG(fval)) && (POINTERG(sptr) || ALLOCG(sptr)) && DTY(DTYPEG(sptr)) == TY_ARRAY) { /* find where ele is allocated */ alloc_std = find_allocate(std, ele); if (!alloc_std) return FALSE; assert(alloc_std, "use_lhs_for_user_func: can not find allocate", ele, 4); /* find where ele is deallocated */ dealloc_std = find_deallocate(std, ele); assert(dealloc_std, "use_lhs_for_user_func: can not find deallocate", ele, 4); } /* decide about whether lhs can be used as function result */ asn = STD_AST(asn_std); lhs = A_DESTG(asn); lhs_sptr = sym_of_ast(lhs); /* RHS or function might modify array through pointer association */ if (POINTERG(lhs_sptr)) return FALSE; /* RHS or function might modify array through pointer association */ if (TARGETG(lhs_sptr)) return FALSE; /* if we are calling an internal function from another internal * function and the LHS is from the host subprogram, no */ if (gbl.internal > 1 && INTERNALG(entry) && !INTERNALG(lhs_sptr)) return FALSE; src = A_SRCG(asn); /* need to have same type */ if (DDTG(DTYPEG(sptr)) != DDTG(DTYPEG(lhs_sptr))) return FALSE; /* don't allow if lhs appears at rhs */ if (contains_ast(src, mk_id(lhs_sptr))) return FALSE; /* don't allow if call has lhs */ ast = STD_AST(std); if (contains_ast(ast, mk_id(lhs_sptr))) return FALSE; /* don't allow if lhs common */ if (SCG(lhs_sptr) == SC_CMBLK) return FALSE; /* don't allow if rhs has call */ if (contains_call(src)) return FALSE; /* don't allow if the lhs was allocated after the call */ for (std1 = STD_NEXT(std); std1; std1 = STD_NEXT(std1)) { if (std1 == asn_std) break; ast = STD_AST(std1); if (contains_ast(ast, lhs)) { return FALSE; } } /* don't allow if any subscript is nontriplet with shape */ for (a = lhs; a;) { switch (A_TYPEG(a)) { case A_ID: a = 0; break; case A_MEM: a = A_PARENTG(a); break; case A_SUBSTR: default: return FALSE; case A_SUBSCR: asd = A_ASDG(a); ndim = ASD_NDIM(asd); for (i = 0; i < ndim; ++i) { int ss = ASD_SUBS(asd, i); if (A_SHAPEG(ss) != 0 && A_TYPEG(ss) != A_TRIPLE) { /* vector subscript, ugly */ return FALSE; } } a = A_LOPG(a); break; } } ast_visit(1, 1); ast_replace(ele, lhs); if (A_SRCG(asn) == ele) { /* don't change tmp(:) = F(b(:)) ; a(:) = tmp(:) * into a(:) = F(b(:)) ; a(:) = a(:) */ delete_stmt(asn_std); } else { /* change the asn */ asn = ast_rewrite(asn); STD_AST(asn_std) = asn; } /* change the call */ ast = STD_AST(std); ast = ast_rewrite(ast); STD_AST(std) = ast; ast_unvisit(); /* delete allocate and deallocate */ if (alloc_std) delete_stmt(alloc_std); if (dealloc_std) delete_stmt(dealloc_std); return TRUE; } /* if the array bounds, or distribute arguments of this template * contain any variables, return TRUE */ static LOGICAL variable_template(int tmpl) { int dtype, dist, i, b; dtype = DTYPEG(tmpl); if (DTY(dtype) == TY_ARRAY) { for (i = 0; i < ADD_NUMDIM(dtype); ++i) { b = ADD_LWAST(dtype, i); if (b && A_ALIASG(b) == 0) return TRUE; b = ADD_UPAST(dtype, i); if (!b || A_ALIASG(b) == 0) return TRUE; } } return FALSE; } /* variable_template */ /* replace dummy arguments in an alignment descriptor with actual arguments */ static int find_entry, find_nargs, find_argt, find_dpdsc, find_std; static void find_args(int ast, int *extra) { if (A_TYPEG(ast) == A_ID && A_REPLG(ast) == 0) { /* is this a dummy argument? */ int sptr, i; sptr = A_SPTRG(ast); for (i = 0; i < find_nargs; ++i) { int arg; arg = aux.dpdsc_base[find_dpdsc + i]; if (sptr == arg) { /* we need to make a copy; get a temp */ int temp, dtype, assn, actual; char *tempname; dtype = DTYPEG(sptr); actual = ARGT_ARG(find_argt, i); if (DTY(dtype) != TY_ARRAY) { if (actual && A_DTYPEG(actual) == dtype) { if (A_ALIASG(actual) && dtype == DT_INT) { ast_replace(ast, A_ALIASG(actual)); } else { tempname = mangle_name(SYMNAME(sptr), "t"); temp = getsymbol(tempname); STYPEP(temp, ST_VAR); DCLDP(temp, 1); SCP(temp, SC_LOCAL); DTYPEP(temp, dtype); /* copy from i'th actual argument */ assn = mk_assn_stmt(mk_id(temp), ARGT_ARG(find_argt, i), dtype); add_stmt_before(assn, find_std); ast_replace(ast, mk_id(temp)); } } } else { /* only handle if the actual is itself an array */ if (A_TYPEG(actual) == A_ID) { /* must be same type of array */ int adtype; adtype = A_DTYPEG(actual); if (DTY(adtype + 1) == DTY(dtype + 1)) { /* use the actual argument */ ast_replace(ast, actual); } } } } } } } /* find_args */ static void find_arguments(int std, int entry, int nargs, int argt, int ast) { if (PARAMCTG(entry) != nargs || ast == 0) return; find_entry = entry; find_dpdsc = DPDSCG(entry); if (find_dpdsc == 0) return; find_nargs = nargs; find_argt = argt; find_std = std; ast_traverse(ast, NULL, find_args, NULL); } /* replace_arguments */ static LOGICAL is_non0_scope(int sptr) { int stype; int dtype; ADSC *ad; int ndim, i; int lb, ub, ast; int proc, tmpl; int dist, align; stype = STYPEG(sptr); if (IGNOREG(sptr)) return TRUE; if (stype == ST_ARRAY) { dtype = DTYPEG(sptr); ad = AD_DPTR(dtype); ndim = AD_NUMDIM(ad); for (i = 0; i < ndim; ++i) { lb = AD_LWBD(ad, i); if (contains_non0_scope(lb)) return TRUE; lb = AD_LWAST(ad, i); if (contains_non0_scope(lb)) return TRUE; ub = AD_UPBD(ad, i); if (contains_non0_scope(ub)) return TRUE; ub = AD_UPAST(ad, i); if (contains_non0_scope(ub)) return TRUE; } } return FALSE; } /* This is the callback function for contains_non0_scope(). */ static LOGICAL _contains_non0_scope(int astSrc, LOGICAL *pflag) { if (astSrc && A_TYPEG(astSrc) == A_ID && IGNOREG(A_SPTRG(astSrc))) { *pflag = TRUE; return TRUE; } return FALSE; } /* Return TRUE if astSrc has non zero scope ID somewhere within astSrc. */ static LOGICAL contains_non0_scope(int astSrc) { LOGICAL result = FALSE; if (!astSrc) return FALSE; ast_visit(1, 1); ast_traverse(astSrc, _contains_non0_scope, NULL, &result); ast_unvisit(); return result; } static void _copy(int ast, int *unused) { if (DT_ISINT(A_DTYPEG(ast))) { int sptr; /* member reference, subscript, simple ID? */ switch (A_TYPEG(ast)) { case A_ID: case A_SUBSCR: case A_MEM: /* not section descriptor, not compiler temp */ sptr = memsym_of_ast(ast); if (!DESCARRAYG(sptr) && !CCSYMG(sptr) && !HCCSYMG(sptr)) { /* not already copied */ if (A_REPLG(ast) == 0) { int tmp, newast, ent; tmp = getcctmp('d', ast, ST_VAR, DT_INT); newast = mk_id(tmp); for (ent = gbl.entries; ent != NOSYM; ent = SYMLKG(ent)) { int entry, asn; entry = ENTSTDG(ent); asn = mk_assn_stmt(newast, ast, DT_INT); add_stmt_after(asn, entry); } ast_replace(ast, newast); } } break; } } } /* _copy */ static int copy_nonconst(int ast) { int newast; if (ast == 0) return 0; if (A_TYPEG(ast) == A_CNST) return ast; /* anything else, search, replace */ ast_traverse(ast, NULL, _copy, NULL); newast = ast_rewrite(ast); return newast; } /* copy_nonconst */ /* Make an AST id for the descriptor (SDSC or DESCR) of this symbol. */ static int mk_descr_id(SPTR sptr) { if (SDSCG(sptr)) { return mk_id(SDSCG(sptr)); } else if (DESCRG(sptr)) { return mk_id(DESCRG(sptr)); } else { interr("no descriptor for symbol", sptr, ERR_Fatal); return 0; } } static int build_sdsc_node(int ast) { SPTR sptr = sym_of_ast(ast); int astsdsc; if (A_TYPEG(ast) == A_SUBSCR) ast = A_LOPG(ast); if (A_TYPEG(ast) == A_MEM) { SPTR sptrmem = memsym_of_ast(ast); int astparent = A_PARENTG(ast); astsdsc = mk_id(SDSCG(sptrmem)); astsdsc = mk_member(astparent, astsdsc, DTYPEG(sptr)); } else { astsdsc = mk_descr_id(sptr); } return astsdsc; } static int build_conformable_func_node(int astdest, int astsrc) { int ast; int astfunc; int astdestsdsc; int astsrcsdsc; int sptrdestmem = memsym_of_ast(astdest); int sptrsrcmem = 0; int sptrfunc; int argt; int dtypesrc = A_DTYPEG(astsrc); int dtypedest = A_DTYPEG(astdest); int srcshape = A_SHAPEG(astsrc); int i; int nargs; static FtnRtlEnum rtl_conformable_nn[] = { RTE_conformable_11v, RTE_conformable_22v, RTE_conformable_33v, RTE_conformable_nnv, RTE_conformable_nnv, RTE_conformable_nnv, RTE_conformable_nnv }; static FtnRtlEnum rtl_conformable_dn[] = { RTE_conformable_d1v, RTE_conformable_d2v, RTE_conformable_d3v, RTE_conformable_dnv, RTE_conformable_dnv, RTE_conformable_dnv, RTE_conformable_dnv }; static FtnRtlEnum rtl_conformable_nd[] = { RTE_conformable_1dv, RTE_conformable_2dv, RTE_conformable_3dv, RTE_conformable_ndv, RTE_conformable_ndv, RTE_conformable_ndv, RTE_conformable_ndv, }; if (A_TYPEG(astsrc) == A_ID || A_TYPEG(astsrc) == A_CONV || A_TYPEG(astsrc) == A_CNST || A_TYPEG(astsrc) == A_MEM) { sptrsrcmem = memsym_of_ast(astsrc); } astdestsdsc = 0; if (DESCUSEDG(sptrdestmem)) { astdestsdsc = build_sdsc_node(astdest); } else if (SCG(sptrdestmem) == SC_DUMMY && NEWDSCG(sptrdestmem) && !ADJARRG(sptrdestmem)) { astdestsdsc = mk_id(NEWDSCG(sptrdestmem)); } astsrcsdsc = 0; if (sptrsrcmem) { if (DESCUSEDG(sptrsrcmem)) { astsrcsdsc = build_sdsc_node(astsrc); } else if (SCG(sptrsrcmem) == SC_DUMMY && NEWDSCG(sptrsrcmem) && !srcshape) { astsrcsdsc = mk_id(NEWDSCG(sptrsrcmem)); } } if (astdestsdsc) { if (astsrcsdsc) { nargs = 3; argt = mk_argt(nargs); ARGT_ARG(argt, 0) = astdest; ARGT_ARG(argt, 1) = astdestsdsc; ARGT_ARG(argt, 2) = astsrcsdsc; sptrfunc = sym_mkfunc(mkRteRtnNm(RTE_conformable_dd), DT_INT); } else { int ndim; if (srcshape) { ndim = SHD_NDIM(srcshape); if(ndim <= 3) { nargs = 2 + ndim; argt = mk_argt(nargs); ARGT_ARG(argt, 0) = astdest; ARGT_ARG(argt, 1) = astdestsdsc; for (i = 0; i < ndim; i++) { ARGT_ARG(argt, 2 + i) = mk_unop(OP_VAL, mk_extent_expr(SHD_LWB(srcshape, i), SHD_UPB(srcshape, i)), astb.bnd.dtype); } } else { nargs = 3 + ndim; argt = mk_argt(nargs); ARGT_ARG(argt, 0) = astdest; ARGT_ARG(argt, 1) = astdestsdsc; ARGT_ARG(argt, 2) = mk_unop(OP_VAL, mk_cval(ndim, astb.bnd.dtype), astb.bnd.dtype); for (i = 0; i < ndim; i++) { ARGT_ARG(argt, 3 + i) = mk_unop(OP_VAL, mk_extent_expr(SHD_LWB(srcshape, i), SHD_UPB(srcshape, i)), astb.bnd.dtype); } } sptrfunc = sym_mkfunc(mkRteRtnNm(rtl_conformable_dn[ndim-1]), DT_INT); } else { /* array = scalar * generate * RTE_conformable_dd(dest_addr, dest_sdsc, dest_sdsc) * will return false iff array is not allocated (i.e., the conformable * call is an RTE_allocated call) */ nargs = 3; argt = mk_argt(nargs); ARGT_ARG(argt, 0) = astdest; ARGT_ARG(argt, 1) = astdestsdsc; ARGT_ARG(argt, 2) = astdestsdsc; sptrfunc = sym_mkfunc(mkRteRtnNm(RTE_conformable_dd), DT_INT); } } } else { if (astsrcsdsc) { int ndim = ADD_NUMDIM(dtypesrc); if(ndim <= 3) { nargs = 2 + ndim; argt = mk_argt(nargs); ARGT_ARG(argt, 0) = astdest; ARGT_ARG(argt, 1) = astsrcsdsc; for (i = 0; i < ndim; i++) { ARGT_ARG(argt, 2 + i) = mk_unop(OP_VAL, mk_extent_expr(ADD_LWAST(dtypedest, i), ADD_UPAST(dtypedest, i)), astb.bnd.dtype); } } else { nargs = 3 + ndim; argt = mk_argt(nargs); ARGT_ARG(argt, 0) = astdest; ARGT_ARG(argt, 1) = astsrcsdsc; ARGT_ARG(argt, 2) = mk_unop(OP_VAL, mk_cval(ndim, astb.bnd.dtype), astb.bnd.dtype); for (i = 0; i < ndim; i++) { ARGT_ARG(argt, 3 + i) = mk_unop(OP_VAL, mk_extent_expr(ADD_LWAST(dtypedest, i), ADD_UPAST(dtypedest, i)), astb.bnd.dtype); } } sptrfunc = sym_mkfunc(mkRteRtnNm(rtl_conformable_nd[ndim-1]), DT_INT); } else { int ndim; if (srcshape) { /* generate * RTE_conformable_nn(dest_addr, dest_sz, dest_sz, dest_ndim, * dest_extnt1,src_extnt1, ..., * dest_extntn,src_extntn) */ ndim = SHD_NDIM(srcshape); if(ndim <= 3) { nargs = 1 + 2 * ndim; argt = mk_argt(nargs); ARGT_ARG(argt, 0) = astdest; for (i = 0; i < ndim; i++) { ARGT_ARG(argt, 1 + i * 2) = mk_unop(OP_VAL, mk_extent_expr(ADD_LWAST(dtypedest, i), ADD_UPAST(dtypedest, i)), astb.bnd.dtype); ARGT_ARG(argt, 2 + i * 2) = mk_unop(OP_VAL, mk_extent_expr(SHD_LWB(srcshape, i), SHD_UPB(srcshape, i)), astb.bnd.dtype); } } else { nargs = 2 + 2 * ndim; argt = mk_argt(nargs); ARGT_ARG(argt, 0) = astdest; ARGT_ARG(argt, 1) = mk_unop(OP_VAL, mk_cval(ndim, astb.bnd.dtype), astb.bnd.dtype); for (i = 0; i < ndim; i++) { ARGT_ARG(argt, 2 + i * 2) = mk_unop(OP_VAL, mk_extent_expr(ADD_LWAST(dtypedest, i), ADD_UPAST(dtypedest, i)), astb.bnd.dtype); ARGT_ARG(argt, 3 + i * 2) = mk_unop(OP_VAL, mk_extent_expr(SHD_LWB(srcshape, i), SHD_UPB(srcshape, i)), astb.bnd.dtype); } } } else { /* array = scalar * generate * RTE_conformable_nn(dest_addr, dest_sz, dest_sz, dest_ndim, * dest_extnt1,dest_extnt1, ..., dest_extntn,dest_extntn) * will return false iff array is not allocated (i.e., the conformable * call acts as a RTE_allocated call) */ ndim = ADD_NUMDIM(dtypedest); if(ndim <= 3) { nargs = 1 + 2 * ndim; argt = mk_argt(nargs); ARGT_ARG(argt, 0) = astdest; for (i = 0; i < ndim; i++) { ARGT_ARG(argt, 1 + i * 2) = mk_unop(OP_VAL, mk_extent_expr(ADD_LWAST(dtypedest, i), ADD_UPAST(dtypedest, i)), astb.bnd.dtype); ARGT_ARG(argt, 2 + i * 2) = ARGT_ARG(argt, 1 + i * 2); } } else { nargs = 2 + 2 * ndim; argt = mk_argt(nargs); ARGT_ARG(argt, 0) = astdest; ARGT_ARG(argt, 1) = mk_unop(OP_VAL, mk_cval(ndim, astb.bnd.dtype), astb.bnd.dtype); for (i = 0; i < ndim; i++) { ARGT_ARG(argt, 2 + i * 2) = mk_unop(OP_VAL, mk_extent_expr(ADD_LWAST(dtypedest, i), ADD_UPAST(dtypedest, i)), astb.bnd.dtype); ARGT_ARG(argt, 3 + i * 2) = ARGT_ARG(argt, 2 + i * 2); } } } sptrfunc = sym_mkfunc(mkRteRtnNm(rtl_conformable_nn[ndim-1]), DT_INT); } } NODESCP(sptrfunc, 1); astfunc = mk_id(sptrfunc); A_DTYPEP(astfunc, DT_INT); ast = mk_func_node(A_FUNC, astfunc, nargs, argt); A_DTYPEP(ast, DT_INT); A_OPTYPEP(ast, INTASTG(sptrfunc)); A_LOPP(ast, astfunc); return ast; } /* Generate a conformable test. optype is for a comparison against 0: * OP_GT => conformable * OP_EQ => not conformable but big enough * OP_LT => not conformable and not big enough (or not allocated) */ int mk_conformable_test(int dest, int src, int optype) { int func = build_conformable_func_node(dest, src); int cmp = mk_binop(optype, func, astb.i0, DT_INT); int astif = mk_stmt(A_IFTHEN, 0); A_IFEXPRP(astif, cmp); return astif; } /** \brief Generate a call to poly_conform_types() that is used in polymorphic * allocatable assignment. * * \param dest is the ast representing the LHS of a polymorphic assignment. * \param src is the ast representing the RHS of a polymorphic assignment. * \param intrin_type is an ast that represents a descriptor for an * intrinsic scalar object when src represents an intrinsic scalar * object. It's zero if src is not a non-zero intrinsic object. * * \return the ast representing the function call to poly_conform_types(). */ static int build_poly_func_node(int dest, int src, int intrin_type) { int ast, astfunc, src_sdsc_ast, dest_sdsc_ast; SPTR sptrsrc, sptrdest, sptrfunc; int argt; int flag_con = mk_cval1(1, DT_INT); sptrdest= memsym_of_ast(dest); sptrsrc = memsym_of_ast(src); if (intrin_type != 0) { src_sdsc_ast = intrin_type; flag_con = mk_cval1(0, DT_INT); } else { src_sdsc_ast = get_sdsc_ast(sptrsrc, src); } if (STYPEG(sptrdest) == ST_MEMBER) { dest_sdsc_ast = find_descriptor_ast(sptrdest, dest); } else { dest_sdsc_ast = mk_id(SDSCG(sptrdest)); } argt = mk_argt(4); ARGT_ARG(argt, 0) = dest; ARGT_ARG(argt, 1) = dest_sdsc_ast; ARGT_ARG(argt, 2) = src_sdsc_ast; flag_con = mk_unop(OP_VAL, flag_con, DT_INT); ARGT_ARG(argt, 3) = flag_con; sptrfunc = sym_mkfunc(mkRteRtnNm(RTE_poly_conform_types), DT_INT); NODESCP(sptrfunc, 1); astfunc = mk_id(sptrfunc); A_DTYPEP(astfunc, DT_INT); ast = mk_func_node(A_FUNC, astfunc, 4, argt); A_DTYPEP(ast, DT_INT); A_OPTYPEP(ast, INTASTG(sptrfunc)); A_LOPP(ast, astfunc); return ast; } /** \brief Same as mk_conformable_test() above, except it generates a test * between two polymorphic scalar objects. * * \param dest is the ast representing the LHS of a polymorphic assignment. * \param src is the ast representing the RHS of a polymorphic assignment. * \param optype is the type of check (see mk_conformable_test() above). * \param intrin_type is an ast that represents a descriptor for an * intrinsic scalar object when src represents an intrinsic scalar * object. It's zero if src is not a non-zero intrinsic object. * * \return an ast representing the "if statement" for the polymorphic test. */ static int mk_poly_test(int dest, int src, int optype, int intrin_type) { int func = build_poly_func_node(dest, src, intrin_type); int cmp = mk_binop(optype, func, astb.i0, DT_INT); int astif = mk_stmt(A_IFTHEN, 0); A_IFEXPRP(astif, cmp); return astif; } int mk_allocate(int ast) { int alloc = mk_stmt(A_ALLOC, 0); A_TKNP(alloc, TK_ALLOCATE); A_SRCP(alloc, ast); return alloc; } int mk_deallocate(int ast) { int dealloc = mk_stmt(A_ALLOC, 0); A_TKNP(dealloc, TK_DEALLOCATE); A_SRCP(dealloc, ast); return dealloc; } /* is_assign_lhs is set when this is for the LHS of an assignment */ void rewrite_deallocate(int ast, bool is_assign_lhs, int std, bool can_reorder) { int i; int sptrmem; DTYPE dtype = A_DTYPEG(ast); int shape = A_SHAPEG(ast); int astparent = ast; int docnt = 0; LOGICAL need_endif = FALSE; assert(DTY(DDTG(dtype)) == TY_DERIVED, "unexpected dtype", dtype, ERR_Fatal); if (ALLOCATTRG(memsym_of_ast(ast))) { gen_allocated_check(ast, std, A_IFTHEN, false, is_assign_lhs, false); need_endif = TRUE; } if (shape != 0) { int asd; assert(DTY(dtype) == TY_ARRAY, "expecting array dtype", 0, ERR_Fatal); asd = gen_dos_over_shape(shape, std); docnt = ASD_NDIM(asd); if (A_TYPEG(ast) == A_MEM) { astparent = subscript_allocmem(ast, asd); } else { astparent = mk_subscr_copy(ast, asd, DTY(dtype + 1)); } } // AOCC Begin bool reorder_nullify=false; for (sptrmem = DTY(DDTG(dtype) + 1); sptrmem > NOSYM; sptrmem = SYMLKG(sptrmem)) { if (is_tbp_or_final(sptrmem)) { continue; /* skip tbp */ } if (!ALLOCATTRG(sptrmem)) { continue; } if (can_reorder && has_finalized_component(sptrmem)) { reorder_nullify=true; } } if (reorder_nullify) { add_stmt_after(add_nullify_ast(ast), std); A_MEM_ORDERP(ast,ast); } // AOCC End for (sptrmem = DTY(DDTG(dtype) + 1); sptrmem > NOSYM; sptrmem = SYMLKG(sptrmem)) { int astdealloc; int astmem; if (is_tbp_or_final(sptrmem)) { continue; /* skip tbp */ } astmem = mk_id(sptrmem); astmem = mk_member(astparent, astmem, A_DTYPEG(astmem)); if (!POINTERG(sptrmem) && allocatable_member(sptrmem)) { rewrite_deallocate(astmem, false, std, false); } if (!ALLOCATTRG(sptrmem)) { continue; } astdealloc = mk_deallocate(astmem); A_DALLOCMEMP(astdealloc, 1); if (reorder_nullify) { // AOCC add_stmt_after(astdealloc, std); } else { add_stmt_before(astdealloc, std); } } gen_do_ends(docnt, std); if (need_endif) { int astendif = mk_stmt(A_ENDIF, 0); add_stmt_before(astendif, std); } } /** \brief Generate an IF to see if ast is allocated and insert before std. Caller is responsible for generating ENDIF. \param atype Type of AST to generate, A_IFTHEN or A_ELSEIF. \param negate Check for not allocated instead of allocated. \param is_assign_lhs True if this check is for the LHS of an assignment */ static void gen_allocated_check(int ast, int std, int atype, bool negate, bool is_assign_lhs, bool is_assign_lhs2) { int astfunc; int funcid = mk_id(getsymbol("allocated")); int argt = mk_argt(1); int astif = mk_stmt(atype, 0); int allocstd; assert(atype == A_IFTHEN || atype == A_ELSEIF, "Bad ast type", atype, ERR_Fatal); A_DTYPEP(funcid, DT_LOG); ARGT_ARG(argt, 0) = A_TYPEG(ast) == A_SUBSCR ? A_LOPG(ast) : ast; astfunc = mk_func_node(A_INTR, funcid, 1, argt); A_DTYPEP(astfunc, DT_LOG); A_OPTYPEP(astfunc, I_ALLOCATED); if (negate) astfunc = mk_unop(OP_LNOT, astfunc, DT_LOG); A_IFEXPRP(astif, astfunc); allocstd = add_stmt_before(astif, std); STD_RESCOPE(allocstd) = 1; } /* Generate DOs over each dimension of shape, insert then before std, and return the temp loop variables as an ASD. */ static int gen_dos_over_shape(int shape, int std) { int i; int subs[MAXSUBS]; int ndim = SHD_NDIM(shape); for (i = 0; i < ndim; i++) { int astdo = mk_stmt(A_DO, 0); int sub = mk_id(get_temp(astb.bnd.dtype)); A_DOVARP(astdo, sub); A_M1P(astdo, SHD_LWB(shape, i)); A_M2P(astdo, SHD_UPB(shape, i)); A_M3P(astdo, SHD_STRIDE(shape, i)); A_M4P(astdo, 0); add_stmt_before(astdo, std); subs[i] = sub; } return mk_asd(subs, ndim); } static void gen_do_ends(int docnt, int std) { int astdo; int i; for (i = 0; i < docnt; i++) { astdo = mk_stmt(A_ENDDO, 0); add_stmt_before(astdo, std); } } static void gen_bounds_assignments(int astdestparent, int astdestmem, int astsrcparent, int astsrcmem, int std) { int sptrdest; int ndim = 0; int shape; if (is_array_dtype(A_DTYPEG(astdestmem))) ndim = ADD_NUMDIM(A_DTYPEG(astdestmem)); if (!astdestparent && A_TYPEG(astdestmem) == A_MEM) { astdestparent = A_PARENTG(astdestmem); astdestmem = A_MEMG(astdestmem); } if (astsrcparent && SDSCG(A_SPTRG(astsrcmem))) { shape = mk_mem_ptr_shape(astsrcparent, astsrcmem, A_DTYPEG(astsrcmem)); } else { shape = A_SHAPEG(astsrcmem); } if (shape == 0 && astsrcparent != 0) { shape = A_SHAPEG(astsrcparent); } if (shape == 0) { assert(ndim == 0, "unexpected ndim", ndim, ERR_Fatal); return; } assert(ndim == SHD_NDIM(shape), "bad shape", 0, ERR_Fatal); if (A_SHAPEG(astsrcmem) == 0 || A_TYPEG(astsrcmem) == A_SUBSCR) { shape = mk_bounds_shape(shape); } sptrdest = memsym_of_ast(astdestmem); if (DESCUSEDG(sptrdest)) { int i; int astdest = mk_descr_id(sptrdest); if (astdestparent) { astdest = mk_member(astdestparent, astdest, astb.bnd.dtype); } for (i = 0; i < ndim; i++) { int stride = SHD_STRIDE(shape, i); int astlb = SHD_LWB(shape, i); int astub = SHD_UPB(shape, i); int astextnt = extent_of_shape(shape, i); int subscr = mk_cval(get_global_lower_index(i), astb.bnd.dtype); int ast = mk_subscr(astdest, &subscr, 1, astb.bnd.dtype); ast = mk_assn_stmt(ast, astlb, astb.bnd.dtype); add_stmt_before(ast, std); subscr = mk_cval(get_global_upper_index(i), astb.bnd.dtype); ast = mk_subscr(astdest, &subscr, 1, astb.bnd.dtype); ast = mk_assn_stmt(ast, astub, astb.bnd.dtype); add_stmt_before(ast, std); subscr = mk_cval(get_global_extent_index(i), astb.bnd.dtype); ast = mk_subscr(astdest, &subscr, 1, astb.bnd.dtype); ast = mk_assn_stmt(ast, astextnt, astb.bnd.dtype); add_stmt_before(ast, std); } if (DDTG(A_DTYPEG(A_DESTG(STD_AST(std)))) == DT_DEFERCHAR) { int lhs_len = get_len_of_deferchar_ast(A_DESTG(STD_AST(std))); int rhs_len, ast; if (is_deferlenchar_ast(A_SRCG(STD_AST(std)))) { rhs_len = get_len_of_deferchar_ast(A_SRCG(STD_AST(std))); } else { rhs_len = string_expr_length(A_SRCG(STD_AST(std))); } ast = mk_assn_stmt(lhs_len, rhs_len, DT_INT); add_stmt_before(ast, std); } } else { int i; DTYPE dtypedest = DTYPEG(sptrdest); for (i = 0; i < ndim; i++) { int astlb = SHD_LWB(shape, i); int astub = SHD_UPB(shape, i); int astextnt = extent_of_shape(shape, i); int astlbv = ADD_LWBD(dtypedest, i); int astubv = ADD_UPBD(dtypedest, i); int astextntv = ADD_EXTNTAST(dtypedest, i); if (astlbv != astlb) { int ast = mk_assn_stmt(astlbv, astlb, astb.bnd.dtype); add_stmt_before(ast, std); } if (astubv != astub) { int ast = mk_assn_stmt(astubv, astub, astb.bnd.dtype); add_stmt_before(ast, std); } if (astextntv != astextnt) { int ast = mk_assn_stmt(astextntv, astextnt, astb.bnd.dtype); add_stmt_before(ast, std); } } } } /* Make a new shape that is 1:extent in each dimension. */ static int mk_bounds_shape(int shape) { int i; int ndim = SHD_NDIM(shape); add_shape_rank(ndim); for (i = 0; i < ndim; i++) { int lb = astb.bnd.one; int ub = extent_of_shape(shape, i); add_shape_spec(lb, ub, astb.bnd.one); } return mk_shape(); } static int build_allocation_item(int astdestparent, int astdestmem) { int indx[MAXSUBS]; int ndim; int astitem; int sptrdest; int sptrsdsc; int astdest; int astsdsc; int i; int subscr; int lbast; int ubast; sptrdest = memsym_of_ast(astdestmem); if (DTY(DTYPEG(sptrdest)) != TY_ARRAY) { if (STYPEG(sptrdest) == ST_MEMBER && astdestparent) { /* FS#20128: astdestmem is an allocatable scalar */ return mk_member(astdestparent, astdestmem, A_DTYPEG(astdestmem)); } return astdestmem; } if (A_TYPEG(astdestmem) == A_SUBSCR) astdestmem = A_LOPG(astdestmem); ndim = ADD_NUMDIM(A_DTYPEG(astdestmem)); astdest = astdestmem; if (astdestparent) { astdest = mk_member(astdestparent, astdest, astb.bnd.dtype); } else if (!astdestparent && A_TYPEG(astdestmem) == A_MEM) { astdestparent = A_PARENTG(astdestmem); astdestmem = A_MEMG(astdestmem); } if (DESCUSEDG(sptrdest)) { astsdsc = mk_descr_id(memsym_of_ast(astdestmem)); if (astdestparent) { astsdsc = mk_member(astdestparent, astsdsc, astb.bnd.dtype); } for (i = 0; i < ndim; i++) { subscr = mk_cval(get_global_lower_index(i), astb.bnd.dtype); lbast = mk_subscr(astsdsc, &subscr, 1, astb.bnd.dtype); subscr = mk_cval(get_global_upper_index(i), astb.bnd.dtype); ubast = mk_subscr(astsdsc, &subscr, 1, astb.bnd.dtype); indx[i] = mk_triple(lbast, ubast, astb.i1); } } else { int dtypedest = DTYPEG(sptrdest); for (i = 0; i < ndim; i++) { indx[i] = mk_triple(ADD_LWBD(dtypedest, i), ADD_UPBD(dtypedest, i), astb.i1); } } astitem = mk_subscr(astdest, indx, ndim, DTYG(A_DTYPEG(astdestmem))); return astitem; } static void gen_alloc_mbr(int ast, int std) { int astfunc = mk_allocate(ast); SPTR sptr = memsym_of_ast(ast); add_stmt_before(astfunc, std); if (is_unl_poly(sptr)) { check_alloc_ptr_type(sptr, std, A_DTYPEG(ast), 1, 0, ast, ast); } else { check_alloc_ptr_type(sptr, std, DTYPEG(sptr), 1, 0, 0, ast); } } static void gen_dealloc_mbr(int ast, int std) { int astfunc = mk_deallocate(ast); int std_dealloc = add_stmt_before(astfunc, std); A_DALLOCMEMP(astfunc, 1); if (allocatable_member(memsym_of_ast(ast))) { rewrite_deallocate(ast, true, std_dealloc, true); } } static void nullify_member(int ast, int std, int sptr) { int dtype = DTYPEG(sptr); int sptrmem, aast, mem_sptr_id; for (sptrmem = DTY(DDTG(dtype) + 1); sptrmem > NOSYM; sptrmem = SYMLKG(sptrmem)) { if (ALLOCATTRG(sptrmem)) { aast = mk_id(sptrmem); mem_sptr_id = mk_member(ast, aast, DTYPEG(sptrmem)); add_stmt_before(add_nullify_ast(mem_sptr_id), std); } if (is_tbp_or_final(sptrmem)) { /* skip tbp */ continue; } } } static void handle_allocatable_members(int astdest, int astsrc, int std, bool non_conformable) { int sptrmem; int docnt = 0; int astdestparent = astdest; int astsrcparent = astsrc; DTYPE dtype = A_DTYPEG(astdest); int shape = A_SHAPEG(astdest); if (shape != 0) { int destasd; int srcasd; if (A_TYPEG(astdest) == A_MEM) { int memsptr = A_SPTRG(A_MEMG(astdest)); if (POINTERG(memsptr) || ALLOCATTRG(memsptr)) { shape = mk_mem_ptr_shape(A_PARENTG(astdest), A_MEMG(astdest), dtype); } } destasd = gen_dos_over_shape(shape, std); docnt = ASD_NDIM(destasd); srcasd = normalize_subscripts(destasd, shape, A_SHAPEG(astsrc)); astdestparent = subscript_allocmem(astdest, destasd); if (A_SHAPEG(astsrc)) { astsrcparent = subscript_allocmem(astsrc, srcasd); } } for (sptrmem = DTY(DDTG(dtype) + 1); sptrmem > NOSYM; sptrmem = SYMLKG(sptrmem)) { /* for allocatable components, build an assignment and recurse */ int astmem; int astdestcmpnt; int astsrccmpnt; if (is_tbp_or_final(sptrmem)) { continue; /* skip tbp */ } astmem = mk_id(sptrmem); astdestcmpnt = mk_member(astdestparent, astmem, A_DTYPEG(astmem)); astsrccmpnt = mk_member(astsrcparent, astmem, A_DTYPEG(astmem)); if (A_SHAPEG(astmem) && DESCUSEDG(sptrmem) && !(USELENG(sptrmem) && ALLOCG(sptrmem) && TPALLOCG(sptrmem))) { int destshape = mk_mem_ptr_shape(astdestparent, astmem, A_DTYPEG(astmem)); int srcshape = mk_mem_ptr_shape(astsrcparent, astmem, A_DTYPEG(astmem)); A_SHAPEP(astdestcmpnt, destshape); A_SHAPEP(astsrccmpnt, srcshape); } if (POINTERG(sptrmem) && !F90POINTERG(sptrmem)) { int ptr_assign = add_ptr_assign(astdestcmpnt, astsrccmpnt, std); A_SHAPEP(ptr_assign, A_SHAPEG(astsrccmpnt)); add_stmt_before(ptr_assign, std); } else { int stdassncmpnt; int sym = memsym_of_ast(astdest); int mem = memsym_of_ast(astdestcmpnt); int assn = mk_assn_stmt(astdestcmpnt, astsrccmpnt, A_DTYPEG(astsrccmpnt)); A_SHAPEP(assn, A_SHAPEG(astsrccmpnt)); stdassncmpnt = add_stmt_before(assn, std); if (SCG(sym) == SC_LOCAL && !INMODULEG(sym) && !SAVEG(sym) && A_TYPEG(astdest) == A_SUBSCR && (ALLOCATTRG(mem) || allocatable_member(mem))) { /* FS#19743: Make sure this member is NULL. Since we're * accessing a member in an individual element of an array * of derived type, we need to make sure member is initially * NULL here. */ int i; LOGICAL const_subscript = FALSE; int asd = A_ASDG(astdest); int ndim = ASD_NDIM(asd); for (i = 0; i < ndim; i++) { const_subscript = A_TYPEG(ASD_SUBS(asd, i)) == A_CNST; if (!const_subscript) break; } if (const_subscript) { add_stmt_after(add_nullify_ast(astdestcmpnt), ENTSTDG(gbl.currsub)); } } if ((ALLOCATTRG(sptrmem) || allocatable_member(sptrmem)) && !TPALLOCG(sptrmem)) { rewrite_allocatable_assignment(assn, stdassncmpnt, non_conformable, true); } } if (ALLOCG(sptrmem) || (POINTERG(sptrmem) && !F90POINTERG(sptrmem))) { /* skip past $p, $o, $sd $td */ int osptr = sptrmem; int midnum = MIDNUMG(sptrmem); int offset = PTROFFG(sptrmem); int sdsc = SDSCG(sptrmem); if (sdsc && STYPEG(sdsc) == ST_MEMBER) { if (SYMLKG(sptrmem) == midnum) { sptrmem = SYMLKG(sptrmem); } if (SYMLKG(sptrmem) == offset) { sptrmem = SYMLKG(sptrmem); } if (SYMLKG(sptrmem) == sdsc) { sptrmem = SYMLKG(sptrmem); } if (CLASSG(osptr) && DESCARRAYG(sptrmem)) { sptrmem = SYMLKG(sptrmem); } } else { if (midnum && midnum == SYMLKG(sptrmem)) sptrmem = SYMLKG(sptrmem); if (sdsc && sdsc == SYMLKG(sptrmem)) sptrmem = SYMLKG(sptrmem); } } } gen_do_ends(docnt, std); } static int sptrMatch; /* sptr # for matching */ static int parentMatch; /* sptr # for matching */ /* This is the callback function for contains_sptr(). */ static LOGICAL _contains_sptr(int astSrc, LOGICAL *pflag) { if (A_TYPEG(astSrc) == A_ID && sptrMatch == A_SPTRG(astSrc) && parentMatch == 0) { *pflag = TRUE; return TRUE; } else if (A_TYPEG(astSrc) == A_MEM && sptrMatch == A_SPTRG(astSrc) && parentMatch == A_PARENTG(astSrc)) { *pflag = TRUE; return TRUE; } return FALSE; } /* Return TRUE if sptrDst occurs somewhere within astSrc. */ static LOGICAL contains_sptr(int astSrc, int sptrDst, int astparent) { LOGICAL result = FALSE; if (!astSrc) return FALSE; sptrMatch = sptrDst; parentMatch = astparent; ast_visit(1, 1); ast_traverse(astSrc, _contains_sptr, NULL, &result); ast_unvisit(); return result; } /** \brief Checks whether the user specified an empty array subscript such as * (:), (:,:), (:,:,:), etc. * * \param a is the array subscript ast (A_SUBSCR) to check. * * \returns true if \ref a is an empty subscript; else false. */ static bool chk_assumed_subscr(int a) { int i, t, asd, ndim; if (A_TYPEG(a) != A_SUBSCR) return false; asd = A_ASDG(a); ndim = ASD_NDIM(asd); assert(ndim >= 1 && ndim <= MAXDIMS, "chk_assumed_subscr: invalid ndim", ndim, ERR_Fatal); for (i = 0; i < ndim; i++) { t = ASD_SUBS(asd, i); if (A_MASKG(t) != (lboundMask | uboundMask | strideMask)) return false; } return true; } /** \brief Create a non-subscripted "alias" or "replacement" ast to a * subscripted expression. * * This is used in a poly_asn() call where the source argument cannot * directly handle an A_SUBSCR which could be an array slice. This * function either returns the array object if it has an empty * subscript expression or a pointer to a contiguous shallow copy * of the array slice. * * \param subAst is the subscripted expression that we are processing. * \param std is the std for adding statements. * * \returns the replacement ast. */ static int mk_ptr_subscr(int subAst, int std) { SPTR ptr; int ptr_ast, ast; DTYPE dtype, eldtype; int asn_ast, temp_arr; int subscr[MAXRANK]; if (A_TYPEG(subAst) != A_SUBSCR) { return subAst; } dtype = A_DTYPEG(subAst); if (chk_assumed_subscr(subAst)) { /* The subscript references the whole array, so return just the array * symbol. */ return A_LOPG(subAst); } /* We have an array slice, so we want to create a shallow contiguous * copy of the array. */ eldtype = DDTG(dtype); temp_arr = mk_assign_sptr(subAst, "a", subscr, eldtype, &ptr_ast); asn_ast = mk_assn_stmt(ptr_ast, subAst, eldtype); if (ALLOCG(temp_arr)) { ast = gen_alloc_dealloc(TK_ALLOCATE, ptr_ast, 0); std = add_stmt_before(ast, std); std = add_stmt_after(mk_stmt(A_CONTINUE, 0), std); } add_stmt_before(asn_ast, std); if (ALLOCG(temp_arr)) { check_and_add_auto_dealloc_from_ast(ptr_ast); } return mk_id(temp_arr); } /** \brief Computes the descriptor on the right hand side of an allocatable * polymorphic assignment. * * \param sptrsrc is the symbol table pointer of the object associated with * the right hand side of a polymorphic assignment. * \param astsrc is the AST representing the right hand side of a polymorphic * assignment. * * \return an AST representing the descriptor for the right hand side of the * polymorphic assignment. */ static int get_sdsc_ast(SPTR sptrsrc, int astsrc) { int src_sdsc_ast; if (!SDSCG(sptrsrc)) { DTYPE src_dtype = DTYPEG(sptrsrc); if (CLASSG(sptrsrc) && STYPEG(sptrsrc) != ST_MEMBER && SCG(sptrsrc) == SC_DUMMY) { src_sdsc_ast = mk_id(get_type_descr_arg(gbl.currsub, sptrsrc)); } else if (DTY(src_dtype) == TY_ARRAY && DESCRG(sptrsrc)) { src_sdsc_ast = mk_id(DESCRG(sptrsrc)); DESCUSEDP(sptrsrc, TRUE); NODESCP(sptrsrc, FALSE); } else if (DTY(src_dtype) == TY_DERIVED) { src_sdsc_ast = mk_id(get_static_type_descriptor(sptrsrc)); } else { get_static_descriptor(sptrsrc); src_sdsc_ast = STYPEG(sptrsrc) != ST_MEMBER ? mk_id(SDSCG(sptrsrc)) : check_member(astsrc, mk_id(SDSCG(sptrsrc))); } } else if (STYPEG(sptrsrc) == ST_MEMBER) { src_sdsc_ast = find_descriptor_ast(sptrsrc, astsrc); } else { src_sdsc_ast = mk_id(SDSCG(sptrsrc)); } return src_sdsc_ast; } /** \brief This function counts the number of allocatable members/components in * a derived type member expression (e.g., a%b, a%b%c, a%b%c%d, etc.). * * \param ast is the AST of the expression that we are testing. * * \return an integer representing the number of allocatable members. */ static int count_allocatable_members(int ast) { SPTR sptr; int num_alloc_members = 0; while (1) { switch (A_TYPEG(ast)) { case A_ID: case A_LABEL: case A_ENTRY: if (ALLOCATTRG(A_SPTRG(ast))) { ++num_alloc_members; } return num_alloc_members; case A_FUNC: case A_CALL: case A_SUBSCR: case A_SUBSTR: ast = A_LOPG(ast); if (A_TYPEG(ast) == A_MEM) ast = A_MEMG(ast); break; case A_MEM: if (ALLOCATTRG(A_SPTRG(A_MEMG(ast)))) { ++num_alloc_members; } ast = A_PARENTG(ast); break; default: interr("count_allocatable_members: unexpected ast", ast, 3); return 0; } } } /* MORE - possible performance improvements: * 1) The RTE_conformable_* RTL functions' return values are ternary * returning * 1 ==> conformable * 0 ==> not conformable but big enough * -1 --> not conformable, no big enough * but the code generated below collapses values 0 and -1 into "not * conformable". * An "ALLOCATE" could be saved by separating these two states (would need * to * reset bounds variables and "remember" actual allocation size). * 2) check assignments to allocatable arrays where the shape of the RHS is * known to be compatiable with the LHS, e.g., * alloc_array = alloc_array + scalar_value * in this case nothing needs to be done * 3) optimize assignments of derived type initializers, e.g., * derived_type%alloc_component = (prototype instance)%alloc_component */ static void rewrite_allocatable_assignment(int astasgn, const int std, bool non_conformable, bool handle_alloc_members ) { int sptrdest; int shape; int astdestparent; int astsrcparent; int astif; int ast; int targstd, newstd; SPTR sptrsrc = NOSYM; DTYPE dtype = A_DTYPEG(astasgn); int astdest = A_DESTG(astasgn); DTYPE dtypedest = A_DTYPEG(astdest); int astsrc = A_SRCG(astasgn); DTYPE dtypesrc = A_DTYPEG(astsrc); LOGICAL alloc_scalar_parent_only = FALSE; LOGICAL needFinalization; SPTR parentSrcSptr = NOSYM; SPTR parentDestSptr; bool is_poly_assign; /* true when we have an F2008 polymorphic assignment */ again: if (A_TYPEG(astdest) != A_ID && A_TYPEG(astdest) != A_MEM && A_TYPEG(astdest) != A_CONV && A_TYPEG(astdest) != A_SUBSCR) { return; } if (A_TYPEG(astdest) == A_SUBSCR && DTYG(A_DTYPEG(astdest)) != TY_DERIVED) { return; } if (A_TYPEG(astsrc) == A_FUNC) { if (!XBIT(54, 0x1)) { if (A_DTYPEG(astdest) == DT_DEFERCHAR || A_DTYPEG(astdest) == DT_DEFERNCHAR) { int fval = FVALG(A_SPTRG(A_LOPG(astsrc))); if (DTYPEG(fval) == DT_DEFERCHAR || DTYPEG(fval) == DT_DEFERNCHAR) return; } else { return; } /* function calls assigned to allocatables are handled in * semfunc.c:func_call */ } } sptrdest = memsym_of_ast(astdest); parentDestSptr = sym_of_ast(astdest); needFinalization = has_finalized_component(sptrdest); if (XBIT(54, 0x1) && !XBIT(54, 0x4) && ALLOCATTRG(sptrdest) && A_TYPEG(astdest) == A_SUBSCR && DTY(dtypesrc) == TY_ARRAY && DTY(dtypedest) == TY_ARRAY) { /* FS#21080: destination array inherits shape from source array * under F2003 semantics, so we can disregard empty subscripts. */ int i; int empty_subscript; int asd = A_ASDG(astdest); int ndim = ASD_NDIM(asd); for (empty_subscript = i = 0; i < ndim; i++) { if (A_TYPEG(ASD_SUBS(asd, i)) == A_TRIPLE && A_MASKG(ASD_SUBS(asd, i)) == (lboundMask | uboundMask | strideMask)) { empty_subscript = 1; } else { empty_subscript = 0; break; } } if (empty_subscript) { astdest = A_LOPG(astdest); goto again; } } while (A_TYPEG(astsrc) == A_CONV) { astsrc = A_LOPG(astsrc); } if (ALLOCATTRG(sptrdest) && A_TYPEG(astsrc) == A_INTR && A_OPTYPEG(astsrc) == I_NULL) { ast = mk_deallocate(astdest); A_DALLOCMEMP(ast, 1); add_stmt_before(ast, std); ast_to_comment(astasgn); return; } if (A_TYPEG(astsrc) == A_ID || A_TYPEG(astsrc) == A_CONV || A_TYPEG(astsrc) == A_SUBSCR || A_TYPEG(astsrc) == A_CNST || A_TYPEG(astsrc) == A_MEM) { sptrsrc = memsym_of_ast(astsrc); parentSrcSptr = sym_of_ast(astsrc); if (STYPEG(sptrdest) == ST_MEMBER && STYPEG(sptrsrc) == ST_MEMBER && ALLOCDESCG(sptrdest)) { /* FS#19589: Make sure we propagate type descriptor from source * to destination. */ check_pointer_type(astdest, astsrc, std, 1); } } is_poly_assign = (!handle_alloc_members || count_allocatable_members(astdest) == 1) && CLASSG(sptrdest) && !MONOMORPHICG(sptrdest) && parentSrcSptr > NOSYM && !CCSYMG(parentSrcSptr) && !HCCSYMG(parentDestSptr); if (XBIT(54, 0x1) && !XBIT(54, 0x4) && sptrsrc != NOSYM && (A_TYPEG(astdest) == A_ID || A_TYPEG(astdest) == A_MEM) && ALLOCATTRG(sptrdest) && (is_poly_assign || (DTY(DTYPEG(sptrdest)) == TY_ARRAY && DTY(DTYPEG(sptrsrc)) == TY_ARRAY && allocatable_member(sptrdest) && !has_vector_subscript_ast(astsrc)))) { int std2 = std; int alloc_std; int src_sdsc_ast = 0; int intrin_type = 0; int tmp_desc = 0; /* holds an intrinsic pseudo descriptor when non-zero */ DTYPE src_dtype = DTYPEG(sptrsrc); int intrin_ast; if (DT_ISBASIC(DDTG(src_dtype))) { /* DTYPE of right hand side is an intrinsic data type, so generate an * intrinsic pseudo descriptor (stored in the tmp_desc variable). */ tmp_desc = getcctmp_sc('d', sem.dtemps++, ST_VAR, astb.bnd.dtype, sem.sc); intrin_type = mk_cval(dtype_to_arg(DDTG(src_dtype)), astb.bnd.dtype); tmp_desc = mk_id(tmp_desc); intrin_ast = mk_assn_stmt(tmp_desc, intrin_type, astb.bnd.dtype); intrin_type = mk_unop(OP_VAL, intrin_type, DT_INT); add_stmt_before(intrin_ast, std2); } /* Allocate function result that's an array of derived types * with allocatable components and -Mallocatable=03. */ /* Generate statements like this: if (.not. allocated(src)) then if (allocated(dest)) deallocate(dest) else if (.not. conformable(src, dest)) then if (allocated(dest) deallocate(dest) allocate(dest, source=src) else // generated iff dest has final subroutines finalize(dest) end if poly_asn(src, dest) end if <-- std2 ... <-- std */ if (ALLOCATTRG(sptrsrc)) { /* if (.not. allocated(src)) then deallocate(dest) else ... end if */ gen_allocated_check(astsrc, std, A_IFTHEN, true, false, false); gen_dealloc_if_allocated(astdest, std); add_stmt_before(mk_stmt(A_ELSE, 0), std); std2 = add_stmt_before(mk_stmt(A_ENDIF, 0), std); } /* if (.not. conformable(src, dst)) then */ astif = DTY(DTYPEG(sptrdest)) != TY_ARRAY ? mk_poly_test(astdest, astsrc, OP_LT, tmp_desc) : mk_conformable_test(astdest, astsrc, OP_LT); add_stmt_before(astif, std2); gen_dealloc_if_allocated(astdest, std2); /* allocate(dest, source=src) */ ast = mk_allocate(0); A_STARTP(ast, astsrc); A_DTYPEP(ast, DTY(DTYPEG(sptrdest)) != TY_ARRAY ? A_DTYPEG(astsrc) : dup_array_dtype(A_DTYPEG(astsrc))); if (DTY(dtypedest) == TY_ARRAY) { int astdest2 = add_shapely_subscripts(astdest, astsrc, A_DTYPEG(astsrc), DDTG(dtypedest)); A_SRCP(ast, astdest2); } else { A_SRCP(ast, astdest); } alloc_std = add_stmt_before(ast, std2); src_sdsc_ast = get_sdsc_ast(sptrsrc, astsrc); if (CLASSG(sptrdest) && DTY(DTYPEG(sptrdest)) == TY_ARRAY && A_TYPEG(astsrc) == A_SUBSCR) { alloc_std = init_sdsc_bounds(sptrdest, A_DTYPEG(astsrc), alloc_std, sym_of_ast(astdest), astsrc, src_sdsc_ast); } if (DTY(DDTG(src_dtype)) == TY_CHAR || DTY(DDTG(src_dtype)) == TY_NCHAR) { int len = ast_intr(I_LEN, astb.bnd.dtype, 1, A_TYPEG(astsrc) == A_SUBSCR ? A_LOPG(astsrc) : astsrc); len = gen_set_len_ast(astdest, SDSCG(sptrdest), len); alloc_std = add_stmt_after(len, alloc_std); } if (needFinalization) { /* Objects are conformable but we still need to finalize destination */ int std3 = add_stmt_before(mk_stmt(A_ELSE, 0), std2); gen_finalization_for_sym(sptrdest, std3, astdest); needFinalization = FALSE; } add_stmt_before(mk_stmt(A_ENDIF, 0), std2); if (CLASSG(sptrdest) || (STYPEG(SDSCG(sptrsrc)) == ST_MEMBER && STYPEG(SDSCG(sptrdest)) == ST_MEMBER)) { /* Generate call to poly_asn(). This call takes care of * the member to member assignments. This includes propagating * the source descriptor values to the destination descriptor. */ int dest_sdsc_ast; SPTR fsptr = sym_mkfunc_nodesc(mkRteRtnNm(RTE_poly_asn), DT_NONE); int argt = mk_argt(5); int std3; int flag_con = 2; int flag_ast; if (STYPEG(sptrdest) == ST_MEMBER) { dest_sdsc_ast = find_descriptor_ast(sptrdest, astdest); } else { dest_sdsc_ast = mk_id(SDSCG(sptrdest)); } if (tmp_desc != 0 && DT_ISBASIC(src_dtype)) { src_sdsc_ast = tmp_desc; flag_con = 0; } flag_ast = mk_cval1(flag_con, DT_INT); flag_ast = mk_unop(OP_VAL, flag_ast, DT_INT); std3 = add_stmt_before(mk_stmt(A_CONTINUE, 0), std2); ARGT_ARG(argt, 4) = flag_ast; ARGT_ARG(argt, 0) = A_TYPEG(astdest) == A_SUBSCR ? A_LOPG(astdest) : astdest; ARGT_ARG(argt, 1) = dest_sdsc_ast; ARGT_ARG(argt, 2) = mk_ptr_subscr(astsrc, std3); ARGT_ARG(argt, 3) = src_sdsc_ast; ast = mk_id(fsptr); ast = mk_func_node(A_CALL, ast, 5, argt); std2 = add_stmt_before(ast, std2); if (intrin_type != 0) { /* Assign intrinsic type to destination's (unlimited polymorphic) * descriptor. */ ast = mk_set_type_call(dest_sdsc_ast, intrin_type, TRUE); add_stmt_before(ast, std2); /* before call to poly_asn() */ if (flag_con == 2) { /* 2 for Flag argument means poly_asn() will copy source descriptor * to destination descriptor. Therefore, make sure we re-assign the * type after the call too. */ 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; } } /* ignore default initialization */ if (sptrsrc > NOSYM) { SPTR sptr; if (A_TYPEG(astsrc) != A_MEM) { sptr = sptrsrc; } else if (A_TYPEG(A_PARENTG(astsrc)) == A_FUNC) { sptr = sym_of_ast(A_LOPG(A_PARENTG(astsrc))); } else { sptr = ast_is_sym(astsrc) ? sym_of_ast(astsrc) : 0; } /* * This little bit of once-undocumented magic (formerly a string * comparison on the name of the RHS symbol!) forces the use of a * block copy for a derived type assignment whose right-hand side is * a compiler-created initialized prototype object used for * filling in new instances. In such circumstances, the left-hand * side of the assignment must be assumed to be uninitialized * garbage. */ if (sptr > NOSYM && INITIALIZERG(sptr)) return; } /* Notes for deciphering the following code: * XBIT(54, 0x1) -> enable "full F'03 allocatable attribute regularization" * XBIT(54, 0x4) -> *No* 2003 allocatable assignment semantics for * allocatable components */ /* Per flyspray 15461, for user-defined type assignment: a[i] = b , A_TYPEG(astdest) is a A_SUBSCR, also need to check for allocatable member. */ if (!ALLOCATTRG(sptrdest) || A_TYPEG(astdest) == A_SUBSCR) { if (DTYG(dtypedest) == TY_DERIVED && !HCCSYMG(sptrdest) && !XBIT(54, 0x4) && allocatable_member(sptrdest)) { handle_allocatable_members(astdest, astsrc, std, false); ast_to_comment(astasgn); return; } if (STYPEG(sptrdest) == ST_MEMBER && !XBIT(54, 0x4) && XBIT(54, 0x1)) { /* FS#19118 - this typically occurs with an intrinsic assignment * that has a structure constructor on the right hand side. We need * to make sure the parent object is allocated when -Mallocatable=03 * is used. */ astdest = A_PARENTG(astdest); if (A_TYPEG(astdest) == A_SUBSCR) astdest = A_LOPG(astdest); if (A_TYPEG(astdest) == A_MEM) { sptrdest = A_SPTRG(A_MEMG(astdest)); } else sptrdest = A_SPTRG(astdest); dtypedest = A_DTYPEG(astdest); if (!ALLOCATTRG(sptrdest) || DTY(dtypedest) == TY_ARRAY) return; alloc_scalar_parent_only = TRUE; /* not returning on this one path */ } else { return; } } /* * The test of absence of -Mallocatable=O3 is required here ... */ if (!XBIT(54, 0x1) && A_TYPEG(astdest) == A_ID && ALLOCATTRG(sptrdest) && DTYG(dtypedest) == TY_DERIVED && !POINTERG(sptrdest) && !XBIT(54, 0x4) && allocatable_member(sptrdest)) { /* * bug1 of f15460 -- have an allocatable array of derived type * containing allocatable components; with pre-F2003 semantics, * still must handle the allocatable components. */ /*add check here too ?*/ handle_allocatable_members(astdest, astsrc, std, false); ast_to_comment(astasgn); } if (DTY(DTYPEG(sptrdest)) == TY_ARRAY && DTY(A_DTYPEG(astsrc)) != TY_ARRAY) { /* By definition, for * array = scalar * the scalar has the same shape as the array. * Therefore, there is no need apply any allocatable * semantics. * NOTE: CANNOT move this check before the checks for an * array containing allocatable components. */ if (XBIT(54, 0x1)) { /* For F2003 allocatation semantics, if the LHS is not allocated, then * allocate it as a size one array. Otherwise, leave it alone and * perform any applicable finalization. */ int subs[MAXDIMS]; int astdest2, ndims, i; ADSC *ad; ad = AD_DPTR(DTYPEG(sptrdest)); ndims = AD_NUMDIM(ad); gen_allocated_check(astdest, std, A_IFTHEN, true, true, true); for (i = 0; i < ndims; ++i) { subs[i] = mk_triple(astb.i1, astb.i1, 0); } astdest2 = mk_subscr(astdest, subs, ndims, DTYPEG(sptrdest)); ast = mk_allocate(astdest2); newstd = add_stmt_before(ast, std); STD_RESCOPE(newstd) = 1; if (needFinalization) { int std2 = add_stmt_before(mk_stmt(A_ELSE, 0), std); gen_finalization_for_sym(sptrdest, std2, astdest); } newstd = add_stmt_before(mk_stmt(A_ENDIF, 0), std); STD_RESCOPE(newstd) = 1; } if (XBIT(54, 0x1) && DTYG(dtypedest) == TY_DERIVED && !POINTERG(sptrdest) && !XBIT(54, 0x4) && allocatable_member(sptrdest)) { /* FS#18432: F2003 allocatable semantics, handle the * allocatable components */ handle_allocatable_members(astdest, astsrc, std, false); ast_to_comment(astasgn); } return; } if (!XBIT(54, 0x1) && A_TYPEG(astdest) != A_MEM) { if (DDTG(A_DTYPEG(astdest)) == DT_DEFERCHAR || DDTG(A_DTYPEG(astdest)) == DT_DEFERNCHAR) { /* 03 semantics default for scalar allocatable deferred char */ ; } else return; /* allocatable array assignment with pre F2003 semantics */ } if (XBIT(54, 0x4)) return; /* not using F'03 assignment semantics for allocatable components */ /* move this block to a separate subroutine eventually */ astdestparent = 0; if (A_TYPEG(astdest) == A_MEM) { astdestparent = A_PARENTG(astdest); } if (ALLOCATTRG(sptrdest) && (DTY(dtypedest) == TY_ARRAY || DTY(dtypedest) == TY_CHAR || DTY(dtypedest) == TY_NCHAR) && (contains_sptr(astsrc, sptrdest, astdestparent) || A_TYPEG(astsrc) == A_FUNC || A_TYPEG(astsrc) == A_INTR)) { int temp_ast; SPTR temp_sptr; int std2; int stdlast = STD_LAST; int shape = A_SHAPEG(astsrc); if (shape != 0) { if (DDTG(A_DTYPEG(astsrc)) == DT_DEFERCHAR || DDTG(A_DTYPEG(astsrc)) == DT_DEFERNCHAR) { DTYPE temp_dtype = get_type(2, TY_CHAR, string_expr_length(astsrc)); temp_dtype = dtype_with_shape(temp_dtype, shape); temp_sptr = get_arr_temp(temp_dtype, FALSE, FALSE, FALSE); DTYPEP(temp_sptr, temp_dtype); } else { DTYPE temp_dtype = dtype_with_shape(dtype, shape); temp_sptr = get_arr_temp(temp_dtype, TRUE, TRUE, FALSE); } } else if (DTY(dtypedest) == TY_CHAR || DTY(dtypedest) == TY_NCHAR) { DTYPE temp_dtype = get_type(2, TY_CHAR, string_expr_length(astsrc)); temp_sptr = get_ch_temp(temp_dtype); } else { /* error if it is TY_CHAR it must have shape */ interr("transfrm: expecting shape for astsrc in assignment stmt", astasgn, ERR_Warning); goto no_lhs_on_rhs; } /* * NOTE - if the rhs warrants creating compiler allocatable, the * corresponding code will be added to the 'end' of the routine * since the routines being called, such as get_arr_temp(), are * 'semant' routines. Therefore, the generated statements need * to be 'moved' to the current position. */ targstd = std; move_stmts_before(STD_NEXT(stdlast), targstd); temp_ast = mk_id(temp_sptr); ast = mk_assn_stmt(temp_ast, astsrc, A_DTYPEG(astasgn)); std2 = add_stmt_before(ast, std); rewrite_allocatable_assignment(ast, std2, false, handle_alloc_members); ast = mk_assn_stmt(astdest, temp_ast, A_DTYPEG(astasgn)); std2 = add_stmt_after(ast, std2); rewrite_allocatable_assignment(ast, std2, false, handle_alloc_members); ast_to_comment(astasgn); gen_deallocate_arrays(); targstd = std; move_stmts_after(STD_NEXT(stdlast), targstd); return; } no_lhs_on_rhs: if (sptrsrc != NOSYM && ALLOCATTRG(sptrsrc)) { /* generate a check for an allocated source */ gen_allocated_check(astsrc, std, A_IFTHEN, false, false, false); } if (DTY(DTYPEG(sptrdest)) != TY_ARRAY) { /* Scalar assignment: * If the dest has not been allocated, then it must be. * Arrays will be handled based on conformability (below). */ if (DTY(dtypedest) == TY_CHAR || DTY(dtypedest) == TY_NCHAR ) { if (!SDSCG(sptrdest)) { get_static_descriptor(sptrdest); } gen_automatic_reallocation(astdest, astsrc, std); } else { int istd; gen_allocated_check(astdest, std, A_IFTHEN, true, true, false); gen_alloc_mbr(build_allocation_item(0, astdest), std); astif = mk_stmt(A_ENDIF, 0); istd = add_stmt_before(astif, std); if (DTYG(dtypedest) == TY_DERIVED && !XBIT(54, 0x4) && allocatable_member(sptrdest)) { nullify_member(astdest, istd, sptrdest); } } } if (alloc_scalar_parent_only) { goto fin; } shape = A_SHAPEG(astdest); if (shape != 0 && !non_conformable) { /* destination is array, generate conformability check */ if (DTYG(dtypedest) == TY_DERIVED) { astif = mk_conformable_test(astdest, astsrc, OP_GT); add_stmt_before(astif, std); if (needFinalization) { /* Arrays are conformable but we still need to finalize destination */ int std2 = add_stmt_before(mk_stmt(A_CONTINUE, 0), std); gen_finalization_for_sym(sptrdest, std2, astdest); needFinalization = FALSE; } } else { /* array of scalar, generate: if( tmp .le. 0 ) then => not conformable */ astif = mk_conformable_test(astdest, astsrc, OP_LE); add_stmt_before(astif, std); if (DDTG(dtypedest) == DT_DEFERCHAR || DDTG(dtypedest) == DT_DEFERNCHAR) { /* Add length check for deferred char to the IF expr as well */ int lhs_len = size_ast_of(astdest, DDTG(dtypedest)); int rhs_len, binopast, ifexpr; if (is_deferlenchar_ast(astsrc)) { rhs_len = get_len_of_deferchar_ast(astsrc); } else { rhs_len = string_expr_length(astsrc); } binopast = mk_binop(OP_NE, lhs_len, rhs_len, DT_LOG); ifexpr = mk_binop(OP_LOR, binopast, A_IFEXPRG(astif), DT_LOG); A_IFEXPRP(astif, ifexpr); } } } if (DTYG(dtypedest) == TY_DERIVED) { if (!XBIT(54, 0x4) && allocatable_member(sptrdest)) { handle_allocatable_members(astdest, astsrc, std, false); ast_to_comment(astasgn); } } if (shape != 0) { if (A_TYPEG(astdest) == A_MEM) { shape = mk_mem_ptr_shape(A_PARENTG(astdest), A_MEMG(astdest), dtypedest); assert(shape != 0, "shape must not be 0", 0, ERR_Fatal); } if (DTY(dtype) == TY_ARRAY && DTY(DTY(dtype + 1)) == TY_DERIVED) { int destasd, srcasd; /* * in the "else" of array of derived type conformability test * loop over array deallocating allocatable members */ int sptrmem; gen_allocated_check(astsrc, std, A_ELSEIF, false, false, false); gen_allocated_check(astdest, std, A_IFTHEN, false, true, false); /* deallocate/re-allocate array */ gen_dealloc_mbr(astdest, std); astif = mk_stmt(A_ENDIF, 0); /* endif allocated dest */ add_stmt_before(astif, std); gen_bounds_assignments(0, astdest, 0, astsrc, std); ast = build_allocation_item(0, astdest); gen_alloc_mbr(ast, std); /* loop over array re-allocating allocatable members and assigning * the src components to the newly alloc'd dest components */ destasd = gen_dos_over_shape(shape, std); srcasd = normalize_subscripts(destasd, shape, A_SHAPEG(astsrc)); astdestparent = subscript_allocmem(astdest, destasd); astsrcparent = subscript_allocmem(astsrc, srcasd); for (sptrmem = DTY(DDTG(dtype) + 1); sptrmem > NOSYM; sptrmem = SYMLKG(sptrmem)) { int astmem = mk_id(sptrmem); int astdestcmpnt = mk_member(astdestparent, astmem, A_DTYPEG(astmem)); int astsrccmpnt = mk_member(astsrcparent, astmem, A_DTYPEG(astmem)); if (is_tbp_or_final(sptrmem)) { /* skip tbp */ continue; } if (ALLOCATTRG(sptrmem)) { gen_allocated_check(astsrccmpnt, std, A_IFTHEN, false, false, false); gen_bounds_assignments(astdestparent, astmem, astsrcparent, astmem, std); if (DTY(A_DTYPEG(astmem)) == TY_CHAR || DTY(A_DTYPEG(astmem)) == TY_NCHAR) { if (!SDSCG(sptrdest)) { get_static_descriptor(sptrdest); } gen_automatic_reallocation(astdestcmpnt, astsrccmpnt, std); } else { ast = build_allocation_item(astdestparent, astmem); gen_alloc_mbr(ast, std); } if (DTYG(DTYPEG(sptrmem)) == TY_DERIVED && !XBIT(54, 0x4) && allocatable_member(sptrmem)) { handle_allocatable_members(astdestcmpnt, astsrccmpnt, std, true); } else { ast = mk_assn_stmt(astdestcmpnt, astsrccmpnt, A_DTYPEG(astmem)); add_stmt_before(ast, std); } astif = mk_stmt(A_ELSE, 0); add_stmt_before(astif, std); ast = mk_member(astdestparent, mk_id(MIDNUMG(sptrmem)), DTYPEG(MIDNUMG(sptrmem))); { int aa = begin_call(A_ICALL, intast_sym[I_NULLIFY], 1); A_OPTYPEP(aa, I_NULLIFY); add_arg(ast); ast = aa; } add_stmt_before(ast, std); astif = mk_stmt(A_ENDIF, 0); add_stmt_before(astif, std); } else if (POINTERG(sptrmem) && !F90POINTERG(sptrmem)) { astsrccmpnt = mk_member(astsrcparent, astmem, A_DTYPEG(astmem)); ast = add_ptr_assign(astdestcmpnt, astsrccmpnt, std); A_SHAPEP(ast, A_SHAPEG(astsrccmpnt)); add_stmt_before(ast, std); } else if (DTYG(DTYPEG(sptrmem)) == TY_DERIVED && !XBIT(54, 0x4) && allocatable_member(sptrmem)) { handle_allocatable_members(astdestcmpnt, astsrccmpnt, std, true); } else { astsrccmpnt = mk_member(astsrcparent, astmem, A_DTYPEG(astmem)); ast = mk_assn_stmt(astdestcmpnt, astsrccmpnt, A_DTYPEG(astmem)); add_stmt_before(ast, std); } if (ALLOCG(sptrmem) || (POINTERG(sptrmem) && !F90POINTERG(sptrmem))) { sptrmem = SDSCG(sptrmem); /* set-up to move past $p, $o, $sd */ } } gen_do_ends(ASD_NDIM(destasd), std); } else { /* in the "not conformable" path of conformability check for allocatable * array of intrinsic type, generate: * rewrite_deallocate(dest) * allocate(dest(lb(src): ub(src))) * endif */ int astmem; int astsrcmem; if (!non_conformable) { gen_dealloc_mbr(astdest, std); } if (A_TYPEG(astdest) == A_MEM) { astdestparent = A_PARENTG(astdest); astmem = A_MEMG(astdest); } else { astdestparent = 0; astmem = astdest; } if (A_TYPEG(astsrc) == A_MEM) { astsrcparent = A_PARENTG(astsrc); astsrcmem = A_MEMG(astsrc); } else { astsrcparent = 0; astsrcmem = astsrc; } gen_bounds_assignments(astdestparent, astmem, astsrcparent, astsrcmem, std); ast = build_allocation_item(astdestparent, astmem); gen_alloc_mbr(ast, std); } if (!non_conformable) { astif = mk_stmt(A_ENDIF, 0); add_stmt_before(astif, std); } } fin: if (sptrsrc != NOSYM && ALLOCATTRG(sptrsrc)) { /* Generate the ELSE part of "if (allocated(src))" to deallocate dest. * Ensure the lineno comes from std. */ int stdend = add_stmt_after(mk_stmt(A_ENDIF, 0), std); gen_allocated_check(astdest, stdend, A_ELSEIF, false, true, false); gen_dealloc_mbr(astdest, stdend); } } /* if (allocated(ast)) deallocate(ast) */ void gen_dealloc_if_allocated(int ast, int std) { int alloc_ast = mk_deallocate(ast); gen_allocated_check(ast, std, A_IFTHEN, false, true, false); add_stmt_before(alloc_ast, std); add_stmt_before(mk_stmt(A_ENDIF, 0), std); } static void find_allocatable_assignment(void) { int std; int stdnext; int workshare_depth; sem.sc = SC_LOCAL; workshare_depth = 0; for (std = STD_NEXT(0); std != 0; std = stdnext) { int ast; int match; ast = STD_AST(std); stdnext = STD_NEXT(std); switch (A_TYPEG(ast)) { case A_MP_PARALLEL: case A_MP_TASK: case A_MP_TASKLOOP: A_OPT1P(ast, sem.sc); sem.sc = SC_PRIVATE; break; case A_MP_ENDPARALLEL: case A_MP_ENDTASK: match = A_LOPG(ast); sem.sc = A_OPT1G(match); A_OPT1P(match, 0); break; case A_MP_WORKSHARE: workshare_depth++; break; case A_MP_ENDWORKSHARE: workshare_depth--; break; case A_ASN: if (!workshare_depth && (A_TYPEG(A_DESTG(ast)) != A_SUBSCR /* Per flyspray 15461, for user-defined type assignment: a[i] = b , A_TYPEG(A_DESTG(ast)) is a A_SUBSCR, also need to check for allocatable member if it is user-defined type. */ || DTYG(A_DTYPEG(A_DESTG(ast))) == TY_DERIVED)) { rewrite_allocatable_assignment(ast, std, false, false); } break; } } } /* Create new asd from subscripts in oldasd by normalizing from oldshape to newshape. */ static int normalize_subscripts(int oldasd, int oldshape, int newshape) { int i; int newsubs[MAXSUBS]; int ndim = SHD_NDIM(oldshape); assert(ndim == ASD_NDIM(oldasd), "ndim does not match", ndim, ERR_Fatal); for (i = 0; i < ndim; i++) { int oldsub = ASD_SUBS(oldasd, i); newsubs[i] = normalize_subscript( oldsub, SHD_LWB(oldshape, i), SHD_STRIDE(oldshape, i), SHD_LWB(newshape, i), SHD_STRIDE(newshape, i)); } return mk_asd(newsubs, ndim); } /* aref represents a reference to an allocatable component where its parent * has shape. asd represents subscripts to be applied. * Need to recurse through the parent to find the correct object * to which the subscripts are applied. After the subscripting has been * done, need to (re)apply the member and the subscript references which we * had recursed. */ static int subscript_allocmem(int aref, int asd) { int ndim = ASD_NDIM(asd); int subs[MAXSUBS]; switch (A_TYPEG(aref)) { case A_SUBSCR: { int asd2 = A_ASDG(aref); int n = ASD_NDIM(asd2); int ast, i, vector; for (i = 0, vector = 0; i < n; ++i) { int sub = ASD_SUBS(asd2, i); if (DTY(A_DTYPEG(sub)) == TY_ARRAY) { int tmp = ASD_SUBS(asd, vector); int subasd = mk_asd(&tmp, 1); if (A_TYPEG(sub) == A_SUBSCR) { sub = subscript_allocmem(sub, subasd); } else { sub = mk_subscr_copy(sub, subasd, DTY(A_DTYPEG(sub) + 1)); } vector++; } else if (A_TYPEG(sub) == A_TRIPLE) { sub = ASD_SUBS(asd, vector); vector++; } subs[i] = sub; } ast = A_LOPG(aref); if (vector == 0) { ast = subscript_allocmem(ast, asd); } return mk_subscr(ast, subs, n, A_DTYPEG(aref)); } case A_MEM: if (vector_member(aref)) { return mk_subscr_copy(aref, asd, DTY(A_DTYPEG(aref) + 1)); } else { int ast = subscript_allocmem(A_PARENTG(aref), asd); return mk_member(ast, A_MEMG(aref), A_DTYPEG(A_MEMG(aref))); } case A_ID: assert(DTY(A_DTYPEG(aref)) == TY_ARRAY, "subscript_allocmem: not array", 0, 4); return mk_subscr_copy(aref, asd, DTY(A_DTYPEG(aref) + 1)); default: interr("subscript_allocmem: bad ast type", A_TYPEG(aref), ERR_Fatal); return 0; } }