diff --git a/collects/tests/racket/contmark.rktl b/collects/tests/racket/contmark.rktl index 57530332ad..77f072caaa 100644 --- a/collects/tests/racket/contmark.rktl +++ b/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) diff --git a/src/racket/src/jit.c b/src/racket/src/jit.c index 34fefcefb0..3183380145 100644 --- a/src/racket/src/jit.c +++ b/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