another context-cache repair

collects/tests/racket/contmark.rktl

@@ -719,4 +719,80 @@
 
 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
+;; Check that `(current-continuation-marks)' captures
+;; consistent context information --- essentially checking
+;; that an internal cache isn't broken
+
+(sync (thread void)) ; tends to flush the cache
+(let ()
+  (define (go)
+    (f (+ 200 (random 1000))))
+
+  (define (f x)
+    (cond
+     [(zero? x)
+      (let ([m1 (current-continuation-marks)]
+            [m2 (current-continuation-marks)]
+            [m3 (current-continuation-marks)]
+            [m4 (current-continuation-marks)]
+            [m5 (current-continuation-marks)])
+        (and (same? m1 m2)
+             (same? m2 m3)
+             (same? m3 m4)
+             (same? m4 m5)))]
+     [else
+      (case (random 7)
+        [(0) (values (f (- x 1)))]
+        [(1) (f (- x 1))]
+        [(2) (values (g (- x 1)))]
+        [(3) (g (- x 1))]
+        [(4) (h (- x 1))]
+        [(5) (i (- x 1))]
+        [(6) (j (- x 1))])]))
+
+  ;; no-name(?)
+  (define g
+    (let ([a-fun (λ (x) x)])
+      (set! a-fun (λ (y) y))
+      (a-fun
+       (λ (x) (f x)))))
+
+  (define q 0)
+  (define (h x)
+    (let ([x 1])
+      (set! x (+ x q))
+      (set! q x)
+      (values (f (- x 1)))))
+
+  (define (i x)
+    (let ([x 1]
+          [y 2])
+      (set! x (+ y x))
+      (set! y (+ x y))
+      (set! q (+ x y))
+      (values (f (- x 1)))))
+
+  (define (j x)
+    (let ([x 1]
+          [y 2]
+          [z 3]
+          [w 4])
+      (set! x (+ y z))
+      (set! y (+ w x))
+      (set! z (+ z z))
+      (set! w (+ w 1))
+      (set! q (+ x y z w))
+      (values (f (- x 1)))))
+
+  (define (same? m1 m2)
+    (equal? (continuation-mark-set->context m1)
+            (continuation-mark-set->context m2)))
+
+  (let ([s (random 10000)])
+    (random-seed s)
+    (test (list s #t)
+          list s (for/and ([i (in-range 100)]) (go)))))
+
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
 (report-errs)

src/racket/src/jit.c

@@ -14557,6 +14557,8 @@ Scheme_Object *scheme_native_stack_trace(void)
   Get_Stack_Proc gs;
 #endif
   int use_unw = 0;
+  int shift_cache_to_next = 0;
+  int added_list_elem;
 
   if (!get_stack_pointer_code)
     return NULL;
@@ -14688,7 +14690,13 @@ Scheme_Object *scheme_native_stack_trace(void)
       else
 	first = name;
       last = name;
-    }
+      if (shift_cache_to_next) {
+        stack_cache_stack[stack_cache_stack_pos].cache = last;
+        shift_cache_to_next = 0;
+      }
+      added_list_elem = 1;
+    } else 
+      added_list_elem = 0;
 
     /* Cache the result halfway up the stack, if possible. Only cache
        on frames where the previous frame had a return address with a
@@ -14713,6 +14721,8 @@ Scheme_Object *scheme_native_stack_trace(void)
       stack_cache_stack[pos].stack_frame = (void *)(((void **)p) + RETURN_ADDRESS_OFFSET);
       stack_cache_stack[pos].cache = last;
       ((void **)p)[RETURN_ADDRESS_OFFSET] = stack_cache_pop_code;
+      if (!added_list_elem)
+        shift_cache_to_next = 1;
 
       halfway = stack_end;
     }
@@ -14751,6 +14761,9 @@ Scheme_Object *scheme_native_stack_trace(void)
     }
   }
 
+  if (shift_cache_to_next)
+    stack_cache_stack[stack_cache_stack_pos].cache = scheme_null;
+
 #ifdef MZ_USE_DWARF_LIBUNWIND
   unw_destroy_local(&c);
 #endif