Skip to content

R
riscv-gcc-1
Commit 7189a4b0 by Geoff Keating Committed by Geoffrey Keating
Options

Make the Fortran front-end use garbage collection: 

	* com.c (ffecom_init_0): Make double_ftype_double,
	float_ftype_float, ldouble_ftype_ldouble,
	ffecom_tree_ptr_to_fun_type_void local.
	(tracker_head): New static variable.
	(mark_tracker_head): New, marker procedure for tracker_head.
	(ffecom_save_tree_forever): New procedure.
	(ffecom_init_zero_): Remove obstack use.
	(ffecom_make_gfrt_): Remove obstack use.
	(ffecom_sym_transform_): Remove obstack use, save appropriate trees.
	(ffecom_transform_common_): Remove obstack use, save appropriate
	trees.
	(ffecom_type_namelist_): Remove obstack use, save appropriate
	trees.
	(ffecom_type_vardesc_): Remove obstack use, save appropriate trees.
	(ffecom_lookup_label): Remove obstack use, save appropriate trees.
	(duplicate_decls): Remove obstack use.
	(finish_function): push & pop ggc context around
	rest_of_compilation when building nested function.
	(mark_binding_level): New function.
	(init_decl_processing): Mark all the GC roots.
	(ggc_p): Set to 1.
	(lang_mark_tree): New function.
	(lang_mark_false_label_stack): New trivial function.
	* com.h (ffecom_save_tree_forever): Declare as external.
	* lex.c (ffelex_hash_): Use GC to allocate the filename string
	even when ffelex_kludge_flag_.
	* ste.c (ffeste_io_ialist_): Register a static root.
	(ffeste_io_inlist_): Likewise.
	(ffeste_io_icilist_): Likewise.
	(ffeste_io_cllist_): Likewise.
	(ffeste_io_cilist_): Likewise.
	(ffeste_io_olist_): Likewise.
	* Makefile.in (OBJS): Don't use ggc-callbacks.o.
	(OBJDEPS): Likewise.
	(GGC_H): New variable.
	Update dependencies.
	* where.c (ffewhere_head): New global.
	(mark_ffewhere_head): New marker procedure for ffewhere_head.
	(ffewhere_file_kill): Use GC to do memory management.
	(ffewhere_file_new): Use GC to do memory management.
	* ggc.j: New file.

From-SVN: r31142
parent 0deeec4e
Showing with 340 additions and 128 deletions
gcc/f/ChangeLog
Thu Dec 30 11:42:05 1999 Geoff Keating <geoffk@cygnus.com>
* com.c (ffecom_init_0): Make double_ftype_double,
float_ftype_float, ldouble_ftype_ldouble,
ffecom_tree_ptr_to_fun_type_void local.
(tracker_head): New static variable.
(mark_tracker_head): New, marker procedure for tracker_head.
(ffecom_save_tree_forever): New procedure.
(ffecom_init_zero_): Remove obstack use.
(ffecom_make_gfrt_): Remove obstack use.
(ffecom_sym_transform_): Remove obstack use, save appropriate trees.
(ffecom_transform_common_): Remove obstack use, save appropriate
trees.
(ffecom_type_namelist_): Remove obstack use, save appropriate
trees.
(ffecom_type_vardesc_): Remove obstack use, save appropriate trees.
(ffecom_lookup_label): Remove obstack use, save appropriate trees.
(duplicate_decls): Remove obstack use.
(finish_function): push & pop ggc context around
rest_of_compilation when building nested function.
(mark_binding_level): New function.
(init_decl_processing): Mark all the GC roots.
(ggc_p): Set to 1.
(lang_mark_tree): New function.
(lang_mark_false_label_stack): New trivial function.
* com.h (ffecom_save_tree_forever): Declare as external.
* lex.c (ffelex_hash_): Use GC to allocate the filename string
even when ffelex_kludge_flag_.
* ste.c (ffeste_io_ialist_): Register a static root.
(ffeste_io_inlist_): Likewise.
(ffeste_io_icilist_): Likewise.
(ffeste_io_cllist_): Likewise.
(ffeste_io_cilist_): Likewise.
(ffeste_io_olist_): Likewise.
* Makefile.in (OBJS): Don't use ggc-callbacks.o.
(OBJDEPS): Likewise.
(GGC_H): New variable.
Update dependencies.
* where.c (ffewhere_head): New global.
(mark_ffewhere_head): New marker procedure for ffewhere_head.
(ffewhere_file_kill): Use GC to do memory management.
(ffewhere_file_new): Use GC to do memory management.
* ggc.j: New file.
Wed Dec 29 19:29:26 1999 Gerald Pfeifer <pfeifer@dbai.tuwien.ac.at>
* g77.texi (C Interfacing Tools): Fix an incorrect link.
......
gcc/f/Make-lang.in
......@@ -200,7 +200,7 @@ F77_SRCS = \
$(srcdir)/f/where.c \
$(srcdir)/f/where.h
f771$(exeext): $(P) $(F77_SRCS) $(LIBDEPS) ggc-callbacks.o stamp-objlist
f771$(exeext): $(P) $(F77_SRCS) $(LIBDEPS) stamp-objlist
touch lang-f77
cd f; $(MAKE) $(FLAGS_TO_PASS) \
HOST_CC="`case '$(HOST_CC)' in stage*) echo '$(HOST_CC)' | sed -e 's|stage|../stage|g';; *) echo '$(HOST_CC)';; esac`" \
......
gcc/f/Makefile.in
......@@ -194,8 +194,8 @@ F77_OBJS = \
where.o
# Language-independent object files.
OBJS = `cat ../stamp-objlist` ../ggc-callbacks.o
OBJDEPS = ../stamp-objlist ../ggc-callbacks.o
OBJS = `cat ../stamp-objlist`
OBJDEPS = ../stamp-objlist
compiler: ../f771$(exeext)
../f771$(exeext): $(P) $(F77_OBJS) $(OBJDEPS) $(LIBDEPS)
......@@ -225,6 +225,7 @@ ASSERT_H = $(srcdir)/assert.j $(srcdir)/../assert.h
CONFIG_H = $(srcdir)/config.j ../config.h
CONVERT_H = $(srcdir)/convert.j $(srcdir)/../convert.h
FLAGS_H = $(srcdir)/flags.j $(srcdir)/../flags.h
GGC_H = $(srcdir)/ggc.j $(srcdir)/../ggc.h
GLIMITS_H = $(srcdir)/glimits.j $(srcdir)/../glimits.h
HCONFIG_H = $(srcdir)/hconfig.j ../hconfig.h
INPUT_H = $(srcdir)/input.j $(srcdir)/../input.h
......@@ -265,7 +266,7 @@ com.o: com.c proj.h $(CONFIG_H) $(SYSTEM_H) $(ASSERT_H) $(FLAGS_H) $(RTL_H) $(TO
malloc.h info.h info-b.def info-k.def info-w.def target.h bad.h \
bad.def where.h $(GLIMITS_H) top.h lex.h type.h intrin.h intrin.def \
lab.h symbol.h symbol.def equiv.h storag.h global.h name.h expr.h \
implic.h src.h st.h
implic.h src.h st.h $(GGC_H)
data.o: data.c proj.h $(CONFIG_H) $(SYSTEM_H) $(ASSERT_H) data.h bld.h \
bld-op.def bit.h malloc.h com.h com-rt.def $(TREE_H) info.h info-b.def \
info-k.def info-w.def target.h bad.h bad.def where.h $(GLIMITS_H) top.h \
......@@ -311,7 +312,7 @@ lex.o: lex.c proj.h $(CONFIG_H) $(SYSTEM_H) $(ASSERT_H) top.h malloc.h where.h \
$(GLIMITS_H) bad.h bad.def com.h com-rt.def $(TREE_H) bld.h bld-op.def \
bit.h info.h info-b.def info-k.def info-w.def target.h lex.h type.h \
intrin.h intrin.def lab.h symbol.h symbol.def equiv.h storag.h \
global.h name.h src.h $(FLAGS_H) $(INPUT_H) $(TOPLEV_H) $(OUTPUT_H)
global.h name.h src.h $(FLAGS_H) $(INPUT_H) $(TOPLEV_H) $(OUTPUT_H) $(GGC_H)
malloc.o: malloc.c proj.h $(CONFIG_H) $(SYSTEM_H) $(ASSERT_H) malloc.h
name.o: name.c proj.h $(CONFIG_H) $(SYSTEM_H) $(ASSERT_H) bad.h bad.def where.h \
$(GLIMITS_H) top.h malloc.h name.h global.h info.h info-b.def info-k.def \
......@@ -359,7 +360,7 @@ ste.o: ste.c proj.h $(CONFIG_H) $(SYSTEM_H) $(ASSERT_H) $(RTL_H) $(TOPLEV_H) ste
info-b.def info-k.def info-w.def target.h bad.h bad.def where.h \
$(GLIMITS_H) top.h lex.h type.h lab.h storag.h symbol.h symbol.def \
equiv.h global.h name.h intrin.h intrin.def stp.h stt.h stamp-str sts.h \
stv.h stw.h expr.h sta.h
stv.h stw.h expr.h sta.h $(GGC_H)
storag.o: storag.c proj.h $(CONFIG_H) $(SYSTEM_H) $(ASSERT_H) storag.h bld.h \
bld-op.def bit.h malloc.h com.h com-rt.def $(TREE_H) info.h info-b.def \
info-k.def info-w.def target.h bad.h bad.def where.h $(GLIMITS_H) top.h \
......@@ -413,7 +414,7 @@ top.o: top.c proj.h $(CONFIG_H) $(SYSTEM_H) $(ASSERT_H) top.h malloc.h where.h \
type.o: type.c proj.h $(CONFIG_H) $(SYSTEM_H) $(ASSERT_H) type.h malloc.h
version.o: version.c
where.o: where.c proj.h $(CONFIG_H) $(SYSTEM_H) $(ASSERT_H) where.h $(GLIMITS_H) \
top.h malloc.h lex.h
top.h malloc.h lex.h $(GGC_H)
# The rest of this list (Fortran 77 language-specific files) is hand-generated.
......
gcc/f/com.c
......@@ -93,6 +93,7 @@ the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
#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. */
......@@ -238,17 +239,12 @@ FILE *finput;
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. */
......@@ -6433,6 +6429,56 @@ ffecom_gfrt_tree_ (ffecomGfrt ix)
/* 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)
{
......@@ -6442,14 +6488,8 @@ 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 ();
......@@ -6966,9 +7006,6 @@ ffecom_make_gfrt_ (ffecomGfrt ix)
tree t;
tree ttype;
push_obstacks_nochange ();
end_temporary_allocation ();
switch (ffecom_gfrt_type_[ix])
{
case FFECOM_rttypeVOID_:
......@@ -7049,9 +7086,6 @@ ffecom_make_gfrt_ (ffecomGfrt ix)
finish_decl (t, NULL_TREE, TRUE);
resume_temporary_allocation ();
pop_obstacks ();
ffecom_gfrt_[ix] = t;
}
......@@ -7583,9 +7617,6 @@ ffecom_sym_transform_ (ffesymbol s)
break;
}
push_obstacks_nochange ();
end_temporary_allocation ();
t = build_decl (FUNCTION_DECL,
ffecom_get_external_identifier_ (s),
ffecom_tree_subr_type); /* Assume subr. */
......@@ -7601,8 +7632,7 @@ ffecom_sym_transform_ (ffesymbol s)
|| (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
ffeglobal_set_hook (g, t);
resume_temporary_allocation ();
pop_obstacks ();
ffecom_save_tree_forever (t);
break;
......@@ -8247,9 +8277,6 @@ ffecom_sym_transform_ (ffesymbol s)
break;
}
push_obstacks_nochange ();
end_temporary_allocation ();
if (ffesymbol_is_f2c (s)
&& (ffesymbol_where (s) != FFEINFO_whereCONSTANT))
t = ffecom_tree_fun_type[bt][kt];
......@@ -8270,8 +8297,7 @@ ffecom_sym_transform_ (ffesymbol s)
|| (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
ffeglobal_set_hook (g, t);
resume_temporary_allocation ();
pop_obstacks ();
ffecom_save_tree_forever (t);
break;
......@@ -8334,9 +8360,6 @@ ffecom_sym_transform_ (ffesymbol s)
break;
}
push_obstacks_nochange ();
end_temporary_allocation ();
t = build_decl (FUNCTION_DECL,
ffecom_get_external_identifier_ (s),
ffecom_tree_subr_type);
......@@ -8351,8 +8374,7 @@ ffecom_sym_transform_ (ffesymbol s)
|| (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
ffeglobal_set_hook (g, t);
resume_temporary_allocation ();
pop_obstacks ();
ffecom_save_tree_forever (t);
break;
......@@ -8421,9 +8443,6 @@ ffecom_sym_transform_ (ffesymbol s)
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);
......@@ -8433,8 +8452,7 @@ ffecom_sym_transform_ (ffesymbol s)
t = start_decl (t, FALSE);
finish_decl (t, NULL_TREE, FALSE);
resume_temporary_allocation ();
pop_obstacks ();
ffecom_save_tree_forever (t);
break;
......@@ -8757,9 +8775,6 @@ ffecom_transform_common_ (ffesymbol s)
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. */
......@@ -8831,8 +8846,7 @@ ffecom_transform_common_ (ffesymbol s)
ffestorag_set_hook (st, cbt);
resume_temporary_allocation ();
pop_obstacks ();
ffecom_save_tree_forever (cbt);
}
#endif
......@@ -9482,9 +9496,6 @@ ffecom_type_namelist_ ()
vardesctype = ffecom_type_vardesc_ ();
push_obstacks_nochange ();
end_temporary_allocation ();
type = make_node (RECORD_TYPE);
vardesctype = build_pointer_type (build_pointer_type (vardesctype));
......@@ -9498,8 +9509,7 @@ ffecom_type_namelist_ ()
TYPE_FIELDS (type) = namefield;
layout_type (type);
resume_temporary_allocation ();
pop_obstacks ();
ggc_add_tree_root (&type, 1);
}
return type;
......@@ -9553,9 +9563,6 @@ ffecom_type_vardesc_ ()
if (type == NULL_TREE)
{
push_obstacks_nochange ();
end_temporary_allocation ();
type = make_node (RECORD_TYPE);
namefield = ffecom_decl_field (type, NULL_TREE, "name",
......@@ -9570,8 +9577,7 @@ ffecom_type_vardesc_ ()
TYPE_FIELDS (type) = namefield;
layout_type (type);
resume_temporary_allocation ();
pop_obstacks ();
ggc_add_tree_root (&type, 1);
}
return type;
......@@ -11566,6 +11572,10 @@ ffecom_init_0 ()
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
......@@ -12392,9 +12402,6 @@ ffecom_lookup_label (ffelab label)
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)),
......@@ -12409,8 +12416,7 @@ ffecom_lookup_label (ffelab label)
make_decl_rtl (glabel, NULL, 0);
expand_decl (glabel);
resume_temporary_allocation ();
pop_obstacks ();
ffecom_save_tree_forever (glabel);
break;
......@@ -13777,17 +13783,6 @@ duplicate_decls (tree newdecl, tree olddecl)
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
......@@ -13800,8 +13795,6 @@ duplicate_decls (tree newdecl, tree olddecl)
if (types_match)
TREE_TYPE (olddecl) = newtype;
}
pop_obstacks ();
}
if (!types_match)
return 0;
......@@ -13830,17 +13823,6 @@ duplicate_decls (tree newdecl, tree olddecl)
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)
......@@ -13919,8 +13901,6 @@ duplicate_decls (tree newdecl, tree olddecl)
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. */
......@@ -14244,8 +14224,17 @@ finish_function (int nested)
/* 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. */
......@@ -14784,10 +14773,87 @@ incomplete_type_error (value, type)
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[] = {
&current_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 (&current_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 ();
}
......@@ -15753,6 +15819,34 @@ unsigned_type (type)
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 */
#if FFECOM_GCC_INCLUDE
......
gcc/f/com.h
......@@ -318,6 +318,7 @@ tree ffecom_lookup_label (ffelab label);
tree ffecom_make_tempvar (const char *commentary, tree type,
ffetargetCharacterSize size, int elements);
tree ffecom_modify (tree newtype, tree lhs, tree rhs);
void ffecom_save_tree_forever (tree t);
#endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
void ffecom_file (const char *name);
void ffecom_notify_init_storage (ffestorag st);
......
gcc/f/ggc.j 0 → 100644
/* rtl.j -- Wrapper for GCC's rtl.h
Copyright (C) 1995 Free Software Foundation, Inc.
Contributed by James Craig Burley.
This file is part of GNU Fortran.
GNU Fortran 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 2, or (at your option)
any later version.
GNU Fortran 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 GNU Fortran; see the file COPYING. If not, write to
the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
02111-1307, USA. */
#ifndef MAKING_DEPENDENCIES
#ifndef _J_f_ggc
#define _J_f_ggc
#include "system.j"
#include "config.j"
#include "ggc.h"
#endif
#endif
gcc/f/lex.c
......@@ -32,6 +32,7 @@ the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
#include "toplev.j"
#include "tree.j"
#include "output.j" /* Must follow tree.j so TREE_CODE is defined! */
#include "ggc.j"
#endif
#ifdef DWARF_DEBUGGING_INFO
......@@ -1320,7 +1321,7 @@ ffelex_hash_ (FILE *finput)
lineno = l;
if (ffelex_kludge_flag_)
input_filename = ffelex_token_text (token);
input_filename = ggc_alloc_string (ffelex_token_text (token), -1);
else
{
wf = ffewhere_file_new (ffelex_token_text (token),
......
gcc/f/ste.c
......@@ -35,6 +35,7 @@ the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
#if FFECOM_targetCURRENT == FFECOM_targetGCC
#include "rtl.j"
#include "toplev.j"
#include "ggc.j"
#endif
#include "ste.h"
......@@ -1218,9 +1219,6 @@ ffeste_io_ialist_ (bool have_err,
{
tree ref;
push_obstacks_nochange ();
end_temporary_allocation ();
ref = make_node (RECORD_TYPE);
errfield = ffecom_decl_field (ref, NULL_TREE, "err",
......@@ -1231,8 +1229,7 @@ ffeste_io_ialist_ (bool have_err,
TYPE_FIELDS (ref) = errfield;
layout_type (ref);
resume_temporary_allocation ();
pop_obstacks ();
ggc_add_tree_root (&f2c_alist_struct, 1);
f2c_alist_struct = ref;
}
......@@ -1355,9 +1352,6 @@ ffeste_io_cilist_ (bool have_err,
{
tree ref;
push_obstacks_nochange ();
end_temporary_allocation ();
ref = make_node (RECORD_TYPE);
errfield = ffecom_decl_field (ref, NULL_TREE, "err",
......@@ -1374,8 +1368,7 @@ ffeste_io_cilist_ (bool have_err,
TYPE_FIELDS (ref) = errfield;
layout_type (ref);
resume_temporary_allocation ();
pop_obstacks ();
ggc_add_tree_root (&f2c_cilist_struct, 1);
f2c_cilist_struct = ref;
}
......@@ -1586,9 +1579,6 @@ ffeste_io_cllist_ (bool have_err,
{
tree ref;
push_obstacks_nochange ();
end_temporary_allocation ();
ref = make_node (RECORD_TYPE);
errfield = ffecom_decl_field (ref, NULL_TREE, "err",
......@@ -1601,8 +1591,7 @@ ffeste_io_cllist_ (bool have_err,
TYPE_FIELDS (ref) = errfield;
layout_type (ref);
resume_temporary_allocation ();
pop_obstacks ();
ggc_add_tree_root (&f2c_close_struct, 1);
f2c_close_struct = ref;
}
......@@ -1713,9 +1702,6 @@ ffeste_io_icilist_ (bool have_err,
{
tree ref;
push_obstacks_nochange ();
end_temporary_allocation ();
ref = make_node (RECORD_TYPE);
errfield = ffecom_decl_field (ref, NULL_TREE, "err",
......@@ -1734,8 +1720,7 @@ ffeste_io_icilist_ (bool have_err,
TYPE_FIELDS (ref) = errfield;
layout_type (ref);
resume_temporary_allocation ();
pop_obstacks ();
ggc_add_tree_root (&f2c_icilist_struct, 1);
f2c_icilist_struct = ref;
}
......@@ -1976,9 +1961,6 @@ ffeste_io_inlist_ (bool have_err,
{
tree ref;
push_obstacks_nochange ();
end_temporary_allocation ();
ref = make_node (RECORD_TYPE);
errfield = ffecom_decl_field (ref, NULL_TREE, "err",
......@@ -2041,8 +2023,7 @@ ffeste_io_inlist_ (bool have_err,
TYPE_FIELDS (ref) = errfield;
layout_type (ref);
resume_temporary_allocation ();
pop_obstacks ();
ggc_add_tree_root (&f2c_inquire_struct, 1);
f2c_inquire_struct = ref;
}
......@@ -2229,9 +2210,6 @@ ffeste_io_olist_ (bool have_err,
{
tree ref;
push_obstacks_nochange ();
end_temporary_allocation ();
ref = make_node (RECORD_TYPE);
errfield = ffecom_decl_field (ref, NULL_TREE, "err",
......@@ -2256,8 +2234,7 @@ ffeste_io_olist_ (bool have_err,
TYPE_FIELDS (ref) = errfield;
layout_type (ref);
resume_temporary_allocation ();
pop_obstacks ();
ggc_add_tree_root (&f2c_open_struct, 1);
f2c_open_struct = ref;
}
......
gcc/f/where.c
......@@ -33,6 +33,7 @@ the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
#include "where.h"
#include "lex.h"
#include "malloc.h"
#include "ggc.j"
/* Externals defined here. */
......@@ -108,6 +109,33 @@ ffewhere_ll_lookup_ (ffewhereLineNumber ln)
return NULL;
}
/* A somewhat evil way to prevent the garbage collector
from collecting 'file' structures. */
#define NUM_FFEWHERE_HEAD_FILES 31
static struct ffewhere_ggc_tracker
{
struct ffewhere_ggc_tracker *next;
ffewhereFile files[NUM_FFEWHERE_HEAD_FILES];
} *ffewhere_head = NULL;
static void
mark_ffewhere_head (arg)
void *arg;
{
struct ffewhere_ggc_tracker *head;
int i;
for (head = * (struct ffewhere_ggc_tracker **) arg;
head != NULL;
head = head->next)
{
ggc_mark (head);
for (i = 0; i < NUM_FFEWHERE_HEAD_FILES; i++)
ggc_mark (head->files[i]);
}
}
/* Kill file object.
Note that this object must not have been passed in a call
......@@ -117,9 +145,18 @@ ffewhere_ll_lookup_ (ffewhereLineNumber ln)
void
ffewhere_file_kill (ffewhereFile wf)
{
malloc_kill_ks (ffe_pool_file (), wf,
offsetof (struct _ffewhere_file_, text)
+ wf->length + 1);
struct ffewhere_ggc_tracker *head;
int i;
for (head = ffewhere_head; head != NULL; head = head->next)
for (i = 0; i < NUM_FFEWHERE_HEAD_FILES; i++)
if (head->files[i] == wf)
{
head->files[i] = NULL;
return;
}
/* Called on a file that has already been deallocated... */
abort();
}
/* Create file object. */
......@@ -128,14 +165,42 @@ ffewhereFile
ffewhere_file_new (char *name, size_t length)
{
ffewhereFile wf;
wf = malloc_new_ks (ffe_pool_file (), "ffewhereFile",
offsetof (struct _ffewhere_file_, text)
+ length + 1);
int filepos;
wf = ggc_alloc (offsetof (struct _ffewhere_file_, text)
+ length + 1);
wf->length = length;
memcpy (&wf->text[0], name, length);
wf->text[length] = '\0';
if (ffewhere_head == NULL)
{
ggc_add_root (&ffewhere_head, 1, sizeof ffewhere_head,
mark_ffewhere_head);
filepos = NUM_FFEWHERE_HEAD_FILES;
}
else
{
for (filepos = 0; filepos < NUM_FFEWHERE_HEAD_FILES; filepos++)
if (ffewhere_head->files[filepos] == NULL)
{
ffewhere_head->files[filepos] = wf;
break;
}
}
if (filepos == NUM_FFEWHERE_HEAD_FILES)
{
/* Need to allocate a new block. */
struct ffewhere_ggc_tracker *old_head = ffewhere_head;
int i;
ffewhere_head = ggc_alloc (sizeof (*ffewhere_head));
ffewhere_head->next = old_head;
ffewhere_head->files[0] = wf;
for (i = 1; i < NUM_FFEWHERE_HEAD_FILES; i++)
ffewhere_head->files[i] = NULL;
}
return wf;
}
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment