From 21f78ecd14b13c5e30b0f8e91d3782e313b56de2 Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Wed, 30 Jul 2014 07:17:08 +0100
Subject: [PATCH] fix problem with `(continuation-marks <thread>)`

A thread can be swapped out while it's in transition between a
mandling of the mark-stack position and recovering from C-stack
overflow. Fix up that case.
---
 .../racket-test/tests/racket/deep.rktl        | 20 +++++++++++++++++++
 racket/src/racket/src/eval.c                  | 15 +++++++++++++-
 racket/src/racket/src/fun.c                   | 14 ++++++++++++-
 3 files changed, 47 insertions(+), 2 deletions(-)

diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/deep.rktl b/pkgs/racket-pkgs/racket-test/tests/racket/deep.rktl
index 2b31343181..e4dde3f582 100644
--- a/pkgs/racket-pkgs/racket-test/tests/racket/deep.rktl
+++ b/pkgs/racket-pkgs/racket-test/tests/racket/deep.rktl
@@ -66,6 +66,26 @@
 			   (k inside))
 			 0)))))
 
+(test 0 'deep-recursion-get-marks
+      (let ()
+        (define (nontail-mark-loop n)
+          (let loop ([n n])
+            (if (zero? n)
+                '(0)
+                (list (car (with-continuation-mark 'x n
+                             (apply list (loop (sub1 n)))))))))
+        (define orig-t (current-thread))
+        (define t (thread
+                   (lambda ()
+                     (let loop ([v #f])
+                       ;; We hope to try to get marks at a place when
+                       ;; the main thread overflows the C stack while
+                       ;; trying to handle a tail call.
+                       (loop (continuation-marks orig-t))))))
+	(nontail-mark-loop proc-depth)
+        (kill-thread t)
+        0))
+
 (define (read-deep depth)
   (define paren-port
     (let* ([depth depth]
diff --git a/racket/src/racket/src/eval.c b/racket/src/racket/src/eval.c
index 3031bce177..bf6a289fed 100644
--- a/racket/src/racket/src/eval.c
+++ b/racket/src/racket/src/eval.c
@@ -1367,6 +1367,12 @@ static Scheme_Object **evacuate_runstack(int num_rands, Scheme_Object **rands, S
     return rands;
 }
 
+static Scheme_Object *do_eval_k_readjust_mark(void)
+{
+  MZ_CONT_MARK_POS -= 2; /* undo increment in do_eval_stack_overflow() */
+  return do_eval_k();
+}
+
 static Scheme_Object *do_eval_stack_overflow(Scheme_Object *obj, int num_rands, Scheme_Object **rands, 
                                              int get_value)
 {
@@ -1390,7 +1396,14 @@ static Scheme_Object *do_eval_stack_overflow(Scheme_Object *obj, int num_rands,
   } else
     p->ku.k.p2 = (void *)rands;
   p->ku.k.i2 = get_value;
-  return scheme_handle_stack_overflow(do_eval_k);
+
+  /* In case we got here via scheme_force_value_same_mark(), in case
+     overflow handling causes the thread to sleep, and in case another
+     thread tries to get this thread's continuation marks: ensure tha
+     the mark pos is not below any current mark. */
+  MZ_CONT_MARK_POS += 2;
+
+  return scheme_handle_stack_overflow(do_eval_k_readjust_mark);
 }
 
 static Scheme_Dynamic_Wind *intersect_dw(Scheme_Dynamic_Wind *a, Scheme_Dynamic_Wind *b, 
diff --git a/racket/src/racket/src/fun.c b/racket/src/racket/src/fun.c
index eb8dc390f9..41337c8efe 100644
--- a/racket/src/racket/src/fun.c
+++ b/racket/src/racket/src/fun.c
@@ -1429,9 +1429,18 @@ Scheme_Object *
 scheme_force_value_same_mark(Scheme_Object *obj)
 {
   Scheme_Object *v;
-  
+
   MZ_CONT_MARK_POS -= 2;
+  /* At this point, if the thread is swapped out and we attempt to get
+     the continuation marks of the thread, then MZ_CONT_MARK_POS may
+     be inconsistent with the first mark on the stack. We assume that
+     a thread swap will not happen until scheme_do_eval(), where
+     the first possibility for a swap is on stack overflow, and
+     in that case MZ_CONT_MARK_POS is adjusted back before overflow
+     handling (which can cause the thread to swap out). */
+
   v = force_values(obj, 1);
+
   MZ_CONT_MARK_POS += 2;
 
   return v;
@@ -1443,7 +1452,10 @@ scheme_force_one_value_same_mark(Scheme_Object *obj)
   Scheme_Object *v;
   
   MZ_CONT_MARK_POS -= 2;
+  /* See above about thread swaps */
+
   v = force_values(obj, 0);
+
   MZ_CONT_MARK_POS += 2;
 
   return v;