#include "tree.j"
#include "output.j" /* Must follow tree.j so TREE_CODE is defined! */
#include "convert.j"
+#include "ggc.j"
#endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
#define FFECOM_GCC_INCLUDE 1 /* Enable -I. */
tree string_type_node;
-static tree double_ftype_double;
-static tree float_ftype_float;
-static tree ldouble_ftype_ldouble;
-
/* The rest of these are inventions for g77, though there might be
similar things in the C front end. As they are found, these
inventions should be renamed to be canonical. Note that only
the ones currently required to be global are so. */
static tree ffecom_tree_fun_type_void;
-static tree ffecom_tree_ptr_to_fun_type_void;
tree ffecom_integer_type_node; /* Abbrev for _tree_type[blah][blah]. */
tree ffecom_integer_zero_node; /* Like *_*_* with g77's integer type. */
/* Return initialize-to-zero expression for this VAR_DECL. */
#if FFECOM_targetCURRENT == FFECOM_targetGCC
+/* A somewhat evil way to prevent the garbage collector
+ from collecting 'tree' structures. */
+#define NUM_TRACKED_CHUNK 63
+static struct tree_ggc_tracker
+{
+ struct tree_ggc_tracker *next;
+ tree trees[NUM_TRACKED_CHUNK];
+} *tracker_head = NULL;
+
+static void
+mark_tracker_head (arg)
+ void *arg;
+{
+ struct tree_ggc_tracker *head;
+ int i;
+
+ for (head = * (struct tree_ggc_tracker **) arg;
+ head != NULL;
+ head = head->next)
+ {
+ ggc_mark (head);
+ for (i = 0; i < NUM_TRACKED_CHUNK; i++)
+ ggc_mark_tree (head->trees[i]);
+ }
+}
+
+void
+ffecom_save_tree_forever (tree t)
+{
+ int i;
+ if (tracker_head != NULL)
+ for (i = 0; i < NUM_TRACKED_CHUNK; i++)
+ if (tracker_head->trees[i] == NULL)
+ {
+ tracker_head->trees[i] = t;
+ return;
+ }
+
+ {
+ /* Need to allocate a new block. */
+ struct tree_ggc_tracker *old_head = tracker_head;
+
+ tracker_head = ggc_alloc (sizeof (*tracker_head));
+ tracker_head->next = old_head;
+ tracker_head->trees[0] = t;
+ for (i = 1; i < NUM_TRACKED_CHUNK; i++)
+ tracker_head->trees[i] = NULL;
+ }
+}
+
static tree
ffecom_init_zero_ (tree decl)
{
if (incremental)
{
- int momentary = suspend_momentary ();
- push_obstacks_nochange ();
- if (TREE_PERMANENT (decl))
- end_temporary_allocation ();
make_decl_rtl (decl, NULL, TREE_PUBLIC (decl) ? 1 : 0);
assemble_variable (decl, TREE_PUBLIC (decl) ? 1 : 0, 0, 1);
- pop_obstacks ();
- resume_momentary (momentary);
}
push_momentary ();
tree t;
tree ttype;
- push_obstacks_nochange ();
- end_temporary_allocation ();
-
switch (ffecom_gfrt_type_[ix])
{
case FFECOM_rttypeVOID_:
finish_decl (t, NULL_TREE, TRUE);
- resume_temporary_allocation ();
- pop_obstacks ();
-
ffecom_gfrt_[ix] = t;
}
break;
}
- push_obstacks_nochange ();
- end_temporary_allocation ();
-
t = build_decl (FUNCTION_DECL,
ffecom_get_external_identifier_ (s),
ffecom_tree_subr_type); /* Assume subr. */
|| (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
ffeglobal_set_hook (g, t);
- resume_temporary_allocation ();
- pop_obstacks ();
+ ffecom_save_tree_forever (t);
break;
break;
}
- push_obstacks_nochange ();
- end_temporary_allocation ();
-
if (ffesymbol_is_f2c (s)
&& (ffesymbol_where (s) != FFEINFO_whereCONSTANT))
t = ffecom_tree_fun_type[bt][kt];
|| (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
ffeglobal_set_hook (g, t);
- resume_temporary_allocation ();
- pop_obstacks ();
+ ffecom_save_tree_forever (t);
break;
break;
}
- push_obstacks_nochange ();
- end_temporary_allocation ();
-
t = build_decl (FUNCTION_DECL,
ffecom_get_external_identifier_ (s),
ffecom_tree_subr_type);
|| (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
ffeglobal_set_hook (g, t);
- resume_temporary_allocation ();
- pop_obstacks ();
+ ffecom_save_tree_forever (t);
break;
case FFEINFO_whereGLOBAL:
assert (!ffecom_transform_only_dummies_);
- push_obstacks_nochange ();
- end_temporary_allocation ();
-
t = build_decl (FUNCTION_DECL,
ffecom_get_external_identifier_ (s),
ffecom_tree_blockdata_type);
t = start_decl (t, FALSE);
finish_decl (t, NULL_TREE, FALSE);
- resume_temporary_allocation ();
- pop_obstacks ();
+ ffecom_save_tree_forever (t);
break;
else
init = NULL_TREE;
- push_obstacks_nochange ();
- end_temporary_allocation ();
-
/* cbtype must be permanently allocated! */
/* Allocate the MAX of the areas so far, seen filewide. */
ffestorag_set_hook (st, cbt);
- resume_temporary_allocation ();
- pop_obstacks ();
+ ffecom_save_tree_forever (cbt);
}
#endif
vardesctype = ffecom_type_vardesc_ ();
- push_obstacks_nochange ();
- end_temporary_allocation ();
-
type = make_node (RECORD_TYPE);
vardesctype = build_pointer_type (build_pointer_type (vardesctype));
TYPE_FIELDS (type) = namefield;
layout_type (type);
- resume_temporary_allocation ();
- pop_obstacks ();
+ ggc_add_tree_root (&type, 1);
}
return type;
if (type == NULL_TREE)
{
- push_obstacks_nochange ();
- end_temporary_allocation ();
-
type = make_node (RECORD_TYPE);
namefield = ffecom_decl_field (type, NULL_TREE, "name",
TYPE_FIELDS (type) = namefield;
layout_type (type);
- resume_temporary_allocation ();
- pop_obstacks ();
+ ggc_add_tree_root (&type, 1);
}
return type;
tree field;
ffetype type;
ffetype base_type;
+ tree double_ftype_double;
+ tree float_ftype_float;
+ tree ldouble_ftype_ldouble;
+ tree ffecom_tree_ptr_to_fun_type_void;
/* This block of code comes from the now-obsolete cktyps.c. It checks
whether the compiler environment is buggy in known ways, some of which
break;
case FFELAB_typeFORMAT:
- push_obstacks_nochange ();
- end_temporary_allocation ();
-
glabel = build_decl (VAR_DECL,
ffecom_get_invented_identifier
("__g77_format_%d", (int) ffelab_value (label)),
make_decl_rtl (glabel, NULL, 0);
expand_decl (glabel);
- resume_temporary_allocation ();
- pop_obstacks ();
+ ffecom_save_tree_forever (glabel);
break;
tree oldreturntype = TREE_TYPE (TREE_TYPE (olddecl));
tree newreturntype = TREE_TYPE (TREE_TYPE (newdecl));
- /* Make sure we put the new type in the same obstack as the old ones.
- If the old types are not both in the same obstack, use the
- permanent one. */
- if (TYPE_OBSTACK (oldtype) == TYPE_OBSTACK (newtype))
- push_obstacks (TYPE_OBSTACK (oldtype), TYPE_OBSTACK (oldtype));
- else
- {
- push_obstacks_nochange ();
- end_temporary_allocation ();
- }
-
if (TYPE_MODE (oldreturntype) == TYPE_MODE (newreturntype))
{
/* Function types may be shared, so we can't just modify
if (types_match)
TREE_TYPE (olddecl) = newtype;
}
-
- pop_obstacks ();
}
if (!types_match)
return 0;
if (types_match)
{
- /* Make sure we put the new type in the same obstack as the old ones.
- If the old types are not both in the same obstack, use the permanent
- one. */
- if (TYPE_OBSTACK (oldtype) == TYPE_OBSTACK (newtype))
- push_obstacks (TYPE_OBSTACK (oldtype), TYPE_OBSTACK (oldtype));
- else
- {
- push_obstacks_nochange ();
- end_temporary_allocation ();
- }
-
/* Merge the data types specified in the two decls. */
if (TREE_CODE (newdecl) != FUNCTION_DECL || !DECL_BUILT_IN (olddecl))
TREE_TYPE (newdecl)
DECL_STATIC_DESTRUCTOR (newdecl) |= DECL_STATIC_DESTRUCTOR (olddecl);
}
#endif
-
- pop_obstacks ();
}
/* If cannot merge, then use the new type and qualifiers,
and don't preserve the old rtl. */
/* So we can tell if jump_optimize sets it to 1. */
can_reach_end = 0;
+ /* If this is a nested function, protect the local variables in the stack
+ above us from being collected while we're compiling this function. */
+ if (ggc_p && nested)
+ ggc_push_context ();
+
/* Run the optimizers and output the assembler code for this function. */
rest_of_compilation (fndecl);
+
+ /* Undo the GC context switch. */
+ if (ggc_p && nested)
+ ggc_pop_context ();
}
/* Free all the tree nodes making up this function. */
assert ("incomplete type?!?" == NULL);
}
+/* Mark ARG for GC. */
+static void
+mark_binding_level (arg)
+ void *arg;
+{
+ struct binding_level *level = *(struct binding_level **) arg;
+
+ while (level)
+ {
+ ggc_mark_tree (level->names);
+ ggc_mark_tree (level->blocks);
+ ggc_mark_tree (level->this_block);
+ level = level->level_chain;
+ }
+}
+
void
init_decl_processing ()
{
+ static tree *const tree_roots[] = {
+ ¤t_function_decl,
+ &string_type_node,
+ &ffecom_tree_fun_type_void,
+ &ffecom_integer_zero_node,
+ &ffecom_integer_one_node,
+ &ffecom_tree_subr_type,
+ &ffecom_tree_ptr_to_subr_type,
+ &ffecom_tree_blockdata_type,
+ &ffecom_tree_xargc_,
+ &ffecom_f2c_integer_type_node,
+ &ffecom_f2c_ptr_to_integer_type_node,
+ &ffecom_f2c_address_type_node,
+ &ffecom_f2c_real_type_node,
+ &ffecom_f2c_ptr_to_real_type_node,
+ &ffecom_f2c_doublereal_type_node,
+ &ffecom_f2c_complex_type_node,
+ &ffecom_f2c_doublecomplex_type_node,
+ &ffecom_f2c_longint_type_node,
+ &ffecom_f2c_logical_type_node,
+ &ffecom_f2c_flag_type_node,
+ &ffecom_f2c_ftnlen_type_node,
+ &ffecom_f2c_ftnlen_zero_node,
+ &ffecom_f2c_ftnlen_one_node,
+ &ffecom_f2c_ftnlen_two_node,
+ &ffecom_f2c_ptr_to_ftnlen_type_node,
+ &ffecom_f2c_ftnint_type_node,
+ &ffecom_f2c_ptr_to_ftnint_type_node,
+ &ffecom_outer_function_decl_,
+ &ffecom_previous_function_decl_,
+ &ffecom_which_entrypoint_decl_,
+ &ffecom_float_zero_,
+ &ffecom_float_half_,
+ &ffecom_double_zero_,
+ &ffecom_double_half_,
+ &ffecom_func_result_,
+ &ffecom_func_length_,
+ &ffecom_multi_type_node_,
+ &ffecom_multi_retval_,
+ &named_labels,
+ &shadowed_labels
+ };
+ size_t i;
+
malloc_init ();
+
+ /* Record our roots. */
+ for (i = 0; i < sizeof(tree_roots)/sizeof(tree_roots[0]); i++)
+ ggc_add_tree_root (tree_roots[i], 1);
+ ggc_add_tree_root (&ffecom_tree_type[0][0],
+ FFEINFO_basictype*FFEINFO_kindtype);
+ ggc_add_tree_root (&ffecom_tree_fun_type[0][0],
+ FFEINFO_basictype*FFEINFO_kindtype);
+ ggc_add_tree_root (&ffecom_tree_ptr_to_fun_type[0][0],
+ FFEINFO_basictype*FFEINFO_kindtype);
+ ggc_add_tree_root (ffecom_gfrt_, FFECOM_gfrt);
+ ggc_add_root (¤t_binding_level, 1, sizeof current_binding_level,
+ mark_binding_level);
+ ggc_add_root (&free_binding_level, 1, sizeof current_binding_level,
+ mark_binding_level);
+ ggc_add_root (&tracker_head, 1, sizeof tracker_head, mark_tracker_head);
+
ffe_init_0 ();
}
return type;
}
+/* Callback routines for garbage collection. */
+
+int ggc_p = 1;
+
+void
+lang_mark_tree (t)
+ union tree_node *t ATTRIBUTE_UNUSED;
+{
+ if (TREE_CODE (t) == IDENTIFIER_NODE)
+ {
+ struct lang_identifier *i = (struct lang_identifier *) t;
+ ggc_mark_tree (IDENTIFIER_GLOBAL_VALUE (i));
+ ggc_mark_tree (IDENTIFIER_LOCAL_VALUE (i));
+ ggc_mark_tree (IDENTIFIER_LABEL_VALUE (i));
+ }
+ else if (TYPE_P (t) && TYPE_LANG_SPECIFIC (t))
+ ggc_mark (TYPE_LANG_SPECIFIC (t));
+}
+
+void
+lang_mark_false_label_stack (l)
+ struct label_node *l;
+{
+ /* Fortran doesn't use false_label_stack. It better be NULL. */
+ if (l != NULL)
+ abort();
+}
+
#endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
\f
#if FFECOM_GCC_INCLUDE
OSDN Git Service
