parser.c

Go to the documentation of this file.

#ifdef HAVE_CONFIG_H
    #include "pips_config.h"
#endif
#include "defines-local.h"
#include <ctype.h> // for toupper
#include "workspace-util.h"  // for compilation_unit_of_module()
#include "prettyprint.h" // for print_statement()
extern void step_bison_parse(pragma pgm, statement stmt);
extern void step_comment2pragma_handle(statement stmt);
 
static statement current_statement = statement_undefined;
static pragma current_pragma = pragma_undefined;
static int current_transform = -1;
 
static void print_step_blocks();
static step_directive new_step_directive(statement directive_stmt, int type,  string s);
static void reset_step_transform();
static step_directive get_current_step_directive(bool open);
 
 
/*
  Stack of blocks/sequences used during parsing to construct sequences
  of statements associated to a directive.
  Fundamental for Fortran programs.
*/
 
DEFINE_LOCAL_STACK(step_blocks, sequence);
 
/* 
 *
 *
 *
 *
 * Functions called from the BISON parser 
 *
 *
 *
 *
 */
 
void set_current_transform(int transform)
{
  current_transform = transform;
}
 
void insert_optional_pragma(int type)
{
  statement new_stmt = make_plain_continue_statement();
 
  switch (type)
    {
    case STEP_DO:
      add_pragma_str_to_statement(new_stmt, "ompenddo\n", true);
      break;
    case STEP_PARALLEL_DO:
      add_pragma_str_to_statement(new_stmt, "ompendparalleldo\n", true);
      break;
    default:
      pips_user_error("Unexpected pragma type %d\n", type);
    }
  statement parent_stmt = (statement)gen_get_ancestor(statement_domain, current_statement);
  pips_assert("parent", parent_stmt != NULL);
  pips_assert("block", statement_block_p(parent_stmt));
  gen_insert_after(new_stmt, current_statement, statement_block(parent_stmt));
}
 
entity entity_from_user_name(string name)
{
  entity e = entity_undefined;
  
  pips_debug(1, "begin\n");
 
  if(fortran_module_p(get_current_module_entity()))
    {
      /* passage de name a NAME */
      size_t i;
      for (i=0; i<strlen(name); i++)
        name[i]=toupper(name[i]);
 
      string full_name = strdup(concatenate(entity_user_name(get_current_module_entity()), MODULE_SEP_STRING, name, NULL));
      e = gen_find_tabulated(full_name, entity_domain);
      if (entity_undefined_p(e))
        pips_user_error("\nFortran entity \"%s\" not found\n", full_name);
      free(full_name);
    }
  else if (c_module_p(get_current_module_entity()))
    {
      /* determiner le nom avec le bon scope... */
      statement stmt_declaration = current_statement;
      pips_debug(4,"##### ENTITY DECL #####\n");
      while (entity_undefined_p(e) && stmt_declaration)
        {
          FOREACH(entity, ee, statement_declarations(stmt_declaration))
            {
              pips_debug(4, "entity decl : \"%s\"\n", entity_name(ee));
              if (strcmp(name, entity_user_name(ee)) == 0)
                {
                  e = ee;
                  break;
                }
            }
          stmt_declaration = (statement)gen_get_ancestor(statement_domain, stmt_declaration);
        }
 
      if (entity_undefined_p(e))
        {
          FOREACH(entity, ee, code_declarations(entity_code(get_current_module_entity())))
            {
              pips_debug(4, "entity decl : \"%s\"\n", entity_name(ee));
              if (strcmp(name, entity_user_name(ee)) == 0)
                {
                  e = ee;
                  break;
                }
            }
        }
      if (entity_undefined_p(e))
        {
          string cu = compilation_unit_of_module(get_current_module_name());
          string full_name = strdup(concatenate(cu, MODULE_SEP_STRING, name, NULL));
          e = gen_find_tabulated(full_name, entity_domain);
          free(full_name);
        }
     if (entity_undefined_p(e))
        {
          string full_name = strdup(concatenate(TOP_LEVEL_MODULE_NAME, MODULE_SEP_STRING, name, NULL));
          e = gen_find_tabulated(full_name, entity_domain);
          free(full_name);
        }
 
      if (entity_undefined_p(e))
        pips_user_error("\nC Entity \"%s\" not found\n", name);
    }
 
  pips_debug(1, "end\n");;
  return e;
}
 
void remove_old_pragma(void)
{
  pips_assert("statement defined", !statement_undefined_p(current_statement));
  pips_assert("pragma defined", !pragma_undefined_p(current_pragma));
 
  extensions es = statement_extensions(current_statement);
 
  list el = extensions_extension(es);
 
  extensions_extension(es) = NIL;
  FOREACH(EXTENSION, e, el)
    {
      pragma p=extension_pragma(e);
      if (p != current_pragma)
        extensions_extension(es) = gen_extension_cons(e, extensions_extension(es));
    }
 
  extensions_extension(es) = gen_nreverse(extensions_extension(es));
}
 
step_directive begin_omp_construct(int type, string s)
{
  statement directive_stmt;
 
  pips_debug(1,"begin type = %d, str = %s\n", type, s);
 
  directive_stmt = current_statement;
 
  if(fortran_module_p(get_current_module_entity()))
    {
      switch(type)
        {
        case STEP_DO:
        case STEP_PARALLEL_DO:
          pips_assert("loop statement", statement_loop_p(directive_stmt)||statement_forloop_p(directive_stmt));
          insert_optional_pragma(type);
          _FALLTHROUGH_; // is that so?
        case STEP_PARALLEL:
        case STEP_MASTER:
        case STEP_SINGLE:
        case STEP_BARRIER:
          directive_stmt = make_empty_block_statement();
          break;
        case STEP_THREADPRIVATE:
          directive_stmt = make_empty_block_statement();
          break;
        default:
          pips_user_error("unknown directive type %d\n", type);
          break;
        }
    }
  else if (c_module_p(get_current_module_entity()))
    {
      switch(type)
        {
        case STEP_DO:
        case STEP_PARALLEL_DO:
          {
            statement new_stmt;
            pips_assert("loop statement", statement_loop_p(directive_stmt)||statement_forloop_p(directive_stmt));
            pips_debug(2,"Block conversion (C)\n");
 
            new_stmt = instruction_to_statement(statement_instruction(directive_stmt));
 
            move_statement_attributes(directive_stmt, new_stmt);
            statement_label(directive_stmt) = entity_empty_label();
            statement_comments(directive_stmt) = empty_comments;
            statement_declarations(directive_stmt) = NIL;
            statement_decls_text(directive_stmt) = NULL;
            statement_extensions(directive_stmt) = empty_extensions();
            statement_instruction(directive_stmt) = make_instruction_block(CONS(STATEMENT, new_stmt, NIL));
          }
        case STEP_PARALLEL:
        case STEP_MASTER:
        case STEP_SINGLE:
          /* In C, these OpenMP pragmas are already supported by blocks: no block conversion needed */
          break;
        case STEP_BARRIER:
          directive_stmt = make_empty_block_statement();
          break;
        case STEP_THREADPRIVATE:
          directive_stmt = make_empty_block_statement();
          break;
        default:
          pips_user_error("unknown directive type %d\n", type);
          break;
        }
    }
  else
    pips_user_error("language not supported");
 
  step_directive drt = new_step_directive(directive_stmt, type, s);
 
  if(fortran_module_p(get_current_module_entity()))
    {
      step_blocks_push(statement_sequence(directive_stmt));
    }
 
  pips_debug(1,"end drt = %p\n", drt);
  return drt;
}
 
/*
 * Function used for Fortran programs
 *
 *
  -> substitution dans une sequence : I1,...,Ii+OMPpragma,... , Ij-1, Ij+OMPpragma, ..., In en :
  I1,..., Block(Ii, ..., Ij-1 )+STEPpragma, Ij..., In
*/
step_directive end_omp_construct(int type)
{
  step_directive drt;
 
  pips_debug(1,"begin type = %d\n", type);
 
  drt = step_directive_undefined;
  if(fortran_module_p(get_current_module_entity()))
    {
      switch(type)
        {
        case STEP_DO:
        case STEP_PARALLEL_DO:
          {
            sequence current_block;
            statement last_stmt;
 
 
            current_block = step_blocks_head();
            last_stmt = STATEMENT(CAR(sequence_statements(current_block)));
            /* suppression du CONTINUE portant le pragma optionnel dans le futur block */
            while (empty_statement_or_labelless_continue_p(last_stmt))
              {
                pips_debug(2,"POP current_block");
                POP(sequence_statements(current_block));
                last_stmt = STATEMENT(CAR(sequence_statements(current_block)));
              }
            if(step_directives_bound_p(last_stmt))
              {
                drt = step_directives_load(last_stmt);
                if (step_directive_type(drt) != type)
                  pips_user_error("\nDirective end-loop not well formed\n");
                else
                  pips_debug(2,"loop directive already closed\n");
              }
            else if (!statement_loop_p(last_stmt))
              pips_user_error("\nDirective end-loop after a no-loop statement\n");
          }
        default:
          break;
        }
 
      if(step_directive_undefined_p(drt))
        {
          drt = get_current_step_directive(true);
          
          if (step_directive_undefined_p(drt) || step_directive_type(drt) != type)
            pips_user_error("\nDirective not well formed\n");
          
          int size = step_blocks_size();
          sequence new_seq = step_blocks_pop();
          pips_debug(2,"pop block directive\n");
          pips_debug(2, "block_stack size :%d\t new_seq_length=%d\n", size, (int)gen_length(sequence_statements(new_seq)));
          
          statement directive_stmt = step_directive_block(drt);
          sequence_statements(statement_sequence(directive_stmt)) = gen_nreverse(statement_block(directive_stmt));
        }
    }
 
  pips_debug(1, "end drt = %p\n", drt);
  return drt;
}
 
/* 
 *
 *
 *
 *
 * Functions used for gen_multi_recurse 
 *
 *
 *
 *
 */
static step_directive new_step_directive(statement directive_stmt, int type,  string s)
{
  step_directive drt;
  sequence current_block;
 
  pips_debug(1,"begin directive_stmt = %p, type = %d, str = %s\n", directive_stmt, type, s);
 
  if(!statement_block_p(directive_stmt))
    {
      pips_debug(0,"Directive type : %s\n", s);
      STEP_DEBUG_STATEMENT(0, "on statement", directive_stmt);
      pips_assert("block statement", false);
    }
 
 
  pips_debug(2, "make_step_directive\n");
  drt = make_step_directive(type, directive_stmt,  CONS(STEP_CLAUSE, make_step_clause_transformation(current_transform), NIL));
  step_directives_store(directive_stmt, drt);
  add_pragma_str_to_statement(directive_stmt, strdup(concatenate(STEP_SENTINELLE, s, NULL)), false);
 
  current_block = step_blocks_head();
  sequence_statements(current_block) = CONS(STATEMENT, directive_stmt, sequence_statements(current_block));
 
  reset_step_transform();
 
  pips_debug(1,"end drt = %p\n", drt);
  return drt;
}
 
 
static void print_step_blocks()
{
  int size;
  int head_len;
 
  size = step_blocks_size();
  head_len = size?gen_length(sequence_statements(step_blocks_head())):0;
  pips_debug(4, "size = %d, head_length = %d\n", size, head_len);
}
 
static void reset_step_transform()
{
  const char* transformation = get_string_property("STEP_DEFAULT_TRANSFORMATION");
 
  if (strncasecmp(transformation, STEP_DEFAULT_TRANSFORMATION_MPI_TXT, strlen(STEP_DEFAULT_TRANSFORMATION_MPI_TXT))==0)
    current_transform = STEP_TRANSFORMATION_MPI;
  else if (strncasecmp(transformation, STEP_DEFAULT_TRANSFORMATION_HYBRID_TXT, strlen(STEP_DEFAULT_TRANSFORMATION_HYBRID_TXT))==0)
    current_transform = STEP_TRANSFORMATION_HYBRID;
  else if (strncasecmp(transformation, STEP_DEFAULT_TRANSFORMATION_OMP_TXT, strlen(STEP_DEFAULT_TRANSFORMATION_OMP_TXT))==0)
    current_transform = STEP_TRANSFORMATION_OMP;
  else
    current_transform = STEP_TRANSFORMATION_SEQ;
 
  pips_debug(2, "step transform type : %d\n", current_transform);
}
 
/*
  Le statement correspondant a la directive courante est en debut de sequence
  (l'ordre des statements dans les séquences est inversé dans la pile step_blocks)
*/
static step_directive get_current_step_directive(bool open)
{
  if(open && fortran_module_p(get_current_module_entity()))
    {
      pips_assert("stack size", step_blocks_size() > 1);
 
      sequence parent_block = step_blocks_nth(2);
 
      statement last_stmt = STATEMENT(CAR(sequence_statements(parent_block)));
      STEP_DEBUG_STATEMENT(1, "last_stmt 1", last_stmt);
 
      pips_assert("directive", step_directives_bound_p(last_stmt));
      pips_assert("sequence", statement_sequence_p(last_stmt));
      pips_assert("same sequence", statement_sequence(last_stmt)==step_blocks_head());
 
      return step_directives_load(last_stmt);
    }
  else if(!step_blocks_empty_p())
    {
      sequence current_block = step_blocks_head();
 
      if (!ENDP(sequence_statements(current_block)))
        {
          statement last_stmt = STATEMENT(CAR(sequence_statements(current_block)));
          STEP_DEBUG_STATEMENT(1,"last_stmt 2",last_stmt);
 
          if(step_directives_bound_p(last_stmt))
            return step_directives_load(last_stmt);
        }
    }
 
  return step_directive_undefined;
}
 
/*
 * pragma analysis 
 */
 
static void step_pragma_handle(statement stmt)
{
  pips_debug(1,"begin\n");
 
  pips_assert("statement undefined", statement_undefined_p(current_statement));
  pips_assert("pragma undefined", pragma_undefined_p(current_pragma));
 
  current_statement = stmt;
 
  reset_step_transform();
 
  STEP_DEBUG_STATEMENT(1, "begin stmt", current_statement);
  pips_debug(1,"end stmt\n");
 
  FOREACH(EXTENSION, e, extensions_extension(statement_extensions(stmt)))
    {
      pips_debug(2,"for each extension\n");
      current_pragma = extension_pragma(e);
      if (pragma_string_p(current_pragma))
        {
          step_bison_parse(current_pragma, current_statement);
        }
    }
  current_pragma = pragma_undefined;
  current_statement = statement_undefined;
  pips_debug(1,"end\n");
}
 
static bool statement_filter(statement stmt)
{
  pips_debug(1,"begin\n");
  STEP_DEBUG_STATEMENT(2,"begin in stmt",stmt);
  pips_debug(2,"end in stmt\n");
 
  print_step_blocks();
 
  /* For fortran programs, converting comments into pragmas */
  if(fortran_module_p(get_current_module_entity()))
    step_comment2pragma_handle(stmt);
 
  if (step_blocks_empty_p())
    {
      pips_debug(2,"empty step_blocks: nothing to do in the module body\n");
    }
  else
    {
      statement parent_stmt;
 
      pips_debug(2,"Analysing and handling pragmas\n");
 
      parent_stmt = (statement)gen_get_ancestor(statement_domain, stmt);
      pips_assert("parent", parent_stmt != NULL);
 
      if (!ENDP(extensions_extension(statement_extensions(stmt))) &&
          !statement_block_p(parent_stmt))
        {
          /*
            On transforme un statement portant un pragma en block s'il ne l'etait pas deja.
            L'analyse aura lieu lors du parcours du block nouvellement cree
          */
          pips_debug(2,"Block conversion (Fortran)\n");
 
          statement new_stmt = instruction_to_statement(statement_instruction(stmt));
          move_statement_attributes(stmt, new_stmt);
 
          statement_label(stmt) = entity_empty_label();
          statement_comments(stmt) = empty_comments;
          statement_declarations(stmt) = NIL;
          statement_decls_text(stmt) = NULL;
          statement_extensions(stmt) = empty_extensions();
 
          statement_instruction(stmt) = make_instruction_block(CONS(STATEMENT, new_stmt, NIL));
        }
      else
        {
          step_pragma_handle(stmt);
 
          /*
            Si dans une sequence (== block), on met a jour le block courant
            Si c'est une directive, elle a ete ajoute a son identification
          */
          if(!step_directives_bound_p(stmt) && statement_block_p(parent_stmt))
            {
              sequence current_block = step_blocks_head();
              pips_debug(2,"ADD stmt to the current block\n");
              sequence_statements(current_block)=CONS(STATEMENT, stmt,
                                                      sequence_statements(current_block));
            }
          else
            {
              pips_debug(2,"NOT added to current step_blocks\n");
            }
        }
    }
 
  STEP_DEBUG_STATEMENT(2,"begin out stmt",stmt);
  pips_debug(2,"end out stmt\n");
  pips_debug(1,"end\n");
  return true;
}
 
static void statement_rewrite(statement stmt)
{
  pips_debug(1,"begin\n");
  STEP_DEBUG_STATEMENT(5, "begin in stmt", stmt);
  pips_debug(5, "end in stmt");
 
  print_step_blocks();
 
  STEP_DEBUG_STATEMENT(5, "begin out stmt", stmt);
  pips_debug(5, "end out stmt");
 
  pips_debug(1,"end\n");
  return;
}
 
static bool sequence_filter(sequence __attribute__ ((unused)) seq)
{
  pips_debug(1,"begin\n");
  pips_debug(2,"PUSH empty sequence on step_blocks\n");
  step_blocks_push(make_sequence(NIL));
  
  print_step_blocks();
  pips_debug(1,"end\n");
  return true;
}
 
static void sequence_rewrite(sequence seq)
{
  int size;
  sequence previous_block;
 
  pips_debug(1,"begin\n");
 
  size = step_blocks_size();
  previous_block = step_blocks_nth(2);
 
  if(previous_block && !sequence_undefined_p(previous_block))
    {
      statement last_stmt = STATEMENT(CAR(sequence_statements(previous_block)));
      if (fortran_module_p(get_current_module_entity()) && step_directives_bound_p(last_stmt))
        pips_user_error("\nDirective not well formed\n");
    }
 
  sequence new_seq = step_blocks_pop();
  pips_debug(2, "POP step_blocks\n");
  pips_debug(2, "block_stack size :%d\t new_seq_length=%d\n", size, (int)gen_length(sequence_statements(new_seq)));
 
  gen_free_list(sequence_statements(seq));
  sequence_statements(seq) = gen_nreverse(sequence_statements(new_seq));
  sequence_statements(new_seq) = NIL;
  free_sequence(new_seq);
 
  pips_debug(1,"end\n");
  return;
}
 
static void step_directive_parser(statement body)
{
  /* For fortran programs, converting comments into pragmas into declaration txt */
  if(fortran_module_p(get_current_module_entity()))
    step_comment2pragma_handle(statement_undefined);
 
  make_step_blocks_stack();
 
  // where the OpenMP constructs are identified
  gen_multi_recurse(body,
                    statement_domain, statement_filter, statement_rewrite,
                    sequence_domain, sequence_filter, sequence_rewrite,
                    NULL);
 
  free_step_blocks_stack();
}
 
bool step_parser(const char* module_name)
{
  debug_on("STEP_PARSER_DEBUG_LEVEL");
  pips_debug(1, "%d module_name = %s\n", __LINE__, module_name);
 
  statement stmt = (statement) db_get_memory_resource(DBR_CODE, module_name, true);
  stmt = make_block_statement(CONS(STATEMENT, stmt, NIL));
 
  set_current_module_entity(local_name_to_top_level_entity(module_name));
 
  step_directives_init(1);
 
  step_directive_parser(stmt);
 
  ifdebug(1)
    {
      step_directives_print();
    }
 
  step_directives_save();
  reset_current_module_entity();
 
 
  module_reorder(stmt);
  if(ordering_to_statement_initialized_p())
    reset_ordering_to_statement();
 
  DB_PUT_MEMORY_RESOURCE(DBR_CODE, module_name, stmt);
 
  pips_debug(1, "End step_parser\n");
  debug_off();
 
  return true;
}