This is the mail archive of the
fortran@gcc.gnu.org
mailing list for the GNU Fortran project.
[Patch, fortran] Runtime memory leak checking.
- From: "Paul Richard Thomas" <paul dot richard dot thomas at gmail dot com>
- To: "fortran at gcc dot gnu dot org" <fortran at gcc dot gnu dot org>, gcc-patches <gcc-patches at gcc dot gnu dot org>
- Date: Sat, 29 Nov 2008 18:35:58 +0100
- Subject: [Patch, fortran] Runtime memory leak checking.
This patch is almost entirely due to FX Coudert; I added the updating
of gfc_current_locus in trans.c, the testcase and the ChangeLogs. I
also corrected one error.
The patch implements checking for memory leaks, such that:
[prt@localhost mem-check]# cat m*.f90
! { dg-do run }
! { dg-options = "-fruntime-check=memleaks" }
!
! Test the runtime check for memory leaks.
!
integer(4), pointer :: i(:)
allocate (i(10))
end
! { dg-output "found 1 memory leaks" }
[prt@localhost mem-check]# /irun/bin/gfortran -static
-fruntime-check=memleaks m*.f90;./a.out
Fortran runtime checking: found 1 memory leaks
- at line 7 of file 'mem_check_1.f90', allocation of 40.0 B (address
0x1749ee0)
Peak user-allocated memory: 40.0 B
Peak memory created by the compiler for temporaries: 0.00 B
When applied to some of the allocatable component testcases, such as:
[prt@localhost mem-check]# /irun/bin/gfortran -static
-fruntime-check=memleaks
/svn/trunk/gcc/testsuite/gfortran.dg/alloc_comp_basics_5.f90;./a.out
Fortran runtime checking: found 1 memory leaks
- at line 25 of file
'/svn/trunk/gcc/testsuite/gfortran.dg/alloc_comp_basics_5.f90',
allocation of 40.0 B (address 0x24fdee0)
Peak user-allocated memory: 40.0 B
Peak memory created by the compiler for temporaries: 0.00 B
It also adds hooks for memusage and recursion in runtime.
All the action happens in libgfortran/runtime/mem-check.c. This sets
up and populates a hash table with allocations of temporaries.
Deallocation removes the entries and anything that is left at the end
of execution represents a memory leak. The modifications to trans*.c
implement the calls when memory is alloctaed or freed, if the
runtime-check flag is set.
Bootstrapped and regtested on FC9/x86_i64.
OK to go on ice ready for 4.5? (Is there any appetite to add it to 4.4?)
Paul
2008-11-28 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
Paul Thomas <pault@gcc.gnu.org>
* Makefile.in : Add runtime/memory_check.c and .lo.
* runtime/memory_check.c : New file containing:
(pretty_memsize, hashval, hasheq, do_nothing,
egister_allocation, malloc_check, register_deallocation,
free_check, realloc_check, report_callback,
memory_check_report): New functions.
* libgfortran.h : Add prototypes for malloc_check,
free_check, realloc_check and memory_check_report.
* Makefile.am : Add runtime/memory_check.c.
2008-11-28 Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
Paul Thomas <pault@gcc.gnu.org>
* trans-expr.c (gfc_conv_string_tmp): Update arguments for call
to gfc_call_free.
* trans-array.c (gfc_trans_allocate_array_storage): Add call
to gfc_allocate_with_status, if checking memory leaks and
extend argument to gfc_call_free.
(gfc_allocate_with_status): Extend arguments for calls to
gfc_allocate_with_status and gfc_allocate_array_with_status.
(gfc_array_deallocate): Add locus* to function declaration.
(gfc_array_deallocate): Add final argument to call to
gfc_deallocate_with_status.
(gfc_trans_auto_array_allocation): If -fmemleaks is set, call
gfc_allocate_with_status. Extend the arglist for gfc_call_free
(gfc_trans_dummy_array_bias): The same.
(gfc_conv_array_parameter): The same.
(gfc_trans_dealloc_allocated): Extend arguments for call to
gfc_deallocate_with_status.
(gfc_duplicate_allocatable): Extend arguments for call to
gfc_allocate_with_status.
* trans-array.h : Modify prototype for gfc_array_deallocate.
trans-openmp.c (gfc_omp_clause_default_ctor): Extend args for
call to gfc_allocate_array_with_status.
(gfc_omp_clause_copy_ctor): The same.
(gfc_trans_omp_array_reduction): The same.
* gfortran.h : Declare rtcheck.
* lang-opt : Correct --ffpe-trap and add -fruntime-check.
* trans-stmt.c (gfc_trans_assign_need_temp): Add arg to call
to gfc_call_free.
(gfc_trans_pointer_assign_need_temp): The same.
(gfc_trans_pointer_assign_need_temp): The same.
(gfc_trans_forall_1, gfc_trans_where_2): The same.
(gfc_trans_allocate): Add arg to call to
gfc_allocate_with_status.
(gfc_trans_deallocate): Add arg to calls to
gfc_array_deallocate and gfc_deallocate_with_status.
* libfortran.h : Add bitmasks for the various runtime checks
and an enum for the allocataion types.
* trans.c (gfc_allocate_with_status): Add arg to decl and code
for real-time checking.
(gfc_allocate_array_with_status, gfc_call_free): The same.
(gfc_deallocate_with_status, gfc_call_realloc): The same.
(gfc_trans_code): Update gfc_current_locus from gfc_code.
* trans.h: Modify prototypes for the above and add tree
decls for gfor_fndecl_malloc_check, gfor_fndecl_free_check,
gfor_fndecl_realloc_check and gfor_fndecl_memory_check_report.
* gfortranspec.c : Add -liberty and remove -lg2c.
* trans-decl.c (gfc_build_builtin_function_decls): Add the
memory checking functions and build them if memory checking
is enabled.
* trans-intrinsic.c (gfc_conv_intrinsic_conversion,
gfc_conv_intrinsic_ctime, gfc_conv_intrinsic_fdate,
gfc_conv_intrinsic_ttynam, gfc_conv_intrinsic_minmax_char,
gfc_conv_intrinsic_array_transfer, gfc_conv_intrinsic_trim):
Add extra args to calls to gfc_call_free.
* options.c (gfc_init_options): Add real time checking.
(gfc_handle_runtime_check_option): New function.
(gfc_handle_option): Add case of runtime_check.
2008-11-28 Paul Thomas <pault@gcc.gnu.org>
* gfortran.dg/mem_check_1.f90: New test.
Index: gcc/testsuite/gfortran.dg/mem_check_1.f90
===================================================================
--- gcc/testsuite/gfortran.dg/mem_check_1.f90 (revision 0)
+++ gcc/testsuite/gfortran.dg/mem_check_1.f90 (revision 0)
@@ -0,0 +1,10 @@
+! { dg-do run }
+! { dg-options "-fruntime-check=memleaks -static" }
+!
+! Test the runtime check for memory leaks.
+!
+ integer(4), pointer :: i(:), j(:)
+ allocate (i(10))
+ allocate (j(10))
+end
+! { dg-output "found 2 memory leaks" }
Index: gcc/fortran/trans-expr.c
===================================================================
--- gcc/fortran/trans-expr.c (revision 142245)
+++ gcc/fortran/trans-expr.c (working copy)
@@ -1119,7 +1119,8 @@
gfc_add_modify (&se->pre, var, tmp);
/* Free the temporary afterwards. */
- tmp = gfc_call_free (convert (pvoid_type_node, var));
+ tmp = gfc_call_free (var, true, &gfc_current_locus,
+ ALLOCTYPE_TEMPORARY);
gfc_add_expr_to_block (&se->post, tmp);
}
Index: gcc/fortran/trans-array.c
===================================================================
--- gcc/fortran/trans-array.c (revision 142245)
+++ gcc/fortran/trans-array.c (working copy)
@@ -541,7 +541,11 @@
/* Allocate memory to hold the data or call internal_pack. */
if (initial == NULL_TREE)
{
- tmp = gfc_call_malloc (pre, NULL, size);
+ if (gfc_option.rtcheck & GFC_RTCHECK_MEMLEAKS)
+ tmp = gfc_allocate_with_status (pre, size, NULL_TREE,
+ &gfc_current_locus);
+ else
+ tmp = gfc_call_malloc (pre, NULL, size);
tmp = gfc_evaluate_now (tmp, pre);
}
else
@@ -599,7 +603,8 @@
{
/* Free the temporary. */
tmp = gfc_conv_descriptor_data_get (desc);
- tmp = gfc_call_free (fold_convert (pvoid_type_node, tmp));
+ tmp = gfc_call_free (tmp, true, &gfc_current_locus,
+ ALLOCTYPE_TEMPORARY);
gfc_add_expr_to_block (post, tmp);
}
}
@@ -3848,9 +3853,10 @@
/* The allocate_array variants take the old pointer as first argument. */
if (allocatable_array)
- tmp = gfc_allocate_array_with_status (&se->pre, pointer, size, pstat, expr);
+ tmp = gfc_allocate_array_with_status (&se->pre, pointer, size, pstat,
+ expr, &expr->where);
else
- tmp = gfc_allocate_with_status (&se->pre, size, pstat);
+ tmp = gfc_allocate_with_status (&se->pre, size, pstat, &expr->where);
tmp = fold_build2 (MODIFY_EXPR, void_type_node, pointer, tmp);
gfc_add_expr_to_block (&se->pre, tmp);
@@ -3874,7 +3880,8 @@
/*GCC ARRAYS*/
tree
-gfc_array_deallocate (tree descriptor, tree pstat, gfc_expr* expr)
+gfc_array_deallocate (tree descriptor, tree pstat,
+ gfc_expr* expr, locus *loc)
{
tree var;
tree tmp;
@@ -3886,7 +3893,7 @@
STRIP_NOPS (var);
/* Parameter is the address of the data component. */
- tmp = gfc_deallocate_with_status (var, pstat, false, expr);
+ tmp = gfc_deallocate_with_status (var, pstat, false, expr, loc);
gfc_add_expr_to_block (&block, tmp);
/* Zero the data pointer. */
@@ -4179,7 +4186,12 @@
fold_convert (gfc_array_index_type, tmp));
/* Allocate memory to hold the data. */
- tmp = gfc_call_malloc (&block, TREE_TYPE (decl), size);
+ if (gfc_option.rtcheck & GFC_RTCHECK_MEMLEAKS)
+ tmp = gfc_allocate_with_status (&block, size, NULL_TREE,
+ &gfc_current_locus);
+ else
+ tmp = gfc_call_malloc (&block, NULL, size);
+ tmp = fold_convert (TREE_TYPE (decl), tmp);
gfc_add_modify (&block, decl, tmp);
/* Set offset of the array. */
@@ -4193,7 +4205,8 @@
gfc_add_expr_to_block (&block, fnbody);
/* Free the temporary. */
- tmp = gfc_call_free (convert (pvoid_type_node, decl));
+ tmp = gfc_call_free (decl, true, &gfc_current_locus,
+ ALLOCTYPE_TEMPORARY);
gfc_add_expr_to_block (&block, tmp);
return gfc_finish_block (&block);
@@ -4554,7 +4567,8 @@
}
/* Free the temporary. */
- tmp = gfc_call_free (tmpdesc);
+ tmp = gfc_call_free (tmpdesc, true, &gfc_current_locus,
+ ALLOCTYPE_TEMPORARY);
gfc_add_expr_to_block (&cleanup, tmp);
stmt = gfc_finish_block (&cleanup);
@@ -5349,7 +5363,8 @@
}
/* Free the temporary. */
- tmp = gfc_call_free (convert (pvoid_type_node, ptr));
+ tmp = gfc_call_free (ptr, true, &gfc_current_locus,
+ ALLOCTYPE_TEMPORARY);
gfc_add_expr_to_block (&block, tmp);
stmt = gfc_finish_block (&block);
@@ -5394,7 +5409,8 @@
/* Call array_deallocate with an int * present in the second argument.
Although it is ignored here, it's presence ensures that arrays that
are already deallocated are ignored. */
- tmp = gfc_deallocate_with_status (var, NULL_TREE, true, NULL);
+ tmp = gfc_deallocate_with_status (var, NULL_TREE, true, NULL,
+ &gfc_current_locus);
gfc_add_expr_to_block (&block, tmp);
/* Zero the data pointer. */
@@ -5453,8 +5469,9 @@
TYPE_SIZE_UNIT (gfc_get_element_type (type))));
/* Allocate memory to the destination. */
- tmp = gfc_call_malloc (&block, TREE_TYPE (gfc_conv_descriptor_data_get (src)),
- size);
+ tmp = gfc_allocate_with_status (&block, size, NULL_TREE,
+ &gfc_current_locus);
+ tmp = fold_convert (TREE_TYPE (gfc_conv_descriptor_data_get (src)), tmp);
gfc_conv_descriptor_data_set (&block, dest, tmp);
/* We know the temporary and the value will be the same length,
Index: gcc/fortran/trans-array.h
===================================================================
--- gcc/fortran/trans-array.h (revision 142245)
+++ gcc/fortran/trans-array.h (working copy)
@@ -20,7 +20,7 @@
<http://www.gnu.org/licenses/>. */
/* Generate code to free an array. */
-tree gfc_array_deallocate (tree, tree, gfc_expr*);
+tree gfc_array_deallocate (tree, tree, gfc_expr*, locus *);
/* Generate code to initialize an allocate an array. Statements are added to
se, which should contain an expression for the array descriptor. */
Index: gcc/fortran/trans-openmp.c
===================================================================
--- gcc/fortran/trans-openmp.c (revision 142245)
+++ gcc/fortran/trans-openmp.c (working copy)
@@ -163,7 +163,7 @@
size = gfc_evaluate_now (fold_convert (size_type_node, size), &cond_block);
ptr = gfc_allocate_array_with_status (&cond_block,
build_int_cst (pvoid_type_node, 0),
- size, NULL, NULL);
+ size, NULL, NULL, &gfc_current_locus);
gfc_conv_descriptor_data_set (&cond_block, decl, ptr);
then_b = gfc_finish_block (&cond_block);
@@ -215,7 +215,7 @@
size = gfc_evaluate_now (fold_convert (size_type_node, size), &block);
ptr = gfc_allocate_array_with_status (&block,
build_int_cst (pvoid_type_node, 0),
- size, NULL, NULL);
+ size, NULL, NULL, &gfc_current_locus);
gfc_conv_descriptor_data_set (&block, dest, ptr);
call = build_call_expr (built_in_decls[BUILT_IN_MEMCPY], 3, ptr,
fold_convert (pvoid_type_node,
@@ -619,7 +619,7 @@
size = gfc_evaluate_now (fold_convert (size_type_node, size), &block);
ptr = gfc_allocate_array_with_status (&block,
build_int_cst (pvoid_type_node, 0),
- size, NULL, NULL);
+ size, NULL, NULL, &gfc_current_locus);
gfc_conv_descriptor_data_set (&block, decl, ptr);
gfc_add_expr_to_block (&block, gfc_trans_assignment (e1, e2, false));
stmt = gfc_finish_block (&block);
Index: gcc/fortran/gfortran.h
===================================================================
--- gcc/fortran/gfortran.h (revision 142245)
+++ gcc/fortran/gfortran.h (working copy)
@@ -2022,6 +2022,7 @@
int flag_align_commons;
int fpe;
+ int rtcheck;
int warn_std;
int allow_std;
Index: gcc/fortran/lang.opt
===================================================================
--- gcc/fortran/lang.opt (revision 142245)
+++ gcc/fortran/lang.opt (working copy)
@@ -246,7 +246,7 @@
ffpe-trap=
Fortran RejectNegative JoinedOrMissing
--ffpe-trap=[..] Stop on following floating point exceptions
+-ffpe-trap=[...] Stop on following floating point exceptions
ffree-form
Fortran RejectNegative
@@ -340,6 +340,10 @@
Fortran
Copy array sections into a contiguous block on procedure entry
+fruntime-check=
+Fortran RejectNegative JoinedOrMissing
+-runtime-check=[...] Specify which runtime checks are to be performed
+
fsecond-underscore
Fortran
Append a second underscore if the name already contains an underscore
Index: gcc/fortran/trans-stmt.c
===================================================================
--- gcc/fortran/trans-stmt.c (revision 142245)
+++ gcc/fortran/trans-stmt.c (working copy)
@@ -2496,7 +2496,8 @@
if (ptemp1)
{
/* Free the temporary. */
- tmp = gfc_call_free (ptemp1);
+ tmp = gfc_call_free (ptemp1, true, &gfc_current_locus,
+ ALLOCTYPE_TEMPORARY);
gfc_add_expr_to_block (block, tmp);
}
}
@@ -2655,7 +2656,8 @@
/* Free the temporary. */
if (ptemp1)
{
- tmp = gfc_call_free (ptemp1);
+ tmp = gfc_call_free (ptemp1, true, &gfc_current_locus,
+ ALLOCTYPE_TEMPORARY);
gfc_add_expr_to_block (block, tmp);
}
}
@@ -3002,7 +3004,8 @@
if (pmask)
{
/* Free the temporary for the mask. */
- tmp = gfc_call_free (pmask);
+ tmp = gfc_call_free (pmask, true, &gfc_current_locus,
+ ALLOCTYPE_TEMPORARY);
gfc_add_expr_to_block (&block, tmp);
}
if (maskindex)
@@ -3611,14 +3614,16 @@
/* If we allocated a pending mask array, deallocate it now. */
if (ppmask)
{
- tmp = gfc_call_free (ppmask);
+ tmp = gfc_call_free (ppmask, true, &gfc_current_locus,
+ ALLOCTYPE_TEMPORARY);
gfc_add_expr_to_block (block, tmp);
}
/* If we allocated a current mask array, deallocate it now. */
if (pcmask)
{
- tmp = gfc_call_free (pcmask);
+ tmp = gfc_call_free (pcmask, true, &gfc_current_locus,
+ ALLOCTYPE_TEMPORARY);
gfc_add_expr_to_block (block, tmp);
}
}
@@ -3911,7 +3916,7 @@
if (expr->ts.type == BT_CHARACTER && tmp == NULL_TREE)
tmp = se.string_length;
- tmp = gfc_allocate_with_status (&se.pre, tmp, pstat);
+ tmp = gfc_allocate_with_status (&se.pre, tmp, pstat, &expr->where);
tmp = fold_build2 (MODIFY_EXPR, void_type_node, se.expr,
fold_convert (TREE_TYPE (se.expr), tmp));
gfc_add_expr_to_block (&se.pre, tmp);
@@ -4035,10 +4040,11 @@
}
if (expr->rank)
- tmp = gfc_array_deallocate (se.expr, pstat, expr);
+ tmp = gfc_array_deallocate (se.expr, pstat, expr, &expr->where);
else
{
- tmp = gfc_deallocate_with_status (se.expr, pstat, false, expr);
+ tmp = gfc_deallocate_with_status (se.expr, pstat, false,
+ expr, &expr->where);
gfc_add_expr_to_block (&se.pre, tmp);
tmp = fold_build2 (MODIFY_EXPR, void_type_node,
Index: gcc/fortran/libgfortran.h
===================================================================
--- gcc/fortran/libgfortran.h (revision 142245)
+++ gcc/fortran/libgfortran.h (working copy)
@@ -40,6 +40,13 @@
#define GFC_FPE_PRECISION (1<<5)
+/* Bitmasks for the various runtime checks that can be enabled. */
+#define GFC_RTCHECK_BOUNDS (1<<0)
+#define GFC_RTCHECK_MEMUSAGE (1<<1)
+#define GFC_RTCHECK_MEMLEAKS (1<<2)
+#define GFC_RTCHECK_RECURSION (1<<3)
+
+
/* Possible values for the CONVERT I/O specifier. */
typedef enum
{
@@ -109,3 +116,12 @@
GFC_DTYPE_CHARACTER
};
+
+/* Allocation types for the checking memory management routines. */
+enum
+{
+ ALLOCTYPE_ALLOCATE, /* ALLOCATE, DEALLOCATE and MOVE_ALLOC statements. */
+ ALLOCTYPE_MALLOC, /* MALLOC, REALLOC and FREE extension routines. */
+ ALLOCTYPE_TEMPORARY /* Allocation for temporaries. */
+};
+
Index: gcc/fortran/trans.c
===================================================================
--- gcc/fortran/trans.c (revision 142245)
+++ gcc/fortran/trans.c (working copy)
@@ -583,7 +583,8 @@
return newmem;
} */
tree
-gfc_allocate_with_status (stmtblock_t * block, tree size, tree status)
+gfc_allocate_with_status (stmtblock_t * block, tree size, tree status,
+ locus *loc)
{
stmtblock_t alloc_block;
tree res, tmp, error, msg, cond;
@@ -636,11 +637,20 @@
/* The allocation itself. */
gfc_start_block (&alloc_block);
- gfc_add_modify (&alloc_block, res,
- build_call_expr (built_in_decls[BUILT_IN_MALLOC], 1,
- fold_build2 (MAX_EXPR, size_type_node,
- size,
- build_int_cst (size_type_node, 1))));
+ if (gfc_option.rtcheck & GFC_RTCHECK_MEMLEAKS)
+ gfc_add_modify (&alloc_block, res,
+ build_call_expr (gfor_fndecl_malloc_check, 4, size,
+ gfc_build_addr_expr (pchar_type_node,
+ gfc_build_cstring_const (loc->lb->file->filename)),
+ build_int_cst (integer_type_node,
+ LOCATION_LINE (loc->lb->location)),
+ build_int_cst (integer_type_node, ALLOCTYPE_ALLOCATE)));
+ else
+ gfc_add_modify (&alloc_block, res,
+ build_call_expr (built_in_decls[BUILT_IN_MALLOC], 1,
+ fold_build2 (MAX_EXPR, size_type_node,
+ size,
+ build_int_cst (size_type_node, 1))));
msg = gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const
("Out of memory"));
@@ -704,7 +714,7 @@
and variable name in case a runtime error has to be printed. */
tree
gfc_allocate_array_with_status (stmtblock_t * block, tree mem, tree size,
- tree status, gfc_expr* expr)
+ tree status, gfc_expr* expr, locus *loc)
{
stmtblock_t alloc_block;
tree res, tmp, null_mem, alloc, error;
@@ -720,7 +730,7 @@
/* If mem is NULL, we call gfc_allocate_with_status. */
gfc_start_block (&alloc_block);
- tmp = gfc_allocate_with_status (&alloc_block, size, status);
+ tmp = gfc_allocate_with_status (&alloc_block, size, status, loc);
gfc_add_modify (&alloc_block, res, fold_convert (type, tmp));
alloc = gfc_finish_block (&alloc_block);
@@ -749,11 +759,10 @@
stmtblock_t set_status_block;
gfc_start_block (&set_status_block);
- tmp = build_call_expr (built_in_decls[BUILT_IN_FREE], 1,
- fold_convert (pvoid_type_node, mem));
+ tmp = gfc_call_free (mem, false, loc, ALLOCTYPE_ALLOCATE);
gfc_add_expr_to_block (&set_status_block, tmp);
- tmp = gfc_allocate_with_status (&set_status_block, size, status);
+ tmp = gfc_allocate_with_status (&set_status_block, size, status, loc);
gfc_add_modify (&set_status_block, res, fold_convert (type, tmp));
gfc_add_modify (&set_status_block,
@@ -773,29 +782,51 @@
}
-/* Free a given variable, if it's not NULL. */
+/* Free a given variable. We possibly check if it's NULL (if argument
+ nullcheck is true. */
tree
-gfc_call_free (tree var)
+gfc_call_free (tree var, bool nullcheck, locus *loc, int type)
{
stmtblock_t block;
- tree tmp, cond, call;
+ tree tmp, call, cond = NULL_TREE;
if (TREE_TYPE (var) != TREE_TYPE (pvoid_type_node))
var = fold_convert (pvoid_type_node, var);
- gfc_start_block (&block);
- var = gfc_evaluate_now (var, &block);
- cond = fold_build2 (NE_EXPR, boolean_type_node, var,
- build_int_cst (pvoid_type_node, 0));
- call = build_call_expr (built_in_decls[BUILT_IN_FREE], 1, var);
- tmp = fold_build3 (COND_EXPR, void_type_node, cond, call,
- build_empty_stmt ());
- gfc_add_expr_to_block (&block, tmp);
+ if (nullcheck)
+ {
+ gfc_start_block (&block);
+ var = gfc_evaluate_now (var, &block);
+ cond = fold_build2 (NE_EXPR, boolean_type_node, var,
+ build_int_cst (pvoid_type_node, 0));
+ }
- return gfc_finish_block (&block);
-}
+ if (gfc_option.rtcheck & GFC_RTCHECK_MEMLEAKS)
+ {
+ int line = loc ? LOCATION_LINE (loc->lb->location) : 0;
+ tree file = loc
+ ? gfc_build_addr_expr (pchar_type_node,
+ gfc_build_cstring_const (loc->lb->file->filename))
+ : build_int_cst (pchar_type_node, 0);
+ call = build_call_expr (gfor_fndecl_free_check, 4, var, file,
+ build_int_cst (integer_type_node, line),
+ build_int_cst (integer_type_node, type));
+ }
+ else
+ call = build_call_expr (built_in_decls[BUILT_IN_FREE], 1, var);
+ if (nullcheck)
+ {
+ tmp = fold_build3 (COND_EXPR, void_type_node, cond, call,
+ build_empty_stmt ());
+ gfc_add_expr_to_block (&block, tmp);
+ return gfc_finish_block (&block);
+ }
+ else
+ return call;
+}
+
/* User-deallocate; we emit the code directly from the front-end, and the
logic is the same as the previous library function:
@@ -828,7 +859,7 @@
expression being deallocated for its locus and variable name. */
tree
gfc_deallocate_with_status (tree pointer, tree status, bool can_fail,
- gfc_expr* expr)
+ gfc_expr* expr, locus *loc)
{
stmtblock_t null, non_null;
tree cond, tmp, error;
@@ -872,8 +903,7 @@
/* When POINTER is not NULL, we free it. */
gfc_start_block (&non_null);
- tmp = build_call_expr (built_in_decls[BUILT_IN_FREE], 1,
- fold_convert (pvoid_type_node, pointer));
+ tmp = gfc_call_free (pointer, false, loc, ALLOCTYPE_ALLOCATE);
gfc_add_expr_to_block (&non_null, tmp);
if (status != NULL_TREE && !integer_zerop (status))
@@ -939,8 +969,16 @@
gfc_add_expr_to_block (block, tmp);
/* Call realloc and check the result. */
- tmp = build_call_expr (built_in_decls[BUILT_IN_REALLOC], 2,
- fold_convert (pvoid_type_node, mem), size);
+ if (gfc_option.rtcheck & GFC_RTCHECK_MEMLEAKS)
+ tmp = build_call_expr (gfor_fndecl_realloc_check, 5,
+ fold_convert (pvoid_type_node, mem), size,
+ build_int_cst (pchar_type_node, 0),
+ build_int_cst (integer_type_node, 0),
+ build_int_cst (integer_type_node,
+ ALLOCTYPE_TEMPORARY));
+ else
+ tmp = build_call_expr (built_in_decls[BUILT_IN_REALLOC], 2,
+ fold_convert (pvoid_type_node, mem), size);
gfc_add_modify (block, res, fold_convert (type, tmp));
null_result = fold_build2 (EQ_EXPR, boolean_type_node, res,
build_int_cst (pvoid_type_node, 0));
@@ -1035,16 +1073,20 @@
{
stmtblock_t block;
tree res;
+ locus saved_locus;
if (!code)
return build_empty_stmt ();
+ saved_locus = gfc_current_locus;
+
gfc_start_block (&block);
/* Translate statements one by one into GENERIC trees until we reach
the end of this gfc_code branch. */
for (; code; code = code->next)
{
+ gfc_current_locus = code->loc;
if (code->here != 0)
{
res = gfc_trans_label_here (code);
@@ -1246,6 +1288,8 @@
}
}
+ gfc_current_locus = saved_locus;
+
/* Return the finished block. */
return gfc_finish_block (&block);
}
Index: gcc/fortran/trans.h
===================================================================
--- gcc/fortran/trans.h (revision 142245)
+++ gcc/fortran/trans.h (working copy)
@@ -458,8 +458,8 @@
void gfc_trans_runtime_check (bool, bool, tree, stmtblock_t *, locus *,
const char *, ...);
-/* Generate a call to free() after checking that its arg is non-NULL. */
-tree gfc_call_free (tree);
+/* Generate a call to free() after possibly checking that its arg is non-NULL. */
+tree gfc_call_free (tree, bool, locus *, int);
/* Allocate memory after performing a few checks. */
tree gfc_call_malloc (stmtblock_t *, tree, tree);
@@ -468,13 +468,13 @@
tree gfc_build_memcpy_call (tree, tree, tree);
/* Allocate memory for arrays, with optional status variable. */
-tree gfc_allocate_array_with_status (stmtblock_t*, tree, tree, tree, gfc_expr*);
+tree gfc_allocate_array_with_status (stmtblock_t*, tree, tree, tree, gfc_expr*, locus *);
/* Allocate memory, with optional status variable. */
-tree gfc_allocate_with_status (stmtblock_t *, tree, tree);
+tree gfc_allocate_with_status (stmtblock_t *, tree, tree, locus *);
/* Generate code to deallocate an array. */
-tree gfc_deallocate_with_status (tree, tree, bool, gfc_expr*);
+tree gfc_deallocate_with_status (tree, tree, bool, gfc_expr*, locus *);
/* Generate code to call realloc(). */
tree gfc_call_realloc (stmtblock_t *, tree, tree);
@@ -535,6 +535,10 @@
extern GTY(()) tree gfor_fndecl_in_pack;
extern GTY(()) tree gfor_fndecl_in_unpack;
extern GTY(()) tree gfor_fndecl_associated;
+extern GTY(()) tree gfor_fndecl_malloc_check;
+extern GTY(()) tree gfor_fndecl_free_check;
+extern GTY(()) tree gfor_fndecl_realloc_check;
+extern GTY(()) tree gfor_fndecl_memory_check_report;
/* Math functions. Many other math functions are handled in
trans-intrinsic.c. */
Index: gcc/fortran/gfortranspec.c
===================================================================
--- gcc/fortran/gfortranspec.c (revision 142245)
+++ gcc/fortran/gfortranspec.c (working copy)
@@ -27,13 +27,13 @@
unless explicitly overridden by the user in certain ways, ensure
that the needs of the language supported by this wrapper are met.
- For GNU Fortran 95(gfortran), we do the following to the argument list
+ For GNU Fortran (gfortran), we do the following to the argument list
before passing it to `gcc':
- 1. Make sure `-lgfortran -lm' is at the end of the list.
+ 1. Make sure `-lgfortran -liberty -lm' is at the end of the list.
2. Make sure each time `-lgfortran' or `-lm' is seen, it forms
- part of the series `-lgfortran -lm'.
+ part of the series `-lgfortran -liberty -lm'.
#1 and #2 are not done if `-nostdlib' or any option that disables
the linking phase is present, or if `-xfoo' is in effect. Note that
@@ -518,6 +518,7 @@
{
saw_library = 1; /* -l<library>. */
ADD_ARG_LIBGFORTRAN (argv[i]);
+ append_arg ("-liberty");
continue;
}
else
@@ -530,7 +531,7 @@
append_arg (argv[i]);
}
- /* Append `-lg2c -lm' as necessary. */
+ /* Append `-lm' as necessary. */
if (library)
{ /* Doing a link and no -nostdlib. */
@@ -549,6 +550,7 @@
/* Fall through. */
case 1:
+ append_arg ("-liberty");
if (need_math)
append_arg (MATH_LIBRARY);
default:
Index: gcc/fortran/trans-decl.c
===================================================================
--- gcc/fortran/trans-decl.c (revision 142245)
+++ gcc/fortran/trans-decl.c (working copy)
@@ -94,6 +94,10 @@
tree gfor_fndecl_in_pack;
tree gfor_fndecl_in_unpack;
tree gfor_fndecl_associated;
+tree gfor_fndecl_malloc_check;
+tree gfor_fndecl_free_check;
+tree gfor_fndecl_realloc_check;
+tree gfor_fndecl_memory_check_report;
/* Math functions. Many other math functions are handled in
@@ -2569,6 +2573,29 @@
integer_type_node, 2, ppvoid_type_node,
ppvoid_type_node);
+ /* Memory checking functions. */
+ gfor_fndecl_malloc_check =
+ gfc_build_library_function_decl (get_identifier (PREFIX("malloc_check")),
+ pvoid_type_node, 4, size_type_node,
+ pchar_type_node, integer_type_node,
+ integer_type_node);
+
+ gfor_fndecl_free_check =
+ gfc_build_library_function_decl (get_identifier (PREFIX("free_check")),
+ void_type_node, 4, pvoid_type_node,
+ pchar_type_node, integer_type_node,
+ integer_type_node);
+
+ gfor_fndecl_realloc_check =
+ gfc_build_library_function_decl (get_identifier (PREFIX("realloc_check")),
+ pvoid_type_node, 5, pvoid_type_node,
+ size_type_node, pchar_type_node,
+ integer_type_node, integer_type_node);
+
+ gfor_fndecl_memory_check_report =
+ gfc_build_library_function_decl (get_identifier (PREFIX("memory_check_report")),
+ void_type_node, 0);
+
gfc_build_intrinsic_function_decls ();
gfc_build_intrinsic_lib_fndecls ();
gfc_build_io_library_fndecls ();
@@ -3903,6 +3930,13 @@
else
gfc_add_expr_to_block (&block, tmp);
+ /* For main program, when memory runtime checking is enabled,
+ print out a final report. */
+ if (sym->attr.is_main_program && gfc_option.rtcheck & GFC_RTCHECK_MEMLEAKS)
+ {
+ tmp = build_call_expr (gfor_fndecl_memory_check_report, 0);
+ gfc_add_expr_to_block (&block, tmp);
+ }
/* Add all the decls we created during processing. */
decl = saved_function_decls;
Index: gcc/fortran/trans-intrinsic.c
===================================================================
--- gcc/fortran/trans-intrinsic.c (revision 142245)
+++ gcc/fortran/trans-intrinsic.c (working copy)
@@ -276,7 +276,8 @@
gfc_add_expr_to_block (&se->pre, tmp);
/* Free the temporary afterwards. */
- tmp = gfc_call_free (var);
+ tmp = gfc_call_free (var, true, &gfc_current_locus,
+ ALLOCTYPE_TEMPORARY);
gfc_add_expr_to_block (&se->post, tmp);
se->expr = var;
@@ -1352,7 +1353,8 @@
/* Free the temporary afterwards, if necessary. */
cond = fold_build2 (GT_EXPR, boolean_type_node,
len, build_int_cst (TREE_TYPE (len), 0));
- tmp = gfc_call_free (var);
+ tmp = gfc_call_free (var, true, &gfc_current_locus,
+ ALLOCTYPE_TEMPORARY);
tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
gfc_add_expr_to_block (&se->post, tmp);
@@ -1390,7 +1392,8 @@
/* Free the temporary afterwards, if necessary. */
cond = fold_build2 (GT_EXPR, boolean_type_node,
len, build_int_cst (TREE_TYPE (len), 0));
- tmp = gfc_call_free (var);
+ tmp = gfc_call_free (var, true, &gfc_current_locus,
+ ALLOCTYPE_TEMPORARY);
tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
gfc_add_expr_to_block (&se->post, tmp);
@@ -1430,7 +1433,8 @@
/* Free the temporary afterwards, if necessary. */
cond = fold_build2 (GT_EXPR, boolean_type_node,
len, build_int_cst (TREE_TYPE (len), 0));
- tmp = gfc_call_free (var);
+ tmp = gfc_call_free (var, true, &gfc_current_locus,
+ ALLOCTYPE_TEMPORARY);
tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
gfc_add_expr_to_block (&se->post, tmp);
@@ -1565,7 +1569,8 @@
/* Free the temporary afterwards, if necessary. */
cond = fold_build2 (GT_EXPR, boolean_type_node,
len, build_int_cst (TREE_TYPE (len), 0));
- tmp = gfc_call_free (var);
+ tmp = gfc_call_free (var, true, &gfc_current_locus,
+ ALLOCTYPE_TEMPORARY);
tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
gfc_add_expr_to_block (&se->post, tmp);
@@ -3663,7 +3668,8 @@
/* Free the temporary. */
gfc_start_block (&block);
- tmp = gfc_call_free (convert (pvoid_type_node, source));
+ tmp = gfc_call_free (source, true, &gfc_current_locus,
+ ALLOCTYPE_TEMPORARY);
gfc_add_expr_to_block (&block, tmp);
stmt = gfc_finish_block (&block);
@@ -4159,7 +4165,8 @@
/* Free the temporary afterwards, if necessary. */
cond = fold_build2 (GT_EXPR, boolean_type_node,
len, build_int_cst (TREE_TYPE (len), 0));
- tmp = gfc_call_free (var);
+ tmp = gfc_call_free (var, true, &gfc_current_locus,
+ ALLOCTYPE_TEMPORARY);
tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
gfc_add_expr_to_block (&se->post, tmp);
Index: gcc/fortran/options.c
===================================================================
--- gcc/fortran/options.c (revision 142245)
+++ gcc/fortran/options.c (working copy)
@@ -125,6 +125,7 @@
gfc_option.flag_align_commons = 1;
gfc_option.fpe = 0;
+ gfc_option.rtcheck = 0;
/* Argument pointers cannot point to anything but their argument. */
flag_argument_noalias = 3;
@@ -232,6 +233,10 @@
if (flag_whole_program)
gfc_fatal_error ("Option -fwhole-program is not supported for Fortran");
+ /* -fbounds-check is equivalent to -fruntime-check=bounds */
+ if (flag_bounds_check)
+ gfc_option.rtcheck |= GFC_RTCHECK_BOUNDS;
+
/* Verify the input file name. */
if (!filename || strcmp (filename, "-") == 0)
{
@@ -449,6 +454,41 @@
}
+static void
+gfc_handle_runtime_check_option (const char *arg)
+{
+ int result, pos = 0, n;
+ static const char * const optname[] = { "bounds", "memusage", "memleaks",
+ "recursion", NULL };
+ static const int optmask[] = { GFC_RTCHECK_BOUNDS, GFC_RTCHECK_MEMUSAGE,
+ GFC_RTCHECK_MEMLEAKS, GFC_RTCHECK_RECURSION, 0 };
+
+ while (*arg)
+ {
+ while (*arg == ',')
+ arg++;
+
+ while (arg[pos] && arg[pos] != ',')
+ pos++;
+
+ result = 0;
+ for (n = 0; optname[n] != NULL; n++)
+ {
+ if (optname[n] && strncmp (optname[n], arg, pos) == 0)
+ {
+ gfc_option.rtcheck |= optmask[n];
+ arg += pos;
+ pos = 0;
+ result = 1;
+ break;
+ }
+ }
+ if (!result)
+ gfc_fatal_error ("Argument to -fruntime-check is not valid: %s", arg);
+ }
+}
+
+
/* Handle command-line options. Returns 0 if unrecognized, 1 if
recognized and handled. */
@@ -843,6 +883,11 @@
case OPT_falign_commons:
gfc_option.flag_align_commons = value;
break;
+
+ case OPT_fruntime_check_:
+ gfc_handle_runtime_check_option (arg);
+ break;
+
}
return result;
Index: libgfortran/Makefile.in
===================================================================
--- libgfortran/Makefile.in (revision 142245)
+++ libgfortran/Makefile.in (working copy)
@@ -79,15 +79,29 @@
LTLIBRARIES = $(myexeclib_LTLIBRARIES) $(toolexeclib_LTLIBRARIES)
libgfortran_la_LIBADD =
am__libgfortran_la_SOURCES_DIST = runtime/backtrace.c \
- runtime/compile_options.c runtime/convert_char.c \
- runtime/environ.c runtime/error.c runtime/fpu.c runtime/main.c \
- runtime/memory.c runtime/pause.c runtime/stop.c \
- runtime/string.c runtime/select.c $(srcdir)/generated/all_l1.c \
- $(srcdir)/generated/all_l2.c $(srcdir)/generated/all_l4.c \
- $(srcdir)/generated/all_l8.c $(srcdir)/generated/all_l16.c \
- $(srcdir)/generated/any_l1.c $(srcdir)/generated/any_l2.c \
- $(srcdir)/generated/any_l4.c $(srcdir)/generated/any_l8.c \
- $(srcdir)/generated/any_l16.c $(srcdir)/generated/count_1_l.c \
+ runtime/compile_options.c \
+ runtime/convert_char.c \
+ runtime/environ.c \
+ runtime/error.c \
+ runtime/fpu.c \
+ runtime/main.c \
+ runtime/memory.c \
+ runtime/memory_check.c \
+ runtime/pause.c \
+ runtime/stop.c \
+ runtime/string.c \
+ runtime/select.c \
+ $(srcdir)/generated/all_l1.c \
+ $(srcdir)/generated/all_l2.c \
+ $(srcdir)/generated/all_l4.c \
+ $(srcdir)/generated/all_l8.c \
+ $(srcdir)/generated/all_l16.c \
+ $(srcdir)/generated/any_l1.c \
+ $(srcdir)/generated/any_l2.c \
+ $(srcdir)/generated/any_l4.c \
+ $(srcdir)/generated/any_l8.c \
+ $(srcdir)/generated/any_l16.c \
+ $(srcdir)/generated/count_1_l.c \
$(srcdir)/generated/count_2_l.c \
$(srcdir)/generated/count_4_l.c \
$(srcdir)/generated/count_8_l.c \
@@ -581,8 +595,8 @@
intrinsics/f2c_specifics.F90 libgfortran_c.c $(filter-out \
%.c,$(prereq_SRC))
am__objects_1 = backtrace.lo compile_options.lo convert_char.lo \
- environ.lo error.lo fpu.lo main.lo memory.lo pause.lo stop.lo \
- string.lo select.lo
+ environ.lo error.lo fpu.lo main.lo memory.lo memory_check.lo \
+ pause.lo stop.lo string.lo select.lo
am__objects_2 = all_l1.lo all_l2.lo all_l4.lo all_l8.lo all_l16.lo
am__objects_3 = any_l1.lo any_l2.lo any_l4.lo any_l8.lo any_l16.lo
am__objects_4 = count_1_l.lo count_2_l.lo count_4_l.lo count_8_l.lo \
@@ -960,6 +974,7 @@
libgfortranbegin_la_LDFLAGS = -static
AM_CPPFLAGS = -iquote$(srcdir)/io -I$(srcdir)/$(MULTISRCTOP)../gcc \
-I$(srcdir)/$(MULTISRCTOP)../gcc/config \
+ -I$(srcdir)/$(MULTISRCTOP)../include \
-I$(MULTIBUILDTOP)../../$(host_subdir)/gcc -D_GNU_SOURCE
gfor_io_src = \
@@ -1053,6 +1068,7 @@
runtime/fpu.c \
runtime/main.c \
runtime/memory.c \
+runtime/memory_check.c \
runtime/pause.c \
runtime/stop.c \
runtime/string.c \
@@ -1988,6 +2004,7 @@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/maxval_r4.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/maxval_r8.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/memory.Plo@am__quote@
+@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/memory_check.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/minloc0_16_i1.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/minloc0_16_i16.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/minloc0_16_i2.Plo@am__quote@
@@ -2722,6 +2739,13 @@
@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
@am__fastdepCC_FALSE@ $(LIBTOOL) --tag=CC --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o memory.lo `test -f 'runtime/memory.c' || echo '$(srcdir)/'`runtime/memory.c
+memory_check.lo: runtime/memory_check.c
+@am__fastdepCC_TRUE@ if $(LIBTOOL) --tag=CC --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT memory_check.lo -MD -MP -MF "$(DEPDIR)/memory_check.Tpo" -c -o memory_check.lo `test -f 'runtime/memory_check.c' || echo '$(srcdir)/'`runtime/memory_check.c; \
+@am__fastdepCC_TRUE@ then mv -f "$(DEPDIR)/memory_check.Tpo" "$(DEPDIR)/memory_check.Plo"; else rm -f "$(DEPDIR)/memory_check.Tpo"; exit 1; fi
+@AMDEP_TRUE@@am__fastdepCC_FALSE@ source='runtime/memory_check.c' object='memory_check.lo' libtool=yes @AMDEPBACKSLASH@
+@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
+@am__fastdepCC_FALSE@ $(LIBTOOL) --tag=CC --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o memory_check.lo `test -f 'runtime/memory_check.c' || echo '$(srcdir)/'`runtime/memory_check.c
+
pause.lo: runtime/pause.c
@am__fastdepCC_TRUE@ if $(LIBTOOL) --tag=CC --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -MT pause.lo -MD -MP -MF "$(DEPDIR)/pause.Tpo" -c -o pause.lo `test -f 'runtime/pause.c' || echo '$(srcdir)/'`runtime/pause.c; \
@am__fastdepCC_TRUE@ then mv -f "$(DEPDIR)/pause.Tpo" "$(DEPDIR)/pause.Plo"; else rm -f "$(DEPDIR)/pause.Tpo"; exit 1; fi
Index: libgfortran/runtime/memory_check.c
===================================================================
--- libgfortran/runtime/memory_check.c (revision 0)
+++ libgfortran/runtime/memory_check.c (revision 0)
@@ -0,0 +1,254 @@
+/* Instrumented routines for memory management.
+ Copyright 2008 Free Software Foundation, Inc.
+ Contributed by François-Xavier Coudert <fxcoudert@gcc.gnu.org>
+
+This file is part of the GNU Fortran runtime library (libgfortran).
+
+Libgfortran 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 of the License, or (at your option) any later version.
+
+In addition to the permissions in the GNU General Public License, the
+Free Software Foundation gives you unlimited permission to link the
+compiled version of this file into combinations with other programs,
+and to distribute those combinations without any restriction coming
+from the use of this file. (The General Public License restrictions
+do apply in other respects; for example, they cover modification of
+the file, and distribution when not linked into a combine
+executable.)
+
+Libgfortran 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 libgfortran; see the file COPYING. If not,
+write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+Boston, MA 02110-1301, USA. */
+
+#include "libgfortran.h"
+#include "hashtab.h"
+
+#include <stdlib.h>
+
+/* Recording the amount of memory used. */
+static size_t usedmem_temp = 0, peakmem_temp = 0;
+static size_t usedmem_user = 0, peakmem_user = 0;
+static htab_t tab = NULL;
+
+/* A structure to store our allocations in. */
+typedef struct
+{
+ void *p;
+ size_t size;
+ const char *file;
+ int line;
+} allocation_t;
+
+
+static char *
+pretty_memsize (size_t size)
+{
+ static char buf[40];
+ static const char *mult[] = { "", "K", "M", "G", "T", "P", "E", "Z", "Y",
+ NULL };
+ int m, p;
+ double s;
+
+ m = 0;
+ s = size;
+ while (s > 1024 && mult[m+1] != NULL)
+ s /= 1024, m++;
+ p = (s > 100 ? 0 : (s > 10 ? 1 : 2));
+
+#ifndef HAVE_SNPRINTF
+# define snprintf(format, size, ...) sprintf (format, __VA_ARGS__)
+#endif
+
+ snprintf (buf, sizeof(buf), "%.*f %sB", p, s, mult[m]);
+ return buf;
+}
+
+
+#define new_allocation_t() (malloc(sizeof(allocation_t)))
+
+static hashval_t
+hashval (const void *a)
+{
+ return htab_hash_pointer (((allocation_t *) a)->p);
+}
+
+static int
+hasheq (const void *a, const void *b)
+{
+ return (((allocation_t *) a)->p == ((allocation_t *) b)->p);
+}
+
+static void
+do_nothing (void *a __attribute__((unused)))
+{
+ ;
+}
+
+
+#define INIT { if (tab == NULL) \
+ tab = htab_create_alloc (128, hashval, hasheq, do_nothing, \
+ calloc, free); }
+
+static void
+register_allocation (void *p, const size_t size, const char *filename,
+ const int line, const int type)
+{
+ allocation_t *a, **slot;
+
+ INIT;
+
+ /* Register the usage of memory. */
+ if (type == ALLOCTYPE_TEMPORARY)
+ {
+ usedmem_temp += size;
+ if (usedmem_temp > peakmem_temp)
+ peakmem_temp = usedmem_temp;
+ }
+ else
+ {
+ usedmem_user += size;
+ if (usedmem_user > peakmem_user)
+ peakmem_user = usedmem_user;
+ }
+
+ /* Register this allocation. */
+ a = malloc (sizeof (allocation_t));
+ a->p = p;
+ a->size = size;
+ a->file = filename;
+ a->line = line;
+ slot = (allocation_t **) htab_find_slot (tab, a, INSERT);
+ *slot = a;
+}
+
+void *
+malloc_check (size_t size, const char *filename, const int line, const int type)
+{
+ void *p;
+
+ p = malloc (size);
+ if (p)
+ register_allocation (p, size, filename, line, type);
+
+ return p;
+}
+
+
+static void
+register_deallocation (void *p, const char *filename, const int line,
+ const int type)
+{
+ allocation_t a, **slot;
+
+ INIT;
+
+ a.p = p;
+ slot = (allocation_t **) htab_find_slot (tab, &a, NO_INSERT);
+
+ if (slot && *slot)
+ {
+ /* Succesfully found in the allocation table. */
+ if (type == ALLOCTYPE_TEMPORARY)
+ usedmem_temp -= (*slot)->size;
+ else
+ usedmem_user -= (*slot)->size;
+
+ htab_clear_slot (tab, (void *) slot);
+ return;
+ }
+
+ /* If we come here, we've caught an error. */
+ if (filename == NULL)
+ st_printf (" !! Memory deallocation error in the code generated by the "
+ "GNU Fortran compiler.\n !! Please report this issue to "
+ "http://gcc.gnu.org/bugzilla/\n";);
+ else
+ st_printf ("Error in memory deallocation at line %d of source file '%s': "
+ "freeing memory that has not been allocated by us.\n", line,
+ filename);
+
+ sys_exit (2);
+}
+
+void
+free_check (void *p, const char *filename, const int line, const int type)
+{
+ free (p);
+ register_deallocation (p, filename, line, type);
+}
+
+
+void *
+realloc_check (void *p, size_t size, const char *filename, const int line,
+ const int type)
+{
+ void *newp;
+
+ if (p)
+ register_deallocation (p, filename, line, type);
+
+ newp = realloc (p, size);
+
+ if (newp)
+ register_allocation (newp, size, filename, line, type);
+
+ return newp;
+}
+
+
+/* Report we output when exiting the program. */
+
+static int
+report_callback (void **slot, void *ptr __attribute__((unused)))
+{
+ static unsigned num = 0;
+ num++;
+
+ if ((*(allocation_t **) slot)->file == NULL)
+ {
+ st_printf (" !! Memory leak in the code generated by the GNU Fortran "
+ "compiler.\n !! Please report this issue to "
+ "http://gcc.gnu.org/bugzilla/\n";);
+ return 0;
+ }
+
+ st_printf (" - at line %d of file '%s', allocation of %s (address %p)\n",
+ (*(allocation_t **) slot)->line, (*(allocation_t **) slot)->file,
+ pretty_memsize ((*(allocation_t **) slot)->size),
+ (*(allocation_t **) slot)->p);
+ return (num >= 20 ? 0 : 1);
+}
+
+void
+memory_check_report (void)
+{
+ unsigned long n;
+
+ if (tab == NULL)
+ return;
+
+ n = (unsigned long) htab_elements (tab);
+
+ if (n > 0)
+ {
+ st_printf ("\n\nFortran runtime checking: found %lu memory leaks\n", n);
+ htab_traverse_noresize (tab, report_callback, NULL);
+ }
+ else
+ st_printf ("\n\nFortran runtime checks: No memory leak found.\n");
+
+ st_printf ("\n");
+ st_printf ("Peak user-allocated memory: %s\n", pretty_memsize (peakmem_user));
+ st_printf ("Peak memory created by the compiler for temporaries: %s\n",
+ pretty_memsize (peakmem_temp));
+
+ htab_delete (tab);
+}
Index: libgfortran/libgfortran.h
===================================================================
--- libgfortran/libgfortran.h (revision 142245)
+++ libgfortran/libgfortran.h (working copy)
@@ -694,6 +694,21 @@
extern void *internal_malloc_size (size_t) __attribute__ ((malloc));
internal_proto(internal_malloc_size);
+/* memory_check.c */
+
+extern void *malloc_check (size_t, const char *, const int, const int);
+export_proto(malloc_check);
+
+extern void free_check (void *, const char *, const int, const int);
+export_proto(free_check);
+
+extern void * realloc_check (void *, size_t, const char *, const int,
+ const int);
+export_proto(realloc_check);
+
+extern void memory_check_report (void);
+export_proto(memory_check_report);
+
/* environ.c */
extern int check_buffered (int);
Index: libgfortran/Makefile.am
===================================================================
--- libgfortran/Makefile.am (revision 142245)
+++ libgfortran/Makefile.am (working copy)
@@ -28,6 +28,7 @@
## use -iquote
AM_CPPFLAGS = -iquote$(srcdir)/io -I$(srcdir)/$(MULTISRCTOP)../gcc \
-I$(srcdir)/$(MULTISRCTOP)../gcc/config \
+ -I$(srcdir)/$(MULTISRCTOP)../include \
-I$(MULTIBUILDTOP)../../$(host_subdir)/gcc -D_GNU_SOURCE
# Fortran rules for complex multiplication and division
@@ -124,6 +125,7 @@
runtime/fpu.c \
runtime/main.c \
runtime/memory.c \
+runtime/memory_check.c \
runtime/pause.c \
runtime/stop.c \
runtime/string.c \