From 4376b7cf2b7d906c1952205ec3242e689f84f671 Mon Sep 17 00:00:00 2001 From: Francois-Xavier Coudert Date: Wed, 29 Aug 2007 12:44:32 +0000 Subject: [PATCH] builtin-types.def (BT_FN_PTR_PTR_SIZE): New type. * builtin-types.def (BT_FN_PTR_PTR_SIZE): New type. * builtins.def (BUILT_IN_REALLOC): New builtin. * trans-array.c (gfc_grow_array): Use gfc_call_realloc. (gfc_array_allocate): Use gfc_allocate_with_status and gfc_allocate_array_with_status. (gfc_array_deallocate): Use gfc_deallocate_with_status. (gfc_trans_dealloc_allocated): Use gfc_deallocate_with_status. * trans-stmt.c (gfc_trans_allocate): Use gfc_allocate_with_status. (gfc_trans_deallocate): Use gfc_deallocate_with_status. * trans.c (gfc_allocate_with_status, gfc_allocate_array_with_status, gfc_deallocate_with_status, gfc_call_realloc): New functions. * trans.h (gfc_allocate_with_status, gfc_allocate_array_with_status, gfc_deallocate_with_status, gfc_call_realloc): New prototypes. (gfor_fndecl_internal_realloc, gfor_fndecl_allocate, gfor_fndecl_allocate_array, gfor_fndecl_deallocate): Remove. * f95-lang.c (gfc_init_builtin_functions): Create decl for BUILT_IN_REALLOC. * trans-decl.c (gfor_fndecl_internal_realloc, gfor_fndecl_allocate, gfor_fndecl_allocate_array, gfor_fndecl_deallocate): Remove function decls. (gfc_build_builtin_function_decls): Likewise. * runtime/memory.c (internal_realloc, allocate, allocate_array, deallocate): Remove functions. * gfortran.map (_gfortran_allocate, _gfortran_allocate_array, _gfortran_deallocate, _gfortran_internal_realloc): Remove symbols. * libgfortran.h (error_codes): Add comment. * gfortran.dg/alloc_comp_basics_1.f90: Update check. * gfortran.dg/alloc_comp_constructor_1.f90: Update check. From-SVN: r127897 --- gcc/ChangeLog | 5 + gcc/builtin-types.def | 2 + gcc/builtins.def | 1 + gcc/fortran/ChangeLog | 22 ++ gcc/fortran/f95-lang.c | 6 + gcc/fortran/trans-array.c | 39 +- gcc/fortran/trans-decl.c | 29 -- gcc/fortran/trans-stmt.c | 15 +- gcc/fortran/trans.c | 373 ++++++++++++++++++ gcc/fortran/trans.h | 16 +- gcc/testsuite/ChangeLog | 5 + .../gfortran.dg/alloc_comp_basics_1.f90 | 2 +- .../gfortran.dg/alloc_comp_constructor_1.f90 | 2 +- libgfortran/ChangeLog | 8 + libgfortran/gfortran.map | 4 - libgfortran/libgfortran.h | 4 +- libgfortran/runtime/memory.c | 124 ------ 17 files changed, 452 insertions(+), 205 deletions(-) diff --git a/gcc/ChangeLog b/gcc/ChangeLog index 5300252823f..c649ee24f2b 100644 --- a/gcc/ChangeLog +++ b/gcc/ChangeLog @@ -1,3 +1,8 @@ +2007-08-29 Francois-Xavier Coudert + + * gcc/builtin-types.def (BT_FN_PTR_PTR_SIZE): New type. + * gcc/builtins.def (BUILT_IN_REALLOC): New builtin. + 2007-08-29 Douglas Gregor PR c++/33194 diff --git a/gcc/builtin-types.def b/gcc/builtin-types.def index 792e8da7097..081a33f0467 100644 --- a/gcc/builtin-types.def +++ b/gcc/builtin-types.def @@ -289,6 +289,8 @@ DEF_FUNCTION_TYPE_2 (BT_FN_INT_CONST_STRING_VALIST_ARG, BT_INT, BT_CONST_STRING, BT_VALIST_ARG) DEF_FUNCTION_TYPE_2 (BT_FN_PTR_SIZE_SIZE, BT_PTR, BT_SIZE, BT_SIZE) +DEF_FUNCTION_TYPE_2 (BT_FN_PTR_PTR_SIZE, + BT_PTR, BT_PTR, BT_SIZE) DEF_FUNCTION_TYPE_2 (BT_FN_COMPLEX_FLOAT_COMPLEX_FLOAT_COMPLEX_FLOAT, BT_COMPLEX_FLOAT, BT_COMPLEX_FLOAT, BT_COMPLEX_FLOAT) DEF_FUNCTION_TYPE_2 (BT_FN_COMPLEX_DOUBLE_COMPLEX_DOUBLE_COMPLEX_DOUBLE, diff --git a/gcc/builtins.def b/gcc/builtins.def index 628fd257e9e..8bedfbf30e9 100644 --- a/gcc/builtins.def +++ b/gcc/builtins.def @@ -687,6 +687,7 @@ DEF_GCC_BUILTIN (BUILT_IN_POPCOUNTIMAX, "popcountimax", BT_FN_INT_UINTMAX DEF_GCC_BUILTIN (BUILT_IN_POPCOUNTL, "popcountl", BT_FN_INT_ULONG, ATTR_CONST_NOTHROW_LIST) DEF_GCC_BUILTIN (BUILT_IN_POPCOUNTLL, "popcountll", BT_FN_INT_ULONGLONG, ATTR_CONST_NOTHROW_LIST) DEF_GCC_BUILTIN (BUILT_IN_PREFETCH, "prefetch", BT_FN_VOID_CONST_PTR_VAR, ATTR_NOVOPS_LIST) +DEF_LIB_BUILTIN (BUILT_IN_REALLOC, "realloc", BT_FN_PTR_PTR_SIZE, ATTR_NOTHROW_LIST) DEF_GCC_BUILTIN (BUILT_IN_RETURN, "return", BT_FN_VOID_PTR, ATTR_NORETURN_NOTHROW_LIST) DEF_GCC_BUILTIN (BUILT_IN_RETURN_ADDRESS, "return_address", BT_FN_PTR_UINT, ATTR_NULL) DEF_GCC_BUILTIN (BUILT_IN_SAVEREGS, "saveregs", BT_FN_PTR_VAR, ATTR_NULL) diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 582d035f186..b523e8aa007 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,25 @@ +2007-08-29 Francois-Xavier Coudert + + * trans-array.c (gfc_grow_array): Use gfc_call_realloc. + (gfc_array_allocate): Use gfc_allocate_with_status and + gfc_allocate_array_with_status. + (gfc_array_deallocate): Use gfc_deallocate_with_status. + (gfc_trans_dealloc_allocated): Use gfc_deallocate_with_status. + * trans-stmt.c (gfc_trans_allocate): Use gfc_allocate_with_status. + (gfc_trans_deallocate): Use gfc_deallocate_with_status. + * trans.c (gfc_allocate_with_status, gfc_allocate_array_with_status, + gfc_deallocate_with_status, gfc_call_realloc): New functions. + * trans.h (gfc_allocate_with_status, gfc_allocate_array_with_status, + gfc_deallocate_with_status, gfc_call_realloc): New prototypes. + (gfor_fndecl_internal_realloc, gfor_fndecl_allocate, + gfor_fndecl_allocate_array, gfor_fndecl_deallocate): Remove. + * f95-lang.c (gfc_init_builtin_functions): Create decl for + BUILT_IN_REALLOC. + * trans-decl.c (gfor_fndecl_internal_realloc, + gfor_fndecl_allocate, gfor_fndecl_allocate_array, + gfor_fndecl_deallocate): Remove function decls. + (gfc_build_builtin_function_decls): Likewise. + 2007-08-28 Jerry DeLisle PR fortran/33055 diff --git a/gcc/fortran/f95-lang.c b/gcc/fortran/f95-lang.c index 1e1b640537e..05f6750218d 100644 --- a/gcc/fortran/f95-lang.c +++ b/gcc/fortran/f95-lang.c @@ -1036,6 +1036,12 @@ gfc_init_builtin_functions (void) "malloc", false); DECL_IS_MALLOC (built_in_decls[BUILT_IN_MALLOC]) = 1; + tmp = tree_cons (NULL_TREE, pvoid_type_node, void_list_node); + tmp = tree_cons (NULL_TREE, size_type_node, tmp); + ftype = build_function_type (pvoid_type_node, tmp); + gfc_define_builtin ("__builtin_realloc", ftype, BUILT_IN_REALLOC, + "realloc", false); + tmp = tree_cons (NULL_TREE, void_type_node, void_list_node); ftype = build_function_type (integer_type_node, tmp); gfc_define_builtin ("__builtin_isnan", ftype, BUILT_IN_ISNAN, diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 73a57e82c4c..09d20cd4291 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -843,17 +843,11 @@ gfc_grow_array (stmtblock_t * pblock, tree desc, tree extra) /* Calculate the new array size. */ size = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc))); tmp = build2 (PLUS_EXPR, gfc_array_index_type, ubound, gfc_index_one_node); - arg1 = build2 (MULT_EXPR, gfc_array_index_type, tmp, - fold_convert (gfc_array_index_type, size)); + arg1 = build2 (MULT_EXPR, size_type_node, fold_convert (size_type_node, tmp), + fold_convert (size_type_node, size)); - /* Pick the realloc function. */ - if (gfc_index_integer_kind == 4 || gfc_index_integer_kind == 8) - tmp = gfor_fndecl_internal_realloc; - else - gcc_unreachable (); - - /* Set the new data pointer. */ - tmp = build_call_expr (tmp, 2, arg0, arg1); + /* Call the realloc() function. */ + tmp = gfc_call_realloc (pblock, arg0, arg1); gfc_conv_descriptor_data_set (pblock, desc, tmp); } @@ -3571,7 +3565,6 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree pstat) { tree tmp; tree pointer; - tree allocate; tree offset; tree size; gfc_expr **lower; @@ -3629,22 +3622,11 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree pstat) pointer = gfc_conv_descriptor_data_get (se->expr); STRIP_NOPS (pointer); - if (TYPE_PRECISION (gfc_array_index_type) == 32 || - TYPE_PRECISION (gfc_array_index_type) == 64) - { - if (allocatable_array) - allocate = gfor_fndecl_allocate_array; - else - allocate = gfor_fndecl_allocate; - } - else - gcc_unreachable (); - /* The allocate_array variants take the old pointer as first argument. */ if (allocatable_array) - tmp = build_call_expr (allocate, 3, pointer, size, pstat); + tmp = gfc_allocate_array_with_status (&se->pre, pointer, size, pstat); else - tmp = build_call_expr (allocate, 2, size, pstat); + tmp = gfc_allocate_with_status (&se->pre, size, pstat); tmp = build2 (MODIFY_EXPR, void_type_node, pointer, tmp); gfc_add_expr_to_block (&se->pre, tmp); @@ -3680,7 +3662,7 @@ gfc_array_deallocate (tree descriptor, tree pstat) STRIP_NOPS (var); /* Parameter is the address of the data component. */ - tmp = build_call_expr (gfor_fndecl_deallocate, 2, var, pstat); + tmp = gfc_deallocate_with_status (var, pstat, false); gfc_add_expr_to_block (&block, tmp); /* Zero the data pointer. */ @@ -4998,7 +4980,6 @@ tree gfc_trans_dealloc_allocated (tree descriptor) { tree tmp; - tree ptr; tree var; stmtblock_t block; @@ -5006,13 +4987,11 @@ gfc_trans_dealloc_allocated (tree descriptor) var = gfc_conv_descriptor_data_get (descriptor); STRIP_NOPS (var); - tmp = gfc_create_var (gfc_array_index_type, NULL); - ptr = build_fold_addr_expr (tmp); - /* Call array_deallocate with an int* present in the second argument. + /* 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 = build_call_expr (gfor_fndecl_deallocate, 2, var, ptr); + tmp = gfc_deallocate_with_status (var, NULL_TREE, true); gfc_add_expr_to_block (&block, tmp); /* Zero the data pointer. */ diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index 047ced92c1b..8ea25fc2532 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -73,10 +73,6 @@ tree gfc_static_ctors; /* Function declarations for builtin library functions. */ -tree gfor_fndecl_internal_realloc; -tree gfor_fndecl_allocate; -tree gfor_fndecl_allocate_array; -tree gfor_fndecl_deallocate; tree gfor_fndecl_pause_numeric; tree gfor_fndecl_pause_string; tree gfor_fndecl_stop_numeric; @@ -2273,35 +2269,10 @@ void gfc_build_builtin_function_decls (void) { tree gfc_int4_type_node = gfc_get_int_type (4); - tree gfc_pint4_type_node = build_pointer_type (gfc_int4_type_node); - - gfor_fndecl_internal_realloc = - gfc_build_library_function_decl (get_identifier - (PREFIX("internal_realloc")), - pvoid_type_node, 2, pvoid_type_node, - gfc_array_index_type); - - gfor_fndecl_allocate = - gfc_build_library_function_decl (get_identifier (PREFIX("allocate")), - pvoid_type_node, 2, - gfc_array_index_type, gfc_pint4_type_node); - DECL_IS_MALLOC (gfor_fndecl_allocate) = 1; - - gfor_fndecl_allocate_array = - gfc_build_library_function_decl (get_identifier (PREFIX("allocate_array")), - pvoid_type_node, 3, pvoid_type_node, - gfc_array_index_type, gfc_pint4_type_node); - DECL_IS_MALLOC (gfor_fndecl_allocate_array) = 1; - - gfor_fndecl_deallocate = - gfc_build_library_function_decl (get_identifier (PREFIX("deallocate")), - void_type_node, 2, pvoid_type_node, - gfc_pint4_type_node); gfor_fndecl_stop_numeric = gfc_build_library_function_decl (get_identifier (PREFIX("stop_numeric")), void_type_node, 1, gfc_int4_type_node); - /* Stop doesn't return. */ TREE_THIS_VOLATILE (gfor_fndecl_stop_numeric) = 1; diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index 47e08229fe9..f900ec52f4b 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -3565,11 +3565,7 @@ gfc_trans_allocate (gfc_code * code) TREE_USED (error_label) = 1; } else - { - pstat = integer_zero_node; - stat = error_label = NULL_TREE; - } - + pstat = stat = error_label = NULL_TREE; for (al = code->ext.alloc_list; al != NULL; al = al->next) { @@ -3590,7 +3586,7 @@ gfc_trans_allocate (gfc_code * code) if (expr->ts.type == BT_CHARACTER && tmp == NULL_TREE) tmp = se.string_length; - tmp = build_call_expr (gfor_fndecl_allocate, 2, tmp, pstat); + tmp = gfc_allocate_with_status (&se.pre, tmp, pstat); tmp = build2 (MODIFY_EXPR, void_type_node, se.expr, fold_convert (TREE_TYPE (se.expr), tmp)); gfc_add_expr_to_block (&se.pre, tmp); @@ -3679,10 +3675,7 @@ gfc_trans_deallocate (gfc_code * code) gfc_add_modify_expr (&block, astat, build_int_cst (TREE_TYPE (astat), 0)); } else - { - pstat = apstat = null_pointer_node; - stat = astat = NULL_TREE; - } + pstat = apstat = stat = astat = NULL_TREE; for (al = code->ext.alloc_list; al != NULL; al = al->next) { @@ -3720,7 +3713,7 @@ gfc_trans_deallocate (gfc_code * code) tmp = gfc_array_deallocate (se.expr, pstat); else { - tmp = build_call_expr (gfor_fndecl_deallocate, 2, se.expr, pstat); + tmp = gfc_deallocate_with_status (se.expr, pstat, false); gfc_add_expr_to_block (&se.pre, tmp); tmp = build2 (MODIFY_EXPR, void_type_node, diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c index 7092ac8cd0a..1113e80fdc3 100644 --- a/gcc/fortran/trans.c +++ b/gcc/fortran/trans.c @@ -473,6 +473,222 @@ gfc_call_malloc (stmtblock_t * block, tree type, tree size) return res; } +/* The status variable of allocate statement is set to ERROR_ALLOCATION + when the allocation wasn't successful. This value needs to be kept in + sync with libgfortran/libgfortran.h. */ +#define ERROR_ALLOCATION 5014 + +/* Allocate memory, using an optional status argument. + + This function follows the following pseudo-code: + + void * + allocate (size_t size, integer_type* stat) + { + void *newmem; + + if (stat) + *stat = 0; + + // The only time this can happen is the size wraps around. + if (size < 0) + { + if (stat) + { + *stat = ERROR_ALLOCATION; + newmem = NULL; + } + else + runtime_error ("Attempt to allocate negative amount of memory. " + "Possible integer overflow"); + } + else + { + newmem = malloc (MAX (size, 1)); + if (newmem == NULL) + { + if (stat) + *stat = ERROR_ALLOCATION; + else + runtime_error ("Out of memory"); + } + } + + return newmem; + } */ +tree +gfc_allocate_with_status (stmtblock_t * block, tree size, tree status) +{ + stmtblock_t alloc_block; + tree res, tmp, error, msg, cond; + tree status_type = status ? TREE_TYPE (TREE_TYPE (status)) : NULL_TREE; + + /* Evaluate size only once, and make sure it has the right type. */ + size = gfc_evaluate_now (size, block); + if (TREE_TYPE (size) != TREE_TYPE (size_type_node)) + size = fold_convert (size_type_node, size); + + /* Create a variable to hold the result. */ + res = gfc_create_var (pvoid_type_node, NULL); + + /* Set the optional status variable to zero. */ + if (status != NULL_TREE && !integer_zerop (status)) + { + tmp = fold_build2 (MODIFY_EXPR, status_type, + build1 (INDIRECT_REF, status_type, status), + build_int_cst (status_type, 0)); + tmp = fold_build3 (COND_EXPR, void_type_node, + fold_build2 (NE_EXPR, boolean_type_node, + status, build_int_cst (status_type, 0)), + tmp, build_empty_stmt ()); + gfc_add_expr_to_block (block, tmp); + } + + /* Generate the block of code handling (size < 0). */ + msg = gfc_build_addr_expr (pchar_type_node, gfc_build_cstring_const + ("Attempt to allocate negative amount of memory. " + "Possible integer overflow")); + error = build_call_expr (gfor_fndecl_runtime_error, 1, msg); + + if (status != NULL_TREE && !integer_zerop (status)) + { + /* Set the status variable if it's present. */ + stmtblock_t set_status_block; + + gfc_start_block (&set_status_block); + gfc_add_modify_expr (&set_status_block, + build1 (INDIRECT_REF, status_type, status), + build_int_cst (status_type, ERROR_ALLOCATION)); + gfc_add_modify_expr (&set_status_block, res, + build_int_cst (pvoid_type_node, 0)); + + tmp = fold_build2 (EQ_EXPR, boolean_type_node, status, + build_int_cst (status_type, 0)); + error = fold_build3 (COND_EXPR, void_type_node, tmp, error, + gfc_finish_block (&set_status_block)); + } + + /* The allocation itself. */ + gfc_start_block (&alloc_block); + gfc_add_modify_expr (&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_cstring_const ("Out of memory")); + tmp = build_call_expr (gfor_fndecl_os_error, 1, msg); + + if (status != NULL_TREE && !integer_zerop (status)) + { + /* Set the status variable if it's present. */ + tree tmp2; + + cond = fold_build2 (EQ_EXPR, boolean_type_node, status, + build_int_cst (status_type, 0)); + tmp2 = fold_build2 (MODIFY_EXPR, status_type, + build1 (INDIRECT_REF, status_type, status), + build_int_cst (status_type, ERROR_ALLOCATION)); + tmp = fold_build3 (COND_EXPR, void_type_node, cond, tmp, + tmp2); + } + + tmp = fold_build3 (COND_EXPR, void_type_node, + fold_build2 (EQ_EXPR, boolean_type_node, res, + build_int_cst (pvoid_type_node, 0)), + tmp, build_empty_stmt ()); + gfc_add_expr_to_block (&alloc_block, tmp); + + cond = fold_build2 (LT_EXPR, boolean_type_node, size, + build_int_cst (TREE_TYPE (size), 0)); + tmp = fold_build3 (COND_EXPR, void_type_node, cond, error, + gfc_finish_block (&alloc_block)); + gfc_add_expr_to_block (block, tmp); + + return res; +} + + +/* Generate code for an ALLOCATE statement when the argument is an + allocatable array. If the array is currently allocated, it is an + error to allocate it again. + + This function follows the following pseudo-code: + + void * + allocate_array (void *mem, size_t size, integer_type *stat) + { + if (mem == NULL) + return allocate (size, stat); + else + { + if (stat) + { + free (mem); + mem = allocate (size, stat); + *stat = ERROR_ALLOCATION; + return mem; + } + else + runtime_error ("Attempting to allocate already allocated array"); + } */ +tree +gfc_allocate_array_with_status (stmtblock_t * block, tree mem, tree size, + tree status) +{ + stmtblock_t alloc_block; + tree res, tmp, null_mem, alloc, error, msg; + tree type = TREE_TYPE (mem); + + if (TREE_TYPE (size) != TREE_TYPE (size_type_node)) + size = fold_convert (size_type_node, size); + + /* Create a variable to hold the result. */ + res = gfc_create_var (pvoid_type_node, NULL); + null_mem = fold_build2 (EQ_EXPR, boolean_type_node, mem, + build_int_cst (type, 0)); + + /* If mem is NULL, we call gfc_allocate_with_status. */ + gfc_start_block (&alloc_block); + tmp = gfc_allocate_with_status (&alloc_block, size, status); + gfc_add_modify_expr (&alloc_block, res, fold_convert (type, tmp)); + alloc = gfc_finish_block (&alloc_block); + + /* Otherwise, we issue a runtime error or set the status variable. */ + msg = gfc_build_addr_expr (pchar_type_node, gfc_build_cstring_const + ("Attempting to allocate already allocated array")); + error = build_call_expr (gfor_fndecl_runtime_error, 1, msg); + + if (status != NULL_TREE && !integer_zerop (status)) + { + tree status_type = TREE_TYPE (TREE_TYPE (status)); + 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)); + gfc_add_expr_to_block (&set_status_block, tmp); + + tmp = gfc_allocate_with_status (&set_status_block, size, status); + gfc_add_modify_expr (&set_status_block, res, fold_convert (type, tmp)); + + gfc_add_modify_expr (&set_status_block, + build1 (INDIRECT_REF, status_type, status), + build_int_cst (status_type, ERROR_ALLOCATION)); + + tmp = fold_build2 (EQ_EXPR, boolean_type_node, status, + build_int_cst (status_type, 0)); + error = fold_build3 (COND_EXPR, void_type_node, tmp, error, + gfc_finish_block (&set_status_block)); + } + + tmp = fold_build3 (COND_EXPR, void_type_node, null_mem, alloc, error); + gfc_add_expr_to_block (block, tmp); + + return res; +} + /* Free a given variable, if it's not NULL. */ tree @@ -497,6 +713,163 @@ gfc_call_free (tree var) } + +/* User-deallocate; we emit the code directly from the front-end, and the + logic is the same as the previous library function: + + void + deallocate (void *pointer, GFC_INTEGER_4 * stat) + { + if (!pointer) + { + if (stat) + *stat = 1; + else + runtime_error ("Attempt to DEALLOCATE unallocated memory."); + } + else + { + free (pointer); + if (stat) + *stat = 0; + } + } + + In this front-end version, status doesn't have to be GFC_INTEGER_4. + Moreover, if CAN_FAIL is true, then we will not emit a runtime error, + even when no status variable is passed to us (this is used for + unconditional deallocation generated by the front-end at end of + each procedure). */ +tree +gfc_deallocate_with_status (tree pointer, tree status, bool can_fail) +{ + stmtblock_t null, non_null; + tree cond, tmp, error, msg; + + cond = fold_build2 (EQ_EXPR, boolean_type_node, pointer, + build_int_cst (TREE_TYPE (pointer), 0)); + + /* When POINTER is NULL, we set STATUS to 1 if it's present, otherwise + we emit a runtime error. */ + gfc_start_block (&null); + if (!can_fail) + { + msg = gfc_build_addr_expr (pchar_type_node, gfc_build_cstring_const + ("Attempt to DEALLOCATE unallocated memory.")); + error = build_call_expr (gfor_fndecl_runtime_error, 1, msg); + } + else + error = build_empty_stmt (); + + if (status != NULL_TREE && !integer_zerop (status)) + { + tree status_type = TREE_TYPE (TREE_TYPE (status)); + tree cond2; + + cond2 = fold_build2 (NE_EXPR, boolean_type_node, status, + build_int_cst (TREE_TYPE (status), 0)); + tmp = fold_build2 (MODIFY_EXPR, status_type, + build1 (INDIRECT_REF, status_type, status), + build_int_cst (status_type, 1)); + error = fold_build3 (COND_EXPR, void_type_node, cond2, tmp, error); + } + + gfc_add_expr_to_block (&null, error); + + /* 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)); + gfc_add_expr_to_block (&non_null, tmp); + + if (status != NULL_TREE && !integer_zerop (status)) + { + /* We set STATUS to zero if it is present. */ + tree status_type = TREE_TYPE (TREE_TYPE (status)); + tree cond2; + + cond2 = fold_build2 (NE_EXPR, boolean_type_node, status, + build_int_cst (TREE_TYPE (status), 0)); + tmp = fold_build2 (MODIFY_EXPR, status_type, + build1 (INDIRECT_REF, status_type, status), + build_int_cst (status_type, 0)); + tmp = fold_build3 (COND_EXPR, void_type_node, cond2, tmp, + build_empty_stmt ()); + gfc_add_expr_to_block (&non_null, tmp); + } + + return fold_build3 (COND_EXPR, void_type_node, cond, + gfc_finish_block (&null), gfc_finish_block (&non_null)); +} + + +/* Reallocate MEM so it has SIZE bytes of data. This behaves like the + following pseudo-code: + +void * +internal_realloc (void *mem, size_t size) +{ + if (size < 0) + runtime_error ("Attempt to allocate a negative amount of memory."); + mem = realloc (mem, size); + if (!mem && size != 0) + _gfortran_os_error ("Out of memory"); + + if (size == 0) + return NULL; + + return mem; +} */ +tree +gfc_call_realloc (stmtblock_t * block, tree mem, tree size) +{ + tree msg, res, negative, zero, null_result, tmp; + tree type = TREE_TYPE (mem); + + size = gfc_evaluate_now (size, block); + + if (TREE_TYPE (size) != TREE_TYPE (size_type_node)) + size = fold_convert (size_type_node, size); + + /* Create a variable to hold the result. */ + res = gfc_create_var (type, NULL); + + /* size < 0 ? */ + negative = fold_build2 (LT_EXPR, boolean_type_node, size, + build_int_cst (size_type_node, 0)); + msg = gfc_build_addr_expr (pchar_type_node, gfc_build_cstring_const + ("Attempt to allocate a negative amount of memory.")); + tmp = fold_build3 (COND_EXPR, void_type_node, negative, + build_call_expr (gfor_fndecl_runtime_error, 1, msg), + build_empty_stmt ()); + 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); + gfc_add_modify_expr (block, res, fold_convert (type, tmp)); + null_result = fold_build2 (EQ_EXPR, boolean_type_node, res, + build_int_cst (pvoid_type_node, 0)); + zero = fold_build2 (EQ_EXPR, boolean_type_node, size, + build_int_cst (size_type_node, 0)); + null_result = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, null_result, + zero); + msg = gfc_build_addr_expr (pchar_type_node, + gfc_build_cstring_const ("Out of memory")); + tmp = fold_build3 (COND_EXPR, void_type_node, null_result, + build_call_expr (gfor_fndecl_os_error, 1, msg), + build_empty_stmt ()); + gfc_add_expr_to_block (block, tmp); + + /* if (size == 0) then the result is NULL. */ + tmp = fold_build2 (MODIFY_EXPR, type, res, build_int_cst (type, 0)); + tmp = fold_build3 (COND_EXPR, void_type_node, zero, tmp, + build_empty_stmt ()); + gfc_add_expr_to_block (block, tmp); + + return res; +} + /* Add a statement to a block. */ void diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index 48bc9fce8cb..1991748eccc 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -450,6 +450,18 @@ tree gfc_call_free (tree); /* Allocate memory after performing a few checks. */ tree gfc_call_malloc (stmtblock_t *, tree, tree); +/* Allocate memory for arrays, with optional status variable. */ +tree gfc_allocate_array_with_status (stmtblock_t *, tree, tree, tree); + +/* Allocate memory, with optional status variable. */ +tree gfc_allocate_with_status (stmtblock_t *, tree, tree); + +/* Generate code to deallocate an array. */ +tree gfc_deallocate_with_status (tree, tree, bool); + +/* Generate code to call realloc(). */ +tree gfc_call_realloc (stmtblock_t *, tree, tree); + /* Generate code for an assignment, includes scalarization. */ tree gfc_trans_assignment (gfc_expr *, gfc_expr *, bool); @@ -483,10 +495,6 @@ struct gimplify_omp_ctx; void gfc_omp_firstprivatize_type_sizes (struct gimplify_omp_ctx *, tree); /* Runtime library function decls. */ -extern GTY(()) tree gfor_fndecl_internal_realloc; -extern GTY(()) tree gfor_fndecl_allocate; -extern GTY(()) tree gfor_fndecl_allocate_array; -extern GTY(()) tree gfor_fndecl_deallocate; extern GTY(()) tree gfor_fndecl_pause_numeric; extern GTY(()) tree gfor_fndecl_pause_string; extern GTY(()) tree gfor_fndecl_stop_numeric; diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index eb9c329684a..1878af1d1fb 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2007-08-29 Francois-Xavier Coudert + + * gfortran.dg/alloc_comp_basics_1.f90: Update check. + * gfortran.dg/alloc_comp_constructor_1.f90: Update check. + 2007-08-29 Douglas Gregor PR c++/33194 diff --git a/gcc/testsuite/gfortran.dg/alloc_comp_basics_1.f90 b/gcc/testsuite/gfortran.dg/alloc_comp_basics_1.f90 index a4617cbf01e..fc58bf44830 100644 --- a/gcc/testsuite/gfortran.dg/alloc_comp_basics_1.f90 +++ b/gcc/testsuite/gfortran.dg/alloc_comp_basics_1.f90 @@ -139,6 +139,6 @@ contains end subroutine check_alloc2 end program alloc -! { dg-final { scan-tree-dump-times "deallocate" 24 "original" } } +! { dg-final { scan-tree-dump-times "builtin_free" 24 "original" } } ! { dg-final { cleanup-tree-dump "original" } } ! { dg-final { cleanup-modules "alloc_m" } } diff --git a/gcc/testsuite/gfortran.dg/alloc_comp_constructor_1.f90 b/gcc/testsuite/gfortran.dg/alloc_comp_constructor_1.f90 index 9beca6d0b7f..969e703094c 100644 --- a/gcc/testsuite/gfortran.dg/alloc_comp_constructor_1.f90 +++ b/gcc/testsuite/gfortran.dg/alloc_comp_constructor_1.f90 @@ -104,5 +104,5 @@ contains end function blaha end program test_constructor -! { dg-final { scan-tree-dump-times "deallocate" 18 "original" } } +! { dg-final { scan-tree-dump-times "builtin_free" 19 "original" } } ! { dg-final { cleanup-tree-dump "original" } } diff --git a/libgfortran/ChangeLog b/libgfortran/ChangeLog index 42d4da2c37b..aa1df6aa7a6 100644 --- a/libgfortran/ChangeLog +++ b/libgfortran/ChangeLog @@ -1,3 +1,11 @@ +2007-08-29 Francois-Xavier Coudert + + * runtime/memory.c (internal_realloc, allocate, allocate_array, + deallocate): Remove functions. + * gfortran.map (_gfortran_allocate, _gfortran_allocate_array, + _gfortran_deallocate, _gfortran_internal_realloc): Remove symbols. + * libgfortran.h (error_codes): Add comment. + 2007-08-28 Jerry DeLisle PR libfortran/33055 diff --git a/libgfortran/gfortran.map b/libgfortran/gfortran.map index 31ca41e9f88..429c84c8c4a 100644 --- a/libgfortran/gfortran.map +++ b/libgfortran/gfortran.map @@ -11,8 +11,6 @@ GFORTRAN_1.0 { _gfortran_all_l16; _gfortran_all_l4; _gfortran_all_l8; - _gfortran_allocate; - _gfortran_allocate_array; _gfortran_any_l16; _gfortran_any_l4; _gfortran_any_l8; @@ -60,7 +58,6 @@ GFORTRAN_1.0 { _gfortran_ctime; _gfortran_ctime_sub; _gfortran_date_and_time; - _gfortran_deallocate; _gfortran_eoshift0_1; _gfortran_eoshift0_1_char; _gfortran_eoshift0_2; @@ -167,7 +164,6 @@ GFORTRAN_1.0 { _gfortran_ierrno_i4; _gfortran_ierrno_i8; _gfortran_internal_pack; - _gfortran_internal_realloc; _gfortran_internal_unpack; _gfortran_irand; _gfortran_isatty_l4; diff --git a/libgfortran/libgfortran.h b/libgfortran/libgfortran.h index 555c6bfd4a8..d068a753fa4 100644 --- a/libgfortran/libgfortran.h +++ b/libgfortran/libgfortran.h @@ -447,7 +447,9 @@ typedef enum ERROR_READ_OVERFLOW, ERROR_INTERNAL, ERROR_INTERNAL_UNIT, - ERROR_ALLOCATION, + ERROR_ALLOCATION, /* Keep in sync with value used in + gcc/fortran/trans.c + (gfc_allocate_array_with_status). */ ERROR_DIRECT_EOR, ERROR_SHORT_RECORD, ERROR_CORRUPT_FILE, diff --git a/libgfortran/runtime/memory.c b/libgfortran/runtime/memory.c index f1991cda324..7407486b696 100644 --- a/libgfortran/runtime/memory.c +++ b/libgfortran/runtime/memory.c @@ -38,10 +38,6 @@ Boston, MA 02110-1301, USA. */ performance is desired, but it can help when you're debugging code. */ /* #define GFC_CLEAR_MEMORY */ -/* If GFC_CHECK_MEMORY is defined, we do some sanity checks at runtime. - This causes small overhead, but again, it also helps debugging. */ -#define GFC_CHECK_MEMORY - void * get_mem (size_t n) { @@ -76,123 +72,3 @@ internal_malloc_size (size_t size) return get_mem (size); } - - -/* Reallocate internal memory MEM so it has SIZE bytes of data. - Allocate a new block if MEM is zero, and free the block if - SIZE is 0. */ - -extern void *internal_realloc (void *, index_type); -export_proto(internal_realloc); - -void * -internal_realloc (void *mem, index_type size) -{ -#ifdef GFC_CHECK_MEMORY - /* Under normal circumstances, this is _never_ going to happen! */ - if (size < 0) - runtime_error ("Attempt to allocate a negative amount of memory."); -#endif - mem = realloc (mem, size); - if (!mem && size != 0) - os_error ("Out of memory."); - - if (size == 0) - return NULL; - - return mem; -} - - -/* User-allocate, one call for each member of the alloc-list of an - ALLOCATE statement. */ - -extern void *allocate (index_type, GFC_INTEGER_4 *) __attribute__ ((malloc)); -export_proto(allocate); - -void * -allocate (index_type size, GFC_INTEGER_4 * stat) -{ - void *newmem; - -#ifdef GFC_CHECK_MEMORY - /* The only time this can happen is the size computed by the - frontend wraps around. */ - if (size < 0) - { - if (stat) - { - *stat = ERROR_ALLOCATION; - return NULL; - } - else - runtime_error ("Attempt to allocate negative amount of memory. " - "Possible integer overflow"); - } -#endif - newmem = malloc (size ? size : 1); - if (!newmem) - { - if (stat) - { - *stat = ERROR_ALLOCATION; - return newmem; - } - else - runtime_error ("ALLOCATE: Out of memory."); - } - - if (stat) - *stat = 0; - - return newmem; -} - -/* Function to call in an ALLOCATE statement when the argument is an - allocatable array. If the array is currently allocated, it is - an error to allocate it again. */ - -extern void *allocate_array (void *, index_type, GFC_INTEGER_4 *); -export_proto(allocate_array); - -void * -allocate_array (void *mem, index_type size, GFC_INTEGER_4 * stat) -{ - if (mem == NULL) - return allocate (size, stat); - if (stat) - { - free (mem); - mem = allocate (size, stat); - *stat = ERROR_ALLOCATION; - return mem; - } - - runtime_error ("Attempting to allocate already allocated array."); -} - - -/* User-deallocate; pointer is then NULLified by the front-end. */ - -extern void deallocate (void *, GFC_INTEGER_4 *); -export_proto(deallocate); - -void -deallocate (void *mem, GFC_INTEGER_4 * stat) -{ - if (!mem) - { - if (stat) - { - *stat = 1; - return; - } - else - runtime_error ("Internal: Attempt to DEALLOCATE unallocated memory."); - } - - free (mem); - - if (stat) - *stat = 0; -}