/* * Copyright (c) 2017, NVIDIA CORPORATION. All rights reserved. * * Licensed under the Apache License, Version 2.0 (the "License"); * you may not use this file except in compliance with the License. * You may obtain a copy of the License at * * http://www.apache.org/licenses/LICENSE-2.0 * * Unless required by applicable law or agreed to in writing, software * distributed under the License is distributed on an "AS IS" BASIS, * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. * See the License for the specific language governing permissions and * limitations under the License. * */ /** * \file * \brief - inliner utils definitions */ #include "gbldefs.h" #include "global.h" #include "error.h" #include "symtab.h" #include "symutl.h" #include "dtypeutl.h" #include "ast.h" #include "gramtk.h" #include "semant.h" #include "optimize.h" #include "interf.h" #include "inliner.h" #include "ccffinfo.h" #include "direct.h" /* Switches: * -q 49 1: Trace * -q 49 4: Dump flowgraph * -q 49 64: Dump STDs * -x 49 0x200000: Inhibit inlining */ /* Macros: */ #if DEBUG #define TRACE0(s) \ if (DBGBIT(49, 1)) \ fprintf(gbl.dbgfil, s) #define TRACE1(s, a1) \ if (DBGBIT(49, 1)) \ fprintf(gbl.dbgfil, s, a1) #define TRACE2(s, a1, a2) \ if (DBGBIT(49, 1)) \ fprintf(gbl.dbgfil, s, a1, a2) #define TRACE3(s, a1, a2, a3) \ if (DBGBIT(49, 1)) \ fprintf(gbl.dbgfil, s, a1, a2, a3) #else #define TRACE0(s) #define TRACE1(s, a1) #define TRACE2(s, a1, a2) #define TRACE3(s, a1, a2, a3) #endif /* inliner version number must be updated whenever ILMs or symbol table format, or inliner interface change: */ #define INLINER_VERSION 14 #define MAX_INLINE_NAME 42 #define MAX_FNAME_LEN 256 #define TOC_HEADER_FMT "Inliner TOC V.%d" #define TOC_ENTRY_FMT "%s %s %s %s" #define MODNAME_FMT "i%d.e" #define ERROR(s, v) \ { \ interr(s, v, 1); \ return; \ } #define MAX_LINE_LEN 400 #define PERM_AREA 8 #define STASH(p, area) strcpy(getitem(area, strlen(p) + 1), p); typedef struct fitem { /* function item */ char *sFunc; /* name of function */ struct fitem *pfiNext; /* pointer to next function item */ } FI; typedef struct libentry { /* info on one inliner library entry */ char *sFunc; /* user function name */ char *sHost; /* user host function name */ char *sMod; /* user containing module name */ char *sModFile; /* file containing encoded form */ struct libentry *pleNext; /* pointer to next library entry */ } LE; typedef struct argrep {/* argument replacement info */ int sptrDummy; /* dummy parameter */ int astAct; /* actual parameter */ } AR; #define AR_SPTRDUMMY(i) parbase[i].sptrDummy #define AR_ASTACT(i) parbase[i].astAct /* Local functions: */ static void inline_stds(int stdStart, int stdLast, int iLevels, int level); static int inline_ast(int std, int ast, int iLevels, int level); static LOGICAL inline_func(int std, int ast, int iLevels, int level, int *pEntry); static void modify_inlined_stds(int sptrEntry, int ast, int stdstart, int stdend); static int find_entry(int sptrCall); static int copy_inargs(int sptrEntry, int astCall, int stdStart, int stdEnd); static void remove_inlined_stds(); static void remove_inlined_symbols(int); static int promote_assumsz_arg(int sptrDummy, int astArg); static void allocate_adjarrs(int stdstart, int stdend); static void allocate_array(int sptr, int stdStart, int stdEnd); static void remove_returns(int stdstart, int stdend); static void move_labels(int stdstart, int stdlast); static void rewrite_inlined_args(int astCall, int sptrEntry, int stdstart, int stdend); static int replace_arg(int astDummy, int astAct); static void assign_bounds(int sptrDummy, int astAct, int std); static int get_subscr(int ast, unsigned int dim); static void load_TOC(char *sDir); static void store_funcname(char *sFunc); static LE *find_libentry(char *sMod, char *sHost, char *sFunc); static LOGICAL tkr_match_arg(int dtypDummy, int dtypAct); static LOGICAL aliased_args(int sptrEntry, int astCall); static LOGICAL make_arg_copy(int sptrEntry, int astCall, unsigned int arg); /* Local data: */ static char *sExtDir = NULL; /* extract directory name */ static FI *pfiStart = NULL; /* functions to be inlined */ static LE *pleStart = NULL; /* table of contents */ static int sptrHigh = 0; /* high-water mark of symbol table */ static int nLevels = 1; /* # levels of calls to inline */ static AR *parbase; /* parameter replacement table */ static int iarsize; /* allocated size of parbase */ static int iaravail; /* next available entry in parbase */ static int stdEnd; /* STD # of END statement */ /* * Record the extract directory or a program unit name to extract. */ void extractor_command_info(char *sDir, int nInsts, char *sFunc) { if (sDir) load_TOC(sDir); if (sFunc) store_funcname(sFunc); } /* * Return TRUE if the current function can be extracted. */ LOGICAL extractor_possible(void) { char *sCurrFunc; FI *pfi; int sptr, std; int dtyp; /* Search for a named program unit. */ if (pfiStart) { sCurrFunc = SYMNAME(gbl.currsub); for (pfi = pfiStart; pfi; pfi = pfi->pfiNext) if (!strcmp(pfi->sFunc, sCurrFunc)) break; if (!pfi) { TRACE1("can't extract: program unit %s not named\n", sCurrFunc); return FALSE; } } if (gbl.rutype != RU_SUBR && gbl.rutype != RU_FUNC) { TRACE0("can't extract: program unit not subroutine or function\n"); return FALSE; } if (SYMLKG(gbl.entries) != NOSYM) { TRACE0("can't extract: multiple entry points\n"); ccff_info(MSGNEGINLINER, "INL024", gbl.findex, gbl.funcline, "%module%separator%function is not HL inlineable: multiple entry " "points", "module=%s", gbl.currmod ? SYMNAME(gbl.currmod) : "", "separator=%s", gbl.currmod ? "::" : "", "function=%s", SYMNAME(gbl.currsub), NULL); return FALSE; } if (gbl.arets) { TRACE0("can't extract: multiple returns\n"); ccff_info( MSGNEGINLINER, "INL025", gbl.findex, gbl.funcline, "%module%separator%function is not HL inlineable: alternate returns", "module=%s", gbl.currmod ? SYMNAME(gbl.currmod) : "", "separator=%s", gbl.currmod ? "::" : "", "function=%s", SYMNAME(gbl.currsub), NULL); return FALSE; } for (sptr = stb.firstusym; sptr < stb.stg_avail; sptr++) { if (ST_ISVAR(STYPEG(sptr)) && SCOPEG(sptr) != stb.curr_scope) continue; if (STYPEG(sptr) == ST_NML) { TRACE0("can't extract: namelist present\n"); ccff_info(MSGNEGINLINER, "INL026", gbl.findex, gbl.funcline, "%module%separator%function is not HL inlineable: namelist " "statements", "module=%s", gbl.currmod ? SYMNAME(gbl.currmod) : "", "separator=%s", gbl.currmod ? "::" : "", "function=%s", SYMNAME(gbl.currsub), NULL); return FALSE; } if (STYPEG(sptr) == ST_LABEL && FMTPTG(sptr)) { TRACE0("can't extract: format list present\n"); ccff_info( MSGNEGINLINER, "INL027", gbl.findex, gbl.funcline, "%module%separator%function is not HL inlineable: format statements", "module=%s", gbl.currmod ? SYMNAME(gbl.currmod) : "", "separator=%s", gbl.currmod ? "::" : "", "function=%s", SYMNAME(gbl.currsub), NULL); return FALSE; } if (ST_ISVAR(STYPEG(sptr)) && SCG(sptr) == SC_STATIC && SAVEG(sptr)) { TRACE0("can't extract: SAVEd local present\n"); ccff_info(MSGNEGINLINER, "INL028", gbl.findex, gbl.funcline, "%module%separator%function is not HL inlineable: SAVEd local " "variables", "module=%s", gbl.currmod ? SYMNAME(gbl.currmod) : "", "separator=%s", gbl.currmod ? "::" : "", "function=%s", SYMNAME(gbl.currsub), NULL); return FALSE; } if (ST_ISVAR(STYPEG(sptr)) && DINITG(sptr)) { TRACE0("can't extract: data initialization present\n"); ccff_info(MSGNEGINLINER, "INL029", gbl.findex, gbl.funcline, "%module%separator%function is not HL inlineable: DATA " "initialization", "module=%s", gbl.currmod ? SYMNAME(gbl.currmod) : "", "separator=%s", gbl.currmod ? "::" : "", "function=%s", SYMNAME(gbl.currsub), NULL); return FALSE; } if (ST_ISVAR(STYPEG(sptr)) && SCG(sptr) == SC_DUMMY && !IGNOREG(sptr)) { dtyp = DTYPEG(sptr); if (DTY(dtyp) == TY_CHAR || DTY(dtyp) == TY_NCHAR) if (dtyp == DT_ASSCHAR || dtyp == DT_ASSNCHAR || dtyp == DT_DEFERCHAR || dtyp == DT_DEFERNCHAR) { TRACE0("can't extract: assumed/deferred length dummy present\n"); ccff_info(MSGNEGINLINER, "INL030", gbl.findex, gbl.funcline, "%module%separator%function is not HL inlineable: " "assumed-length character dummy", "module=%s", gbl.currmod ? SYMNAME(gbl.currmod) : "", "separator=%s", gbl.currmod ? "::" : "", "function=%s", SYMNAME(gbl.currsub), NULL); return FALSE; } } } if (!XBIT(13, 0x200) && !INMODULEG(gbl.currsub)) { /* only extract module subprograms */ return FALSE; } for (std = STD_NEXT(0); std; std = STD_NEXT(std)) { /* whether to allow loops or conditionals */ switch (A_TYPEG(STD_AST(std))) { case A_DO: if (!XBIT(13, 0x100)) { ccff_info(MSGNEGINLINER, "INL031", gbl.findex, gbl.funcline, "%module%separator%function is not HL inlineable: DO " "statements disallowed", "module=%s", gbl.currmod ? SYMNAME(gbl.currmod) : "", "separator=%s", gbl.currmod ? "::" : "", "function=%s", SYMNAME(gbl.currsub), NULL); return FALSE; } break; case A_DOWHILE: ccff_info(MSGNEGINLINER, "INL032", gbl.findex, gbl.funcline, "%module%separator%function is not HL inlineable: DOWHILE " "statements disallowed", "module=%s", gbl.currmod ? SYMNAME(gbl.currmod) : "", "separator=%s", gbl.currmod ? "::" : "", "function=%s", SYMNAME(gbl.currsub), NULL); return FALSE; case A_IF: case A_IFTHEN: if (!XBIT(13, 0x80)) { ccff_info(MSGNEGINLINER, "INL033", gbl.findex, gbl.funcline, "%module%separator%function is not HL inlineable: IF " "statements disallowed", "module=%s", gbl.currmod ? SYMNAME(gbl.currmod) : "", "separator=%s", gbl.currmod ? "::" : "", "function=%s", SYMNAME(gbl.currsub), NULL); return FALSE; } break; case A_AIF: ccff_info(MSGNEGINLINER, "INL034", gbl.findex, gbl.funcline, "%module%separator%function is not HL inlineable: arithmetic " "IF statements disallowed", "module=%s", gbl.currmod ? SYMNAME(gbl.currmod) : "", "separator=%s", gbl.currmod ? "::" : "", "function=%s", SYMNAME(gbl.currsub), NULL); return FALSE; case A_GOTO: ccff_info(MSGNEGINLINER, "INL035", gbl.findex, gbl.funcline, "%module%separator%function is not HL inlineable: GOTO " "statements disallowed", "module=%s", gbl.currmod ? SYMNAME(gbl.currmod) : "", "separator=%s", gbl.currmod ? "::" : "", "function=%s", SYMNAME(gbl.currsub), NULL); return FALSE; case A_CGOTO: ccff_info(MSGNEGINLINER, "INL036", gbl.findex, gbl.funcline, "%module%separator%function is not HL inlineable: computed " "GOTO statements disallowed", "module=%s", gbl.currmod ? SYMNAME(gbl.currmod) : "", "separator=%s", gbl.currmod ? "::" : "", "function=%s", SYMNAME(gbl.currsub), NULL); return FALSE; case A_AGOTO: ccff_info(MSGNEGINLINER, "INL037", gbl.findex, gbl.funcline, "%module%separator%function is not HL inlineable: assigned " "GOTO statements disallowed", "module=%s", gbl.currmod ? SYMNAME(gbl.currmod) : "", "separator=%s", gbl.currmod ? "::" : "", "function=%s", SYMNAME(gbl.currsub), NULL); return FALSE; case A_ASNGOTO: ccff_info(MSGNEGINLINER, "INL038", gbl.findex, gbl.funcline, "%module%separator%function is not HL inlineable: ASSIGN " "statements disallowed", "module=%s", gbl.currmod ? SYMNAME(gbl.currmod) : "", "separator=%s", gbl.currmod ? "::" : "", "function=%s", SYMNAME(gbl.currsub), NULL); return FALSE; case A_STOP: ccff_info(MSGNEGINLINER, "INL039", gbl.findex, gbl.funcline, "%module%separator%function is not HL inlineable: STOP " "statements disallowed", "module=%s", gbl.currmod ? SYMNAME(gbl.currmod) : "", "separator=%s", gbl.currmod ? "::" : "", "function=%s", SYMNAME(gbl.currsub), NULL); return FALSE; case A_PAUSE: ccff_info(MSGNEGINLINER, "INL040", gbl.findex, gbl.funcline, "%module%separator%function is not HL inlineable: PAUSE " "statements disallowed", "module=%s", gbl.currmod ? SYMNAME(gbl.currmod) : "", "separator=%s", gbl.currmod ? "::" : "", "function=%s", SYMNAME(gbl.currsub), NULL); return FALSE; case A_MP_PARALLEL: ccff_info(MSGNEGINLINER, "INL041", gbl.findex, gbl.funcline, "%module%separator%function is not HL inlineable: OpenMP " "parallel section disallowed", "module=%s", gbl.currmod ? SYMNAME(gbl.currmod) : "", "separator=%s", gbl.currmod ? "::" : "", "function=%s", SYMNAME(gbl.currsub), NULL); return FALSE; } } return TRUE; } /* extractor_possible */ /* * Extract the current subroutine. */ void extractor(void) { FILE *fd; char *sCurrFunc, *sCurrHost, *sCurrMod; int iFile, nFile; LE *ple; int iStat; char sExtFile[MAX_FNAME_LEN]; TRACE0("----------\n"); TRACE0("Extractor:\n"); if (!sExtDir) { errsev(270); return; } if (!extractor_possible()) return; sCurrFunc = SYMNAME(gbl.currsub); if (gbl.internal <= 1 || gbl.outersub == 0) { sCurrHost = "."; } else { sCurrHost = SYMNAME(gbl.outersub); } if (gbl.currmod == 0) { sCurrMod = "."; } else { sCurrMod = SYMNAME(gbl.currmod); } /* Get the highest extract file #. */ nFile = 0; for (ple = pleStart; ple; ple = ple->pleNext) { iStat = sscanf(ple->sModFile, MODNAME_FMT, &iFile); if (iStat != 1) return; if (iFile > nFile) nFile = iFile; } /* Search for an existing library entry. */ ple = find_libentry(sCurrMod, sCurrHost, sCurrFunc); if (!ple) { /* Create a new library entry. */ ple = (LE *)getitem(PERM_AREA, sizeof(LE)); if (!ple) ERROR("extractor: can't allocate memory", 3); ple->sFunc = STASH(sCurrFunc, PERM_AREA); ple->sHost = STASH(sCurrHost, PERM_AREA); ple->sMod = STASH(sCurrMod, PERM_AREA); sprintf(sExtFile, MODNAME_FMT, nFile + 1); ple->sModFile = STASH(sExtFile, PERM_AREA); ple->pleNext = pleStart; pleStart = ple; } sprintf(sExtFile, "%s/%s", sExtDir, ple->sModFile); fd = fopen(sExtFile, "w"); if (!fd) { error(275, 2, gbl.lineno, sExtFile, NULL); return; } export_inline(fd, sCurrFunc, sExtFile); } void extractor_end(void) { int iStat; FILE *fd; char sTOCFile[MAX_FNAME_LEN]; LE *ple; if (!sExtDir) return; /* Create the TOC file. */ fndpath("TOC", sTOCFile, MAX_FNAME_LEN, sExtDir); fd = fopen(sTOCFile, "w"); if (!fd) { error(274, 2, gbl.lineno, sExtDir, NULL); return; } /* Write the header. */ fprintf(fd, TOC_HEADER_FMT, INLINER_VERSION); fprintf(fd, "\n"); /* Write out the library entries. */ for (ple = pleStart; ple; ple = ple->pleNext) { fprintf(fd, TOC_ENTRY_FMT, ple->sMod, ple->sHost, ple->sFunc, ple->sModFile); fprintf(fd, "\n"); } fclose(fd); freearea(PERM_AREA); } void inline_add_lib(char *sDir) { load_TOC(sDir); } void inline_add_func(char *sFunc, int n) { if (sFunc) store_funcname(sFunc); else nLevels = n; } static int ninlined = 0; static int nskip = 0; /* * inline into this subprogram */ void inliner(void) { int lpi; if (flg.x[115]) nLevels = flg.x[115]; if (!sExtDir) return; ninlined = 0; nskip = 0; if (XBIT(49, 0x200000)) return; inline_stds(STD_NEXT(0), STD_PREV(0), nLevels, 1); #if DEBUG if (DBGBIT(49, 64)) { fprintf(gbl.dbgfil, "----------- STDs after inlining\n"); dump_std(); } #endif } /* * Perform inlining on all STDs between stdStart & stdLast repeating * recursively for iLevels. */ static void inline_stds(int stdStart, int stdLast, int iLevels, int level) { int std, stdNext; int ast, astNew; if (!iLevels) return; if (stdLast) stdLast = STD_NEXT(stdLast); for (std = stdStart; std != stdLast; std = stdNext) { stdNext = STD_NEXT(std); if (STD_LINENO(std)) gbl.lineno = STD_LINENO(std); ast = STD_AST(std); astNew = inline_ast(std, ast, iLevels, level); if (astNew == ast) continue; if (!astNew) { delete_stmt(std); continue; } STD_AST(std) = astNew; A_STDP(astNew, std); } } /* * Inline any function calls within ast, and repeat on the inlined statements * iLevels times. Add inlined statements prior to * std. Replace any inlined call with a new temp. After replacement, return * the new AST. Return 0 if std will be deleted after inlining. */ static int inline_ast(int std, int ast, int iLevels, int level) { int astNewl, astNewr, astNew, vastSubs[7], astNewu, astNews, astNewc; int asd, sptrEntry; int nsubs, sub; int sptrRet; int shd; INT argt, argtNew; int arg, nargs; LOGICAL bChanged; if (ast == 0) return 0; /* Explicit recursion is used here instead of a call to ast_traverse() * because ast_traverse() is called by rewrite_inlined_args() to replace * dummy parameters with actual. */ switch (A_TYPEG(ast)) { case A_NULL: case A_ID: case A_CNST: case A_LABEL: case A_CMPLXC: case A_MEM: return ast; case A_BINOP: astNewl = inline_ast(std, A_LOPG(ast), iLevels, level); astNewr = inline_ast(std, A_ROPG(ast), iLevels, level); if (astNewl == A_LOPG(ast) && astNewr == A_ROPG(ast)) return ast; astNew = mk_binop(A_OPTYPEG(ast), astNewl, astNewr, A_DTYPEG(ast)); return astNew; case A_UNOP: astNewl = inline_ast(std, A_LOPG(ast), iLevels, level); if (astNewl == A_LOPG(ast)) return ast; astNew = mk_unop(A_OPTYPEG(ast), astNewl, A_DTYPEG(ast)); return astNew; case A_CONV: astNewl = inline_ast(std, A_LOPG(ast), iLevels, level); if (astNewl == A_LOPG(ast)) return ast; astNew = mk_convert(astNewl, A_DTYPEG(ast)); return astNew; case A_PAREN: astNewl = inline_ast(std, A_LOPG(ast), iLevels, level); if (astNewl == A_LOPG(ast)) return ast; astNew = mk_paren(astNewl, A_DTYPEG(ast)); return astNew; case A_SUBSCR: asd = A_ASDG(ast); nsubs = ASD_NDIM(asd); bChanged = FALSE; for (sub = 0; sub < nsubs; sub++) { vastSubs[sub] = inline_ast(std, ASD_SUBS(asd, sub), iLevels, level); bChanged |= (vastSubs[sub] != ASD_SUBS(asd, sub)); } if (!bChanged) return ast; astNew = mk_subscr(A_LOPG(ast), vastSubs, nsubs, A_DTYPEG(ast)); return astNew; case A_SUBSTR: astNewl = inline_ast(std, A_LEFTG(ast), iLevels, level); astNewr = inline_ast(std, A_RIGHTG(ast), iLevels, level); if (astNewl == A_LEFTG(ast) && astNewr == A_RIGHTG(ast)) return ast; astNew = mk_substr(A_LOPG(ast), astNewl, astNewr, A_DTYPEG(ast)); return astNew; case A_TRIPLE: astNewl = inline_ast(std, A_LBDG(ast), iLevels, level); astNewu = inline_ast(std, A_UPBDG(ast), iLevels, level); astNews = inline_ast(std, A_STRIDEG(ast), iLevels, level); if (astNewl == A_LBDG(ast) && astNewu == A_UPBDG(ast) && astNews == A_STRIDEG(ast)) return ast; astNew = mk_triple(astNewl, astNewu, astNews); return astNew; case A_FUNC: case A_INTR: case A_CALL: case A_ICALL: argt = A_ARGSG(ast); nargs = A_ARGCNTG(ast); argtNew = mk_argt(nargs); bChanged = FALSE; for (arg = 0; arg < nargs; arg++) { ARGT_ARG(argtNew, arg) = inline_ast(std, ARGT_ARG(argt, arg), iLevels, level); if (ARGT_ARG(argtNew, arg) != ARGT_ARG(argt, arg)) bChanged = TRUE; } if (bChanged == FALSE) { unmk_argt(nargs); astNew = ast; } else { astNew = mk_func_node(A_TYPEG(ast), A_LOPG(ast), nargs, argtNew); A_SHAPEP(astNew, A_SHAPEG(ast)); A_DTYPEP(astNew, A_DTYPEG(ast)); if (A_TYPEG(ast) == A_INTR || A_TYPEG(ast) == A_ICALL) { A_OPTYPEP(astNew, A_OPTYPEG(ast)); } } if (A_TYPEG(ast) == A_INTR || A_TYPEG(ast) == A_ICALL) { return astNew; } #if DEBUG if (flg.x[17] != 0 && ninlined >= flg.x[17]) return astNew; #endif if (A_TYPEG(ast) == A_CALL) { bChanged = inline_func(std, astNew, iLevels, level, &sptrEntry); if (bChanged) return 0; else return astNew; } bChanged = inline_func(std, astNew, iLevels, level, &sptrEntry); if (!bChanged) return astNew; sptrRet = FVALG(sptrEntry); assert(sptrRet, "inline_ast: function value not found", std, 4); SCP(sptrRet, SC_LOCAL); /* ensures declaration's generation */ astNew = mk_id(sptrRet); return astNew; case A_ASN: astNewr = inline_ast(std, A_SRCG(ast), iLevels, level); astNewl = inline_ast(std, A_DESTG(ast), iLevels, level); if (astNewr == A_SRCG(ast) && astNewl == A_DESTG(ast)) return ast; astNew = mk_assn_stmt(astNewl, astNewr, A_DTYPEG(ast)); return astNew; case A_IF: case A_IFTHEN: astNewl = inline_ast(std, A_IFEXPRG(ast), iLevels, level); if (astNewl == A_IFEXPRG(ast)) return ast; astNew = mk_stmt(A_TYPEG(ast), 0); A_IFEXPRP(astNew, astNewl); A_IFSTMTP(astNew, A_IFSTMTG(ast)); return astNew; case A_DO: astNewl = inline_ast(std, A_M1G(ast), iLevels, level); astNewr = inline_ast(std, A_M2G(ast), iLevels, level); astNews = inline_ast(std, A_M3G(ast), iLevels, level); astNewc = inline_ast(std, A_M4G(ast), iLevels, level); if (astNewl == A_M1G(ast) && astNewr == A_M2G(ast) && astNews == A_M3G(ast) && astNewc == A_M4G(ast)) return ast; astNew = mk_stmt(A_TYPEG(ast), 0); A_DOLABP(astNew, A_DOLABG(ast)); A_DOVARP(astNew, A_DOVARG(ast)); A_M1P(astNew, astNewl); A_M2P(astNew, astNewr); A_M3P(astNew, astNews); A_M4P(astNew, astNewc); return astNew; default: return ast; } } /* * if we inline foo into bar, and foo calls ugh, and bar has another * symbol for ugh, reuse bar's symbol for ugh instead */ static int use_old_subprogram_limits[2] = {0, 0}; static void use_old_subprograms(int oldsymavl) { int sptr, tptr; use_old_subprogram_limits[0] = oldsymavl; use_old_subprogram_limits[1] = stb.stg_avail - 1; for (sptr = oldsymavl; sptr < stb.stg_avail; ++sptr) { switch (STYPEG(sptr)) { case ST_PROC: /* see if there is an identical function in the caller */ for (tptr = HASHLKG(sptr); tptr > NOSYM; tptr = HASHLKG(tptr)) { if (NMPTRG(tptr) != NMPTRG(sptr)) continue; if (STYPEG(tptr) != ST_PROC) continue; if (tptr >= sptrHigh) continue; if (INMODULEG(tptr) != INMODULEG(sptr)) continue; if (INMODULEG(tptr)) { if (NMPTRG(ENCLFUNCG(tptr)) != NMPTRG(ENCLFUNCG(sptr))) continue; if (SCOPEG(sptr) && STYPEG(SCOPEG(sptr)) == ST_ALIAS && SCOPEG(SCOPEG(sptr)) && STYPEG(SCOPEG(SCOPEG(sptr))) == ST_MODULE) { if (!SCOPEG(tptr) || STYPEG(SCOPEG(tptr)) != ST_ALIAS || !SCOPEG(SCOPEG(sptr)) || STYPEG(SCOPEG(SCOPEG(sptr))) != ST_MODULE) { continue; } if (NMPTRG(SCOPEG(SCOPEG(tptr))) != NMPTRG(SCOPEG(SCOPEG(sptr)))) continue; } } if (HCCSYMG(tptr)) continue; /* tptr and sptr are two functions with the same name */ FUNCLINEP(sptr, tptr); IGNOREP(sptr, 1); DPDSCP(sptr, 0); /* don't generate interface block */ break; } break; default:; } } } /* use_old_subprograms */ static void erase_entry(int oldsymavl) { int sptr, tptr; for (sptr = oldsymavl; sptr < stb.stg_avail; ++sptr) { switch (STYPEG(sptr)) { case ST_ENTRY: STYPEP(sptr, ST_PROC); IGNOREP(sptr, 1); break; default:; } } } /* erase_entry */ extern void remove_alias(int std, int ast); /* * temp workaround: return TRUE if there is an optional argument * to the subprogram, and the actual argument is missing. */ static LOGICAL missing_optionals(int sptrEntry, int astCall) { int argt, nargs, arg, astArg; int dpdsc, sptrDummy; argt = A_ARGSG(astCall); nargs = A_ARGCNTG(astCall); dpdsc = DPDSCG(sptrEntry); if (!dpdsc) return FALSE; for (arg = 0; arg < nargs; ++arg) { sptrDummy = aux.dpdsc_base[dpdsc + arg]; astArg = ARGT_ARG(argt, arg); if (sptrDummy && OPTARGG(sptrDummy) && astArg == astb.ptr0) { return TRUE; } } return FALSE; } /* missing_optionals */ /* * If CALL/FUNC ast residing in std has been extracted, inline the called * program unit, and continue inlining iLevels times. * Return TRUE if inlining performed. */ static LOGICAL inline_func(int std, int ast, int iLevels, int level, int *psptrEntry) { int sptrCall, sptrEntry; int sptrMod, sptrHost; char *sFunc, *sMod, *sHost; char *currMod; FI *pfi; LE *ple; char sExtFile[MAX_FNAME_LEN]; FILE *fd; int stdstart, stdfinal, sptrHighCopy; #if DEBUG if (flg.x[22] && gbl.func_count != flg.x[22]) return FALSE; #endif assert(A_TYPEG(ast) == A_FUNC || A_TYPEG(ast) == A_CALL, "inline_func: bad type", ast, 4); assert(A_TYPEG(A_LOPG(ast)) == A_ID, "inline_func: bad call type", ast, 4); remove_alias(std, ast); sptrCall = A_SPTRG(A_LOPG(ast)); sFunc = SYMNAME(sptrCall); if (!INTERNALG(sptrCall)) { sptrHost = sptrCall; sHost = "."; } else { sptrHost = SCOPEG(sptrCall); sHost = SYMNAME(sptrHost); } /* see if this is a module subprogram */ currMod = NULL; sMod = "."; if (INMODULEG(sptrHost)) { for (sptrMod = sptrHost; sptrMod > NOSYM; sptrMod = SCOPEG(sptrMod)) { if (STYPEG(sptrMod) == ST_MODULE) { sMod = SYMNAME(sptrMod); currMod = sMod; break; } if (SCOPEG(sptrMod) == sptrMod) { break; } } } if (pfiStart) { /* Determine if sptrCall is a function specified for inlining. */ for (pfi = pfiStart; pfi; pfi = pfi->pfiNext) if (!strcmp(pfi->sFunc, sFunc)) break; if (!pfi) return FALSE; } ple = find_libentry(sMod, sHost, sFunc); if (!ple) { return FALSE; } if (!XBIT(13, 0x400) && missing_optionals(sptrCall, ast)) { ccff_info( MSGNEGINLINER, "INL044", gbl.findex, gbl.funcline, "%module%separator%function not inlined: missing OPTIONAL arguments", "module=%s", currMod ? SYMNAME(sptrMod) : "", "separator=%s", currMod ? "::" : "", "function=%s", SYMNAME(sptrCall), NULL); return FALSE; } sprintf(sExtFile, "%s/%s", sExtDir, ple->sModFile); fd = fopen(sExtFile, "r"); if (!fd) error(275, 4, gbl.lineno, sExtFile, NULL); stdEnd = STD_PREV(0); sptrHighCopy = sptrHigh = stb.stg_avail; if (import_inline(fd, sExtFile)) { ccff_info( MSGNEGINLINER, "INL045", gbl.findex, gbl.funcline, "%module%separator%function not inlined: conflicting declarations", "module=%s", currMod ? SYMNAME(sptrMod) : "", "separator=%s", currMod ? "::" : "", "function=%s", SYMNAME(sptrCall), NULL); return FALSE; } sptrEntry = find_entry(A_SPTRG(A_LOPG(ast))); if (STD_PREV(0) == stdEnd) { ccff_info(MSGNEGINLINER, "INL047", gbl.findex, gbl.funcline, "%module%separator%function not inlined: empty subprogram", "module=%s", currMod ? SYMNAME(sptrMod) : "", "separator=%s", currMod ? "::" : "", "function=%s", SYMNAME(sptrCall), NULL); remove_inlined_symbols(sptrHigh); return FALSE; } if (aliased_args(sptrEntry, ast)) { ccff_info(MSGNEGINLINER, "INL048", gbl.findex, gbl.funcline, "%module%separator%function not inlined: argument aliasing", "module=%s", currMod ? SYMNAME(sptrMod) : "", "separator=%s", currMod ? "::" : "", "function=%s", SYMNAME(sptrCall), NULL); remove_inlined_stds(); remove_inlined_symbols(sptrHigh); return FALSE; } use_old_subprograms(sptrHigh); modify_inlined_stds(sptrEntry, ast, STD_NEXT(stdEnd), STD_PREV(0)); if (STD_PREV(0) == stdEnd) { ccff_info(MSGNEGINLINER, "INL049", gbl.findex, gbl.funcline, "%module%separator%function not inlined: no statements", "module=%s", currMod ? SYMNAME(sptrMod) : "", "separator=%s", currMod ? "::" : "", "function=%s", SYMNAME(sptrCall), NULL); remove_inlined_symbols(sptrHigh); return FALSE; } #if DEBUG if (flg.x[18] != 0 && nskip < flg.x[18]) { ++nskip; ccff_info(MSGNEGINLINER, "INL050", gbl.findex, gbl.funcline, "%module%separator%function not inlined: skipped", "module=%s", currMod ? SYMNAME(sptrMod) : "", "separator=%s", currMod ? "::" : "", "function=%s", SYMNAME(sptrCall), NULL); remove_inlined_stds(); remove_inlined_symbols(sptrHigh); return FALSE; } #endif /* Insert the inlined STDs before std. */ stdstart = STD_NEXT(stdEnd); stdfinal = STD_PREV(0); if (XBIT(49, 0x4000)) { /* line-level profiling */ int std; for (std = stdstart; std; std = STD_NEXT(std)) { STD_LINENO(std) = 0; if (std == stdfinal) break; } } STD_NEXT(stdEnd) = 0; STD_PREV(0) = stdEnd; STD_PREV(stdstart) = STD_PREV(std); STD_NEXT(STD_PREV(std)) = stdstart; STD_NEXT(stdfinal) = std; STD_PREV(std) = stdfinal; /* change inlined ST_ENTRY */ erase_entry(sptrHigh); if (XBIT(0, 8)) { ccff_info( MSGNEGINLINER, "INL051", gbl.findex, gbl.funcline, "%module%separator%function inlined", "module=%s", sptrHost == sptrCall && INMODULEG(sptrHost) ? SYMNAME(sptrMod) : "", "separator=%s", sptrHost == sptrCall && INMODULEG(sptrHost) ? "::" : "", "function=%s", SYMNAME(sptrCall), NULL); } ++ninlined; inline_stds(stdstart, stdfinal, iLevels - 1, level + 1); if (psptrEntry) *psptrEntry = sptrEntry; return TRUE; } /* * Modify inlined STDs between stdstart & stdlast for call AST ast. * Remove the END and RETURN statements. * Move labels on branching statements to CONTINUE statements. * If an argument is INTENT IN, or the actual argument is not an * identifier or subscript, copy the actual to the dummy parameter * at the beginning of the inlined code. * If an argument is INTENT INOUT/OUT and the actual argument is an identifer * or subscript, replace all occurrences of the dummy parameter with the * actual. */ static void modify_inlined_stds(int sptrEntry, int ast, int stdstart, int stdlast) { switch (A_TYPEG(ast)) { case A_CALL: case A_FUNC: break; default: interr("modify_inlined_stds: unrecognized CALL", stdstart, 4); } /* Copy expressions and arguments with INTENT IN to dummy parameters. */ ast = copy_inargs(sptrEntry, ast, stdstart, stdlast); /* Remove RETURN & END statements. */ remove_returns(stdstart, stdlast); /* Move labels on branching constructs. */ move_labels(stdstart, stdlast); /* Replace dummy parameters with INTENT OUT or INOUT with identifier * arguments. */ rewrite_inlined_args(ast, sptrEntry, stdstart, stdlast); /* Allocate adjustable arrays. */ allocate_adjarrs(stdstart, stdlast); } /* * Return the symbol table pointer to the first ENTRY description associated * with the program unit whose symbol table pointer is sptrCall. The search * begins after sptrHigh. */ static int find_entry(int sptrCall) { int sptr; int nmptr = NMPTRG(sptrCall); for (sptr = sptrHigh; sptr < stb.stg_avail; sptr++) if (STYPEG(sptr) == ST_ENTRY && NMPTRG(sptr) == nmptr) break; assert(sptr < stb.stg_avail, "find_entry: ENTRY symtab record not found", 0, 4); return sptr; } /* * Copy arguments within astCall that have INTENT IN, or are expressions, * to new variables, which are allocated * prior to stdstart, and deallocated after stdlast. Replace the original * variables within call/func astCall with the new variables, and return * the new call AST. */ static int copy_inargs(int sptrEntry, int astCall, int stdstart, int stdlast) { int dscend = DPDSCG(sptrEntry) + PARAMCTG(sptrEntry); int dsc; int sptrCall, sptrDummy, sptrCopy, sptrBnd; int nargs, arg; int argtNew; int astArg, astCopy, ast, astl, astu, asts, vastSubs[7], astBnd, astAlloc; int shd; int dtyp; int ndims, dim; ADSC *adCopy; assert(A_TYPEG(astCall) == A_CALL || A_TYPEG(astCall) == A_FUNC, "copy_inargs: call not found", astCall, 4); sptrCall = A_SPTRG(A_LOPG(astCall)); if (PARAMCTG(sptrEntry) != A_ARGCNTG(astCall)) { error(271, 2, gbl.lineno, SYMNAME(sptrCall), NULL); remove_inlined_stds(); return astCall; } /* Find an argument that needs to be copied. */ nargs = A_ARGCNTG(astCall); for (arg = 0; arg < nargs; arg++) if (make_arg_copy(sptrEntry, astCall, arg)) break; if (arg == nargs) return astCall; /* No copies needed. */ argtNew = mk_argt(nargs); /* Create a new argument descriptor. */ arg = 0; for (dsc = DPDSCG(sptrEntry); dsc < dscend; dsc++, arg++) { astArg = ARGT_ARG(A_ARGSG(astCall), arg); ARGT_ARG(argtNew, arg) = astArg; if (!make_arg_copy(sptrEntry, astCall, arg)) continue; sptrDummy = aux.dpdsc_base[dsc]; if (A_TYPEG(astArg) == A_SUBSCR && !A_SHAPEG(astArg) && DTY(DTYPEG(sptrDummy)) == TY_ARRAY) astArg = promote_assumsz_arg(sptrDummy, astArg); shd = A_SHAPEG(astArg); if (shd) { dtyp = DDTG(A_DTYPEG(astArg)); ndims = SHD_NDIM(shd); sptrCopy = sym_get_array(SYMNAME(sptrDummy), "inl", dtyp, ndims); adCopy = AD_DPTR(DTYPEG(sptrCopy)); for (dim = 0; dim < ndims; dim++) { /* Assign 1 to a new lower bound temp. */ sptrBnd = sym_get_scalar("l", "inl", DT_INT); astl = mk_id(sptrBnd); ast = mk_assn_stmt(astl, astb.i1, DT_INT); add_stmt_before(ast, stdstart); AD_LWBD(adCopy, dim) = AD_LWAST(adCopy, dim) = astl; /* Compute the size of dimension dim. */ ast = mk_binop(OP_SUB, SHD_UPB(shd, dim), SHD_LWB(shd, dim), DT_INT); asts = SHD_STRIDE(shd, dim); if (!asts) asts = astb.i1; ast = mk_binop(OP_ADD, asts, ast, DT_INT); if (asts != astb.i1) ast = mk_binop(OP_DIV, ast, asts, DT_INT); /* Assign the computed size to a new upper bound temp. */ sptrBnd = sym_get_scalar("u", "inl", DT_INT); astu = mk_id(sptrBnd); ast = mk_assn_stmt(astu, ast, DT_INT); add_stmt_before(ast, stdstart); AD_UPBD(adCopy, dim) = AD_UPAST(adCopy, dim) = astu; vastSubs[dim] = mk_triple(astl, astu, 0); } /* Create ALLOCATE & DEALLOCATE statements for the new array. */ astCopy = mk_id(sptrCopy); ast = mk_subscr(astCopy, vastSubs, ndims, DTYPEG(sptrCopy)); astAlloc = mk_stmt(A_ALLOC, 0); A_TKNP(astAlloc, TK_ALLOCATE); A_LOPP(astAlloc, 0); A_SRCP(astAlloc, ast); add_stmt_before(astAlloc, stdstart); astAlloc = mk_stmt(A_ALLOC, 0); A_TKNP(astAlloc, TK_DEALLOCATE); A_LOPP(astAlloc, 0); A_SRCP(astAlloc, astCopy); add_stmt_after(astAlloc, stdlast); } else { sptrCopy = sym_get_scalar(SYMNAME(sptrDummy), "inl", A_DTYPEG(astArg)); astCopy = mk_id(sptrCopy); } /* Create a statement for copying the actual argument to the temp. */ ast = mk_assn_stmt(astCopy, astArg, A_DTYPEG(astArg)); add_stmt_before(ast, stdstart); ARGT_ARG(argtNew, arg) = astCopy; } /* Create a new CALL/FUNC AST. */ ast = mk_func_node(A_TYPEG(astCall), A_LOPG(astCall), nargs, argtNew); A_SHAPEP(ast, A_SHAPEG(astCall)); A_DTYPEP(ast, A_DTYPEG(astCall)); return ast; } /* * Remove all inlined statements. */ static void remove_inlined_stds() { STD_PREV(0) = stdEnd; STD_NEXT(stdEnd) = 0; } static int removelist(int listhead, int oldsymavl) { int l; for (l = listhead; l >= oldsymavl; l = SYMLKG(l)) ; return l; } /* removelist */ static int removeautolist(int listhead, int oldsymavl) { int l; for (l = listhead; l >= oldsymavl; l = AUTOBJG(l)) ; return l; } /* removeautolist */ static void remove_inlined_symbols(int oldsymavl) { int sptr, hashval, len; char *np; INT V[4]; for (sptr = stb.stg_avail - 1; sptr >= oldsymavl; --sptr) { hashval = -1; switch (STYPEG(sptr)) { case ST_CONST: switch (DTY(DTYPEG(sptr))) { case TY_BINT: case TY_SINT: case TY_INT: case TY_BLOG: case TY_SLOG: case TY_LOG: case TY_WORD: case TY_REAL: case TY_DWORD: case TY_DBLE: case TY_CMPLX: case TY_INT8: case TY_LOG8: V[0] = CONVAL1G(sptr); V[1] = CONVAL2G(sptr); hashval = HASH_CON(V); if (hashval < 0) hashval = -hashval; break; case TY_QUAD: case TY_DCMPLX: case TY_QCMPLX: case TY_HOLL: case TY_NCHAR: V[0] = CONVAL1G(0); V[1] = CONVAL2G(0); V[2] = CONVAL3G(0); V[3] = CONVAL4G(0); hashval = HASH_CON(V); if (hashval < 0) hashval = -hashval; break; case TY_CHAR: np = stb.n_base + CONVAL1G(sptr); HASH_ID(hashval, np, strlen(np)); if (hashval < 0) hashval = -hashval; break; default: interr("remove_inlined_symbols: unknown constant datatype", 0, 4); return; } break; case ST_UNKNOWN: case ST_IDENT: case ST_LABEL: case ST_STAG: case ST_MEMBER: case ST_VAR: case ST_ARRAY: case ST_DESCRIPTOR: case ST_STRUCT: case ST_UNION: case ST_CMBLK: case ST_NML: case ST_ENTRY: case ST_PROC: case ST_STFUNC: case ST_PARAM: case ST_INTRIN: case ST_GENERIC: case ST_USERGENERIC: case ST_PD: case ST_PLIST: case ST_ARRDSC: case ST_ALIAS: case ST_MODULE: case ST_TYPEDEF: case ST_OPERATOR: case ST_MODPROC: case ST_CONSTRUCT: case ST_CRAY: np = SYMNAME(sptr); if (np) { len = strlen(np); HASH_ID(hashval, np, len); if (hashval < 0) hashval = -hashval; } break; default:; } if (hashval >= 0) { int s, ps; for (s = stb.hashtb[hashval], ps = 0; s; s = HASHLKG(s)) { if (s == sptr) { if (ps) { HASHLKP(ps, HASHLKG(s)); } else { stb.hashtb[hashval] = HASHLKG(s); } break; } ps = s; } } } /* remove from gbl. lists */ gbl.cmblks = removelist(gbl.cmblks, oldsymavl); gbl.externs = removelist(gbl.externs, oldsymavl); gbl.consts = removelist(gbl.consts, oldsymavl); gbl.entries = removelist(gbl.entries, oldsymavl); gbl.statics = removelist(gbl.statics, oldsymavl); gbl.locals = removelist(gbl.locals, oldsymavl); gbl.asgnlbls = removelist(gbl.asgnlbls, oldsymavl); gbl.autobj = removeautolist(gbl.autobj, oldsymavl); gbl.tp_adjarr = removeautolist(gbl.tp_adjarr, oldsymavl); gbl.p_adjarr = removelist(gbl.p_adjarr, oldsymavl); stb.stg_avail = oldsymavl; } /* remove_inlined_symbols */ /* * Promote an actual assumed-size array argument to an array section, and * return the new AST. * Expand 'n' dimensions, where 'n' is the number of dimensions of * sptrDummy. Also, if the expanded dimension is the last assumed-size * dimension, check that sptrDummy is also assumed-size */ static int promote_assumsz_arg(int sptrDummy, int astArg) { int asd; int nsubs, sub; int astl, astu, vastSubs[7], ast; int dtyp; int dtypeDummy, nsubsDummy, sptr, dtype; if (A_TYPEG(astArg) != A_SUBSCR) return astArg; if (A_SHAPEG(astArg)) return astArg; dtypeDummy = DTYPEG(sptrDummy); if (DTY(dtypeDummy) != TY_ARRAY) return astArg; nsubsDummy = ADD_NUMDIM(dtypeDummy); asd = A_ASDG(astArg); nsubs = ASD_NDIM(asd); if (nsubsDummy > nsubs) return astArg; for (sub = 0; sub < nsubs; sub++) vastSubs[sub] = ASD_SUBS(asd, sub); sptr = memsym_of_ast(astArg); dtype = DTYPEG(sptr); for (sub = 0; sub < nsubsDummy; ++sub) { astl = ASD_SUBS(asd, sub); /* subscripts must be equal to lower bound, except last one */ if (astl != ADD_LWAST(dtype, sub) && sub != nsubsDummy - 1) return astArg; astu = ADD_UPAST(dtype, sub); if (astu != 0) { vastSubs[sub] = mk_triple(astl, astu, 0); } else { /* had better be last dimension of actual */ if (sub != nsubs - 1) return astArg; /* actual had better be assumed-size */ if (!ADD_ASSUMSZ(dtype)) return astArg; /* dummy had better be assumed-size */ if (!ADD_ASSUMSZ(dtypeDummy)) return astArg; vastSubs[sub] = mk_triple(astl, astu, 0); } } dtyp = get_array_dtype(nsubsDummy, A_DTYPEG(astArg)); ast = mk_subscr(A_LOPG(astArg), vastSubs, nsubs, dtyp); return ast; } /* * Create ALLOCATE statements for all local adjustable arrays whose * symbol table entries occur after sptrHigh. ALLOCATE statements * are added before stdstart; DEALLOCATE statements are added after stdlast. */ static void allocate_adjarrs(int stdstart, int stdlast) { int sptr; int ndims, dim; int vastSubs[7], astArr, ast, astAlloc, astl, astu; int std1 = STD_PREV(stdstart), std2 = stdlast; for (sptr = sptrHigh; sptr < stb.stg_avail; sptr++) if (STYPEG(sptr) == ST_ARRAY && SCG(sptr) == SC_LOCAL && ADJARRG(sptr)) allocate_array(sptr, stdstart, stdlast); } /* * Create an ALLOCATE statement before stdstart for array sptr, and a * DEALLOCATE statement for the array after stdlast. */ static void allocate_array(int sptr, int stdstart, int stdlast) { ADSC *ad; int sptrBnd; int vastSubs[7], astArr, ast, astAlloc, astl, astu; int std1 = STD_PREV(stdstart), std2 = stdlast; int ndims, dim; if (STYPEG(sptr) != ST_ARRAY) return; ad = AD_DPTR(DTYPEG(sptr)); ndims = AD_NUMDIM(ad); for (dim = 0; dim < ndims; dim++) { if (AD_LWBD(ad, dim) && A_TYPEG(AD_LWAST(ad, dim)) == A_ID) { /* Explicitly assign bound expression to the lower bound. */ ast = mk_assn_stmt(AD_LWAST(ad, dim), AD_LWBD(ad, dim), DT_INT); std1 = add_stmt_after(ast, std1); } /* Create a new array bound. */ sptrBnd = sym_get_scalar("l", "inl", DT_INT); astl = mk_id(sptrBnd); ast = mk_assn_stmt(mk_id(sptrBnd), AD_LWAST(ad, dim), DT_INT); std1 = add_stmt_after(ast, std1); AD_LWAST(ad, dim) = astl; AD_LWBD(ad, dim) = astl; if (AD_UPBD(ad, dim) && A_TYPEG(AD_UPAST(ad, dim)) == A_ID) { /* Explicitly assign bound expression to the upper bound. */ ast = mk_assn_stmt(AD_UPAST(ad, dim), AD_UPBD(ad, dim), DT_INT); std1 = add_stmt_after(ast, std1); } /* Create a new array bound. */ sptrBnd = sym_get_scalar("u", "inl", DT_INT); astu = mk_id(sptrBnd); ast = mk_assn_stmt(mk_id(sptrBnd), AD_UPAST(ad, dim), DT_INT); std1 = add_stmt_after(ast, std1); AD_UPAST(ad, dim) = astu; AD_UPBD(ad, dim) = astu; AD_EXTNTAST(ad, dim) = mk_extent(astl, astu, dim); vastSubs[dim] = mk_triple(astl, astu, 0); } astArr = mk_id(sptr); ast = mk_subscr(astArr, vastSubs, ndims, DTYPEG(sptr)); astAlloc = mk_stmt(A_ALLOC, 0); A_TKNP(astAlloc, TK_ALLOCATE); A_LOPP(astAlloc, 0); A_SRCP(astAlloc, ast); std1 = add_stmt_after(astAlloc, std1); astAlloc = mk_stmt(A_ALLOC, 0); A_TKNP(astAlloc, TK_DEALLOCATE); A_LOPP(astAlloc, 0); A_SRCP(astAlloc, astArr); std2 = add_stmt_after(astAlloc, std2); ALLOCP(sptr, TRUE); ADJARRP(sptr, FALSE); AD_DEFER(ad) = TRUE; AD_ADJARR(ad) = FALSE; } /* * Remove RETURN & END statements within STDs between stdstart & stdlast. * Set line #s on all STDs. */ static void remove_returns(int stdstart, int stdlast) { int std; int ast, astStmt, astLbl; int sptrEnd; LOGICAL bEndFound = FALSE; /* Create a new label for the END statement. */ sptrEnd = getlab(); astLbl = mk_label(sptrEnd); for (std = stdstart; std != STD_NEXT(stdlast); std = STD_NEXT(std)) { STD_LINENO(std) = gbl.lineno; ast = STD_AST(std); switch (A_TYPEG(ast)) { case A_RETURN: /* Create a GOTO statement to the END-statement's new label. */ astStmt = mk_stmt(A_GOTO, 0); A_L1P(astStmt, astLbl); STD_AST(std) = astStmt; A_STDP(astStmt, std); RFCNTI(sptrEnd); break; case A_END: /* Remove the END statement, and create a labeled CONTINUE. */ astStmt = mk_stmt(A_CONTINUE, 0); STD_AST(std) = astStmt; A_STDP(astStmt, std); STD_LABEL(std) = sptrEnd; bEndFound = TRUE; break; } } assert(!RFCNTG(sptrEnd) || bEndFound, "remove_returns: no END found", stdstart, 4); } /* * Move labels on branching statements to new CONTINUE statements. */ static void move_labels(int stdstart, int stdlast) { int std, stdnew; int ast, astnew; int sptrLbl; for (std = stdstart; std != STD_NEXT(stdlast); std = STD_NEXT(std)) { sptrLbl = STD_LABEL(std); if (!sptrLbl) continue; STD_LABEL(std) = 0; if (!RFCNTG(sptrLbl)) continue; ast = STD_AST(std); switch (A_TYPEG(ast)) { case A_IF: case A_IFTHEN: case A_ENDIF: case A_AIF: case A_GOTO: case A_CGOTO: case A_AGOTO: case A_ASNGOTO: case A_DO: case A_DOWHILE: case A_ENDDO: case A_CALL: case A_ICALL: case A_WHERE: case A_FORALL: astnew = mk_stmt(A_CONTINUE, 0); stdnew = add_stmt_before(astnew, std); STD_LABEL(stdnew) = sptrLbl; break; case A_ELSE: case A_ELSEIF: case A_ELSEWHERE: case A_ENDWHERE: case A_ENDFORALL: case A_ELSEFORALL: interr("move_labels: statement not handled", std, 4); default: STD_LABEL(std) = sptrLbl; break; } } } /* * Within ast, replace every occurrence of a sub-expression containing * a dummy parameter with an expression derived from the corresponding * actual parameter. */ static int replace_parms(int ast, void *extra_arg) { int iar; int astLop, astNew, astSS, astSub, vastSubs[7], ast1; int sptr, dtypeOld, dtypeNew, memOld, memNew, astMemNew; int asd, asdSS; int ndims, dim; LOGICAL bChanged; switch (A_TYPEG(ast)) { case A_ID: sptr = A_SPTRG(ast); for (iar = 1; iar < iaravail; iar++) if (sptr == AR_SPTRDUMMY(iar)) break; if (iar < iaravail) { astNew = replace_arg(ast, AR_ASTACT(iar)); ast_replace(ast, astNew); } else { if (STYPEG(sptr) == ST_PROC) { if (!HCCSYMG(sptr) && IGNOREG(sptr) && sptr >= use_old_subprogram_limits[0] && sptr <= use_old_subprogram_limits[1]) { int tptr; tptr = FUNCLINEG(sptr); astNew = mk_id(tptr); ast_replace(ast, astNew); } else if (IGNOREG(sptr)) { /* reset IGNORE flag, we have inlined the call */ IGNOREP(sptr, 0); } } } return TRUE; case A_MEM: astLop = A_PARENTG(ast); ast_traverse(astLop, replace_parms, NULL, NULL); astNew = ast_rewrite(astLop); if (astNew == astLop) { ast_replace(ast, ast); } else { /* we have to find the corresponding member name in any new datatype */ dtypeOld = A_DTYPEG(astLop); dtypeNew = A_DTYPEG(astNew); if (DTY(dtypeOld) == TY_ARRAY) dtypeOld = DTY(dtypeOld + 1); if (DTY(dtypeNew) == TY_ARRAY) dtypeNew = DTY(dtypeNew + 1); if (dtypeOld == dtypeNew) { astMemNew = A_MEMG(ast); memNew = A_SPTRG(astMemNew); } else { sptr = A_SPTRG(A_MEMG(ast)); if (DTY(dtypeOld) != DTY(dtypeNew) || DTY(dtypeOld) != TY_DERIVED) { interr("replace_parms: unmatched derived types", ast, 4); } for (memOld = DTY(dtypeOld + 1), memNew = DTY(dtypeNew + 1); memOld > NOSYM && memNew > NOSYM; memOld = SYMLKG(memOld), memNew = SYMLKG(memNew)) { if (memOld == sptr) break; } if (memOld <= NOSYM || memNew <= NOSYM || ADDRESSG(memOld) != ADDRESSG(memNew)) { interr("replace_parms: unmatched derived type members", ast, 4); } astMemNew = mk_id(memNew); } astNew = mk_member(astNew, astMemNew, DTYPEG(memNew)); ast_replace(ast, astNew); } return TRUE; case A_SUBSCR: asd = A_ASDG(ast); bChanged = FALSE; ndims = ASD_NDIM(asd); for (dim = 0; dim < ndims; dim++) { astSub = ASD_SUBS(asd, dim); ast_traverse(astSub, replace_parms, NULL, NULL); astNew = ast_rewrite(astSub); vastSubs[dim] = astNew; bChanged |= astNew != astSub; } astLop = A_LOPG(ast); ast_traverse(astLop, replace_parms, NULL, NULL); astNew = ast_rewrite(astLop); astSS = 0; if (A_TYPEG(astNew) == A_SUBSCR) { astSS = astNew; asdSS = A_ASDG(astSS); astNew = A_LOPG(astNew); } bChanged |= astNew != astLop; ast1 = ast; if (astSS && ASD_NDIM(asdSS) != ndims) { int nSubs[7], i, j; bChanged = 1; j = 0; ndims = ASD_NDIM(asdSS); for (dim = 0; dim < ndims; ++dim) { astSub = ASD_SUBS(asdSS, dim); if (A_SHAPEG(astSub) || A_TYPEG(astSub) == A_TRIPLE) { nSubs[dim] = vastSubs[j++]; } else { nSubs[dim] = astSub; } } for (dim = 0; dim < ndims; ++dim) vastSubs[dim] = nSubs[dim]; } if (bChanged) ast1 = mk_subscr(astNew, vastSubs, ndims, A_DTYPEG(ast)); ast_replace(ast, ast1); return TRUE; case A_INTR: /* look for PRESENT() call */ if (A_OPTYPEG(ast) == I_PRESENT) { /* 1st argument just be A_ID */ int argt, arg; INT v[4]; if (A_ARGCNTG(ast) != 1) { interr("replace_parms: PRESENT with wrong argument count", A_ARGCNTG(ast), 4); } argt = A_ARGSG(ast); arg = ARGT_ARG(argt, 0); if (A_TYPEG(arg) != A_ID) { interr("replace_parms: PRESENT with wrong argument type", A_TYPEG(ast), 4); } sptr = A_SPTRG(arg); for (iar = 1; iar < iaravail; ++iar) if (sptr == AR_SPTRDUMMY(iar)) break; if (iar >= iaravail) { interr("replace_parms: PRESENT with bad argument symbol", sptr, 4); } ast1 = AR_ASTACT(iar); if (ast1 == astb.ptr0) { /* missing optional, replace by .false. */ v[0] = 0; v[1] = 0; v[2] = 0; v[3] = 0; sptr = getcon(v, DT_LOG4); astNew = mk_cnst(sptr); ast_replace(ast, astNew); return TRUE; } else if (A_TYPEG(ast1) == A_ID) { /* get the symbol; if it is a dummy, replace it */ sptr = sym_of_ast(ast1); if (SCG(sptr) == SC_DUMMY) { /* use the dummy in the PRESENT call */ ast_replace(arg, ast1); } else { /* present optional, replace by .true. */ v[0] = -1; v[1] = -1; v[2] = 0; v[3] = 0; sptr = getcon(v, DT_LOG4); astNew = mk_cnst(sptr); ast_replace(ast, astNew); return TRUE; } } else { /* present optional, replace by .true. */ v[0] = -1; v[1] = -1; v[2] = 0; v[3] = 0; sptr = getcon(v, DT_LOG4); astNew = mk_cnst(sptr); ast_replace(ast, astNew); return TRUE; } } break; } return FALSE; } /* * Rewrite all STDs between stdstart & stdlast so that arguments in * AST astCall replace dummy parameters in sptrEntry. */ static void rewrite_inlined_args(int astCall, int sptrEntry, int stdstart, int stdlast) { int iar; int dsc, dscend = DPDSCG(sptrEntry) + PARAMCTG(sptrEntry); int arg, argnum; int astArg, ast; int std; int sptrDummy, sptrArg, sptr, dtype; int shd; int ndims, dim; int vastSubs[7]; ADSC *adDummy, *adArg, *ad; /* Initialize the argument replacement table. */ parbase = NULL; iarsize = 100; NEW(parbase, AR, iarsize); iaravail = 1; arg = 0; argnum = 0; for (dsc = DPDSCG(sptrEntry); dsc < dscend; dsc++, arg++) { ++argnum; astArg = ARGT_ARG(A_ARGSG(astCall), arg); sptrDummy = aux.dpdsc_base[dsc]; if (OPTARGG(sptrDummy) && astArg == astb.ptr0) { iar = iaravail++; NEED(iaravail, parbase, AR, iarsize, iarsize + 100); BZERO(&parbase[iar], AR, 1); AR_SPTRDUMMY(iar) = sptrDummy; AR_ASTACT(iar) = astArg; } if (A_TYPEG(astArg) != A_ID && A_TYPEG(astArg) != A_SUBSCR && A_TYPEG(astArg) != A_MEM) continue; if (A_TYPEG(astArg) == A_SUBSCR && A_SHAPEG(astArg) && DTY(DTYPEG(sptrDummy)) == TY_ARRAY && ASUMSZG(sptrDummy)) { remove_inlined_stds(); return; } if (A_TYPEG(astArg) == A_SUBSCR && !A_SHAPEG(astArg) && DTY(DTYPEG(sptrDummy)) == TY_ARRAY) astArg = promote_assumsz_arg(sptrDummy, astArg); if (!tkr_match_arg(DTYPEG(sptrDummy), A_DTYPEG(astArg))) { if (XBIT(0, 8)) { int modname; modname = SCOPEG(sptrEntry); if (modname && STYPEG(modname) == ST_ALIAS) modname = SCOPEG(modname); if (modname && STYPEG(modname) != ST_MODULE) modname = 0; ccff_info(MSGNEGINLINER, "INL052", gbl.findex, gbl.lineno, "%module%separator%function not inlined: argument " "%arg:%argname type mismatch", "module=%s", modname ? SYMNAME(modname) : "", "separator=%s", modname ? "::" : "", "function=%s", SYMNAME(sptrEntry), "arg=%d", argnum, "argname=%s", SYMNAME(sptrDummy), NULL); } remove_inlined_stds(); return; } if (DTY(DTYPEG(sptrDummy)) == TY_ARRAY) assign_bounds(sptrDummy, astArg, stdstart); iar = iaravail++; NEED(iaravail, parbase, AR, iarsize, iarsize + 100); BZERO(&parbase[iar], AR, 1); AR_SPTRDUMMY(iar) = sptrDummy; AR_ASTACT(iar) = astArg; if (SDSCG(sptrDummy)) { int sptrArgx; sptrArgx = memsym_of_ast(astArg); if (SDSCG(sptrArgx)) { iar = iaravail++; NEED(iaravail, parbase, AR, iarsize, iarsize + 100); BZERO(&parbase[iar], AR, 1); AR_SPTRDUMMY(iar) = SDSCG(sptrDummy); AR_ASTACT(iar) = check_member(astArg, mk_id(SDSCG(sptrArgx))); } } if (MIDNUMG(sptrDummy)) { int sptrArgx; sptrArgx = memsym_of_ast(astArg); if (MIDNUMG(sptrArgx)) { iar = iaravail++; NEED(iaravail, parbase, AR, iarsize, iarsize + 100); BZERO(&parbase[iar], AR, 1); AR_SPTRDUMMY(iar) = MIDNUMG(sptrDummy); AR_ASTACT(iar) = check_member(astArg, mk_id(MIDNUMG(sptrArgx))); } } } for (std = stdstart; std != STD_NEXT(stdlast); std = STD_NEXT(std)) { ast = STD_AST(std); /* Replace dummy parameters with actuals. */ if (ast) { ast_visit(1, 1); ast_traverse(ast, replace_parms, NULL, NULL); ast = ast_rewrite(ast); ast_unvisit(); } STD_AST(std) = ast; A_STDP(ast, std); } /* Rewrite dummy arrays appearing in bounds of adjustable arrays. */ for (sptr = sptrHigh; sptr < stb.stg_avail; sptr++) { dtype = DTYPEG(sptr); if (STYPEG(sptr) == ST_ARRAY && SCG(sptr) == SC_LOCAL && ADJARRG(sptr)) { ad = AD_DPTR(dtype); ndims = AD_NUMDIM(ad); for (dim = 0; dim < ndims; dim++) { /* Replace dummy parameters with actuals in the lower bound. */ ast = AD_LWBD(ad, dim); if (ast) { ast_visit(1, 1); ast_traverse(ast, replace_parms, NULL, NULL); ast = ast_rewrite(ast); ast_unvisit(); } AD_LWBD(ad, dim) = ast; /* Replace dummy parameters with actuals in the upper bound. */ ast = AD_UPBD(ad, dim); if (ast) { ast_visit(1, 1); ast_traverse(ast, replace_parms, NULL, NULL); ast = ast_rewrite(ast); ast_unvisit(); } AD_UPBD(ad, dim) = ast; } } dtype = DDTG(dtype); /* base type */ if ((DTY(dtype) == TY_CHAR || DTY(dtype) == TY_NCHAR) && ADJLENG(sptr)) { ast = DTY(dtype + 1); if (ast) { ast_visit(1, 1); ast_traverse(ast, replace_parms, NULL, NULL); ast = ast_rewrite(ast); ast_unvisit(); DTY(dtype + 1) = ast; } if (ADJLENG(sptr)) { /* treat like we would an automatic object; * create a pointer variable */ if (MIDNUMG(sptr) == 0) { int ptr; ptr = sym_get_ptr(sptr); if (SCG(sptr) == SC_STATIC) { SCP(ptr, SC_STATIC); } else { SCP(ptr, SC_LOCAL); } MIDNUMP(sptr, ptr); SCP(sptr, SC_BASED); } } } } FREE(parbase); parbase = NULL; } /* * Replace an occurrence of astDummy with a reference to astAct. Return * the reference to astAct. */ static int replace_arg(int astDummy, int astAct) { int sptrAct, sptrDummy; int rankAct, dimAct, dim, rankDummy; int asdAct, asdDummy; int ast, astl, astu, asts, astSub, ast1; int vastSubs[7]; int shd, shdDummy; int dtyp, needsubscripts; ADSC *adDummy; shd = A_SHAPEG(astAct); if (!shd) return astAct; sptrAct = memsym_of_ast(astAct); rankAct = rank_of_sym(sptrAct); sptrDummy = memsym_of_ast(astDummy); assert(STYPEG(sptrDummy) == ST_ARRAY || STYPEG(sptrDummy) == ST_DESCRIPTOR, "replace_arg: formal not array", astDummy, 4); /* * if we pass a full array, and the dummy we're replacing is the full array, * we don't need any subscripts */ needsubscripts = 0; for (ast = astAct; ast;) { int sptr; switch (A_TYPEG(ast)) { case A_ID: ast = 0; break; case A_MEM: if (!A_SHAPEG(ast)) { ast = A_LOPG(ast); } else { ast = 0; /* leave loop */ /* we're using the shape of the whole member */ } break; default: needsubscripts = 1; ast = 0; /* leave loop */ } } if (needsubscripts == 0) { for (ast = astDummy; ast;) { switch (A_TYPEG(ast)) { case A_ID: ast = 0; break; case A_MEM: ast = A_LOPG(ast); break; default: needsubscripts = 1; ast = 0; /* leave loop */ } } } if (!needsubscripts) { return astAct; } adDummy = AD_DPTR(DTYPEG(sptrDummy)); rankDummy = AD_NUMDIM(adDummy); dim = -1; for (dimAct = 0; dimAct < rankAct; dimAct++) { astSub = get_subscr(astAct, dimAct); if (!A_SHAPEG(astSub) && A_TYPEG(astSub) != A_TRIPLE) { vastSubs[dimAct] = astSub; continue; } dim++; astSub = get_subscr(astDummy, dim); /* Convert each subscript x to s*(x-l1)+l2, where: * l1 is the lower bound of the dummy array, * s is the stride on the array section of the argument array, * l2 is the lower bound on the array section of the argument. */ /* Compute l2 - s*l1 once. */ ast1 = mk_binop(OP_MUL, SHD_STRIDE(shd, dim), AD_LWAST(adDummy, dim), DT_INT); ast1 = mk_binop(OP_SUB, SHD_LWB(shd, dim), ast1, DT_INT); if (A_TYPEG(astSub) == A_TRIPLE) { astl = mk_binop(OP_MUL, SHD_STRIDE(shd, dim), A_LBDG(astSub), DT_INT); astl = mk_binop(OP_ADD, ast1, astl, DT_INT); astu = mk_binop(OP_MUL, SHD_STRIDE(shd, dim), A_UPBDG(astSub), DT_INT); astu = mk_binop(OP_ADD, ast1, astu, DT_INT); asts = A_STRIDEG(astSub); if (!asts) asts = astb.i1; asts = mk_binop(OP_MUL, SHD_STRIDE(shd, dim), asts, DT_INT); ast = mk_triple(astl, astu, asts); } else if (A_SHAPEG(astSub)) { ast = mk_convert(SHD_STRIDE(shd, dim), A_DTYPEG(astSub)); ast = mk_binop(OP_MUL, ast, astSub, A_DTYPEG(astSub)); ast1 = mk_convert(ast1, A_DTYPEG(astSub)); ast = mk_binop(OP_ADD, ast1, ast, A_DTYPEG(astSub)); } else { ast = mk_binop(OP_MUL, SHD_STRIDE(shd, dim), astSub, DT_INT); ast = mk_binop(OP_ADD, ast1, ast, DT_INT); } vastSubs[dimAct] = ast; } dtyp = DDTG(A_DTYPEG(astAct)); shdDummy = A_SHAPEG(astDummy); if (shdDummy) dtyp = get_array_dtype(SHD_NDIM(shdDummy), dtyp); if (A_TYPEG(astAct) == A_SUBSCR) astAct = A_LOPG(astAct); ast = mk_subscr(astAct, vastSubs, rankAct, dtyp); return ast; } /* * Replace the array bounds in sptrDummy with the array bounds of the * corresponding actual array parameter, astAct. Create * assignments prior to std of actual array bounds to dummy bounds. */ static void assign_bounds(int sptrDummy, int astAct, int std) { int sptrAct; int dim, ndimsAct; int astSub, ast; ADSC *adDummy; int shd; sptrAct = memsym_of_ast(astAct); ndimsAct = rank_of_sym(sptrAct); /* Make assignments of actual array bounds to dummy bounds. */ shd = A_SHAPEG(astAct); assert(shd, "assign_bounds: array has no shape", sptrDummy, 4); ndimsAct = SHD_NDIM(shd); adDummy = AD_DPTR(DTYPEG(sptrDummy)); assert(ndimsAct == AD_NUMDIM(adDummy), "assign_bounds: different ranks", sptrDummy, 4); for (dim = 0; dim < ndimsAct; dim++) { if (A_TYPEG(AD_LWAST(adDummy, dim)) == A_ID) { /* dummylb = actuallb */ ast = mk_assn_stmt(AD_LWAST(adDummy, dim), SHD_LWB(shd, dim), DT_INT); add_stmt_before(ast, std); } if (A_TYPEG(AD_UPAST(adDummy, dim)) == A_ID) { if (A_TYPEG(AD_LWAST(adDummy, dim)) == A_ID || SHD_LWB(shd, dim) == AD_LWAST(adDummy, dim)) { /* dummyub = actualub */ ast = mk_assn_stmt(AD_UPAST(adDummy, dim), SHD_UPB(shd, dim), DT_INT); } else { /* dummyub = actualub-(actuallb-dummylb) */ ast = mk_binop(OP_SUB, SHD_LWB(shd, dim), AD_LWAST(adDummy, dim), DT_INT); ast = mk_binop(OP_SUB, SHD_UPB(shd, dim), ast, DT_INT); ast = mk_assn_stmt(AD_UPAST(adDummy, dim), ast, DT_INT); } add_stmt_before(ast, std); } } } /* * Return subscript #dim of array reference ast. */ static int get_subscr(int ast, unsigned int dim) { int dtyp; ADSC *ad; int astSub; int asd; switch (A_TYPEG(ast)) { case A_ID: case A_MEM: dtyp = A_DTYPEG(ast); assert(DTY(dtyp) == TY_ARRAY, "get_subscr: non-array reference", ast, 4); ad = AD_DPTR(dtyp); assert(dim < AD_NUMDIM(ad), "get_subscr: bad dim", ast, 4); astSub = mk_triple(AD_LWAST(ad, dim), AD_UPAST(ad, dim), astb.i1); return astSub; case A_SUBSCR: asd = A_ASDG(ast); assert(dim < ASD_NDIM(asd), "get_subscr: bad subscript", ast, 4); astSub = ASD_SUBS(asd, dim); return astSub; default: interr("get_subscr: unknown type", ast, 4); return 0; } } static void load_inline_file(char *sDir) { char sHintsFile[MAX_FNAME_LEN]; char sLine[MAX_LINE_LEN]; int iStat, iVer; char *sStat; FILE *fd; /* Open Hints file. */ iStat = fndpath("Inline", sHintsFile, MAX_FNAME_LEN, sDir); /* File found? */ if (iStat) return; fd = fopen(sHintsFile, "r"); if (!fd) return; /* read the hints file, record each routine in the file */ while (fgets(sLine, MAX_LINE_LEN, fd)) { char *ch; for (ch = sLine; *ch; ++ch) { if (*ch == '\n') { *ch = '\0'; break; } } store_funcname(sLine); } fclose(fd); } /* load_inline_file */ /* * Save the extract directory obtained from a command line switch. */ static void load_TOC(char *sDir) { int iStat; char *sStat; FILE *fd; char sTOCFile[MAX_FNAME_LEN]; char sLine[MAX_LINE_LEN]; char sFunc[MAX_FNAME_LEN]; char sHost[MAX_FNAME_LEN]; char sMod[MAX_FNAME_LEN]; char sSrcFile[MAX_FNAME_LEN]; char sModFile[MAX_FNAME_LEN]; int iVer; LE *ple; sExtDir = sDir; pleStart = NULL; /* Open TOC file. */ iStat = fndpath("TOC", sTOCFile, MAX_FNAME_LEN, sDir); if (iStat) /* TOC not found. */ return; fd = fopen(sTOCFile, "r"); if (!fd) ERROR("extractor/inliner: TOC file not found", 0); /* Read the TOC's header line. */ sStat = fgets(sLine, MAX_LINE_LEN, fd); if (!sStat) return; iStat = sscanf(sLine, TOC_HEADER_FMT, &iVer); if (iStat != 1) ERROR("extractor/inliner: bad TOC file header", 0); if (iVer != INLINER_VERSION) ERROR("extractor/inliner: incorrect inliner version in TOC", 0); /* Read the TOC file and create LE records for each line. */ while (fgets(sLine, MAX_LINE_LEN, fd)) { ple = (LE *)getitem(PERM_AREA, sizeof(LE)); if (!ple) ERROR("extractor/inliner: can't allocate memory", 1); iStat = sscanf(sLine, TOC_ENTRY_FMT, sMod, sHost, sFunc, sModFile); if (iStat != 4) ERROR("extractor/inliner: bad TOC line", 0); ple->sMod = STASH(sMod, PERM_AREA); ple->sHost = STASH(sHost, PERM_AREA); ple->sFunc = STASH(sFunc, PERM_AREA); ple->sModFile = STASH(sModFile, PERM_AREA); ple->pleNext = pleStart; pleStart = ple; } fclose(fd); load_inline_file(sDir); } /* * Save a subroutine name that should be inlined. */ static void store_funcname(char *sFunc) { FI *pfi = (FI *)getitem(PERM_AREA, sizeof(FI)); if (!pfi) ERROR("allocator: can't allocate memory", 2); pfi->sFunc = STASH(sFunc, PERM_AREA); pfi->pfiNext = pfiStart; pfiStart = pfi; } /* * Return a pointer to a library entry record associated with program * unit name sFunc. Return NULL if none found. */ static LE * find_libentry(char *sMod, char *sHost, char *sFunc) { LE *ple; for (ple = pleStart; ple; ple = ple->pleNext) if (!strcmp(ple->sFunc, sFunc) && !strcmp(ple->sHost, sHost) && !strcmp(ple->sMod, sMod)) return ple; return NULL; } /* * Return TRUE if the data type of a dummy argument, dtypDummy, has the * same type-kind-rank as the data type of an actual argument, dtypAct. */ static LOGICAL tkr_match_arg(int dtypDummy, int dtypAct) { int rankDummy, rankAct; /* Check scalar types. */ if (!tk_match_arg(dtypDummy, dtypAct, FALSE)) return FALSE; /* Check ranks. */ rankDummy = rank_of(dtypDummy); rankAct = rank_of(dtypDummy); return (rankDummy == rankAct); } /* * Return TRUE if any arguments within CALL/FUNC AST astCall that are * valid left-hand side expressions occur in other expressions within the * call. If so, aliasing could occur. */ static LOGICAL aliased_args(int sptrEntry, int astCall) { int arg, arg1, nargs; int argt; int astArg, astArg1; assert(A_TYPEG(astCall) == A_CALL || A_TYPEG(astCall) == A_FUNC, "aliased_args: missing call", astCall, 4); assert(STYPEG(sptrEntry) == ST_ENTRY, "aliased_args: missing entry", sptrEntry, 4); argt = A_ARGSG(astCall); nargs = A_ARGCNTG(astCall); for (arg = 0; arg < nargs; arg++) { if (make_arg_copy(sptrEntry, astCall, arg)) continue; astArg = ARGT_ARG(argt, arg); /* Check for occurrence of argAst in other arguments. */ for (arg1 = 0; arg1 < nargs; arg1++) { if (arg == arg1) continue; if (make_arg_copy(sptrEntry, astCall, arg1)) continue; astArg1 = ARGT_ARG(argt, arg1); if (contains_ast(astArg1, astArg)) return TRUE; } } return FALSE; } /* * Return TRUE if argument #arg within astCall should be copied at entry * to the procedure whose entry symbol table pointer is sptrEntry. */ static LOGICAL make_arg_copy(int sptrEntry, int astCall, unsigned int arg) { int dsc; int sptrDummy; int astArg; assert(A_TYPEG(astCall) == A_CALL || A_TYPEG(astCall) == A_FUNC, "make_arg_copy: missing call", astCall, 4); assert(STYPEG(sptrEntry) == ST_ENTRY, "make_arg_copy: missing entry", sptrEntry, 4); assert(PARAMCTG(sptrEntry) > arg, "make_arg_copy: not enough dummy parms", sptrEntry, 4); assert(A_ARGCNTG(astCall) > arg, "make_arg_copy: not enough actual parms", astCall, 4); dsc = DPDSCG(sptrEntry) + arg; sptrDummy = aux.dpdsc_base[dsc]; if (SCG(sptrDummy) == SC_EXTERN) return FALSE; assert(SCG(sptrDummy) == SC_DUMMY, "make_arg_copy: arg not dummy", sptrEntry, 4); astArg = ARGT_ARG(A_ARGSG(astCall), arg); if (OPTARGG(sptrDummy) && astArg == astb.ptr0) return FALSE; return A_TYPEG(astArg) == A_SUBSTR || !A_ISLVAL(A_TYPEG(astArg)); }