https://gcc.gnu.org/g:dc2759b1a924a3365558b9e71da3d9e0c678bd74
commit r16-5759-gdc2759b1a924a3365558b9e71da3d9e0c678bd74 Author: Jose E. Marchesi <[email protected]> Date: Sat Oct 11 19:53:49 2025 +0200 a68: low: ranges Signed-off-by: Jose E. Marchesi <[email protected]> gcc/ChangeLog * algol68/a68-low-ranges.cc: New file. Diff: --- gcc/algol68/a68-low-ranges.cc | 699 ++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 699 insertions(+) diff --git a/gcc/algol68/a68-low-ranges.cc b/gcc/algol68/a68-low-ranges.cc new file mode 100644 index 000000000000..9a2008aa571b --- /dev/null +++ b/gcc/algol68/a68-low-ranges.cc @@ -0,0 +1,699 @@ +/* Management of ranges in the Algol 68 front-end. + Copyright (C) 2025 Jose E. Marchesi. + + Written by Jose E. Marchesi. + + GCC 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 3, or (at your option) + any later version. + + GCC 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 GCC; see the file COPYING3. If not see + <http://www.gnu.org/licenses/>. */ + +#include "config.h" +#include "system.h" +#include "coretypes.h" + +#include "tree.h" +#include "fold-const.h" +#include "langhooks.h" +#include "tm.h" +#include "function.h" +#include "cgraph.h" +#include "toplev.h" +#include "varasm.h" +#include "predict.h" +#include "stor-layout.h" +#include "tree-iterator.h" +#include "stringpool.h" +#include "print-tree.h" +#include "gimplify.h" +#include "dumpfile.h" +#include "convert.h" +#include "tree-nested.h" + +#include "a68.h" + +/* Many Algol 68 constructions introduce a new range of definitions. This is + the case of clauses and of routine definitions. The stack of ranges at any + point in the program determines the "nest" of the constructions declared in + the program. This nest carries a record of all the declarations forming the + environment in which that construct is to be interpreted. + + This file contains a manager of ranges of which we allocate one for each + range inducing construct. The top-level range corresponds to the primal + environment. + + The ranges are used by the lowering code in order to create GCC tree BLOCK + nodes, and also to keep track of the set of declarations and of statements + being added by the current serial clause. */ + +struct GTY (()) range +{ + /* Whether this range entry doesn't introduce a lexical frame. Declarations + and decl_exprs get added to the nearst enclosing range that is not + frameless. */ + bool frameless; + + /* A chain of _DECL nodes for all variables, constants, functions, + and typedef types. These are in the reverse of the order supplied. */ + tree names; + + /* A statements list of DECL_EXPR nodes for all the declarations in the + range. These are prepended to the statements list when the range is + closed. */ + tree decl_exprs; + + /* The context of the range, either a function declaration or a translation + unit. */ + tree context; + + /* The range below this one. */ + struct range *next; + + /* Statement list. */ + tree stmt_list; + + /* List of blocks to which the block created for this range is the + superblock. */ + tree blocks; + + /* Mode associated with the range. For serial clauses, this is the mode of + the value yielded by the clause. */ + MOID_T *mode; + + /* If not TREE_NULL, then the range corresponds to a function, which can be + either nested or defined at top-level. */ + tree fndecl; + bool top_level_function; + + /* The following fields are used by ranges introduced by serial + clauses. */ + bool save_restore_stack; + bool has_completers; + tree clause_result_decl; + tree clause_exit_label_decl; + tree clause_stack_save_decl; +}; + +/* Global and current ranges. */ + +static GTY (()) struct range *global_range; +static GTY (()) struct range *current_range; + +/* Create a new range and push it in the list. */ + +static struct range * +new_range (void) +{ + struct range *range = ggc_alloc<struct range> (); + + range->frameless = false; + range->names = NULL; + range->decl_exprs = alloc_stmt_list (); + range->context = NULL; + range->next = NULL; + range->blocks = NULL_TREE; + range->stmt_list = alloc_stmt_list (); + range->fndecl = NULL_TREE; + range->top_level_function = false; + range->save_restore_stack = false; + range->has_completers = false; + range->clause_result_decl = NULL_TREE; + range->clause_exit_label_decl = NULL_TREE; + range->clause_stack_save_decl = NULL_TREE; + range->mode = NO_MOID; + return range; +} + +/* Push a new frameless range. */ + +void +a68_push_stmt_list (MOID_T *mode) +{ + a68_push_range (mode); + current_range->frameless = true; +} + +/* Pop a frameless range. */ + +tree +a68_pop_stmt_list (void) +{ + /* This will result into a stmt list. */ + tree res = a68_pop_range (); + gcc_assert (TREE_CODE (res) == STATEMENT_LIST); + return res; +} + +/* Push a new range. */ + +void +a68_push_range (MOID_T *mode) +{ + struct range *range = new_range (); + if (current_range) + range->context = current_range->context; + range->next = current_range; + range->mode = mode; + current_range = range; +} + +/* Pop a range, with a finalizer. + + Return a BIND_EXPR, a statement list or a TRY_FINALLY_EXPR. */ + +tree +a68_pop_range_with_finalizer (tree finalizer) +{ + tree range = a68_pop_range (); + return fold_build2 (TRY_FINALLY_EXPR, TREE_TYPE (range), + range, finalizer); +} + +/* Pop a range. Return either a BIND_EXPR or a statements list. */ + +tree +a68_pop_range (void) +{ + struct range *range = current_range; + current_range = range->next; + tree type = (range->mode == NULL ? void_type_node : CTYPE (range->mode)); + + /* If TYPE is a pointer type and the last expression in the statement list is + a variable of the type pointed by TYPE then take its address. */ + tree_stmt_iterator i = tsi_last (range->stmt_list); + if (POINTER_TYPE_P (type) && TREE_TYPE (type) == TREE_TYPE (tsi_stmt (i))) + { + append_to_statement_list_force (a68_consolidate_ref (range->mode, tsi_stmt (i)), + &range->stmt_list); + tsi_delink (&i); + } + + tree clause = NULL_TREE; + if (range->frameless) + clause = range->stmt_list; + else + { + /* Create a block and set its declarations and supercontext. */ + tree block = make_node (BLOCK); + BLOCK_VARS (block) = range->names; + BLOCK_SUBBLOCKS (block) = range->blocks; + + /* In each subblock, record that this is its superior. */ + for (tree t = range->blocks; t; t = BLOCK_CHAIN (t)) + BLOCK_SUPERCONTEXT (t) = block; + + if (range->fndecl) + { + BLOCK_SUPERCONTEXT (block) = range->fndecl; + DECL_INITIAL (range->fndecl) = block; + } + else + { + current_range->blocks + = block_chainon (current_range->blocks, block); + } + + TREE_USED (block) = true; + + /* Create a BIND if the range contains declarations. Otherwise just + use the statements list. */ + clause = range->stmt_list; + if (range->names != NULL_TREE) + { + clause = build3 (BIND_EXPR, + type, + range->names, + range->stmt_list, + block); + TREE_SIDE_EFFECTS (clause) = 1; + BIND_EXPR_VARS (clause) = BLOCK_VARS (block); + } + + /* Prepend the decl_exprs to the range's statements list. */ + tree_stmt_iterator q = tsi_start (range->stmt_list); + tsi_link_before (&q, range->decl_exprs, TSI_SAME_STMT); + } + + /* Set the type of the stmt_list. */ + TREE_TYPE (range->stmt_list) = type; + TREE_SIDE_EFFECTS (range->stmt_list) = 1; + + return clause; +} + +/* Add a new expression to the current range. */ + +void +a68_add_stmt (tree exp) +{ + if (exp == void_node) + /* This may result from a mode declaration. */ + return; + gcc_assert (current_range != NULL); + append_to_statement_list_force (exp, + ¤t_range->stmt_list); +} + +/* Add a new declaration to the current range. */ + +void +a68_add_decl (tree decl) +{ + gcc_assert (current_range != NULL); + struct range *range = current_range; + + /* Search for the right frame where to add the declaration. */ + while (range->frameless) + { + gcc_assert (range->next != NULL); + range = range->next; + } + + tree n = range->names; + while (n != decl && n != NULL) + n = TREE_CHAIN (n); + if (n != decl) + { + if (decl != current_function_decl) + DECL_CONTEXT (decl) = range->context; + /* Note this list needs to be in reverse order for compatibility with + GCC. */ + TREE_CHAIN (decl) = range->names; + range->names = decl; + } +} + +/* Add a new declaration expr to the current range. */ + +void +a68_add_decl_expr (tree decl_expr) +{ + gcc_assert (current_range != NULL); + struct range *range = current_range; + + /* Search for the right frame where to add the declaration expr. */ + while (range->frameless) + { + gcc_assert (range->next != NULL); + range = range->next; + } + + append_to_statement_list_force (decl_expr, &range->decl_exprs); +} + +/* Add a completer in the current range. */ + +void +a68_add_completer (void) +{ + struct range *range = current_range; + + /* The last statement in the statements list is either a single unit or a + labeled unit, i.e a COMPOUND_EXPR whose first expression is a label and + second expression is the unit. Consolidate the unit within the labeled + unit to a ref. */ + tree_stmt_iterator i = tsi_last (range->stmt_list); + tree last_expr = tsi_stmt (i); + + if (TREE_CODE (last_expr) == COMPOUND_EXPR + && TREE_CODE (TREE_OPERAND (last_expr, 0)) == LABEL_EXPR) + { + TREE_OPERAND (last_expr, 1) = a68_consolidate_ref (range->mode, + TREE_OPERAND (last_expr, 1)); + TREE_TYPE (last_expr) = TREE_TYPE (TREE_OPERAND (last_expr, 1)); + } + else + last_expr = a68_consolidate_ref (range->mode, last_expr); + + /* Now assign the labeled unit to the clause result decl then jump to the end + of the serial clause. */ + append_to_statement_list_force (fold_build2 (MODIFY_EXPR, + void_type_node, + range->clause_result_decl, + last_expr), + &range->stmt_list); + tsi_delink (&i); + append_to_statement_list_force (fold_build1 (GOTO_EXPR, void_type_node, + range->clause_exit_label_decl), + &range->stmt_list); + range->has_completers = true; +} + +/* Get the context of the current range. */ + +tree +a68_range_context (void) +{ + gcc_assert (current_range != NULL); + return current_range->context; +} + +/* Get the list of declarations in the current range. */ + +tree +a68_range_names (void) +{ + struct range *range = current_range; + + while (range->frameless && range->next != NULL) + range = range->next; + + if (range != NULL) + return range->names; + else + return NULL_TREE; +} + +/* Get the statements list of the current range. */ + +tree +a68_range_stmt_list (void) +{ + gcc_assert (current_range != NULL); + return current_range->stmt_list; +} + +/* Push a range for a function. */ + +void +a68_push_function_range (tree fndecl, tree result_type, + bool top_level) +{ + a68_push_range (NULL /* VOID */); + current_range->fndecl = fndecl; + current_range->top_level_function = top_level; + current_range->context = fndecl; + + /* Setup the result declaration. */ + tree resdecl = build_decl (UNKNOWN_LOCATION, + RESULT_DECL, + get_identifier ("resdecl%"), + result_type); + DECL_ARTIFICIAL (resdecl) = 1; + DECL_IGNORED_P (resdecl) = 1; + DECL_CONTEXT (resdecl) = fndecl; + DECL_RESULT (fndecl) = resdecl; + rest_of_decl_compilation (fndecl, 1, 0); + make_decl_rtl (fndecl); + allocate_struct_function (fndecl, false); + + /* Let GCC know the current scope is this function. */ + current_function_decl = fndecl; +} + +/* Pop a range for a function. */ + +void +a68_pop_function_range (tree body) +{ + tree fndecl = current_range->fndecl; + bool top_level = current_range->top_level_function; + + if (TREE_TYPE (DECL_RESULT (fndecl)) == void_type_node) + { + a68_add_stmt (body); + } + else + { + /* Append the return statement. + Note that this does the copy of the returned value. */ + tree return_stmt = fold_build1 (RETURN_EXPR, + void_type_node, + fold_build2 (MODIFY_EXPR, + TREE_TYPE (DECL_RESULT (fndecl)), + DECL_RESULT (fndecl), + a68_low_dup (body, true /* use_heap */))); + a68_add_stmt (return_stmt); + } + + /* Set the body of the function. */ + DECL_SAVED_TREE (fndecl) = a68_pop_range (); + + /* Output the GENERIC tree for the function.. */ + dump_function (TDI_original, fndecl); + /* This compiles the function all the way to assembler language output. + Nested functions are finalized when the containing top-level function is + finalized. */ + if (top_level || a68_in_global_range ()) + cgraph_node::finalize_function (fndecl, true); + else + /* Register this function with cgraph just far enough to get it added to + our parent's nested function list. */ + (void) cgraph_node::get_create (fndecl); + + /* Let GCC know the current scope has changed. */ + current_function_decl = NULL_TREE; + for (struct range *r = current_range; r; r = r->next) + { + if (r->fndecl != NULL_TREE) + current_function_decl = r->fndecl; + } +} + +/* Push a range for a serial clause. + + label1: BIND_EXPR_BODY (STATEMENT_LIST ( + expr1; label1, + expr2 expr1, + exit label2: clause_result = expr2, + expr3; goto exit_label, + expr4 label2, + exit label3: expr3, + expr5 clause_result = expr4, + goto exit_label, + label3, + clause_result = expr5, + exit_label, + clause_result)) */ + +void +a68_push_serial_clause_range (MOID_T *clause_mode, + bool save_restore_stack) +{ + /* Get the type of the enclosing clause. */ + tree clause_type = CTYPE (clause_mode); + + /* If the serial clause has declarations that involve dynamic allocation, and + the environ it establishes is local, then save the stack pointer. */ + if (save_restore_stack) + { + a68_push_range (clause_mode); + current_range->save_restore_stack = true; + + tree outer_clause_result_decl = build_decl (UNKNOWN_LOCATION, + VAR_DECL, + NULL, /* Set below. */ + clause_type); + char *outer_clause_result_name = xasprintf ("outer_clause_result%d%%", + DECL_UID (outer_clause_result_decl)); + DECL_NAME (outer_clause_result_decl) = get_identifier (outer_clause_result_name); + free (outer_clause_result_name); + current_range->clause_result_decl = outer_clause_result_decl; + a68_add_decl (outer_clause_result_decl); + + /* Variable used to save the stack pointer. */ + tree stack_save_decl = build_decl (UNKNOWN_LOCATION, + VAR_DECL, + get_identifier ("stack_save%"), + build_pointer_type (char_type_node)); + current_range->clause_stack_save_decl = stack_save_decl; + a68_add_decl (stack_save_decl); + a68_add_stmt (fold_build1 (DECL_EXPR, + TREE_TYPE (stack_save_decl), + stack_save_decl)); + + /* Save stack pointer. */ + tree call = builtin_decl_implicit (BUILT_IN_STACK_SAVE); + call = build_call_expr_loc (UNKNOWN_LOCATION, call, 0); + a68_add_stmt (fold_build2 (MODIFY_EXPR, void_type_node, + stack_save_decl, call)); + } + + /* Push a new range. */ + a68_push_range (clause_mode); + current_range->save_restore_stack = save_restore_stack; + + /* Create a decl for clause_result with the right type and add it to the + block's declaration list. */ + tree clause_result_decl = build_decl (UNKNOWN_LOCATION, + VAR_DECL, + NULL, /* Set below. */ + clause_type); + char *clause_result_name = xasprintf ("clause_result%d%%", DECL_UID (clause_result_decl)); + DECL_NAME (clause_result_decl) = get_identifier (clause_result_name); + // free (clause_result_name); + DECL_INITIAL (clause_result_decl) = a68_get_skip_tree (clause_mode); + DECL_CONTEXT (clause_result_decl) = current_range->context; + current_range->clause_result_decl = clause_result_decl; + + /* Create a decl for the clause's exit label. */ + tree clause_exit_label_decl = build_decl (UNKNOWN_LOCATION, + LABEL_DECL, + NULL, /* Set below. */ + void_type_node); + char *exit_label_name = xasprintf ("clause_exit_label%d%%", DECL_UID (clause_exit_label_decl)); + DECL_NAME (clause_exit_label_decl) = get_identifier (exit_label_name); + free (exit_label_name); + DECL_CONTEXT (clause_exit_label_decl) = current_range->context; + current_range->clause_exit_label_decl = clause_exit_label_decl; +} + +/* Pop a range for a serial clause and return the resulting bind + expression. */ + +tree +a68_pop_serial_clause_range (void) +{ + struct range *range = current_range; + MOID_T *clause_mode = range->mode; + tree clause_type = CTYPE (clause_mode); + + /* The last expression in the statements list is either a single unit or a + labeled unit. Consolidate it to a ref if required by the mode of the + serial clause. */ + { + tree_stmt_iterator si = tsi_last (range->stmt_list); + tree last_expr = tsi_stmt (si); + if (TREE_CODE (last_expr) == COMPOUND_EXPR + && TREE_CODE (TREE_OPERAND (last_expr, 0)) == LABEL_EXPR) + { + TREE_OPERAND (last_expr, 1) = a68_consolidate_ref (range->mode, + TREE_OPERAND (last_expr, 1)); + TREE_TYPE (last_expr) = TREE_TYPE (TREE_OPERAND (last_expr, 1)); + } + else + last_expr = a68_consolidate_ref (range->mode, last_expr); + a68_add_stmt (last_expr); + tsi_delink (&si); + } + + /* If the serial clause has completers, we have to make use of the + clause_result% and clause_exit_label% mechanism to assure the statements + list has a single exit at the end. */ + if (range->has_completers) + { + /* First prepend EXPR_DECL expressions for clause_result% and + clause_exit_label% */ + { + tree_stmt_iterator si = tsi_start (range->stmt_list); + tsi_link_before (&si, + fold_build1 (DECL_EXPR, + TREE_TYPE (range->clause_result_decl), + range->clause_result_decl), + TSI_CONTINUE_LINKING); + tsi_link_before (&si, + fold_build1 (DECL_EXPR, + TREE_TYPE (range->clause_exit_label_decl), + range->clause_exit_label_decl), + TSI_CONTINUE_LINKING); + } + + /* Then turn the last expression in stmt_list to an assignment to + clause_result_decl%, but don't bother if it has been voided. */ + if (clause_type != a68_void_type) + { + tree_stmt_iterator si = tsi_last (range->stmt_list); + tree last_expr = tsi_stmt (si); + + a68_add_stmt (build2 (MODIFY_EXPR, + clause_type, + range->clause_result_decl, + last_expr)); + tsi_delink (&si); + } + + a68_add_decl (range->clause_result_decl); + a68_add_decl (range->clause_exit_label_decl); + + /* Finally append the exit label and last expression with + result_decl. */ + a68_add_stmt (build1 (LABEL_EXPR, void_type_node, range->clause_exit_label_decl)); + a68_add_stmt (build1 (NON_LVALUE_EXPR, clause_type, range->clause_result_decl)); + } + + /* Check that the type of the last statement in the statements list is the + same than the type corresponding to the clause mode. */ + { + tree_stmt_iterator si = tsi_last (range->stmt_list); + if (TREE_TYPE (tsi_stmt (si)) != clause_type + /* But NIL can appear in a context expecting VOID with no widening. */ + && !(clause_type == a68_void_type + && POINTER_TYPE_P (TREE_TYPE (tsi_stmt (si))) + && TREE_CODE (tsi_stmt (si)) == INTEGER_CST + && tree_to_shwi (tsi_stmt (si)) == 0) + /* And any row type is valid when M_ROWS is expected. */ + && !(A68_ROWS_TYPE_P (clause_type) + && A68_ROWS_TYPE_P (TREE_TYPE (tsi_stmt (si)))) + /* Do not rely on comparing pointer types, as the equality fails in + that case. We need a better way of comparing types, either using + TYPE_CANONICAL or caching. */ + && !(POINTER_TYPE_P (TREE_TYPE (tsi_stmt (si))) && POINTER_TYPE_P (clause_type))) + { + printf ("last statement:\n"); + debug_tree (tsi_stmt (si)); + printf ("expected type:\n"); + debug_tree (clause_type); + gcc_unreachable (); + } + } + + /* If the serial clause has declarations that involve dynamic allocation, and + the environ it establishes is local, then restore the stack pointer. */ + if (range->save_restore_stack) + { + /* Turn last expression of inner clause into a modify statement. This + may involve a copy. This can be omitted if the serial clause yields + void. */ + if (clause_type != a68_void_type) + { + tree_stmt_iterator si = tsi_last (range->stmt_list); + tree last_expr = tsi_stmt (si); + + a68_add_stmt (build2 (MODIFY_EXPR, + clause_type, + range->next->clause_result_decl, + a68_low_dup (last_expr))); + tsi_delink (&si); + } + + /* Finish inner clause, restoring stack pointer on finalizing. */ + tree restore_sp = builtin_decl_implicit (BUILT_IN_STACK_RESTORE); + restore_sp = build_call_expr_loc (UNKNOWN_LOCATION, restore_sp, 1, + current_range->next->clause_stack_save_decl); + a68_add_stmt (a68_pop_range_with_finalizer (restore_sp)); + /* The result value is now in clause_result_decl. */ + a68_add_stmt (build1 (NON_LVALUE_EXPR, clause_type, + current_range->clause_result_decl)); + } + + return a68_pop_range (); +} + +/* Whether the current range is the global range. */ + +bool +a68_in_global_range (void) +{ + return current_range == global_range; +} + +/* Initialize ranges. */ + +void +a68_init_ranges (void) +{ + global_range = new_range (); + global_range->context = build_translation_unit_decl (NULL); + current_range = global_range; +} + +#include "gt-algol68-a68-low-ranges.h"
