Subversion Repositories openrisc

/* Backend function setup

   Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010,

   2011, 2012

   Free Software Foundation, Inc.

   Contributed by Paul Brook

This file is part of GCC.

GCC is free software; you can redistribute it and/or modify it under

the terms of the GNU General Public License as published by the Free

Software Foundation; either version 3, or (at your option) any later

version.

GCC is distributed in the hope that it will be useful, but WITHOUT ANY

WARRANTY; without even the implied warranty of MERCHANTABILITY or

FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License

for more details.

You should have received a copy of the GNU General Public License

along with GCC; see the file COPYING3.  If not see

<http://www.gnu.org/licenses/>.  */

/* trans-decl.c -- Handling of backend function and variable decls, etc */

#include "config.h"

#include "system.h"

#include "coretypes.h"

#include "tm.h"

#include "tree.h"

#include "tree-dump.h"

#include "gimple.h"     /* For create_tmp_var_raw.  */

#include "ggc.h"

#include "diagnostic-core.h"    /* For internal_error.  */

#include "toplev.h"     /* For announce_function.  */

#include "output.h"     /* For decl_default_tls_model.  */

#include "target.h"

#include "function.h"

#include "flags.h"

#include "cgraph.h"

#include "debug.h"

#include "gfortran.h"

#include "pointer-set.h"

#include "constructor.h"

#include "trans.h"

#include "trans-types.h"

#include "trans-array.h"

#include "trans-const.h"

/* Only for gfc_trans_code.  Shouldn't need to include this.  */

#include "trans-stmt.h"

#define MAX_LABEL_VALUE 99999

/* Holds the result of the function if no result variable specified.  */

static GTY(()) tree current_fake_result_decl;

static GTY(()) tree parent_fake_result_decl;

/* Holds the variable DECLs for the current function.  */

static GTY(()) tree saved_function_decls;

static GTY(()) tree saved_parent_function_decls;

static struct pointer_set_t *nonlocal_dummy_decl_pset;

static GTY(()) tree nonlocal_dummy_decls;

/* Holds the variable DECLs that are locals.  */

static GTY(()) tree saved_local_decls;

/* The namespace of the module we're currently generating.  Only used while

   outputting decls for module variables.  Do not rely on this being set.  */

static gfc_namespace *module_namespace;

/* The currently processed procedure symbol.  */

static gfc_symbol* current_procedure_symbol = NULL;

/* With -fcoarray=lib: For generating the registering call

   of static coarrays.  */

static bool has_coarray_vars;

static stmtblock_t caf_init_block;

/* List of static constructor functions.  */

tree gfc_static_ctors;

/* Function declarations for builtin library functions.  */

tree gfor_fndecl_pause_numeric;

tree gfor_fndecl_pause_string;

tree gfor_fndecl_stop_numeric;

tree gfor_fndecl_stop_numeric_f08;

tree gfor_fndecl_stop_string;

tree gfor_fndecl_error_stop_numeric;

tree gfor_fndecl_error_stop_string;

tree gfor_fndecl_runtime_error;

tree gfor_fndecl_runtime_error_at;

tree gfor_fndecl_runtime_warning_at;

tree gfor_fndecl_os_error;

tree gfor_fndecl_generate_error;

tree gfor_fndecl_set_args;

tree gfor_fndecl_set_fpe;

tree gfor_fndecl_set_options;

tree gfor_fndecl_set_convert;

tree gfor_fndecl_set_record_marker;

tree gfor_fndecl_set_max_subrecord_length;

tree gfor_fndecl_ctime;

tree gfor_fndecl_fdate;

tree gfor_fndecl_ttynam;

tree gfor_fndecl_in_pack;

tree gfor_fndecl_in_unpack;

tree gfor_fndecl_associated;

/* Coarray run-time library function decls.  */

tree gfor_fndecl_caf_init;

tree gfor_fndecl_caf_finalize;

tree gfor_fndecl_caf_register;

tree gfor_fndecl_caf_deregister;

tree gfor_fndecl_caf_critical;

tree gfor_fndecl_caf_end_critical;

tree gfor_fndecl_caf_sync_all;

tree gfor_fndecl_caf_sync_images;

tree gfor_fndecl_caf_error_stop;

tree gfor_fndecl_caf_error_stop_str;

/* Coarray global variables for num_images/this_image.  */

tree gfort_gvar_caf_num_images;

tree gfort_gvar_caf_this_image;

/* Math functions.  Many other math functions are handled in

   trans-intrinsic.c.  */

gfc_powdecl_list gfor_fndecl_math_powi[4][3];

tree gfor_fndecl_math_ishftc4;

tree gfor_fndecl_math_ishftc8;

tree gfor_fndecl_math_ishftc16;

/* String functions.  */

tree gfor_fndecl_compare_string;

tree gfor_fndecl_concat_string;

tree gfor_fndecl_string_len_trim;

tree gfor_fndecl_string_index;

tree gfor_fndecl_string_scan;

tree gfor_fndecl_string_verify;

tree gfor_fndecl_string_trim;

tree gfor_fndecl_string_minmax;

tree gfor_fndecl_adjustl;

tree gfor_fndecl_adjustr;

tree gfor_fndecl_select_string;

tree gfor_fndecl_compare_string_char4;

tree gfor_fndecl_concat_string_char4;

tree gfor_fndecl_string_len_trim_char4;

tree gfor_fndecl_string_index_char4;

tree gfor_fndecl_string_scan_char4;

tree gfor_fndecl_string_verify_char4;

tree gfor_fndecl_string_trim_char4;

tree gfor_fndecl_string_minmax_char4;

tree gfor_fndecl_adjustl_char4;

tree gfor_fndecl_adjustr_char4;

tree gfor_fndecl_select_string_char4;

/* Conversion between character kinds.  */

tree gfor_fndecl_convert_char1_to_char4;

tree gfor_fndecl_convert_char4_to_char1;

/* Other misc. runtime library functions.  */

tree gfor_fndecl_size0;

tree gfor_fndecl_size1;

tree gfor_fndecl_iargc;

/* Intrinsic functions implemented in Fortran.  */

tree gfor_fndecl_sc_kind;

tree gfor_fndecl_si_kind;

tree gfor_fndecl_sr_kind;

/* BLAS gemm functions.  */

tree gfor_fndecl_sgemm;

tree gfor_fndecl_dgemm;

tree gfor_fndecl_cgemm;

tree gfor_fndecl_zgemm;

static void

gfc_add_decl_to_parent_function (tree decl)

{

  gcc_assert (decl);

  DECL_CONTEXT (decl) = DECL_CONTEXT (current_function_decl);

  DECL_NONLOCAL (decl) = 1;

  DECL_CHAIN (decl) = saved_parent_function_decls;

  saved_parent_function_decls = decl;

}

void

gfc_add_decl_to_function (tree decl)

{

  gcc_assert (decl);

  TREE_USED (decl) = 1;

  DECL_CONTEXT (decl) = current_function_decl;

  DECL_CHAIN (decl) = saved_function_decls;

  saved_function_decls = decl;

}

static void

add_decl_as_local (tree decl)

{

  gcc_assert (decl);

  TREE_USED (decl) = 1;

  DECL_CONTEXT (decl) = current_function_decl;

  DECL_CHAIN (decl) = saved_local_decls;

  saved_local_decls = decl;

}

/* Build a  backend label declaration.  Set TREE_USED for named labels.

   The context of the label is always the current_function_decl.  All

   labels are marked artificial.  */

tree

gfc_build_label_decl (tree label_id)

{

  /* 2^32 temporaries should be enough.  */

  static unsigned int tmp_num = 1;

  tree label_decl;

  char *label_name;

  if (label_id == NULL_TREE)

    {

      /* Build an internal label name.  */

      ASM_FORMAT_PRIVATE_NAME (label_name, "L", tmp_num++);

      label_id = get_identifier (label_name);

    }

  else

    label_name = NULL;

  /* Build the LABEL_DECL node. Labels have no type.  */

  label_decl = build_decl (input_location,

                           LABEL_DECL, label_id, void_type_node);

  DECL_CONTEXT (label_decl) = current_function_decl;

  DECL_MODE (label_decl) = VOIDmode;

  /* We always define the label as used, even if the original source

     file never references the label.  We don't want all kinds of

     spurious warnings for old-style Fortran code with too many

     labels.  */

  TREE_USED (label_decl) = 1;

  DECL_ARTIFICIAL (label_decl) = 1;

  return label_decl;

}

/* Set the backend source location of a decl.  */

void

gfc_set_decl_location (tree decl, locus * loc)

{

  DECL_SOURCE_LOCATION (decl) = loc->lb->location;

}

/* Return the backend label declaration for a given label structure,

   or create it if it doesn't exist yet.  */

tree

gfc_get_label_decl (gfc_st_label * lp)

{

  if (lp->backend_decl)

    return lp->backend_decl;

  else

    {

      char label_name[GFC_MAX_SYMBOL_LEN + 1];

      tree label_decl;

      /* Validate the label declaration from the front end.  */

      gcc_assert (lp != NULL && lp->value <= MAX_LABEL_VALUE);

      /* Build a mangled name for the label.  */

      sprintf (label_name, "__label_%.6d", lp->value);

      /* Build the LABEL_DECL node.  */

      label_decl = gfc_build_label_decl (get_identifier (label_name));

      /* Tell the debugger where the label came from.  */

      if (lp->value <= MAX_LABEL_VALUE) /* An internal label.  */

        gfc_set_decl_location (label_decl, &lp->where);

      else

        DECL_ARTIFICIAL (label_decl) = 1;

      /* Store the label in the label list and return the LABEL_DECL.  */

      lp->backend_decl = label_decl;

      return label_decl;

    }

}

/* Convert a gfc_symbol to an identifier of the same name.  */

static tree

gfc_sym_identifier (gfc_symbol * sym)

{

  if (sym->attr.is_main_program && strcmp (sym->name, "main") == 0)

    return (get_identifier ("MAIN__"));

  else

    return (get_identifier (sym->name));

}

/* Construct mangled name from symbol name.  */

static tree

gfc_sym_mangled_identifier (gfc_symbol * sym)

{

  char name[GFC_MAX_MANGLED_SYMBOL_LEN + 1];

  /* Prevent the mangling of identifiers that have an assigned

     binding label (mainly those that are bind(c)).  */

  if (sym->attr.is_bind_c == 1 && sym->binding_label)

    return get_identifier (sym->binding_label);

  if (sym->module == NULL)

    return gfc_sym_identifier (sym);

  else

    {

      snprintf (name, sizeof name, "__%s_MOD_%s", sym->module, sym->name);

      return get_identifier (name);

    }

}

/* Construct mangled function name from symbol name.  */

static tree

gfc_sym_mangled_function_id (gfc_symbol * sym)

{

  int has_underscore;

  char name[GFC_MAX_MANGLED_SYMBOL_LEN + 1];

  /* It may be possible to simply use the binding label if it's

     provided, and remove the other checks.  Then we could use it

     for other things if we wished.  */

  if ((sym->attr.is_bind_c == 1 || sym->attr.is_iso_c == 1) &&

      sym->binding_label)

    /* use the binding label rather than the mangled name */

    return get_identifier (sym->binding_label);

  if (sym->module == NULL || sym->attr.proc == PROC_EXTERNAL

      || (sym->module != NULL && (sym->attr.external

            || sym->attr.if_source == IFSRC_IFBODY)))

    {

      /* Main program is mangled into MAIN__.  */

      if (sym->attr.is_main_program)

        return get_identifier ("MAIN__");

      /* Intrinsic procedures are never mangled.  */

      if (sym->attr.proc == PROC_INTRINSIC)

        return get_identifier (sym->name);

      if (gfc_option.flag_underscoring)

        {

          has_underscore = strchr (sym->name, '_') != 0;

          if (gfc_option.flag_second_underscore && has_underscore)

            snprintf (name, sizeof name, "%s__", sym->name);

          else

            snprintf (name, sizeof name, "%s_", sym->name);

          return get_identifier (name);

        }

      else

        return get_identifier (sym->name);

    }

  else

    {

      snprintf (name, sizeof name, "__%s_MOD_%s", sym->module, sym->name);

      return get_identifier (name);

    }

}

void

gfc_set_decl_assembler_name (tree decl, tree name)

{

  tree target_mangled = targetm.mangle_decl_assembler_name (decl, name);

  SET_DECL_ASSEMBLER_NAME (decl, target_mangled);

}

/* Returns true if a variable of specified size should go on the stack.  */

int

gfc_can_put_var_on_stack (tree size)

{

  unsigned HOST_WIDE_INT low;

  if (!INTEGER_CST_P (size))

    return 0;

  if (gfc_option.flag_max_stack_var_size < 0)

    return 1;

  if (TREE_INT_CST_HIGH (size) != 0)

    return 0;

  low = TREE_INT_CST_LOW (size);

  if (low > (unsigned HOST_WIDE_INT) gfc_option.flag_max_stack_var_size)

    return 0;

/* TODO: Set a per-function stack size limit.  */

  return 1;

}

/* gfc_finish_cray_pointee sets DECL_VALUE_EXPR for a Cray pointee to

   an expression involving its corresponding pointer.  There are

   2 cases; one for variable size arrays, and one for everything else,

   because variable-sized arrays require one fewer level of

   indirection.  */

static void

gfc_finish_cray_pointee (tree decl, gfc_symbol *sym)

{

  tree ptr_decl = gfc_get_symbol_decl (sym->cp_pointer);

  tree value;

  /* Parameters need to be dereferenced.  */

  if (sym->cp_pointer->attr.dummy)

    ptr_decl = build_fold_indirect_ref_loc (input_location,

                                        ptr_decl);

  /* Check to see if we're dealing with a variable-sized array.  */

  if (sym->attr.dimension

      && TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE)

    {

      /* These decls will be dereferenced later, so we don't dereference

         them here.  */

      value = convert (TREE_TYPE (decl), ptr_decl);

    }

  else

    {

      ptr_decl = convert (build_pointer_type (TREE_TYPE (decl)),

                          ptr_decl);

      value = build_fold_indirect_ref_loc (input_location,

                                       ptr_decl);

    }

  SET_DECL_VALUE_EXPR (decl, value);

  DECL_HAS_VALUE_EXPR_P (decl) = 1;

  GFC_DECL_CRAY_POINTEE (decl) = 1;

  /* This is a fake variable just for debugging purposes.  */

  TREE_ASM_WRITTEN (decl) = 1;

}

/* Finish processing of a declaration without an initial value.  */

static void

gfc_finish_decl (tree decl)

{

  gcc_assert (TREE_CODE (decl) == PARM_DECL

              || DECL_INITIAL (decl) == NULL_TREE);

  if (TREE_CODE (decl) != VAR_DECL)

    return;

  if (DECL_SIZE (decl) == NULL_TREE

      && TYPE_SIZE (TREE_TYPE (decl)) != NULL_TREE)

    layout_decl (decl, 0);

  /* A few consistency checks.  */

  /* A static variable with an incomplete type is an error if it is

     initialized. Also if it is not file scope. Otherwise, let it

     through, but if it is not `extern' then it may cause an error

     message later.  */

  /* An automatic variable with an incomplete type is an error.  */

  /* We should know the storage size.  */

  gcc_assert (DECL_SIZE (decl) != NULL_TREE

              || (TREE_STATIC (decl)

                  ? (!DECL_INITIAL (decl) || !DECL_CONTEXT (decl))

                  : DECL_EXTERNAL (decl)));

  /* The storage size should be constant.  */

  gcc_assert ((!DECL_EXTERNAL (decl) && !TREE_STATIC (decl))

              || !DECL_SIZE (decl)

              || TREE_CODE (DECL_SIZE (decl)) == INTEGER_CST);

}

/* Apply symbol attributes to a variable, and add it to the function scope.  */

static void

gfc_finish_var_decl (tree decl, gfc_symbol * sym)

{

  tree new_type;

  /* TREE_ADDRESSABLE means the address of this variable is actually needed.

     This is the equivalent of the TARGET variables.

     We also need to set this if the variable is passed by reference in a

     CALL statement.  */

  /* Set DECL_VALUE_EXPR for Cray Pointees.  */

  if (sym->attr.cray_pointee)

    gfc_finish_cray_pointee (decl, sym);

  if (sym->attr.target)

    TREE_ADDRESSABLE (decl) = 1;

  /* If it wasn't used we wouldn't be getting it.  */

  TREE_USED (decl) = 1;

  if (sym->attr.flavor == FL_PARAMETER

      && (sym->attr.dimension || sym->ts.type == BT_DERIVED))

    TREE_READONLY (decl) = 1;

  /* Chain this decl to the pending declarations.  Don't do pushdecl()

     because this would add them to the current scope rather than the

     function scope.  */

  if (current_function_decl != NULL_TREE)

    {

      if (sym->ns->proc_name->backend_decl == current_function_decl

          || sym->result == sym)

        gfc_add_decl_to_function (decl);

      else if (sym->ns->proc_name->attr.flavor == FL_LABEL)

        /* This is a BLOCK construct.  */

        add_decl_as_local (decl);

      else

        gfc_add_decl_to_parent_function (decl);

    }

  if (sym->attr.cray_pointee)

    return;

  if(sym->attr.is_bind_c == 1)

    {

      /* We need to put variables that are bind(c) into the common

         segment of the object file, because this is what C would do.

         gfortran would typically put them in either the BSS or

         initialized data segments, and only mark them as common if

         they were part of common blocks.  However, if they are not put

         into common space, then C cannot initialize global Fortran

         variables that it interoperates with and the draft says that

         either Fortran or C should be able to initialize it (but not

         both, of course.) (J3/04-007, section 15.3).  */

      TREE_PUBLIC(decl) = 1;

      DECL_COMMON(decl) = 1;

    }

  /* If a variable is USE associated, it's always external.  */

  if (sym->attr.use_assoc)

    {

      DECL_EXTERNAL (decl) = 1;

      TREE_PUBLIC (decl) = 1;

    }

  else if (sym->module && !sym->attr.result && !sym->attr.dummy)

    {

      /* TODO: Don't set sym->module for result or dummy variables.  */

      gcc_assert (current_function_decl == NULL_TREE || sym->result == sym);

      /* This is the declaration of a module variable.  */

      TREE_PUBLIC (decl) = 1;

      TREE_STATIC (decl) = 1;

    }

  /* Derived types are a bit peculiar because of the possibility of

     a default initializer; this must be applied each time the variable

     comes into scope it therefore need not be static.  These variables

     are SAVE_NONE but have an initializer.  Otherwise explicitly

     initialized variables are SAVE_IMPLICIT and explicitly saved are

     SAVE_EXPLICIT.  */

  if (!sym->attr.use_assoc

        && (sym->attr.save != SAVE_NONE || sym->attr.data

            || (sym->value && sym->ns->proc_name->attr.is_main_program)

            || (gfc_option.coarray == GFC_FCOARRAY_LIB

                && sym->attr.codimension && !sym->attr.allocatable)))

    TREE_STATIC (decl) = 1;

  if (sym->attr.volatile_)

    {

      TREE_THIS_VOLATILE (decl) = 1;

      TREE_SIDE_EFFECTS (decl) = 1;

      new_type = build_qualified_type (TREE_TYPE (decl), TYPE_QUAL_VOLATILE);

      TREE_TYPE (decl) = new_type;

    }

  /* Keep variables larger than max-stack-var-size off stack.  */

  if (!sym->ns->proc_name->attr.recursive

      && INTEGER_CST_P (DECL_SIZE_UNIT (decl))

      && !gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl))

         /* Put variable length auto array pointers always into stack.  */

      && (TREE_CODE (TREE_TYPE (decl)) != POINTER_TYPE

          || sym->attr.dimension == 0

          || sym->as->type != AS_EXPLICIT

          || sym->attr.pointer

          || sym->attr.allocatable)

      && !DECL_ARTIFICIAL (decl))

    TREE_STATIC (decl) = 1;

  /* Handle threadprivate variables.  */

  if (sym->attr.threadprivate

      && (TREE_STATIC (decl) || DECL_EXTERNAL (decl)))

    DECL_TLS_MODEL (decl) = decl_default_tls_model (decl);

  if (!sym->attr.target

      && !sym->attr.pointer

      && !sym->attr.cray_pointee

      && !sym->attr.proc_pointer)

    DECL_RESTRICTED_P (decl) = 1;

}

/* Allocate the lang-specific part of a decl.  */

void

gfc_allocate_lang_decl (tree decl)

{

  DECL_LANG_SPECIFIC (decl) = ggc_alloc_cleared_lang_decl(sizeof

                                                          (struct lang_decl));

}

/* Remember a symbol to generate initialization/cleanup code at function

   entry/exit.  */

static void

gfc_defer_symbol_init (gfc_symbol * sym)

{

  gfc_symbol *p;

  gfc_symbol *last;

  gfc_symbol *head;

  /* Don't add a symbol twice.  */

  if (sym->tlink)

    return;

  last = head = sym->ns->proc_name;

  p = last->tlink;

  /* Make sure that setup code for dummy variables which are used in the

     setup of other variables is generated first.  */

  if (sym->attr.dummy)

    {

      /* Find the first dummy arg seen after us, or the first non-dummy arg.

         This is a circular list, so don't go past the head.  */

      while (p != head

             && (!p->attr.dummy || p->dummy_order > sym->dummy_order))

        {

          last = p;

          p = p->tlink;

        }

    }

  /* Insert in between last and p.  */

  last->tlink = sym;

  sym->tlink = p;

}

/* Used in gfc_get_symbol_decl and gfc_get_derived_type to obtain the

   backend_decl for a module symbol, if it all ready exists.  If the

   module gsymbol does not exist, it is created.  If the symbol does

   not exist, it is added to the gsymbol namespace.  Returns true if

   an existing backend_decl is found.  */

bool

gfc_get_module_backend_decl (gfc_symbol *sym)

{

  gfc_gsymbol *gsym;

  gfc_symbol *s;

  gfc_symtree *st;

  gsym =  gfc_find_gsymbol (gfc_gsym_root, sym->module);

  if (!gsym || (gsym->ns && gsym->type == GSYM_MODULE))

    {

      st = NULL;

      s = NULL;

      if (gsym)

        gfc_find_symbol (sym->name, gsym->ns, 0, &s);

      if (!s)

        {

          if (!gsym)

            {

              gsym = gfc_get_gsymbol (sym->module);

              gsym->type = GSYM_MODULE;

              gsym->ns = gfc_get_namespace (NULL, 0);

            }

          st = gfc_new_symtree (&gsym->ns->sym_root, sym->name);

          st->n.sym = sym;

          sym->refs++;

        }

      else if (sym->attr.flavor == FL_DERIVED)

        {

          if (s && s->attr.flavor == FL_PROCEDURE)

            {

              gfc_interface *intr;

              gcc_assert (s->attr.generic);

              for (intr = s->generic; intr; intr = intr->next)

                if (intr->sym->attr.flavor == FL_DERIVED)

                  {

                    s = intr->sym;

                    break;

                  }

            }

          if (!s->backend_decl)

            s->backend_decl = gfc_get_derived_type (s);

          gfc_copy_dt_decls_ifequal (s, sym, true);

          return true;

        }

      else if (s->backend_decl)

        {

          if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)

            gfc_copy_dt_decls_ifequal (s->ts.u.derived, sym->ts.u.derived,

                                       true);