more memory-accounting repairs, so that sandbox tests now pass

svn: r12861

collects/tests/mzscheme/sandbox.ss

@@ -152,7 +152,7 @@
                    (make-evaluator 'scheme/base
                                    '(define a (for/list ([i (in-range 10)])
                                                 (collect-garbage)
-                                                (make-string 1000))))))
+                                                (make-string 500000))))))
         =err> "out of memory"))
 
    ;; i/o
@@ -488,9 +488,13 @@
         --eval--
         (define a '())
         (define b 1)
-        (for ([i (in-range 20)])
+        (length
+         (for/fold ([v null]) ([i (in-range 20)])
+           ;; Increases size of sandbox:
            (set! a (cons (make-bytes 500000) a))
-          (collect-garbage))
+           (collect-garbage)
+           ;; Increases size of evaluation:
+           (cons (make-bytes 500000) v)))
         =err> "out of memory"
         b => 1))
 

src/mzscheme/gc2/gc2.h

@@ -371,6 +371,13 @@ GC2_EXTERN void GC_fixup_variable_stack(void **var_stack,
    The `stack_mem' argument indicates the start of the allocated memory
    that contains `var_stack'. It is used for backtraces. */
 
+GC2_EXTERN int GC_merely_accounting();
+/*
+   Can be called by a mark or fixup traversal proc to determine whether
+   the traversal is merely for accounting, in which case some marking
+   can be skipped if the corresponding data should be charged to a
+   different object. */
+
 GC2_EXTERN void GC_write_barrier(void *p);
 /* 
    Explicit write barrier to ensure that a write-barrier signal is not

src/mzscheme/gc2/newgc.c

@@ -1404,6 +1404,12 @@ void GC_register_new_thread(void *t, void *c)
 #endif
 }
 
+int GC_merely_accounting()
+{
+  NewGC *gc = GC_get_GC();
+  return gc->doing_memory_accounting;
+}
+
 /*****************************************************************************/
 /* administration / initialization                                           */
 /*****************************************************************************/

src/mzscheme/src/mzmark.c

@@ -923,8 +923,10 @@ static int cont_proc_MARK(void *p) {
   MARK_cjs(&c->cjs);
   MARK_stack_state(&c->ss);
   gcMARK(c->barrier_prompt);
+  if (!GC_merely_accounting()) {
     gcMARK(c->runstack_start);
     gcMARK(c->runstack_saved);
+  }
 
   gcMARK(c->prompt_id);
   gcMARK(c->prompt_buf);
@@ -961,8 +963,10 @@ static int cont_proc_FIXUP(void *p) {
   FIXUP_cjs(&c->cjs);
   FIXUP_stack_state(&c->ss);
   gcFIXUP(c->barrier_prompt);
+  if (!GC_merely_accounting()) {
     gcFIXUP(c->runstack_start);
     gcFIXUP(c->runstack_saved);
+  }
 
   gcFIXUP(c->prompt_id);
   gcFIXUP(c->prompt_buf);
@@ -1600,12 +1604,16 @@ static int thread_val_MARK(void *p) {
   gcMARK(pr->init_config);
   gcMARK(pr->init_break_cell);
 
-  {
+  if (!pr->runstack_owner
+      || !GC_merely_accounting()
+      || (*pr->runstack_owner == pr)) {
     Scheme_Object **rs = pr->runstack_start;
     gcMARK( pr->runstack_start);
+    if (pr->runstack != pr->runstack_start + (pr->runstack - rs))
       pr->runstack = pr->runstack_start + (pr->runstack - rs);
-  }
+
     gcMARK(pr->runstack_saved);
+  }
   gcMARK(pr->runstack_owner);
   gcMARK(pr->runstack_swapped);
   pr->spare_runstack = NULL; /* just in case */
@@ -1706,12 +1714,16 @@ static int thread_val_FIXUP(void *p) {
   gcFIXUP(pr->init_config);
   gcFIXUP(pr->init_break_cell);
 
-  {
+  if (!pr->runstack_owner
+      || !GC_merely_accounting()
+      || (*pr->runstack_owner == pr)) {
     Scheme_Object **rs = pr->runstack_start;
     gcFIXUP_TYPED_NOW(Scheme_Object **, pr->runstack_start);
+    if (pr->runstack != pr->runstack_start + (pr->runstack - rs))
       pr->runstack = pr->runstack_start + (pr->runstack - rs);
-  }
+
     gcFIXUP(pr->runstack_saved);
+  }
   gcFIXUP(pr->runstack_owner);
   gcFIXUP(pr->runstack_swapped);
   pr->spare_runstack = NULL; /* just in case */
@@ -1858,6 +1870,7 @@ static int prompt_val_SIZE(void *p) {
 static int prompt_val_MARK(void *p) {
   Scheme_Prompt *pr = (Scheme_Prompt *)p;
   gcMARK(pr->boundary_overflow_id);
+  if (!GC_merely_accounting())
     gcMARK(pr->runstack_boundary_start);
   gcMARK(pr->tag);
   gcMARK(pr->id);
@@ -1868,6 +1881,7 @@ static int prompt_val_MARK(void *p) {
 static int prompt_val_FIXUP(void *p) {
   Scheme_Prompt *pr = (Scheme_Prompt *)p;
   gcFIXUP(pr->boundary_overflow_id);
+  if (!GC_merely_accounting())
     gcFIXUP(pr->runstack_boundary_start);
   gcFIXUP(pr->tag);
   gcFIXUP(pr->id);

src/mzscheme/src/mzmarksrc.c

@@ -355,8 +355,10 @@ cont_proc {
   MARK_cjs(&c->cjs);
   MARK_stack_state(&c->ss);
   gcMARK(c->barrier_prompt);
+  if (!GC_merely_accounting()) {
     gcMARK(c->runstack_start);
     gcMARK(c->runstack_saved);
+  }
 
   gcMARK(c->prompt_id);
   gcMARK(c->prompt_buf);
@@ -615,12 +617,16 @@ thread_val {
   gcMARK(pr->init_config);
   gcMARK(pr->init_break_cell);
 
-  {
+  if (!pr->runstack_owner
+      || !GC_merely_accounting()
+      || (*pr->runstack_owner == pr)) {
     Scheme_Object **rs = pr->runstack_start;
     gcFIXUP_TYPED_NOW(Scheme_Object **, pr->runstack_start);
+    if (pr->runstack != pr->runstack_start + (pr->runstack - rs))
       pr->runstack = pr->runstack_start + (pr->runstack - rs);
-  }
+
     gcMARK(pr->runstack_saved);
+  }
   gcMARK(pr->runstack_owner);
   gcMARK(pr->runstack_swapped);
   pr->spare_runstack = NULL; /* just in case */
@@ -738,6 +744,7 @@ prompt_val {
  mark: 
   Scheme_Prompt *pr = (Scheme_Prompt *)p;
   gcMARK(pr->boundary_overflow_id);
+  if (!GC_merely_accounting())
     gcMARK(pr->runstack_boundary_start);
   gcMARK(pr->tag);
   gcMARK(pr->id);