2233 lines
71 KiB
C++
2233 lines
71 KiB
C++
/*********************************************************************/
|
|
/* Fortran DVM+OpenMP+ACC */
|
|
/* */
|
|
/* Call Site Processing */
|
|
/*********************************************************************/
|
|
#include "leak_detector.h"
|
|
|
|
#include "dvm.h"
|
|
#include "acc_data.h"
|
|
#include "calls.h"
|
|
|
|
using std::map;
|
|
using std::string;
|
|
using std::vector;
|
|
using std::pair;
|
|
|
|
//---------------------------------------------------------------------------------
|
|
|
|
#define NEW 1
|
|
#define STATIC 1
|
|
|
|
graph_node *cur_node;
|
|
graph_node *node_list;
|
|
int deb_reg = 0;
|
|
int do_dummy = 0;
|
|
int do_stmtfn = 0;
|
|
int gcount = 0;
|
|
int has_generic_interface = 0;
|
|
int in_region = 0;
|
|
int in_routine = 0;
|
|
//-----------------------------------------------------------------------------------------
|
|
graph_node *GraphNode(SgSymbol *s, SgStatement *header_st, int flag_new);
|
|
graph_node *NodeForSymbInGraph(SgSymbol *s, SgStatement *stheader);
|
|
graph_node *NewGraphNode(SgSymbol *s, SgStatement *header_st);
|
|
edge *CreateOutcomingEdge(graph_node *gnode, int inlined);
|
|
edge *CreateIncomingEdge(graph_node *gnode, int inlined);
|
|
edge *NewEdge(graph_node *from, graph_node *to, int inlined);
|
|
int isDummyArgument(SgSymbol *s);
|
|
int isHeaderStmtSymbol(SgSymbol *s);
|
|
int isStatementFunction(SgSymbol *s);
|
|
int isHeaderNode(graph_node *gnode);
|
|
int isDeadNode(graph_node *gnode);
|
|
int isNoBodyNode(graph_node *gnode);
|
|
void PrototypeOfFunctionFromOtherFile(graph_node *node, SgStatement *after);
|
|
graph_node_list *addToNodeList(graph_node_list *pnode, graph_node *gnode);
|
|
graph_node_list *delFromNodeList(graph_node_list *pnode, graph_node *gnode);
|
|
graph_node_list *isInNodeList(graph_node_list *pnode, graph_node *gnode);
|
|
void PrintGraphNode(graph_node *gnode);
|
|
void PrintGraphNodeWithAllEdges(graph_node *gnode);
|
|
void PrintWholeGraph();
|
|
void PrintWholeGraph_kind_2();
|
|
void BuildingHeaderNodeList();
|
|
void RemovingDeadSubprograms();
|
|
void NoBodySubprograms();
|
|
void DeleteIncomingEdgeFrom(graph_node *gnode, graph_node *from);
|
|
void DeleteOutcomingEdgeTo(graph_node *gnode, graph_node *gto);
|
|
void ScanSymbolTable(SgFile *f);
|
|
void ScanTypeTable(SgFile *f);
|
|
void printSymb(SgSymbol *s);
|
|
void printType(SgType *t);
|
|
//-------------------------------------------------------------------------------------
|
|
extern SgExpression *private_list;
|
|
extern map <string, vector<vector<SgType*> > > interfaceProcedures;
|
|
|
|
void MarkAsUserProcedure(SgSymbol *s)
|
|
{
|
|
SYMB_ATTR(s->thesymb) = SYMB_ATTR(s->thesymb) | USER_PROCEDURE_BIT;
|
|
}
|
|
|
|
void MarkAsExternalProcedure(SgSymbol *s)
|
|
{
|
|
SYMB_ATTR(s->thesymb) = SYMB_ATTR(s->thesymb) | EXTERNAL_BIT;
|
|
}
|
|
|
|
SgSymbol * GetProcedureHeaderSymbol(SgSymbol *s)
|
|
{
|
|
if (!ATTR_NODE(s))
|
|
return(NULL);
|
|
return(GRAPHNODE(s)->symb);
|
|
}
|
|
|
|
int FromOtherFile(SgSymbol *s)
|
|
{
|
|
if (!ATTR_NODE(s))
|
|
return(1);
|
|
graph_node *gnode = GRAPHNODE(s);
|
|
if(!gnode->st_header || current_file_id != gnode->file_id)
|
|
return(1);
|
|
else
|
|
return(0);
|
|
}
|
|
|
|
int IsInternalProcedure(SgSymbol *s)
|
|
{
|
|
if (!ATTR_NODE(s))
|
|
return 0;
|
|
graph_node *gnode = GRAPHNODE(s);
|
|
if(gnode->st_header && gnode->st_header->controlParent()->variant() != GLOBAL && gnode->st_header->controlParent()->variant() != MODULE_STMT)
|
|
return 1;
|
|
else
|
|
return 0;
|
|
}
|
|
|
|
SgStatement *hasInterface(SgSymbol *s)
|
|
{
|
|
return (ATTR_NODE(s) ? GRAPHNODE(s)->st_interface : NULL);
|
|
}
|
|
|
|
void SaveInterface(SgSymbol *s, SgStatement *interface)
|
|
{
|
|
if (ATTR_NODE(s) && !GRAPHNODE(s)->st_interface)
|
|
GRAPHNODE(s)->st_interface = interface;
|
|
}
|
|
|
|
SgStatement *Interface(SgSymbol *s)
|
|
{
|
|
SgStatement *interface = hasInterface(s);
|
|
if (!interface)
|
|
interface = getInterface(s);
|
|
|
|
if (isForCudaRegion() && interface)
|
|
{
|
|
SaveInterface(s,interface);
|
|
MarkAsUserProcedure(s);
|
|
}
|
|
return interface;
|
|
}
|
|
|
|
int findParameterNumber(SgSymbol *s, char *name)
|
|
{
|
|
int i;
|
|
int n = ((SgFunctionSymb *) s)->numberOfParameters();
|
|
for(i=0; i<n; i++)
|
|
if(!strcmp(((SgFunctionSymb *) s)->parameter(i)->identifier(), name))
|
|
return i;
|
|
return -1;
|
|
}
|
|
|
|
int isInParameter(SgSymbol *s, int i)
|
|
{
|
|
return (s && ((SgFunctionSymb *) s)->parameter(i) && (((SgFunctionSymb *) s)->parameter(i)->attributes() & IN_BIT) ? 1 : 0);
|
|
}
|
|
|
|
SgSymbol *ProcedureSymbol(SgSymbol *s)
|
|
{
|
|
if (FromOtherFile(s))
|
|
{
|
|
SgStatement *header = Interface(s);
|
|
return( header ? header->symbol() : NULL);
|
|
}
|
|
return (GetProcedureHeaderSymbol(s));
|
|
}
|
|
|
|
int IsPureProcedure(SgSymbol *s)
|
|
{
|
|
SgSymbol *sproc = ProcedureSymbol(s);
|
|
return ( sproc ? sproc->attributes() & PURE_BIT : 0 );
|
|
}
|
|
|
|
int IsElementalProcedure(SgSymbol *s)
|
|
{
|
|
SgSymbol *shedr;
|
|
shedr = GetProcedureHeaderSymbol(s);
|
|
if (shedr)
|
|
return(shedr->attributes() & ELEMENTAL_BIT);
|
|
else
|
|
return 0;
|
|
}
|
|
|
|
int IsRecursiveProcedure(SgSymbol *s)
|
|
{
|
|
SgSymbol *shedr;
|
|
shedr = GetProcedureHeaderSymbol(s);
|
|
if (shedr)
|
|
return(shedr->attributes() & RECURSIVE_BIT);
|
|
else
|
|
return 0;
|
|
}
|
|
|
|
int isUserFunction(SgSymbol *s)
|
|
{
|
|
return(s->attributes() & USER_PROCEDURE_BIT);
|
|
}
|
|
|
|
int IsNoBodyProcedure(SgSymbol *s)
|
|
{
|
|
if (!ATTR_NODE(s))
|
|
return 0;
|
|
return(GRAPHNODE(s)->st_header == NULL);
|
|
}
|
|
|
|
void MarkAsRoutine(SgSymbol *s)
|
|
{
|
|
graph_node *gnode;
|
|
|
|
if (!ATTR_NODE(s))
|
|
return;
|
|
gnode = GRAPHNODE(s);
|
|
gnode->is_routine = 1;
|
|
return;
|
|
}
|
|
|
|
void MarkAsCalled(SgSymbol *s)
|
|
{
|
|
graph_node *gnode;
|
|
edge *gedge;
|
|
if (!ATTR_NODE(s))
|
|
return;
|
|
gnode = GRAPHNODE(s);
|
|
//if (gnode->st_header) // for nobody procedure (for intrinsic functions and ...) gnode->st_header== NULL
|
|
gnode->count++;
|
|
for (gedge = gnode->to_called; gedge; gedge = gedge->next)
|
|
MarkAsCalled(gedge->to->symb);
|
|
return;
|
|
|
|
}
|
|
|
|
void MakeFunctionCopy(SgSymbol *s)
|
|
{
|
|
SgSymbol *s_header;
|
|
graph_node *gnode;
|
|
|
|
if (!ATTR_NODE(s))
|
|
return;
|
|
GRAPHNODE(s)->count++;
|
|
|
|
|
|
gnode = GRAPHNODE(s);
|
|
s_header = gnode->symb;
|
|
gnode->count++;
|
|
|
|
/*
|
|
if(!gnode->st_copy)
|
|
{ printf("make copy of %s\n",s_header->identifier());
|
|
gnode->st_copy = s_header->copySubprogram(*mod_gpu->lexNext()).body();
|
|
}
|
|
*/
|
|
//s_copy = &s_header->copySubprogram(*mod_gpu); *mod_gpu->lexNext()
|
|
//gnode->st_copy = s_header->copySubprogram(*mod_gpu).body();
|
|
//gnode->st_copy->unparsestdout();
|
|
//HeaderStatement(&s_header->copySubprogram(*mod_gpu)); //(s_copy); //(s_header->copySubprogram(*mod_gpu));
|
|
}
|
|
|
|
SgStatement *HeaderStatement(SgSymbol *s)
|
|
{
|
|
return(s->body());
|
|
}
|
|
|
|
|
|
void InsertCalledProcedureCopies()
|
|
{
|
|
graph_node *ndl;
|
|
int n = 0;
|
|
if (!mod_gpu)
|
|
return;
|
|
|
|
SgStatement *after = mod_gpu->lexNext();
|
|
SgStatement *first_kernel_const = after->lexNext();
|
|
|
|
for (ndl = node_list; ndl; ndl = ndl->next)
|
|
if (ndl->count)
|
|
{
|
|
if (ndl->st_header && current_file_id == ndl->file_id) //procedure from current_file
|
|
{
|
|
ndl->st_copy = InsertProcedureCopy(ndl->st_header, ndl->st_header->symbol(), ndl->is_routine, after); //C_Cuda ? mod_gpu : mod_gpu->lexNext());
|
|
n++;
|
|
}
|
|
else //procedure from other file
|
|
PrototypeOfFunctionFromOtherFile(ndl,after);
|
|
|
|
ndl->count = 0;
|
|
ndl->st_interface = NULL;
|
|
//ndl->st_copy = NULL;
|
|
}
|
|
|
|
if (options.isOn(C_CUDA) && mod_gpu->lexNext()->variant() == COMMENT_STAT)
|
|
mod_gpu->lexNext()->extractStmt(); //extracting empty statement (COMMENT_STAT)
|
|
|
|
if (options.isOn(RTC) && options.isOn(C_CUDA) && n != 0)
|
|
ACC_RTC_AddFunctionsToKernelConsts(first_kernel_const);
|
|
cuda_functions = n;
|
|
}
|
|
|
|
SgSymbol* getReturnSymbol(SgStatement *st_header, SgSymbol *s)
|
|
{
|
|
if (st_header->expr(0) == NULL)
|
|
return s;
|
|
else
|
|
return st_header->expr(0)->symbol();
|
|
}
|
|
|
|
void replaceAttribute(SgStatement *header)
|
|
{
|
|
SgExpression *e = new SgExpression(ACC_ATTRIBUTES_OP, new SgExpression(ACC_DEVICE_OP), NULL, NULL);
|
|
header->setExpression(2, *e);
|
|
}
|
|
|
|
int isInterfaceStatement(SgStatement *stmt)
|
|
{
|
|
if (stmt->variant() == INTERFACE_STMT || stmt->variant() == INTERFACE_ASSIGNMENT || stmt->variant() == INTERFACE_OPERATOR)
|
|
return 1;
|
|
return 0;
|
|
}
|
|
|
|
void ReplaceInterfaceBlocks(SgStatement *header)
|
|
{
|
|
SgStatement *last = header->lastNodeOfStmt();
|
|
SgStatement *stmt;
|
|
for (stmt=header->lexNext(); stmt && stmt!=last; stmt=stmt->lexNext())
|
|
{
|
|
if(isSgExecutableStatement(stmt))
|
|
return;
|
|
if(stmt->variant() == INTERFACE_STMT || stmt->variant() == INTERFACE_ASSIGNMENT || stmt->variant() == INTERFACE_OPERATOR)
|
|
{
|
|
SgStatement *st_end = stmt->lastNodeOfStmt(); // END INTERFACE
|
|
stmt = stmt->lexNext();
|
|
while(stmt!=st_end)
|
|
{
|
|
if(stmt->variant() == FUNC_HEDR || stmt->variant() == PROC_HEDR )
|
|
{
|
|
replaceAttribute(stmt);
|
|
stmt = stmt->lastNodeOfStmt()->lexNext();
|
|
}
|
|
else
|
|
stmt = stmt->lexNext();
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
|
|
int HasDerivedTypeVariables(SgStatement *header)
|
|
{
|
|
SgSymbol *s;
|
|
SgSymbol *s_last = LastSymbolOfFunction(header);
|
|
|
|
for (s = header->symbol()->next(); s != s_last->next(); s = s->next())
|
|
{
|
|
if( s->type() && s->type()->variant()==T_DERIVED_TYPE)
|
|
{ // !!! not implemented
|
|
err_p("Derived type variables", header->symbol()->identifier(), 999);
|
|
return 1;
|
|
}
|
|
}
|
|
return 0;
|
|
}
|
|
|
|
SgStatement *InsertProcedureCopy(SgStatement *st_header, SgSymbol *sproc, int is_routine, SgStatement *after)
|
|
{
|
|
//insert copy of procedure after statement 'after'
|
|
SgStatement *new_header, *end_st;
|
|
|
|
SgSymbol *new_sproc = &sproc->copySubprogram(*after);
|
|
new_header = after->lexNext(); // new procedure header //new_sproc->body()
|
|
SYMB_SCOPE(new_sproc->thesymb) = mod_gpu->thebif;
|
|
new_header->setControlParent(mod_gpu);
|
|
SgSymbol *returnSymbol = getReturnSymbol(new_header, new_sproc);
|
|
|
|
if (options.isOn(C_CUDA))
|
|
{
|
|
RenamingNewProcedureVariables(new_sproc); // to avoid conflicts with C language keywords
|
|
int flagHasDerivedTypeVariables = HasDerivedTypeVariables(new_header);
|
|
|
|
end_st = new_header->lastNodeOfStmt();
|
|
ConvertArrayReferences(new_header->lexNext(), end_st); //!!!!
|
|
|
|
TranslateProcedureHeader_To_C(new_header);
|
|
|
|
private_list = NULL;
|
|
|
|
ExtractDeclarationStatements(new_header);
|
|
SgSymbol *s_last = LastSymbolOfFunction(new_header);
|
|
if (sproc->variant() == FUNCTION_NAME)
|
|
{
|
|
SgSymbol *sfun = &new_sproc->copy();
|
|
new_header->expr(0)->setSymbol(sfun); //fe->setSymbol(sfun);
|
|
SYMB_IDENT(new_sproc->thesymb) = FunctionResultIdentifier(new_sproc);
|
|
|
|
InsertReturnBeforeEnd(new_header, end_st);
|
|
}
|
|
|
|
swapDimentionsInprivateList();
|
|
//std::vector < std::stack < SgStatement*> > zero = std::vector < std::stack < SgStatement*> >(0);
|
|
//cur_func = after;
|
|
Translate_Fortran_To_C(new_header, end_st, 0, st_header); //TranslateProcedure_Fortran_To_C(after->lexNext());
|
|
cur_func = after;
|
|
if (sproc->variant() == FUNCTION_NAME)
|
|
{
|
|
new_header->insertStmtAfter(*Declaration_Statement(new_sproc), *new_header);
|
|
ChangeReturnStmts(new_header, end_st, returnSymbol);
|
|
}
|
|
if(!flagHasDerivedTypeVariables) //!!! derived data type is not supported
|
|
MakeFunctionDeclarations(new_header, s_last);
|
|
|
|
newVars.clear();
|
|
private_list = NULL;
|
|
// generate prototype of function and insert it before 'after'
|
|
if (options.isOn(RTC) == false)
|
|
doPrototype(new_header, mod_gpu, is_routine ? !STATIC : STATIC);
|
|
|
|
}
|
|
else //Fortran Cuda
|
|
{
|
|
replaceAttribute(new_header);
|
|
new_header->addComment("\n"); // add comment (empty line) to new procedure header
|
|
ReplaceInterfaceBlocks(new_header);
|
|
}
|
|
|
|
return(new_header);
|
|
}
|
|
|
|
SgStatement *FunctionPrototype(SgSymbol *sf)
|
|
{
|
|
SgExpression *fref = new SgFunctionRefExp(*sf);
|
|
fref->setSymbol(*sf);
|
|
fref->setType(*sf->type());
|
|
SgStatement *st = new SgStatement(VAR_DECL);
|
|
st->setExpression(0, *new SgExprListExp(*fref));
|
|
|
|
return (st);
|
|
}
|
|
|
|
|
|
void doPrototype(SgStatement *func_hedr, SgStatement *block_header, int static_flag)
|
|
{
|
|
SgSymbol *sf = func_hedr->expr(0)->symbol();
|
|
SgStatement *st = FunctionPrototype(sf);
|
|
if (func_hedr->expr(0)->lhs())
|
|
st->expr(0)->lhs()->setLhs(func_hedr->expr(0)->lhs()->copy());
|
|
st->addDeclSpec(BIT_CUDA_DEVICE);
|
|
if (static_flag)
|
|
st->addDeclSpec(BIT_STATIC);
|
|
|
|
block_header->insertStmtAfter(*st, *block_header); //before->insertStmtAfter(*st,*before->controlParent());
|
|
}
|
|
|
|
SgStatement *TranslateProcedureHeader_To_C(SgStatement *new_header)
|
|
{
|
|
SgSymbol *new_sproc = new_header->symbol();
|
|
SgFunctionRefExp *fe = new SgFunctionRefExp(*new_sproc);
|
|
fe->setSymbol(*new_sproc);
|
|
new_header->setExpression(0, *fe);
|
|
SgSymbol *returnSymbol = getReturnSymbol(new_header, new_sproc);
|
|
if (new_sproc->variant() == PROCEDURE_NAME)
|
|
new_sproc->setType(C_VoidType());
|
|
else // FUNCTION_NAME
|
|
{
|
|
//new_sproc->setType(C_Type(new_sproc->type()));
|
|
new_sproc->setType(C_Type(returnSymbol->type()));
|
|
}
|
|
fe->setType(new_sproc->type());
|
|
fe->setLhs(FunctionDummyList(new_sproc));
|
|
BIF_LL3(new_header->thebif) = NULL;
|
|
new_header->addDeclSpec(BIT_CUDA_DEVICE);
|
|
new_header->setVariant(FUNC_HEDR);
|
|
return new_header;
|
|
}
|
|
|
|
void PrototypeOfFunctionFromOtherFile(graph_node *node, SgStatement *after)
|
|
{
|
|
if (options.isOn(RTC)) return;
|
|
if(!node->st_interface) return;
|
|
|
|
SgStatement *interface = node->st_interface;
|
|
//SgSymbol *sproc = interface->symbol()
|
|
//SgSymbol *new_sproc = new SgSymbol(sproc->variant(), sproc->identifier(), sproc->type(), current_file->firstStatement(),);
|
|
|
|
SgSymbol *sh = &(interface->symbol()->copyLevel1());
|
|
SYMB_SCOPE(sh->thesymb) = current_file->firstStatement()->thebif;
|
|
SgStatement *new_hedr = &(interface->copy());
|
|
new_hedr->setSymbol(*sh);
|
|
TranslateProcedureHeader_To_C(new_hedr);
|
|
doPrototype(new_hedr, mod_gpu, !STATIC);
|
|
|
|
//current_file->firstStatement()->insertStmtAfter(*new_hedr, *current_file->firstStatement());
|
|
//SYMB_FUNC_HEDR(sh->thesymb) = new_hedr->thebif;
|
|
|
|
|
|
//node->st_interface->setLexNext(*node->st_interface->lastNodeOfStmt());
|
|
//SgStatement *hedr_st = InsertProcedureCopy(node->st_interface, node->st_interface->symbol(), after);
|
|
//hedr_st->extractStmt();
|
|
node->st_interface = NULL;
|
|
return;
|
|
}
|
|
|
|
SgExpression *FunctionDummyList(SgSymbol *s)
|
|
{
|
|
SgExpression *arg_list = NULL, *ae = NULL;
|
|
|
|
int n = ((SgFunctionSymb *)s)->numberOfParameters();
|
|
|
|
//insert at 0-th position inf-argument
|
|
//check for optional arguments, if some argunemt exist with optional then add argument-mask
|
|
|
|
//int useOption = false;
|
|
//for (i = 0; i < n; i++)
|
|
//{
|
|
// useOption |= ((SgFunctionSymb *)s)->parameter(i)->attributes() & OPTIONAL_BIT;
|
|
//}
|
|
//if(useOption)
|
|
//{
|
|
// std::string nameForArgsInfo = "arg_info"; // name for new arguments
|
|
// SgSymbol* argInfo = new SgSymbol(VARIABLE_NAME,nameForArgsInfo.c_str());
|
|
// argInfo->setType(C_LongType());
|
|
// ae = new SgVarRefExp(argInfo);
|
|
// ae = new SgExprListExp(*ae);
|
|
// arg_list = AddListToList(arg_list, ae);
|
|
//}
|
|
|
|
for (int i = 0; i < n; i++)
|
|
{
|
|
SgSymbol *sarg = ((SgFunctionSymb *)s)->parameter(i);
|
|
|
|
if (!isSgArrayType(sarg->type()))
|
|
{
|
|
sarg->setType(C_Type(sarg->type()));
|
|
if (sarg->attributes() & OPTIONAL_BIT)
|
|
{
|
|
sarg->setType(new SgDerivedTemplateType(new SgTypeRefExp(*sarg->type()), new SgSymbol(TYPE_NAME, "optArg")));
|
|
}
|
|
ae = new SgVarRefExp(sarg);
|
|
//ae->setType(C_ReferenceType(sarg->type()));
|
|
if (sarg->attributes() & IN_BIT)
|
|
ae = new SgExprListExp(*ae);
|
|
else
|
|
ae = new SgExprListExp(SgAddrOp(*ae));
|
|
arg_list = AddListToList(arg_list, ae);
|
|
|
|
}
|
|
else
|
|
{
|
|
int needChanged = true;
|
|
SgArrayType* arrT = (SgArrayType*)sarg->type();
|
|
int dims = arrT->dimension();
|
|
SgExpression *dimList = arrT->getDimList();
|
|
|
|
while (dimList)
|
|
{
|
|
if (dimList->lhs()->variant() != DDOT)
|
|
{
|
|
needChanged = false;
|
|
break;
|
|
}
|
|
else if (dimList->lhs()->rhs())
|
|
{
|
|
needChanged = false;
|
|
break;
|
|
}
|
|
dimList = dimList->rhs();
|
|
}
|
|
|
|
SgType *t = C_PointerType(C_Type(sarg->type()->baseType()));
|
|
sarg->setType(t);
|
|
ae = new SgVarRefExp(sarg);
|
|
ae->setType(t);
|
|
if (needChanged)
|
|
{
|
|
sarg->setType(new SgDerivedTemplateType(new SgTypeRefExp(*t), new SgSymbol(TYPE_NAME, "s_array")));
|
|
ae = new SgVarRefExp(sarg);
|
|
ae = new SgExprListExp(*ae);
|
|
arg_list = AddListToList(arg_list, ae);
|
|
continue;
|
|
}
|
|
|
|
//ae->setType(C_ReferenceType(sarg->type()));
|
|
ae = new SgExprListExp(*new SgPointerDerefExp(*ae));
|
|
arg_list = AddListToList(arg_list, ae);
|
|
//SgSymbol *arr_info = new SgSymbol(VAR_REF, ("inf_" + std::string(sarg->identifier())).c_str());
|
|
//arr_info->setType(C_PointerType(C_Type(new SgType(T_INT))));
|
|
//ae = new SgVarRefExp(arr_info);
|
|
//ae = new SgExprListExp(*new SgPointerDerefExp(*ae));
|
|
//arg_list = AddListToList(arg_list, ae);
|
|
}
|
|
}
|
|
return (arg_list);
|
|
}
|
|
|
|
char *FunctionResultIdentifier(SgSymbol *sfun)
|
|
{
|
|
char *name;
|
|
name = (char *)malloc((unsigned)(strlen(sfun->identifier()) + 4 + 1));
|
|
sprintf(name, "%s_res", sfun->identifier());
|
|
return(NameCheck(name, sfun));
|
|
}
|
|
|
|
SgSymbol *isSameNameInProcedure(char *name, SgSymbol *sfun)
|
|
{
|
|
SgSymbol *s;
|
|
for (s = sfun->next(); s; s = s->next())
|
|
if (!strcmp(s->identifier(), name))
|
|
return(s);
|
|
return(NULL);
|
|
}
|
|
|
|
char *NameCheck(char *name, SgSymbol *sfun)
|
|
{
|
|
SgSymbol *s;
|
|
while ((s = isSameNameInProcedure(name, sfun)) != 0)
|
|
{
|
|
name = (char *)malloc((unsigned)(strlen(name) + 2));
|
|
sprintf(name, "%s_", s->identifier());
|
|
}
|
|
return(name);
|
|
}
|
|
|
|
void InsertReturnBeforeEnd(SgStatement *new_header, SgStatement *end_st)
|
|
{
|
|
SgStatement *prev = end_st->lexPrev();
|
|
if (prev->variant() == RETURN_STAT)
|
|
return;
|
|
prev->insertStmtAfter(*new SgStatement(RETURN_STAT), *new_header);
|
|
}
|
|
|
|
void ChangeReturnStmts(SgStatement *new_header, SgStatement *end_st, SgSymbol *sres)
|
|
{
|
|
SgStatement *stmt;
|
|
for (stmt = new_header->lexNext(); stmt != end_st; stmt = stmt->lexNext())
|
|
if (stmt->variant() == RETURN_STAT)
|
|
stmt->setExpression(0, *new SgVarRefExp(sres));
|
|
|
|
}
|
|
|
|
template<typename callStatType>
|
|
static void createIntefacePrototype(callStatType *funcDecl)
|
|
{
|
|
string funcName = funcDecl->name().identifier();
|
|
const int parNum = funcDecl->numberOfParameters();
|
|
vector<SgType*> prototype(parNum);
|
|
for (int i = 0; i < parNum; ++i)
|
|
{
|
|
SgSymbol *par = funcDecl->parameter(i);
|
|
SgType *type = par->type();
|
|
prototype[i] = type;
|
|
}
|
|
map <string, vector<vector<SgType*> > >::iterator it = interfaceProcedures.find(funcName);
|
|
if (it == interfaceProcedures.end())
|
|
{
|
|
vector<vector<SgType*> > prototypes = vector<vector<SgType*> >();
|
|
prototypes.push_back(prototype);
|
|
|
|
interfaceProcedures.insert(it, make_pair(funcName, prototypes));
|
|
}
|
|
else
|
|
it->second.push_back(prototype);
|
|
}
|
|
|
|
bool CreateIntefacePrototype(SgStatement *header)
|
|
{
|
|
bool retVal = true;
|
|
if (header->variant() == FUNC_HEDR)
|
|
{
|
|
SgFuncHedrStmt *funcDecl = isSgFuncHedrStmt(header);
|
|
if (funcDecl)
|
|
createIntefacePrototype(funcDecl);
|
|
else
|
|
retVal = false;
|
|
}
|
|
else if (header->variant() == PROC_HEDR)
|
|
{
|
|
SgProcHedrStmt *procDecl = isSgProcHedrStmt(header);
|
|
if (procDecl)
|
|
createIntefacePrototype(procDecl);
|
|
else
|
|
retVal = false;
|
|
}
|
|
else
|
|
retVal = false;
|
|
|
|
return retVal;
|
|
}
|
|
|
|
void ExtractDeclarationStatements(SgStatement *header)
|
|
{
|
|
SgStatement *cur_st;
|
|
SgStatement *stmt = header->lexNext();
|
|
SgExprListExp *e;
|
|
SgExpression *list, *it;
|
|
|
|
if(stmt->variant()==CONTROL_END)
|
|
return;
|
|
|
|
while (stmt && !isSgExecutableStatement(stmt)) //is Fortran specification statement
|
|
{
|
|
cur_st = stmt;
|
|
stmt = stmt->lexNext();
|
|
if(cur_st->variant() == INTERFACE_STMT || cur_st->variant() == INTERFACE_ASSIGNMENT || cur_st->variant() == INTERFACE_OPERATOR)
|
|
{
|
|
SgStatement *last = cur_st->lastNodeOfStmt();
|
|
SgStatement *start = cur_st;
|
|
while (start != last)
|
|
{
|
|
// save prototypes of FUNC and PROC
|
|
if (start->variant() == FUNC_HEDR)
|
|
{
|
|
SgFuncHedrStmt *funcDecl = isSgFuncHedrStmt(start);
|
|
if (funcDecl)
|
|
{
|
|
createIntefacePrototype(funcDecl);
|
|
start = funcDecl->lastNodeOfStmt();
|
|
}
|
|
}
|
|
else if (start->variant() == PROC_HEDR)
|
|
{
|
|
SgProcHedrStmt *procDecl = isSgProcHedrStmt(start);
|
|
if (procDecl)
|
|
{
|
|
createIntefacePrototype(procDecl);
|
|
start = procDecl->lastNodeOfStmt();
|
|
}
|
|
}
|
|
start = start->lexNext();
|
|
}
|
|
stmt = cur_st->lastNodeOfStmt()->lexNext();
|
|
cur_st->extractStmt();
|
|
continue;
|
|
}
|
|
if(cur_st->variant()==STRUCT_DECL)
|
|
{
|
|
stmt = cur_st->lastNodeOfStmt()->lexNext();
|
|
cur_st->extractStmt();
|
|
continue;
|
|
}
|
|
//if(cur_st->variant()==IMPL_DECL || cur_st->variant()==DATA_DECL || cur_st->variant()==USE_STMT || cur_st->variant()==FORMAT_STAT || cur_st->variant()==ENTRY_STAT || cur_st->variant()==COMM_STAT || cur_st->variant()==STMTFN_STAT )
|
|
if(!isSgVarDeclStmt(cur_st) && !isSgVarListDeclStmt(cur_st))
|
|
{
|
|
cur_st->extractStmt();
|
|
continue;
|
|
}
|
|
|
|
list = cur_st->expr(0);
|
|
for(; list; list = list->rhs())
|
|
{
|
|
if(IS_DUMMY(list->lhs()->symbol()) || !isSgArrayType(list->lhs()->symbol()->type()))
|
|
continue;
|
|
//add local array in private list
|
|
e = new SgExprListExp(*new SgVarRefExp(*list->lhs()->symbol()));
|
|
e->setRhs(private_list);
|
|
private_list = e;
|
|
}
|
|
cur_st->extractStmt();
|
|
}
|
|
}
|
|
|
|
/*
|
|
std::string ArrParametrs(SgSymbol* arr)
|
|
{
|
|
return ("inf_" + std::string(arr->identifier())).c_str();
|
|
}
|
|
SgExpression* InheritUpperBound(SgSymbol* arr, int i)
|
|
{
|
|
SgExpression *dim = ((SgArrayType *)(arr->type()))->sizeInDim(i);
|
|
SgExpression *lb = dim->lhs();
|
|
SgExpression *ub = dim->rhs();
|
|
if(dim->variant() != DDOT || ub != NULL)
|
|
{
|
|
return UpperBound(arr,i);
|
|
}
|
|
if(lb == NULL)
|
|
{
|
|
return &(*(new SgArrayRefExp(*new SgSymbol(VARIABLE_NAME, ArrParametrs(arr).c_str()), *new SgValueExp((i-1)+7)))
|
|
- *(new SgArrayRefExp(*new SgSymbol(VARIABLE_NAME, ArrParametrs(arr).c_str()), *new SgValueExp(i-1)))
|
|
+ *new SgValueExp(1)) ;
|
|
}
|
|
else if(1)
|
|
{
|
|
return &(*(new SgArrayRefExp(*new SgSymbol(VARIABLE_NAME, ArrParametrs(arr).c_str()), *new SgValueExp((i-1)+7)))
|
|
- *(new SgArrayRefExp(*new SgSymbol(VARIABLE_NAME, ArrParametrs(arr).c_str()), *new SgValueExp(i-1)))
|
|
+ *lb) ;
|
|
}
|
|
|
|
}
|
|
SgExpression* InheritLowerBound(SgSymbol* arr, int i)
|
|
{
|
|
SgExpression *dim = ((SgArrayType *)(arr->type()))->sizeInDim(i);
|
|
SgExpression *lb = dim->lhs();
|
|
SgExpression *ub = dim->rhs();
|
|
if(dim->variant() != DDOT || ub != NULL)
|
|
{
|
|
return UpperBound(arr,i);
|
|
}
|
|
if(lb == NULL)
|
|
{
|
|
return new SgValueExp(1) ;
|
|
}
|
|
else
|
|
{
|
|
return lb;
|
|
}
|
|
|
|
}
|
|
*/
|
|
void CorrectSubscript(SgExpression *e)
|
|
{
|
|
int dims = ((SgArrayType *)(e->symbol()->type()))->dimension();
|
|
std::deque<std::pair<SgExpression*, SgExpression*> > koefs;
|
|
// SgExpression *infUpperBound = NULL; ;
|
|
// SgExpression *infLowerBound = NULL;
|
|
SgExpression *tmp = e->lhs();
|
|
if (tmp == NULL)
|
|
{
|
|
return;
|
|
}
|
|
for (int i = 0; i < dims; ++i)
|
|
{
|
|
SgExpression *dimsize = ((SgArrayType *)(e->symbol()->type()))->sizeInDim(i);
|
|
if (dimsize->variant() == STAR_RANGE)
|
|
{
|
|
break;
|
|
}
|
|
}
|
|
for (int i = 0; i < dims; ++i)
|
|
{
|
|
std::pair<SgExpression*, SgExpression*> tmp_pair;
|
|
SgExpression * koef = new SgValueExp(1);
|
|
SgExpression *dimsize = ((SgArrayType *)(e->symbol()->type()))->sizeInDim(i);
|
|
SgExpression *check = dimsize->lhs();
|
|
for (int j = 0; j < i; ++j)
|
|
{
|
|
// SgExpression *dimsize = ((SgArrayType *)(e->symbol()->type()))->sizeInDim(j);
|
|
// if (isSgSubscriptExp(dimsize) && !dimsize->rhs())
|
|
// {
|
|
// infLowerBound = (new SgArrayRefExp(*new SgSymbol(VARIABLE_NAME, ArrParametrs(e->symbol()).c_str()), *new SgValueExp(j)));
|
|
// infUpperBound = (new SgArrayRefExp(*new SgSymbol(VARIABLE_NAME, ArrParametrs(e->symbol()).c_str()), *new SgValueExp(j+7)));
|
|
//
|
|
// koef = Calculate(&(*koef * (*infUpperBound - *infLowerBound + *new SgValueExp(1))));
|
|
//
|
|
// }
|
|
// else
|
|
// {
|
|
SgExpression * up = UpperBound(e->symbol(), j);
|
|
if(up->variant() == FUNC_CALL)
|
|
{
|
|
up = new SgExpression(RECORD_REF);
|
|
up->setLhs(new SgVarRefExp(e->symbol()));
|
|
//up->setRhs(new SgVarRefExp(*new SgSymbol(FIELD_NAME,(std::string("ub[")+std::to_string(j)+std::string("]")).c_str())));
|
|
up->setRhs(new SgFunctionCallExp(*new SgSymbol(MEMBER_FUNC,"ub"), *new SgExprListExp(*new SgValueExp(j))));
|
|
}
|
|
SgExpression * low = LowerBound(e->symbol(), j);
|
|
koef = Calculate(&(*koef * (*up - *LowerBound(e->symbol(), j) + *new SgValueExp(1))));
|
|
// }
|
|
}
|
|
tmp_pair.first = koef;
|
|
|
|
tmp_pair.second = Calculate(&(*tmp->lhs() - *LowerBound(e->symbol(), i)));
|
|
tmp = tmp->rhs();
|
|
koefs.push_back(tmp_pair);
|
|
|
|
}
|
|
SgExpression *line = koefs.front().second;
|
|
koefs.pop_front();
|
|
tmp = e->lhs();
|
|
for (int i = 0; i < dims - 1; ++i)
|
|
{
|
|
line = &(*koefs.front().second * *koefs.front().first + *line);
|
|
koefs.pop_front();
|
|
tmp = tmp->rhs();
|
|
}
|
|
e->setLhs((new SgExprListExp(*line)));
|
|
}
|
|
|
|
void replaceVectorRef(SgExpression *e)
|
|
{
|
|
SgType *type;
|
|
if (e == NULL)
|
|
return;
|
|
if (isSgArrayRefExp(e))
|
|
{
|
|
type = isSgArrayType(e->symbol()->type());
|
|
if (IS_DUMMY(e->symbol()) && type)
|
|
{
|
|
CorrectSubscript(e);
|
|
}
|
|
return;
|
|
}
|
|
|
|
replaceVectorRef(e->lhs());
|
|
replaceVectorRef(e->rhs());
|
|
}
|
|
|
|
void ConvertArrayReferences(SgStatement *first, SgStatement *last)
|
|
{
|
|
SgStatement *st;
|
|
for (st = first; st != last; st = st->lexNext())
|
|
{
|
|
if (st->expr(0))
|
|
replaceVectorRef(st->expr(0));
|
|
if (st->expr(1))
|
|
replaceVectorRef(st->expr(1));
|
|
if (st->expr(2))
|
|
replaceVectorRef(st->expr(2));
|
|
}
|
|
}
|
|
|
|
void convertArrayDecl(SgSymbol* s)
|
|
{
|
|
SgExprListExp *resDims, *tmp;
|
|
std::stack<SgExpression*>dims;
|
|
if(isSgArrayType(s->type()))
|
|
{
|
|
SgExpression *dimList = isSgArrayType(s->type())->getDimList();
|
|
while (dimList)
|
|
{
|
|
if(dimList->lhs()->variant() == DDOT)
|
|
{
|
|
dims.push(Calculate(&(*(dimList->lhs()->rhs()) - *(dimList->lhs()->lhs()) + *new SgValueExp(1))));
|
|
}
|
|
else
|
|
{
|
|
dims.push(Calculate(&(*(dimList->lhs()))));
|
|
}
|
|
dimList = dimList->rhs();
|
|
}
|
|
SgType* t = C_Type(isSgArrayType(s->type())->baseType());
|
|
SgArrayType *arr = new SgArrayType(*t);
|
|
while (!dims.empty())
|
|
{
|
|
arr->addDimension(dims.top());
|
|
dims.pop();
|
|
}
|
|
s->setType(arr);
|
|
}
|
|
|
|
|
|
}
|
|
|
|
void MakeFunctionDeclarations(SgStatement *header, SgSymbol *s_last)
|
|
{
|
|
SgSymbol *s;
|
|
SgStatement *cur_stat = header;
|
|
SgStatement *st;
|
|
SgExpression *el;
|
|
char* name = header->expr(0)->symbol()->identifier();
|
|
|
|
for (s = header->symbol()->next(); s != s_last->next(); s = s->next())
|
|
{
|
|
if (isSgFunctionSymb(s) != NULL)
|
|
continue;
|
|
|
|
int flags = s->attributes();
|
|
|
|
if (IS_DUMMY(s))
|
|
{
|
|
if (flags & (IN_BIT | OUT_BIT | INOUT_BIT))
|
|
;
|
|
else if(!options.isOn(NO_PURE_FUNC))
|
|
err_p("Dummy argument need to have INTENT attribute in PURE procedure", name, 617);
|
|
continue;
|
|
}
|
|
|
|
if (flags & SAVE_BIT)
|
|
err_p("SAVE not be used in PURE procedure", name, 618);
|
|
if (flags & COMMON_BIT)
|
|
err_p("COMMON not be used in PURE procedure", name, 619);
|
|
|
|
if (s->scope() != header)
|
|
{
|
|
//printf("%s: %d \n",s->identifier(),s->scope()->variant()); //printf("%s: %d %s \n",s->identifier(),s->scope()->variant(),s->scope()->symbol()->identifier());
|
|
continue;
|
|
}
|
|
if (!isSgArrayType(s->type())) //scalar variable
|
|
s->setType(C_Type(s->type()));
|
|
else
|
|
{
|
|
continue;
|
|
}
|
|
|
|
if (isSgConstantSymb(s))
|
|
{
|
|
SgExpression *ce = ((SgConstantSymb *)s)->constantValue();
|
|
convertExpr(ce, ce);
|
|
st = makeSymbolDeclarationWithInit(s, ce);
|
|
st->addDeclSpec(BIT_CONST);
|
|
}
|
|
else if(isSgVariableSymb(s))
|
|
st = makeSymbolDeclaration(s); //st = Declaration_Statement(s);
|
|
else
|
|
continue;
|
|
cur_stat->insertStmtAfter(*st);
|
|
cur_stat = st;
|
|
}
|
|
//printf("\n"); if(private_list) private_list->unparsestdout(); printf("\n");
|
|
for (el = private_list; el; el = el->rhs())
|
|
{
|
|
convertArrayDecl(el->lhs()->symbol());
|
|
st = makeSymbolDeclaration(el->lhs()->symbol());
|
|
cur_stat->insertStmtAfter(*st);
|
|
cur_stat = st;
|
|
}
|
|
}
|
|
|
|
SgSymbol *LastSymbolOfFunction(SgStatement *header)
|
|
{
|
|
SgSymbol *s = header->symbol();
|
|
while (s->next())
|
|
{ //printf(" %s: %d %s\n", s->next()->identifier(),s->next()->scope()->variant(), s->next()->scope()->symbol() ? s->next()->scope()->symbol()->identifier() : "N");
|
|
s = s->next();
|
|
}
|
|
return(s);
|
|
}
|
|
|
|
|
|
//---------------------------------------------------------------------------------------
|
|
void ProjectStructure(SgProject &project)
|
|
{
|
|
int n = project.numberOfFiles();
|
|
SgFile *file;
|
|
int i;
|
|
// building program structure
|
|
// looking through the file list of project (first time)
|
|
for (i = n - 1; i >= 0; i--)
|
|
{
|
|
file = &(project.file(i));
|
|
current_file = file;
|
|
current_file_id = i;
|
|
FileStructure(file);
|
|
//printf("%s %d\n",project.fileName(i),i); PrintWholeGraph();
|
|
}
|
|
for (i = n - 1; i >= 0; i--)
|
|
{
|
|
file = &(project.file(i));
|
|
current_file = file;
|
|
current_file_id = i;
|
|
doCallGraph(file);
|
|
}
|
|
//ScanSymbolTable(file);
|
|
//PrintWholeGraph();
|
|
}
|
|
|
|
void FileStructure(SgFile *file)
|
|
{// looking through the file and creating graph node for header of each program unit
|
|
SgStatement *stat;
|
|
|
|
// grab the first statement in the file.
|
|
stat = file->firstStatement(); // file header
|
|
for (stat = stat->lexNext(); stat; stat = stat->lexNext())
|
|
{
|
|
if (stat->variant() == INTERFACE_STMT || stat->variant() == INTERFACE_ASSIGNMENT || stat->variant() == INTERFACE_OPERATOR)
|
|
{
|
|
stat = stat->lastNodeOfStmt(); //InterfaceBlock(stat);
|
|
continue;
|
|
}
|
|
|
|
if (stat->variant() == FUNC_HEDR || stat->variant() == PROC_HEDR || stat->variant() == PROG_HEDR || stat->variant() == MODULE_STMT)
|
|
{ //printf("%d %s \n",stat->lineNumber(),stat->symbol()->identifier());
|
|
//creating graph node for header of function (procedure, program)
|
|
cur_node = GraphNode(stat->symbol(), stat, NEW);
|
|
|
|
}
|
|
|
|
}
|
|
|
|
}
|
|
|
|
void ReplaceGenericInterfaceBlocks(SgStatement *hedr, SgStatement *end_of_unit)
|
|
{
|
|
SgStatement *stmt;
|
|
//SgSymbol *symb = NULL;
|
|
for (stmt = hedr->lexNext(); stmt != end_of_unit; stmt = stmt->lastNodeOfStmt()->lexNext())
|
|
{
|
|
if(stmt->variant() == INTERFACE_STMT && stmt->symbol())
|
|
BIF_SYMB(stmt->thebif) = NULL;
|
|
if(stmt->variant() == FUNC_HEDR || stmt->variant() == PROC_HEDR )
|
|
stmt = stmt->lexNext();
|
|
}
|
|
}
|
|
|
|
|
|
void doCallGraph(SgFile *file)
|
|
{// scanning the file to search procedure calls
|
|
SgStatement *stat = NULL, *end_of_unit = NULL;
|
|
//char *func_name;
|
|
//int *ir;
|
|
//int has_main_program_unit = 0;
|
|
|
|
// grab the first statement in the file.
|
|
stat = file->firstStatement(); // file header
|
|
for (stat = stat->lexNext(); stat; stat = end_of_unit->lexNext())
|
|
{
|
|
has_generic_interface = 0;
|
|
end_of_unit = ProgramUnit(stat);
|
|
if (has_generic_interface)
|
|
ReplaceGenericInterfaceBlocks(stat,end_of_unit);
|
|
}
|
|
// add the attribute (last statement of file) to first statement of file
|
|
SgStatement **last = new (SgStatement *);
|
|
#if __SPF
|
|
addToCollection(__LINE__, __FILE__, last, 1);
|
|
#endif
|
|
*last = end_of_unit;
|
|
file->firstStatement()->addAttribute(LAST_STATEMENT, (void*)last, sizeof(SgStatement *));
|
|
|
|
}
|
|
|
|
SgStatement *ProgramUnit(SgStatement *first)
|
|
{
|
|
SgStatement *stat, *end_of_unit;
|
|
|
|
// program unit: main program, external subprogram, module or block data
|
|
for (stat = first; stat; stat = end_of_unit->lexNext())
|
|
{
|
|
//end of program unit with CONTAINS statement
|
|
if (stat->variant() == CONTROL_END)
|
|
{
|
|
if (stat->controlParent() == first) //end of program unit with CONTAINS statement
|
|
return(stat);
|
|
else
|
|
{
|
|
end_of_unit = stat;
|
|
continue;
|
|
}
|
|
}
|
|
if (stat->variant() == BLOCK_DATA) //BLOCK_DATA header
|
|
return(stat->lastNodeOfStmt());
|
|
|
|
// PROGRAM, SUBROUTINE, FUNCTION or MODULE header
|
|
|
|
//scanning the Symbols Table of the function
|
|
// ScanSymbTable(func->symbol(), (f->functions(i+1))->symbol());
|
|
|
|
end_of_unit = Subprogram(stat); // end_of unit may be END or CONTAINS statement
|
|
//printf("---%d %d %s \n",stat->lineNumber(),end_of_unit->lineNumber(),stat->symbol()->identifier());
|
|
GRAPHNODE(stat->symbol())->st_last = end_of_unit;
|
|
if (end_of_unit->variant() == CONTROL_END && end_of_unit->controlParent() == first) //end of program unit without CONTAINS statement
|
|
return(end_of_unit);
|
|
}
|
|
return NULL;
|
|
}
|
|
|
|
SgStatement *Subprogram(SgStatement *func)
|
|
{
|
|
// Build a directed acyclic call multigrahp (call DAMG)
|
|
// which represents calls between routines of the program
|
|
|
|
SgStatement *stmt, *last, *first;
|
|
|
|
|
|
DECL(func->symbol()) = 1;
|
|
HEDR(func->symbol()) = func->thebif;
|
|
cur_func = func;
|
|
in_routine = 0;
|
|
//if( func->variant() == PROG_HEDR)
|
|
// PROGRAM_HEADER(func->symbol()) = func->thebif;
|
|
|
|
// determing graph node for header of function (procedure, program)
|
|
cur_node = ATTR_NODE(func->symbol()) ? GRAPHNODE(func->symbol()) : GraphNode(func->symbol(), func, 0);
|
|
|
|
first = func->lexNext();
|
|
//printf("\n%s header_id= %d \n", func->symbol()->identifier(), func->symbol()->id());
|
|
//!!!debug
|
|
//if(fsymb)
|
|
//printf("\n%s %s \n", header(func->variant()),fsymb->identifier());
|
|
//else {
|
|
//printf("Function name error \n");
|
|
//return;
|
|
//}
|
|
|
|
last = func->lastNodeOfStmt();
|
|
|
|
// follow the statements of the function in lexical order
|
|
// until last statement
|
|
for (stmt = first; stmt && (stmt != last); stmt = stmt->lexNext())
|
|
{
|
|
switch (stmt->variant()) {
|
|
|
|
case CONTAINS_STMT:
|
|
last = stmt;
|
|
goto END_;
|
|
break;
|
|
|
|
case ENTRY_STAT:
|
|
// !!!!!!!
|
|
break;
|
|
|
|
case DATA_DECL:
|
|
case CONTROL_END:
|
|
case STOP_STAT:
|
|
case PAUSE_NODE:
|
|
case GOTO_NODE: // GO TO
|
|
break;
|
|
case ACC_ROUTINE_DIR:
|
|
in_routine = 1;
|
|
break;
|
|
case VAR_DECL:
|
|
case SWITCH_NODE: // SELECT CASE ...
|
|
case ARITHIF_NODE: // Arithmetical IF
|
|
case IF_NODE: // IF... THEN
|
|
case WHILE_NODE: // DO WHILE (...)
|
|
case CASE_NODE: // CASE ...
|
|
case ELSEIF_NODE: // ELSE IF...
|
|
case LOGIF_NODE: // Logical IF
|
|
FunctionCallSearch(stmt->expr(0));
|
|
break;
|
|
case STMTFN_STAT:
|
|
DECL(stmt->expr(0)->symbol()) = 2;
|
|
break;
|
|
case COMGOTO_NODE: // Computed GO TO
|
|
case OPEN_STAT:
|
|
case CLOSE_STAT:
|
|
case INQUIRE_STAT:
|
|
case BACKSPACE_STAT:
|
|
case ENDFILE_STAT:
|
|
case REWIND_STAT:
|
|
FunctionCallSearch(stmt->expr(1));
|
|
break;
|
|
|
|
case PROC_STAT: { // CALL
|
|
SgExpression *el;
|
|
int inlined;
|
|
//printf("\n%s call_id= %d \n", stmt->symbol()->identifier(), stmt->symbol()->id());
|
|
//!!!temporary
|
|
//inlined = (func->variant() == PROG_HEDR) ? 0 : 1;
|
|
inlined = 1;
|
|
Call_Site(stmt->symbol(), inlined, stmt, NULL);
|
|
// looking through the arguments list
|
|
for (el = stmt->expr(0); el; el = el->rhs())
|
|
Arg_FunctionCallSearch(el->lhs()); // argument
|
|
}
|
|
break;
|
|
|
|
case ASSIGN_STAT: // Assign statement
|
|
case WRITE_STAT:
|
|
case READ_STAT:
|
|
case PRINT_STAT:
|
|
case FOR_NODE:
|
|
FunctionCallSearch(stmt->expr(0)); // left part
|
|
FunctionCallSearch(stmt->expr(1)); // right part
|
|
break;
|
|
case ACC_REGION_DIR:
|
|
in_region++;
|
|
break;
|
|
case ACC_END_REGION_DIR:
|
|
in_region--;
|
|
break;
|
|
default:
|
|
FunctionCallSearch(stmt->expr(0));
|
|
FunctionCallSearch(stmt->expr(1));
|
|
FunctionCallSearch(stmt->expr(2));
|
|
break;
|
|
}
|
|
|
|
} // end of processing statement/directive
|
|
|
|
END_:
|
|
// for debugging
|
|
if (deb_reg > 1)
|
|
PrintGraphNode(cur_node);
|
|
in_routine = 0;
|
|
return(last);
|
|
}
|
|
|
|
void FunctionCallSearch(SgExpression *e)
|
|
{
|
|
SgExpression *el;
|
|
if (!e)
|
|
return;
|
|
|
|
if (isSgFunctionCallExp(e)) {
|
|
Call_Site(e->symbol(), 1, NULL, e);
|
|
for (el = e->lhs(); el; el = el->rhs())
|
|
Arg_FunctionCallSearch(el->lhs());
|
|
return;
|
|
}
|
|
FunctionCallSearch(e->lhs());
|
|
FunctionCallSearch(e->rhs());
|
|
return;
|
|
}
|
|
|
|
void Arg_FunctionCallSearch(SgExpression *e)
|
|
{
|
|
FunctionCallSearch(e);
|
|
return;
|
|
}
|
|
|
|
void FunctionCallSearch_Left(SgExpression *e)
|
|
{
|
|
FunctionCallSearch(e);
|
|
}
|
|
|
|
int isAsterDummy(SgSymbol *s)
|
|
{
|
|
if (!s) return 0;
|
|
if (!strcmp(s->identifier(),"*")) return 1;
|
|
return 0;
|
|
}
|
|
|
|
SgExpression * TypeKindExpr(SgType *t)
|
|
{
|
|
SgExpression *len;
|
|
SgExpression *selector;
|
|
if(!t) return (NULL);
|
|
len = t->length();
|
|
selector = t->selector();
|
|
//printf("\nTypeSize");
|
|
//printf("\nranges:"); if(len) len->unparsestdout();
|
|
//printf("\nkind_len:"); if(selector) selector->unparsestdout();
|
|
|
|
//the number of bytes is not specified in type declaration statement
|
|
if (!len && !selector)
|
|
return (new SgValueExp(IntrinsicTypeSize(t)));
|
|
if (t->variant() != T_STRING) // numeric types
|
|
{
|
|
if (len && !selector) //INTEGER*2,REAL*8,CHARACTER*(N+1)
|
|
return(Calculate(len));
|
|
else
|
|
return(Calculate(selector->lhs() ? selector->lhs() : selector)); //specified kind:INT_VAL for literal constants or KIND_OP
|
|
}
|
|
else // character (T_STRING)
|
|
{
|
|
if (!selector->lhs()) // for literal constants 1_"xxx"
|
|
return(Calculate(selector));
|
|
else if (selector->variant() == KIND_OP)
|
|
return(Calculate(selector->lhs()));
|
|
else if (selector->variant() == LENGTH_OP)
|
|
return(new SgValueExp(IntrinsicTypeSize(t)));
|
|
else if (selector->lhs()->variant()==KIND_OP)
|
|
return(Calculate(selector->lhs()));
|
|
else if (selector->rhs()->variant()==KIND_OP)
|
|
return(Calculate(selector->rhs()));
|
|
}
|
|
return (NULL);
|
|
}
|
|
|
|
int CompareKind(SgType *type_arg, SgType *type_dummy)
|
|
{
|
|
int kind1=-1, kind2=-1;
|
|
SgExpression *e1 = TypeKindExpr(type_dummy);
|
|
if (e1 && e1->isInteger())
|
|
kind1 = e1->valueInteger();
|
|
|
|
SgExpression *e2 = TypeKindExpr(type_arg);
|
|
if (e2 && e2->isInteger())
|
|
kind2 = e2->valueInteger();
|
|
|
|
if (kind1>=0 && kind1 == kind2)
|
|
return 1;
|
|
else
|
|
return 0;
|
|
}
|
|
|
|
int CompareTypeKindRank (SgExpression *e, SgSymbol *dummy)
|
|
{
|
|
if (!dummy) return 0;
|
|
if (e->variant() == ARRAY_OP)
|
|
CompareTypeKindRank (e->lhs(), dummy);
|
|
//if (isSgRecordRefExp(e))
|
|
// CompareTypeKindRank (RightMostField(e), dummy);
|
|
if (!e->type() && !dummy->type())
|
|
return 1;
|
|
else if (!e->type())
|
|
return 0;
|
|
else if (!dummy->type())
|
|
return 0;
|
|
|
|
SgArrayType *artype_dummy = isSgArrayType(dummy->type());
|
|
SgArrayType *artype_arg = isSgArrayType(e->type());
|
|
if (artype_dummy != 0 && artype_arg != 0)
|
|
{
|
|
if (TYPE_DIM(artype_dummy->thetype) != TYPE_DIM(artype_arg->thetype)) //dimension() method cannot be used
|
|
return 0;
|
|
}
|
|
else if (artype_dummy == 0 && artype_arg == 0)
|
|
;
|
|
else
|
|
return 0;
|
|
SgType *type_arg = artype_arg ? artype_arg->baseType() : e->type();
|
|
SgType *type_dummy = artype_dummy ? artype_dummy->baseType() : dummy->type();
|
|
|
|
if (type_dummy->variant() == T_DERIVED_TYPE && type_arg->variant() == T_DERIVED_TYPE)
|
|
{
|
|
if (!strcmp(ORIGINAL_SYMBOL(type_dummy->symbol())->identifier(), ORIGINAL_SYMBOL(type_arg->symbol())->identifier()))
|
|
return 1;
|
|
else
|
|
return 0;
|
|
}
|
|
else if (type_dummy->variant() == T_DERIVED_TYPE || type_arg->variant() == T_DERIVED_TYPE)
|
|
return 0;
|
|
if (type_dummy->variant() == T_STRING)
|
|
{
|
|
if( type_arg->variant() == T_STRING)
|
|
return 1;
|
|
else
|
|
return 0;
|
|
}
|
|
if ( type_dummy->variant() == T_COMPLEX || type_dummy->variant() == T_DCOMPLEX)
|
|
if ( type_arg->variant() == T_COMPLEX || type_arg->variant() == T_DCOMPLEX)
|
|
return (CompareKind(type_arg, type_dummy));
|
|
else
|
|
return 0;
|
|
if (type_dummy->variant() == T_FLOAT || type_dummy->variant() == T_DOUBLE)
|
|
if (type_arg->variant() == T_FLOAT || type_arg->variant() == T_DOUBLE)
|
|
return (CompareKind(type_arg,type_dummy));
|
|
else
|
|
return 0;
|
|
if (type_arg->variant() != type_dummy->variant())
|
|
return 0;
|
|
|
|
return (CompareKind(type_arg,type_dummy));
|
|
}
|
|
|
|
int CompareArgDummy(SgExpression *e, int i, SgSymbol *symb)
|
|
{
|
|
if (i == -1) return 0;
|
|
if (e->variant() == KEYWORD_ARG)
|
|
CompareArgDummy(e->rhs(), findParameterNumber(symb, NODE_STR(e->lhs()->thellnd)), symb);
|
|
//if((((SgFunctionSymb *) symb)->parameter(i))->attributes() & OPTIONAL_BIT ) return 1;
|
|
if (e->variant() == LABEL_ARG) return isAsterDummy(((SgFunctionSymb *) symb)->parameter(i)); //!!! illegal
|
|
return (CompareTypeKindRank(e, ((SgFunctionSymb *) symb)->parameter(i) ));
|
|
}
|
|
|
|
int CompareArguments(SgSymbol *symb, SgExpression *arg_list)
|
|
{
|
|
SgExpression *el, *e;
|
|
int i;
|
|
for (el = arg_list, i = 0; el; el = el->rhs(), i++)
|
|
if (!CompareArgDummy(el->lhs(), i, symb))
|
|
return 0;
|
|
return 1;
|
|
}
|
|
|
|
SgStatement *getInterfaceInScope(SgSymbol *s, SgStatement *func)
|
|
{
|
|
enum { SEARCH_INTERFACE, CHECK_INTERFACE, FIND_NAME };
|
|
|
|
SgStatement *searchStmt = func->lexNext();
|
|
SgStatement *tmp;
|
|
const char *funcName = s->identifier();
|
|
const char *toCmp;
|
|
|
|
int mode = SEARCH_INTERFACE;
|
|
//search interface in the specification part of a program unit
|
|
while (searchStmt && (!isSgExecutableStatement(searchStmt) || isDvmSpecification(searchStmt)))
|
|
{
|
|
switch (mode)
|
|
{
|
|
case SEARCH_INTERFACE:
|
|
if (searchStmt->variant() != INTERFACE_STMT)
|
|
searchStmt = searchStmt->lastNodeOfStmt()->lexNext();
|
|
else
|
|
mode = CHECK_INTERFACE;
|
|
break;
|
|
case CHECK_INTERFACE:
|
|
if (searchStmt->symbol())
|
|
toCmp = searchStmt->symbol()->identifier();
|
|
else
|
|
toCmp = "";
|
|
|
|
if (searchStmt->symbol() && strcmp(toCmp, funcName) != 0)
|
|
{
|
|
searchStmt = searchStmt->lastNodeOfStmt()->lexNext();
|
|
mode = SEARCH_INTERFACE;
|
|
}
|
|
else
|
|
{
|
|
if(searchStmt->symbol())
|
|
{
|
|
return searchStmt;
|
|
}
|
|
else
|
|
{
|
|
mode = FIND_NAME;
|
|
searchStmt = searchStmt->lexNext();
|
|
}
|
|
}
|
|
break;
|
|
case FIND_NAME:
|
|
if (searchStmt->variant() == FUNC_HEDR || searchStmt->variant() == PROC_HEDR)
|
|
{
|
|
if (!strcmp(searchStmt->symbol()->identifier(), funcName))
|
|
return searchStmt;
|
|
else
|
|
searchStmt = searchStmt->lastNodeOfStmt()->lexNext();
|
|
}
|
|
else if (searchStmt->variant() == MODULE_PROC_STMT)
|
|
searchStmt = searchStmt->lastNodeOfStmt()->lexNext();
|
|
|
|
if (searchStmt->variant() == CONTROL_END) // end of interface block
|
|
{
|
|
mode = SEARCH_INTERFACE;
|
|
searchStmt = searchStmt->lexNext();
|
|
}
|
|
break;
|
|
}
|
|
}
|
|
return NULL;
|
|
}
|
|
|
|
SgStatement *getInterface(SgSymbol *s)
|
|
{
|
|
SgStatement *func = cur_func;
|
|
SgStatement *interface_st = NULL;
|
|
while (func->variant() != GLOBAL)
|
|
{
|
|
if (interface_st = getInterfaceInScope(s, func))
|
|
return interface_st;
|
|
else
|
|
func = func->controlParent();
|
|
}
|
|
return interface_st;
|
|
}
|
|
|
|
int CompareModuleProcedureName(SgExpression *name_list, SgSymbol *symb)
|
|
{
|
|
SgExpression *el;
|
|
for (el=name_list; el; el=el->rhs())
|
|
if (!strcmp(el->lhs()->symbol()->identifier(), symb->identifier()))
|
|
return 1;
|
|
return 0;
|
|
}
|
|
|
|
SgStatement *SearchModuleProcedure(SgExpression *name_list, SgExpression *arg_list, SgStatement *module_st)
|
|
{
|
|
SgStatement *stmt = module_st->lexNext();
|
|
while (stmt->variant() != CONTAINS_STMT && stmt->variant() != CONTROL_END )
|
|
stmt = stmt->lastNodeOfStmt()->lexNext();
|
|
if (stmt->variant() == CONTROL_END)
|
|
return NULL;
|
|
SgStatement *last = module_st->lastNodeOfStmt();
|
|
for (stmt=stmt->lexNext(); stmt != last; stmt = stmt->lastNodeOfStmt()->lexNext())
|
|
{
|
|
if (CompareModuleProcedureName(name_list, stmt->symbol()) && CompareArguments(stmt->symbol(),arg_list))
|
|
return stmt;
|
|
else
|
|
continue;
|
|
}
|
|
return NULL;
|
|
}
|
|
|
|
SgStatement *getGenericInterfaceInScope(SgSymbol *s, SgExpression *arg_list, SgStatement *func)
|
|
{
|
|
enum { SEARCH_INTERFACE, CHECK_INTERFACE, FIND_NAME };
|
|
|
|
SgStatement *searchStmt = func->lexNext();
|
|
SgStatement *tmp;
|
|
const char *funcName = s->identifier();
|
|
const char *toCmp;
|
|
|
|
int mode = SEARCH_INTERFACE;
|
|
//search interface in the specification part of a program unit
|
|
while (searchStmt && (!isSgExecutableStatement(searchStmt) || isDvmSpecification(searchStmt)))
|
|
{
|
|
switch (mode)
|
|
{
|
|
case SEARCH_INTERFACE:
|
|
if (searchStmt->variant() != INTERFACE_STMT)
|
|
searchStmt = searchStmt->lastNodeOfStmt()->lexNext();
|
|
else
|
|
mode = CHECK_INTERFACE;
|
|
break;
|
|
case CHECK_INTERFACE:
|
|
if (searchStmt->symbol())
|
|
toCmp = searchStmt->symbol()->identifier();
|
|
else
|
|
toCmp = "";
|
|
|
|
if (searchStmt->symbol() && !strcmp(toCmp, funcName))
|
|
{
|
|
mode = FIND_NAME;
|
|
searchStmt = searchStmt->lexNext();
|
|
}
|
|
else
|
|
{
|
|
searchStmt = searchStmt->lastNodeOfStmt()->lexNext();
|
|
mode = SEARCH_INTERFACE;
|
|
}
|
|
break;
|
|
case FIND_NAME:
|
|
if (searchStmt->variant() == FUNC_HEDR || searchStmt->variant() == PROC_HEDR)
|
|
{
|
|
if (CompareArguments(searchStmt->symbol(), arg_list))
|
|
return searchStmt;
|
|
else
|
|
searchStmt = searchStmt->lastNodeOfStmt()->lexNext();
|
|
}
|
|
else if (searchStmt->variant() == MODULE_PROC_STMT)
|
|
{
|
|
SgStatement *module_proc = SearchModuleProcedure(searchStmt->expr(0), arg_list, func->variant()==MODULE_STMT ? func : ORIGINAL_SYMBOL(searchStmt->expr(0)->symbol())->scope());
|
|
if (module_proc)
|
|
return module_proc;
|
|
else
|
|
searchStmt = searchStmt->lexNext();
|
|
}
|
|
if (searchStmt->variant() == CONTROL_END) // end of interface block
|
|
{
|
|
mode = SEARCH_INTERFACE;
|
|
searchStmt = searchStmt->lexNext();
|
|
}
|
|
break;
|
|
}
|
|
}
|
|
return NULL;
|
|
}
|
|
|
|
SgStatement *getGenericInterface(SgSymbol *s, SgExpression *arg_list)
|
|
{
|
|
SgStatement *func = IS_BY_USE(s) ? ORIGINAL_SYMBOL(s)->scope() : cur_func;
|
|
SgStatement *interface_st = NULL;
|
|
while (func->variant() != GLOBAL)
|
|
{
|
|
if (interface_st = getGenericInterfaceInScope(s, arg_list, func))
|
|
return interface_st;
|
|
else
|
|
func = func->controlParent();
|
|
}
|
|
return interface_st;
|
|
}
|
|
|
|
void Call_Site(SgSymbol *s, int inlined, SgStatement *stat, SgExpression *e)
|
|
{
|
|
graph_node * gnode, *node_by_attr = NULL;
|
|
SgSymbol *s_new = s;
|
|
SgStatement *interface_st = NULL;
|
|
//printf("\n%s id= %d \n", s->identifier(), s->id());
|
|
if (!do_dummy && isDummyArgument(s)) return;
|
|
if (!do_stmtfn && isStatementFunction(s)) return;
|
|
// if(isIntrinsicFunction(s)) return;
|
|
//printf("\nLINE %d", cur_st->lineNumber());
|
|
|
|
if(s->variant() == INTERFACE_NAME && in_region)
|
|
{
|
|
//printf("INTERFACE_NAME %s\n",s->identifier());
|
|
interface_st = getGenericInterface(s, stat ? stat->expr(0) : e->lhs());
|
|
SgSymbol *s_gen = s;
|
|
if(!interface_st)
|
|
{
|
|
Error("No interface found for the procedure %s", s->identifier(), 661, cur_func);
|
|
return;
|
|
}
|
|
s = interface_st->symbol();
|
|
has_generic_interface = 1;
|
|
if (stat)
|
|
stat->setSymbol(*s);
|
|
else
|
|
e->setSymbol(*s);
|
|
MarkAsUserProcedure(s);
|
|
MarkAsExternalProcedure(s);
|
|
}
|
|
|
|
if (ATTR_NODE(s))
|
|
node_by_attr = GRAPHNODE(s);
|
|
gnode = GraphNode(s, NULL, 0);
|
|
CreateOutcomingEdge(gnode, inlined); // for node 'cur_node' edge: [cur_node]-> gnode
|
|
CreateIncomingEdge(gnode, inlined); // for node 'gnode' edge: cur_node ->[gnode]
|
|
if(node_by_attr && gnode != node_by_attr)
|
|
{
|
|
s_new = &s->copy();
|
|
if (stat)
|
|
stat->setSymbol(*s_new);
|
|
else
|
|
e->setSymbol(*s_new);
|
|
graph_node **pnode = new (graph_node *);
|
|
*pnode = gnode;
|
|
s_new->addAttribute(GRAPH_NODE, (void*)pnode, sizeof(graph_node *));
|
|
}
|
|
if (gnode->st_header)
|
|
MarkAsUserProcedure(s_new);
|
|
else if (in_routine && (interface_st || (interface_st = getInterface(s_new))))
|
|
{
|
|
SaveInterface(s_new, interface_st);
|
|
MarkAsUserProcedure(s_new);
|
|
}
|
|
//printf(" call site on line %d: %d %s: %d %d\n", stat ? stat->lineNumber() : 0, ATTR_NODE(s_new) ? GRAPHNODE(s_new)->id : -1, s_new->identifier(), s_new->id(), s->id());
|
|
}
|
|
|
|
graph_node *GraphNode(SgSymbol *s, SgStatement *header_st, int flag_new)
|
|
{
|
|
graph_node * gnode;
|
|
graph_node **pnode = new (graph_node *);
|
|
|
|
#if __SPF
|
|
addToCollection(__LINE__, __FILE__, pnode, 1);
|
|
#endif
|
|
|
|
gnode = flag_new == NEW ? NULL : NodeForSymbInGraph(s, header_st);
|
|
if (!gnode)
|
|
gnode = NewGraphNode(s, header_st);
|
|
|
|
*pnode = gnode;
|
|
if (!ATTR_NODE(s)){
|
|
s->addAttribute(GRAPH_NODE, (void*)pnode, sizeof(graph_node *));
|
|
if (deb_reg > 1)
|
|
printf("\n attribute NODE[%d] for %s[%d]\n", GRAPHNODE(s)->id, s->identifier(), s->id());
|
|
}
|
|
return(gnode);
|
|
}
|
|
|
|
graph_node *SearchOriginalSymbolNode(SgSymbol *s, graph_node *first_node)
|
|
{
|
|
graph_node *ndl;
|
|
SgSymbol * s_origin = ORIGINAL_SYMBOL(s);
|
|
for (ndl = first_node; ndl->same_name_next; ndl = ndl->same_name_next)
|
|
if (ndl->file_id == current_file_id && ndl->symb->scope() == s_origin->scope())
|
|
return (ndl);
|
|
return (ndl);
|
|
}
|
|
|
|
graph_node *SearchInternalProcedureName(SgSymbol *s, SgStatement *proc_scope, graph_node *first_node)
|
|
{
|
|
graph_node *ndl;
|
|
for (ndl = first_node; ndl->same_name_next; ndl = ndl->same_name_next)
|
|
{
|
|
if (ndl->type != 2) continue; // is not internal procedure
|
|
if (ndl->file_id == current_file_id && ndl->symb->scope() == proc_scope)
|
|
return (ndl);
|
|
else
|
|
continue;
|
|
}
|
|
if (ndl->type == 2 && ndl->file_id == current_file_id && ndl->symb->scope() == proc_scope)
|
|
return (ndl);
|
|
else
|
|
return (NULL);
|
|
|
|
}
|
|
|
|
graph_node *SearchExternalProcedureName(graph_node *first_node)
|
|
{
|
|
graph_node *ndl;
|
|
for (ndl = first_node; ndl->same_name_next; ndl = ndl->same_name_next)
|
|
if (ndl->type == 1)
|
|
return (ndl);
|
|
if (ndl->type == 1)
|
|
return (ndl);
|
|
else
|
|
return (NULL);
|
|
}
|
|
|
|
graph_node *NodeForSymbInGraph(SgSymbol *s, SgStatement *stheader)
|
|
{
|
|
graph_node *ndl, *node=NULL;
|
|
for (ndl = node_list; ndl; ndl = ndl->next) {
|
|
|
|
if (!strcmp(ndl->name, ORIGINAL_SYMBOL(s)->identifier()))
|
|
{
|
|
if(ndl->same_name_next)
|
|
{
|
|
if(IS_BY_USE(s))
|
|
{
|
|
node = SearchOriginalSymbolNode(s, ndl);
|
|
return (node);
|
|
}
|
|
if( s->attributes() & EXTERNAL_BIT || getInterface(s))
|
|
{
|
|
node = SearchExternalProcedureName(ndl);
|
|
return (node);
|
|
}
|
|
if (cur_func->controlParent()->variant() == GLOBAL)
|
|
node = SearchInternalProcedureName(s, cur_func, ndl);
|
|
else if (cur_func->controlParent()->variant() == MODULE_STMT)
|
|
{
|
|
node = SearchInternalProcedureName(s, cur_func, ndl);
|
|
if (!node)
|
|
node = SearchInternalProcedureName(s, cur_func->controlParent(), ndl);
|
|
}
|
|
if (!node)
|
|
node = SearchExternalProcedureName(ndl);
|
|
}
|
|
else
|
|
node = ndl;
|
|
|
|
return(node);
|
|
}
|
|
}
|
|
return(NULL);
|
|
}
|
|
|
|
graph_node *SameNameNode(char *name)
|
|
{
|
|
graph_node *ndl;
|
|
for (ndl = node_list->next; ndl; ndl = ndl->next)
|
|
if (!strcmp(ndl->name, name))
|
|
return(ndl);
|
|
return (NULL);
|
|
}
|
|
|
|
graph_node *NewGraphNode(SgSymbol *s, SgStatement *header_st)
|
|
{
|
|
graph_node * gnode;
|
|
|
|
gnode = new graph_node;
|
|
gnode->id = ++gcount;
|
|
gnode->next = node_list;
|
|
node_list = gnode;
|
|
gnode->same_name_next = SameNameNode(s->identifier());
|
|
if (gnode->same_name_next)
|
|
gnode->samenamed = gnode->same_name_next->samenamed = 1;
|
|
gnode->file = header_st ? current_file : NULL;
|
|
gnode->file_id = header_st ? current_file_id : -1;
|
|
gnode->st_header = header_st;
|
|
gnode->symb = s;
|
|
gnode->name = new char[strlen(s->identifier()) + 1];
|
|
#if __SPF
|
|
addToCollection(__LINE__, __FILE__, gnode->name, 2);
|
|
#endif
|
|
strcpy(gnode->name, s->identifier());
|
|
gnode->to_called = NULL;
|
|
gnode->from_calling = NULL;
|
|
if (header_st && (header_st->variant() == FUNC_HEDR || header_st->variant() == PROC_HEDR))
|
|
{
|
|
if (header_st->controlParent()->variant() == MODULE_STMT)
|
|
gnode->type = 3;
|
|
else if (header_st->controlParent()->variant() == GLOBAL)
|
|
gnode->type = 1;
|
|
else
|
|
gnode->type = 2;
|
|
}
|
|
else
|
|
gnode->type = 0;
|
|
if (header_st && header_st->expr(2))
|
|
{
|
|
if (header_st->expr(2)->variant() == PURE_OP)
|
|
SYMB_ATTR(s->thesymb) = SYMB_ATTR(s->thesymb) | PURE_BIT;
|
|
else if (header_st->expr(2)->variant() == ELEMENTAL_OP)
|
|
SYMB_ATTR(s->thesymb) = SYMB_ATTR(s->thesymb) | ELEMENTAL_BIT;
|
|
}
|
|
gnode->split = 0;
|
|
gnode->tmplt = 0;
|
|
gnode->clone = 0;
|
|
gnode->count = 0;
|
|
gnode->is_routine = 0;
|
|
gnode->st_interface = NULL;
|
|
//printf("%s --- %d %d\n",gnode->name,gnode->id,gnode->type);
|
|
return(gnode);
|
|
}
|
|
|
|
edge *CreateOutcomingEdge(graph_node *gnode, int inlined)
|
|
{
|
|
edge *out_edge, *edgl;
|
|
//SgSymbol *sunit;
|
|
//sunit = cur_func->symbol();
|
|
|
|
// testing outcoming edge list of current (calling) routine graph-node: cur_node
|
|
for (edgl = cur_node->to_called; edgl; edgl = edgl->next)
|
|
if ((edgl->to->symb == gnode->symb) && (edgl->inlined == inlined)) //there is outcoming edge: [cur_node]->gnode
|
|
return(edgl);
|
|
// creating new edge: [cur_node]->gnode
|
|
out_edge = NewEdge(NULL, gnode, inlined); //NULL -> cur_node
|
|
out_edge->next = cur_node->to_called;
|
|
cur_node->to_called = out_edge;
|
|
return(out_edge);
|
|
}
|
|
|
|
edge *CreateIncomingEdge(graph_node *gnode, int inlined)
|
|
{
|
|
edge *in_edge, *edgl;
|
|
//SgSymbol *sunit;
|
|
//sunit = cur_func->symbol();
|
|
|
|
// testing incoming edge list of called routine graph-node: gnode
|
|
for (edgl = gnode->from_calling; edgl; edgl = edgl->next)
|
|
if ((edgl->from->symb == cur_node->symb) && (edgl->inlined == inlined)) //there is incoming edge: : cur_node->[gnode]
|
|
return(edgl);
|
|
// creating new edge: cur_node->[gnode]
|
|
in_edge = NewEdge(cur_node, NULL, inlined); //NULL -> gnode
|
|
in_edge->next = gnode->from_calling;
|
|
gnode->from_calling = in_edge;
|
|
return(in_edge);
|
|
}
|
|
|
|
edge *NewEdge(graph_node *from, graph_node *to, int inlined)
|
|
{
|
|
edge *nedg;
|
|
nedg = new edge;
|
|
nedg->from = from;
|
|
nedg->to = to;
|
|
nedg->inlined = inlined;
|
|
return(nedg);
|
|
}
|
|
|
|
/**********************************************************************/
|
|
|
|
/* Testing and Help Functions */
|
|
|
|
/**********************************************************************/
|
|
|
|
|
|
int isDummyArgument(SgSymbol *s)
|
|
{
|
|
if (s->thesymb->entry.var_decl.local == IO) // is dummy argument
|
|
return(1);
|
|
else
|
|
return(0);
|
|
}
|
|
|
|
int isHeaderStmtSymbol(SgSymbol *s)
|
|
{
|
|
return(DECL(s) == 1 && (s->variant() == FUNCTION_NAME || s->variant() == PROCEDURE_NAME || s->variant() == PROGRAM_NAME));
|
|
}
|
|
|
|
int isStatementFunction(SgSymbol *s)
|
|
{
|
|
if (DECL(s) == 2)
|
|
//if(s->scope() == cur_func && s->variant()==FUNCTION_NAME)
|
|
return (1); //is statement function symbol
|
|
else return (0);
|
|
}
|
|
|
|
int isHeaderNode(graph_node *gnode)
|
|
{
|
|
//header node represent a "top level" routine:
|
|
//main program, or any subprogram which was called
|
|
//without inline expansion somewhere in the original program
|
|
edge * edgl;
|
|
if (gnode->symb->variant() == PROGRAM_NAME)
|
|
return(1);
|
|
for (edgl = gnode->from_calling; edgl; edgl = edgl->next)
|
|
if (!edgl->inlined) return(1);
|
|
return(0);
|
|
}
|
|
|
|
int isDeadNode(graph_node *gnode)
|
|
{
|
|
// dead node represent a "dead" routine:
|
|
// a subprogram which was not called
|
|
if (gnode->from_calling || gnode->symb->variant() == PROGRAM_NAME)
|
|
return(0);
|
|
else
|
|
return(1);
|
|
}
|
|
|
|
int isNoBodyNode(graph_node *gnode)
|
|
{
|
|
// nobody node represent a "nobody" routine: intrinsic or absent
|
|
|
|
if (gnode->st_header)
|
|
return(0);
|
|
else
|
|
return(1);
|
|
}
|
|
|
|
|
|
graph_node_list *addToNodeList(graph_node_list *pnode, graph_node *gnode)
|
|
{
|
|
// adding the node to the beginning of node list
|
|
// pnode-> gnode -> gnode-> ... -> gnode
|
|
graph_node_list * ndl;
|
|
if (!pnode) {
|
|
pnode = new graph_node_list;
|
|
pnode->node = gnode;
|
|
pnode->next = NULL;
|
|
}
|
|
else {
|
|
ndl = new graph_node_list;
|
|
ndl->node = gnode;
|
|
ndl->next = pnode;
|
|
pnode = ndl;
|
|
}
|
|
return (pnode);
|
|
}
|
|
|
|
graph_node_list *delFromNodeList(graph_node_list *pnode, graph_node *gnode)
|
|
{
|
|
// deleting the node from the node list
|
|
|
|
graph_node_list * ndl, *l;
|
|
if (!pnode) return (NULL);
|
|
if (pnode->node == gnode) return(pnode->next);
|
|
l = pnode;
|
|
for (ndl = pnode->next; ndl; ndl = ndl->next)
|
|
{
|
|
if (ndl->node == gnode)
|
|
{
|
|
l->next = ndl->next;
|
|
return(pnode);
|
|
}
|
|
else
|
|
l = ndl;
|
|
}
|
|
return (pnode);
|
|
}
|
|
|
|
graph_node_list *isInNodeList(graph_node_list *pnode, graph_node *gnode)
|
|
{
|
|
// testing: is there node in the node list
|
|
|
|
graph_node_list * ndl;
|
|
if (!pnode) return (NULL);
|
|
for (ndl = pnode; ndl; ndl = ndl->next)
|
|
{
|
|
if (ndl->node == gnode)
|
|
return(ndl);
|
|
}
|
|
return (NULL);
|
|
}
|
|
|
|
|
|
void PrintGraphNode(graph_node *gnode)
|
|
{
|
|
edge * edgl;
|
|
printf("\n%s(%d)[%d] -> ", gnode->name, gnode->symb->id(), gnode->id);
|
|
for (edgl = gnode->to_called; edgl; edgl = edgl->next)
|
|
printf(" %s(%d)", edgl->to->name, edgl->to->symb->id());
|
|
}
|
|
|
|
void PrintGraphNodeWithAllEdges(graph_node *gnode)
|
|
{
|
|
edge * edgl;
|
|
printf("\n");
|
|
for (edgl = gnode->from_calling; edgl; edgl = edgl->next)
|
|
printf(" %s(%d)", edgl->from->name, edgl->from->symb->id());
|
|
if (!gnode->from_calling)
|
|
printf(" ");
|
|
printf(" ->%s(%d)-> ", gnode->name, gnode->symb->id());
|
|
for (edgl = gnode->to_called; edgl; edgl = edgl->next)
|
|
printf(" %s(%d)", edgl->to->name, edgl->to->symb->id());
|
|
}
|
|
|
|
void PrintWholeGraph()
|
|
{
|
|
graph_node *ndl;
|
|
printf("\n%s\n", "C a l l G r a p h");
|
|
for (ndl = node_list; ndl; ndl = ndl->next)
|
|
PrintGraphNode(ndl);
|
|
printf("\n");
|
|
}
|
|
|
|
void PrintWholeGraph_kind_2()
|
|
{
|
|
graph_node *ndl;
|
|
printf("\n%s\n", "C a l l G r a p h 2");
|
|
for (ndl = node_list; ndl; ndl = ndl->next)
|
|
PrintGraphNodeWithAllEdges(ndl);
|
|
printf("\n");
|
|
}
|
|
|
|
|
|
void DeleteIncomingEdgeFrom(graph_node *gnode, graph_node *from)
|
|
{
|
|
// deleting edge that is incoming to node 'gnode' from node 'from'
|
|
edge *edgl, *ledge;
|
|
ledge = NULL;
|
|
for (edgl = gnode->from_calling; edgl; edgl = edgl->next) {
|
|
if (edgl->from == from) {
|
|
if (deb_reg > 1)
|
|
printf("\n%s(%d)-%s(%d) edge dead ", from->name, from->symb->id(), gnode->name, gnode->symb->id());
|
|
|
|
if (ledge)
|
|
ledge->next = edgl->next;
|
|
else
|
|
gnode->from_calling = edgl->next;
|
|
}
|
|
else
|
|
ledge = edgl;
|
|
}
|
|
}
|
|
|
|
void DeleteOutcomingEdgeTo(graph_node *gnode, graph_node *gto)
|
|
{
|
|
// deleting edge that is outcoming from node 'gnode' to node 'gto'
|
|
edge *edgl, *ledge;
|
|
ledge = NULL;
|
|
for (edgl = gnode->to_called; edgl; edgl = edgl->next) {
|
|
if (edgl->to == gto) {
|
|
if (deb_reg > 1)
|
|
printf("\n%s(%d)-%s(%d) edge empty ", gnode->name, gnode->symb->id(), gto->name, gto->symb->id());
|
|
|
|
if (ledge)
|
|
ledge->next = edgl->next;
|
|
else
|
|
gnode->to_called = edgl->next;
|
|
}
|
|
else
|
|
ledge = edgl;
|
|
}
|
|
}
|
|
|
|
void ScanSymbolTable(SgFile *f)
|
|
{
|
|
SgSymbol *s;
|
|
for (s = f->firstSymbol(); s; s = s->next())
|
|
//if(isHeaderStmtSymbol(s))
|
|
printSymb(s);
|
|
}
|
|
|
|
void ScanTypeTable(SgFile *f)
|
|
{
|
|
SgType *t;
|
|
for (t = f->firstType(); t; t = t->next())
|
|
{ // printf("TYPE[%d] : ", t->id());
|
|
printType(t);
|
|
}
|
|
}
|
|
|
|
void ReseatEdges(graph_node *gnode, graph_node *newnode)
|
|
{//reseat all edges representing inlined calls to gnode to point to newnode
|
|
edge *edgl, *tol, *ledge, *curedg;
|
|
graph_node *from;
|
|
ledge = NULL;
|
|
// for(edgl=gnode->from_calling; edgl; edgl=edgl->next)
|
|
// looking through the incoming edge list of gnode
|
|
edgl = gnode->from_calling;
|
|
while (edgl)
|
|
{
|
|
if (edgl->inlined)
|
|
{
|
|
from = edgl->from;
|
|
// reseating outcoming edge to 'gnode' to point to 'newnode'
|
|
for (tol = from->to_called; tol; tol = tol->next)
|
|
if (tol->to == gnode && tol->inlined)
|
|
{
|
|
tol->to = newnode; break;
|
|
}
|
|
// removing "inlined" incoming edge of gnode
|
|
if (ledge)
|
|
ledge->next = edgl->next;
|
|
else
|
|
gnode->from_calling = edgl->next;
|
|
|
|
curedg = edgl; // set curedg to point at removed edge
|
|
edgl = edgl->next; // to next node of list
|
|
|
|
// adding removed edge to 'newnode'
|
|
curedg->next = newnode->from_calling;
|
|
newnode->from_calling = curedg;
|
|
|
|
}
|
|
else
|
|
{
|
|
ledge = edgl;
|
|
edgl = edgl->next;
|
|
}
|
|
} //end while
|
|
}
|
|
|
|
void CopyOutcomingEdges(graph_node *gnode, graph_node *gnew)
|
|
{
|
|
edge *out_edge, *in_edge, *edgl;
|
|
graph_node *s;
|
|
// looking through the outcoming edge list of gnode
|
|
for (edgl = gnode->to_called; edgl; edgl = edgl->next)
|
|
{
|
|
s = edgl->to; // successor of gnode
|
|
// creating new edge of gnew (copy of edgl)
|
|
out_edge = NewEdge(NULL, edgl->to, edgl->inlined);
|
|
out_edge->next = gnew->to_called;
|
|
gnew->to_called = out_edge;
|
|
// creating new edge of s (successor of gnode)
|
|
in_edge = NewEdge(gnew, NULL, edgl->inlined);
|
|
in_edge->next = s->from_calling;
|
|
s->from_calling = in_edge;
|
|
}
|
|
return;
|
|
}
|
|
|
|
void CopyIncomingEdges(graph_node *gnode, graph_node *gnew)
|
|
{
|
|
edge *in_edge, *out_edge, *edgl;
|
|
graph_node *p;
|
|
// looking through the incoming edge list of gnode
|
|
for (edgl = gnode->from_calling; edgl; edgl = edgl->next)
|
|
{
|
|
p = edgl->from; // predecessor of gnode
|
|
// creating new edge of gnew (copy of edgl)
|
|
in_edge = NewEdge(edgl->from, NULL, edgl->inlined);
|
|
in_edge->next = gnew->from_calling;
|
|
gnew->from_calling = in_edge;
|
|
// creating new edge of p (predecessor of gnode)
|
|
out_edge = NewEdge(NULL, gnew, edgl->inlined);
|
|
out_edge->next = p->to_called;
|
|
p->to_called = out_edge;
|
|
|
|
}
|
|
return;
|
|
}
|
|
|
|
void printSymb(SgSymbol *s)
|
|
{
|
|
const char *head;
|
|
head = isHeaderStmtSymbol(s) ? "HEADER " : " ";
|
|
printf("SYMB[%3d] scope=STMT[%3d] : %s %s", s->id(), (s->scope()) ? (s->scope())->id() : -1, s->identifier(), head);
|
|
printType(s->type());
|
|
if(IS_BY_USE(s))
|
|
printf(" BY_USE %s", ORIGINAL_SYMBOL(s)->scope()->symbol()->identifier());
|
|
if(ATTR_NODE(s))
|
|
printf(" GRAPHNODE %d", GRAPHNODE(s)->id);
|
|
printf("\n");
|
|
}
|
|
|
|
void printType(SgType *t)
|
|
{
|
|
SgArrayType *arrayt;
|
|
|
|
if (!t) {
|
|
printf("no type "); return;
|
|
}
|
|
else printf("TYPE[%d]:", t->id());
|
|
if ((arrayt = isSgArrayType(t)) != 0)
|
|
{
|
|
SgExpression *e = arrayt->getDimList();
|
|
if (!e)
|
|
printf(" dimension() ");
|
|
else
|
|
printf(" dimension(%s) ", UnparseExpr(arrayt->getDimList()));
|
|
/*
|
|
int i;
|
|
int n = arrayt->dimension();
|
|
printf("dimension(");
|
|
for(i = 0; i < n; i++)
|
|
{ if(arrayt->sizeInDim(i))
|
|
{ printf("%s", UnparseExpr(arrayt->sizeInDim(i))); //(arrayt->sizeInDim(i))->unparsestdout();
|
|
if(i < n-1) printf(", ");
|
|
}
|
|
}
|
|
printf(") ");
|
|
*/
|
|
}
|
|
else
|
|
{
|
|
switch (t->variant())
|
|
{
|
|
case T_INT: printf("integer "); break;
|
|
case T_FLOAT: printf("real "); break;
|
|
case T_DOUBLE: printf("double precision "); break;
|
|
case T_CHAR: printf("character "); break;
|
|
case T_STRING: printf("Character ");
|
|
UnparseLLND(TYPE_RANGES(t->thetype));
|
|
/*if(t->length()) printf("[%d]",t->length()->variant());*/
|
|
/*((SgArrayType *) t)->getDimList()->unparsestdout();*/
|
|
break;
|
|
case T_BOOL: printf("logical "); break;
|
|
case T_COMPLEX: printf("complex "); break;
|
|
case T_DCOMPLEX: printf("double complex "); break;
|
|
|
|
default: break;
|
|
}
|
|
}
|
|
|
|
if (t->hasBaseType())
|
|
{
|
|
printf("of ");
|
|
printType(t->baseType());
|
|
}
|
|
}
|
|
|
|
#undef NEW |