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-array.c =================================================================== --- gcc/fortran/trans-array.c (revision 145225) +++ 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. */ @@ -4192,7 +4199,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. */ @@ -4206,7 +4218,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); @@ -4568,7 +4581,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); @@ -5420,7 +5434,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); @@ -5465,7 +5480,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. */ @@ -5524,8 +5540,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-expr.c =================================================================== --- gcc/fortran/trans-expr.c (revision 145225) +++ 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.h =================================================================== --- gcc/fortran/trans-array.h (revision 145225) +++ gcc/fortran/trans-array.h (working copy) @@ -20,7 +20,7 @@ . */ /* 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 145225) +++ 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/trans-stmt.c =================================================================== --- gcc/fortran/trans-stmt.c (revision 145225) +++ gcc/fortran/trans-stmt.c (working copy) @@ -2551,7 +2551,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); } } @@ -2710,7 +2711,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); } } @@ -3057,7 +3059,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) @@ -3666,14 +3669,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); } } @@ -3966,7 +3971,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); @@ -4090,10 +4095,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 145225) +++ gcc/fortran/libgfortran.h (working copy) @@ -45,8 +45,10 @@ #define GFC_RTCHECK_ARRAY_TEMPS (1<<1) #define GFC_RTCHECK_RECURSION (1<<2) #define GFC_RTCHECK_DO (1<<3) +#define GFC_RTCHECK_MEMLEAKS (1<<4) #define GFC_RTCHECK_ALL (GFC_RTCHECK_BOUNDS | GFC_RTCHECK_ARRAY_TEMPS \ - | GFC_RTCHECK_RECURSION | GFC_RTCHECK_DO) + | GFC_RTCHECK_RECURSION | GFC_RTCHECK_DO \ + | GFC_RTCHECK_MEMLEAKS) /* Possible values for the CONVERT I/O specifier. */ @@ -118,3 +120,11 @@ 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 145225) +++ gcc/fortran/trans.c (working copy) @@ -584,7 +584,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; @@ -637,11 +638,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")); @@ -705,7 +715,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; @@ -721,7 +731,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); @@ -750,11 +760,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, @@ -774,29 +783,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: @@ -829,7 +860,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; @@ -873,8 +904,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)) @@ -940,8 +970,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)); @@ -1036,16 +1074,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); @@ -1247,6 +1289,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 145225) +++ gcc/fortran/trans.h (working copy) @@ -462,8 +462,8 @@ void gfc_trans_same_strlen_check (const char*, locus*, tree, tree, stmtblock_t*); -/* 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); @@ -472,13 +472,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); @@ -539,6 +539,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 145225) +++ 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. */ 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 145225) +++ 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 @@ -2582,6 +2586,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 (); @@ -3941,10 +3968,18 @@ else gfc_add_expr_to_block (&block, tmp); - /* Reset recursion-check variable. */ - if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION) && !sym->attr.recursive) - gfc_add_modify (&block, recurcheckvar, boolean_false_node); + /* Reset recursion-check variable. */ + if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION) && !sym->attr.recursive) + gfc_add_modify (&block, recurcheckvar, boolean_false_node); + /* 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; while (decl) @@ -4101,5 +4136,4 @@ rest_of_decl_compilation (decl, 1, 0); } - #include "gt-fortran-trans-decl.h" Index: gcc/fortran/trans-intrinsic.c =================================================================== --- gcc/fortran/trans-intrinsic.c (revision 145225) +++ 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; @@ -1386,7 +1387,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); @@ -1424,7 +1426,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); @@ -1464,7 +1467,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); @@ -1599,7 +1603,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); @@ -3723,7 +3728,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); @@ -4221,7 +4227,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 145225) +++ gcc/fortran/options.c (working copy) @@ -458,10 +458,12 @@ { int result, pos = 0, n; static const char * const optname[] = { "all", "bounds", "array-temps", - "recursion", "do", NULL }; + "recursion", "do", "memleaks", + NULL }; static const int optmask[] = { GFC_RTCHECK_ALL, GFC_RTCHECK_BOUNDS, GFC_RTCHECK_ARRAY_TEMPS, GFC_RTCHECK_RECURSION, GFC_RTCHECK_DO, + GFC_RTCHECK_MEMLEAKS, 0 }; while (*arg) Index: libgfortran/Makefile.in =================================================================== --- libgfortran/Makefile.in (revision 145225) +++ libgfortran/Makefile.in (working copy) @@ -81,13 +81,14 @@ 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/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 +582,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 \ @@ -953,13 +954,14 @@ LTLDFLAGS = $(shell $(SHELL) $(top_srcdir)/../libtool-ldflags $(LDFLAGS)) toolexeclib_LTLIBRARIES = libgfortran.la libgfortran_la_LINK = $(LINK) -libgfortran_la_LDFLAGS = -version-info `grep -v '^\#' $(srcdir)/libtool-version` $(LTLDFLAGS) -lm $(extra_ldflags_libgfortran) $(version_arg) +libgfortran_la_LDFLAGS = -version-info `grep -v '^\#' $(srcdir)/libtool-version` $(LTLDFLAGS) -L../libiberty -liberty -lm $(extra_ldflags_libgfortran) $(version_arg) myexeclib_LTLIBRARIES = libgfortranbegin.la myexeclibdir = $(libdir)/gcc/$(target_alias)/$(gcc_version)$(MULTISUBDIR) libgfortranbegin_la_SOURCES = fmain.c 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 +1055,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 +1991,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 +2726,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 2009 Free Software Foundation, Inc. + Contributed by François-Xavier Coudert + +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 + +/* 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/gfortran.map =================================================================== --- libgfortran/gfortran.map (revision 145225) +++ libgfortran/gfortran.map (working copy) @@ -1069,8 +1069,12 @@ _gfortran_erfc_scaled_r16; _gfortran_erfc_scaled_r4; _gfortran_erfc_scaled_r8; + _gfortran_free_check; + _gfortran_malloc_check; + _gfortran_memory_check_report; _gfortran_pack_char4; _gfortran_pack_s_char4; + _gfortran_realloc_check; _gfortran_reshape_char4; _gfortran_runtime_warning_at; _gfortran_selected_char_kind; Index: libgfortran/libgfortran.h =================================================================== --- libgfortran/libgfortran.h (revision 145225) +++ libgfortran/libgfortran.h (working copy) @@ -1,10 +1,10 @@ /* Common declarations for all of libgfortran. - Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008 + Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 Free Software Foundation, Inc. Contributed by Paul Brook , and Andy Vaught -This file is part of the GNU Fortran 95 runtime library (libgfortran). +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 Lesser General Public @@ -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 145225) +++ libgfortran/Makefile.am (working copy) @@ -17,7 +17,7 @@ toolexeclib_LTLIBRARIES = libgfortran.la libgfortran_la_LINK = $(LINK) -libgfortran_la_LDFLAGS = -version-info `grep -v '^\#' $(srcdir)/libtool-version` $(LTLDFLAGS) -lm $(extra_ldflags_libgfortran) $(version_arg) +libgfortran_la_LDFLAGS = -version-info `grep -v '^\#' $(srcdir)/libtool-version` $(LTLDFLAGS) -L../libiberty -liberty -lm $(extra_ldflags_libgfortran) $(version_arg) myexeclib_LTLIBRARIES = libgfortranbegin.la myexeclibdir = $(libdir)/gcc/$(target_alias)/$(gcc_version)$(MULTISUBDIR) @@ -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 \