From 7c026ff0b4ced0cd0480cdb6a2ddc88204d68646 Mon Sep 17 00:00:00 2001 From: sperber Date: Sun, 27 Jan 2002 20:20:53 +0000 Subject: [PATCH] Fix external-call-from-callback problem leading to spurious gc-protection-mismatch exceptions. --- c/external.c | 9 ++++++--- scheme/vm/gc-root.scm | 6 +++--- 2 files changed, 9 insertions(+), 6 deletions(-) diff --git a/c/external.c b/c/external.c index d6cf637..17a4d9c 100644 --- a/c/external.c +++ b/c/external.c @@ -127,6 +127,8 @@ s48_value s48_external_call(s48_value sch_proc, s48_value proc_name, 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 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_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); */ @@ -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. */ - 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); } @@ -242,7 +245,7 @@ s48_external_call(s48_value sch_proc, s48_value proc_name, depth, callback_depth()); 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. */ diff --git a/scheme/vm/gc-root.scm b/scheme/vm/gc-root.scm index 8e16463..2404703 100644 --- a/scheme/vm/gc-root.scm +++ b/scheme/vm/gc-root.scm @@ -62,13 +62,13 @@ (define (s48-set-gc-roots-base!) (let ((old-base *external-root-stack-base*)) (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* *external-root-stack-base*))) (set! *external-root-stack-base* old-base) - (set! *external-root-stack* old-base) + (set! *external-root-stack* old-stack) okay?)) ;----------------