From 23a3c78611ce304387560b2830452301efcdb081 Mon Sep 17 00:00:00 2001
From: jjgarcia <jjgarcia>
Date: Sun, 28 Sep 2008 22:15:24 +0000
Subject: [PATCH] Now frame stack overflows can also be recovered. Functions
 for enlarging stack sizes.

---
 src/CHANGELOG           | 17 ++++++++-
 src/c/stacks.d          | 83 ++++++++++++++++++++++++++++++++++-------
 src/c/symbols_list.h    |  8 +++-
 src/c/symbols_list2.h   |  8 +++-
 src/clos/conditions.lsp |  9 +++--
 src/h/external.h        |  2 +-
 src/h/stacks.h          |  2 +-
 7 files changed, 106 insertions(+), 23 deletions(-)

diff --git a/src/CHANGELOG b/src/CHANGELOG
index d06939fe3..0aebbe203 100644
--- a/src/CHANGELOG
+++ b/src/CHANGELOG
@@ -102,8 +102,21 @@ ECL 8.9.0:
  - COMPILE would create an extra empty file which would not get deleted after
    finishing compilation (Josh Elsasser).
 
- - On overflow, binding stack signals a correctable error with STACK-OVERFLOW
-   condition.
+ - On overflow, binding and frame stack signal a correctable error with
+   STACK-OVERFLOW condition.
+	(block faa
+	      (labels ((foo (x)
+			 (catch 'foo (foo (1+ x))))
+		       (handle-overflow (c)
+			 (let ((s (ext:stack-overflow-size c)))
+				   (if (< s 2304)
+			       (continue)
+			       (return-from faa (ext::stack-overflow-type c))))))
+		(handler-bind ((ext:stack-overflow #'handle-overflow))
+		  (foo 1))))
+
+ - New function (EXT:SET-STACK-SIZE type size) can resize type =
+   EXT:BINDING-STACK, EXT:LISP-STACK and EXT:FRAME-STACK.
 
  - FLOAT-SIGN returns the right value on negative zeros.
 
diff --git a/src/c/stacks.d b/src/c/stacks.d
index e84ad7bea..c2fb996b0 100644
--- a/src/c/stacks.d
+++ b/src/c/stacks.d
@@ -119,6 +119,24 @@ bds_unwind_n(int n)
 	while (n--) bds_unwind1();
 }
 
+static void
+bds_set_size(cl_index size)
+{
+	cl_index limit = (cl_env.bds_top - cl_env.bds_org);
+	if (size <= limit) {
+		FEerror("Cannot shrink the binding stack below ~D.", 1,
+			ecl_make_unsigned_integer(limit));
+	} else {
+		bds_ptr org;
+		org = cl_alloc_atomic(size * sizeof(*org));
+		memcpy(org, cl_env.bds_org, (cl_env.bds_top - cl_env.bds_org) * sizeof(*org));
+		cl_env.bds_top = org + (cl_env.bds_top - cl_env.bds_org);
+		cl_env.bds_org = org;
+		cl_env.bds_limit = org + (size - 2*BDSGETA);
+		cl_env.bds_size = size;
+	}
+}
+
 void
 bds_overflow(void)
 {
@@ -129,14 +147,10 @@ bds_overflow(void)
 		ecl_internal_error("Bind stack overflow, cannot grow larger.");
 	}
 	cl_env.bds_limit += BDSGETA;
-	cl_cerror(4, Ct, @'si::stack-overflow', @':size', MAKE_FIXNUM(size));
-	size += size / 2;
-	org = cl_alloc_atomic(size * sizeof(*org));
-	memcpy(org, cl_env.bds_org, (cl_env.bds_top - cl_env.bds_org) * sizeof(*org));
-	cl_env.bds_top = org + (cl_env.bds_top - cl_env.bds_org);
-	cl_env.bds_org = org;
-	cl_env.bds_limit = org + (size - 2*BDSGETA);
-	cl_env.bds_size = size;
+	cl_cerror(6, make_constant_base_string("Extend stack size"),
+		  @'ext::stack-overflow', @':size', MAKE_FIXNUM(size),
+		  @':type', @'ext::binding-stack');
+	bds_set_size(size + (size / 2));
 }
 
 void
@@ -271,21 +285,48 @@ new_frame_id(void)
   return(MAKE_FIXNUM(frame_id++));
 }
 
-int
+static void
+frs_set_size(cl_index size)
+{
+	cl_index limit = (cl_env.frs_top - cl_env.frs_org);
+	if (size <= limit) {
+		FEerror("Cannot shrink frame stack below ~D.", 1,
+			ecl_make_unsigned_integer(limit));
+	} else {
+		ecl_frame_ptr org;
+		org = cl_alloc_atomic(size * sizeof(*org));
+		memcpy(org, cl_env.frs_org, (cl_env.frs_top - cl_env.frs_org) * sizeof(*org));
+		cl_env.frs_top = org + (cl_env.frs_top - cl_env.frs_org);
+		cl_env.frs_org = org;
+		cl_env.frs_limit = org + (size - 2*FRSGETA);
+		cl_env.frs_size = size;
+	}
+}
+
+static void
 frs_overflow(void)		/* used as condition in list.d */
 {
-	--cl_env.frs_top;
-	if (cl_env.frs_limit > cl_env.frs_org + cl_env.frs_size)
-		ecl_internal_error("frame stack overflow.");
+	cl_index size = cl_env.frs_size;
+	ecl_frame_ptr org = cl_env.frs_org;
+	ecl_frame_ptr last = org + size;
+	if (cl_env.frs_limit >= last) {
+		ecl_internal_error("Frame stack overflow, cannot grow larger.");
+	}
 	cl_env.frs_limit += FRSGETA;
-	FEerror("Frame stack overflow.", 0);
+	cl_cerror(6, make_constant_base_string("Extend stack size"),
+		  @'ext::stack-overflow', @':size', MAKE_FIXNUM(size),
+		  @':type', @'ext::frame-stack');
+	frs_set_size(size + size / 2);
 }
 
 ecl_frame_ptr
 _frs_push(register cl_object val)
 {
 	ecl_frame_ptr output = ++cl_env.frs_top;
-	if (output >= cl_env.frs_limit) frs_overflow();
+	if (output >= cl_env.frs_limit) {
+		frs_overflow();
+		output = cl_env.frs_top;
+	}
 	output->frs_bds_top_index = cl_env.bds_top - cl_env.bds_org;
 	output->frs_val = val;
 	output->frs_ihs = cl_env.ihs_top;
@@ -394,6 +435,20 @@ si_reset_stack_limits()
 	@(return Cnil)
 }
 
+cl_object
+si_set_stack_size(cl_object type, cl_object size)
+{
+	cl_index the_size = fixnnint(size);
+	if (type == @'ext::frame-stack') {
+		frs_set_size(the_size);
+	} else if (type == @'ext::binding-stack') {
+		bds_set_size(the_size);
+	} else {
+		cl_stack_set_size(the_size);
+	}
+	@(return)
+}
+
 void
 init_stacks(int *new_cs_org)
 {
diff --git a/src/c/symbols_list.h b/src/c/symbols_list.h
index 435e116ec..d257bee91 100644
--- a/src/c/symbols_list.h
+++ b/src/c/symbols_list.h
@@ -1702,7 +1702,13 @@ cl_symbols[] = {
 
 {EXT_ "INTERACTIVE-INTERRUPT", SI_ORDINARY, NULL, -1, OBJNULL},
 
-{SYS_ "STACK-OVERFLOW", SI_ORDINARY, NULL, -1, OBJNULL},
+{EXT_ "STACK-OVERFLOW", SI_ORDINARY, NULL, -1, OBJNULL},
+{EXT_ "STACK-OVERFLOW-SIZE", SI_ORDINARY, NULL, -1, OBJNULL},
+{EXT_ "STACK-OVERFLOW-TYPE", SI_ORDINARY, NULL, -1, OBJNULL},
+{EXT_ "BINDING-STACK", SI_ORDINARY, NULL, -1, OBJNULL},
+{EXT_ "FRAME-STACK", SI_ORDINARY, NULL, -1, OBJNULL},
+{EXT_ "LISP-STACK", SI_ORDINARY, NULL, -1, OBJNULL},
+{EXT_ "SET-STACK-SIZE", SI_ORDINARY, si_set_stack_size, 2, OBJNULL},
 
 /* Tag for end of list */
 {NULL, CL_ORDINARY, NULL, -1, OBJNULL}};
diff --git a/src/c/symbols_list2.h b/src/c/symbols_list2.h
index 6d3efe249..1345a6192 100644
--- a/src/c/symbols_list2.h
+++ b/src/c/symbols_list2.h
@@ -1702,7 +1702,13 @@ cl_symbols[] = {
 
 {EXT_ "INTERACTIVE-INTERRUPT",NULL},
 
-{SYS_ "STACK-OVERFLOW",NULL},
+{EXT_ "STACK-OVERFLOW",NULL},
+{EXT_ "STACK-OVERFLOW-SIZE",NULL},
+{EXT_ "STACK-OVERFLOW-TYPE",NULL},
+{EXT_ "BINDING-STACK",NULL},
+{EXT_ "FRAME-STACK",NULL},
+{EXT_ "LISP-STACK",NULL},
+{EXT_ "SET-STACK-SIZE","si_set_stack_size"},
 
 /* Tag for end of list */
 {NULL,NULL}};
diff --git a/src/clos/conditions.lsp b/src/clos/conditions.lsp
index 59c25b600..8c1420322 100644
--- a/src/clos/conditions.lsp
+++ b/src/clos/conditions.lsp
@@ -533,11 +533,14 @@ returns with NIL."
 
 (define-condition storage-condition (serious-condition) ())
 
-(define-condition stack-overflow (storage-condition)
-  ((stack-size :initarg :size :initform 0))
+(define-condition ext:stack-overflow (storage-condition)
+  ((size :initarg :size :initform 0 :reader ext:stack-overflow-size)
+   (type :initarg :type :initform nil :reader ext:stack-overflow-type))
   (:REPORT
    (lambda (condition stream)
-     (format stream "Stack overflow at size ~D." (slot-value condition 'stack-size)))))
+     (format stream "~A overflow at size ~D. Stack can probably be resized."
+	     (ext:stack-overflow-type condition)
+	     (ext:stack-overflow-size condition)))))
 
 (define-condition storage-exhausted (storage-condition) ())
 
diff --git a/src/h/external.h b/src/h/external.h
index f231aea62..601d49099 100644
--- a/src/h/external.h
+++ b/src/h/external.h
@@ -1293,10 +1293,10 @@ extern ECL_API cl_object si_bds_var(cl_object arg);
 extern ECL_API cl_object si_bds_val(cl_object arg);
 extern ECL_API cl_object si_sch_frs_base(cl_object fr, cl_object ihs);
 extern ECL_API cl_object si_reset_stack_limits(void);
+extern ECL_API cl_object si_set_stack_size(cl_object type, cl_object size);
 
 extern ECL_API void bds_overflow(void) /*__attribute__((noreturn))*/;
 extern ECL_API void bds_unwind(cl_index new_bds_top_index);
-extern ECL_API int frs_overflow(void) /*__attribute__((noreturn))*/;
 extern ECL_API void ecl_unwind(ecl_frame_ptr fr) /*__attribute__((noreturn))*/;
 extern ECL_API ecl_frame_ptr frs_sch(cl_object frame_id);
 extern ECL_API ecl_frame_ptr frs_sch_catch(cl_object frame_id);
diff --git a/src/h/stacks.h b/src/h/stacks.h
index 50ab5bc69..1b7275ce0 100644
--- a/src/h/stacks.h
+++ b/src/h/stacks.h
@@ -111,7 +111,7 @@ extern ECL_API cl_object ihs_top_function_name(void);
 typedef struct ecl_frame {
 	jmp_buf		frs_jmpbuf;
 	cl_object	frs_val;
-	bds_ptr		frs_bds_top_index;
+	cl_index	frs_bds_top_index;
 	ihs_ptr		frs_ihs;
 	cl_index	frs_sp;
 } *ecl_frame_ptr;