scsh-conservatory
/
scsh-0.6
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Fix external-call-from-callback problem leading to spurious 

gc-protection-mismatch exceptions.
This commit is contained in:
sperber 2002-01-27 20:20:53 +00:00
parent 369bc08f2e
commit 7c026ff0b4
2 changed files with 9 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
c/external.c
View File

@ -127,6 +127,8 @@ s48_value
s48_external_call(s48_value sch_proc, s48_value proc_name, s48_external_call(s48_value sch_proc, s48_value proc_name,
long nargs, char *char_argv) long nargs, char *char_argv)
{ {
volatile char *gc_marker; /* volatile to survive longjumps */
char *gc_marker_temp; /* C wants it so */
volatile char *gc_roots_marker; /* volatile to survive longjumps */ volatile char *gc_roots_marker; /* volatile to survive longjumps */
volatile s48_value name = proc_name; /* volatile to survive longjumps */ volatile s48_value name = proc_name; /* volatile to survive longjumps */
@ -144,7 +146,8 @@ s48_external_call(s48_value sch_proc, s48_value proc_name,
S48_CHECK_VALUE(sch_proc); S48_CHECK_VALUE(sch_proc);
S48_CHECK_STRING(name); S48_CHECK_STRING(name);
gc_roots_marker = s48_set_gc_roots_baseB(); gc_roots_marker = s48_set_gc_roots_baseB(&gc_marker_temp);
gc_marker = gc_marker_temp;
/* fprintf(stderr, "[external_call at depth %d]\n", depth); */ /* fprintf(stderr, "[external_call at depth %d]\n", depth); */
@ -209,7 +212,7 @@ s48_external_call(s48_value sch_proc, s48_value proc_name,
/* Raise an exception if the user neglected to pop off some gc roots. */ /* Raise an exception if the user neglected to pop off some gc roots. */
if (! s48_release_gc_roots_baseB((char *)gc_roots_marker)) { if (! s48_release_gc_roots_baseB((char *)gc_roots_marker, (char *)gc_marker)) {
s48_raise_scheme_exception(S48_EXCEPTION_GC_PROTECTION_MISMATCH, 0); s48_raise_scheme_exception(S48_EXCEPTION_GC_PROTECTION_MISMATCH, 0);
} }
@ -242,7 +245,7 @@ s48_external_call(s48_value sch_proc, s48_value proc_name,
depth, depth,
callback_depth()); callback_depth());
fprintf(stderr, "[throw unrolling to %ld]\n", gc_roots_marker); */ fprintf(stderr, "[throw unrolling to %ld]\n", gc_roots_marker); */
s48_release_gc_roots_baseB((char *)gc_roots_marker); s48_release_gc_roots_baseB((char *)gc_roots_marker, (char *)gc_marker);
} }
/* Check to see if a thread is waiting to return to the next block down. */ /* Check to see if a thread is waiting to return to the next block down. */

6
scheme/vm/gc-root.scm
View File

@ -62,13 +62,13 @@
(define (s48-set-gc-roots-base!) (define (s48-set-gc-roots-base!)
(let ((old-base *external-root-stack-base*)) (let ((old-base *external-root-stack-base*))
(set! *external-root-stack-base* *external-root-stack*) (set! *external-root-stack-base* *external-root-stack*)
old-base)) (values old-base *external-root-stack*)))
(define (s48-release-gc-roots-base! old-base) (define (s48-release-gc-roots-base! old-base old-stack)
(let ((okay? (address= *external-root-stack* (let ((okay? (address= *external-root-stack*
*external-root-stack-base*))) *external-root-stack-base*)))
(set! *external-root-stack-base* old-base) (set! *external-root-stack-base* old-base)
(set! *external-root-stack* old-base) (set! *external-root-stack* old-stack)
okay?)) okay?))
;---------------- ;----------------