[COMMITTED] algol68: adjust stack in serial clauses with dynamic stack allocations
Jose E. Marchesi
jemarch@gnu.org
Sun May 4 02:33:06 GMT 2025
---
gcc/algol68/Make-lang.in | 1 +
gcc/algol68/a68-low-clauses.cc | 35 ++++--
gcc/algol68/a68-low-ranges.cc | 67 +++++++++-
gcc/algol68/a68-low.cc | 6 +-
gcc/algol68/a68-parser-serial-dsa.cc | 115 ++++++++++++++++++
gcc/algol68/a68-parser.cc | 11 ++
gcc/algol68/a68-types.h | 16 ++-
gcc/algol68/a68.h | 7 +-
gcc/testsuite/algol68/execute/mcts/clau04.a68 | 2 +-
.../algol68/execute/serial-dsa-1.a68 | 18 +++
.../algol68/execute/serial-dsa-2.a68 | 5 +
11 files changed, 270 insertions(+), 13 deletions(-)
create mode 100644 gcc/algol68/a68-parser-serial-dsa.cc
create mode 100644 gcc/testsuite/algol68/execute/serial-dsa-1.a68
create mode 100644 gcc/testsuite/algol68/execute/serial-dsa-2.a68
diff --git a/gcc/algol68/Make-lang.in b/gcc/algol68/Make-lang.in
index 63e538629d3..b9277fcb299 100644
--- a/gcc/algol68/Make-lang.in
+++ b/gcc/algol68/Make-lang.in
@@ -76,6 +76,7 @@ ALGOL68_OBJS = algol68/a68-lang.o \
algol68/a68-parser-moids-equivalence.o \
algol68/a68-parser-scanner.o \
algol68/a68-parser-scope.o \
+ algol68/a68-parser-serial-dsa.o \
algol68/a68-parser-taxes.o \
algol68/a68-parser-top-down.o \
algol68/a68-parser-victal.o \
diff --git a/gcc/algol68/a68-low-clauses.cc b/gcc/algol68/a68-low-clauses.cc
index 16a572c800d..821adda4d09 100644
--- a/gcc/algol68/a68-low-clauses.cc
+++ b/gcc/algol68/a68-low-clauses.cc
@@ -406,7 +406,8 @@ a68_lower_loop_clause (NODE_T *p ATTRIBUTE_UNUSED,
}
/* Serial clauses in DO .. OD do not yield any value. */
- a68_push_serial_clause_range (M_VOID);
+ a68_push_serial_clause_range (M_VOID,
+ DYNAMIC_STACK_ALLOCS (NEXT (SUB (s))));
(void) a68_lower_tree (NEXT (SUB (s)), ctx);
do_part = a68_pop_serial_clause_range ();
a68_add_stmt (do_part);
@@ -595,7 +596,8 @@ a68_lower_conformity_clause (NODE_T *p, LOW_CTX_T ctx)
{
case CHOICE:
case OUT_PART:
- a68_push_serial_clause_range (conformity_clause_mode);
+ a68_push_serial_clause_range (conformity_clause_mode,
+ DYNAMIC_STACK_ALLOCS (NEXT (SUB (s))));
(void) a68_lower_tree (NEXT (SUB (s)), ctx);
a68_add_stmt (fold_build2 (MODIFY_EXPR, TREE_TYPE (result),
result, a68_pop_serial_clause_range ()));
@@ -729,7 +731,8 @@ a68_lower_case_clause (NODE_T *p ATTRIBUTE_UNUSED,
{
case CHOICE:
case OUT_PART:
- a68_push_serial_clause_range (case_clause_mode);
+ a68_push_serial_clause_range (case_clause_mode,
+ DYNAMIC_STACK_ALLOCS (NEXT (SUB (s))));
(void) a68_lower_tree (NEXT (SUB (s)), ctx);
a68_add_stmt (fold_build2 (MODIFY_EXPR, TREE_TYPE (result),
result, a68_pop_serial_clause_range ()));
@@ -898,7 +901,8 @@ a68_lower_conditional_clause (NODE_T *p, LOW_CTX_T ctx)
/* THEN part. */
FORWARD (s);
- a68_push_serial_clause_range (is_rows ? effective_rows_mode : conditional_clause_mode);
+ a68_push_serial_clause_range (is_rows ? effective_rows_mode : conditional_clause_mode,
+ DYNAMIC_STACK_ALLOCS (NEXT (SUB (s))));
(void) a68_lower_tree (NEXT (SUB (s)), ctx);
then_expr = a68_pop_serial_clause_range ();
@@ -909,7 +913,8 @@ a68_lower_conditional_clause (NODE_T *p, LOW_CTX_T ctx)
case CHOICE:
case ELSE_PART:
{
- a68_push_serial_clause_range (is_rows ? effective_rows_mode : conditional_clause_mode);
+ a68_push_serial_clause_range (is_rows ? effective_rows_mode : conditional_clause_mode,
+ DYNAMIC_STACK_ALLOCS (NEXT (SUB (s))));
(void) a68_lower_tree (NEXT (SUB (s)), ctx);
else_expr = a68_pop_serial_clause_range ();
break;
@@ -1286,8 +1291,24 @@ a68_lower_closed_clause (NODE_T *p, LOW_CTX_T ctx)
gcc_assert (clause_mode != NO_MOID);
gcc_assert (CTYPE (clause_mode) != NULL_TREE);
- /* Lower the enclosed serial clause. */
- a68_push_serial_clause_range (clause_mode);
+ /* Lower the enclosed serial clause.
+
+ Note that a serial clause can be nested right inside another, and in that
+ case the range we are pushing corresponds to all of them, so we have to
+ keep this into account when determining whether using a DSA serial
+ range. */
+ // XXX the same has to be done in all other occurences of
+ // a68_push_serial_clause_range
+ bool dsa = false;
+ NODE_T *s = NEXT (SUB (p));
+ for (s = NEXT (SUB (p)); SUB (s) && IS (s, SERIAL_CLAUSE); s = SUB (s))
+ {
+ dsa = DYNAMIC_STACK_ALLOCS (s);
+ if (dsa)
+ break;
+ }
+
+ a68_push_serial_clause_range (clause_mode, dsa);
(void) a68_lower_tree (NEXT (SUB (p)), ctx);
return a68_pop_serial_clause_range ();
}
diff --git a/gcc/algol68/a68-low-ranges.cc b/gcc/algol68/a68-low-ranges.cc
index c15a2f461c0..6a5644fda1a 100644
--- a/gcc/algol68/a68-low-ranges.cc
+++ b/gcc/algol68/a68-low-ranges.cc
@@ -96,9 +96,11 @@ struct GTY (()) range
/* The following fields are used by ranges introduced by serial
clauses. */
+ bool dsa;
bool has_completers;
tree clause_result_decl;
tree clause_exit_label_decl;
+ tree clause_stack_save_decl;
};
/* Global and current ranges. */
@@ -122,9 +124,11 @@ new_range (void)
range->stmt_list = alloc_stmt_list ();
range->fndecl = NULL_TREE;
range->top_level_function = false;
+ range->dsa = 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;
}
@@ -460,13 +464,53 @@ a68_pop_function_range (tree body)
clause_result)) */
void
-a68_push_serial_clause_range (MOID_T *clause_mode)
+a68_push_serial_clause_range (MOID_T *clause_mode,
+ bool dsa)
{
/* Get the type of the enclosing clause. */
tree clause_type = CTYPE (clause_mode);
+ /* If the serial clause has declarations of values that are allocated
+ dynamically, and if the last expression in the serial clause is of a mode
+ that requires dynamic allocation then it may be in the stack area
+ dynamically allocated within the serial clause. */
+ if (dsa)
+ {
+ a68_push_range (clause_mode);
+ current_range->dsa = 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->dsa = dsa;
/* Create a decl for clause_result with the right type and add it to the
block's declaration list. */
@@ -592,6 +636,27 @@ a68_pop_serial_clause_range (void)
}
}
+ /* If the serial clause has declarations that involve dynamic allocation then
+ save and restore the stack pointer. */
+ if (range->dsa)
+ {
+ /* Finish the inner clause. This may involve a copy. */
+ tree inner_clause = a68_low_dup (a68_pop_range ());
+ a68_add_stmt (build2 (MODIFY_EXPR,
+ clause_type,
+ current_range->clause_result_decl,
+ inner_clause));
+
+ /* Restore stack pointer. */
+ tree call = builtin_decl_implicit (BUILT_IN_STACK_RESTORE);
+ call = build_call_expr_loc (UNKNOWN_LOCATION, call, 1,
+ current_range->clause_stack_save_decl);
+ a68_add_stmt (call);
+
+ /* Return the outer result. */
+ a68_add_stmt (build1 (NON_LVALUE_EXPR, clause_type, current_range->clause_result_decl));
+ }
+
return a68_pop_range ();
}
diff --git a/gcc/algol68/a68-low.cc b/gcc/algol68/a68-low.cc
index 04da444609f..967fc228c42 100644
--- a/gcc/algol68/a68-low.cc
+++ b/gcc/algol68/a68-low.cc
@@ -819,8 +819,10 @@ a68_lower_memcpy (tree dst, tree src, tree size)
tree
a68_lower_alloca (tree type, tree size)
{
- tree call = builtin_decl_explicit (BUILT_IN_ALLOCA);
- call = build_call_expr_loc (UNKNOWN_LOCATION, call, 1, size);
+ tree call = builtin_decl_explicit (BUILT_IN_ALLOCA_WITH_ALIGN);
+ call = build_call_expr_loc (UNKNOWN_LOCATION, call, 2,
+ size,
+ size_int (TYPE_ALIGN (type)));
call = fold_convert (build_pointer_type (type), call);
return call;
}
diff --git a/gcc/algol68/a68-parser-serial-dsa.cc b/gcc/algol68/a68-parser-serial-dsa.cc
new file mode 100644
index 00000000000..bc03e4f75d8
--- /dev/null
+++ b/gcc/algol68/a68-parser-serial-dsa.cc
@@ -0,0 +1,115 @@
+/* Check dynamic stack usage in serial clauses.
+ 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/>. */
+
+/* This file implements a phase that determines what serial clauses contain
+ phrases whose elaboration may involve dynamic stack allocation. It
+ annotates the SERIAL_CLAUSE parse nodes by setting the DYNAMIC_STACK_ALLOCS
+ flag. */
+
+#include "config.h"
+#include "system.h"
+#include "coretypes.h"
+#include "options.h"
+
+#include "a68.h"
+
+/* Uncomment the following line for debugging traces. */
+/* #define SERIAL_DSA_DEBUG */
+
+static void
+serial_dsa_check_serial_clause (NODE_T *p, bool *dsa)
+{
+ for (; p != NO_NODE; FORWARD (p))
+ {
+ if (IS (p, GENERATOR))
+ {
+ /* LOC generators always result in dyamic stack allocation regardless
+ of the mode of the allocated value. */
+ if (IS (SUB (p), LOC_SYMBOL))
+ {
+#ifdef SERIAL_DSA_DEBUG
+ fprintf (stderr, "serial_dsa: %s:%d: loc generator implies DSA\n",
+ FILENAME (LINE (INFO (p))),
+ LINE_NUMBER (p));
+#endif
+ *dsa = true;
+ return;
+ }
+ }
+ else if (IS (p, DEFINING_IDENTIFIER))
+ {
+ /* Variable declarations of values with rows that haven't been
+ explicitly allocated in the heap will result in dynamic stack
+ allocation.
+
+ Note that label declarations do no have a mode, so we have to
+ check for MOID (p). */
+
+ if (MOID (p) != NO_MOID && IS_REF (MOID (p)))
+ {
+ bool heap = HEAP (TAX (p)) == HEAP_SYMBOL;
+ if (HAS_ROWS (SUB (MOID (p))) && !heap)
+ {
+#ifdef SERIAL_DSA_DEBUG
+ fprintf (stderr,
+ "serial_dsa: %s:%d: defining identifier %s implies DSA\n",
+ FILENAME (LINE (INFO (p))),
+ LINE_NUMBER (p),
+ NSYMBOL (p));
+#endif
+ *dsa = true;
+ return;
+ }
+ }
+ }
+ else
+ {
+ /* Inner serial clauses will take care of their own. Code in routine
+ texts will not impact the stack of the containing serial
+ clause. */
+ if (!IS (p, SERIAL_CLAUSE) && !IS (p, ROUTINE_TEXT))
+ serial_dsa_check_serial_clause (SUB (p), dsa);
+ }
+ }
+}
+
+void
+a68_serial_dsa (NODE_T *p)
+{
+ for (; p != NO_NODE; FORWARD (p))
+ {
+ a68_serial_dsa (SUB (p));
+ if (IS (p, SERIAL_CLAUSE))
+ {
+ bool dsa = false;
+ serial_dsa_check_serial_clause (SUB (p), &dsa);
+ DYNAMIC_STACK_ALLOCS (p) = dsa;
+#ifdef SERIAL_DSA_DEBUG
+ if (dsa)
+ {
+ fprintf (stderr, "serial_dsa: %s:%d: marking serial clause %p as DSA\n",
+ FILENAME (LINE (INFO (p))),
+ LINE_NUMBER (p),
+ (void *) p);
+ }
+
+#endif
+ }
+ }
+}
diff --git a/gcc/algol68/a68-parser.cc b/gcc/algol68/a68-parser.cc
index 21c0727a5de..2f33ad5b446 100644
--- a/gcc/algol68/a68-parser.cc
+++ b/gcc/algol68/a68-parser.cc
@@ -106,6 +106,10 @@
(6) A static scope checker detects where objects are transported out of scope.
At run time, a dynamic scope checker will check that what the static scope
checker cannot see.
+
+ (7) A serial-clause dynamic stack allocation (DSA) phase annotates the
+ serial clauses that contain phrases whose elaboration may result in
+ dynamic stack adjustments.
*/
#define INCLUDE_MEMORY
@@ -573,6 +577,12 @@ a68_parser (const char *filename)
a68_scope_checker (TOP_NODE (&A68_JOB));
}
+ /* Serial dynamic stack allocation checker. */
+ if (ERROR_COUNT (&A68_JOB) == 0)
+ {
+ a68_serial_dsa (TOP_NODE (&A68_JOB));
+ }
+
/* Finalise syntax tree. */
if (ERROR_COUNT (&A68_JOB) == 0)
{
@@ -636,6 +646,7 @@ a68_new_node (void)
SEQUENCE (z) = NO_NODE;
PACK (z) = NO_PACK;
CDECL (z) = NULL_TREE;
+ DYNAMIC_STACK_ALLOCS (z) = false;
return z;
}
diff --git a/gcc/algol68/a68-types.h b/gcc/algol68/a68-types.h
index 1b83ed870fa..60450133dd3 100644
--- a/gcc/algol68/a68-types.h
+++ b/gcc/algol68/a68-types.h
@@ -103,7 +103,14 @@ typedef struct A68_T A68_T;
#define NO_TUPLE ((A68_TUPLE *) 0)
#define NO_VAR (0)
-/* A STATUS_MASK_T is a word of flags denoting states. */
+/* A STATUS_MASK_T is a word of flags denoting states.
+
+ Status masks are used in parse tree nodes (NODE_T) and in entries in the
+ symbol table (TAG_T).
+
+
+ SCOPE_ERROR_MASK is used by the static scope checker in order to avoid
+ emitting duplicated scope warnings. */
typedef uint32_t STATUS_MASK_T;
@@ -437,6 +444,11 @@ struct OPTIONS_T
ORIGIN is a static property that describes the history of the entity denoted
by the node. This is only used in nodes denoting values.
+ DYNAMIC_STACK_ALLOCS is a flag used in serial clause nodes. It determines
+ whether the elaboration of the phrases in the serial clause may involve
+ dynamic stack allocation. This is used by the lower pass in order to
+ properly manage the stack pointer while lowering these clauses.
+
CDECL is a GCC GENERIC tree corresponding to a DECL_FIELD for FIELD
nodes. */
@@ -456,6 +468,7 @@ struct NODE_T
TABLE_T *non_local;
TAG_T *tag;
tree cdecl;
+ bool dynamic_stack_allocs;
};
#define NO_NODE ((NODE_T *) 0)
@@ -803,6 +816,7 @@ struct A68_T
#define DERIVATE(p) ((p)->derivate)
#define DIAGNOSTICS(p) ((p)->diagnostics)
#define DIM(p) ((p)->dim)
+#define DYNAMIC_STACK_ALLOCS(p) ((p)->dynamic_stack_allocs)
#define EQUIVALENT(p) ((p)->equivalent_mode)
#define EQUIVALENT_MODE(p) ((p)->equivalent_mode)
#define ERROR_COUNT(p) ((p)->error_count)
diff --git a/gcc/algol68/a68.h b/gcc/algol68/a68.h
index 82ff0108a12..663ab07ba9f 100644
--- a/gcc/algol68/a68.h
+++ b/gcc/algol68/a68.h
@@ -443,6 +443,10 @@ void a68_make_void (NODE_T *p, MOID_T *q);
void a68_scope_checker (NODE_T *p);
+/* a68-parser-serial-dsa.cc */
+
+void a68_serial_dsa (NODE_T *p);
+
/* a68-moids-diagnostics.cc */
char *a68_mode_error_text (NODE_T *n, MOID_T *p, MOID_T *q, int context, int deflex, int depth);
@@ -678,7 +682,8 @@ tree a68_pop_stmt_list (void);
void a68_push_function_range (tree fndel, tree result_type,
bool top_level = false);
void a68_pop_function_range (tree body);
-void a68_push_serial_clause_range (MOID_T *clause_mode);
+void a68_push_serial_clause_range (MOID_T *clause_mode,
+ bool dsa = false);
tree a68_pop_serial_clause_range (void);
void a68_add_stmt (tree exp);
void a68_add_decl (tree decl);
diff --git a/gcc/testsuite/algol68/execute/mcts/clau04.a68 b/gcc/testsuite/algol68/execute/mcts/clau04.a68
index 3b0dca0ec92..7889b0a13e8 100644
--- a/gcc/testsuite/algol68/execute/mcts/clau04.a68
+++ b/gcc/testsuite/algol68/execute/mcts/clau04.a68
@@ -7,5 +7,5 @@ BEGIN ASSERT (LWB []INT BEGIN END = 1);
ASSERT (1UPB[,]INT([]INT(puts("there");())) = 1);
ASSERT (2UPB[,]INT(()) = 0);
CO runtime error: wrong length CO
- 2UPB[,]INT((),(1))
+ CO 2UPB[,]INT((),(1)) CO
END
diff --git a/gcc/testsuite/algol68/execute/serial-dsa-1.a68 b/gcc/testsuite/algol68/execute/serial-dsa-1.a68
new file mode 100644
index 00000000000..e49e95bf4f4
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/serial-dsa-1.a68
@@ -0,0 +1,18 @@
+# This tests stack management for DSA serial clauses.
+ If it fails a stack overflow happens. #
+begin # DSA due to stack allocated multiple. #
+ to 10000
+ do [10000]int foo;
+ skip
+ od;
+ # DSA due to stack allocated multiple. Explicit loc. #
+ to 10000
+ do loc[10000]int foo;
+ skip
+ od;
+ # DSA due to loc generator. #
+ to 10000
+ do ref[]int jorl = loc [10000]int;
+ skip
+ od
+end
diff --git a/gcc/testsuite/algol68/execute/serial-dsa-2.a68 b/gcc/testsuite/algol68/execute/serial-dsa-2.a68
new file mode 100644
index 00000000000..ea8a0fd47a2
--- /dev/null
+++ b/gcc/testsuite/algol68/execute/serial-dsa-2.a68
@@ -0,0 +1,5 @@
+# Check value yielding of DSA serial clauses. #
+begin assert ((ref int foo = loc int := 100;
+ foo) = 100);
+ assert (([10000]int foo; foo[10] := 666; foo)[10] = 666)
+end
--
2.30.2
More information about the Algol68
mailing list