suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

drop the uglier half of the Mac OS X thread-local variable hack; thread GC state through mark functions (to avoid overhead of thread-local accesses); fix some procedure-arity bugs and work toward fixing chaperones and some other procedure operations on keyword procedures

Browse Source 
svn: r18661
This commit is contained in:
Matthew Flatt 2010-03-29 15:06:47 +00:00
parent 2bda6af6b0
commit baab09fc1b
20 changed files with 2761 additions and 2646 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

88
collects/scheme/private/kw.ss
View File

@ -18,7 +18,10 @@
keyword-apply
procedure-keywords
procedure-reduce-keyword-arity
new-prop:procedure)
new-prop:procedure
new:procedure->method
new:procedure-rename
new:chaperone-procedure)
;; ----------------------------------------
@ -854,8 +857,10 @@
(let loop ([kws kws][req-kws req-kws])
(if (null? req-kws)
(null? kws)
(and (eq? (car kws) (car req-kws))
(loop (cdr kws) (cdr req-kws))))))
(if (null? kws)
#f
(and (eq? (car kws) (car req-kws))
(loop (cdr kws) (cdr req-kws)))))))
(arity-check-lambda
(kws)
;; Required is a subset of allowed
@ -970,8 +975,8 @@
;; setting procedure arity
(define (procedure-reduce-keyword-arity proc arity req-kw allowed-kw)
(let ([plain-proc (procedure-reduce-arity (if (okp? proc)
(okp-ref proc 0)
(let ([plain-proc (procedure-reduce-arity (if (okp? proc)
(okp-ref proc 0)
proc)
arity)])
(define (sorted? kws)
@ -1022,17 +1027,62 @@
(raise-mismatch-error 'procedure-reduce-keyword-arity
"cannot allow keywords not in original allowed set: "
old-allowed))))
(let ([new-arity (let loop ([a arity])
(cond
[(integer? a) (+ a 2)]
[(arity-at-least? a)
(make-arity-at-least (+ (arity-at-least-value a) 2))]
[else
(map loop a)]))])
(make-optional-keyword-procedure
(make-keyword-checker req-kw allowed-kw new-arity)
(procedure-reduce-arity (keyword-procedure-proc proc)
new-arity)
req-kw
allowed-kw
plain-proc)))))
(if (null? allowed-kw)
plain-proc
(let* ([inc-arity (lambda (arity delta)
(let loop ([a arity])
(cond
[(integer? a) (+ a delta)]
[(arity-at-least? a)
(make-arity-at-least (+ (arity-at-least-value a) delta))]
[else
(map loop a)])))]
[new-arity (inc-arity arity 2)]
[kw-checker (make-keyword-checker req-kw allowed-kw new-arity)]
[new-kw-proc (procedure-reduce-arity (keyword-procedure-proc proc)
new-arity)])
(if (null? req-kw)
;; All keywords are optional:
((if (okm? proc)
make-optional-keyword-method
make-optional-keyword-procedure)
kw-checker
new-kw-proc
req-kw
allowed-kw
plain-proc)
;; Some keywords are required, so "plain" proc is
;; irrelevant; we build a new one that wraps `missing-kws'.
((make-required (or (and (named-keyword-procedure? proc)
(keyword-procedure-name proc))
(object-name proc))
(procedure-reduce-arity
missing-kw
(inc-arity arity 1))
(or (okm? proc)
(keyword-method? proc)))
kw-checker
new-kw-proc
req-kw
allowed-kw))))))
(define new:procedure->method
(let ([procedure->method
(lambda (proc)
(procedure->method proc))])
procedure->method))
(define new:procedure-rename
(let ([procedure-rename
(lambda (proc name)
(if (not (and (keyword-procedure? proc)
(symbol? name)))
(procedure-rename proc name)
(procedure-rename proc name)))])
procedure-rename))
(define new:chaperone-procedure
(let ([chaperone-procedure
(lambda (proc wrap-proc . props)
(apply chaperone-procedure proc wrap-proc props))])
chaperone-procedure)))

7
collects/scheme/private/pre-base.ss
View File

@ -73,8 +73,13 @@
(rename module-begin #%module-begin)
(rename norm:procedure-arity procedure-arity)
(rename norm:raise-arity-error raise-arity-error)
(rename new:procedure->method procedure->method)
(rename new:procedure-rename procedure-rename)
(rename new:chaperone-procedure chaperone-procedure)
(all-from-except '#%kernel lambda λ #%app #%module-begin apply prop:procedure
procedure-arity raise-arity-error)
procedure-arity raise-arity-error
procedure->method procedure-rename
chaperone-procedure)
(all-from "reqprov.ss")
(all-from "for.ss")
(all-from "kernstruct.ss")

6
collects/tests/mzscheme/chaperone.ss
View File

@ -314,6 +314,12 @@
[a2 (if rev?
(chaperone-struct a3 a-y (lambda (a v) (set! get v) v))
a2)])
(test #t a? a1)
(test #t a? a2)
(test #t a? a3)
(test #t procedure? a1)
(test #t procedure? a2)
(test #t procedure? a3)
(test '(12 12) a1 12)
(test #f values get)
(test #f values pre)

11
collects/tests/mzscheme/procs.ss
View File

@ -68,7 +68,7 @@
(for-each (lambda (p)
(let ([a (cadr p)])
(test a procedure-arity (car p))
(test-values (list (caddr p) (cadddr p))
(test-values (list (caddr p) (cadddr p))
(lambda ()
(procedure-keywords (car p))))
(let ([1-ok? (let loop ([a a])
@ -78,7 +78,14 @@
(and (list? a)
(ormap loop a))))])
(test 1-ok? procedure-arity-includes? (car p) 1)
(let ([allowed (cadddr p)])
(let ([allowed (cadddr p)]
[required (caddr p)])
;; If some keyword is required, make sure that a plain
;; application fails:
(unless (null? required)
(err/rt-test
(apply (car p) (make-list (procedure-arity (car p)) #\0))))
;; Other tests:
(if 1-ok?
(cond
[(equal? allowed '())

1
doc/release-notes/mzscheme/HISTORY.txt
View File

@ -1,4 +1,5 @@
Version 4.2.5, March 2010
Added scheme/future, enabled by default on main platforms
Changed module to wrap each body expression in a prompt
Changed define-cstruct to bind type name for struct-out, etc.

2
src/mzscheme/gc2/Makefile.in
View File

@ -269,7 +269,7 @@ list.@LTO@: $(XSRCDIR)/list.c
$(CC) $(CFLAGS) -c $(XSRCDIR)/list.c -o list.@LTO@
module.@LTO@: $(XSRCDIR)/module.c
$(CC) $(CFLAGS) -c $(XSRCDIR)/module.c -o module.@LTO@
mzrt.@LTO@: $(SRCDIR)/mzrt.c $(SRCDIR)/mzrt.h
mzrt.@LTO@: $(SRCDIR)/mzrt.c $(SRCDIR)/mzrt.h $(XFORMDEP)
$(CC) $(CFLAGS) -DMZ_PRECISE_GC -c $(SRCDIR)/mzrt.c -o mzrt.@LTO@
network.@LTO@: $(XSRCDIR)/network.c
$(CC) $(CFLAGS) -c $(XSRCDIR)/network.c -o network.@LTO@

25
src/mzscheme/gc2/gc2.h
View File

@ -15,9 +15,14 @@
#ifndef GC2_JUST_MACROS
struct NewGC;
typedef int (*Size_Proc)(void *obj);
typedef int (*Size2_Proc)(void *obj, struct NewGC *);
typedef int (*Mark_Proc)(void *obj);
typedef int (*Mark2_Proc)(void *obj, struct NewGC *);
typedef int (*Fixup_Proc)(void *obj);
typedef int (*Fixup2_Proc)(void *obj, struct NewGC *);
typedef void (*GC_collect_start_callback_Proc)(void);
typedef void (*GC_collect_end_callback_Proc)(void);
typedef void (*GC_collect_inform_callback_Proc)(int major_gc, long pre_used, long post_used);
@ -288,6 +293,8 @@ GC2_EXTERN void GC_set_variable_stack(void **p);
GC2_EXTERN void GC_register_traversers(short tag, Size_Proc size, Mark_Proc mark, Fixup_Proc fixup,
int is_constant_size, int is_atomic);
GC2_EXTERN void GC_register_traversers2(short tag, Size2_Proc size, Mark2_Proc mark, Fixup2_Proc fixup,
int is_constant_size, int is_atomic);
/*
Registers a traversal procedure for a tag. Obviously, a traversal
procedure must be installed for each tag before a collection
@ -336,6 +343,8 @@ GC2_EXTERN void *GC_fixup_self(void *p);
/* INTERNAL for the current implemenation (used by macros): */
GC2_EXTERN void GC_mark(const void *p);
GC2_EXTERN void GC_fixup(void *p);
GC2_EXTERN void GC_mark2(const void *p, struct NewGC *gc);
GC2_EXTERN void GC_fixup2(void *p, struct NewGC *gc);
/*
Used in the expansion of gcMARK and gcFIXUP.
@ -350,6 +359,16 @@ GC2_EXTERN void GC_fixup_variable_stack(void **var_stack,
long delta,
void *limit,
void *stack_mem);
GC2_EXTERN void GC_mark2_variable_stack(void **var_stack,
long delta,
void *limit,
void *stack_mem,
struct NewGC *gc);
GC2_EXTERN void GC_fixup2_variable_stack(void **var_stack,
long delta,
void *limit,
void *stack_mem,
struct NewGC *gc);
/*
Can be called by a mark or fixup traversal proc to traverse and
update a chunk of (atomically-allocated) memory containing an image
@ -443,11 +462,17 @@ GC2_EXTERN void GC_set_put_external_event_fd(void *fd);
# define gcLOG_WORD_SIZE 2
#endif
#define gcMARK(x) GC_mark(x)
#define gcMARK2(x, gc) GC_mark2(x, gc)
#define gcMARK_TYPED(t, x) gcMARK(x)
#define gcMARK2_TYPED(t, x, gc) gcMARK2(x, gc)
#define gcMARK_TYPED_NOW(t, x) gcMARK(x)
#define gcMARK2_TYPED_NOW(t, x, gc) gcMARK(x, gc)
#define gcFIXUP_TYPED_NOW(t, x) GC_fixup(&(x))
#define gcFIXUP2_TYPED_NOW(t, x, gc) GC_fixup2(&(x), gc)
#define gcFIXUP_TYPED(t, x) gcFIXUP_TYPED_NOW(void*, x)
#define gcFIXUP2_TYPED(t, x, gc) gcFIXUP2_TYPED_NOW(void*, x, gc)
#define gcFIXUP(x) gcFIXUP_TYPED(void*, x)
#define gcFIXUP2(x, gc) gcFIXUP2_TYPED(void*, x, gc)
#define gcBYTES_TO_WORDS(x) ((x + (1 << gcLOG_WORD_SIZE) - 1) >> gcLOG_WORD_SIZE)
#define gcWORDS_TO_BYTES(x) (x << gcLOG_WORD_SIZE)

30
src/mzscheme/gc2/mem_account.c
View File

@ -43,12 +43,12 @@ inline static void BTC_register_thread(void *t, void *c)
inline static void mark_threads(NewGC *gc, int owner)
{
GC_Thread_Info *work;
Mark_Proc thread_mark = gc->mark_table[btc_redirect_thread];
Mark2_Proc thread_mark = gc->mark_table[btc_redirect_thread];
for(work = gc->thread_infos; work; work = work->next)
if(work->owner == owner) {
if (((Scheme_Thread *)work->thread)->running) {
thread_mark(work->thread);
thread_mark(work->thread, gc);
if (work->thread == scheme_current_thread) {
GC_mark_variable_stack(GC_variable_stack, 0, get_stack_base(gc), NULL);
}
@ -275,7 +275,7 @@ inline static void mark_cust_boxes(NewGC *gc, Scheme_Custodian *cur)
{
Scheme_Object *pr, *prev = NULL, *next;
GC_Weak_Box *wb;
Mark_Proc cust_box_mark = gc->mark_table[btc_redirect_cust_box];
Mark2_Proc cust_box_mark = gc->mark_table[btc_redirect_cust_box];
/* cust boxes is a list of weak boxes to cust boxes */
@ -284,7 +284,7 @@ inline static void mark_cust_boxes(NewGC *gc, Scheme_Custodian *cur)
wb = (GC_Weak_Box *)SCHEME_CAR(pr);
next = SCHEME_CDR(pr);
if (wb->val) {
cust_box_mark(wb->val);
cust_box_mark(wb->val, gc);
prev = pr;
} else {
if (prev)
@ -298,34 +298,31 @@ inline static void mark_cust_boxes(NewGC *gc, Scheme_Custodian *cur)
cur->checked_cust_boxes = cur->num_cust_boxes;
}
int BTC_thread_mark(void *p)
int BTC_thread_mark(void *p, struct NewGC *gc)
{
NewGC *gc = GC_get_GC();
if (gc->doing_memory_accounting) {
return OBJPTR_TO_OBJHEAD(p)->size;
}
return gc->mark_table[btc_redirect_thread](p);
return gc->mark_table[btc_redirect_thread](p, gc);
}
int BTC_custodian_mark(void *p)
int BTC_custodian_mark(void *p, struct NewGC *gc)
{
NewGC *gc = GC_get_GC();
if (gc->doing_memory_accounting) {
if(custodian_to_owner_set(gc, p) == gc->current_mark_owner)
return gc->mark_table[btc_redirect_custodian](p);
return gc->mark_table[btc_redirect_custodian](p, gc);
else
return OBJPTR_TO_OBJHEAD(p)->size;
}
return gc->mark_table[btc_redirect_custodian](p);
return gc->mark_table[btc_redirect_custodian](p, gc);
}
int BTC_cust_box_mark(void *p)
int BTC_cust_box_mark(void *p, struct NewGC *gc)
{
NewGC *gc = GC_get_GC();
if (gc->doing_memory_accounting) {
return OBJPTR_TO_OBJHEAD(p)->size;
}
return gc->mark_table[btc_redirect_cust_box](p);
return gc->mark_table[btc_redirect_cust_box](p, gc);
}
static void btc_overmem_abort(NewGC *gc)
@ -338,12 +335,11 @@ static void btc_overmem_abort(NewGC *gc)
static void propagate_accounting_marks(NewGC *gc)
{
void *p;
PageMap pagemap = gc->page_maps;
Mark_Proc *mark_table = gc->mark_table;
Mark2_Proc *mark_table = gc->mark_table;
while(pop_ptr(gc, &p) && !gc->kill_propagation_loop) {
/* GCDEBUG((DEBUGOUTF, "btc_account: popped off page %p:%p, ptr %p\n", page, page->addr, p)); */
propagate_marks_worker(pagemap, mark_table, p);
propagate_marks_worker(gc, mark_table, p);
}
if(gc->kill_propagation_loop)
reset_pointer_stack(gc);

148
src/mzscheme/gc2/newgc.c
View File

@ -1432,22 +1432,38 @@ static inline void *get_stack_base(NewGC *gc) {
#include "stack_comp.c"
#define GC_X_variable_stack GC_mark_variable_stack
#define gcX(a) gcMARK(*a)
#define GC_X_variable_stack GC_mark2_variable_stack
#define gcX2(a, gc) gcMARK2(*a, gc)
#define X_source(stk, p) set_backtrace_source((stk ? stk : p), BT_STACK)
#include "var_stack.c"
#undef GC_X_variable_stack
#undef gcX
#undef gcX2
#undef X_source
#define GC_X_variable_stack GC_fixup_variable_stack
#define gcX(a) gcFIXUP(*a)
#define GC_X_variable_stack GC_fixup2_variable_stack
#define gcX2(a, gc) gcFIXUP2(*a, gc)
#define X_source(stk, p) /* */
#include "var_stack.c"
#undef GC_X_variable_stack
#undef gcX
#undef gcX2
#undef X_source
void GC_mark_variable_stack(void **var_stack,
long delta,
void *limit,
void *stack_mem)
{
GC_mark2_variable_stack(var_stack, delta, limit, stack_mem, GC_get_GC());
}
void GC_fixup_variable_stack(void **var_stack,
long delta,
void *limit,
void *stack_mem)
{
GC_fixup2_variable_stack(var_stack, delta, limit, stack_mem, GC_get_GC());
}
/*****************************************************************************/
/* Routines for root sets */
/*****************************************************************************/
@ -1499,16 +1515,16 @@ inline static void mark_finalizer_structs(NewGC *gc)
for(fnl = GC_resolve(gc->finalizers); fnl; fnl = GC_resolve(fnl->next)) {
set_backtrace_source(fnl, BT_FINALIZER);
gcMARK(fnl->data);
gcMARK2(fnl->data, gc);
set_backtrace_source(&gc->finalizers, BT_ROOT);
gcMARK(fnl);
gcMARK2(fnl, gc);
}
for(fnl = gc->run_queue; fnl; fnl = fnl->next) {
set_backtrace_source(fnl, BT_FINALIZER);
gcMARK(fnl->data);
gcMARK(fnl->p);
gcMARK2(fnl->data, gc);
gcMARK2(fnl->p, gc);
set_backtrace_source(&gc->run_queue, BT_ROOT);
gcMARK(fnl);
gcMARK2(fnl, gc);
}
}
@ -1517,17 +1533,17 @@ inline static void repair_finalizer_structs(NewGC *gc)
Fnl *fnl;
/* repair the base parts of the list */
gcFIXUP(gc->finalizers); gcFIXUP(gc->run_queue);
gcFIXUP2(gc->finalizers, gc); gcFIXUP2(gc->run_queue, gc);
/* then repair the stuff inside them */
for(fnl = gc->finalizers; fnl; fnl = fnl->next) {
gcFIXUP(fnl->data);
gcFIXUP(fnl->p);
gcFIXUP(fnl->next);
gcFIXUP2(fnl->data, gc);
gcFIXUP2(fnl->p, gc);
gcFIXUP2(fnl->next, gc);
}
for(fnl = gc->run_queue; fnl; fnl = fnl->next) {
gcFIXUP(fnl->data);
gcFIXUP(fnl->p);
gcFIXUP(fnl->next);
gcFIXUP2(fnl->data, gc);
gcFIXUP2(fnl->p, gc);
gcFIXUP2(fnl->next, gc);
}
}
@ -1545,7 +1561,7 @@ inline static void check_finalizers(NewGC *gc, int level)
"CFNL: Level %i finalizer %p on %p queued for finalization.\n",
work->eager_level, work, work->p));
set_backtrace_source(work, BT_FINALIZER);
gcMARK(work->p);
gcMARK2(work->p, gc);
if(prev) prev->next = next;
if(!prev) gc->finalizers = next;
if(gc->last_in_queue) gc->last_in_queue = gc->last_in_queue->next = work;
@ -1567,7 +1583,7 @@ inline static void check_finalizers(NewGC *gc, int level)
inline static void do_ordered_level3(NewGC *gc)
{
struct finalizer *temp;
Mark_Proc *mark_table = gc->mark_table;
Mark2_Proc *mark_table = gc->mark_table;
for(temp = GC_resolve(gc->finalizers); temp; temp = GC_resolve(temp->next))
if(!marked(gc, temp->p)) {
@ -1575,7 +1591,7 @@ inline static void do_ordered_level3(NewGC *gc)
"LVL3: %p is not marked. Marking payload (%p)\n",
temp, temp->p));
set_backtrace_source(temp, BT_FINALIZER);
if(temp->tagged) mark_table[*(unsigned short*)temp->p](temp->p);
if(temp->tagged) mark_table[*(unsigned short*)temp->p](temp->p, gc);
if(!temp->tagged) GC_mark_xtagged(temp->p);
}
}
@ -1598,7 +1614,7 @@ inline static void mark_weak_finalizer_structs(NewGC *gc)
GCDEBUG((DEBUGOUTF, "MARKING WEAK FINALIZERS.\n"));
for(work = gc->weak_finalizers; work; work = work->next) {
set_backtrace_source(&gc->weak_finalizers, BT_ROOT);
gcMARK(work);
gcMARK2(work, gc);
}
}
@ -1607,16 +1623,16 @@ inline static void repair_weak_finalizer_structs(NewGC *gc)
Weak_Finalizer *work;
Weak_Finalizer *prev;
gcFIXUP(gc->weak_finalizers);
gcFIXUP2(gc->weak_finalizers, gc);
work = gc->weak_finalizers; prev = NULL;
while(work) {
gcFIXUP(work->next);
gcFIXUP2(work->next, gc);
if(!marked(gc, work->p)) {
if(prev) prev->next = work->next;
if(!prev) gc->weak_finalizers = work->next;
work = GC_resolve(work->next);
} else {
gcFIXUP(work->p);
gcFIXUP2(work->p, gc);
prev = work;
work = work->next;
}
@ -1640,7 +1656,7 @@ inline static void reset_weak_finalizers(NewGC *gc)
for(wfnl = GC_resolve(gc->weak_finalizers); wfnl; wfnl = GC_resolve(wfnl->next)) {
if(marked(gc, wfnl->p)) {
set_backtrace_source(wfnl, BT_WEAKLINK);
gcMARK(wfnl->saved);
gcMARK2(wfnl->saved, gc);
}
*(void**)(NUM(GC_resolve(wfnl->p)) + wfnl->offset) = wfnl->saved;
wfnl->saved = NULL;
@ -1754,7 +1770,7 @@ inline static void reset_pointer_stack(NewGC *gc)
gc->mark_stack->top = MARK_STACK_START(gc->mark_stack);
}
static inline void propagate_marks_worker(PageMap pagemap, Mark_Proc *mark_table, void *p);
static inline void propagate_marks_worker(NewGC *gc, Mark2_Proc *mark_table, void *p);
/*****************************************************************************/
/* MEMORY ACCOUNTING */
@ -1996,8 +2012,8 @@ static void NewGC_initialize(NewGC *newgc, NewGC *parentgc) {
#ifdef MZ_USE_PLACES
NewGCMasterInfo_initialize();
#endif
newgc->mark_table = ofm_malloc_zero(NUMBER_OF_TAGS * sizeof (Mark_Proc));
newgc->fixup_table = ofm_malloc_zero(NUMBER_OF_TAGS * sizeof (Fixup_Proc));
newgc->mark_table = ofm_malloc_zero(NUMBER_OF_TAGS * sizeof (Mark2_Proc));
newgc->fixup_table = ofm_malloc_zero(NUMBER_OF_TAGS * sizeof (Fixup2_Proc));
#ifdef NEWGC_BTC_ACCOUNT
BTC_initialize_mark_table(newgc);
#endif
@ -2053,9 +2069,9 @@ static NewGC *init_type_tags_worker(NewGC *parentgc, int count, int pair, int mu
resize_gen0(gc, GEN0_INITIAL_SIZE);
if (!parentgc) {
GC_register_traversers(gc->weak_box_tag, size_weak_box, mark_weak_box, fixup_weak_box, 0, 0);
GC_register_traversers(gc->ephemeron_tag, size_ephemeron, mark_ephemeron, fixup_ephemeron, 0, 0);
GC_register_traversers(gc->weak_array_tag, size_weak_array, mark_weak_array, fixup_weak_array, 0, 0);
GC_register_traversers2(gc->weak_box_tag, size_weak_box, mark_weak_box, fixup_weak_box, 0, 0);
GC_register_traversers2(gc->ephemeron_tag, size_ephemeron, mark_ephemeron, fixup_ephemeron, 0, 0);
GC_register_traversers2(gc->weak_array_tag, size_weak_array, mark_weak_array, fixup_weak_array, 0, 0);
}
initialize_signal_handler(gc);
GC_add_roots(&gc->park, (char *)&gc->park + sizeof(gc->park) + 1);
@ -2163,8 +2179,8 @@ void GC_gcollect(void)
}
static inline int atomic_mark(void *p) { return 0; }
void GC_register_traversers(short tag, Size_Proc size, Mark_Proc mark,
Fixup_Proc fixup, int constant_Size, int atomic)
void GC_register_traversers2(short tag, Size2_Proc size, Mark2_Proc mark,
Fixup2_Proc fixup, int constant_Size, int atomic)
{
NewGC *gc = GC_get_GC();
@ -2179,10 +2195,17 @@ void GC_register_traversers(short tag, Size_Proc size, Mark_Proc mark,
atomic = 0;
#endif
gc->mark_table[mark_tag] = atomic ? (Mark_Proc)PAGE_ATOMIC : mark;
gc->mark_table[mark_tag] = atomic ? (Mark2_Proc)PAGE_ATOMIC : mark;
gc->fixup_table[tag] = fixup;
}
void GC_register_traversers(short tag, Size_Proc size, Mark_Proc mark,
Fixup_Proc fixup, int constant_Size, int atomic)
{
GC_register_traversers2(tag, (Size2_Proc)size, (Mark2_Proc)mark,
(Fixup2_Proc)fixup, constant_Size, atomic);
}
long GC_get_memory_use(void *o)
{
NewGC *gc = GC_get_GC();
@ -2203,18 +2226,16 @@ long GC_get_memory_use(void *o)
we use internally, and it doesn't do nearly as much. */
/* This is the first mark routine. It's a bit complicated. */
void GC_mark(const void *const_p)
void GC_mark2(const void *const_p, struct NewGC *gc)
{
mpage *page;
void *p = (void*)const_p;
NewGC *gc;
if(!p || (NUM(p) & 0x1)) {
GCDEBUG((DEBUGOUTF, "Not marking %p (bad ptr)\n", p));
return;
}
gc = GC_get_GC();
if(!(page = pagemap_find_page(gc->page_maps, p))) {
#ifdef MZ_USE_PLACES
if (!MASTERGC || !MASTERGC->major_places_gc || !(page = pagemap_find_page(MASTERGC->page_maps, p)))
@ -2405,9 +2426,14 @@ void GC_mark(const void *const_p)
}
}
void GC_mark(const void *const_p)
{
GC_mark2(const_p, GC_get_GC());
}
/* this is the second mark routine. It's not quite as complicated. */
/* this is what actually does mark propagation */
static inline void propagate_marks_worker(PageMap pagemap, Mark_Proc *mark_table, void *pp)
static inline void propagate_marks_worker(NewGC *gc, Mark2_Proc *mark_table, void *pp)
{
void **start, **end;
int alloc_type;
@ -2418,7 +2444,7 @@ static inline void propagate_marks_worker(PageMap pagemap, Mark_Proc *mark_table
if (IS_BIG_PAGE_PTR(pp)) {
mpage *page;
p = REMOVE_BIG_PAGE_PTR_TAG(pp);
page = pagemap_find_page(pagemap, p);
page = pagemap_find_page(gc->page_maps, p);
#ifdef MZ_USE_PLACES
if (!page && MASTERGC && MASTERGC->major_places_gc) {
page = pagemap_find_page(MASTERGC->page_maps, p);
@ -2442,12 +2468,12 @@ static inline void propagate_marks_worker(PageMap pagemap, Mark_Proc *mark_table
case PAGE_TAGGED:
{
const unsigned short tag = *(unsigned short*)start;
Mark_Proc markproc;
Mark2_Proc markproc;
ASSERT_TAG(tag);
markproc = mark_table[tag];
if(((unsigned long) markproc) >= PAGE_TYPES) {
GC_ASSERT(markproc);
markproc(start);
markproc(start, gc);
}
break;
}
@ -2455,7 +2481,7 @@ static inline void propagate_marks_worker(PageMap pagemap, Mark_Proc *mark_table
break;
case PAGE_ARRAY:
{
while(start < end) gcMARK(*start++); break;
while(start < end) gcMARK2(*start++, gc); break;
}
case PAGE_TARRAY:
{
@ -2464,7 +2490,7 @@ static inline void propagate_marks_worker(PageMap pagemap, Mark_Proc *mark_table
end -= INSET_WORDS;
while(start < end) {
GC_ASSERT(mark_table[tag]);
start += mark_table[tag](start);
start += mark_table[tag](start, gc);
}
break;
}
@ -2476,12 +2502,11 @@ static inline void propagate_marks_worker(PageMap pagemap, Mark_Proc *mark_table
static void propagate_marks(NewGC *gc)
{
void *p;
PageMap pagemap = gc->page_maps;
Mark_Proc *mark_table = gc->mark_table;
Mark2_Proc *mark_table = gc->mark_table;
while(pop_ptr(gc, &p)) {
GCDEBUG((DEBUGOUTF, "Popped pointer %p\n", p));
propagate_marks_worker(pagemap, mark_table, p);
propagate_marks_worker(gc, mark_table, p);
}
}
@ -2506,16 +2531,14 @@ void *GC_fixup_self(void *p)
return p;
}
void GC_fixup(void *pp)
void GC_fixup2(void *pp, struct NewGC *gc)
{
NewGC *gc;
mpage *page;
void *p = *(void**)pp;
if(!p || (NUM(p) & 0x1))
return;
gc = GC_get_GC();
if((page = pagemap_find_page(gc->page_maps, p))) {
objhead *info;
@ -2527,6 +2550,11 @@ void GC_fixup(void *pp)
} else GCDEBUG((DEBUGOUTF, "Not repairing %p from %p (no page)\n", p, pp));
}
void GC_fixup(void *pp)
{
GC_fixup2(pp, GC_get_GC());
}
/*****************************************************************************/
/* memory stats and traces */
/*****************************************************************************/
@ -3075,7 +3103,7 @@ static void repair_heap(NewGC *gc)
{
mpage *page;
int i;
Fixup_Proc *fixup_table = gc->fixup_table;
Fixup2_Proc *fixup_table = gc->fixup_table;
#ifdef MZ_USE_PLACES
int master_has_switched = postmaster_and_master_gc(gc);
#endif
@ -3105,11 +3133,11 @@ static void repair_heap(NewGC *gc)
page->size_class = 2; /* remove the mark */
switch(page->page_type) {
case PAGE_TAGGED:
fixup_table[*(unsigned short*)start](start);
fixup_table[*(unsigned short*)start](start, gc);
break;
case PAGE_ATOMIC: break;
case PAGE_ARRAY:
while(start < end) gcFIXUP(*(start++));
while(start < end) gcFIXUP2(*(start++), gc);
break;
case PAGE_XTAGGED:
GC_fixup_xtagged(start);
@ -3118,7 +3146,7 @@ static void repair_heap(NewGC *gc)
unsigned short tag = *(unsigned short *)start;
ASSERT_TAG(tag);
end -= INSET_WORDS;
while(start < end) start += fixup_table[tag](start);
while(start < end) start += fixup_table[tag](start, gc);
break;
}
}
@ -3141,7 +3169,7 @@ static void repair_heap(NewGC *gc)
unsigned short tag = *(unsigned short *)obj_start;
ASSERT_TAG(tag);
info->mark = 0;
fixup_table[tag](obj_start);
fixup_table[tag](obj_start, gc);
} else {
info->dead = 1;
}
@ -3164,7 +3192,7 @@ static void repair_heap(NewGC *gc)
if(info->mark) {
void **tempend = PPTR(info) + info->size;
start = OBJHEAD_TO_OBJPTR(start);
while(start < tempend) gcFIXUP(*start++);
while(start < tempend) gcFIXUP2(*start++, gc);
info->mark = 0;
} else {
info->dead = 1;
@ -3183,7 +3211,7 @@ static void repair_heap(NewGC *gc)
tag = *(unsigned short*)start;
ASSERT_TAG(tag);
while(start < tempend)
start += fixup_table[tag](start);
start += fixup_table[tag](start, gc);
info->mark = 0;
start = PPTR(info) + size;
} else {
@ -3226,7 +3254,7 @@ static void repair_heap(NewGC *gc)
{
void **tempend = PPTR(info) + info->size;
start = OBJHEAD_TO_OBJPTR(start);
while(start < tempend) gcFIXUP(*start++);
while(start < tempend) gcFIXUP2(*start++, gc);
}
break;
case PAGE_TAGGED:
@ -3234,7 +3262,7 @@ static void repair_heap(NewGC *gc)
void *obj_start = OBJHEAD_TO_OBJPTR(start);
unsigned short tag = *(unsigned short *)obj_start;
ASSERT_TAG(tag);
fixup_table[tag](obj_start);
fixup_table[tag](obj_start, gc);
start += info->size;
}
break;
@ -3763,7 +3791,7 @@ static void dump_stack_pos(void *a)
}
# define GC_X_variable_stack GC_do_dump_variable_stack
# define gcX(a) dump_stack_pos(a)
# define gcX2(a, gc) dump_stack_pos(a)
# define X_source(stk, p) /* */
# include "var_stack.c"
# undef GC_X_variable_stack

4
src/mzscheme/gc2/newgc.h
View File

@ -105,8 +105,8 @@ typedef mpage **PageMap;
typedef struct NewGC {
Gen0 gen0;
Mark_Proc *mark_table; /* the table of mark procs */
Fixup_Proc *fixup_table; /* the table of repair procs */
Mark2_Proc *mark_table; /* the table of mark procs */
Fixup2_Proc *fixup_table; /* the table of repair procs */
PageMap page_maps;
/* All non-gen0 pages are held in the following structure. */
struct mpage *gen1_pages[PAGE_TYPES];

10
src/mzscheme/gc2/var_stack.c
View File

@ -1,5 +1,5 @@
void GC_X_variable_stack(void **var_stack, long delta, void *limit, void *stack_mem)
void GC_X_variable_stack(void **var_stack, long delta, void *limit, void *stack_mem, struct NewGC *gc)
{
long size, count;
void ***p, **a;
@ -36,7 +36,7 @@ void GC_X_variable_stack(void **var_stack, long delta, void *limit, void *stack_
if (SHALLOWER_STACK_ADDRESS(a, limit)) {
while (count--) {
X_source(stack_mem, a);
gcX(a);
gcX2(a, gc);
a++;
}
}
@ -44,7 +44,7 @@ void GC_X_variable_stack(void **var_stack, long delta, void *limit, void *stack_
a = (void **)((char *)a + delta);
if (SHALLOWER_STACK_ADDRESS(a, limit)) {
X_source(stack_mem, a);
gcX(a);
gcX2(a, gc);
}
}
p++;
@ -64,13 +64,13 @@ void GC_X_variable_stack(void **var_stack, long delta, void *limit, void *stack_
a = (void **)((char *)a + delta);
while (count--) {
X_source(stack_mem, a);
gcX(a);
gcX2(a, gc);
a++;
}
} else {
a = (void **)((char *)a + delta);
X_source(stack_mem, a);
gcX(a);
gcX2(a, gc);
}
p++;
}

48
src/mzscheme/gc2/weak.c
View File

@ -25,7 +25,7 @@
/* weak arrays */
/******************************************************************************/
static int size_weak_array(void *p)
static int size_weak_array(void *p, struct NewGC *gc)
{
GC_Weak_Array *a = (GC_Weak_Array *)p;
@ -33,12 +33,11 @@ static int size_weak_array(void *p)
+ ((a->count - 1) * sizeof(void *)));
}
static int mark_weak_array(void *p)
static int mark_weak_array(void *p, struct NewGC *gc)
{
GCTYPE *gc = GC_get_GC();
GC_Weak_Array *a = (GC_Weak_Array *)p;
gcMARK(a->replace_val);
gcMARK2(a->replace_val, gc);
a->next = gc->weak_arrays;
gc->weak_arrays = a;
@ -64,18 +63,18 @@ static int mark_weak_array(void *p)
+ ((a->count - 1) * sizeof(void *)));
}
static int fixup_weak_array(void *p)
static int fixup_weak_array(void *p, struct NewGC *gc)
{
GC_Weak_Array *a = (GC_Weak_Array *)p;
int i;
void **data;
gcFIXUP(a->replace_val);
gcFIXUP2(a->replace_val, gc);
data = a->data;
for (i = a->count; i--; ) {
if (data[i])
gcFIXUP(data[i]);
gcFIXUP2(data[i], gc);
}
return gcBYTES_TO_WORDS(sizeof(GC_Weak_Array)
@ -132,17 +131,16 @@ static void zero_weak_arrays(GCTYPE *gc)
/* weak boxes */
/******************************************************************************/
static int size_weak_box(void *p)
static int size_weak_box(void *p, struct NewGC *gc)
{
return gcBYTES_TO_WORDS(sizeof(GC_Weak_Box));
}
static int mark_weak_box(void *p)
static int mark_weak_box(void *p, struct NewGC *gc)
{
GCTYPE *gc = GC_get_GC();
GC_Weak_Box *wb = (GC_Weak_Box *)p;
gcMARK(wb->secondary_erase);
gcMARK2(wb->secondary_erase, gc);
if (wb->val) {
wb->next = gc->weak_boxes;
@ -152,12 +150,12 @@ static int mark_weak_box(void *p)
return gcBYTES_TO_WORDS(sizeof(GC_Weak_Box));
}
static int fixup_weak_box(void *p)
static int fixup_weak_box(void *p, struct NewGC *gc)
{
GC_Weak_Box *wb = (GC_Weak_Box *)p;
gcFIXUP(wb->secondary_erase);
gcFIXUP(wb->val);
gcFIXUP2(wb->secondary_erase, gc);
gcFIXUP2(wb->val, gc);
return gcBYTES_TO_WORDS(sizeof(GC_Weak_Box));
}
@ -213,14 +211,13 @@ static void zero_weak_boxes(GCTYPE *gc)
/* ephemeron */
/******************************************************************************/
static int size_ephemeron(void *p)
static int size_ephemeron(void *p, struct NewGC *gc)
{
return gcBYTES_TO_WORDS(sizeof(GC_Ephemeron));
}
static int mark_ephemeron(void *p)
static int mark_ephemeron(void *p, struct NewGC *gc)
{
GCTYPE *gc = GC_get_GC();
GC_Ephemeron *eph = (GC_Ephemeron *)p;
if (eph->val) {
@ -232,29 +229,28 @@ static int mark_ephemeron(void *p)
}
#ifdef NEWGC_BTC_ACCOUNT
static int BTC_ephemeron_mark(void *p)
static int BTC_ephemeron_mark(void *p, struct NewGC *gc)
{
GCTYPE *gc = GC_get_GC();
if (gc->doing_memory_accounting) {
GC_Ephemeron *eph = (GC_Ephemeron *)p;
gcMARK(eph->key);
gcMARK(eph->val);
gcMARK2(eph->key, gc);
gcMARK2(eph->val, gc);
return gcBYTES_TO_WORDS(sizeof(GC_Ephemeron));
}
return mark_ephemeron(p);
return mark_ephemeron(p, gc);
}
#endif
static int fixup_ephemeron(void *p)
static int fixup_ephemeron(void *p, struct NewGC *gc)
{
GC_Ephemeron *eph = (GC_Ephemeron *)p;
gcFIXUP(eph->key);
gcFIXUP(eph->val);
gcFIXUP2(eph->key, gc);
gcFIXUP2(eph->val, gc);
return gcBYTES_TO_WORDS(sizeof(GC_Ephemeron));
}
@ -294,7 +290,7 @@ static void mark_ready_ephemerons(GCTYPE *gc)
for (eph = gc->ephemerons; eph; eph = next) {
next = eph->next;
if (is_marked(gc, eph->key)) {
gcMARK(eph->val);
gcMARK2(eph->val, gc);
gc->num_last_seen_ephemerons++;
} else {
eph->next = waiting;

4
src/mzscheme/include/schthread.h
View File

@ -303,9 +303,9 @@ static inline Thread_Local_Variables *scheme_get_thread_local_variables() {
Thread_Local_Variables *x = NULL;
# if defined(OS_X)
# if defined(__x86_64__)
asm volatile("movq %%gs:0x8E0, %0" : "=r"(x));
asm volatile("movq %%gs:0x60(,%1,8), %0" : "=r"(x) : "r"(scheme_thread_local_key));
# else
asm volatile("movl %%gs:0x488, %0" : "=r"(x));
asm volatile("movl %%gs:0x48(,%1,4), %0" : "=r"(x) : "r"(scheme_thread_local_key));
# endif
# elif defined(linux) && defined(MZ_USES_SHARED_LIB)
# if defined(__x86_64__)

24
src/mzscheme/src/fun.c
View File

@ -2898,21 +2898,28 @@ Scheme_Object *scheme_make_arity(mzshort mina, mzshort maxa)
}
}
static Scheme_Object *clone_arity(Scheme_Object *a)
static Scheme_Object *clone_arity(Scheme_Object *a, int delta)
{
if (SCHEME_PAIRP(a)) {
Scheme_Object *m, *l;
m = scheme_copy_list(a);
for (l = m; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) {
a = clone_arity(SCHEME_CAR(l));
a = clone_arity(SCHEME_CAR(l), delta);
SCHEME_CAR(l) = a;
}
return m;
} else if (SCHEME_CHAPERONE_STRUCTP(a)) {
Scheme_Object *p[1];
p[0] = scheme_struct_ref(a, 0);
a = scheme_struct_ref(a, 0);
if (delta)
a = scheme_bin_minus(a, scheme_make_integer(delta));
p[0] = a;
return scheme_make_struct_instance(scheme_arity_at_least, 1, p);
} else
} else if (SCHEME_NULLP(a))
return a;
else if (delta)
return scheme_bin_minus(a, scheme_make_integer(delta));
else
return a;
}
@ -2996,10 +3003,13 @@ static Scheme_Object *get_or_check_arity(Scheme_Object *p, long a, Scheme_Object
int is_method;
if (scheme_reduced_procedure_struct
&& scheme_is_struct_instance(scheme_reduced_procedure_struct, p)) {
if (a >= 0)
if (a >= 0) {
bign = scheme_make_integer(a);
if (drop)
bign = scheme_bin_plus(bign, scheme_make_integer(a));
}
if (a == -1)
return clone_arity(((Scheme_Structure *)p)->slots[1]);
return clone_arity(((Scheme_Structure *)p)->slots[1], drop);
else {
/* Check arity (or for varargs) */
Scheme_Object *v;
@ -3836,7 +3846,7 @@ static Scheme_Object *procedure_reduce_arity(int argc, Scheme_Object *argv[])
lists that include arity-at-least records. */
orig = get_or_check_arity(argv[0], -1, NULL);
aty = clone_arity(argv[1]);
aty = clone_arity(argv[1], 0);
if (!is_subarity(aty, orig)) {
scheme_raise_exn(MZEXN_FAIL_CONTRACT,

15
src/mzscheme/src/jit.c
View File

@ -11351,7 +11351,8 @@ static int do_generate_common(mz_jit_state *jitter, void *_data)
for (i = 0; i < 4; i++) {
void *code;
int kind, for_branch;
jit_insn *ref, *ref2, *refslow, *bref1, *bref2, *bref3, *bref4, *bref5, *bref6, *bref8;
GC_CAN_IGNORE jit_insn *ref, *ref2, *ref3, *refslow, *bref1, *bref2, *refretry;
GC_CAN_IGNORE jit_insn *bref3, *bref4, *bref5, *bref6, *bref8, *ref9;
if ((ii == 1) && (i == 1)) continue; /* no multi variant of pred branch */
@ -11448,11 +11449,21 @@ static int do_generate_common(mz_jit_state *jitter, void *_data)
/* Check argument: */
if (kind == 1) {
bref1 = jit_bmsi_ul(jit_forward(), JIT_R1, 0x1);
refretry = _jit.x.pc;
jit_ldxi_s(JIT_R2, JIT_R1, &((Scheme_Object *)0x0)->type);
__START_INNER_TINY__(1);
ref2 = jit_beqi_i(jit_forward(), JIT_R2, scheme_structure_type);
ref3 = jit_beqi_i(jit_forward(), JIT_R2, scheme_proc_struct_type);
ref9 = jit_beqi_i(jit_forward(), JIT_R2, scheme_chaperone_type);
__END_INNER_TINY__(1);
bref2 = jit_bnei_i(jit_forward(), JIT_R2, scheme_proc_chaperone_type);
CHECK_LIMIT();
__START_INNER_TINY__(1);
mz_patch_branch(ref9);
jit_ldxi_p(JIT_R1, JIT_R1, &SCHEME_CHAPERONE_VAL(0x0));
(void)jit_jmpi(refretry);
mz_patch_branch(ref3);
__END_INNER_TINY__(1);
bref2 = jit_bnei_i(jit_forward(), JIT_R2, scheme_proc_struct_type);
} else {
(void)jit_bmsi_ul(refslow, JIT_R1, 0x1);
jit_ldxi_s(JIT_R2, JIT_R1, &((Scheme_Object *)0x0)->type);

10
src/mzscheme/src/mkmark.ss
View File

@ -48,28 +48,28 @@
(read-lines re:size))
null)]
[size (read-lines re:close)])
(printf "static int ~a_SIZE(void *p) {~n" name)
(printf "static int ~a_SIZE(void *p, struct NewGC *gc) {~n" name)
(print-lines prefix)
(printf " return~n")
(print-lines size)
(printf "}~n~n")
(printf "static int ~a_MARK(void *p) {~n" name)
(printf "static int ~a_MARK(void *p, struct NewGC *gc) {~n" name)
(print-lines prefix)
(print-lines (map (lambda (s)
(regexp-replace*
"FIXUP_ONLY[(]([^;]*;)[)]"
(regexp-replace*
"FIXUP_TYPED_NOW[(][^,]*,"
"FIXUP2_TYPED_NOW[(][^,]*,"
s
"MARK(")
"MARK2(")
""))
mark))
(printf " return~n")
(print-lines size)
(printf "}~n~n")
(printf "static int ~a_FIXUP(void *p) {~n" name)
(printf "static int ~a_FIXUP(void *p, struct NewGC *gc) {~n" name)
(print-lines prefix)
(print-lines (map (lambda (s)
(regexp-replace*

3562
src/mzscheme/src/mzmark.c
View File

File diff suppressed because it is too large Load Diff

1302
src/mzscheme/src/mzmarksrc.c
View File

File diff suppressed because it is too large Load Diff

50
src/mzscheme/src/salloc.c
View File

@ -210,7 +210,8 @@ void scheme_set_thread_local_variables(Thread_Local_Variables *tlvs) XFORM_SKIP_
}
#endif
#if defined(IMPLEMENT_THREAD_LOCAL_VIA_PTHREADS) && defined(INLINE_GETSPECIFIC_ASSEMBLY_CODE)
#if 0 && defined(IMPLEMENT_THREAD_LOCAL_VIA_PTHREADS) && defined(INLINE_GETSPECIFIC_ASSEMBLY_CODE)
/* This code is dsiabled */
static void macosx_get_thread_local_key_for_assembly_code() XFORM_SKIP_PROC
{
/* Our [highly questionable] strategy for inlining pthread_getspecific() is taken from
@ -265,44 +266,21 @@ Thread_Local_Variables *scheme_external_get_thread_local_variables() XFORM_SKIP_
void scheme_setup_thread_local_key_if_needed() XFORM_SKIP_PROC
{
#ifdef IMPLEMENT_THREAD_LOCAL_VIA_PTHREADS
# ifdef INLINE_GETSPECIFIC_ASSEMBLY_CODE
# if defined(linux)
scheme_thread_local_key = 0;
if (pthread_key_create(&scheme_thread_local_key, NULL)) {
fprintf(stderr, "pthread key create failed\n");
abort();
}
/*
if (scheme_thread_local_key != 0) {
fprintf(stderr, "pthread getspecific inline hack failed scheme_thread_local_key %i\n", scheme_thread_local_key);
abort();
}
*/
pthread_setspecific(scheme_thread_local_key, (void *)0xaced);
if (scheme_get_thread_local_variables() != (Thread_Local_Variables *)0xaced) {
fprintf(stderr, "pthread getspecific inline hack failed to return set data\n");
abort();
}
# else
macosx_get_thread_local_key_for_assembly_code();
# endif
# else
if (pthread_key_create(&scheme_thread_local_key, NULL)) {
fprintf(stderr, "pthread key create failed\n");
abort();
}
# endif
scheme_thread_local_key = 0;
if (pthread_key_create(&scheme_thread_local_key, NULL)) {
fprintf(stderr, "pthread key create failed\n");
abort();
}
#endif
#ifdef IMPLEMENT_THREAD_LOCAL_VIA_WIN_TLS
{
void **base;
{
void **base;
__asm { mov ecx, FS:[0x2C]
mov base, ecx }
scheme_tls_delta -= (unsigned long)base[scheme_tls_index];
scheme_tls_index *= sizeof(void*);
}
__asm { mov ecx, FS:[0x2C]
mov base, ecx }
scheme_tls_delta -= (unsigned long)base[scheme_tls_index];
scheme_tls_index *= sizeof(void*);
}
#endif
}

60
src/mzscheme/src/type.c
View File

@ -400,19 +400,19 @@ int scheme_num_types(void)
START_XFORM_SKIP;
static int bad_trav_SIZE(void *p)
static int bad_trav_SIZE(void *p, struct NewGC *gc)
{
printf("Shouldn't get here.\n");
exit(1);
}
static int bad_trav_MARK(void *p)
static int bad_trav_MARK(void *p, struct NewGC *gc)
{
printf("Shouldn't get here.\n");
exit(1);
}
static int bad_trav_FIXUP(void *p)
static int bad_trav_FIXUP(void *p, struct NewGC *gc)
{
printf("Shouldn't get here.\n");
exit(1);
@ -421,59 +421,61 @@ static int bad_trav_FIXUP(void *p)
#define bad_trav_IS_CONST_SIZE 0
#define bad_trav_IS_ATOMIC 0
static void MARK_cjs(Scheme_Continuation_Jump_State *cjs)
static void MARK_cjs(Scheme_Continuation_Jump_State *cjs, struct NewGC *gc)
{
gcMARK(cjs->jumping_to_continuation);
gcMARK(cjs->val);
gcMARK2(cjs->jumping_to_continuation, gc);
gcMARK2(cjs->val, gc);
}
static void FIXUP_cjs(Scheme_Continuation_Jump_State *cjs)
static void FIXUP_cjs(Scheme_Continuation_Jump_State *cjs, struct NewGC *gc)
{
gcFIXUP(cjs->jumping_to_continuation);
gcFIXUP(cjs->val);
gcFIXUP2(cjs->jumping_to_continuation, gc);
gcFIXUP2(cjs->val, gc);
}
static void MARK_stack_state(Scheme_Stack_State *ss)
static void MARK_stack_state(Scheme_Stack_State *ss, struct NewGC *gc)
{
}
static void FIXUP_stack_state(Scheme_Stack_State *ss)
static void FIXUP_stack_state(Scheme_Stack_State *ss, struct NewGC *gc)
{
}
static void MARK_jmpup(Scheme_Jumpup_Buf *buf)
static void MARK_jmpup(Scheme_Jumpup_Buf *buf, struct NewGC *gc)
{
gcMARK(buf->stack_copy);
gcMARK(buf->cont);
gcMARK(buf->external_stack);
gcMARK2(buf->stack_copy, gc);
gcMARK2(buf->cont, gc);
gcMARK2(buf->external_stack, gc);
/* IMPORTANT: the buf->stack_copy pointer must be the only instance
of this stack to be traversed. If you copy a jmpup buffer (as in
fun.c), don't let a GC happen until the old copy is zeroed
out. */
if (buf->stack_copy)
GC_mark_variable_stack(buf->gc_var_stack,
(long)buf->stack_copy - (long)buf->stack_from,
/* FIXME: stack direction */
(char *)buf->stack_copy + buf->stack_size,
buf->stack_copy);
GC_mark2_variable_stack(buf->gc_var_stack,
(long)buf->stack_copy - (long)buf->stack_from,
/* FIXME: stack direction */
(char *)buf->stack_copy + buf->stack_size,
buf->stack_copy,
gc);
}
static void FIXUP_jmpup(Scheme_Jumpup_Buf *buf)
static void FIXUP_jmpup(Scheme_Jumpup_Buf *buf, struct NewGC *gc)
{
void *new_stack;
new_stack = GC_resolve(buf->stack_copy);
gcFIXUP_TYPED_NOW(void *, buf->stack_copy);
gcFIXUP(buf->cont);
gcFIXUP(buf->external_stack);
gcFIXUP2_TYPED_NOW(void *, buf->stack_copy, gc);
gcFIXUP2(buf->cont, gc);
gcFIXUP2(buf->external_stack, gc);
if (buf->stack_copy)
GC_fixup_variable_stack(buf->gc_var_stack,
(long)new_stack - (long)buf->stack_from,
/* FIXME: stack direction */
(char *)new_stack + buf->stack_size,
new_stack);
GC_fixup2_variable_stack(buf->gc_var_stack,
(long)new_stack - (long)buf->stack_from,
/* FIXME: stack direction */
(char *)new_stack + buf->stack_size,
new_stack,
gc);
}
#define RUNSTACK_ZERO_VAL NULL