mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2026-01-14 13:21:54 -08:00
Code Issues Projects Releases Packages Wiki Activity

Now frame stack overflows can also be recovered. Functions for enlarging stack sizes.

Browse source
This commit is contained in:
jjgarcia 2008-09-28 22:15:24 +00:00
parent 1a8633a0fe
commit 23a3c78611
7 changed files with 106 additions and 23 deletions
Download patch file Download diff file Expand all files Collapse all files

17
src/CHANGELOG
View file

@ -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.

83
src/c/stacks.d
View file

@ -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)
{

8
src/c/symbols_list.h
View file

@ -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}};

8
src/c/symbols_list2.h
View file

@ -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}};

9
src/clos/conditions.lsp
View file

@ -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) ())

2
src/h/external.h
View file

@ -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);

2
src/h/stacks.h
View file

@ -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;