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

svn: r18661

collects/scheme/private/kw.ss

@@ -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))
+                   (if (null? kws)
-                        (loop (cdr kws) (cdr req-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)
+    (let ([plain-proc (procedure-reduce-arity (if (okp? proc) 
-                                                  (okp-ref proc 0) 
+                                                  (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])
+      (if (null? allowed-kw)
-                         (cond
+          plain-proc
-                          [(integer? a) (+ a 2)]
+          (let* ([inc-arity (lambda (arity delta)
-                          [(arity-at-least? a)
+                              (let loop ([a arity])
-                           (make-arity-at-least (+ (arity-at-least-value a) 2))]
+                                (cond
-                          [else
+                                 [(integer? a) (+ a delta)]
-                           (map loop a)]))])
+                                 [(arity-at-least? a)
-        (make-optional-keyword-procedure
+                                  (make-arity-at-least (+ (arity-at-least-value a) delta))]
-         (make-keyword-checker req-kw allowed-kw new-arity)
+                                 [else
-         (procedure-reduce-arity (keyword-procedure-proc proc)
+                                  (map loop a)])))]
-                                 new-arity)
+                 [new-arity (inc-arity arity 2)]
-         req-kw
+                 [kw-checker (make-keyword-checker req-kw allowed-kw new-arity)]
-         allowed-kw
+                 [new-kw-proc (procedure-reduce-arity (keyword-procedure-proc proc)
-         plain-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)))

collects/scheme/private/pre-base.ss

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

collects/tests/mzscheme/chaperone.ss

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

collects/tests/mzscheme/procs.ss

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

doc/release-notes/mzscheme/HISTORY.txt

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

src/mzscheme/gc2/Makefile.in

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

src/mzscheme/gc2/gc2.h

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

src/mzscheme/gc2/mem_account.c

@@ -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;
+  Mark2_Proc *mark_table = gc->mark_table;
-  Mark_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);

src/mzscheme/gc2/newgc.c

@@ -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 GC_X_variable_stack GC_mark2_variable_stack
-#define gcX(a) gcMARK(*a)
+#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 GC_X_variable_stack GC_fixup2_variable_stack
-#define gcX(a) gcFIXUP(*a)
+#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);
+    gcMARK2(fnl->data, gc);
-    gcMARK(fnl->p);
+    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);
+    gcFIXUP2(fnl->data, gc);
-    gcFIXUP(fnl->p);
+    gcFIXUP2(fnl->p, gc);
-    gcFIXUP(fnl->next);
+    gcFIXUP2(fnl->next, gc);
   }
   for(fnl = gc->run_queue; fnl; fnl = fnl->next) {
-    gcFIXUP(fnl->data);
+    gcFIXUP2(fnl->data, gc);
-    gcFIXUP(fnl->p);
+    gcFIXUP2(fnl->p, gc);
-    gcFIXUP(fnl->next);
+    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->mark_table  = ofm_malloc_zero(NUMBER_OF_TAGS * sizeof (Mark2_Proc)); 
-    newgc->fixup_table = ofm_malloc_zero(NUMBER_OF_TAGS * sizeof (Fixup_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_traversers2(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_traversers2(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_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,
+void GC_register_traversers2(short tag, Size2_Proc size, Mark2_Proc mark,
-                            Fixup_Proc fixup, int constant_Size, int atomic)
+                             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;
+  Mark2_Proc *mark_table = gc->mark_table;
-  Mark_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

src/mzscheme/gc2/newgc.h

@@ -105,8 +105,8 @@ typedef mpage **PageMap;
 
 typedef struct NewGC {
   Gen0 gen0;
-  Mark_Proc  *mark_table;   /* the table of mark procs */
+  Mark2_Proc  *mark_table;   /* the table of mark procs */
-  Fixup_Proc *fixup_table;  /* the table of repair 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];

src/mzscheme/gc2/var_stack.c

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

src/mzscheme/gc2/weak.c

@@ -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);
+  gcFIXUP2(wb->secondary_erase, gc);
-  gcFIXUP(wb->val);
+  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);
+    gcMARK2(eph->key, gc);
-    gcMARK(eph->val);
+    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);
+  gcFIXUP2(eph->key, gc);
-  gcFIXUP(eph->val);
+  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;

src/mzscheme/include/schthread.h

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

src/mzscheme/src/fun.c

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

src/mzscheme/src/jit.c

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

src/mzscheme/src/mkmark.ss

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

src/mzscheme/src/salloc.c

@@ -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
+  scheme_thread_local_key = 0;
-#  if defined(linux)
+  if (pthread_key_create(&scheme_thread_local_key, NULL)) {
-    scheme_thread_local_key = 0;
+    fprintf(stderr, "pthread key create failed\n");
-    if (pthread_key_create(&scheme_thread_local_key, NULL)) {
+    abort();
-      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
 #endif
 #ifdef IMPLEMENT_THREAD_LOCAL_VIA_WIN_TLS
-    {
+  {
-      void **base;
+    void **base;
 
-      __asm { mov ecx, FS:[0x2C]
+    __asm { mov ecx, FS:[0x2C]
-              mov base, ecx }
+            mov base, ecx }
-      scheme_tls_delta -= (unsigned long)base[scheme_tls_index];
+    scheme_tls_delta -= (unsigned long)base[scheme_tls_index];
-      scheme_tls_index *= sizeof(void*);
+    scheme_tls_index *= sizeof(void*);
-      
+  }
-    }
 #endif
 }
 

src/mzscheme/src/type.c

@@ -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);
+  gcMARK2(cjs->jumping_to_continuation, gc);
-  gcMARK(cjs->val);
+  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);
+  gcFIXUP2(cjs->jumping_to_continuation, gc);
-  gcFIXUP(cjs->val);
+  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);
+  gcMARK2(buf->stack_copy, gc);
-  gcMARK(buf->cont);
+  gcMARK2(buf->cont, gc);
-  gcMARK(buf->external_stack);
+  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,
+    GC_mark2_variable_stack(buf->gc_var_stack,
-			   (long)buf->stack_copy - (long)buf->stack_from,
+                            (long)buf->stack_copy - (long)buf->stack_from,
-			   /* FIXME: stack direction */
+                            /* FIXME: stack direction */
-			   (char *)buf->stack_copy + buf->stack_size,
+                            (char *)buf->stack_copy + buf->stack_size,
-                           buf->stack_copy);
+                            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);
+  gcFIXUP2_TYPED_NOW(void *, buf->stack_copy, gc);
-  gcFIXUP(buf->cont);
+  gcFIXUP2(buf->cont, gc);
-  gcFIXUP(buf->external_stack);
+  gcFIXUP2(buf->external_stack, gc);
 
   if (buf->stack_copy)
-    GC_fixup_variable_stack(buf->gc_var_stack,
+    GC_fixup2_variable_stack(buf->gc_var_stack,
-			    (long)new_stack - (long)buf->stack_from,
+                             (long)new_stack - (long)buf->stack_from,
-			    /* FIXME: stack direction */
+                             /* FIXME: stack direction */
-			    (char *)new_stack + buf->stack_size,
+                             (char *)new_stack + buf->stack_size,
-                            new_stack);
+                             new_stack,
+                             gc);
 }
 
 #define RUNSTACK_ZERO_VAL NULL