This is the mail archive of the gcc-patches@gcc.gnu.org mailing list for the GCC project.


Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]
Other format: [Raw text]

[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 \

Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]